summaryrefslogtreecommitdiff
path: root/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp')
-rw-r--r--lisp/.arch-inventory4
-rw-r--r--lisp/ChangeLog8302
-rw-r--r--lisp/ChangeLog.167
-rw-r--r--lisp/ChangeLog.1026
-rw-r--r--lisp/ChangeLog.1134
-rw-r--r--lisp/ChangeLog.1268
-rw-r--r--lisp/ChangeLog.1326
-rw-r--r--lisp/ChangeLog.1438
-rw-r--r--lisp/ChangeLog.24
-rw-r--r--lisp/ChangeLog.38
-rw-r--r--lisp/ChangeLog.5102
-rw-r--r--lisp/ChangeLog.628
-rw-r--r--lisp/ChangeLog.74
-rw-r--r--lisp/ChangeLog.892
-rw-r--r--lisp/ChangeLog.9188
-rw-r--r--lisp/Makefile.in1424
-rw-r--r--lisp/abbrev.el20
-rw-r--r--lisp/abbrevlist.el1
-rw-r--r--lisp/allout.el387
-rw-r--r--lisp/ansi-color.el4
-rw-r--r--lisp/apropos.el1
-rw-r--r--lisp/arc-mode.el131
-rw-r--r--lisp/array.el53
-rw-r--r--lisp/autoinsert.el6
-rw-r--r--lisp/avoid.el3
-rw-r--r--lisp/bindings.el128
-rw-r--r--lisp/bookmark.el139
-rw-r--r--lisp/bs.el2
-rw-r--r--lisp/buff-menu.el11
-rw-r--r--lisp/button.el1
-rw-r--r--lisp/calc/.arch-inventory4
-rw-r--r--lisp/calc/README13
-rw-r--r--lisp/calc/calc-aent.el115
-rw-r--r--lisp/calc/calc-alg.el26
-rw-r--r--lisp/calc/calc-bin.el4
-rw-r--r--lisp/calc/calc-ext.el79
-rw-r--r--lisp/calc/calc-frac.el34
-rw-r--r--lisp/calc/calc-graph.el2
-rw-r--r--lisp/calc/calc-help.el8
-rw-r--r--lisp/calc/calc-incom.el6
-rw-r--r--lisp/calc/calc-keypd.el9
-rw-r--r--lisp/calc/calc-lang.el152
-rw-r--r--lisp/calc/calc-misc.el33
-rw-r--r--lisp/calc/calc-poly.el2
-rw-r--r--lisp/calc/calc-prog.el3
-rw-r--r--lisp/calc/calc-sel.el10
-rw-r--r--lisp/calc/calc-store.el14
-rw-r--r--lisp/calc/calc-trail.el28
-rw-r--r--lisp/calc/calc-units.el51
-rw-r--r--lisp/calc/calc-vec.el71
-rw-r--r--lisp/calc/calc-yank.el12
-rw-r--r--lisp/calc/calc.el64
-rw-r--r--lisp/calc/calcalg2.el14
-rw-r--r--lisp/calc/calccomp.el77
-rw-r--r--lisp/calculator.el2
-rw-r--r--lisp/calendar/.arch-inventory4
-rw-r--r--lisp/calendar/appt.el333
-rw-r--r--lisp/calendar/cal-bahai.el1
-rw-r--r--lisp/calendar/cal-china.el1
-rw-r--r--lisp/calendar/cal-coptic.el1
-rw-r--r--lisp/calendar/cal-dst.el1
-rw-r--r--lisp/calendar/cal-french.el22
-rw-r--r--lisp/calendar/cal-hebrew.el169
-rw-r--r--lisp/calendar/cal-html.el1
-rw-r--r--lisp/calendar/cal-islam.el1
-rw-r--r--lisp/calendar/cal-iso.el1
-rw-r--r--lisp/calendar/cal-julian.el1
-rw-r--r--lisp/calendar/cal-mayan.el1
-rw-r--r--lisp/calendar/cal-menu.el1
-rw-r--r--lisp/calendar/cal-move.el1
-rw-r--r--lisp/calendar/cal-persia.el1
-rw-r--r--lisp/calendar/cal-tex.el1
-rw-r--r--lisp/calendar/cal-x.el1
-rw-r--r--lisp/calendar/diary-lib.el290
-rw-r--r--lisp/calendar/holidays.el51
-rw-r--r--lisp/calendar/icalendar.el113
-rw-r--r--lisp/calendar/lunar.el1
-rw-r--r--lisp/calendar/parse-time.el1
-rw-r--r--lisp/calendar/solar.el1
-rw-r--r--lisp/calendar/time-date.el81
-rw-r--r--lisp/calendar/timeclock.el8
-rw-r--r--lisp/calendar/todo-mode.el14
-rw-r--r--lisp/case-table.el1
-rw-r--r--lisp/cedet/ChangeLog174
-rw-r--r--lisp/cedet/cedet-cscope.el1
-rw-r--r--lisp/cedet/cedet-files.el1
-rw-r--r--lisp/cedet/cedet-global.el1
-rw-r--r--lisp/cedet/cedet-idutils.el1
-rw-r--r--lisp/cedet/cedet.el2
-rw-r--r--lisp/cedet/data-debug.el1
-rw-r--r--lisp/cedet/ede.el8
-rw-r--r--lisp/cedet/ede/autoconf-edit.el8
-rw-r--r--lisp/cedet/ede/dired.el98
-rw-r--r--lisp/cedet/ede/pmake.el10
-rw-r--r--lisp/cedet/ede/proj-elisp.el23
-rw-r--r--lisp/cedet/ede/project-am.el2
-rw-r--r--lisp/cedet/ede/speedbar.el10
-rw-r--r--lisp/cedet/semantic/bovine/c.el24
-rw-r--r--lisp/cedet/semantic/decorate/mode.el86
-rw-r--r--lisp/cedet/semantic/ede-grammar.el11
-rw-r--r--lisp/cedet/semantic/grammar.el6
-rw-r--r--lisp/cedet/semantic/idle.el161
-rw-r--r--lisp/cedet/semantic/lex.el15
-rw-r--r--lisp/cedet/semantic/mru-bookmark.el71
-rw-r--r--lisp/cedet/semantic/symref.el3
-rw-r--r--lisp/cedet/semantic/symref/cscope.el3
-rw-r--r--lisp/cedet/semantic/tag-file.el3
-rw-r--r--lisp/cedet/semantic/util-modes.el603
-rw-r--r--lisp/cedet/semantic/wisent/comp.el12
-rw-r--r--lisp/cedet/srecode.el1
-rw-r--r--lisp/cedet/srecode/fields.el2
-rw-r--r--lisp/cedet/srecode/mode.el49
-rw-r--r--lisp/comint.el42
-rw-r--r--lisp/composite.el77
-rw-r--r--lisp/cus-dep.el1
-rw-r--r--lisp/cus-edit.el1314
-rw-r--r--lisp/cus-face.el66
-rw-r--r--lisp/cus-start.el156
-rw-r--r--lisp/cus-theme.el811
-rw-r--r--lisp/custom.el386
-rw-r--r--lisp/descr-text.el5
-rw-r--r--lisp/desktop.el5
-rw-r--r--lisp/dframe.el17
-rw-r--r--lisp/dired-aux.el22
-rw-r--r--lisp/dired-x.el32
-rw-r--r--lisp/dired.el132
-rw-r--r--lisp/dirtrack.el12
-rw-r--r--lisp/disp-table.el1
-rw-r--r--lisp/dnd.el1
-rw-r--r--lisp/doc-view.el4
-rw-r--r--lisp/dos-fns.el65
-rw-r--r--lisp/dos-vars.el1
-rw-r--r--lisp/dos-w32.el1
-rw-r--r--lisp/dynamic-setting.el (renamed from lisp/font-setting.el)39
-rw-r--r--lisp/ebuff-menu.el11
-rw-r--r--lisp/edmacro.el10
-rw-r--r--lisp/ehelp.el20
-rw-r--r--lisp/electric.el232
-rw-r--r--lisp/emacs-lisp/advice.el1
-rw-r--r--lisp/emacs-lisp/authors.el104
-rw-r--r--lisp/emacs-lisp/autoload.el215
-rw-r--r--lisp/emacs-lisp/backquote.el1
-rw-r--r--lisp/emacs-lisp/byte-opt.el95
-rw-r--r--lisp/emacs-lisp/byte-run.el2
-rw-r--r--lisp/emacs-lisp/bytecomp.el198
-rw-r--r--lisp/emacs-lisp/chart.el15
-rw-r--r--lisp/emacs-lisp/checkdoc.el345
-rw-r--r--lisp/emacs-lisp/cl-extra.el3
-rw-r--r--lisp/emacs-lisp/cl-indent.el1
-rw-r--r--lisp/emacs-lisp/cl-loaddefs.el24
-rw-r--r--lisp/emacs-lisp/cl-macs.el294
-rw-r--r--lisp/emacs-lisp/cl-seq.el13
-rw-r--r--lisp/emacs-lisp/cl-specs.el1
-rw-r--r--lisp/emacs-lisp/cl.el1
-rw-r--r--lisp/emacs-lisp/copyright.el22
-rw-r--r--lisp/emacs-lisp/debug.el2
-rw-r--r--lisp/emacs-lisp/derived.el3
-rw-r--r--lisp/emacs-lisp/easy-mmode.el84
-rw-r--r--lisp/emacs-lisp/easymenu.el4
-rw-r--r--lisp/emacs-lisp/edebug.el65
-rw-r--r--lisp/emacs-lisp/eieio-base.el1
-rw-r--r--lisp/emacs-lisp/eieio-comp.el22
-rw-r--r--lisp/emacs-lisp/eieio-custom.el1
-rw-r--r--lisp/emacs-lisp/eieio-datadebug.el1
-rw-r--r--lisp/emacs-lisp/eieio-opt.el1
-rw-r--r--lisp/emacs-lisp/eieio-speedbar.el1
-rw-r--r--lisp/emacs-lisp/eieio.el3
-rw-r--r--lisp/emacs-lisp/eldoc.el14
-rw-r--r--lisp/emacs-lisp/elint.el46
-rw-r--r--lisp/emacs-lisp/find-func.el12
-rw-r--r--lisp/emacs-lisp/find-gc.el2
-rw-r--r--lisp/emacs-lisp/float-sup.el24
-rw-r--r--lisp/emacs-lisp/generic.el1
-rw-r--r--lisp/emacs-lisp/helper.el1
-rw-r--r--lisp/emacs-lisp/lisp-mnt.el8
-rw-r--r--lisp/emacs-lisp/lisp-mode.el42
-rw-r--r--lisp/emacs-lisp/lisp.el94
-rw-r--r--lisp/emacs-lisp/macroexp.el139
-rw-r--r--lisp/emacs-lisp/package-x.el227
-rw-r--r--lisp/emacs-lisp/package.el1700
-rw-r--r--lisp/emacs-lisp/pcase.el553
-rw-r--r--lisp/emacs-lisp/re-builder.el25
-rw-r--r--lisp/emacs-lisp/regexp-opt.el13
-rw-r--r--lisp/emacs-lisp/shadow.el50
-rw-r--r--lisp/emacs-lisp/syntax.el282
-rw-r--r--lisp/emacs-lisp/tcover-ses.el1
-rw-r--r--lisp/emacs-lisp/tcover-unsafep.el1
-rw-r--r--lisp/emacs-lisp/timer.el50
-rw-r--r--lisp/emacs-lisp/warnings.el29
-rw-r--r--lisp/emulation/crisp.el8
-rw-r--r--lisp/emulation/cua-base.el74
-rw-r--r--lisp/emulation/cua-gmrk.el5
-rw-r--r--lisp/emulation/cua-rect.el13
-rw-r--r--lisp/emulation/edt-lk201.el1
-rw-r--r--lisp/emulation/edt-mapper.el1
-rw-r--r--lisp/emulation/edt-pc.el1
-rw-r--r--lisp/emulation/edt-vt100.el1
-rw-r--r--lisp/emulation/edt.el350
-rw-r--r--lisp/emulation/pc-select.el12
-rw-r--r--lisp/emulation/tpu-edt.el2
-rw-r--r--lisp/emulation/tpu-extras.el131
-rw-r--r--lisp/emulation/tpu-mapper.el1
-rw-r--r--lisp/emulation/vip.el16
-rw-r--r--lisp/emulation/viper-cmd.el66
-rw-r--r--lisp/emulation/viper-ex.el3
-rw-r--r--lisp/emulation/viper-init.el15
-rw-r--r--lisp/emulation/viper-keym.el1
-rw-r--r--lisp/emulation/viper-macs.el1
-rw-r--r--lisp/emulation/viper-mous.el1
-rw-r--r--lisp/emulation/viper-util.el6
-rw-r--r--lisp/emulation/viper.el1
-rw-r--r--lisp/emulation/ws-mode.el310
-rw-r--r--lisp/env.el1
-rw-r--r--lisp/epa-dired.el1
-rw-r--r--lisp/epa-file.el41
-rw-r--r--lisp/epa-hook.el1
-rw-r--r--lisp/epa-mail.el31
-rw-r--r--lisp/epa.el22
-rw-r--r--lisp/epg-config.el7
-rw-r--r--lisp/epg.el4
-rw-r--r--lisp/erc/ChangeLog40
-rw-r--r--lisp/erc/ChangeLog.034
-rw-r--r--lisp/erc/ChangeLog.042
-rw-r--r--lisp/erc/ChangeLog.062
-rw-r--r--lisp/erc/erc-backend.el20
-rw-r--r--lisp/erc/erc-join.el76
-rw-r--r--lisp/erc/erc-lang.el8
-rw-r--r--lisp/erc/erc-list.el21
-rw-r--r--lisp/erc/erc.el5
-rw-r--r--lisp/eshell/.arch-inventory4
-rw-r--r--lisp/eshell/em-alias.el6
-rw-r--r--lisp/eshell/em-banner.el4
-rw-r--r--lisp/eshell/em-basic.el2
-rw-r--r--lisp/eshell/em-cmpl.el10
-rw-r--r--lisp/eshell/em-dirs.el28
-rw-r--r--lisp/eshell/em-glob.el30
-rw-r--r--lisp/eshell/em-hist.el26
-rw-r--r--lisp/eshell/em-ls.el58
-rw-r--r--lisp/eshell/em-pred.el13
-rw-r--r--lisp/eshell/em-prompt.el12
-rw-r--r--lisp/eshell/em-rebind.el12
-rw-r--r--lisp/eshell/em-script.el40
-rw-r--r--lisp/eshell/em-smart.el12
-rw-r--r--lisp/eshell/em-term.el11
-rw-r--r--lisp/eshell/em-unix.el157
-rw-r--r--lisp/eshell/esh-arg.el37
-rw-r--r--lisp/eshell/esh-cmd.el42
-rw-r--r--lisp/eshell/esh-ext.el20
-rw-r--r--lisp/eshell/esh-io.el14
-rw-r--r--lisp/eshell/esh-mode.el34
-rw-r--r--lisp/eshell/esh-opt.el9
-rw-r--r--lisp/eshell/esh-proc.el26
-rw-r--r--lisp/eshell/esh-test.el18
-rw-r--r--lisp/eshell/esh-util.el80
-rw-r--r--lisp/eshell/esh-var.el16
-rw-r--r--lisp/eshell/eshell.el2
-rw-r--r--lisp/expand.el2
-rw-r--r--lisp/face-remap.el2
-rw-r--r--lisp/facemenu.el352
-rw-r--r--lisp/faces.el446
-rw-r--r--lisp/filecache.el7
-rw-r--r--lisp/files-x.el1
-rw-r--r--lisp/files.el405
-rw-r--r--lisp/filesets.el2
-rw-r--r--lisp/find-dired.el2
-rw-r--r--lisp/finder.el282
-rw-r--r--lisp/foldout.el2
-rw-r--r--lisp/font-core.el18
-rw-r--r--lisp/font-lock.el193
-rw-r--r--lisp/format-spec.el1
-rw-r--r--lisp/format.el1
-rw-r--r--lisp/forms.el4
-rw-r--r--lisp/frame.el249
-rw-r--r--lisp/fringe.el70
-rw-r--r--lisp/generic-x.el1
-rw-r--r--lisp/gnus/.dir-locals.el4
-rw-r--r--lisp/gnus/ChangeLog5592
-rw-r--r--lisp/gnus/ChangeLog.120
-rw-r--r--lisp/gnus/ChangeLog.244
-rw-r--r--lisp/gnus/auth-source.el460
-rw-r--r--lisp/gnus/canlock.el1
-rw-r--r--lisp/gnus/color.el268
-rw-r--r--lisp/gnus/compface.el1
-rw-r--r--lisp/gnus/deuglify.el1
-rw-r--r--lisp/gnus/earcon.el233
-rw-r--r--lisp/gnus/ecomplete.el18
-rw-r--r--lisp/gnus/flow-fill.el4
-rw-r--r--lisp/gnus/gmm-utils.el46
-rw-r--r--lisp/gnus/gnus-agent.el149
-rw-r--r--lisp/gnus/gnus-art.el831
-rw-r--r--lisp/gnus/gnus-async.el32
-rw-r--r--lisp/gnus/gnus-audio.el150
-rw-r--r--lisp/gnus/gnus-bcklg.el19
-rw-r--r--lisp/gnus/gnus-bookmark.el20
-rw-r--r--lisp/gnus/gnus-cache.el33
-rw-r--r--lisp/gnus/gnus-cite.el193
-rw-r--r--lisp/gnus/gnus-cus.el8
-rw-r--r--lisp/gnus/gnus-delay.el4
-rw-r--r--lisp/gnus/gnus-demon.el234
-rw-r--r--lisp/gnus/gnus-diary.el9
-rw-r--r--lisp/gnus/gnus-dired.el61
-rw-r--r--lisp/gnus/gnus-draft.el48
-rw-r--r--lisp/gnus/gnus-dup.el1
-rw-r--r--lisp/gnus/gnus-eform.el1
-rw-r--r--lisp/gnus/gnus-ems.el147
-rw-r--r--lisp/gnus/gnus-fun.el3
-rw-r--r--lisp/gnus/gnus-gravatar.el138
-rw-r--r--lisp/gnus/gnus-group.el762
-rw-r--r--lisp/gnus/gnus-html.el526
-rw-r--r--lisp/gnus/gnus-int.el189
-rw-r--r--lisp/gnus/gnus-kill.el15
-rw-r--r--lisp/gnus/gnus-logic.el4
-rw-r--r--lisp/gnus/gnus-mh.el1
-rw-r--r--lisp/gnus/gnus-ml.el57
-rw-r--r--lisp/gnus/gnus-mlspl.el1
-rw-r--r--lisp/gnus/gnus-move.el181
-rw-r--r--lisp/gnus/gnus-msg.el40
-rw-r--r--lisp/gnus/gnus-nocem.el453
-rw-r--r--lisp/gnus/gnus-picon.el28
-rw-r--r--lisp/gnus/gnus-range.el37
-rw-r--r--lisp/gnus/gnus-registry.el184
-rw-r--r--lisp/gnus/gnus-salt.el298
-rw-r--r--lisp/gnus/gnus-score.el75
-rw-r--r--lisp/gnus/gnus-setup.el1
-rw-r--r--lisp/gnus/gnus-sieve.el1
-rw-r--r--lisp/gnus/gnus-soup.el611
-rw-r--r--lisp/gnus/gnus-spec.el5
-rw-r--r--lisp/gnus/gnus-srvr.el96
-rw-r--r--lisp/gnus/gnus-start.el560
-rw-r--r--lisp/gnus/gnus-sum.el1329
-rw-r--r--lisp/gnus/gnus-sync.el240
-rw-r--r--lisp/gnus/gnus-topic.el37
-rw-r--r--lisp/gnus/gnus-undo.el39
-rw-r--r--lisp/gnus/gnus-util.el420
-rw-r--r--lisp/gnus/gnus-uu.el70
-rw-r--r--lisp/gnus/gnus-vm.el1
-rw-r--r--lisp/gnus/gnus-win.el22
-rw-r--r--lisp/gnus/gnus.el499
-rw-r--r--lisp/gnus/gravatar.el133
-rw-r--r--lisp/gnus/html2text.el2
-rw-r--r--lisp/gnus/ietf-drums.el2
-rw-r--r--lisp/gnus/legacy-gnus-agent.el1
-rw-r--r--lisp/gnus/mail-parse.el4
-rw-r--r--lisp/gnus/mail-prsvr.el1
-rw-r--r--lisp/gnus/mail-source.el110
-rw-r--r--lisp/gnus/mailcap.el14
-rw-r--r--lisp/gnus/message.el315
-rw-r--r--lisp/gnus/messcompat.el1
-rw-r--r--lisp/gnus/mm-bodies.el3
-rw-r--r--lisp/gnus/mm-decode.el169
-rw-r--r--lisp/gnus/mm-encode.el14
-rw-r--r--lisp/gnus/mm-extern.el11
-rw-r--r--lisp/gnus/mm-partial.el7
-rw-r--r--lisp/gnus/mm-url.el80
-rw-r--r--lisp/gnus/mm-util.el187
-rw-r--r--lisp/gnus/mm-uu.el5
-rw-r--r--lisp/gnus/mm-view.el66
-rw-r--r--lisp/gnus/mml-sec.el19
-rw-r--r--lisp/gnus/mml-smime.el37
-rw-r--r--lisp/gnus/mml.el114
-rw-r--r--lisp/gnus/mml1991.el108
-rw-r--r--lisp/gnus/mml2015.el410
-rw-r--r--lisp/gnus/nnagent.el12
-rw-r--r--lisp/gnus/nnbabyl.el55
-rw-r--r--lisp/gnus/nndb.el325
-rw-r--r--lisp/gnus/nndiary.el54
-rw-r--r--lisp/gnus/nndir.el1
-rw-r--r--lisp/gnus/nndoc.el140
-rw-r--r--lisp/gnus/nndraft.el24
-rw-r--r--lisp/gnus/nneething.el16
-rw-r--r--lisp/gnus/nnfolder.el64
-rw-r--r--lisp/gnus/nngateway.el1
-rw-r--r--lisp/gnus/nnheader.el59
-rw-r--r--lisp/gnus/nnimap.el3463
-rw-r--r--lisp/gnus/nnir.el1115
-rw-r--r--lisp/gnus/nnkiboze.el391
-rw-r--r--lisp/gnus/nnlistserv.el152
-rw-r--r--lisp/gnus/nnmail.el160
-rw-r--r--lisp/gnus/nnmaildir.el27
-rw-r--r--lisp/gnus/nnmairix.el187
-rw-r--r--lisp/gnus/nnmbox.el31
-rw-r--r--lisp/gnus/nnmh.el84
-rw-r--r--lisp/gnus/nnml.el185
-rw-r--r--lisp/gnus/nnnil.el7
-rw-r--r--lisp/gnus/nnoo.el1
-rw-r--r--lisp/gnus/nnregistry.el66
-rw-r--r--lisp/gnus/nnrss.el167
-rw-r--r--lisp/gnus/nnslashdot.el505
-rw-r--r--lisp/gnus/nnsoup.el812
-rw-r--r--lisp/gnus/nnspool.el33
-rw-r--r--lisp/gnus/nntp.el79
-rw-r--r--lisp/gnus/nnultimate.el480
-rw-r--r--lisp/gnus/nnvirtual.el37
-rw-r--r--lisp/gnus/nnwarchive.el727
-rw-r--r--lisp/gnus/nnweb.el31
-rw-r--r--lisp/gnus/nnwfm.el432
-rw-r--r--lisp/gnus/pop3.el193
-rw-r--r--lisp/gnus/qp.el1
-rw-r--r--lisp/gnus/rfc1843.el4
-rw-r--r--lisp/gnus/rfc2045.el1
-rw-r--r--lisp/gnus/rfc2047.el41
-rw-r--r--lisp/gnus/rfc2104.el1
-rw-r--r--lisp/gnus/rfc2231.el19
-rw-r--r--lisp/gnus/score-mode.el1
-rw-r--r--lisp/gnus/shr-color.el361
-rw-r--r--lisp/gnus/shr.el1104
-rw-r--r--lisp/gnus/sieve-manage.el268
-rw-r--r--lisp/gnus/sieve-mode.el7
-rw-r--r--lisp/gnus/sieve.el12
-rw-r--r--lisp/gnus/smiley.el5
-rw-r--r--lisp/gnus/smime.el75
-rw-r--r--lisp/gnus/spam-report.el14
-rw-r--r--lisp/gnus/spam-stat.el6
-rw-r--r--lisp/gnus/spam-wash.el1
-rw-r--r--lisp/gnus/spam.el36
-rw-r--r--lisp/gnus/starttls.el5
-rw-r--r--lisp/gnus/utf7.el8
-rw-r--r--lisp/gnus/webmail.el1152
-rw-r--r--lisp/gnus/yenc.el6
-rw-r--r--lisp/help-fns.el122
-rw-r--r--lisp/help-macro.el1
-rw-r--r--lisp/help-mode.el38
-rw-r--r--lisp/help.el13
-rw-r--r--lisp/hex-util.el1
-rw-r--r--lisp/hexl.el222
-rw-r--r--lisp/hfy-cmap.el11
-rw-r--r--lisp/hilit-chg.el25
-rw-r--r--lisp/hippie-exp.el4
-rw-r--r--lisp/hl-line.el2
-rw-r--r--lisp/htmlfontify.el65
-rw-r--r--lisp/ibuf-ext.el30
-rw-r--r--lisp/ibuf-macs.el1
-rw-r--r--lisp/ibuffer.el12
-rw-r--r--lisp/icomplete.el3
-rw-r--r--lisp/ido.el92
-rw-r--r--lisp/iimage.el118
-rw-r--r--lisp/image-dired.el45
-rw-r--r--lisp/image-mode.el123
-rw-r--r--lisp/image.el146
-rw-r--r--lisp/imenu.el2
-rw-r--r--lisp/indent.el10
-rw-r--r--lisp/info.el272
-rw-r--r--lisp/international/characters.el164
-rw-r--r--lisp/international/charprop.el2
-rw-r--r--lisp/international/fontset.el2
-rw-r--r--lisp/international/iso-ascii.el19
-rw-r--r--lisp/international/kkc.el6
-rw-r--r--lisp/international/mule-cmds.el29
-rw-r--r--lisp/international/mule.el110
-rw-r--r--lisp/international/ogonek.el10
-rw-r--r--lisp/international/quail.el2
-rw-r--r--lisp/international/ucs-normalize.el2
-rw-r--r--lisp/international/uni-bidi.elbin8707 -> 9287 bytes
-rw-r--r--lisp/international/uni-category.elbin11749 -> 12450 bytes
-rw-r--r--lisp/international/uni-combining.elbin8333 -> 8881 bytes
-rw-r--r--lisp/international/uni-comment.elbin2270 -> 2276 bytes
-rw-r--r--lisp/international/uni-decimal.elbin2389 -> 2483 bytes
-rw-r--r--lisp/international/uni-decomposition.elbin27731 -> 27823 bytes
-rw-r--r--lisp/international/uni-digit.elbin2683 -> 2790 bytes
-rw-r--r--lisp/international/uni-lowercase.elbin5336 -> 5387 bytes
-rw-r--r--lisp/international/uni-mirrored.elbin7383 -> 7904 bytes
-rw-r--r--lisp/international/uni-name.elbin140890 -> 157287 bytes
-rw-r--r--lisp/international/uni-numeric.elbin4134 -> 4258 bytes
-rw-r--r--lisp/international/uni-old-name.elbin19332 -> 19338 bytes
-rw-r--r--lisp/international/uni-titlecase.elbin5425 -> 5477 bytes
-rw-r--r--lisp/international/uni-uppercase.elbin5421 -> 5473 bytes
-rw-r--r--lisp/international/utf-7.el2
-rw-r--r--lisp/isearch.el60
-rw-r--r--lisp/iswitchb.el30
-rw-r--r--lisp/jit-lock.el27
-rw-r--r--lisp/jka-cmpr-hook.el4
-rw-r--r--lisp/jka-compr.el12
-rw-r--r--lisp/kmacro.el12
-rw-r--r--lisp/language/ethio-util.el2
-rw-r--r--lisp/language/hebrew.el188
-rw-r--r--lisp/language/misc-lang.el18
-rw-r--r--lisp/language/tai-viet.el10
-rw-r--r--lisp/language/tv-util.el3
-rw-r--r--lisp/ldefs-boot.el3289
-rw-r--r--lisp/linum.el1
-rw-r--r--lisp/loadup.el30
-rw-r--r--lisp/locate.el4
-rw-r--r--lisp/lpr.el2
-rw-r--r--lisp/ls-lisp.el91
-rw-r--r--lisp/macros.el1
-rw-r--r--lisp/mail/binhex.el4
-rw-r--r--lisp/mail/blessmail.el1
-rw-r--r--lisp/mail/emacsbug.el193
-rw-r--r--lisp/mail/feedmail.el100
-rw-r--r--lisp/mail/hashcash.el20
-rw-r--r--lisp/mail/mail-extr.el53
-rw-r--r--lisp/mail/mail-hist.el1
-rw-r--r--lisp/mail/mailclient.el6
-rw-r--r--lisp/mail/mailheader.el12
-rw-r--r--lisp/mail/metamail.el1
-rw-r--r--lisp/mail/mspools.el43
-rw-r--r--lisp/mail/rfc2368.el8
-rw-r--r--lisp/mail/rmail-spam-filter.el1
-rw-r--r--lisp/mail/rmail.el28
-rw-r--r--lisp/mail/rmailedit.el1
-rw-r--r--lisp/mail/rmailkwd.el1
-rw-r--r--lisp/mail/rmailmm.el1
-rw-r--r--lisp/mail/rmailmsc.el1
-rw-r--r--lisp/mail/rmailout.el1
-rw-r--r--lisp/mail/rmailsort.el1
-rw-r--r--lisp/mail/rmailsum.el1
-rw-r--r--lisp/mail/sendmail.el148
-rw-r--r--lisp/mail/supercite.el36
-rw-r--r--lisp/mail/uudecode.el3
-rw-r--r--lisp/makefile.w32-in74
-rw-r--r--lisp/makesum.el7
-rw-r--r--lisp/man.el74
-rw-r--r--lisp/md4.el1
-rw-r--r--lisp/menu-bar.el237
-rw-r--r--lisp/mh-e/.arch-inventory4
-rw-r--r--lisp/mh-e/ChangeLog40
-rw-r--r--lisp/mh-e/ChangeLog.1100
-rw-r--r--lisp/mh-e/mh-alias.el2
-rw-r--r--lisp/mh-e/mh-comp.el3
-rw-r--r--lisp/mh-e/mh-e.el6
-rw-r--r--lisp/mh-e/mh-mime.el22
-rw-r--r--lisp/mh-e/mh-search.el2
-rw-r--r--lisp/mh-e/mh-seq.el8
-rw-r--r--lisp/mh-e/mh-show.el10
-rw-r--r--lisp/midnight.el6
-rw-r--r--lisp/minibuffer.el324
-rw-r--r--lisp/misc.el8
-rw-r--r--lisp/mouse-drag.el7
-rw-r--r--lisp/mouse-sel.el20
-rw-r--r--lisp/mouse.el1147
-rw-r--r--lisp/mpc.el128
-rw-r--r--lisp/mwheel.el3
-rw-r--r--lisp/net/ange-ftp.el26
-rw-r--r--lisp/net/browse-url.el127
-rw-r--r--lisp/net/dbus.el120
-rw-r--r--lisp/net/dig.el12
-rw-r--r--lisp/net/dns.el13
-rw-r--r--lisp/net/eudc-bob.el1
-rw-r--r--lisp/net/eudc-export.el1
-rw-r--r--lisp/net/eudc-hotlist.el22
-rw-r--r--lisp/net/eudc-vars.el45
-rw-r--r--lisp/net/eudc.el6
-rw-r--r--lisp/net/eudcb-bbdb.el1
-rw-r--r--lisp/net/eudcb-ldap.el1
-rw-r--r--lisp/net/eudcb-mab.el1
-rw-r--r--lisp/net/eudcb-ph.el1
-rw-r--r--lisp/net/gnutls.el115
-rw-r--r--lisp/net/goto-addr.el2
-rw-r--r--lisp/net/hmac-def.el5
-rw-r--r--lisp/net/hmac-md5.el3
-rw-r--r--lisp/net/imap.el93
-rw-r--r--lisp/net/ldap.el27
-rw-r--r--lisp/net/mairix.el32
-rw-r--r--lisp/net/net-utils.el6
-rw-r--r--lisp/net/netrc.el78
-rw-r--r--lisp/net/newst-backend.el1
-rw-r--r--lisp/net/newst-plainview.el1
-rw-r--r--lisp/net/newst-reader.el1
-rw-r--r--lisp/net/newst-ticker.el1
-rw-r--r--lisp/net/newst-treeview.el1
-rw-r--r--lisp/net/newsticker.el1
-rw-r--r--lisp/net/ntlm.el7
-rw-r--r--lisp/net/quickurl.el39
-rw-r--r--lisp/net/rcirc.el193
-rw-r--r--lisp/net/rcompile.el12
-rw-r--r--lisp/net/rlogin.el19
-rw-r--r--lisp/net/sasl-cram.el2
-rw-r--r--lisp/net/sasl-digest.el6
-rw-r--r--lisp/net/sasl-ntlm.el2
-rw-r--r--lisp/net/sasl.el1
-rw-r--r--lisp/net/secrets.el862
-rw-r--r--lisp/net/telnet.el20
-rw-r--r--lisp/net/tls.el9
-rw-r--r--lisp/net/tramp-cache.el180
-rw-r--r--lisp/net/tramp-cmds.el107
-rw-r--r--lisp/net/tramp-compat.el167
-rw-r--r--lisp/net/tramp-fish.el1180
-rw-r--r--lisp/net/tramp-ftp.el33
-rw-r--r--lisp/net/tramp-gvfs.el55
-rw-r--r--lisp/net/tramp-gw.el41
-rw-r--r--lisp/net/tramp-imap.el68
-rw-r--r--lisp/net/tramp-sh.el5040
-rw-r--r--lisp/net/tramp-smb.el70
-rw-r--r--lisp/net/tramp-uu.el6
-rw-r--r--lisp/net/tramp.el6992
-rw-r--r--lisp/net/trampver.el19
-rw-r--r--lisp/net/xesam.el2
-rw-r--r--lisp/newcomment.el15
-rw-r--r--lisp/notifications.el294
-rw-r--r--lisp/nxml/TODO468
-rw-r--r--lisp/nxml/nxml-maint.el6
-rw-r--r--lisp/nxml/nxml-mode.el31
-rw-r--r--lisp/obsolete/cl-compat.el9
-rw-r--r--lisp/obsolete/complete.el (renamed from lisp/complete.el)4
-rw-r--r--lisp/obsolete/lazy-lock.el30
-rw-r--r--lisp/obsolete/lucid.el13
-rw-r--r--lisp/obsolete/old-whitespace.el5
-rw-r--r--lisp/obsolete/rnews.el981
-rw-r--r--lisp/obsolete/rnewspost.el447
-rw-r--r--lisp/obsolete/s-region.el (renamed from lisp/s-region.el)1
-rw-r--r--lisp/obsolete/sc.el19
-rw-r--r--lisp/obsolete/vc-mcvs.el5
-rw-r--r--lisp/obsolete/x-menu.el153
-rw-r--r--lisp/org/ChangeLog6029
-rw-r--r--lisp/org/ob-C.el194
-rw-r--r--lisp/org/ob-R.el302
-rw-r--r--lisp/org/ob-asymptote.el164
-rw-r--r--lisp/org/ob-calc.el67
-rw-r--r--lisp/org/ob-clojure.el318
-rw-r--r--lisp/org/ob-comint.el163
-rw-r--r--lisp/org/ob-css.el49
-rw-r--r--lisp/org/ob-ditaa.el74
-rw-r--r--lisp/org/ob-dot.el90
-rw-r--r--lisp/org/ob-emacs-lisp.el71
-rw-r--r--lisp/org/ob-eval.el254
-rw-r--r--lisp/org/ob-exp.el328
-rw-r--r--lisp/org/ob-gnuplot.el235
-rw-r--r--lisp/org/ob-haskell.el226
-rw-r--r--lisp/org/ob-js.el163
-rw-r--r--lisp/org/ob-keys.el98
-rw-r--r--lisp/org/ob-latex.el180
-rw-r--r--lisp/org/ob-ledger.el72
-rw-r--r--lisp/org/ob-lisp.el108
-rw-r--r--lisp/org/ob-lob.el121
-rw-r--r--lisp/org/ob-matlab.el48
-rw-r--r--lisp/org/ob-mscgen.el86
-rw-r--r--lisp/org/ob-ocaml.el157
-rw-r--r--lisp/org/ob-octave.el264
-rw-r--r--lisp/org/ob-org.el62
-rw-r--r--lisp/org/ob-perl.el118
-rw-r--r--lisp/org/ob-plantuml.el83
-rw-r--r--lisp/org/ob-python.el289
-rw-r--r--lisp/org/ob-ref.el233
-rw-r--r--lisp/org/ob-ruby.el248
-rw-r--r--lisp/org/ob-sass.el69
-rw-r--r--lisp/org/ob-scheme.el137
-rw-r--r--lisp/org/ob-screen.el147
-rw-r--r--lisp/org/ob-sh.el180
-rw-r--r--lisp/org/ob-sql.el94
-rw-r--r--lisp/org/ob-sqlite.el152
-rw-r--r--lisp/org/ob-table.el125
-rw-r--r--lisp/org/ob-tangle.el453
-rw-r--r--lisp/org/ob.el1886
-rw-r--r--lisp/org/org-agenda.el1359
-rw-r--r--lisp/org/org-archive.el30
-rw-r--r--lisp/org/org-ascii.el160
-rw-r--r--lisp/org/org-attach.el24
-rw-r--r--lisp/org/org-bbdb.el11
-rw-r--r--lisp/org/org-beamer.el636
-rw-r--r--lisp/org/org-bibtex.el2
-rw-r--r--lisp/org/org-capture.el1362
-rw-r--r--lisp/org/org-clock.el628
-rw-r--r--lisp/org/org-colview.el163
-rw-r--r--lisp/org/org-compat.el236
-rw-r--r--lisp/org/org-crypt.el122
-rw-r--r--lisp/org/org-ctags.el541
-rw-r--r--lisp/org/org-datetree.el9
-rw-r--r--lisp/org/org-docbook.el284
-rw-r--r--lisp/org/org-docview.el93
-rw-r--r--lisp/org/org-entities.el573
-rw-r--r--lisp/org/org-exp-blocks.el115
-rw-r--r--lisp/org/org-exp.el1200
-rw-r--r--lisp/org/org-faces.el115
-rw-r--r--lisp/org/org-feed.el113
-rw-r--r--lisp/org/org-footnote.el71
-rw-r--r--lisp/org/org-freemind.el352
-rw-r--r--lisp/org/org-gnus.el118
-rw-r--r--lisp/org/org-habit.el50
-rw-r--r--lisp/org/org-html.el964
-rw-r--r--lisp/org/org-icalendar.el117
-rw-r--r--lisp/org/org-id.el70
-rw-r--r--lisp/org/org-indent.el121
-rw-r--r--lisp/org/org-info.el2
-rw-r--r--lisp/org/org-inlinetask.el68
-rw-r--r--lisp/org/org-irc.el2
-rw-r--r--lisp/org/org-jsinfo.el8
-rw-r--r--lisp/org/org-latex.el1012
-rw-r--r--lisp/org/org-list.el2824
-rw-r--r--lisp/org/org-mac-message.el14
-rw-r--r--lisp/org/org-macs.el60
-rw-r--r--lisp/org/org-mew.el14
-rw-r--r--lisp/org/org-mhe.el23
-rw-r--r--lisp/org/org-mks.el137
-rw-r--r--lisp/org/org-mobile.el293
-rw-r--r--lisp/org/org-mouse.el71
-rw-r--r--lisp/org/org-plot.el16
-rw-r--r--lisp/org/org-protocol.el159
-rw-r--r--lisp/org/org-publish.el702
-rw-r--r--lisp/org/org-remember.el160
-rw-r--r--lisp/org/org-rmail.el12
-rw-r--r--lisp/org/org-src.el398
-rw-r--r--lisp/org/org-table.el538
-rw-r--r--lisp/org/org-taskjuggler.el648
-rw-r--r--lisp/org/org-timer.el198
-rw-r--r--lisp/org/org-vm.el12
-rw-r--r--lisp/org/org-w3m.el17
-rw-r--r--lisp/org/org-wl.el302
-rw-r--r--lisp/org/org-xoxo.el8
-rw-r--r--lisp/org/org.el4387
-rw-r--r--lisp/outline.el15
-rw-r--r--lisp/paren.el4
-rw-r--r--lisp/password-cache.el11
-rw-r--r--lisp/paths.el1
-rw-r--r--lisp/pcmpl-cvs.el1
-rw-r--r--lisp/pcmpl-gnu.el2
-rw-r--r--lisp/pcmpl-linux.el2
-rw-r--r--lisp/pcmpl-rpm.el2
-rw-r--r--lisp/pcmpl-unix.el2
-rw-r--r--lisp/pcomplete.el27
-rw-r--r--lisp/pgg-def.el2
-rw-r--r--lisp/pgg-gpg.el4
-rw-r--r--lisp/pgg-parse.el7
-rw-r--r--lisp/pgg-pgp.el2
-rw-r--r--lisp/pgg-pgp5.el2
-rw-r--r--lisp/pgg.el72
-rw-r--r--lisp/play/5x5.el10
-rw-r--r--lisp/play/decipher.el66
-rw-r--r--lisp/play/doctor.el1397
-rw-r--r--lisp/play/gametree.el3
-rw-r--r--lisp/play/gomoku.el177
-rw-r--r--lisp/play/landmark.el236
-rw-r--r--lisp/play/life.el7
-rw-r--r--lisp/play/mpuz.el51
-rw-r--r--lisp/play/tetris.el305
-rw-r--r--lisp/play/zone.el59
-rw-r--r--lisp/printing.el17
-rw-r--r--lisp/progmodes/ada-mode.el662
-rw-r--r--lisp/progmodes/ada-prj.el17
-rw-r--r--lisp/progmodes/ada-stmt.el1
-rw-r--r--lisp/progmodes/ada-xref.el42
-rw-r--r--lisp/progmodes/antlr-mode.el2
-rw-r--r--lisp/progmodes/asm-mode.el12
-rw-r--r--lisp/progmodes/autoconf.el7
-rw-r--r--lisp/progmodes/bug-reference.el29
-rw-r--r--lisp/progmodes/cc-align.el4
-rw-r--r--lisp/progmodes/cc-awk.el21
-rw-r--r--lisp/progmodes/cc-bytecomp.el4
-rw-r--r--lisp/progmodes/cc-cmds.el208
-rw-r--r--lisp/progmodes/cc-compat.el4
-rw-r--r--lisp/progmodes/cc-defs.el152
-rw-r--r--lisp/progmodes/cc-engine.el1981
-rw-r--r--lisp/progmodes/cc-fonts.el371
-rw-r--r--lisp/progmodes/cc-langs.el120
-rw-r--r--lisp/progmodes/cc-menus.el4
-rw-r--r--lisp/progmodes/cc-mode.el167
-rw-r--r--lisp/progmodes/cc-styles.el7
-rw-r--r--lisp/progmodes/cc-vars.el30
-rw-r--r--lisp/progmodes/cfengine.el20
-rw-r--r--lisp/progmodes/compile.el106
-rw-r--r--lisp/progmodes/cperl-mode.el96
-rw-r--r--lisp/progmodes/cwarn.el2
-rw-r--r--lisp/progmodes/dcl-mode.el17
-rw-r--r--lisp/progmodes/delphi.el39
-rw-r--r--lisp/progmodes/ebnf-abn.el1
-rw-r--r--lisp/progmodes/ebnf-bnf.el1
-rw-r--r--lisp/progmodes/ebnf-dtd.el1
-rw-r--r--lisp/progmodes/ebnf-ebx.el1
-rw-r--r--lisp/progmodes/ebnf-iso.el1
-rw-r--r--lisp/progmodes/ebnf-otz.el1
-rw-r--r--lisp/progmodes/ebnf-yac.el1
-rw-r--r--lisp/progmodes/ebnf2ps.el7
-rw-r--r--lisp/progmodes/ebrowse.el9
-rw-r--r--lisp/progmodes/etags.el72
-rw-r--r--lisp/progmodes/f90.el16
-rw-r--r--lisp/progmodes/flymake.el15
-rw-r--r--lisp/progmodes/fortran.el87
-rw-r--r--lisp/progmodes/gdb-mi.el4195
-rw-r--r--lisp/progmodes/gdb-ui.el4158
-rw-r--r--lisp/progmodes/grep.el17
-rw-r--r--lisp/progmodes/gud.el237
-rw-r--r--lisp/progmodes/hideif.el5
-rw-r--r--lisp/progmodes/icon.el7
-rw-r--r--lisp/progmodes/idlw-complete-structtag.el15
-rw-r--r--lisp/progmodes/idlw-help.el45
-rw-r--r--lisp/progmodes/idlw-shell.el27
-rw-r--r--lisp/progmodes/idlw-toolbar.el3
-rw-r--r--lisp/progmodes/idlwave.el137
-rw-r--r--lisp/progmodes/inf-lisp.el24
-rw-r--r--lisp/progmodes/js.el126
-rw-r--r--lisp/progmodes/ld-script.el22
-rw-r--r--lisp/progmodes/make-mode.el153
-rw-r--r--lisp/progmodes/meta-mode.el42
-rw-r--r--lisp/progmodes/mixal-mode.el30
-rw-r--r--lisp/progmodes/modula2.el607
-rw-r--r--lisp/progmodes/octave-inf.el1
-rw-r--r--lisp/progmodes/octave-mod.el1086
-rw-r--r--lisp/progmodes/pascal.el158
-rw-r--r--lisp/progmodes/perl-mode.el346
-rw-r--r--lisp/progmodes/prolog.el170
-rw-r--r--lisp/progmodes/ps-mode.el60
-rw-r--r--lisp/progmodes/python.el80
-rw-r--r--lisp/progmodes/ruby-mode.el404
-rw-r--r--lisp/progmodes/scheme.el2
-rw-r--r--lisp/progmodes/sh-script.el252
-rw-r--r--lisp/progmodes/simula.el37
-rw-r--r--lisp/progmodes/sql.el2973
-rw-r--r--lisp/progmodes/subword.el2
-rw-r--r--lisp/progmodes/tcl.el19
-rw-r--r--lisp/progmodes/vera-mode.el3
-rw-r--r--lisp/progmodes/verilog-mode.el31
-rw-r--r--lisp/progmodes/vhdl-mode.el128
-rw-r--r--lisp/progmodes/xscheme.el8
-rw-r--r--lisp/ps-bdf.el1
-rw-r--r--lisp/ps-def.el71
-rw-r--r--lisp/ps-mule.el1
-rw-r--r--lisp/ps-print.el12
-rw-r--r--lisp/ps-samp.el1
-rw-r--r--lisp/rect.el1
-rw-r--r--lisp/register.el1
-rw-r--r--lisp/repeat.el2
-rw-r--r--lisp/replace.el268
-rw-r--r--lisp/reposition.el7
-rw-r--r--lisp/reveal.el2
-rw-r--r--lisp/rfn-eshadow.el1
-rw-r--r--lisp/ruler-mode.el35
-rw-r--r--lisp/savehist.el25
-rw-r--r--lisp/scroll-all.el4
-rw-r--r--lisp/scroll-bar.el23
-rw-r--r--lisp/select.el56
-rw-r--r--lisp/server.el95
-rw-r--r--lisp/sha1.el3
-rw-r--r--lisp/shell.el87
-rw-r--r--lisp/simple.el823
-rw-r--r--lisp/skeleton.el61
-rw-r--r--lisp/sort.el13
-rw-r--r--lisp/speedbar.el69
-rw-r--r--lisp/startup.el207
-rw-r--r--lisp/subr.el308
-rw-r--r--lisp/tabify.el1
-rw-r--r--lisp/tar-mode.el33
-rw-r--r--lisp/term.el45
-rw-r--r--lisp/term/common-win.el463
-rw-r--r--lisp/term/ns-win.el481
-rw-r--r--lisp/term/pc-win.el51
-rw-r--r--lisp/term/tty-colors.el10
-rw-r--r--lisp/term/tvi970.el13
-rw-r--r--lisp/term/vt100.el14
-rw-r--r--lisp/term/w32-win.el17
-rw-r--r--lisp/term/w32console.el4
-rw-r--r--lisp/term/x-win.el203
-rw-r--r--lisp/textmodes/artist.el27
-rw-r--r--lisp/textmodes/bibtex-style.el5
-rw-r--r--lisp/textmodes/bibtex.el6
-rw-r--r--lisp/textmodes/css-mode.el12
-rw-r--r--lisp/textmodes/dns-mode.el8
-rw-r--r--lisp/textmodes/enriched.el6
-rw-r--r--lisp/textmodes/fill.el33
-rw-r--r--lisp/textmodes/flyspell.el80
-rw-r--r--lisp/textmodes/ispell.el616
-rw-r--r--lisp/textmodes/makeinfo.el8
-rw-r--r--lisp/textmodes/nroff-mode.el21
-rw-r--r--lisp/textmodes/page-ext.el23
-rw-r--r--lisp/textmodes/page.el1
-rw-r--r--lisp/textmodes/paragraphs.el1
-rw-r--r--lisp/textmodes/picture.el19
-rw-r--r--lisp/textmodes/refer.el10
-rw-r--r--lisp/textmodes/reftex-auc.el3
-rw-r--r--lisp/textmodes/reftex-cite.el51
-rw-r--r--lisp/textmodes/reftex-dcr.el1
-rw-r--r--lisp/textmodes/reftex-global.el1
-rw-r--r--lisp/textmodes/reftex-index.el4
-rw-r--r--lisp/textmodes/reftex-parse.el16
-rw-r--r--lisp/textmodes/reftex-ref.el57
-rw-r--r--lisp/textmodes/reftex-sel.el75
-rw-r--r--lisp/textmodes/reftex-toc.el54
-rw-r--r--lisp/textmodes/reftex-vars.el1
-rw-r--r--lisp/textmodes/reftex.el41
-rw-r--r--lisp/textmodes/remember.el14
-rw-r--r--lisp/textmodes/rst.el349
-rw-r--r--lisp/textmodes/sgml-mode.el27
-rw-r--r--lisp/textmodes/spell.el8
-rw-r--r--lisp/textmodes/table.el107
-rw-r--r--lisp/textmodes/tex-mode.el221
-rw-r--r--lisp/textmodes/texinfmt.el56
-rw-r--r--lisp/textmodes/texinfo.el15
-rw-r--r--lisp/textmodes/texnfo-upd.el64
-rw-r--r--lisp/textmodes/text-mode.el3
-rw-r--r--lisp/textmodes/two-column.el10
-rw-r--r--lisp/time.el34
-rw-r--r--lisp/tool-bar.el102
-rw-r--r--lisp/tooltip.el1
-rw-r--r--lisp/tutorial.el11
-rw-r--r--lisp/type-break.el46
-rw-r--r--lisp/uniquify.el3
-rw-r--r--lisp/url/ChangeLog156
-rw-r--r--lisp/url/url-cache.el66
-rw-r--r--lisp/url/url-cookie.el4
-rw-r--r--lisp/url/url-dired.el39
-rw-r--r--lisp/url/url-file.el19
-rw-r--r--lisp/url/url-gw.el27
-rw-r--r--lisp/url/url-history.el10
-rw-r--r--lisp/url/url-http.el167
-rw-r--r--lisp/url/url-irc.el9
-rw-r--r--lisp/url/url-parse.el22
-rw-r--r--lisp/url/url-util.el23
-rw-r--r--lisp/url/url-vars.el51
-rw-r--r--lisp/url/url.el25
-rw-r--r--lisp/vc/add-log.el (renamed from lisp/add-log.el)26
-rw-r--r--lisp/vc/compare-w.el (renamed from lisp/compare-w.el)2
-rw-r--r--lisp/vc/cvs-status.el (renamed from lisp/cvs-status.el)12
-rw-r--r--lisp/vc/diff-mode.el (renamed from lisp/diff-mode.el)6
-rw-r--r--lisp/vc/diff.el (renamed from lisp/diff.el)126
-rw-r--r--lisp/vc/ediff-diff.el (renamed from lisp/ediff-diff.el)17
-rw-r--r--lisp/vc/ediff-help.el (renamed from lisp/ediff-help.el)1
-rw-r--r--lisp/vc/ediff-hook.el (renamed from lisp/ediff-hook.el)1
-rw-r--r--lisp/vc/ediff-init.el (renamed from lisp/ediff-init.el)11
-rw-r--r--lisp/vc/ediff-merg.el (renamed from lisp/ediff-merg.el)1
-rw-r--r--lisp/vc/ediff-mult.el (renamed from lisp/ediff-mult.el)1
-rw-r--r--lisp/vc/ediff-ptch.el (renamed from lisp/ediff-ptch.el)9
-rw-r--r--lisp/vc/ediff-util.el (renamed from lisp/ediff-util.el)9
-rw-r--r--lisp/vc/ediff-vers.el (renamed from lisp/ediff-vers.el)1
-rw-r--r--lisp/vc/ediff-wind.el (renamed from lisp/ediff-wind.el)18
-rw-r--r--lisp/vc/ediff.el (renamed from lisp/ediff.el)3
-rw-r--r--lisp/vc/emerge.el (renamed from lisp/emerge.el)244
-rw-r--r--lisp/vc/log-edit.el (renamed from lisp/log-edit.el)9
-rw-r--r--lisp/vc/log-view.el (renamed from lisp/log-view.el)5
-rw-r--r--lisp/vc/pcvs-defs.el (renamed from lisp/pcvs-defs.el)1
-rw-r--r--lisp/vc/pcvs-info.el (renamed from lisp/pcvs-info.el)1
-rw-r--r--lisp/vc/pcvs-parse.el (renamed from lisp/pcvs-parse.el)1
-rw-r--r--lisp/vc/pcvs-util.el (renamed from lisp/pcvs-util.el)1
-rw-r--r--lisp/vc/pcvs.el (renamed from lisp/pcvs.el)2
-rw-r--r--lisp/vc/smerge-mode.el (renamed from lisp/smerge-mode.el)28
-rw-r--r--lisp/vc/vc-annotate.el (renamed from lisp/vc-annotate.el)6
-rw-r--r--lisp/vc/vc-arch.el (renamed from lisp/vc-arch.el)1
-rw-r--r--lisp/vc/vc-bzr.el (renamed from lisp/vc-bzr.el)105
-rw-r--r--lisp/vc/vc-cvs.el (renamed from lisp/vc-cvs.el)5
-rw-r--r--lisp/vc/vc-dav.el (renamed from lisp/vc-dav.el)1
-rw-r--r--lisp/vc/vc-dir.el (renamed from lisp/vc-dir.el)16
-rw-r--r--lisp/vc/vc-dispatcher.el (renamed from lisp/vc-dispatcher.el)14
-rw-r--r--lisp/vc/vc-git.el (renamed from lisp/vc-git.el)5
-rw-r--r--lisp/vc/vc-hg.el (renamed from lisp/vc-hg.el)3
-rw-r--r--lisp/vc/vc-hooks.el (renamed from lisp/vc-hooks.el)14
-rw-r--r--lisp/vc/vc-mtn.el (renamed from lisp/vc-mtn.el)5
-rw-r--r--lisp/vc/vc-rcs.el (renamed from lisp/vc-rcs.el)5
-rw-r--r--lisp/vc/vc-sccs.el (renamed from lisp/vc-sccs.el)4
-rw-r--r--lisp/vc/vc-svn.el (renamed from lisp/vc-svn.el)7
-rw-r--r--lisp/vc/vc.el (renamed from lisp/vc.el)200
-rw-r--r--lisp/vcursor.el2
-rw-r--r--lisp/version.el7
-rw-r--r--lisp/view.el46
-rw-r--r--lisp/w32-fns.el75
-rw-r--r--lisp/w32-vars.el12
-rw-r--r--lisp/wid-browse.el1
-rw-r--r--lisp/wid-edit.el161
-rw-r--r--lisp/widget.el1
-rw-r--r--lisp/window.el166
-rw-r--r--lisp/woman.el161
-rw-r--r--lisp/x-dnd.el4
948 files changed, 93963 insertions, 56628 deletions
diff --git a/lisp/.arch-inventory b/lisp/.arch-inventory
deleted file mode 100644
index 5341c2d8fec..00000000000
--- a/lisp/.arch-inventory
+++ /dev/null
@@ -1,4 +0,0 @@
-# Auto-generated lisp files, which ignore
-precious ^(loaddefs|finder-inf|cus-load)\.el$
-
-# arch-tag: fc62dc9f-3a91-455b-b8e7-d49df66beee0
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index c6da166726b..8544b0e53d3 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -13,7 +13,7 @@
`directory-listing-before-filename-regexp'. (Bug#7308)
(locate-post-command-hook, locate-post-command-hook): New defcustoms.
-2010-11-26 Stefan Monnier <monnier@iro.umontreal.ca>
+2010-11-27 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/smie.el (smie-prec2->grammar): Simplify handling
of :smie-open/close-alist.
@@ -21,14 +21,14 @@
(smie-indent-keyword): Be careful not to misidentify tokens that span
more than one line, as empty lines. Add argument `token'.
-2010-11-26 Kenichi Handa <handa@m17n.org>
+2010-11-27 Kenichi Handa <handa@m17n.org>
* mail/rmailmm.el (rmail-mime-insert-multipart): For unsupported
multipart subtypes, insert all as usual.
* mail/rmail.el: Require rfc2047.
-2010-11-26 Kenichi Handa <handa@m17n.org>
+2010-11-27 Kenichi Handa <handa@m17n.org>
* mail/rmailmm.el (rmail-mime-entity, rmail-mime-entity-type)
(rmail-mime-entity-disposition)
@@ -71,20 +71,20 @@
rmail-show-mime-function for a MIME message. Decode the headers
according to RFC2047.
-2010-11-24 Stefan Monnier <monnier@iro.umontreal.ca>
+2010-11-27 Stefan Monnier <monnier@iro.umontreal.ca>
* progmodes/which-func.el (which-func-imenu-joiner-function):
Return a string, as expected.
(which-function-mode): Make sure we stop any previous timer before
starting a new one.
-2010-11-23 Michael Albinus <michael.albinus@gmx.de>
+2010-11-27 Michael Albinus <michael.albinus@gmx.de>
* net/tramp.el (tramp-default-method-alist)
(tramp-default-user-alist, tramp-default-proxies-alist):
Adapt custom options type. (Bug#7445)
-2010-11-21 Chong Yidong <cyd@stupidchicken.com>
+2010-11-27 Chong Yidong <cyd@stupidchicken.com>
* progmodes/python.el: Add Ipython support (Bug#5390).
(python-shell-prompt-alist)
@@ -98,23 +98,249 @@
(python-comint-output-filter-function): Use it.
(run-python): Use a pipe (Bug#5694).
-2010-11-21 Chong Yidong <cyd@stupidchicken.com>
+2010-11-27 Chong Yidong <cyd@stupidchicken.com>
* progmodes/python.el (run-python): Doc fix.
(python-keep-current-directory-in-path): New var (Bug#7454).
-2010-11-20 Chong Yidong <cyd@stupidchicken.com>
+2010-11-27 Chong Yidong <cyd@stupidchicken.com>
* lpr.el (lpr-buffer, print-buffer, lpr-region, print-region):
Prompt user before actually printing.
+2010-11-27 Eli Zaretskii <eliz@gnu.org>
+
+ * international/characters.el (glyphless-char-display-control):
+ Exclude newline and TAB from the c0-control group.
+
+2010-11-27 Glenn Morris <rgm@gnu.org>
+
+ * mail/sendmail.el (build-mail-aliases): Doc fix for autoload.
+ (expand-mail-aliases): Remove unnecessary autoload.
+
+ * allout.el (allout-command-prefix, allout-mode-map): Declare.
+
+ * shell.el (shell-dir-cookie-re): Move definition before use.
+
+ * mail/emacsbug.el (report-emacs-bug-create-existing-bugs-buffer):
+ Replace undefined CL functions.
+
+2010-11-26 Eli Zaretskii <eliz@gnu.org>
+
+ * simple.el (prog-mode): Set bidi-paragraph-direction to
+ left-to-right.
+
+ * term/pc-win.el (x-get-selection-internal): Emulation for MS-DOS.
+
+2010-11-26 Glenn Morris <rgm@gnu.org>
+
+ * calendar/diary-lib.el (diary-outlook-format-1): New function, so that
+ diary-outlook-formats can be sensitive to calendar-date-style.
+ (diary-outlook-formats): Simplify the default setting.
+ (diary-from-outlook-internal): Pass subject and body as arguments.
+ Use dolist rather than dotimes. Don't save the diary buffer.
+ (diary-from-outlook-gnus, diary-from-outlook-rmail):
+ Pass subject and body as explicit arguments to the -internal function.
+
+2010-11-26 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * mail/rfc2368.el (rfc2368-parse-mailto-url): Unfold URLs before
+ parsing them. This makes mailto:...?subject=foo\nbar work.
+
+2010-11-25 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * vc/diff.el (diff): Fix last change.
+
+2010-11-24 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/pcase.el: Improve pcase-let. Use "pcase--" prefix.
+ (pcase--dontcare-upats): New var.
+ (pcase-let, pcase-let*): Generate better code.
+ Accept the same bodies as `let'.
+ (pcase-dolist): New macro.
+ (pcase--trivial-upat-p): New helper function.
+ (pcase--expand): Strip leading "(let nil" if any.
+
+2010-11-24 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * mail/mailclient.el (browse-url): Require.
+ (mailclient-send-it): Bind `browse-url-mailto-function' to nil to
+ use the external browser function to send the mail (bug#7469).
+
+ * net/browse-url.el (browse-url-browser-function): Revert the
+ default back to the previous value, since the new value broke
+ mailclient.el.
+ (browse-url-mailto-function): New variable for mailto: URLs.
+ (browse-url): Use the new variable for mailto: URLs.
+
+2010-11-23 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * eshell/esh-cmd.el (eshell-parse-command):
+ * eshell/esh-arg.el (eshell-parse-arguments):
+ * eshell/em-script.el (eshell-source-file):
+ Use with-silent-modifications.
+
+2010-11-23 Chong Yidong <cyd@stupidchicken.com>
+
+ * vc/vc.el (vc-merge): Remove optional arg PROMPT. Always prompt
+ for a merge location.
+
+ * vc/vc-bzr.el (vc-bzr-pull): Remove unused var.
+ (vc-bzr-merge-branch): Always prompt.
+ (vc-bzr-async-command): Use the full branch filename.
+
+2010-11-23 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * shell.el (shell): Use current-buffer by default if it's already
+ a shell mode buffer and its process is dead.
+ Suggested by <jemarch@gnu.org>.
+
+2010-11-23 Tassilo Horn <tassilo@member.fsf.org>
+
+ * mail/emacsbug.el (report-emacs-bug-query-existing-bugs):
+ Mention that the keywords should be comma separated.
+
+2010-11-23 Chong Yidong <cyd@stupidchicken.com>
+
+ * vc/vc.el (vc-merge): Use vc-BACKEND-merge-branch if available.
+ Accept optional prefix arg meaning to prompt for a command.
+ (vc-update): Use vc-BACKEND-pull if available. Accept optional
+ prefix arg meaning to prompt for a command.
+ (vc-pull): Alias for vc-update.
+
+ * vc/vc-bzr.el (vc-bzr-admin-branchconf, vc-bzr-history): New vars.
+ (vc-bzr--branch-conf, vc-bzr-async-command, vc-bzr-pull)
+ (vc-bzr-merge-branch): New functions, implementing merge-branch
+ and pull operations.
+
+2010-11-22 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * Makefile.in: Fix up last merge.
+
+ * vc/diff.el (diff-old-temp-file, diff-new-temp-file): Remove.
+ (diff-sentinel): Get them as arguments instead.
+ (diff-old-file, diff-new-file, diff-extra-args): Remove.
+ (diff-file-local-copy, diff-better-file-name): New funs.
+ (diff-no-select): Rename from diff-into-buffer.
+ Support buffers additionally to files. Move `buf' arg. Don't display buf.
+ Prefer closures to buffer-local variables.
+ (diff): Adjust accordingly.
+ (diff-buffer-with-file): Move from files.el.
+ * files.el (diff-buffer-with-file): Move to vc/diff.el.
+ (diff-buffer-internal): Remove.
+ (diff-buffer-buffer): Remove.
+ (save-some-buffers-action-alist): Use diff-no-select so as not to guess
+ the buffer name used, and so as not to mess up windows and frames.
+
+2010-11-22 Bob Rogers <rogers-emacs@rgrjr.dyndns.org>
+
+ * files.el: Make revert work with diff-buffer-with-file (bug#7277).
+ (diff-buffer-internal): New function extracted from diff-buffer-with-file
+ (diff-buffer-with-file): Use it.
+ * vc/diff.el (diff-into-buffer): New fun, extracted from diff.
+ (diff): Use it.
+
+2010-11-22 Tassilo Horn <tassilo@member.fsf.org>
+
+ * textmodes/reftex-ref.el (reftex-goto-label): Use the current
+ \ref's or \pageref's value as default instead of initial input.
+
+2010-11-21 Michael Albinus <michael.albinus@gmx.de>
+
+ * files.el (backup-by-copying-when-mismatch): The default value is
+ now t.
+
+ * startup.el (normal-top-level):
+ * net/tramp.el (tramp-handle-insert-file-contents): Do not set
+ `backup-by-copying-when-mismatch'.
+
+2010-11-21 Jan Djärv <jan.h.d@swipnet.se>
+
+ * tool-bar.el (tool-bar-setup): Remove save as, print and customize.
+
+2010-11-21 Deniz Dogan <deniz.a.m.dogan@gmail.com>
+
+ * progmodes/python.el (python-font-lock-keywords):
+ Highlight top-level augmented assignments (Bug#6445).
+
+2010-11-21 Jan Djärv <jan.h.d@swipnet.se>
+
+ * term/ns-win.el (ns-right-control-modifier)
+ (ns-right-command-modifier): Defvar them.
+
+ * cus-start.el (all): Add ns-right-control-modifier and
+ ns-right-command-modifier (Bug#7458).
+
+2010-11-20 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/authors.el (authors-ignored-files)
+ (authors-valid-file-names, authors-renamed-files-alist): Add entries.
+
+2010-11-20 Tassilo Horn <tassilo@member.fsf.org>
+
+ * mail/emacsbug.el (report-emacs-bug-query-existing-bugs)
+ (report-emacs-bug-parse-query-results)
+ (report-emacs-bug-create-existing-bugs-buffer): Pass through
+ keywords used for querying the bug database to show them in the
+ existing bugs buffer.
+
+2010-11-20 Jan Djärv <jan.h.d@swipnet.se>
+
+ * tool-bar.el (tool-bar-setup): Add some :vert-only keywords.
+
+ * info.el (info-tool-bar-map): Add some :vert-only keywords.
+
+2010-11-20 Eli Zaretskii <eliz@gnu.org>
+
+ * international/characters.el (glyphless-char-display-control):
+ Make it a defcustom, with update-glyphless-char-display as its
+ :set attribute.
+ (top level): Don't call update-glyphless-char-display.
+
+2010-11-20 Michael Albinus <michael.albinus@gmx.de>
+
+ Sync with Tramp 2.2.0.
+
+ * net/tramp.el (tramp-handle-insert-file-contents): Don't use
+ `file-remote-p' (due to compatibility).
+
+ * net/tramp-sh.el (tramp-do-copy-or-rename-file-directly)
+ (tramp-do-copy-or-rename-file-out-of-band): Use `ignore-errors'.
+
+ * net/trampver.el: Update release number.
+
+2010-11-20 Eli Zaretskii <eliz@gnu.org>
+
+ * faces.el (glyphless-char): Define value for `pc'.
+
+2010-11-20 Tassilo Horn <tassilo@member.fsf.org>
+
+ Implemented a bug querying mechanism.
+ * mail/emacsbug.el (report-emacs-bug-tracker-url): New variable.
+ (report-emacs-bug-create-existing-bugs-buffer)
+ (report-emacs-bug-parse-query-results)
+ (report-emacs-bug-query-existing-bugs): New functions.
+
+2010-11-19 Tassilo Horn <tassilo@member.fsf.org>
+
+ * textmodes/reftex-ref.el (reftex-goto-label): If point is inside
+ a \ref{} or \pageref{} macro, then use its value as initial input.
+
+2010-11-19 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc-units.el (math-build-units-table-buffer):
+ calc/README: Mention that the TeX specific units won't use the
+ `tex' prefix in TeX mode.
+ calc/calc-lang.el (math-variable-table): Don't use the `tex'
+ prefix for units in TeX mode.
+
2010-11-18 Stefan Monnier <monnier@iro.umontreal.ca>
* simple.el (kill-new, kill-append, kill-region):
* comint.el (comint-kill-region): Make the yank-handler argument
obsolete.
-2010-11-17 Stefan Monnier <monnier@iro.umontreal.ca>
+2010-11-18 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/smie.el (smie-bnf-classify): Signal errors for tokens
that are both openers (resp. closers) and something else.
@@ -128,48 +354,41 @@
Suggested by Norman Gray <norman@astro.gla.ac.uk>.
(vc-hg-state, vc-hg-working-revision, vc-hg-command): Use it.
-2010-11-17 Glenn Morris <rgm@gnu.org>
+2010-11-18 Glenn Morris <rgm@gnu.org>
* emacs-lisp/autoload.el (autoload-find-destination): The function
coding-system-eol-type may return non-numeric values. (Bug#7414)
-2010-11-16 Ulrich Mueller <ulm@gentoo.org>
+2010-11-18 Ulrich Mueller <ulm@gentoo.org>
* server.el (server-force-stop): Ensure the server is stopped (Bug#7409).
-2010-11-13 Eli Zaretskii <eliz@gnu.org>
+2010-11-18 Eli Zaretskii <eliz@gnu.org>
* subr.el (posn-col-row): Pay attention to header line. (Bug#7390)
-2010-11-13 Chong Yidong <cyd@stupidchicken.com>
+2010-11-18 Chong Yidong <cyd@stupidchicken.com>
* textmodes/picture.el (picture-mouse-set-point): Don't use
posn-col-row; explicitly compute the motion based on the posn at
the window-start (Bug#7390).
-2010-11-13 Michael Albinus <michael.albinus@gmx.de>
-
- * net/tramp.el (tramp-remote-coding-commands): Add an alternative
- using "base64 -d -i". This is needed for older base64 versions
- from GNU coreutils. Reported by Klaus Reichl
- <Klaus.Reichl@thalesgroup.com>.
-
-2010-11-13 Glenn Morris <rgm@gnu.org>
+2010-11-18 Glenn Morris <rgm@gnu.org>
* novice.el (disabled-command-function):
Fix 2009-11-15 change. (Bug#7384)
-2010-11-12 Glenn Morris <rgm@gnu.org>
+2010-11-18 Glenn Morris <rgm@gnu.org>
* calendar/calendar.el (diary-iso-date-forms): Make elements
mutually exclusive. (Bug#7377)
-2010-11-12 Stefan Monnier <monnier@iro.umontreal.ca>
+2010-11-18 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/smie.el (smie-prec2->grammar): Obey equality constraints
when filling the remaining "unconstrained" values.
-2010-11-11 Stefan Monnier <monnier@iro.umontreal.ca>
+2010-11-18 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/bytecomp.el (byte-compile-warnings): Simplify the
safety predicate.
@@ -182,11 +401,11 @@
(smie-indent-keyword): Consult rules, even for openers at bol.
(smie-indent-comment-close): Try to align closer's content.
-2010-11-11 Glenn Morris <rgm@gnu.org>
+2010-11-18 Glenn Morris <rgm@gnu.org>
* ls-lisp.el (ls-lisp-dired-ignore-case): Make it an obsolete alias.
-2010-11-10 Glenn Morris <rgm@gnu.org>
+2010-11-18 Glenn Morris <rgm@gnu.org>
* printing.el (pr-menu-bind): Doc fix.
@@ -197,11 +416,363 @@
* wid-edit.el (widget-field-use-before-change)
(widget-use-overlay-change): Doc fixes.
+2010-11-18 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Minor cleanup to improve style.
+ * textmodes/rst.el (rst-update-section): Use point-marker.
+ (rst-get-decoration): Eliminate unneeded assignment.
+ (rst-promote-region, rst-straighten-decorations)
+ (rst-section-tree, rst-adjust): Use point-marker.
+ (rst-toc-mode-mouse-goto): Avoid setq.
+ (rst-shift-region-guts, rst-shift-region-left)
+ (rst-iterate-leftmost-paragraphs, rst-iterate-leftmost-paragraphs-2)
+ (rst-convert-bullets-to-enumeration): Use copy-marker.
+
+ * minibuffer.el (completion-fail-discreetly): New var.
+ (completion--do-completion): Use it.
+
+ * electric.el (electric-pair-pairs): New var.
+ (electric-pair-post-self-insert-function): Use it.
+ (electric-layout-post-self-insert-function): Don't insert a before
+ newline unless it's actually needed.
+
+2010-11-17 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/python.el (run-python): Explain why we remove the current
+ directory from sys.path. Suggested by Eric Hanchrow <erich@cozi.com>.
+
+ * progmodes/grep.el (grep-regexp-alist): Tighten the regexp (bug#7378).
+
+2010-11-16 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/octave-mod.el: Rely on elecric-*-modes.
+ (octave-mode-map): Don't bind ;, SPC, and LF.
+ (octave-auto-indent, octave-auto-newline): Remove.
+ (electric-layout-rules): Declare.
+ (octave-mode): Set electric-layout-rules.
+ (octave-indent-new-comment-line): Use reindent-then-newline-and-indent.
+ (octave-reindent-then-newline-and-indent, octave-electric-semi)
+ (octave-electric-space): Remove.
+
+ * electric.el (electric-layout-mode): New minor mode.
+ (electric--after-char-pos): New function.
+ (electric-indent-post-self-insert-function): Use it.
+ (electric-layout-rules): New var.
+ (electric-layout-post-self-insert-function): New function.
+ (electric-indent-mode): Make them interact better.
+
+2010-11-15 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/checkdoc.el (checkdoc-syntax-table): Fix last change.
+ (checkdoc-sentencespace-region-engine, checkdoc-this-string-valid)
+ (checkdoc-proper-noun-region-engine): Use with-syntax-table.
+
+2010-11-15 Agustín Martín <agustin.martin@hispalinux.es>
+
+ * textmodes/flyspell.el (flyspell-generic-progmode-verify):
+ Make sure to check inside the word (Bug#6761).
+
+2010-11-14 Chong Yidong <cyd@stupidchicken.com>
+
+ * startup.el (command-line): If the cursorColor resource is set,
+ change the cursor face-spec (Bug#7392).
+
+2010-11-13 Ken Manheimer <ken.manheimer@gmail.com>
+
+ The main features of the following allout.el changes are:
+ - implement user customization for the allout key bindings
+ - add a customization control by which the user can inhibit use of
+ a trailing Ctrl-H, so by default it's reserved for use with
+ describe-prefix-bindings
+ - adapt to new version of called-interactively-p, while
+ maintaining backwards compatibility with old version
+ - fix hotspot navigation so i works properly with meta-modified keys
+
+ * allout.el (allout-keybindings, allout-bind-keys)
+ (allout-keybindings-binding, allout-prefixed-keybindings)
+ (allout-unprefixed-keybindings, allout-preempt-trailing-ctrl-h)
+ (allout-keybindings-list, allout-mode-map-adjustments)
+ (allout-setup-mode-map): Establish allout-mode keymaps as user
+ customizable settings, and also establish a customizable setting which
+ regulates whether or not a trailing control-h is reserved for use with
+ describe-prefix-bindings - and inhibit it by default, so that control-h
+ *is* reserved for describe-prefix-bindings unless the user changes it.
+
+ * allout.el (allout-hotspot-key-handler): Distinguish more explicitly
+ and accurately between modified and unmodified events, and handle
+ modified events more comprehensively.
+
+ * allout.el (allout-substring-no-properties):
+ Alias to use or provide version of `substring-no-properties'.
+ (allout-solicit-alternate-bullet): Use `allout-substring-no-properties'.
+
+ * allout.el (allout-next-single-char-property-change):
+ Alias to use or provide version of `next-single-char-property-change'.
+ (allout-annotate-hidden, allout-hide-by-annotation):
+ Use `allout-next-single-char-property-change'.
+
+ * allout.el (allout-select-safe-coding-system):
+ Alias to use or provide version of `select-safe-coding-system'.
+ (allout-toggle-subtree-encryption):
+ Use `allout-select-safe-coding-system'.
+
+ * allout.el (allout-set-buffer-multibyte):
+ Alias to use or provide version of `set-buffer-multibyte'.
+ (allout-encrypt-string): Use `allout-set-buffer-multibyte'.
+
+ * allout.el (allout-called-interactively-p): Macro for using the
+ different versions of called-interactively-p identically, depending on
+ the subroutine's argument signature.
+ (allout-back-to-current-heading, allout-beginning-of-current-entry):
+ Use `(interactive "p")' instead of `(called-interactively-p)'.
+
+ * allout.el (allout-init, allout-ascend, allout-end-of-level)
+ (allout-previous-visible-heading, allout-forward-current-level)
+ (allout-backward-current-level, allout-show-children):
+ Use `allout-called-interactively-p' instead of `called-interactively-p'.
+
+ * allout.el (allout-before-change-handler):
+ Exempt edits to the (overlaid) character after the allout outline
+ bullet from edit confirmation prompt.
+
+ * allout.el (allout-add-resumptions):
+ Ensure that it respects correct buffer for keybindings.
+
+ * allout.el (allout-beginning-of-line):
+ Use `allout-previous-single-char-property-change' alias for the sake of
+ diverse compatibility.
+
+ * allout.el (allout-end-of-line):
+ Use `allout-mark-active-p' to encapsulate respect for mark activity.
+
+2010-11-13 Chong Yidong <cyd@stupidchicken.com>
+
+ * frame.el (frame-notice-user-settings): Don't clobber other
+ user-set parameters when calling face-set-after-frame-default in
+ response to background-color parameter (Bug#7373).
+
+2010-11-13 Eli Zaretskii <eliz@gnu.org>
+
+ * international/characters.el (glyphless-char-display-control):
+ Renamed from glyphless-char-control; all users changed. Doc fix.
+ Signal an error if display method is not one of the recognized
+ symbols.
+
+2010-11-13 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-compat.el (tramp-compat-line-beginning-position)
+ (tramp-compat-line-end-position): Remove them.
+
+ * net/tramp.el (tramp-parse-rhosts-group)
+ (tramp-parse-shosts-group, tramp-parse-sconfig-group)
+ (tramp-parse-hosts-group, tramp-parse-passwd-group)
+ (tramp-parse-netrc-group, tramp-parse-putty-group)
+ * net/tramp-cmds.el (tramp-append-tramp-buffers)
+ * net/tramp-sh.el (tramp-do-file-attributes-with-ls)
+ (tramp-sh-handle-file-selinux-context)
+ (tramp-sh-handle-file-name-all-completions)
+ (tramp-sh-handle-insert-directory)
+ (tramp-sh-handle-expand-file-name, tramp-find-executable)
+ (tramp-wait-for-output, tramp-send-command-and-read)
+ * net/tramp-smb.el (tramp-smb-read-file-entry)
+ (tramp-smb-get-cifs-capabilities): Use `point-at-eol'.
+
+ * net/tramp-sh.el (tramp-sh-handle-insert-directory) Use
+ `point-at-bol'.
+ (tramp-remote-coding-commands): Add an alternative using "base64
+ -d -i". This is needed for older base64 versions from GNU
+ coreutils. Reported by Klaus Reichl
+ <Klaus.Reichl@thalesgroup.com>.
+
+2010-11-13 Hrvoje Niksic <hniksic@xemacs.org>
+
+ * simple.el (count-words-region): New function.
+
+2010-11-12 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * shell.el (shell-dir-cookie-re): New custom variable.
+ (shell-dir-cookie-watcher): New function.
+
+ * vc/vc.el (vc-deduce-backend): Use default-directory in shell-mode
+ and compilation-mode (bug#7350).
+
+ * vc/smerge-mode.el (smerge-refine): Choose better default part to
+ highlight when one of them is empty.
+
+ * skeleton.el (skeleton-read): Don't use `newline' since it may strip
+ trailing space.
+ (skeleton-newline): New function.
+ (skeleton-internal-1): Use it.
+
+ * simple.el (open-line): `newline' may strip trailing space.
+
+2010-11-12 Kevin Ryde <user42@zip.com.au>
+
+ * international/mule-cmds.el (princ-list): Use mapc.
+
+2010-11-12 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/bytecomp.el (byte-compile-log-buffer): New constant.
+ Use it to replace all instances of "*Compile-Log*"
+
+2010-11-12 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/pcase.el (pcase-let*, pcase-let): Add debug and
+ indentation specs.
+
+2010-11-11 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/modula2.el: Use SMIE and skeleton.
+ (m2-mode-syntax-table): (*..*) can be nested.
+ Add //...\n. Fix paren syntax.
+ (m2-mode-map): Remove LF and TAB bindings.
+ (m2-indent): Add safety property.
+ (m2-smie-grammar): New var.
+ (m2-smie-refine-colon, m2-smie-refine-of, m2-smie-backward-token)
+ (m2-smie-forward-token, m2-smie-refine-semi, m2-smie-rules): New funs.
+ (m2-mode): Use define-derived-mode.
+ (m2-newline, m2-tab): Remove.
+ (m2-begin, m2-case, m2-definition, m2-else, m2-for, m2-header)
+ (m2-if, m2-loop, m2-module, m2-or, m2-procedure, m2-with, m2-record)
+ (m2-stdio, m2-type, m2-until, m2-var, m2-while, m2-export)
+ (m2-import): Use define-skeleton.
+
+2010-11-11 Glenn Morris <rgm@gnu.org>
+
+ * obsolete/lucid.el: Don't warn about any CL functions in this file.
+
+ * ls-lisp.el (ls-lisp-ignore-case, ls-lisp-dirs-first)
+ (ls-lisp-verbosity): Add custom :set-after property.
+ (ls-lisp-verbosity, ls-lisp-use-localized-time-format): Doc fixes.
+ (ls-lisp-format, ls-lisp-format-time): Don't take `now' as an argument.
+ (ls-lisp-insert-directory): Update caller.
+ (ls-lisp-set-options): New function.
+ (ls-lisp-emulation): Use ls-lisp-set-options for custom :set.
+ Doc fix.
+
+ * play/landmark.el (lm-prompt-for-move):
+ * play/gomoku.el (gomoku-prompt-for-move): Remove nonsensical code.
+
+ * progmodes/idlw-complete-structtag.el: Remove unused dec `name'.
+
+ * progmodes/idlwave.el (idlwave-routine-entry-compare-twins)
+ (idlwave-study-twins): Prefix dynamic local variable `name'.
+ (idlwave-routine-twin-compare): Update for above change.
+
+ * progmodes/idlw-help.el (idlwave-do-mouse-completion-help):
+ Prefix dynamic local variables `name', `kwd', and `link'.
+ * progmodes/idlw-shell.el (idlwave-shell-complete-execcomm-help):
+ * progmodes/idlw-complete-structtag.el
+ (idlwave-complete-structure-tag-help):
+ * progmodes/idlwave.el (idlwave-complete-sysvar-help)
+ (idlwave-complete-sysvar-tag-help)
+ (idlwave-complete-class-structure-tag-help):
+ Update for above name changes.
+
+2010-11-10 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * net/browse-url.el (browse-url-browser-function): Change the
+ default to use `browse-url-mail' on mailto: URLs.
+
+2010-11-10 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/package.el (package-read-all-archive-contents):
+ Reset package-archive-contents to nil before re-reading.
+
+2010-11-10 Brandon Craig Rhodes <brandon@rhodesmill.org> (tiny change)
+
+ * textmodes/flyspell.el (flyspell-word): Do not re-check words
+ already found as misspellings by (flyspell-large-region), just
+ do highlighting (bug#7322).
+
+2010-11-10 Glenn Morris <rgm@gnu.org>
+
+ * progmodes/octave-mod.el (octave-mark-block): Update for smie change.
+
+ * emulation/edt.el (edt-with-position): New macro.
+ (edt-find-forward, edt-find-backward, edt-find-next-forward)
+ (edt-find-next-backward, edt-sentence-forward, edt-sentence-backward)
+ (edt-paragraph-forward, edt-paragraph-backward): Use it.
+
+ * emulation/tpu-extras.el (tpu-with-position): New macro.
+ (tpu-paragraph, tpu-page, tpu-search-internal): Use it.
+
+ * textmodes/texnfo-upd.el (texinfo-pointer-name): Fix typo.
+
+ * textmodes/texnfo-upd.el (texinfo-all-menus-update)
+ (texinfo-menu-copy-old-description, texinfo-start-menu-description)
+ (texinfo-master-menu, texinfo-insert-node-lines)
+ (texinfo-multiple-files-update):
+ * textmodes/texinfmt.el (texinfo-append-refill, texinfo-copying):
+ Use line-beginning-position.
+
+ * progmodes/cperl-mode.el (cperl-find-pods-heres, cperl-write-tags):
+ No recent Emacs supports system-type `emx'.
+
+ * progmodes/ada-xref.el (is-windows): Rename to ada-on-ms-windows.
+ (ada-command-separator, ada-default-prj-properties)
+ (ada-find-any-references): Update for above name change.
+
+ * dirtrack.el (dirtrack-directory-function)
+ (dirtrack-canonicalize-function):
+ * filecache.el (file-cache-completion-ignore-case)
+ (file-cache-case-fold-search, file-cache-ignore-case):
+ * term.el (serial-port-is-file-p): Cosmetic change.
+
+ * emulation/viper-init.el (viper-ms-style-os-p): Doc fix.
+ Remove non-existent `windows-95' system-type.
+ * dired.el (dired-chown-program): Remove non-existent `linux'
+ system-type.
+
+ * net/net-utils.el (net-utils-remove-ctl-m): Use memq for system-types.
+ (ping-program-options): Remove non-existent `linux' system-type.
+
+ * startup.el (package-initialize): Update declaration.
+
+ * ls-lisp.el (ls-lisp-time-lessp, ls-lisp-time-to-seconds): Remove.
+ (ls-lisp-handle-switches): Use time-less-p.
+ (ls-lisp-format-time): Use float-time.
+
+ * textmodes/remember.el (remember-time-to-seconds): Remove.
+ (remember-store-in-mailbox): Use float-time.
+
+ * calendar/timeclock.el (timeclock-time-to-seconds): Make it an alias.
+
+ * calendar/time-date.el (time-to-seconds): Always an alias on Emacs,
+ never a real function.
+ (with-no-warnings): Remove compat stub, now unused.
+ (time-less-p): Doc fix.
+ (time-to-number-of-days): Simplify.
+
+ * eshell/esh-util.el (eshell-time-less-p, eshell-time-to-seconds):
+ Remove.
+ (eshell-read-passwd, eshell-read-hosts): Use time-less-p.
+ * eshell/esh-test.el (eshell-test, eshell-show-usage-metrics):
+ * eshell/em-unix.el (eshell-show-elapsed-time, eshell/time):
+ * eshell/em-pred.el (eshell-pred-file-time): Use float-time.
+ * eshell/em-ls.el (eshell-ls-sort-entries): Use time-less-p.
+
+ * eshell/em-unix.el (eshell-remove-entries, eshell/rm)
+ (eshell-shuffle-files, eshell-shorthand-tar-command)
+ (eshell-mvcpln-template, eshell/mv, eshell/cp, eshell/ln):
+ Prefix dynamic locals `interactive', `preview', `recursive', `verbose'.
+ * eshell/em-glob.el (eshell-extended-glob, eshell-glob-entries):
+ Prefix dynamic local variable `matches'.
+
+ * skeleton.el (skeleton-internal-list, skeleton-internal-1):
+ Prefix dynamic local variable `skeleton'.
+
+2010-11-10 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * net/browse-url.el (browse-url-mail): Insert body part of mailto url
+ in mail buffer; make yank-action always a command that yanks original
+ buffer.
+
2010-11-09 Glenn Morris <rgm@gnu.org>
* progmodes/tcl.el (tcl-hairy-scan-for-comment): Doc fix.
-2010-11-08 Stefan Monnier <monnier@iro.umontreal.ca>
+2010-11-09 Stefan Monnier <monnier@iro.umontreal.ca>
* minibuffer.el (minibuffer-completion-help): Specify the end of the
completion field (bug#7211).
@@ -210,20 +781,20 @@
Fix handling of backslash escapes.
(python-quote-syntax): Adjust accordingly.
-2010-11-08 Richard Levitte <richard@levitte.org> (tiny change)
+2010-11-09 Richard Levitte <richard@levitte.org> (tiny change)
* vc-mtn.el (vc-mtn-working-revision, vc-mtn-after-dir-status)
(vc-mtn-workfile-branch): Adjust to new output format.
-2010-11-08 Stefan Monnier <monnier@iro.umontreal.ca>
+2010-11-09 Stefan Monnier <monnier@iro.umontreal.ca>
* international/mule-cmds.el (princ-list): Mark as obsolete.
-2010-11-07 Stefan Monnier <monnier@iro.umontreal.ca>
+2010-11-09 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/smie.el: New package.
-2010-11-06 Michael Albinus <michael.albinus@gmx.de>
+2010-11-09 Michael Albinus <michael.albinus@gmx.de>
* files.el (backup-by-copying-when-mismatch):
Set `permanent-local' property.
@@ -231,15 +802,11 @@
* net/tramp.el (tramp-handle-insert-file-contents): Do not set
`permanent-local' property for `backup-by-copying-when-mismatch'.
-2010-11-06 Eli Zaretskii <eliz@gnu.org>
+2010-11-09 Eli Zaretskii <eliz@gnu.org>
* ls-lisp.el (insert-directory): Doc fix. (bug#7285)
- (ls-lisp-classify-file): New function.
- (ls-lisp-insert-directory): Call it if switches include -F (bug#6294).
- (ls-lisp-classify): Call ls-lisp-classify-file.
- (insert-directory): Remove blanks from switches.
-2010-11-07 Wilson Snyder <wsnyder@wsnyder.org>
+2010-11-09 Wilson Snyder <wsnyder@wsnyder.org>
* progmodes/verilog-mode.el (verilog-insert-one-definition)
(verilog-read-decls, verilog-read-sub-decls-sig): Fix AUTOWIRE and
@@ -248,20 +815,11 @@
(verilog-preprocess): Use with-current-buffer and
font-lock-fontify-buffer to cleanup style issues.
-2010-11-05 Michael Albinus <michael.albinus@gmx.de>
-
- * net/trampver.el: Update release number.
-
-2010-08-01 YAMAMOTO Mitsuharu <mituharu@math.s.chiba-u.ac.jp>
-
- * mouse.el (mouse-fixup-help-message): Match "mouse-2" only at the
- beginning of the string. Use `string-match-p'. (Bug#6765)
-
-2010-11-01 Glenn Morris <rgm@gnu.org>
+2010-11-09 Glenn Morris <rgm@gnu.org>
* locate.el (locate, locate-mode): Doc fixes.
-2010-11-01 Chong Yidong <cyd@stupidchicken.com>
+2010-11-09 Chong Yidong <cyd@stupidchicken.com>
* server.el (server-start): New arg INHIBIT-PROMPT prevents asking
user for confirmation.
@@ -269,197 +827,476 @@
(server-start): Use server-force-stop for kill-emacs-hook, to
avoid user interaction while killing Emacs.
-2010-10-31 Stefan Monnier <monnier@iro.umontreal.ca>
+2010-11-09 Glenn Morris <rgm@gnu.org>
- * vc/log-edit.el (log-edit-rewrite-fixes): New var.
- (log-edit-author): New dynamic var.
- (log-edit-changelog-ours-p, log-edit-insert-changelog-entries):
- Use it to return the author if different from committer.
- (log-edit-insert-changelog): Use them to add Author: and Fixes headers.
+ * progmodes/meta-mode.el: Remove leading `*' from defcustom docs.
+ (meta-indent-line): Simplify.
+
+ * vc/emerge.el (emerge-line-number-in-buf):
+ * textmodes/ispell.el (ispell-region):
+ * textmodes/fill.el (current-fill-column):
+ * progmodes/xscheme.el (xscheme-send-current-line):
+ * progmodes/vhdl-mode.el (vhdl-current-line, vhdl-line-copy):
+ * progmodes/tcl.el (tcl-hairy-scan-for-comment):
+ * progmodes/sh-script.el (sh-handle-prev-do):
+ * progmodes/meta-mode.el (meta-indent-line):
+ * progmodes/idlwave.el (idlwave-goto-comment, idlwave-fill-paragraph)
+ (idlwave-in-quote):
+ * progmodes/idlw-shell.el (idlwave-shell-current-frame)
+ (idlwave-shell-update-bp-overlays, idlwave-shell-sources-filter):
+ * progmodes/fortran.el (fortran-looking-at-if-then):
+ * progmodes/etags.el (find-tag-in-order, etags-snarf-tag):
+ * progmodes/cperl-mode.el (cperl-sniff-for-indent)
+ (cperl-find-pods-heres):
+ * progmodes/ada-mode.el (ada-get-current-indent, ada-narrow-to-defun):
+ * net/quickurl.el (quickurl-list-insert):
+ * net/ldap.el (ldap-search-internal):
+ * net/eudc.el (eudc-expand-inline):
+ * mail/sendmail.el (sendmail-send-it):
+ * mail/mspools.el (mspools-visit-spool, mspools-get-spool-name):
+ * emulation/viper-cmd.el (viper-paren-match, viper-backward-indent)
+ (viper-brac-function):
+ * calc/calc-yank.el (calc-do-grab-region):
+ * calc/calc-keypd.el (calc-keypad-press):
+ * term.el (term-move-columns, term-insert-spaces):
+ * speedbar.el (speedbar-highlight-one-tag-line):
+ * simple.el (current-word):
+ * mouse-drag.el (mouse-drag-should-do-col-scrolling):
+ * info.el (Info-find-node-in-buffer-1, Info-follow-reference)
+ (Info-scroll-down):
+ * hippie-exp.el (he-line-beg):
+ * epa.el (epa--marked-keys):
+ * dired-aux.el (dired-kill-line, dired-do-kill-lines)
+ (dired-update-file-line, dired-add-entry, dired-remove-entry)
+ (dired-relist-entry):
+ * buff-menu.el (Buffer-menu-buffer):
+ * array.el (current-line):
+ * allout.el (allout-resolve-xref)
+ (allout-latex-verbatim-quote-curr-line):
+ Replace yet more uses of end-of-line etc with line-end-position, etc.
-2010-10-31 Eli Zaretskii <eliz@gnu.org>
+2010-11-08 Stefan Monnier <monnier@iro.umontreal.ca>
- * vc/vc-hooks.el (vc-default-mode-line-string): Doc fix.
+ * emacs-lisp/checkdoc.el (checkdoc-display-status-buffer)
+ (checkdoc-interactive-loop, checkdoc-recursive-edit): Avoid princ-list.
+ (checkdoc-syntax-table): Initialize in the declaration.
+ (emacs-lisp-mode-hook): Use just checkdoc-minor-mode now that it turns
+ the mode on unconditionally.
-2010-10-31 Chong Yidong <cyd@stupidchicken.com>
+ * emacs-lisp/cl-macs.el (extent-data, extent-face, extent-priority)
+ (extent-end-position, extent-start-position): Remove setf method for
+ non-existing functions (bug#7319).
- * vc/vc.el (vc-deduce-backend): New fun. Handle diff buffers.
- (vc-root-diff, vc-print-root-log, vc-log-incoming)
- (vc-log-outgoing): Use it.
- (vc-diff-internal): Set diff-vc-backend.
+2010-11-07 Stefan Monnier <monnier@iro.umontreal.ca>
- * vc/diff-mode.el (diff-vc-backend): New var.
+ * emacs-lisp/smie.el: Simplify the smie-rules-function return values.
+ (smie-precs->prec2): Rename from smie-precs-precedence-table.
+ (smie-bnf->prec2): Rename from smie-bnf-precedence-table.
+ (smie-prec2->grammar): Rename from smie-prec2-levels.
+ (smie-grammar): Rename from smie-op-levels.
+ (smie-indent--hanging-p): Rename from smie-hanging-p.
+ (smie-rule-hanging-p): New alias.
+ (smie-indent--bolp): Rename from smie-bolp.
+ (smie-indent--hanging-p): New alias.
+ (smie--token): New dynamically bound variable.
+ (smie-indent--parent): New function.
+ (smie-rule-parent-p): Use it; rename from smie-parent-p.
+ (smie-rule-next-p): Rename from smie-next-p.
+ (smie-rule-prev-p): Rename from smie-prev-p.
+ (smie-rule-sibling-p, smie-rule-parent)
+ (smie-indent--separator-outdent, smie-rule-separator): New functions.
+ (smie-rule-separator-outdent): New var.
+ (smie-indent--rule): Merge with smie-indent--column.
+ (smie-indent-forward-token, smie-indent-backward-token):
+ Also recognize close parens.
+ (smie-indent-keyword): Don't use smie-indent--column any more.
+ (smie-indent-after-keyword): Ignore closers by default.
+ (smie-indent-line): Use with-demoted-errors.
+ * progmodes/octave-mod.el (octave-smie-grammar):
+ Rename from octave-smie-op-levels.
+ (octave-smie-rules): Adjust to new behavior.
+ * progmodes/prolog.el (prolog-smie-grammar):
+ Rename from prolog-smie-op-levels.
+
+2010-11-07 Glenn Morris <rgm@gnu.org>
+
+ * eshell/esh-util.el (subst-char-in-string)
+ (directory-files-and-attributes): These compatibility definitions are
+ not needed on any version of Emacs since at least 21.4.
+
+ * progmodes/verilog-mode.el (verilog-get-beg-of-line)
+ (verilog-get-end-of-line): Remove.
+ (verilog-within-string, verilog-re-search-forward-substr)
+ (verilog-re-search-backward-substr, verilog-set-auto-endcomments)
+ (verilog-surelint-off, verilog-getopt-file, verilog-highlight-region):
+ Use point-at-bol, point-at-eol.
+ * progmodes/pascal.el (pascal-get-beg-of-line, pascal-get-end-of-line):
+ Remove.
+ (pascal-declaration-end, pascal-declaration-beg, pascal-within-string)
+ (electric-pascal-terminate-line, pascal-set-auto-comments)
+ (pascal-indent-paramlist, pascal-indent-declaration)
+ (pascal-get-lineup-indent, pascal-func-completion)
+ (pascal-get-completion-decl, pascal-var-completion, pascal-completion):
+ Use point-at-bol, point-at-eol.
+ * progmodes/flymake.el (flymake-line-beginning-position)
+ (flymake-line-end-position): Remove.
+ (flymake-highlight-line): Use point-at-bol, point-at-eol.
+ * eshell/esh-util.el (line-end-position, line-beginning-position):
+ Remove compat definitions.
+
+ * emacs-lisp/checkdoc.el (checkdoc-this-string-valid-engine):
+ Use end-of-line N.
+ (checkdoc-this-string-valid-engine, checkdoc-file-comments-engine):
+ Use line-end-position.
+
+ * emacs-lisp/chart.el (chart-zap-chars):
+ * play/decipher.el (decipher-set-map):
+ * progmodes/ada-mode.el (ada-get-current-indent)
+ (ada-search-ignore-string-comment, ada-tab-hard, ada-untab-hard):
+ * progmodes/ada-prj.el (ada-prj-load-from-file, ada-prj-display-help):
+ * progmodes/ada-xref.el (ada-initialize-runtime-library)
+ (ada-get-all-references):
+ * progmodes/cperl-mode.el (cperl-electric-paren)
+ (cperl-electric-rparen, cperl-electric-keyword, cperl-electric-else)
+ (cperl-linefeed, cperl-sniff-for-indent, cperl-to-comment-or-eol)
+ (cperl-find-pods-heres, cperl-indent-exp, cperl-fix-line-spacing)
+ (cperl-word-at-point-hard):
+ * progmodes/idlw-shell.el (idlwave-shell-move-or-history)
+ (idlwave-shell-filename-string, idlwave-shell-batch-command)
+ (idlwave-shell-display-line):
+ * progmodes/idlwave.el (idlwave-show-begin, idlwave-fill-paragraph)
+ (idlwave-calc-hanging-indent, idlwave-auto-fill, idlwave-template):
+ * progmodes/js.el (js--re-search-forward-inner)
+ (js--re-search-backward-inner):
+ * progmodes/vhdl-mode.el (vhdl-align-region-1, vhdl-align-region-2)
+ (vhdl-fix-clause, vhdl-compose-configuration-architecture):
+ * progmodes/ruby-mode.el (ruby-parse-partial, eval-when-compile):
+ * textmodes/flyspell.el (flyspell-process-localwords):
+ * textmodes/ispell.el (ispell-buffer-local-parsing)
+ (ispell-buffer-local-dict, ispell-buffer-local-words):
+ Use point-at-bol and point-at-eol.
+
+ * speedbar.el (speedbar-generic-item-info)
+ (speedbar-item-info-tag-helper, speedbar-change-expand-button-char)
+ (speedbar-add-indicator, speedbar-check-vc-this-line)
+ (speedbar-check-obj-this-line, speedbar-extract-one-symbol)
+ (speedbar-buffers-line-directory, speedbar-buffer-revert-buffer):
+ Replace more uses of end-of-line etc with line-end-position.
+
+2010-11-06 Glenn Morris <rgm@gnu.org>
+
+ * textmodes/texnfo-upd.el (texinfo-start-menu-description)
+ (texinfo-update-menu-region-beginning, texinfo-menu-first-node)
+ (texinfo-delete-existing-pointers, texinfo-find-pointer)
+ (texinfo-clean-up-node-line, texinfo-insert-node-lines)
+ (texinfo-multiple-files-update):
+ * textmodes/table.el (table--probe-cell-left-up)
+ (table--probe-cell-right-bottom):
+ * textmodes/picture.el (picture-tab-search):
+ * textmodes/page-ext.el (pages-copy-header-and-position)
+ (pages-directory-for-addresses):
+ * progmodes/vera-mode.el (vera-get-offset):
+ * progmodes/simula.el (simula-calculate-indent):
+ * progmodes/python.el (python-pdbtrack-overlay-arrow):
+ * progmodes/prolog.el (end-of-prolog-clause):
+ * progmodes/perl-mode.el (perl-calculate-indent, perl-indent-exp):
+ * progmodes/icon.el (indent-icon-exp):
+ * progmodes/etags.el (tag-re-match-p):
+ * progmodes/ebrowse.el (ebrowse-show-file-name-at-point):
+ * progmodes/ebnf2ps.el (ebnf-begin-file):
+ * progmodes/dcl-mode.el (dcl-back-to-indentation-1)
+ (dcl-save-local-variable):
+ * play/life.el (life-setup):
+ * play/gametree.el (gametree-looking-at-ply):
+ * nxml/nxml-maint.el (nxml-insert-target-repertoire-glyph-set):
+ * mail/sendmail.el (mail-mode-auto-fill):
+ * emacs-lisp/lisp-mode.el (calculate-lisp-indent):
+ * emacs-lisp/edebug.el (edebug-overlay-arrow):
+ * emacs-lisp/checkdoc.el (checkdoc-this-string-valid):
+ * woman.el (woman-parse-numeric-value, woman2-TH, woman2-SH)
+ (woman-tab-to-tab-stop, WoMan-warn-ignored):
+ * type-break.el (type-break-file-keystroke-count):
+ * term.el (term-replace-by-expanded-history-before-point)
+ (term-skip-prompt, term-extract-string):
+ * speedbar.el (speedbar-edit-line, speedbar-expand-line)
+ (speedbar-contract-line, speedbar-toggle-line-expansion)
+ (speedbar-parse-c-or-c++tag, speedbar-parse-tex-string)
+ (speedbar-buffer-revert-buffer, speedbar-highlight-one-tag-line):
+ * sort.el (sort-skip-fields):
+ * skeleton.el (skeleton-internal-list):
+ * simple.el (line-move-finish, line-move-to-column):
+ * shell.el (shell-forward-command):
+ * misc.el (copy-from-above-command):
+ * makesum.el (double-column):
+ * ebuff-menu.el (electric-buffer-update-highlight):
+ * dired.el (dired-move-to-end-of-filename):
+ * dframe.el (dframe-popup-kludge):
+ * bookmark.el (bookmark-kill-line, bookmark-bmenu-show-filenames):
+ * arc-mode.el (archive-get-lineno):
+ Use line-end-position and line-beginning-position.
+
+ * progmodes/idlwave.el (idlwave-routine-entry-compare-twins):
+ (idlwave-study-twins): Prefix dynamic local `class'.
+ (idlwave-routine-twin-compare): Update for above name change.
+
+ * emacs-lisp/eieio-comp.el (byte-compile-file-form-defmethod):
+ Use boundp tests to silence compiler. Update for changed name of
+ bytecomp-filename variable.
+
+ * emulation/viper-cmd.el (viper-read-string-with-history):
+ Prefix dynamic local `initial'.
+ (viper-minibuffer-standard-hook): Update for above name change.
+
+ * emacs-lisp/elint.el (elint-init-env): Prefix dynamic local `env'.
+ (elint-init-form): Update for above name change.
+
+ * mail/mail-extr.el (mail-extract-address-components): Give dynamic
+ local variables `cbeg' and `cend' a prefix.
+ (mail-extr-voodoo): Update for above name change.
+
+ * textmodes/reftex-toc.el (reftex-toc-do-promote)
+ (reftex-toc-promote-prepare): Pass `delta' as an explicit argument.
+ (reftex-toc-promote-action): Doc fix.
+
+ * textmodes/reftex-sel.el (reftex-select-item): Give local variables
+ `prompt', `data' a prefix.
+ (reftex-select-post-command-hook, reftex-select-callback)
+ (reftex-select-mouse-accept, reftex-select-read-cite):
+ Update for above name changes.
+
+ * textmodes/reftex-ref.el (reftex-reference): Rename local variable
+ `refstyle' to reftex-refstyle.
+ (reftex-offer-label-menu): Update for above name change.
+ * textmodes/reftex-sel.el (reftex-select-toggle-varioref): Update for
+ `refstyle' name change.
+
+ * vc/emerge.el (emerge-eval-in-buffer): Remove, and replace all uses
+ with with-current-buffer.
+ (diff, template): Give dynamic local variables a prefix.
+ (emerge-line-numbers): Rename local `diff' to emerge-line-diff.
+ (emerge-line-number-in-buf): Update for above name change.
+ (emerge-combine-versions-internal): Rename local `template' to
+ emerge-combine-template.
+ (emerge-combine-versions-edit): Update for above name change.
+
+2010-11-06 Ralf Angeli <angeli@caeruleus.net>
+
+ * textmodes/reftex-cite.el
+ (reftex-extract-bib-entries-from-thebibliography): Match bibitem
+ entries with whitespace after \bibitem.
+ (reftex-create-bibtex-file): Match entries containing numbers and
+ symbol constituents. Make sure that entries with whitespace at
+ various places are found.
+
+2010-11-05 Christian Millour <cm@abtela.com> (tiny change)
+
+ * shell.el (shell-process-popd): Made aware of comint-file-name-prefix.
+
+2010-11-05 Jan Djärv <jan.h.d@swipnet.se>
+
+ * mouse.el (mouse-yank-primary): Update comment (Bug#6802).
+
+2010-11-05 Glenn Morris <rgm@gnu.org>
+
+ * woman.el (woman0-roff-buffer, woman1-roff-buffer)
+ (woman2-roff-buffer): Give local variable `request' a prefix.
+ (woman0-macro): Rename argument `request' in the same way.
+ (woman-request): New name for `request' dynamic variable.
+ (woman-unquote, woman-forward-arg): Update for above name change.
+ (woman1-roff-buffer): Give local variable `unquote' a prefix.
+ (woman1-unquote): New name for `unquote' dynamic variable.
+ (woman1-B-or-I, woman1-alt-fonts): Update for above name change.
+ (woman-translations): Rename from `translations'. No longer global.
+ (woman2-tr, woman-translate): Update for above name change.
+ (woman-translate): Check for bound variable.
+ (woman2-roff-buffer): Give local variable `translations' a prefix.
+
+ * play/doctor.el: Give all local variables a prefix. Update callers.
+ (doc$, doctor-put-meaning): Use backquote.
+
+ * emacs-lisp/cl-macs.el (loop): Give local variable args a prefix.
+ (cl-parse-loop-clause, cl-loop-handle-accum): Update for above change.
+
+ * emacs-lisp/byte-opt.el (byte-decompile-bytecode-1): Give local
+ variables bytes, ptr, op a prefix.
+ (disassemble-offset): Update for above change.
+
+2010-11-03 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/package.el (package-unpack): Remove no-op.
+ (package--builtins, package--dir): Doc fix.
+ (package-activate-1, package-activate, package-install)
+ (package-compute-transaction): Fix error message.
+ (package-delete): Use delete-directory. Omit system packages.
+ (package-initialize): Set package-alist to nil first.
+ (package-menu-mark-delete, package-menu-mark-install): Don't add
+ symbols that are inconsistent with the package state.
+ (package-menu-execute): Perform deletions and installations as
+ single batch operations.
-2010-10-31 Juri Linkov <juri@jurta.org>
+2010-11-03 Glenn Morris <rgm@gnu.org>
- * vc/vc.el (vc-diff-internal): Set `revert-buffer-function'
- buffer-locally to lambda that re-runs the vc diff command.
- (Bug#6447)
+ * progmodes/idlwave.el (idlwave-pset): Only used on XEmacs.
+ (props): Remove unnecessary declaration.
-2010-10-31 Dan Nicolaescu <dann@ics.uci.edu>
+ * textmodes/ispell.el (ispell-init-process): On Emacs, always use
+ set-process-query-on-exit-flag.
- * vc/log-view.el (log-view-mode-map): Bind revert-buffer.
+ * textmodes/reftex-toc.el (name1, dummy, dummy2): Remove unused decs.
+ (reftex-toc-do-promote): Remove unused local `mpos'.
+ (reftex-toc-restore-region): Make `mpos' local to this function.
- Make 'g' (AKA revert-buffer) rerun VC log, log-incoming and
- log-outgoing commands.
- * vc/vc.el (vc-log-internal-common): Add a new argument and use it
- to create a buffer local revert-buffer-function variable.
- (vc-print-log-internal, vc-log-incoming, vc-log-outgoing): Pass a
- revert-buffer-function lambda.
+ * net/dbus.el (dbus-name-owner-changed-handler): Doc fix.
- Improve VC create/retrieve tag/branch.
- * vc.el (vc-create-tag): Do not read the directory name for VCs
- with repository revision granularity. Adjust the tag/branch
- prompt. Reset VC properties.
- (vc-retrieve-tag): Do not read the directory name for VCs
- with repository revision granularity. Reset VC properties.
+ * play/landmark.el (lm-losing-threshold): Correct spelling.
+ (lm-human-plays): Use new name.
+
+ * play/gomoku.el (gomoku-loosing-threshold): Correct spelling.
+ (gomoku-human-plays): Use new name.
- Add optional support for resetting VC properties.
- * vc-dispatcher.el (vc-resynch-window): Add new optional argument,
- call vc-file-clearprops when true.
- (vc-resynch-buffer): Add new optional argument, pass it down.
- (vc-resynch-buffers-in-directory): Likewise.
+ * play/gomoku.el (nil-score, Xscore, XXscore, XXXscore, XXXXscore)
+ (Oscore, OOscore, OOOscore, OOOOscore): Rename with gomoku- prefix.
+ (gomoku-score-trans-table, gomoku-winning-threshold)
+ (gomoku-loosing-threshold, gomoku-init-score-table): Use new names.
+
+2010-11-03 Chong Yidong <cyd@stupidchicken.com>
- Improve support for special markup in the VC commit message.
- * vc-mtn.el (vc-mtn-checkin): Support Author: and Date: markup.
- * vc-hg.el (vc-hg-checkin): Add support for Date:.
- * vc-git.el (vc-git-checkin):
- * vc-bzr.el (vc-bzr-checkin): Likewise.
+ * emacs-lisp/package.el: Don't put built-in packages in
+ package-alist, to avoid loading inefficiencies.
+ (package-built-in-p): Make VERSION optional, and treat it as a
+ minimum acceptable version.
+ (package-activate): Search separately for built-in packages.
+ Emit a warning if a dependency fails.
+ (define-package): Handle most common case, where there is no
+ obsolete package, first.
+ (package-compute-transaction): Print required version in error.
+ (package--initialized): New variable.
+ (list-packages): Use it.
+ (package-initialize): Optional arg NO-ACTIVATE. Don't put
+ built-in packages in packages-alist; keep it separate.
+ Set package--initialized.
+ (describe-package): Avoid activating packages as a side-effect.
+ Search separately for built-in packages.
+ (describe-package-1): Handle the case where an elpa package is
+ simultaneously built-in and available/installed.
+ (package-installed-p, package--generate-package-list):
+ Search separately for built-in packages.
+ (package-load-descriptor): Doc fix.
- Add support for vc-log-incoming, improve vc-log-outgoing for Git.
- * vc-git.el (vc-git-log-view-mode): Fix font lock for
- incoming/outgoing logs.
- (vc-git-log-outgoing, vc-git-log-incoming): New functions.
+2010-11-03 Stefan Monnier <monnier@iro.umontreal.ca>
- * vc-git.el (vc-git-log-outgoing): Use the same format as the
- short log.
- (vc-git-log-incoming): Likewise. Run "git fetch" before the log
- command
+ * progmodes/perl-mode.el (perl-syntax-propertize-function):
+ Handle __DATA__ and __END__.
- Add bindings for vc-log-incoming and vc-log-outgoing.
- * vc-hooks.el (vc-prefix-map): Add bindings for vc-log-incoming
- and vc-log-outgoing.
- * vc-dir.el (vc-dir-menu-map): Add menu bindings for vc-log-incoming
- and vc-log-outgoing.
+2010-11-02 Noah Friedman <friedman@splode.com>
- Improve state updating for VC tag commands.
- * vc.el (vc-create-tag, vc-retrieve-tag): Call vc-resynch-buffer
- to update the state of all buffers in the directory.
+ * emacs-lisp/bytecomp.el (byte-recompile-file): If bytecomp-arg is
+ nil, do not ask to recompile files that are not already compiled,
+ and do not recompile them.
-2010-05-19 Glenn Morris <rgm@gnu.org>
+2010-11-02 Chong Yidong <cyd@stupidchicken.com>
- * vc-dir.el (vc-dir): Don't pop-up-windows. (Bug#6204)
+ * emacs-lisp/package.el (package-initialize): Ensure that
+ obsoleted built-in packages are not in package-activated-list
+ during activation.
+ (describe-package-1): Make the "installed" status override
+ "built-in".
-2010-10-31 Stefan Monnier <monnier@iro.umontreal.ca>
+2010-11-01 Vinicius Jose Latorre <viniciusjl@ig.com.br>
- * vc.el (vc-checkin, vc-modify-change-comment):
- Adjust to new vc-start/finish-logentry.
- (vc-find-conflicted-file): New command.
- (vc-transfer-file): Adjust to new vc-checkin.
- (vc-next-action): Improve scoping.
+ * subr.el (version-separator, version-regexp-alist): Remove '*'
+ from docstring.
+ (version-list-<=, version<=, version=): Doc fix.
- * vc-git.el (vc-git-checkin): Use log-edit-extract-headers.
- (vc-git-commits-coding-system): Rename from git-commits-coding-system.
+2010-11-01 Kenichi Handa <handa@m17n.org>
- * vc-dispatcher.el (vc-log-edit): Shorten names for
- log-edit-show-files.
+ * faces.el (glyphless-char): Inherit underline for tty.
- * vc-bzr.el (vc-bzr-checkin): Use log-edit-extract-headers.
- (vc-bzr-conflicted-files): New function.
+2010-11-01 Kenichi Handa <handa@m17n.org>
- * log-edit.el (log-edit-summary, log-edit-header)
- (log-edit-unknown-header): New faces.
- (log-edit-headers-alist): New var.
- (log-edit-header-contents-regexp): New const.
- (log-edit-match-to-eoh): New function.
- (log-edit-font-lock-keywords): Use them.
- (log-edit): Insert a "Summary:" header as default.
- (log-edit-mode): Mark font-lock rules as case-insensitive.
- (log-edit-done): Cleanup headers.
- (log-edit-extract-headers): New function to replace it.
+ Implement various display methods for glyphless characters.
- * vc-dispatcher.el (vc-finish-logentry): Don't mess so badly with
- the windows/frames.
+ * international/characters.el (char-acronym-table): New variable.
+ (glyphless-char-control): New variable.
+ (update-glyphless-char-display): New funciton.
- * vc-bzr.el (vc-bzr-shelve-apply): Don't use *vc-bzr-shelve*.
+ * faces.el (glyphless-char): New face.
- * vc-dir.el (vc-dir-kill-line): New command.
- (vc-dir-mode-map): Bind it to C-k.
- (vc-dir-headers): Abbreviate the working dir.
+2010-11-01 Glenn Morris <rgm@gnu.org>
- * vc-git.el (vc-git-revision-table): Include remote branches.
+ * calendar/holidays.el (general-holidays, oriental-holidays)
+ (local-holidays, other-holidays, hebrew-holidays, christian-holidays)
+ (islamic-holidays, bahai-holidays, solar-holidays): Move aliases before
+ the definitions of their targets.
-2010-10-31 Dan Nicolaescu <dann@ics.uci.edu>
+ * emacs-lisp/smie.el (smie): New custom group.
+ (smie-blink-matching-inners, smie-indent-basic): Add :group.
- New VC methods: vc-log-incoming and vc-log-outgoing.
- * vc.el (vc-print-log-setup-buttons, vc-log-internal-common)
- (vc-incoming-outgoing-internal, vc-log-incoming, vc-log-outgoing):
- New functions.
- (vc-print-log-internal): Just call vc-log-internal-common.
- (vc-log-view-type): New permanent local variable.
+ * faces.el (xw-defined-colors, x-setup-function-keys):
+ * mouse-sel.el (x-select-text):
+ * term/w32console.el (x-setup-function-keys): Update declarations.
- * vc-hooks.el (vc-menu-map): Bind vc-log-incoming and vc-log-outgoing.
+ * progmodes/ruby-mode.el (ruby-syntax-propertize-heredoc): Declare.
- * vc-bzr.el (vc-bzr-log-view-mode): Use vc-log-view-type instead
- of the dynamic bound vc-short-log.
- (vc-bzr-log-incoming, vc-bzr-log-outgoing): New functions.
+ * textmodes/ispell.el (comment-add): Declare.
- * vc-git.el (vc-git-log-outgoing): New function.
- (vc-git-log-view-mode): Use vc-log-view-type instead
- of the dynamic bound vc-short-log.
+ * net/gnutls.el (gnutls-boot, gnutls-errorp, gnutls-error-string):
+ Declare.
- * vc-hg.el (vc-hg-log-view-mode): Use vc-log-view-type instead of
- the dynamic bound vc-short-log. Highlight the tag.
- (vc-hg-log-incoming, vc-hg-log-outgoing): New functions.
- (vc-hg-outgoing, vc-hg-incoming, vc-hg-outgoing-mode):
- (vc-hg-incoming-mode): Remove.
- (vc-hg-extra-menu-map): Do not bind vc-hg-incoming and vc-hg-outgoing.
+ * info.el (finder-keywords-hash, package-alist): Declare.
- Fix default-directory for vc-root-diff.
- * vc.el (vc-root-diff): Bind default-directory to the root
- directory for the diff command.
+2010-11-01 Chong Yidong <cyd@stupidchicken.com>
-2010-10-31 Sam Steingold <sds@gnu.org>
+ * finder.el (finder-compile-keywords): Don't use intern-soft,
+ since package names may not yet exist in the obarray.
- * vc-hg.el (vc-hg-push, vc-hg-pull): Use `apply' when calling
- `vc-hg-command' with a list of flags.
+2010-11-01 Chong Yidong <cyd@stupidchicken.com>
-2010-10-31 Glenn Morris <rgm@gnu.org>
+ * vc/vc-arch.el (vc-arch-checkin):
+ * vc/vc-cvs.el (vc-cvs-checkin):
+ * vc/vc-mtn.el (vc-mtn-checkin):
+ * vc/vc-rcs.el (vc-rcs-checkin):
+ * vc/vc-sccs.el (vc-sccs-checkin):
+ * vc/vc-svn.el (vc-svn-checkin): Remove optional extra arg, unused
+ since 2010-04-21 commit by Stefan Monnier.
- * vc-bzr.el (vc-bzr-log-edit-mode): Add --fixes support to
- log-edit-before-checkin-process.
+2010-11-01 Glenn Morris <rgm@gnu.org>
- * vc.el (vc-modify-change-comment): Pass MODE to vc-start-logentry.
+ * emacs-lisp/bytecomp.el (byte-recompile-file): Fix previous change.
- * vc-bzr.el, vc-hg.el (log-edit-mode): Declare.
+ * startup.el (package-enable-at-startup, package-initialize):
+ Silence compiler.
- * vc-dispatcher.el (vc-start-logentry): Doc fix.
- (log-view-process-buffer, log-edit-extra-flags): Declare.
+ * progmodes/ada-mode.el (ada-font-lock-syntactic-keywords):
+ Silence compiler.
-2010-10-31 Dan Nicolaescu <dann@ics.uci.edu>
+2010-10-31 Julien Danjou <julien@danjou.info>
- Add special markup processing for commit logs.
- * log-edit.el (log-edit): Add new argument MODE. Use that mode
- when non-nil instead of the log-view-mode.
+ * emacs-lisp/bytecomp.el (byte-recompile-file): New fun (bug#7297).
+ (byte-recompile-directory):
+ * emacs-lisp/lisp-mode.el (emacs-lisp-byte-compile-and-load):
+ Use `byte-recompile-file'.
- * vc.el (vc-default-log-edit-mode): New function.
+2010-10-31 Glenn Morris <rgm@gnu.org>
- * vc-dispatcher.el (vc-log-edit): Add a mode argument, pass it to
- log-edit.
+ * cus-start.el: Handle standard values via a keyword.
+ Only set version property if specified.
+ (cursor-in-non-selected-windows, menu-bar-mode)
+ (tool-bar-mode, show-trailing-whitespace):
+ Do not specify standard values.
+ (transient-mark-mode, temporary-file-directory): Use :standard.
- Support for shelving snapshots and for showing shelves.
- * vc-bzr.el (vc-bzr-shelve-show, vc-bzr-shelve-show-at-point)
- (vc-bzr-shelve-apply-and-keep-at-point, vc-bzr-shelve-snapshot):
- New functions.
- (vc-bzr-shelve-map, vc-bzr-shelve-menu-map)
- (vc-bzr-extra-menu-map): Map them.
+2010-10-31 Jan Djärv <jan.h.d@swipnet.se>
-2010-10-30 Michael Albinus <michael.albinus@gmx.de>
+ * term/x-win.el (x-get-selection-value): New function that gets
+ PRIMARY with type as specified in x-select-request-type. (Bug#6802).
+
+2010-10-31 Michael Albinus <michael.albinus@gmx.de>
* net/tramp.el (tramp-handle-insert-file-contents): For root,
preserve owner and group when editing files. (Bug#7289)
-2010-10-29 Glenn Morris <rgm@gnu.org>
+2010-10-31 Glenn Morris <rgm@gnu.org>
* speedbar.el (speedbar-mode):
* play/fortune.el (fortune-in-buffer, fortune):
@@ -468,21 +1305,261 @@
* textmodes/bibtex.el (bibtex-validate, bibtex-validate-globally):
Replace inappropriate uses of toggle-read-only. (Bug#7292)
-2010-10-28 Glenn Morris <rgm@gnu.org>
-
* select.el (x-selection): Mark it as an obsolete alias.
-2010-10-27 Aaron S. Hawley <aaron.s.hawley@gmail.com>
+2010-10-31 Aaron S. Hawley <aaron.s.hawley@gmail.com>
- * add-log.el (find-change-log): Use derived-mode-p rather than
+ * vc/add-log.el (find-change-log): Use derived-mode-p rather than
major-mode (bug#7284).
-2010-10-27 Glenn Morris <rgm@gnu.org>
+2010-10-31 Glenn Morris <rgm@gnu.org>
* menu-bar.el (menu-bar-files-menu): Make it into an actual alias,
rather than just an unused variable that inherits from the real one.
-2010-10-23 Michael McNamara <mac@mail.brushroad.com>
+2010-10-31 Alan Mackenzie <acm@muc.de>
+
+ * progmodes/cc-cmds.el (c-mask-paragraph): Fix an off-by-1 error.
+ This fixes bug #7185.
+
+2010-10-30 Chong Yidong <cyd@stupidchicken.com>
+
+ * startup.el (command-line): Search for package directories, and
+ don't load package.el if none are found.
+
+ * emacs-lisp/package.el (describe-package, list-packages):
+ Call package-initialize if it has not been called yet.
+
+2010-10-30 Alan Mackenzie <acm@muc.de>
+
+ * progmodes/cc-fonts.el (c-font-lock-enum-tail): New function
+ which fontifies the tail of an enum.
+ (c-basic-matchers-after): Insert a call to the above new function.
+ This fixes bug #7264.
+
+2010-10-30 Glenn Morris <rgm@gnu.org>
+
+ * cus-start.el: Add :set properties for minor modes menu-bar-mode,
+ tool-bar-mode, transient-mark-mode. (Bug#7306)
+ Include the :set property in the dumped Emacs.
+
+2010-10-29 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ SMIE: change indent rules format, improve smie-setup.
+ * emacs-lisp/smie.el (smie-precs-precedence-table)
+ (smie-merge-prec2s, smie-bnf-precedence-table, smie-prec2-levels):
+ Mark them pure so the tables gets built at compile time.
+ (smie-bnf-precedence-table): Store the closer-alist in the table.
+ (smie-prec2-levels): Preserve the closer-alist.
+ (smie-blink-matching-open): Be more forgiving in case of indentation.
+ (smie-hanging-p): Rename from smie-indent--hanging-p.
+ (smie-bolp): Rename from smie-indent--bolp.
+ (smie--parent, smie--after): New dynamic vars.
+ (smie-parent-p, smie-next-p, smie-prev-p): New funs.
+ (smie-indent-rules): Remove.
+ (smie-indent--offset-rule): Remove fun.
+ (smie-rules-function): New var.
+ (smie-indent--rule): New fun.
+ (smie-indent--offset, smie-indent-keyword, smie-indent-after-keyword)
+ (smie-indent-exps): Use it.
+ (smie-setup): Setup paren blinking; add keyword args for token
+ functions; extract closer-alist from op-levels.
+ (smie-indent-debug-log): Remove var.
+ (smie-indent-debug): Remove fun.
+ * progmodes/prolog.el (prolog-smie-indent-rules): Remove.
+ (prolog-smie-rules): New fun to replace it.
+ (prolog-mode-variables): Simplify.
+ * progmodes/octave-mod.el (octave-smie-closer-alist): Remove, now that
+ it's setup automatically.
+ (octave-smie-indent-rules): Remove.
+ (octave-smie-rules): New fun to replace it.
+ (octave-mode): Simplify.
+
+2010-10-29 Glenn Morris <rgm@gnu.org>
+
+ * files.el (temporary-file-directory): Remove (already defined in C).
+ * cus-start.el: Add temporary-file-directory.
+
+ * abbrev.el (abbrev-mode):
+ * composite.el (auto-composition-mode):
+ * menu-bar.el (menu-bar-mode):
+ * simple.el (transient-mark-mode):
+ * tool-bar.el (tool-bar-mode): Adjust the define-minor-mode calls so
+ that they do not define the associated variables twice.
+ * simple.el (transient-mark-mode): Remove defvar.
+ * composite.el (auto-composition-mode): Make variable auto-buffer-local.
+ * cus-start.el: Add transient-mark-mode, menu-bar-mode, tool-bar-mode.
+ Handle multiple groups, and also custom-delayed-init-variables.
+ * emacs-lisp/easy-mmode.el (define-minor-mode): Doc fix.
+
+2010-10-29 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/pcase.el (pcase): New `string' and `guard' patterns.
+ (pcase-if): Add one minor optimization.
+ (pcase-split-equal): Rename from pcase-split-eq.
+ (pcase-split-member): Rename from pcase-split-memq.
+ (pcase-u1): Add strings to the member optimization.
+ Add `guard' variant of predicates.
+ (pcase-q1): Add string patterns.
+
+2010-10-28 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * vc/log-edit.el (log-edit-rewrite-fixes): State its safety pred.
+
+2010-10-28 Glenn Morris <rgm@gnu.org>
+
+ * term/ns-win.el (global-map, menu-bar-final-items, menu-bar-help-menu):
+ Move menu-bar related settings to ../menu-bar.el.
+ * menu-bar.el (global-map, menu-bar-final-items, menu-bar-help-menu):
+ Move ns-specific settings here from term/ns-win.el.
+
+ * simple.el (x-selection-owner-p): Remove unused declaration.
+
+2010-10-28 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * minibuffer.el (completion-cycling): New var (bug#7266).
+ (minibuffer-complete, completion--do-completion):
+ Use completion--flush-all-sorted-completions.
+ (minibuffer-complete): Only cycle if completion-cycling is set.
+ (completion--flush-all-sorted-completions): Unset completion-cycling.
+ (minibuffer-force-complete): Set completion-cycling.
+ (completion-all-sorted-completions): Move declaration before first use.
+
+2010-10-28 Leo <sdl.web@gmail.com>
+
+ * iswitchb.el (iswitchb-kill-buffer): Avoid `iswitchb-make-buflist'
+ which changes the order of matches seen by users (bug#7231).
+
+2010-10-28 Jes Bodi Klinke <jes@bodi-klinke.dk> (tiny change)
+
+ * progmodes/compile.el (compilation-mode-font-lock-keywords):
+ Don't confuse -omega as "-o mega".
+
+2010-10-27 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * vc/log-edit.el (log-edit-rewrite-fixes): New var.
+ (log-edit-author): New dynamic var.
+ (log-edit-changelog-ours-p, log-edit-insert-changelog-entries): Use it
+ to return the author if different from committer.
+ (log-edit-insert-changelog): Use them to add Author: and Fixes headers.
+
+ * play/landmark.el: Adjust commenting convention.
+ (lm-nil-score): Rename from nil-score.
+ (Xscore, XXscore, XXXscore, XXXXscore, Oscore, OOscore, OOOscore)
+ (OOOOscore): Move into a let in lm-score-trans-table.
+ (lm-winning-threshold, lm-loosing-threshold): Use lm-score-trans-table.
+
+ * electric.el (electric-indent-chars): Autoload.
+ * progmodes/octave-mod.el (octave-mode):
+ * progmodes/ruby-mode.el (ruby-mode): Take advantage of it.
+ (ruby-mode-abbrev-table): Merge initialization and declaration.
+
+2010-10-27 Glenn Morris <rgm@gnu.org>
+
+ * abbrev.el (abbrev-mode): Remove one of the three definitions of this
+ variable.
+
+ * server.el (server-host, server-port, server-auth-dir): Autoload risky.
+
+ * term/ns-win.el: Restore require of cl when compiling.
+ (menu-bar-final-items): Remove non-existent `windows' menu.
+ (ns-handle-nxopen): Optionally handle the temp-case.
+ (ns-handle-nxopentemp): Just call ns-handle-nxopen.
+ (ns-insert-file, ns-find-file): Use `pop'.
+
+2010-10-26 Glenn Morris <rgm@gnu.org>
+
+ * term/common-win.el (xw-defined-colors): Simplify the 'ns case.
+
+2010-10-26 Adrian Robert <Adrian.B.Robert@gmail.com>
+
+ * term/ns-win.el (ns-new-frame, ns-show-prefs): Don't add to
+ global map.
+ * term/common-win.el (x-setup-function-keys): Remove most of the
+ keymappings. Comment on the remaining ones.
+
+2010-10-26 Peter Oliver <p.d.oliver@mavit.org.uk> (tiny change)
+
+ * server.el (server-port): New option. (Bug#854)
+ (server-start): Use server-port.
+
+2010-10-26 Glenn Morris <rgm@gnu.org>
+
+ * term/ns-win.el (ns-version-string): Remove unused declaration.
+ (ns-invocation-args): Change to x-invocation-args.
+ (ns-handle-switch, ns-handle-numeric-switch, ns-handle-iconic)
+ (ns-handle-name-switch, ns-ignore-2-arg): Remove.
+ (ns-handle-nxopen, ns-handle-nxopentemp, ns-ignore-1-arg):
+ Use x-invocation-args instead of ns-invocation-args.
+ (ns-initialize-window-system, handle-args-function-alist):
+ Use x-handle-args instead of ns-handle-args.
+ * term/common-win.el (x-handle-args): Also handle nextstep arguments.
+ * startup.el (command-line-ns-option-alist): Replace
+ ns-handle-name-switch, ns-handle-switch, ns-handle-numeric-switch,
+ ns-handle-iconic with the x- equivalents.
+
+ * term/common-win.el (x-select-enable-clipboard):
+ * term/pc-win.el (x-select-enable-clipboard): Doc fix.
+
+ * term/ns-win.el: No need to require cl when compiling.
+ (x-display-name, x-setup-function-keys, x-select-text, x-colors)
+ (xw-defined-colors): Use the common-win definitions.
+ (ns-alternatives-map): Make it an obsolete alias for x-alternatives-map.
+ (ns-handle-iconic): Make it an alias for x-handle-iconic.
+ * term/common-win.el (x-select-text, x-alternatives-map)
+ (x-setup-function-keys, x-colors, xw-defined-colors): Handle 'ns case.
+ * loadup.el [ns]: Load common-win.
+
+2010-10-26 Daiki Ueno <ueno@unixuser.org>
+
+ * epa-mail.el (epa-mail-encrypt): Handle local-part only
+ recipients; expand mail aliases (Bug#7280).
+
+2010-10-25 Glenn Morris <rgm@gnu.org>
+
+ * term/common-win.el (x-handle-switch): Simplify with pop.
+ Optionally handle numeric switches.
+ (x-handle-numeric-switch): Just call x-handle-switch.
+ (x-handle-initial-switch, x-handle-xrm-switch, x-handle-geometry)
+ (x-handle-name-switch, x-handle-display, x-handle-args):
+ Simplify with pop.
+
+ * term/ns-win.el: Do not require easymenu.
+ (menu-bar-edit-menu) <copy, paste, paste-from-menu, separator-undo>:
+ <spell>: Move adjustments to menu-bar.el.
+ * menu-bar.el (menu-bar-edit-menu) <copy, paste, paste-from-menu>:
+ <separator-undo, spell>: Move ns-win's adjustments here.
+ * loadup.el [ns]: Do not load easymenu.
+
+2010-10-24 Chong Yidong <cyd@stupidchicken.com>
+
+ * image.el (image-checkbox-checked, image-checkbox-unchecked):
+ Delete (Bug#7222).
+
+ * startup.el (fancy-startup-tail): Instead of using inline images,
+ refer to image files from etc/.
+
+ * wid-edit.el (checkbox): Likewise.
+ (widget-image-find): Center image specs.
+
+2010-10-24 Glenn Morris <rgm@gnu.org>
+
+ * term/ns-win.el (x-select-text): Doc fix.
+ * w32-fns.el (x-alternatives-map, x-setup-function-keys)
+ (x-select-text): Move to term/common-win.
+ * term/w32-win.el (xw-defined-colors): Move to common-win.
+ * term/x-win.el (xw-defined-colors, x-alternatives-map)
+ (x-setup-function-keys, x-select-text): Move to common-win.
+ * term/common-win.el (x-select-text, x-alternatives-map)
+ (x-setup-function-keys, xw-defined-colors): Merge x- and w32-
+ definitions here.
+
+2010-10-24 T.V. Raman <tv.raman.tv@gmail.com> (tiny change)
+
+ * net/mairix.el (mairix-searches-mode-map):
+ * mail/mspools.el (mspools-mode-map): Fix 2010-10-10 change.
+
+2010-10-24 Michael McNamara <mac@mail.brushroad.com>
* verilog-mode.el (verilog-directive-re): Make this variable
auto-built for efficiency of execution and updating.
@@ -516,7 +1593,7 @@
(verilog-calc-1): Fix for clocking block in modport
declaration. Reported by Brian Hunter.
-2010-10-23 Wilson Snyder <wsnyder@wsnyder.org>
+2010-10-24 Wilson Snyder <wsnyder@wsnyder.org>
* verilog-mode.el (verilog-auto-inst, verilog-gate-ios)
(verilog-gate-keywords, verilog-read-sub-decls)
@@ -599,63 +1676,316 @@
(verilog-read-sub-decls-expr): Fix AUTOOUTPUT not detecting
submodule connections with replications "{#{a},#{b}}".
+2010-10-24 Juanma Barranquero <lekktu@gmail.com>
+
+ * progmodes/dcl-mode.el (dcl-electric-reindent-regexps):
+ Fix typo in docstring.
+
+2010-10-24 Kenichi Handa <handa@m17n.org>
+
+ * face-remap.el (text-scale-adjust): Call read-event with a proper
+ prompt.
+
+2010-10-24 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/unsafep.el: Don't mark functions that display
+ messages as safe. Suggested by Johan Bockgård.
+
+2010-10-24 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/regexp-opt.el (regexp-opt-group, regexp-opt-charset):
+ Turn comments into docstrings.
+
+ * minibuffer.el (completion--replace): Move point where it belongs
+ when there's a common suffix (bug#7215).
+
+2010-10-24 Chong Yidong <cyd@stupidchicken.com>
+
+ Merge read-color and facemenu-read-color (Bug#7242).
+
+ * faces.el (read-color): Use the completion code from
+ facemenu-read-color. Require match in completion. Doc fix.
+
+ * facemenu.el (facemenu-read-color): Alias for read-color.
+ (facemenu-set-foreground, facemenu-set-background):
+ Use read-color.
+
+ * frame.el (set-background-color, set-foreground-color)
+ (set-cursor-color, set-mouse-color, set-border-color):
+ Use read-color.
+
+2010-10-24 Leo <sdl.web@gmail.com>
+
+ * eshell/em-unix.el (eshell-remove-entries): Use the TRASH
+ argument of delete-file and delete-directory (Bug#7011).
+
+2010-10-24 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/package.el (package-menu-mode-map): Inherit from
+ button-buffer-map.
+
+2010-10-24 Ralf Angeli <angeli@caeruleus.net>
+
+ * emacs-lisp/package.el (package--generate-package-list): Make the
+ *Packages* buffer read-only.
+
+2010-10-24 Alan Mackenzie <acm@muc.de>
+
+ * progmodes/cc-fonts.el (c-font-lock-declarations): Cache the
+ result of `c-beginning-of-decl-1' between invocations of a lambda
+ function (Bug #7265).
+
+2010-10-24 Daiki Ueno <ueno@unixuser.org>
+
+ * epg-config.el (epg-gpg-program): Try to use "gpg2" if "gpg"
+ executable is not available on the system (Bug#7268).
+
+2010-10-24 Glenn Morris <rgm@gnu.org>
+
+ * select.el (selection-coding-system, next-selection-coding-system):
+ Sync doc with C versions.
+
+ * w32-vars.el (x-select-enable-clipboard):
+ * term/x-win.el (x-select-enable-clipboard): Move to common-win.
+ * term/common-win.el (x-select-enable-clipboard): Move here.
+
+ * term/tty-colors.el (tty-defined-color-alist): Remove duplicate
+ definition of C variable.
+
+ * frame.el (show-trailing-whitespace, auto-hscroll-mode)
+ (display-hourglass, hourglass-delay, cursor-in-non-selected-windows):
+ Don't redefine things that are defined in C.
+ * cus-start.el: Also handle :risky, :safe, :set, and :tag.
+ (show-trailing-whitespace, auto-hscroll-mode)
+ (display-hourglass, hourglass-delay, cursor-in-non-selected-windows):
+ Set up the appropriate custom properties.
+
+2010-10-24 Chong Yidong <cyd@stupidchicken.com>
+
+ Bind "C-c ]" to ...
+ * progmodes/f90.el (f90-mode-map): ... f90-insert-end.
+ * nxml/nxml-mode.el (nxml-mode-map): ... nxml-finish-element.
+ * textmodes/tex-mode.el (tex-mode-map): ... latex-close-block.
+ * textmodes/sgml-mode.el (sgml-mode-map): ... sgml-close-tag.
+
2010-10-23 Glenn Morris <rgm@gnu.org>
- * comint.el (comint-password-prompt-regexp):
- Match "enter the password". (Bug#7224)
+ * textmodes/flyspell.el (flyspell-mode): If there was an error,
+ say what it was.
-2010-10-22 Juanma Barranquero <lekktu@gmail.com>
+ * frame.el (auto-hscroll-mode, cursor-in-non-selected-windows):
+ Sync docs with C version.
- * progmodes/dcl-mode.el (dcl-electric-reindent-regexps):
- Fix typo in docstring.
+ * term/ns-win.el (xw-defined-colors):
+ * term/x-win.el (xw-defined-colors): Make docs identical to w32-win.
+
+ * term/pc-win.el (x-select-enable-clipboard):
+ * term/x-win.el (x-select-enable-clipboard):
+ * w32-vars.el (x-select-enable-clipboard): Make doc-strings identical.
+
+ * comint.el (comint-password-prompt-regexp): Make it less vague.
+ Bump version.
+
+ * help-fns.el (doc-file-to-man, doc-file-to-info): New commands.
+
+ * help.el (finder-by-keyword): Remove unnecessary autoload.
+
+2010-10-22 Glenn Morris <rgm@gnu.org>
+
+ * loadup.el: Unconditionally load float-sup.
+ * paren.el (show-paren-delay):
+ * emacs-lisp/float-sup.el:
+ * emulation/cua-base.el (cua-prefix-override-inhibit-delay):
+ * obsolete/lazy-lock.el (lazy-lock-defer-time, lazy-lock-stealth-nice)
+ (lazy-lock-stealth-verbose): Assume float support.
+ * ps-print.el: Assume float support on Emacs.
+ * emacs-lisp/timer.el (timer-next-integral-multiple-of-time):
+ Remove non-float branch.
+
+ * emacs-lisp/autoload.el (batch-update-autoloads): Update for
+ src/Makefile no longer being pre-processed.
+
+2010-10-22 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/find-func.el (find-library): Use test-completion.
+
+2010-10-21 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * newcomment.el (comment-dwim): Fix the intentation in the doc string.
2010-10-21 Michael Albinus <michael.albinus@gmx.de>
- * net/tramp.el (tramp-get-inline-coding): Return `nil' in case of
- errors.
+ * net/tramp-sh.el (tramp-do-file-attributes-with-stat): Do not use
+ space in stat format string.
+ (tramp-send-command): Unset $PS1 when using here documents, in
+ order not to get several prompts.
+ (tramp-get-inline-coding): Return `nil' in case of errors.
- * net/trampver.el: Update release number.
+2010-10-21 Daiki Ueno <ueno@unixuser.org>
-2010-10-20 Kenichi Handa <handa@m17n.org>
+ * hexl.el (hexl-mode, hexl-mode-exit):
+ Tweak revert-buffer-function to inhibit auto-mode-alist (Bug#7252).
+ (hexl-revert-buffer-function): New function.
+ (hexl-before-revert-hook, hexl-after-revert-hook): Abolish.
- * face-remap.el (text-scale-adjust): Call read-event with a proper
- prompt.
+2010-10-19 Alan Mackenzie <acm@muc.de>
-2010-10-19 Michael Albinus <michael.albinus@gmx.de>
+ * progmodes/cc-langs.el (c-type-decl-prefix-key): C++ bit:
+ Move "\(const\|throw\|volatile\)\>" nearer the start of the regexp, so
+ that these keywords aren't wrongly matched as identifiers.
- * net/tramp.el (tramp-do-file-attributes-with-stat)
- (tramp-do-directory-files-and-attributes-with-stat): Use "e0" in
- order to make stat results a float. Patch by Andreas Schwab
- <schwab@linux-m68k.org>.
+ * progmodes/cc-mode.el (c-before-change, c-after-change): Move the
+ setting of c-new-BEG and c-new-END from c-before-change to
+ c-after-change. (Bug#7181)
-2010-10-18 Stefan Monnier <monnier@iro.umontreal.ca>
+2010-10-19 Chong Yidong <cyd@stupidchicken.com>
+
+ * cus-face.el (custom-theme-set-faces): Revert 2010-10-18 change.
+ Don't mark as safe.
+
+ * custom.el (custom-theme-set-variables): Likewise.
+ (load-theme): Add custom-theme-set-faces and
+ custom-theme-set-variables to safe-functions while loading.
+ (custom-enabled-themes): Mark as risky.
+
+2010-10-18 Julien Danjou <julien@danjou.info>
+
+ * bindings.el: Remove end dashes in default mode-line-format.
+
+2010-10-19 Chong Yidong <cyd@stupidchicken.com>
+
+ * bindings.el (global-map): Bind C-d to delete-char and deletechar
+ to delete-forward-char.
+
+ * simple.el (normal-erase-is-backspace-mode): Remap delete to
+ deletechar, and hence delete-forward-char.
+
+2010-10-19 Stefan Monnier <monnier@iro.umontreal.ca>
* repeat.el (repeat): Use read-key (bug#6256).
-2010-10-18 Chong Yidong <cyd@stupidchicken.com>
+2010-10-19 Chong Yidong <cyd@stupidchicken.com>
* emacs-lisp/unsafep.el: Don't mark functions that display
messages as safe. Suggested by Johan Bockgård.
-2010-10-17 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * emacs-lisp/regexp-opt.el (regexp-opt-group, regexp-opt-charset):
- Turn comments into docstrings.
+2010-10-19 Stefan Monnier <monnier@iro.umontreal.ca>
* minibuffer.el (completion--replace): Move point where it belongs
when there's a common suffix (bug#7215).
+2010-10-19 Kenichi Handa <handa@m17n.org>
+
+ * international/characters.el: Add category '|' (word breakable)
+ to fullwidth characters.
+
+2010-10-19 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-sh.el (tramp-do-file-attributes-with-stat)
+ (tramp-do-directory-files-and-attributes-with-stat): Use "e0" in
+ order to make stat results a float. Patch by Andreas Schwab
+ <schwab@linux-m68k.org>.
+
+2010-10-18 Julien Danjou <julien@danjou.info>
+
+ * avoid.el (mouse-avoidance-ignore-p): Ignore mouse when it is
+ hidden by `make-pointer-invisible'.
+
+2010-10-18 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * files.el (locate-file-completion-table): Strip non-matching elements
+ before checking length of list (bug#7238).
+
+2010-10-18 Chong Yidong <cyd@stupidchicken.com>
+
+ * custom.el (custom-theme-set-variables): Mark as a safe function.
+ (load-theme): Check forms using unsafep.
+
+ * cus-face.el (custom-theme-set-faces): Mark as a safe function.
+
+2010-10-17 Agustín Martín <agustin.martin@hispalinux.es>
+
+ * textmodes/ispell.el (ispell-aspell-find-dictionary):
+ Fix aspell data file searching (bug#7230).
+
+2010-10-16 Chong Yidong <cyd@stupidchicken.com>
+
+ * cus-theme.el (custom-theme--migrate-settings): New var.
+ (customize-create-theme): Allow editing the `user' theme.
+ (custom-theme-add-variable, custom-theme-add-var-1)
+ (custom-theme-add-face, custom-theme-add-face-1): Add a checkbox
+ to the front of each variable or face widget.
+ (custom-theme-write): Save theme settings in the correct order.
+ Optionally, remove saved settings from user customizations.
+ (custom-theme-write-variables, custom-theme-write-faces):
+ Save only the checked widgets.
+ (customize-themes): Add a link for migrating custom settings.
+
+ * custom.el (custom-declare-theme, provide-theme):
+ Use custom-theme-name-valid-p.
+ (custom-theme-name-valid-p): Remove checks that are now
+ unnecessary since themes no longer obey load-path.
+
+ * cus-edit.el (custom-variable-value-create): For the simple
+ style, hide documentation string when hidden.
+
+2010-10-16 Chong Yidong <cyd@stupidchicken.com>
+
+ * cus-edit.el (custom-variable, custom-face): Combine the
+ :inhibit-magic and :display-style properties into a single
+ :custom-style property.
+ (custom-toggle-hide-variable, custom-toggle-hide-face):
+ New functions. If hiding an edited value, save it to :shown-value.
+ (custom-variable-value-create, custom-face-value-create): Use them.
+ (custom-magic-reset): Allow magic property to be unset.
+
+ * custom.el: Custom themes no longer use load-path.
+ (custom-theme-load-path): New option. Change built-in theme
+ directory to etc/.
+ (custom-enabled-themes): Add custom-theme-load-path dependency.
+ (custom-theme--load-path): New function.
+ (load-theme, custom-available-themes): Use it.
+
+ * cus-theme.el (describe-theme-1): Use custom-theme--load-path.
+ (customize-themes): Link to custom-theme-load-path variable.
+ (custom-theme-add-var-1, custom-theme-add-face-1): Use the
+ :custom-style property.
+
+ * themes/*.el: Moved to etc/.
+
+2010-10-16 Ralf Angeli <angeli@caeruleus.net>
+
+ * textmodes/reftex-cite.el
+ (reftex-extract-bib-entries-from-thebibliography): Do not move
+ point when searching for \bibitem entries. Match entries with
+ spaces or tabs in front of arguments.
+
+2010-10-16 Chong Yidong <cyd@stupidchicken.com>
+
+ * cus-theme.el (customize-create-theme): Delete overlays after
+ erasing. If given a THEME arg, display only the faces of that arg
+ instead of custom-theme--listed-faces.
+ (custom-theme-variable-menu, custom-theme-variable-action)
+ (custom-variable-reset-theme, custom-theme-delete-variable): Delete.
+ (custom-theme-add-variable, custom-theme-add-face): Apply value
+ from the theme settings, instead of the current value.
+ (custom-theme-add-var-1, custom-theme-add-face-1): New functions.
+ (custom-theme-visit-theme): Allow calling outside theme buffers.
+ (custom-theme-merge-theme): Don't enable the theme when merging.
+ (custom-theme-write-variables, custom-theme-write-faces): Use the
+ :shown-value properties to save buffer values, not global ones.
+ (customize-themes): Display a warning about user customizations.
+
+ * cus-edit.el (custom-variable-value-create)
+ (custom-face-value-create): Obey new special properties
+ :shown-value and :inhibit-magic.
+
2010-10-15 Michael Albinus <michael.albinus@gmx.de>
- * net/tramp.el (tramp-open-connection-setup-interactive-shell):
+ * net/tramp-sh.el (tramp-open-connection-setup-interactive-shell):
Suppress expansion of tabs to spaces. Reported by Dale Sedivec
<dale@codefu.org>.
-2010-10-15 Kenichi Handa <handa@m17n.org>
-
- * international/characters.el: Add category '|' (word breakable)
- to fullwidth characters.
-
2010-10-14 Kenichi Handa <handa@m17n.org>
* mail/rmail.el (rmail-show-message-1): Catch an error of
@@ -665,17 +1995,126 @@
(ps-mule-begin-job): Fix for the case that only ENCODING is set in
a font-spec (bug#7197).
-2010-10-13 Glenn Morris <rgm@gnu.org>
+2010-10-14 Glenn Morris <rgm@gnu.org>
* mail/emacsbug.el (report-emacs-bug): Mention debbugs.gnu.org.
-2010-10-12 Juanma Barranquero <lekktu@gmail.com>
+2010-10-14 Juanma Barranquero <lekktu@gmail.com>
* international/mule.el (define-coding-system):
* international/titdic-cnv.el (quail-cxterm-package-ext-info):
* composite.el (compose-region): Fix typo in docstring.
-2010-10-10 Jan Djärv <jan.h.d@swipnet.se>
+2010-10-14 Chong Yidong <cyd@stupidchicken.com>
+
+ * cus-face.el (custom-theme-set-faces): Call custom-push-theme
+ only after checking the theme-face property.
+
+ * faces.el (face-spec-reset-face): Reset all attributes in one
+ single call to set-face-attribute.
+ (face-spec-match-p): Make it a defsubst.
+ (frame-set-background-mode): New arg KEEP-FACE-SPECS.
+ (x-create-frame-with-faces, tty-create-frame-with-faces)
+ (tty-set-up-initial-frame-faces): Don't recompute face specs in
+ frame-set-background-mode, since they are recomputed immediately
+ afterwards in face-set-after-frame-default.
+ (face-set-after-frame-default): Minor optimization.
+ (cursor): Provide non-trivial defface spec.
+
+ * custom.el (custom-theme-recalc-face): Simplify.
+
+2010-10-14 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc-alg.el (math-var): Rename from `var'.
+ (math-is-polynomial, math-is-poly-rec): Replace `var'
+ with `math-var'.
+
+ * calc/calcalg2.el (math-var): Rename from `var'.
+ (calcFunc-table, math-scan-for-limits): Replace `var'
+ with `math-var'.
+
+2010-10-13 Glenn Morris <rgm@gnu.org>
+
+ * subr.el (last): Deal with dotted lists (reported in bug#7174).
+
+2010-10-13 Stephen Berman <stephen.berman@gmx.net>
+
+ * subr.el (last): Use `safe-length' instead of `length' (bug#7206).
+
+2010-10-13 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * net/tls.el (tls-program): Remove spurious %s from openssl.
+ (tls-starttls-switches): Remove starttls hack.
+ (open-tls-stream): Ditto.
+ (tls-find-starttls-argument): Ditto.
+
+2010-10-13 Juanma Barranquero <lekktu@gmail.com>
+
+ * image.el (image-library-alist): Declare as obsolete alias.
+ (image-type-available-p): Use `dynamic-library-alist'.
+
+ * term/w32-win.el (dynamic-library-alist):
+ Use instead of `image-library-alist'.
+
+2010-10-13 IRIE Shinsuke <irieshinsuke@yahoo.co.jp> (tiny change)
+
+ * subr.el (last): Make it faster. (Bug#7174)
+
+2010-10-13 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> (tiny change)
+
+ * Makefile.in (compile-clean): Use `` instead of $(). (Bug#7178)
+
+2010-10-12 Chong Yidong <cyd@stupidchicken.com>
+
+ * cus-theme.el (custom-theme--listed-faces): Add cursor face.
+ (describe-theme-1): Extract doc from unloaded themes.
+
+ * custom.el (custom-theme-name-valid-p): Don't list color-themes.
+
+ * themes/tango-theme.el:
+ * themes/tango-dark-theme.el:
+ * themes/wheatgrass-theme.el: New files.
+
+2010-10-12 Chong Yidong <cyd@stupidchicken.com>
+
+ * cus-theme.el (describe-theme, customize-themes)
+ (custom-theme-save): New commands.
+ (custom-new-theme-mode-map): Bind C-x C-s.
+ (custom-new-theme-mode): Use custom--initialize-widget-variables.
+ (customize-create-theme): New optional arg THEME.
+ (custom-theme-revert): Use it.
+ (custom-theme-visit-theme): Remove dead code.
+ (custom-theme-merge-theme): Use custom-available-themes.
+ (custom-theme-write): Make interactive.
+ (custom-theme-write): Use custom-theme-name-valid-p.
+ (describe-theme-1, custom-theme-choose-revert)
+ (custom-theme-checkbox-toggle, custom-theme-selections-toggle):
+ New funs.
+ (custom-theme-allow-multiple-selections): New option.
+ (custom-theme-choose-mode): New major mode.
+
+ * custom.el (custom-theme-set-variables): Remove dead code.
+ Obey custom--inhibit-theme-enable.
+ (custom--inhibit-theme-enable): New var.
+ (provide-theme): Obey it.
+ (load-theme): Replace load with manual read/eval, in order to
+ check for correctness. Use custom-theme-name-valid-p.
+ (custom-theme-name-valid-p): New function.
+ (custom-available-themes): Use it.
+
+ * cus-edit.el (custom--initialize-widget-variables): New function.
+ (Custom-mode): Use it.
+
+ * cus-face.el (custom-theme-set-faces): Remove dead code.
+ Obey custom--inhibit-theme-enable.
+
+ * help-mode.el (help-theme-def, help-theme-edit): New buttons.
+
+2010-10-12 Juanma Barranquero <lekktu@gmail.com>
+
+ * net/telnet.el (telnet-mode-map): Fix previous change (bug#7193).
+
+2010-10-12 Jan Djärv <jan.h.d@swipnet.se>
* term/ns-win.el (ns-right-alternate-modifier): New defvar.
(ns-right-option-modifier): New alias for ns-right-alternate-modifier.
@@ -683,22 +2122,12 @@
* cus-start.el (all): ns-right-alternate-modifier is new.
-2010-10-10 Andreas Schwab <schwab@linux-m68k.org>
-
- * Makefile.in (ELCFILES): Update.
-
-2010-10-09 Stefan Monnier <monnier@iro.umontreal.ca>
+2010-10-12 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/lisp.el (lisp-completion-at-point):
Use emacs-lisp-mode-syntax-table for the whole function.
-2010-10-09 Richard Sharman <richard_sharman@mitel.com> (tiny change)
-
- * progmodes/gdb-ui.el (gdb-mouse-toggle-breakpoint-margin)
- (gdb-mouse-toggle-breakpoint-fringe): Correct regexp to
- work when breakpoint number exceeds nine.
-
-2010-10-05 David Koppelman <koppel@ece.lsu.edu>
+2010-10-12 David Koppelman <koppel@ece.lsu.edu>
* hi-lock.el (hi-lock-font-lock-hook): Check font-lock-fontified
instead of font-lock-mode before adding keywords.
@@ -706,7 +2135,7 @@
(hi-lock-set-pattern): Only add keywords if font-lock-fontified
non-nil; removed hook inhibit hack.
-2010-10-09 Glenn Morris <rgm@gnu.org>
+2010-10-12 Glenn Morris <rgm@gnu.org>
* emacs-lisp/shadow.el (find-emacs-lisp-shadows): Rename it...
(load-path-shadows-find): ... to this.
@@ -714,6 +2143,150 @@
* mail/mail-utils.el (mail-mbox-from): Also try return-path.
+2010-10-11 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * mail/hashcash.el, net/imap.el, pgg-parse.el, pgg.el:
+ Fix comment for declare-function.
+
+2010-10-11 Chong Yidong <cyd@stupidchicken.com>
+
+ * custom.el (custom-fix-face-spec): New function; code moved from
+ custom-face-edit-fix-value.
+ (custom-push-theme): Use it when checking if a face has been
+ changed outside customize.
+ (custom-available-themes): New function.
+ (load-theme): Use it.
+
+ * cus-edit.el (custom-face-edit-fix-value): Use custom-fix-face-spec.
+
+ * custom.el (custom-push-theme): Cleanup (use cond).
+ (disable-theme): Recompute the saved-face property.
+ (custom-theme-recalc-face): Follow face alias before setting prop.
+
+ * image.el (image-checkbox-checked, image-checkbox-unchecked):
+ New variables, containing checkbox images.
+
+ * startup.el (fancy-startup-tail):
+ * wid-edit.el (checkbox): Use them.
+
+2010-10-10 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * shell.el (shell-mode-map):
+ * progmodes/modula2.el (m2-mode-map):
+ * progmodes/inf-lisp.el (inferior-lisp-mode-map):
+ * play/mpuz.el (mpuz-mode-map):
+ * play/landmark.el (lm-mode-map):
+ * play/decipher.el (decipher-mode-map):
+ * play/5x5.el (5x5-mode-map):
+ * net/telnet.el (telnet-mode-map):
+ * net/quickurl.el (quickurl-list-mode-map):
+ * net/mairix.el (mairix-searches-mode-map):
+ * net/eudc-hotlist.el (eudc-hotlist-mode-map):
+ * net/dig.el (dig-mode-map):
+ * mail/mspools.el (mspools-mode-map):
+ * hexl.el (hexl-mode-map):
+ * emulation/ws-mode.el (wordstar-C-k-map, wordstar-mode-map)
+ (wordstar-C-o-map, wordstar-C-q-map):
+ * emacs-lisp/edebug.el (edebug-eval-mode-map):
+ * emacs-lisp/chart.el (chart-map):
+ * edmacro.el (edmacro-mode-map):
+ * erc/erc-list.el (erc-list-menu-mode-map):
+ * array.el (array-mode-map): Declare and define in one step.
+
+ * vc/log-view.el (log-view-mode-map): Bind revert-buffer.
+
+2010-10-10 Daiki Ueno <ueno@unixuser.org>
+
+ * epa.el (epa-passphrase-callback-function): Display filename
+ passed as the 3rd arg.
+ * epa-file.el (epa-file-passphrase-callback-function):
+ Pass filename to epa-passphrase-callback-function.
+
+2010-10-09 Chong Yidong <cyd@stupidchicken.com>
+
+ * cus-edit.el (custom-face-widget-to-spec)
+ (custom-face-get-current-spec, custom-face-state): New functions.
+ (custom-face-set, custom-face-mark-to-save)
+ (custom-face-value-create, custom-face-state-set): Use them.
+
+ * cus-theme.el (custom-theme--listed-faces): New var.
+ (customize-create-theme): Use *Custom Theme* as the buffer name.
+ Set revert-buffer-function. Optional arg BUFFER. Insert all
+ faces listed in custom-theme--listed-faces.
+ (custom-theme-revert): New function.
+ (custom-theme-add-variable, custom-theme-add-face): Insert at the
+ bottom of the list.
+ (custom-theme-write): Prompt for theme name if empty.
+ (custom-theme-write-variables): Use dolist.
+ (custom-theme-write-faces): Handle hidden (collapsed) widgets.
+
+2010-10-09 Alan Mackenzie <acm@muc.de>
+
+ Enhance fontification of declarators to take account of the
+ presence/absence of "typedef".
+
+ * cc-engine.el (c-forward-type): New &optional param
+ "brace-block-too".
+ (c-forward-decl-or-cast-1): cdr of return value now indicates the
+ presence of either or both of a "struct"-like keyword and "typedef".
+
+ * cc-fonts.el (c-complex-decl-matchers): Remove the heuristic
+ fontification of declarators which follow a "}".
+ (c-font-lock-declarations): Fontify declarators according to the
+ presence/absence of "typedef".
+
+ * cc-langs.el (c-typedef-kwds c-typedef-key): New lang variable
+ for "typedef".
+ (c-typedef-decl-key): New lang variable built from
+ c-typedef-decl-kwds.
+
+2010-10-09 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * ibuffer.el (ibuffer-mode-map): Don't redefine the cursor keys,
+ since that's too annoying. Move the filter groups commands to
+ TAB/backtab.
+
+ * epa.el (epa-passphrase-callback-function): Say what we're
+ querying the password for.
+
+ * ibuffer.el (ibuffer-visit-buffer): To mimick list-buffers
+ behaviour, don't bury the ibuffer buffer when visiting other buffers.
+
+2010-10-08 Chong Yidong <cyd@stupidchicken.com>
+
+ * cus-edit.el (custom-commands, custom-buffer-create-internal)
+ (custom-magic-value-create): Pad button tags with spaces.
+ (custom-face-edit): New variable.
+ (custom-face-value-create): Determine whether to use the usual
+ face editor here, instead of using custom-face-selected.
+ Pass face defaults to custom-face-edit widget.
+ (custom-face-selected, custom-display-unselected): Delete widgets.
+ (custom-display-unselected-match): Function removed.
+ (custom-face-set, custom-face-mark-to-save):
+ Accept custom-face-edit widgets as the direct widget child.
+
+ * wid-edit.el (widget--completing-widget): New var.
+ (widget-default-complete): Bind it when doing completion.
+ (widget-string-complete, widget-file-complete): Use it.
+
+2010-10-09 Glenn Morris <rgm@gnu.org>
+
+ * calendar/cal-hebrew.el (holiday-hebrew-rosh-hashanah)
+ (holiday-hebrew-passover, holiday-hebrew-tisha-b-av)
+ (holiday-hebrew-misc): Small simplifications.
+
+ * emacs-lisp/authors.el (authors-valid-file-names): Add b2m.c.
+
+ * net/browse-url.el: Don't require thingatpt, term, dired,
+ executable, or w3-auto when compiling.
+ (dired-get-filename, term-char-mode, term-send-down, term-send-string):
+ Declare.
+ (browse-url-text-emacs): Require term.
+
+2010-10-08 Andreas Schwab <schwab@linux-m68k.org>
+
+ * net/browse-url.el (browse-url-xdg-open): Remove use of /bin/sh.
+
2010-10-08 Glenn Morris <rgm@gnu.org>
* emacs-lisp/cl-compat.el, emacs-lisp/lmenu.el: Move to obsolete/.
@@ -725,7 +2298,7 @@
(load-path-shadows-same-file-or-nonexistent): New name for the old
shadow-same-file-or-nonexistent.
-2010-10-03 Chong Yidong <cyd@stupidchicken.com>
+2010-10-08 Chong Yidong <cyd@stupidchicken.com>
* minibuffer.el (completion--some, completion--do-completion)
(minibuffer-complete-and-exit, minibuffer-completion-help)
@@ -734,31 +2307,449 @@
(completion-pcm--find-all-completions): Use lexical-let to
avoid some false matches in variable completion (Bug#7056)
-2010-10-03 Olof Ohlsson Sax <olof.ohlsson.sax@gmail.com> (tiny change)
+2010-10-08 Olof Ohlsson Sax <olof.ohlsson.sax@gmail.com> (tiny change)
* vc-svn.el (vc-svn-merge-news): Use --non-interactive. (Bug#7152)
-2010-10-03 Leo <sdl.web@gmail.com>
+2010-10-08 Leo <sdl.web@gmail.com>
* dnd.el (dnd-get-local-file-name): If MUST-EXIST is non-nil, only
return non-nil if the file exists (Bug#7090).
-2010-09-30 Stefan Monnier <monnier@iro.umontreal.ca>
+2010-10-08 Stefan Monnier <monnier@iro.umontreal.ca>
* minibuffer.el (completion--replace):
Better preserve markers (bug#7138).
-2010-09-29 Juanma Barranquero <lekktu@gmail.com>
+2010-10-08 Juanma Barranquero <lekktu@gmail.com>
* server.el (server-process-filter): Doc fix.
-2010-09-27 Drew Adams <drew.adams@oracle.com>
+2010-10-08 Drew Adams <drew.adams@oracle.com>
* dired.el (dired-save-positions): Doc fix. (Bug#7119)
-2010-09-27 Andreas Schwab <schwab@linux-m68k.org>
+2010-10-08 Glenn Morris <rgm@gnu.org>
- * Makefile.in (ELCFILES): Update.
+ * vc/ediff-wind.el (ediff-setup-control-frame):
+ * vc/ediff-ptch.el (ediff-default-backup-extension):
+ * vc/ediff-diff.el (ediff-shell, ediff-diff-options)
+ (ediff-exec-process): Remove system-types emx, windows-95.
+
+ * net/browse-url.el (browse-url-xdg-open): Shell-quote url. (Bug#7166)
+
+2010-10-07 Chong Yidong <cyd@stupidchicken.com>
+
+ * cus-edit.el (custom-variable, custom-face): Doc fix.
+ (custom-face-edit): Add value-create attribute.
+ (custom-face-edit-value-create)
+ (custom-face-edit-value-visibility-action): New functions.
+ Hide unused face attributes by default, and add a visibility toggle.
+ (custom-face-edit-deactivate): Show empty values with shadow face.
+ (custom-face-selected): Only use this for face specs with default
+ attributes.
+ (custom-face-value-create): Cleanup.
+
+ * wid-edit.el (widget-checklist-value-create): Use dolist.
+ (widget-checklist-match-find): Make second arg optional.
+
+2010-10-07 Glenn Morris <rgm@gnu.org>
+
+ * hilit-chg.el (hilit-chg-get-diff-info, hilit-chg-get-diff-list-hk):
+ Prefix things.
+
+ * emacs-lisp/shadow.el (shadow-font-lock-keywords)
+ (load-path-shadows-mode, list-load-path-shadows): Rename shadow-mode to
+ load-path-shadows-mode, update references.
+ (load-path-shadows-font-lock-keywords, load-path-shadows-find-file):
+ Rename variable and button.
+ (list-load-path-shadows): Update button caller.
+
+2010-10-07 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/smie.el (smie-bnf-classify): New function.
+ (smie-bnf-precedence-table): Use it to remember the closers/openers.
+ (smie-merge-prec2s): Handle those new entries.
+ (smie-prec2-levels): Only set precedence to nil for actual
+ openers/closers.
+ * progmodes/octave-mod.el (octave-smie-op-levels): Remove dummy entry
+ that is now unnecessary.
+
+2010-10-07 Miles Bader <miles@gnu.org>
+
+ * emacs-lisp/regexp-opt.el (regexp-opt): Add `symbols' mode.
+
+2010-10-07 Glenn Morris <rgm@gnu.org>
+
+ * mail/rmail.el (mail-sendmail-delimit-header, mail-header-end)
+ (mail-position-on-field): Remove declarations.
+ (mail-position-on-field): Autoload it.
+ (rmail-retry-failure): Replace use of mail-sendmail-delimit-header
+ and mail-header-end. Don't require sendmail.
+
+ * emacs-lisp/shadow.el (shadow-font-lock-keywords): New variable.
+ (shadow-mode): New mode.
+ (shadow-find-file): New button.
+ (list-load-path-shadows): Use shadow-mode and buttons.
+
+ * iimage.el (iimage-version): Remove.
+ (iimage-mode-image-search-path, iimage-mode-image-regex-alist):
+ Turn into defcustoms.
+ (iimage-mode-map): Give it a doc string.
+
+ * calendar/appt.el (appt-activate): Give a warning rather than an error
+ if there is no diary-file.
+
+2010-10-06 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-sh.el (tramp-sh-file-name-handler-alist):
+ Use `tramp-handle-find-backup-file-name'.
+
+2010-10-06 Glenn Morris <rgm@gnu.org>
+
+ * font-core.el (font-lock-defaults-alist): Remove variable.
+ (font-lock-mode): Doc fix.
+ (font-lock-default-function): Do not consult font-lock-defaults-alist.
+ * font-lock.el (font-lock-refresh-defaults): Doc fix.
+ (font-lock-set-defaults): Doc fix.
+ Do not consult font-lock-defaults-alist.
+
+ * hilit-chg.el (hilit-chg-get-diff-list-hk): Declare `e' for compiler.
+
+ * emacs-lisp/cl.el: No longer provide cl-19.
+
+2010-10-05 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-handle-directory-files-and-attributes)
+ (tramp-handle-file-exists-p, tramp-handle-file-newer-than-file-p):
+ New defuns, taken from tramp-smb.el.
+ (tramp-coding-system-change-eol-conversion)
+ (tramp-set-process-query-on-exit-flag): Remove.
+
+ * net/tramp-compat.el (top): Do not check for byte-compiler objects.
+ (tramp-compat-coding-system-change-eol-conversion)
+ (tramp-compat-set-process-query-on-exit-flag): New defuns, taken
+ from tramp.el.
+
+ * net/tramp-gvfs.el:
+ * net/tramp-gw.el: Replace `tramp-set-process-query-on-exit-flag'
+ by `tramp-compat-set-process-query-on-exit-flag'.
+
+ * net/tramp-imap.el (tramp-imap-file-name-handler-alist):
+ Use `tramp-handle-directory-files-and-attributes',
+ `tramp-handle-file-exists-p' and
+ `tramp-handle-file-newer-than-file-p'.
+ (tramp-imap-handle-file-exists-p)
+ (tramp-imap-handle-file-executable-p)
+ (tramp-imap-handle-file-readable-p)
+ (tramp-imap-handle-directory-files-and-attributes)
+ (tramp-imap-handle-file-newer-than-file-p): Remove.
+
+ * net/tramp-sh.el: Replace `tramp-set-process-query-on-exit-flag'
+ by `tramp-compat-set-process-query-on-exit-flag' and
+ `tramp-coding-system-change-eol-conversion' by
+ `tramp-compat-coding-system-change-eol-conversion'.
+
+ * net/tramp-smb.el (tramp-smb-file-name-handler-alist):
+ Use `tramp-handle-directory-files-and-attributes',
+ `tramp-handle-file-exists-p' and
+ `tramp-handle-file-newer-than-file-p'.
+ (tramp-smb-handle-directory-files-and-attributes)
+ (tramp-smb-handle-file-exists-p)
+ (tramp-smb-handle-file-newer-than-file-p): Remove.
+ (tramp-smb-maybe-open-connection):
+ Replace `tramp-set-process-query-on-exit-flag' by
+ `tramp-compat-set-process-query-on-exit-flag'.
+
+2010-10-05 Glenn Morris <rgm@gnu.org>
+
+ * obsolete/rnews.el, obsolete/rnewspost.el: Remove files.
+
+2010-10-04 Michael Albinus <michael.albinus@gmx.de>
+
+ Continue reorganization of load dependencies. (Bug#7156)
+
+ * net/tramp.el (tramp-handle-file-local-copy-hook)
+ (tramp-delete-temp-file-function): Move down.
+ (tramp-exists-file-name-handler): Move up.
+ (tramp-register-file-name-handlers): Simplify autoload.
+ (tramp-handle-write-region-hook, tramp-handle-directory-file-name)
+ (tramp-handle-directory-files, tramp-handle-dired-uncache)
+ (tramp-handle-file-modes, tramp-handle-file-name-as-directory)
+ (tramp-handle-file-name-completion)
+ (tramp-handle-file-name-directory)
+ (tramp-handle-file-name-nondirectory, tramp-handle-file-regular-p)
+ (tramp-handle-file-remote-p, tramp-handle-file-symlink-p)
+ (tramp-handle-find-backup-file-name)
+ (tramp-handle-insert-file-contents, tramp-handle-load)
+ (tramp-handle-substitute-in-file-name)
+ (tramp-handle-unhandled-file-name-directory)
+ (tramp-mode-string-to-int, tramp-local-host-p)
+ (tramp-make-tramp-temp-file): Move from tramp-sh.el.
+
+ * net/tramp-gvfs.el (top):
+ * net/tramp-smb.el (top): Do not require 'tramp-sh.
+
+ * net/tramp-sh.el (all): Move several objects to tramp.el, see
+ there. Rename `tramp-handle-*' to `tramp-sh-handle-*'.
+
+2010-10-04 Glenn Morris <rgm@gnu.org>
+
+ * calendar/appt.el (appt-add): Ensure reminders are enabled.
+ (appt-activate): Give status messages.
+
+2010-10-03 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * net/gnutls.el: Improve docs. Remove starttls and ssl emulation.
+ Provide only `open-gnutls-stream' (formerly `open-ssl-stream') and
+ `gnutls-negotiate' (formerly `starttls-negotiate').
+ Remove trivial wrapper `starttls-open-stream'.
+
+2010-10-03 Dan Nicolaescu <dann@ics.uci.edu>
+
+ Make 'g' (AKA revert-buffer) rerun the VC log, log-incoming and
+ log-outgoing commands.
+ * vc/vc.el (vc-log-internal-common): Add a new argument and use it
+ to create a buffer local revert-buffer-function variable.
+ (vc-print-log-internal, vc-log-incoming, vc-log-outgoing): Pass a
+ revert-buffer-function lambda.
+
+2010-10-03 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * net/gnutls.el (starttls-negotiate): Use the plist interface to
+ `gnutls-boot'. Make TYPE the only required parameter.
+ Allow TRUSTFILES and KEYFILES to be lists.
+ (open-ssl-stream): Use it.
+
+2010-10-03 Glenn Morris <rgm@gnu.org>
+
+ * subr.el (directory-sep-char): Remove obsolete variable.
+ * net/tramp-compat.el: Don't mess about with the byte-compiler unless
+ it is "necessary".
+
+ * vc/vc-hooks.el (vc-header-alist): Remove obsolete variable.
+ * vc/vc.el (vc-static-header-alist): Doc fix.
+ * vc/vc-cvs.el (vc-cvs-header):
+ * vc/vc-rcs.el (vc-rcs-header):
+ * vc/vc-sccs.el (vc-sccs-header):
+ * vc/vc-svn.el (vc-svn-header): Do not consult vc-header-alist.
+ * obsolete/vc-mcvs.el (vc-mcvs-header):
+ * progmodes/cperl-mode.el (cperl-mode): Only set vc-header-alist
+ on XEmacs.
+
+2010-10-03 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/bytecomp.el (byte-compile-from-buffer):
+ Remove obsolete use of binary-overwrite-mode (Bug#7001).
+
+2010-10-03 Glenn Morris <rgm@gnu.org>
+
+ * obsolete/x-menu.el: Remove file, obsolete since 21.1
+
+ * textmodes/rst.el (rst-font-lock-keywords-function):
+ Drop Emacs 20 code.
+
+ * textmodes/artist.el (artist-replace-char): Drop Emacs 20 code.
+
+ * printing.el: Drop Emacs 20 code.
+
+ * calendar/appt.el (appt-delete): Don't autoload it (you can't use it
+ without having used appt.el already).
+
+ * subr.el (make-local-hook): Remove function obsolete since 21.1.
+ * progmodes/cc-mode.el (make-local-hook): Don't do cc-bytecomp stuff.
+ (c-basic-common-init, c-font-lock-init): Only call make-local-hook on
+ XEmacs.
+ * progmodes/cc-styles.el (make-local-hook): Don't do cc-bytecomp stuff.
+ (c-make-styles-buffer-local): Only call make-local-hook on XEmacs.
+
+ * ps-def.el (leading-code-private-22, charset-bytes, charset-id)
+ (charset-width, find-charset-region, chars-in-region, forward-point)
+ (encode-coding-string, coding-system-p, ccl-execute-on-string)
+ (define-ccl-program, multibyte-string-p, string-make-multibyte):
+ Remove compatibility cruft (none of these are used by ps*.el).
+
+2010-10-03 Kevin Rodgers <kevin.d.rodgers@gmail.com>
+
+ * subr.el (booleanp): Return t instead of a list (Bug#7086).
+
+2010-10-03 Chong Yidong <cyd@stupidchicken.com>
+
+ * server.el (server-process-filter, server-return-error):
+ Give emacsclient time to shut down after receiving an error string.
+
+2010-10-02 Michael Albinus <michael.albinus@gmx.de>
+
+ * files.el (remote-file-name-inhibit-cache): New defcustom.
+
+ * time.el (display-time-file-nonempty-p):
+ Use `remote-file-name-inhibit-cache'.
+
+ * net/tramp.el (tramp-completion-reread-directory-timeout):
+ Fix docstring.
+
+ * net/tramp-cache.el (tramp-cache-inhibit-cache): Remove.
+ (tramp-get-file-property): Replace `tramp-cache-inhibit-cache' by
+ `remote-file-name-inhibit-cache'. Check also for an integer
+ value. Add/increase counter when `tramp-verbose' >= 10.
+ (tramp-set-file-property): Add/increase counter when
+ `tramp-verbose' >= 10.
+
+ * net/tramp-cmds.el (tramp-cleanup-all-connections)
+ (tramp-cleanup-all-buffers): Set tramp-autoload cookie.
+ (tramp-bug): Set tramp-autoload cookie. Report all interned
+ tramp-* variables. Report also `remote-file-name-inhibit-cache'.
+ (tramp-reporter-dump-variable): Fix docstring. Mask non-7bit
+ characters only in strings.
+
+ * net/tramp-compat.el (remote-file-name-inhibit-cache): Define due
+ to backward compatibility.
+
+ * net/tramp-sh.el (tramp-handle-verify-visited-file-modtime)
+ (tramp-handle-file-name-all-completions)
+ (tramp-handle-vc-registered): Use `remote-file-name-inhibit-cache'.
+ (tramp-open-connection-setup-interactive-shell):
+ Call `tramp-cleanup-connection' directly.
+
+2010-10-02 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/checkdoc.el (checkdoc-minor-keymap): Remove obsolete alias.
+
+ * subr.el (char-bytes): Remove obsolete function.
+
+ * isearch.el (isearch-return-char): Remove obsolete function.
+
+ * mouse.el: No longer provide mldrag.
+ (mldrag-drag-mode-line, mldrag-drag-vertical-line):
+ Remove obsolete aliases.
+
+ * comint.el (comint-kill-output): Remove obsolete alias.
+
+ * composite.el (decompose-composite-char): Remove obsolete function.
+ * ps-def.el (decompose-composite-char): Remove unused function.
+
+ * iswitchb.el (iswitchb-default-keybindings): Remove obsolete function.
+
+ * outline.el (outline-visible): Remove obsolete function.
+
+ * term/pc-win.el (x-frob-font-slant, x-frob-font-weight):
+ * faces.el (internal-find-face, internal-get-face)
+ (frame-update-faces, frame-update-face-colors)
+ (x-frob-font-weight, x-frob-font-slant)
+ (internal-frob-font-weight, internal-frob-font-slant)
+ (x-make-font-bold, x-make-font-demibold, x-make-font-unbold)
+ (x-make-font-italic, x-make-font-oblique, x-make-font-unitalic)
+ (x-make-font-bold-italic): Remove functions and aliases, obsolete
+ since Emacs 21.1.
+ * emulation/viper-util.el (viper-get-face):
+ * obsolete/lucid.el (find-face, get-face): Use facep.
+ * vc/ediff-init.el (ediff-valid-color-p, ediff-get-face):
+ Remove unused functions.
+ * vc/ediff-util.el (ediff-submit-report): Doc fix.
+
+ * emacs-lisp/bytecomp.el (byte-compile-file): Use kill-emacs-hook to
+ delete tempfile if interrupted during compilation.
+
+2010-10-01 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * net/tls.el (tls-starttls-switches): Give up on using starttls with
+ gnutls-cli.
+ (tls-program): Add --insecure to be consistent with the defaults from
+ openssl s_client. Now all three commands are insecure.
+
+2010-10-01 Eli Zaretskii <eliz@gnu.org>
+
+ * makefile.w32-in (DEST, TAGS, TAGS-LISP, TAGS-nmake)
+ (TAGS-LISP-nmake, TAGS-gmake, TAGS-LISP-gmake, TAGS-SH)
+ (TAGS-LISP-SH, TAGS-CMD, TAGS-LISP-CMD): New targets.
+
+2010-10-01 Glenn Morris <rgm@gnu.org>
+
+ * obsolete/sc.el: Remove file.
+
+ * files.el (temporary-file-directory): On darwin, also try
+ DARWIN_USER_TEMP_DIR (see discussion in bug#7135).
+
+2010-10-01 Juanma Barranquero <lekktu@gmail.com>
+
+ * server.el (server-start): Revert part of 2010-09-30T02:53:26Z!lekktu@gmail.com.
+ Let's not break compatibility gratuitously, shall we?
+
+2010-09-30 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * net/tls.el (tls-starttls-switches): New variable.
+ (tls-find-starttls-argument): Use it.
+ (open-tls-stream): Ditto.
+
+ * net/netrc.el (netrc-credentials): Return the value of the "default"
+ entry.
+ (netrc-machine): Ditto.
+
+2010-09-30 Eli Zaretskii <eliz@gnu.org>
+
+ * vc/vc-hooks.el (vc-default-mode-line-string): Doc fix.
+
+2010-09-30 Juanma Barranquero <lekktu@gmail.com>
+
+ * server.el (server-start): Don't write pid to the authentication file.
+ (server-create-tty-frame): Don't send pid.
+ (server-process-filter): Send pid at the start of every connection.
+
+2010-09-30 Glenn Morris <rgm@gnu.org>
+
+ * calendar/diary-lib.el (view-diary-entries, list-diary-entries)
+ (show-all-diary-entries): Remove obsolete function aliases.
+
+ * calendar/appt.el (appt-issue-message, appt-visible, appt-msg-window):
+ Remove options, obsolete since 22.1.
+ (appt-display-format, appt-display-message):
+ Remove backwards-compatibility code.
+ (appt-check): No longer check appt-issue-message.
+ (appt-make-list): No longer autoload it. Doc fix. No longer
+ activate the package.
+
+2010-09-29 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * net/gnutls.el (starttls-negotiate): Loop a lot longer.
+ (starttls-negotiate): Just call boot, and let the handshake be
+ triggered from the read loop.
+
+2010-09-29 Glenn Morris <rgm@gnu.org>
+
+ * calendar/diary-lib.el (diary-list-entries): Use temp buffers when
+ not displaying the diary.
+ (diary-add-to-list): If no buffer-file-name, fall back to diary-file.
+ * calendar/appt.el (appt-check): No longer need to kill diary.
+
+ * calendar/diary-lib.el (diary-list-entries): Move the
+ "Preparing..." message entirely here.
+ (diary-simple-display, diary-fancy-display): Move "Preparing..."
+ messages to diary-list-entries.
+ (diary-include-other-diary-files): Use LIST-ONLY rather than setting
+ diary-display-function.
+
+ * calendar/diary-lib.el (diary-include-other-diary-files):
+ Trap some recursive includes.
+
+ * calendar/appt.el (appt-activate): Check diary file.
+
+2010-09-29 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * pgg.el (pgg-run-at-time-1): Define it for XEmacs only; fix if/else
+ construction.
+
+ * calendar/time-date.el: No need to require cl for Emacs 21.
+
+2010-09-28 Glenn Morris <rgm@gnu.org>
+
+ * calendar/appt.el (appt-check): Minor simplification.
+
+2010-09-28 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * mail/sendmail.el (mail-citation-prefix-regexp): Remove "}" from
+ citation prefix.
+
+2010-09-27 Andreas Schwab <schwab@linux-m68k.org>
* emacs-lisp/byte-opt.el (byte-optimize-form-code-walker):
Avoid infinite recursion on erroneous lambda form. (Bug#7114)
@@ -775,10 +2766,90 @@
* international/mule-diag.el (describe-character-set): Use princ
with proper print-length and print-level instead of insert.
-2010-09-26 Juanma Barranquero <lekktu@gmail.com>
+2010-09-27 Juanma Barranquero <lekktu@gmail.com>
* window.el (walk-windows): Doc fix (bug#7105).
+2010-09-27 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/float-sup.el (e): Remove.
+
+2010-09-27 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * net/gnutls.el (gnutls, gnutls-log-level): Add group and custom
+ variable.
+ (starttls-negotiate): Use it.
+
+2010-09-27 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * net/gnutls.el (starttls-negotiate): Stop looping when we get a t
+ back.
+
+2010-09-26 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/pcase.el (pcase-let*, pcase-let): plet -> pcase-let.
+
+2010-09-26 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * net/gnutls.el (starttls-negotiate): Avoid the cl.el decf function.
+
+ * net/netrc.el (netrc-store-data): New function.
+
+2010-09-26 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * net/gnutls.el: GnuTLS glue code to set up a connection.
+
+2010-09-25 Julien Danjou <julien@danjou.info>
+
+ * notifications.el: Call dbus-register-signal only if it is bound.
+
+2010-09-25 Glenn Morris <rgm@gnu.org>
+
+ * eshell/em-alias.el, eshell/em-banner.el, eshell/em-basic.el:
+ * eshell/em-cmpl.el, eshell/em-dirs.el, eshell/em-glob.el:
+ * eshell/em-hist.el, eshell/em-ls.el, eshell/em-pred.el:
+ * eshell/em-prompt.el, eshell/em-rebind.el, eshell/em-script.el:
+ * eshell/em-smart.el, eshell/em-term.el, eshell/em-unix.el:
+ * eshell/esh-cmd.el, eshell/esh-ext.el, eshell/esh-io.el:
+ * eshell/esh-mode.el, eshell/esh-proc.el, eshell/esh-test.el:
+ * eshell/esh-util.el, eshell/esh-var.el:
+ Remove leading `*' from docs of faces and defcustoms.
+
+2010-09-25 Ulrich Mueller <ulm@gentoo.org>
+
+ * eshell/em-ls.el (eshell-ls-archive-regexp):
+ * eshell/esh-util.el (eshell-tar-regexp):
+ * ibuffer.el (ibuffer-compressed-file-name-regexp):
+ * info.el (Info-suffix-list):
+ * international/mule.el (auto-coding-alist):
+ * woman.el (woman-file-regexp, woman-file-compression-regexp):
+ * progmodes/etags.el (tags-compression-info-list):
+ Support xz compression.
+
+2010-09-25 Chong Yidong <cyd@stupidchicken.com>
+
+ * files.el (get-free-disk-space): Don't assume the "df" output
+ columns line up (Bug#6995).
+
+2010-09-25 Juanma Barranquero <lekktu@gmail.com>
+
+ * finder.el (finder-unknown-keywords):
+ * progmodes/gdb-mi.el (gdb-jsonify-buffer, gdb-running-threads-count):
+ * progmodes/etags.el (tags-table-including): Fix typos in docstrings.
+
+2010-09-25 Juanma Barranquero <lekktu@gmail.com>
+
+ * server.el (server-start): Revert part of 2010-08-08 change. Using
+ address 127.0.0.1 for local host is now done in Fmake_network_process.
+
+2010-09-24 Glenn Morris <rgm@gnu.org>
+
+ * image-mode.el, progmodes/compile.el, progmodes/gud.el:
+ * progmodes/mixal-mode.el, textmodes/bibtex-style.el:
+ * textmodes/css-mode.el, textmodes/dns-mode.el:
+ Move autoloaded auto-mode-alist entries to files.el.
+ * files.el (auto-mode-alist): Move entries here.
+
2010-09-23 Glenn Morris <rgm@gnu.org>
* isearch.el (isearch-lazy-highlight-cleanup)
@@ -788,12 +2859,12 @@
* net/net-utils.el (ipconfig-program-options):
Move aliases to options before the associated definitions.
-2010-09-21 Stefan Monnier <monnier@iro.umontreal.ca>
+2010-09-23 Stefan Monnier <monnier@iro.umontreal.ca>
* newcomment.el (comment-normalize-vars): Better test validity of
comment-end-skip.
-2010-09-19 Stefan Monnier <monnier@iro.umontreal.ca>
+2010-09-23 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/float-sup.el (float-pi): New name for `pi'.
(float-e): New name for `e'.
@@ -803,7 +2874,7 @@
* textmodes/artist.el (artist-spray-random-points):
* play/bubbles.el (bubbles--initialize-images): Use new names.
-2010-09-19 Eric M. Ludlam <zappo@gnu.org>
+2010-09-23 Eric M. Ludlam <zappo@gnu.org>
Update to CEDET 1.0's version of EIEIO.
@@ -821,7 +2892,7 @@
(eieio-eval-default-p): New function.
(eieio-default-eval-maybe): Use it.
-2010-07-03 Jan Moringen <jan.moringen@uni-bielefeld.de>
+2010-09-23 Jan Moringen <jan.moringen@uni-bielefeld.de>
* emacs-lisp/eieio.el (eieio-defclass): Allow :c3
method-invocation-order.
@@ -838,7 +2909,7 @@
(call-next-method): Stow the replacement argument list for future
call-next-method invocations.
-2010-09-15 Glenn Morris <rgm@gnu.org>
+2010-09-23 Glenn Morris <rgm@gnu.org>
* calendar/appt.el (appt-check): If not displaying the diary,
use (diary 1) to only get the entries we need.
@@ -850,6 +2921,312 @@
* calendar/diary-lib.el (diary-list-entries): Doc fix. (Bug#7019)
+2010-09-23 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/bytecomp.el (byte-compile-file-form-defvar):
+ (byte-compile-defvar, byte-compile-cl-warn):
+ Start warnings with lower-case, like the majority.
+
+ * files.el (auto-mode-alist): Add .xa, .xw, .xsw for ld-script-mode.
+
+ * files.el (auto-mode-alist): Prefer C-mode for .xs. (Bug#7071)
+
+ * progmodes/ld-script.el (auto-mode-alist): Move to files.el.
+ * files.el (auto-mode-alist): Move ld-script entries here, further down
+ the list.
+
+ * vc/add-log.el: Don't require timezone when compiling.
+ (timezone-make-date-sortable): Autoload it.
+ (change-log-sortable-date-at): Don't require timezone.
+ Use `ignore-errors'.
+
+ * comint.el (comint-use-prompt-regexp-instead-of-fields):
+ Move alias before definition, so it does not need autoloading.
+
+ * emulation/crisp.el, emulation/cua-base.el, emulation/edt.el:
+ * emulation/pc-select.el, emulation/vip.el, international/iso-ascii.el:
+ * international/kkc.el, international/ogonek.el, mail/feedmail.el:
+ * net/browse-url.el, net/eudc-vars.el, net/net-utils.el:
+ * net/rcompile.el, net/rlogin.el, textmodes/enriched.el:
+ * textmodes/makeinfo.el, textmodes/page-ext.el, textmodes/picture.el:
+ * textmodes/refer.el, textmodes/spell.el, textmodes/table.el:
+ * textmodes/tex-mode.el, textmodes/two-column.el:
+ Remove leading `*' from docs of defcustoms etc.
+
+2010-09-23 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * net/netrc.el (netrc-parse): Remove encrypt.el mentions.
+
+2010-09-22 Dan Christensen <jdc@uwo.ca>
+
+ * calendar/time-date.el (date-to-time): Try using parse-time-string
+ first before using the slower timezone-make-date-arpa-standard.
+
+2010-09-22 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * calendar/time-date.el (format-seconds): Comment fix.
+
+2010-09-22 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/package.el (package-menu-mode): `revert-buffer-function'
+ is not automatically buffer-local.
+
+2010-09-21 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/smie.el (smie-debug--describe-cycle): Fix typo.
+ (smie-indent-comment): Be more careful with comment-start-skip.
+ (smie-indent-comment-close, smie-indent-comment-inside): New funs.
+ (smie-indent-functions): Use them.
+
+2010-09-21 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/ange-ftp.el (ange-ftp-skip-msgs): Add "^504 ..." message.
+
+2010-09-21 Jan Djärv <jan.h.d@swipnet.se>
+
+ * menu-bar.el (menu-bar-set-tool-bar-position): customize-set-variable
+ tool-bar-position. Don't modify frame parameters here.
+ (menu-bar-options-save): Add tool-bar-position.
+
+ * tool-bar.el (tool-bar-position): New defcustom (Bug#7049).
+
+2010-09-20 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * textmodes/reftex-parse.el (reftex-what-macro)
+ (reftex-context-substring): Let-bind forward-sexp-function to nil
+ since we don't need/want to treat \begin...\end as a block (bug#7053).
+
+ * emacs-lisp/lisp.el (up-list): Don't do nothing silently.
+
+ * simple.el (blink-matching-open): Use syntax-class.
+
+ * progmodes/pascal.el (pascal-mode): Use define-derived-mode.
+ Set invisibility spec for pascal's outline mode.
+ (pascal-outline-change): Clean up calling convention.
+ (pascal-show-all, pascal-hide-other-defuns): Update callers.
+
+ * progmodes/prolog.el (prolog-smie-forward-token)
+ (prolog-smie-backward-token): New functions.
+ (prolog-mode-variables): Use them to parse "!," correctly.
+ Set up smie-blink-matching for ".".
+
+ * textmodes/ispell.el (ispell-start, ispell-end): Rename from `start'
+ and `end'.
+ (ispell-region, ispell-process-line): Update users.
+
+ * textmodes/reftex-parse.el (reftex-what-macro): Don't hardcode
+ point-min==1.
+
+ * textmodes/ispell.el: Fix commenting convention.
+ (ispell-parse-output): Simplify, use push.
+ (ispell-region): Use match-string-no-properties.
+ (ispell-begin-skip-region-regexp): Use mapconcat to simplify.
+ (ispell-minor-mode): Use define-minor-mode.
+ (ispell-message): Remove unused var `skip-regexp'.
+ (ispell-add-per-file-word-list): Use dynamic let-binding.
+ Try and use the proper comment marker.
+
+ * mail/sendmail.el: Fix commenting convention.
+ (sendmail-send-it): Use line-beginning-position.
+
+ * help-fns.el (describe-variable): Add original value, if applicable.
+
+2010-09-20 Juanma Barranquero <lekktu@gmail.com>
+
+ * subr.el (y-or-n-p): Remove leftover code from 2010-09-17T13:30:30Z!monnier@iro.umontreal.ca.
+
+ * emacs-lisp/smie.el (smie-indent--hanging-p): Use `smie-indent--bolp'.
+
+2010-09-19 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/smie.el (smie-bnf-precedence-table): Improve error message.
+ (smie-debug--prec2-cycle, smie-debug--describe-cycle): New functions.
+ (smie-prec2-levels): Use them to better diagnose precedence cycles.
+ (smie-blink-matching-check): Don't signal a mismatch if car is t.
+ (smie-blink-matching-open): Rewrite to remove assumptions, so that
+ something like "." can also be a closer.
+ (smie--associative-p, smie-indent--hanging-p, smie-indent--bolp)
+ (smie-indent--offset, smie-indent--offset-rule, smie-indent--column):
+ Rename internal functions to use "--". Update callers.
+
+ * frame.el (make-frame-names-alist): Don't list frames on other displays.
+
+ * fringe.el (fringe-styles): New var.
+ (fringe-mode, fringe-query-style): Use it.
+
+2010-09-18 Michael R. Mauger <mmaug@yahoo.com>
+
+ * progmodes/sql.el: Version 2.8
+ (sql-login-params): Update widget structure; changes still needed.
+ (sql-product-alist): Add :list-all and :list-table features for
+ SQLite, Postgres and MySQL products.
+ (sql-redirect): Handle default value.
+ (sql-execute, sql-execute-feature): New functions.
+ (sql-read-table-name): New function.
+ (sql-list-all, sql-list-table): New functions. User API.
+ (sql-mode-map, sql-interactive-mode-map): Add key definitions
+ for above functions.
+ (sql-mode-menu, sql-interactive-mode-menu): Add menu definitions
+ for above functions.
+ (sql-postgres-login-params): Add user and database defaults.
+ (sql-buffer-live-p): Bug fix.
+ (sql-product-history): New variable.
+ (sql-read-product): New function. Use it.
+ (sql-set-product, sql-product-interactive): Use it.
+ (sql-connection-history): New variable.
+ (sql-read-connection): New function. Use it.
+ (sql-connect): New function.
+ (sql-for-each-login): Redesign function interface.
+ (sql-make-alternate-buffer-name, sql-save-connection): Use it.
+ (sql-get-login-ext, sql-get-login): Use it. Handle default values.
+ (sql-comint): Check for program. Existing live buffer.
+ (sql-comint-postgres): Add port parameter.
+
+2010-09-19 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/warnings.el: Fix commenting convention.
+ (display-warning): Use special mode and make the buffer read-only.
+
+2010-09-18 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc-prog.el (calc-read-parse-table-part): Don't "fix" the
+ empty string when it follows a repeated or optional pattern.
+
+2010-09-18 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * indent.el (indent-according-to-mode): Apply syntax-propertize.
+ (indent-region): Use indent-according-to-mode.
+
+2010-09-18 Eli Zaretskii <eliz@gnu.org>
+
+ * fringe.el (fringe-mode): Doc fix.
+
+2010-09-14 Kan-Ru Chen <kanru@kanru.info> (tiny change)
+
+ * textmodes/nroff-mode.el (nroff-view): Kill old buffer before
+ refreshing the preview buffer.
+
+2010-09-18 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * textmodes/tex-mode.el (tex-syntax-propertize-rules)
+ (latex-syntax-propertize-rules): New consts; replace
+ tex-font-lock-syntactic-keywords.
+ (tex-env-mark, latex-env-before-change): New functions.
+ (latex-electric-env-pair-mode): New minor mode.
+ (tex-font-lock-verb): Change arguments; do move point.
+ (tex-font-lock-syntactic-face-function): Adjust to new verbatim
+ representation as a form of comment.
+ (tex-font-lock-keywords-1): Remove workaround, now unneeded.
+ (doctex-syntax-propertize-rules): New const; replaces
+ doctex-font-lock-syntactic-keywords.
+ (tex-common-initialization, doctex-mode): Use syntax-propertize-rules.
+
+ * progmodes/fortran.el (fortran--font-lock-syntactic-keywords): Remove.
+ (fortran-make-syntax-propertize-function): New function; replaces
+ fortran-font-lock-syntactic-keywords.
+ (fortran-mode): Use it.
+ (fortran-line-length): Use it. Improve interactive spec.
+
+ * emacs-lisp/syntax.el (syntax-propertize-precompile-rules): New macro.
+ (syntax-propertize-rules): Add var-ref case. Fix offset computation
+ when adding surrounding \(..\).
+
+ * progmodes/js.el (js-mode): Fix last change (bug#7054).
+
+2010-09-17 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * obsolete/old-whitespace.el (whitespace-rescan-files-in-buffers):
+ Use with-current-buffer.
+
+ * isearch.el (isearch-face): Rename from `isearch'.
+ (isearch-highlight): Use new name.
+
+2010-09-17 Eli Zaretskii <eliz@gnu.org>
+
+ * fringe.el (fringe-mode, fringe-query-style): Use 4 pixels, not
+ 5, for `half' width fringes. (Bug#6933)
+
+2010-09-17 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/bytecomp.el (byte-compile-file-form-defvar)
+ (byte-compile-defvar): "foo/bar" does not lack a prefix.
+
+ * subr.el (y-or-n-p): Add the "(y or n)" that was lost somehow.
+
+2010-09-17 Stephen Berman <stephen.berman@gmx.net>
+
+ * dframe.el (dframe-reposition-frame-emacs): Use tool-bar-pixel-width
+ in calculating new frame position. Add more space between new and
+ parent on the left (Bug#7048).
+
+2010-09-17 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-compat.el (tramp-compat-with-temp-message): Make it a
+ defmacro.
+
+2010-09-16 Chong Yidong <cyd@stupidchicken.com>
+
+ * mail/sendmail.el: Add "*unsent mail*" to same-window-buffer-names.
+
+ * term/x-win.el (x-cut-buffer-or-selection-value): Define as
+ obsolete alias for x-selection-value.
+
+ * ido.el (ido-make-buffer-list): Fix error in 2010-08-22 merge.
+
+2010-09-16 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-cmds.el (tramp-cleanup-connection): Set tramp-autoload
+ cookie.
+
+2010-09-15 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-compat.el (tramp-compat-with-temp-message)
+ (tramp-compat-font-lock-add-keywords, tramp-compat-process-get)
+ (tramp-compat-process-put): New defuns.
+
+ * net/tramp.el (top):
+ * net/tramp-gvfs.el (top):
+ * net/tramp-cache.el (top): Use `tramp-compat-font-lock-add-keywords'.
+
+ * net/tramp.el (tramp-progress-reporter-update):
+ Use `tramp-compat-funcall'.
+
+ * net/tramp.el (tramp-process-actions):
+ * net/tramp-gvfs.el (tramp-handle-vc-registered):
+ * net/tramp-sh.el (tramp-gvfs-handler-askquestion)
+ (tramp-get-remote-stat, tramp-get-remote-readlink):
+ Use `tramp-compat-with-temp-message'.
+
+ * net/tramp-sh.el (top): Require 'cl.
+ (tramp-handle-start-file-process): Use `tramp-compat-process-get'.
+ (tramp-open-connection-setup-interactive-shell):
+ Use `tramp-compat-process-put'.
+
+2010-09-15 Alan Mackenzie <acm@muc.de>
+
+ * progmodes/cc-engine.el (c-forward-<>-arglist-recur): Correct the
+ indentation.
+ (c-forward-<>-arglist-recur): Fix an infinite recursion.
+
+2010-09-15 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/bytecomp.el (byte-compile-warning-types): New type
+ `lexical' for warnings related to lexical scoping.
+ (byte-compile-file-form-defvar, byte-compile-defvar): Warn about
+ global vars which don't have a prefix and could hence affect lexical
+ scoping in unrelated files.
+
+2010-09-14 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * net/imap.el: Revert back to version
+ cb950ed8ff3e0f40dac437a51b269166f9ffb60d, since some of the changes
+ seem problematic.
+
+2010-09-14 Juanma Barranquero <lekktu@gmail.com>
+
+ * obsolete/old-whitespace.el (whitespace-unload-function):
+ Explicitly pass `obarray' to `unintern' to avoid a warning.
+
2010-09-14 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/byte-run.el (set-advertised-calling-convention):
@@ -869,39 +3246,39 @@
diary-included-files. (Bug#6999)
(appt-check): Doc fix.
-2010-09-12 David Reitter <david.reitter@gmail.com>
+2010-09-14 David Reitter <david.reitter@gmail.com>
* simple.el (line-move-visual): Do not truncate goal column to
integer size. (Bug#7020)
-2010-09-11 Stefan Monnier <monnier@iro.umontreal.ca>
+2010-09-14 Stefan Monnier <monnier@iro.umontreal.ca>
* repeat.el (repeat): Allow repeating when the last event is a click.
Suggested by Drew Adams (bug#6256).
-2010-09-11 Sascha Wilde <wilde@sha-bang.de>
+2010-09-14 Sascha Wilde <wilde@sha-bang.de>
* vc/vc-hg.el (vc-hg-state,vc-hg-working-revision):
Replace setting HGRCPATH to "" by some less invasive --config options.
-2010-09-11 Stefan Monnier <monnier@iro.umontreal.ca>
+2010-09-14 Stefan Monnier <monnier@iro.umontreal.ca>
* font-lock.el (font-lock-beginning-of-syntax-function):
Mark as obsolete.
-2010-09-10 Glenn Morris <rgm@gnu.org>
+2010-09-14 Glenn Morris <rgm@gnu.org>
* menu-bar.el (menu-bar-options-save): Fix handling of menu-bar
and tool-bar modes. (Bug#6211)
(menu-bar-mode): Move setting of standard-value after the
minor-mode definition, otherwise it seems to have no effect.
-2010-09-08 Masatake YAMATO <yamato@redhat.com>
+2010-09-14 Masatake YAMATO <yamato@redhat.com>
* progmodes/antlr-mode.el (antlr-font-lock-additional-keywords):
Fix typo. (Bug#6976)
-2010-09-06 Vinicius Jose Latorre <viniciusjl@ig.com.br>
+2010-09-14 Vinicius Jose Latorre <viniciusjl@ig.com.br>
* whitespace.el: Allow cleaning up blanks without blank
visualization (Bug#6651). Adjust help window for
@@ -919,7 +3296,552 @@
(whitespace-style-face-p, whitespace-color-on): Adjust code.
(whitespace-help-scroll): New fun.
-2010-09-05 Alexander Klimov <alserkli@inbox.ru> (tiny change)
+2010-09-14 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * calendar/time-date.el (format-seconds): Comment fix.
+
+2010-09-13 Michael R. Mauger <mmaug@yahoo.com>
+
+ * progmodes/sql.el: Version 2.7.
+ (sql-buffer-live-p): Improve detection.
+ (sql-find-sqli-buffer, sql-set-sqli-buffer-generally)
+ (sql-set-sqli-buffer): Use it.
+ (sql-product-interactive): Run `sql-set-sqli-hook'.
+ (sql-rename-buffer): Code cleanup.
+ (sql-redirect, sql-redirect-value): New functions. More to come.
+
+2010-09-13 Juanma Barranquero <lekktu@gmail.com>
+
+ Port tramp-related Makefile changes of 2010-09-08T14:42:54Z!michael.albinus@gmx.de, 2010-09-13T15:17:01Z!michael.albinus@gmx.de to Windows.
+ * makefile.w32-in (LOADDEFS): Add $(lisp)/net/tramp-loaddefs.el.
+ (TRAMP_SRC): New macro.
+ ($(lisp)/net/tramp-loaddefs.el): New target.
+
+2010-09-13 Michael Albinus <michael.albinus@gmx.de>
+
+ Major code cleanup. Split tramp.el into tramp.el and tramp-sh.el.
+
+ * Makefile.in (TRAMP_SRC): Remove tramp-fish.el. Add tramp-sh.el.
+
+ * net/tramp.el (top): Don't show loading message. Require just
+ 'tramp-compat, everything else is required there.
+ Use `ignore-errors' where appropriate.
+ (tramp-inline-compress-start-size, tramp-copy-size-limit)
+ (tramp-terminal-type, tramp-end-of-output)
+ (tramp-initial-end-of-output, tramp-completion-function-alist-rsh)
+ (tramp-completion-function-alist-ssh)
+ (tramp-completion-function-alist-telnet)
+ (tramp-completion-function-alist-su)
+ (tramp-completion-function-alist-putty, tramp-remote-path)
+ (tramp-remote-process-environment, tramp-sh-extra-args)
+ (tramp-actions-before-shell, tramp-uudecode)
+ (tramp-perl-file-truename, tramp-perl-file-name-all-completions)
+ (tramp-perl-file-attributes)
+ (tramp-perl-directory-files-and-attributes)
+ (tramp-perl-encode-with-module, tramp-perl-decode-with-module)
+ (tramp-perl-encode, tramp-perl-decode)
+ (tramp-vc-registered-read-file-names, tramp-file-mode-type-map)
+ (tramp-file-name-handler-alist, tramp-make-tramp-temp-file)
+ (tramp-handle-make-symbolic-link, tramp-handle-load)
+ (tramp-handle-file-name-as-directory)
+ (tramp-handle-file-name-directory)
+ (tramp-handle-file-name-nondirectory, tramp-handle-file-truename)
+ (tramp-handle-file-exists-p, tramp-handle-file-attributes)
+ (tramp-do-file-attributes-with-ls)
+ (tramp-do-file-attributes-with-perl)
+ (tramp-do-file-attributes-with-stat)
+ (tramp-handle-set-visited-file-modtime)
+ (tramp-handle-verify-visited-file-modtime)
+ (tramp-handle-set-file-modes, tramp-handle-set-file-times)
+ (tramp-set-file-uid-gid, tramp-remote-selinux-p)
+ (tramp-handle-file-selinux-context)
+ (tramp-handle-set-file-selinux-context)
+ (tramp-handle-file-executable-p, tramp-handle-file-readable-p)
+ (tramp-handle-file-newer-than-file-p, tramp-handle-file-modes)
+ (tramp-handle-file-directory-p, tramp-handle-file-regular-p)
+ (tramp-handle-file-symlink-p, tramp-handle-file-writable-p)
+ (tramp-handle-file-ownership-preserved-p)
+ (tramp-handle-directory-file-name, tramp-handle-directory-files)
+ (tramp-handle-directory-files-and-attributes)
+ (tramp-do-directory-files-and-attributes-with-perl)
+ (tramp-do-directory-files-and-attributes-with-stat)
+ (tramp-handle-file-name-all-completions)
+ (tramp-handle-file-name-completion, tramp-handle-add-name-to-file)
+ (tramp-handle-copy-file, tramp-handle-copy-directory)
+ (tramp-handle-rename-file, tramp-do-copy-or-rename-file)
+ (tramp-do-copy-or-rename-file-via-buffer)
+ (tramp-do-copy-or-rename-file-directly)
+ (tramp-do-copy-or-rename-file-out-of-band)
+ (tramp-handle-make-directory, tramp-handle-delete-directory)
+ (tramp-handle-delete-file)
+ (tramp-handle-dired-recursive-delete-directory)
+ (tramp-handle-dired-compress-file, tramp-handle-dired-uncache)
+ (tramp-handle-insert-directory)
+ (tramp-handle-unhandled-file-name-directory)
+ (tramp-handle-expand-file-name)
+ (tramp-handle-substitute-in-file-name)
+ (tramp-handle-executable-find, tramp-process-sentinel)
+ (tramp-handle-start-file-process, tramp-handle-process-file)
+ (tramp-handle-call-process-region, tramp-handle-shell-command)
+ (tramp-handle-file-local-copy, tramp-handle-file-remote-p)
+ (tramp-handle-insert-file-contents)
+ (tramp-handle-insert-file-contents-literally)
+ (tramp-handle-find-backup-file-name)
+ (tramp-handle-make-auto-save-file-name, tramp-handle-write-region)
+ (tramp-vc-registered-file-names, tramp-handle-vc-registered)
+ (tramp-sh-file-name-handler, tramp-vc-file-name-handler)
+ (tramp-maybe-send-script, tramp-set-auto-save, tramp-run-test)
+ (tramp-run-test2, tramp-find-executable, tramp-set-remote-path)
+ (tramp-find-file-exists-command, tramp-open-shell)
+ (tramp-find-shell, tramp-barf-if-no-shell-prompt)
+ (tramp-open-connection-setup-interactive-shell)
+ (tramp-local-coding-commands, tramp-remote-coding-commands)
+ (tramp-find-inline-encoding, tramp-call-local-coding-command)
+ (tramp-inline-compress-commands, tramp-find-inline-compress)
+ (tramp-compute-multi-hops, tramp-maybe-open-connection)
+ (tramp-send-command, tramp-wait-for-output)
+ (tramp-send-command-and-check, tramp-barf-unless-okay)
+ (tramp-send-command-and-read, tramp-mode-string-to-int)
+ (tramp-convert-file-attributes, tramp-check-cached-permissions)
+ (tramp-file-mode-from-int, tramp-file-mode-permissions)
+ (tramp-shell-case-fold, tramp-make-copy-program-file-name)
+ (tramp-method-out-of-band-p, tramp-local-host-p)
+ (tramp-get-remote-path, tramp-get-remote-tmpdir)
+ (tramp-get-ls-command, tramp-get-ls-command-with-dired)
+ (tramp-get-test-command, tramp-get-test-nt-command)
+ (tramp-get-file-exists-command, tramp-get-remote-ln)
+ (tramp-get-remote-perl, tramp-get-remote-stat)
+ (tramp-get-remote-readlink, tramp-get-remote-trash)
+ (tramp-get-remote-id, tramp-get-remote-uid, tramp-get-remote-gid)
+ (tramp-get-local-uid, tramp-get-local-gid)
+ (tramp-get-inline-compress, tramp-get-inline-coding): Move to
+ tramp-sh.el.
+ (tramp-methods, tramp-default-method-alist)
+ (tramp-default-user-alist, tramp-foreign-file-name-handler-alist):
+ Move initialization to tramp-sh.el.
+ (tramp-temp-name-prefix): Make it a defconst.
+ (tramp-dissect-file-name): Don't check anymore for multi-hop
+ methods.
+ (tramp-debug-outline-regexp): Add a docstring.
+ (tramp-debug-outline-level): Rename from `tramp-outline-level'.
+ (tramp-get-debug-buffer): Use it.
+
+ * net/tramp-cache.el (top): Set tramp-autoload cookie for
+ initialization forms.
+ (tramp-set-connection-property): Don't protect `tramp-message'
+ call, it isn't necessary any longer.
+ (tramp-dump-connection-properties): Use `ignore-errors'.
+
+ * net/tramp-compat.el (top): Require 'advice, 'format-spec,
+ 'password-cache and 'auth-source.
+
+ * net/tramp-gvfs.el (top):
+ * net/tramp-smb.el (top): Require 'tramp-sh.
+
+ * net/tramp-gw.el (tramp-gw-open-network-stream): Use `ignore-errors'.
+
+ * net/tramp-sh.el: New file, derived from tramp.el.
+ (top): Initialize `tramp-methods', `tramp-default-method-alist',
+ `tramp-default-user-alist', `tramp-foreign-file-name-handler-alist'.
+ Remove "scp1_old", "scp2_old", "ssh1_old", "ssh2_old".
+ Use `ignore-errors' where appropriate.
+ (tramp-sh-file-name-handler-alist): Rename from
+ `tramp-file-name-handler-alist'.
+ (tramp-send-command-and-check): Return t or nil. Remove all
+ `zerop' checks, where called.
+ (tramp-handle-set-file-modes)
+ (tramp-do-copy-or-rename-file-directly)
+ (tramp-handle-delete-directory, tramp-handle-delete-file)
+ (tramp-maybe-send-script): Use `tramp-barf-unless-okay'.
+ (tramp-sh-file-name-handler, tramp-send-command-and-check)
+ (tramp-get-remote-ln): Set tramp-autoload cookie.
+
+ * net/tramp-fish.el: Remove file.
+
+2010-09-13 Daiki Ueno <ueno@unixuser.org>
+
+ * epa-file.el (epa-file-insert-file-contents): If visiting, bind
+ buffer-file-name to avoid file-locking. (Bug#7026)
+
+2010-09-13 Julien Danjou <julien@danjou.info>
+
+ * notifications.el (notifications-notify): Add support for
+ image-path and sound-name.
+ (notifications-specification-version): Add this variable.
+
+2010-09-12 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * subr.el (y-or-n-p): New function, moved from src/fns.c; use read-key.
+
+2010-09-12 Leo <sdl.web@gmail.com>
+
+ * net/rcirc.el (rcirc-server-commands, rcirc-client-commands)
+ (rcirc-completion-start): New variables.
+ (rcirc-nick-completions): Rename to rcirc-completions.
+ (rcirc-nick-completion-start-offset): Delete.
+ (rcirc-completion-at-point): New function for constructing
+ completion data for both nicks and irc commands. Add to
+ completion-at-point-functions in rcirc mode.
+ (rcirc-complete): Rename from rcirc-nick-complete; use
+ rcirc-completion-at-point.
+ (defun-rcirc-command): Update rcirc-client-commands.
+
+2010-09-11 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/bytecomp.el (byte-compile-file): Create .elc files
+ atomically, to avoid parallel build errors. (Bug#4196)
+
+2010-09-11 Michael R. Mauger <mmaug@yahoo.com>
+
+ * progmodes/sql.el: Version 2.6
+ (sql-dialect): Synonym for "sql-product".
+ (sql-find-sqli-buffer, sql-set-sqli-buffer-generally)
+ (sql-set-sqli-buffer, sql-show-sqli-buffer, sql-interactive-mode):
+ Set "sql-buffer" to buffer name not buffer object so multiple sql
+ interactive buffers work properly. Reverts misguided changes in
+ earlier work.
+ (sql-comint): Make sure different buffer name is used if "*SQL*"
+ buffer is for a different product.
+ (sql-make-alternate-buffer-name): Fix bug with "sql-database"
+ login param.
+ (sql-oracle, sql-sybase, sql-informix, sql-sqlite, sql-mysql)
+ (sql-solid, sql-ingres, sql-ms, sql-postgres, sql-interbase)
+ (sql-db2, sql-linter, sql-product-interactive, sql-rename-buffer):
+ Accept new buffer name or prompt for one.
+ (sql-port): Default to zero.
+ (sql-comint-mysql): Handle "sql-port" as a numeric.
+ (sql-port-history): Delete unused variable.
+ (sql-get-login): Default "sql-port" to a number.
+ (sql-product-alist): Correct Postgres prompt and terminator regexp.
+ (sql-sqlite-program): Dynamically detect presence of "sqlite" or
+ "sqlite3" executables.
+ (sql-sqlite-login-params): Add "*.sqlite[23]?" database name pattern.
+ (sql-buffer-live-p): New function.
+ (sql-mode-menu, sql-send-string): Use it.
+ (sql-mode-oracle-font-lock-keywords): Improve SQL*Plus REMARK
+ syntax pattern.
+ (sql-mode-postgres-font-lock-keywords): Support Postgres V9.
+ (sql-mode-sqlite-font-lock-keywords): Hilight sqlite commands.
+
+2010-09-10 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * net/netrc.el (netrc-credentials): New convenience function.
+
+2010-09-10 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * textmodes/texinfo.el (texinfo-syntax-propertize-function): New fun
+ to replace texinfo-font-lock-syntactic-keywords.
+ (texinfo-mode): Use it.
+
+ * textmodes/tex-mode.el (tex-common-initialization, doctex-mode):
+ Use syntax-propertize-function.
+
+ * textmodes/sgml-mode.el (sgml-syntax-propertize-function): New var to
+ replace sgml-font-lock-syntactic-keywords.
+ (sgml-mode): Use it.
+
+ * textmodes/reftex.el (font-lock-syntactic-keywords): Don't declare
+ since we don't use it.
+
+ * textmodes/bibtex.el (bibtex-mode): Use syntax-propertize-function.
+
+ * progmodes/vhdl-mode.el (vhdl-mode): Use syntax-propertize-function
+ if available.
+ (vhdl-fontify-buffer): Adjust.
+
+ * progmodes/tcl.el (tcl-syntax-propertize-function): New var to
+ replace tcl-font-lock-syntactic-keywords.
+ (tcl-mode): Use it.
+
+ * progmodes/simula.el (simula-syntax-propertize-function): New var to
+ replace simula-font-lock-syntactic-keywords.
+ (simula-mode): Use it.
+
+ * progmodes/sh-script.el (sh-st-symbol): Remove.
+ (sh-font-lock-close-heredoc, sh-font-lock-open-heredoc): Add eol arg.
+ (sh-font-lock-flush-syntax-ppss-cache, sh-font-lock-here-doc): Remove.
+ (sh-font-lock-quoted-subshell): Assume we've already matched $(.
+ (sh-font-lock-paren): Set syntax-multiline.
+ (sh-font-lock-syntactic-keywords): Remove.
+ (sh-syntax-propertize-function): New function to replace it.
+ (sh-mode): Use it.
+
+ * progmodes/ruby-mode.el (ruby-here-doc-beg-re):
+ Define while compiling.
+ (ruby-here-doc-end-re, ruby-here-doc-beg-match)
+ (ruby-font-lock-syntactic-keywords, ruby-comment-beg-syntax)
+ (syntax-ppss, ruby-in-ppss-context-p, ruby-in-here-doc-p)
+ (ruby-here-doc-find-end, ruby-here-doc-beg-syntax)
+ (ruby-here-doc-end-syntax): Only define when
+ syntax-propertize is not available.
+ (ruby-syntax-propertize-function, ruby-syntax-propertize-heredoc):
+ New functions.
+ (ruby-in-ppss-context-p): Update to new syntax of heredocs.
+ (electric-indent-chars): Silence bytecompiler.
+ (ruby-mode): Use prog-mode, syntax-propertize-function, and
+ electric-indent-chars.
+
+ * progmodes/python.el (python-syntax-propertize-function): New var to
+ replace python-font-lock-syntactic-keywords.
+ (python-mode): Use it.
+ (python-quote-syntax): Simplify and adjust to new use.
+
+ * progmodes/perl-mode.el (perl-syntax-propertize-function): New fun to
+ replace perl-font-lock-syntactic-keywords.
+ (perl-syntax-propertize-special-constructs): New fun to replace
+ perl-font-lock-special-syntactic-constructs.
+ (perl-font-lock-syntactic-face-function): New fun.
+ (perl-mode): Use it.
+
+ * progmodes/octave-mod.el (octave-syntax-propertize-sqs): New function
+ to replace octave-font-lock-close-quotes.
+ (octave-syntax-propertize-function): New function to replace
+ octave-font-lock-syntactic-keywords.
+ (octave-mode): Use it.
+
+ * progmodes/mixal-mode.el (mixal-syntax-propertize-function): New var;
+ replaces mixal-font-lock-syntactic-keywords.
+ (mixal-mode): Use it.
+
+ * progmodes/make-mode.el (makefile-syntax-propertize-function):
+ New var; replaces makefile-font-lock-syntactic-keywords.
+ (makefile-mode): Use it.
+ (makefile-imake-mode): Adjust.
+
+ * progmodes/js.el (js--regexp-literal): Define while compiling.
+ (js-syntax-propertize-function): New var; replaces
+ js-font-lock-syntactic-keywords.
+ (js-mode): Use it.
+
+ * progmodes/gud.el (gdb-script-syntax-propertize-function): New var;
+ replaces gdb-script-font-lock-syntactic-keywords.
+ (gdb-script-mode): Use it.
+
+ * progmodes/fortran.el (fortran-mode): Use syntax-propertize-function.
+ (fortran--font-lock-syntactic-keywords): New var.
+ (fortran-line-length): Update syntax-propertize-function and
+ fortran--font-lock-syntactic-keywords.
+
+ * progmodes/cperl-mode.el (cperl-mode): Use syntax-propertize-function.
+
+ * progmodes/cfengine.el (cfengine-mode):
+ Use syntax-propertize-function.
+ (cfengine-font-lock-syntactic-keywords): Remove.
+
+ * progmodes/autoconf.el (autoconf-mode):
+ Use syntax-propertize-function.
+ (autoconf-font-lock-syntactic-keywords): Remove.
+
+ * progmodes/ada-mode.el (ada-set-syntax-table-properties)
+ (ada-after-change-function, ada-initialize-syntax-table-properties)
+ (ada-handle-syntax-table-properties): Only define when
+ syntax-propertize is not available.
+ (ada-mode): Use syntax-propertize-function.
+
+ * font-lock.el (font-lock-syntactic-keywords): Make obsolete.
+ (font-lock-fontify-syntactic-keywords-region): Move handling of
+ font-lock-syntactically-fontified to...
+ (font-lock-default-fontify-region): ...here.
+ Let syntax-propertize-function take precedence.
+ (font-lock-fontify-syntactically-region): Cal syntax-propertize.
+
+ * emacs-lisp/syntax.el (syntax-propertize-function)
+ (syntax-propertize-chunk-size, syntax-propertize--done)
+ (syntax-propertize-extend-region-functions): New vars.
+ (syntax-propertize-wholelines, syntax-propertize-multiline)
+ (syntax-propertize--shift-groups, syntax-propertize-via-font-lock)
+ (syntax-propertize): New functions.
+ (syntax-propertize-rules): New macro.
+ (syntax-ppss-flush-cache): Set syntax-propertize--done.
+ (syntax-ppss): Call syntax-propertize.
+
+ * emacs-lisp/regexp-opt.el (regexp-opt-depth): Skip named groups.
+
+2010-09-10 Agustín Martín <agustin.martin@hispalinux.es>
+
+ * textmodes/ispell.el (ispell-init-process): Improve comments.
+ XEmacs compatibility changes regarding (add-hook) 'local option
+ and (set-process-query-on-exit-flag).
+
+2010-09-09 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-cache.el (tramp-parse-connection-properties):
+ Set tramp-autoload cookie.
+
+2010-09-09 Glenn Morris <rgm@gnu.org>
+
+ * image.el (imagemagick-types-inhibit): Add :type, :version, :group.
+ (imagemagick-register-types): Doc fix.
+
+2010-09-08 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/octave-mod.el (electric-indent-chars): Silence bytecomp.
+
+ * progmodes/js.el (require): Require is already "eval-and-compile".
+ (js--re-search-forward): Avoid `eval'. Preserve the error data.
+ (js--re-search-backward): Use js--re-search-forward.
+
+ * progmodes/fortran.el (fortran-line-length): Don't recompute
+ syntactic keywords redundantly a second time.
+
+ * progmodes/ada-mode.el: Replace "(set '" with setq.
+ (ada-mode): Simplify.
+ (ada-create-case-exception, ada-adjust-case-interactive)
+ (ada-adjust-case-region, ada-format-paramlist, ada-indent-current)
+ (ada-search-ignore-string-comment, ada-move-to-start)
+ (ada-move-to-end): Use with-syntax-table.
+
+ * font-lock.el (save-buffer-state): Remove `varlist' arg.
+ (font-lock-unfontify-region, font-lock-default-fontify-region):
+ Update usage correspondingly.
+ (font-lock-fontify-syntactic-keywords-region):
+ Set parse-sexp-lookup-properties buffer-locally here.
+ (font-lock-fontify-syntactically-region): Remove unused `ppss' arg.
+
+ * simple.el (blink-matching-open): Don't burp if we can't find a match.
+
+2010-09-08 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/bytecomp.el (byte-compile-report-ops):
+ Error if not compiled with -DBYTE_CODE_METER.
+
+ * emacs-lisp/bytecomp.el (byte-recompile-directory):
+ Ignore dir-locals-file.
+
+2010-09-08 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/compile.el (compilation-error-regexp-alist-alist):
+ Not a const.
+ (compilation-error-regexp-alist-alist): Rule out ": " in file names
+ for the `gnu' messages.
+ (compilation-set-skip-threshold): New command.
+ (compilation-start): Use \' rather than $.
+ (compilation-forget-errors): Use clrhash.
+
+2010-09-08 Agustín Martín <agustin.martin@hispalinux.es>
+
+ * textmodes/ispell.el (ispell-valid-dictionary-list):
+ Simplify logic.
+
+2010-09-08 Michael Albinus <michael.albinus@gmx.de>
+
+ Migrate to Tramp 2.2. Rearrange load dependencies.
+ (Bug#1529, Bug#5448, Bug#5705)
+
+ * Makefile.in (TRAMP_DIR, TRAMP_SRC): New variables.
+ ($(TRAMP_DIR)/tramp-loaddefs.el): New target.
+ (LOADDEFS): Add $(lisp)/net/tramp-loaddefs.el.
+
+ * net/tramp.el (top): Remove all other tramp-* loads except
+ tramp-compat.el. Remove all changes to tramp-unload-hook for
+ other tramp-* packages. Rearrange defun order. Change calls of
+ `tramp-compat-call-process', `tramp-compat-decimal-to-octal',
+ `tramp-compat-octal-to-decimal' to new function names.
+ (tramp-terminal-type, tramp-initial-end-of-output)
+ (tramp-methods, tramp-foreign-file-name-handler-alist)
+ (tramp-tramp-file-p, tramp-completion-mode-p)
+ (tramp-send-command-and-check, tramp-get-remote-path)
+ (tramp-get-remote-tmpdir, tramp-get-remote-ln)
+ (tramp-shell-quote-argument): Set tramp-autoload cookie.
+ (with-file-property, with-connection-property): Move to
+ tramp-cache.el.
+ (tramp-local-call-process, tramp-decimal-to-octal)
+ (tramp-octal-to-decimal): Move to tramp-compat.el.
+ (tramp-handle-shell-command): Do not require 'shell.
+ (tramp-compute-multi-hops): No special handling for tramp-gw-*
+ symbols.
+ (tramp-unload-tramp): Do not call `tramp-unload-file-name-handlers'.
+
+ * net/tramp-cache.el (top): Require 'tramp. Add to
+ `tramp-unload-hook'.
+ (tramp-cache-data, tramp-get-file-property)
+ (tramp-set-file-property, tramp-flush-file-property)
+ (tramp-flush-directory-property, tramp-get-connection-property)
+ (tramp-set-connection-property, tramp-flush-connection-property)
+ (tramp-cache-print, tramp-list-connections): Set tramp-autoload
+ cookie.
+ (with-file-property, with-connection-property): New defuns, moved
+ from tramp.el.
+ (tramp-flush-file-function): Use `with-parsed-tramp-file-name'
+ macro.
+
+ * net/tramp-cmds.el (top): Add to `tramp-unload-hook'.
+ (tramp-version): Set tramp-autoload cookie.
+
+ * net/tramp-compat.el (top): Require 'tramp-loaddefs. Remove all
+ changes to tramp-unload-hook for other tramp-* packages. Add to
+ `tramp-unload-hook'.
+ (tramp-compat-decimal-to-octal, tramp-compat-octal-to-decimal)
+ (tramp-compat-call-process): New defuns, moved from tramp.el.
+
+ * net/tramp-fish.el (top) Require just 'tramp. Add objects to
+ `tramp-methods' and `tramp-foreign-file-name-handler-alist'.
+ Add to `tramp-unload-hook'. Change call of
+ `tramp-compat-decimal-to-octal' to new function name.
+ (tramp-fish-method): Make it a defconst.
+ (tramp-fish-file-name-p): Make it a defsubst.
+ (tramp-fish-method, tramp-fish-file-name-handler)
+ (tramp-fish-file-name-p): Set tramp-autoload cookie.
+
+ * net/tramp-ftp.el (top) Add objects to `tramp-methods' and
+ `tramp-foreign-file-name-handler-alist'. Add to
+ `tramp-unload-hook'.
+ (tramp-ftp-method): Make it a defconst.
+ (tramp-ftp-file-name-p): Make it a defsubst.
+ (tramp-ftp-method, tramp-ftp-file-name-handler)
+ (tramp-ftp-file-name-p): Set tramp-autoload cookie.
+
+ * net/tramp-gvfs.el (top) Add objects to `tramp-methods' and
+ `tramp-foreign-file-name-handler-alist'. Add to
+ `tramp-unload-hook'. Change checks, whether package can be
+ loaded.
+ (tramp-gvfs-file-name-p): Make it a defsubst.
+ (tramp-gvfs-methods, tramp-gvfs-file-name-handler)
+ (tramp-gvfs-file-name-p): Set tramp-autoload cookie.
+ (tramp-gvfs-handle-file-directory-p): New defun.
+ (tramp-gvfs-file-name-handler-alist): Use it.
+
+ * net/tramp-gw.el (top) Add objects to `tramp-methods' and
+ `tramp-foreign-file-name-handler-alist'. Add to
+ `tramp-unload-hook'.
+ (tramp-gw-tunnel-method, tramp-gw-default-tunnel-port)
+ (tramp-gw-socks-method, tramp-gw-default-socks-port): Make it a
+ defconst.
+ (tramp-gw-tunnel-method, tramp-gw-socks-method)
+ (tramp-gw-open-connection): Set tramp-autoload cookie.
+
+ * net/tramp-imap.el (top) Require just 'tramp. Add objects to
+ `tramp-methods' and `tramp-foreign-file-name-handler-alist'.
+ Add to `tramp-unload-hook'. Change checks, whether package can be
+ loaded.
+ (tramp-imap-file-name-p): Make it a defsubst.
+ (tramp-imap-method, tramp-imaps-method)
+ (tramp-imap-file-name-handler)
+ (tramp-imap-file-name-p): Set tramp-autoload cookie.
+
+ * net/tramp-smb.el (top) Require just 'tramp. Add objects to
+ `tramp-methods' and `tramp-foreign-file-name-handler-alist'.
+ Add to `tramp-unload-hook'. Change checks, whether package can be
+ loaded. Change call of `tramp-compat-decimal-to-octal' to new
+ function name.
+ (tramp-smb-tunnel-method): Make it a defconst.
+ (tramp-smb-file-name-p): Make it a defsubst.
+ (tramp-smb-method, tramp-smb-file-name-handler)
+ (tramp-smb-file-name-p): Set tramp-autoload cookie.
+
+ * net/tramp-uu.el (top) Add to `tramp-unload-hook'.
+ (tramp-uuencode-region): Set tramp-autoload cookie.
+
+ * net/trampver.el (top) Add to `tramp-unload-hook'.
+ (tramp-version, tramp-bug-report-address): Set tramp-autoload
+ cookie. Update release number.
+
+2010-09-07 Agustín Martín <agustin.martin@hispalinux.es>
+
+ * textmodes/ispell.el (ispell-start-process): Make sure original
+ arg list is properly initialized (Bug#6993, Bug#6994).
+
+2010-09-06 Alexander Klimov <alserkli@inbox.ru> (tiny change)
* files.el (directory-abbrev-alist): Use \` as default regexp.
@@ -927,14 +3849,226 @@
chars like - or ] (bug#6984).
(rx-any-condense-range): Explode 2-char ranges.
-2010-09-02 Stefan Monnier <monnier@iro.umontreal.ca>
+2010-09-06 Glenn Morris <rgm@gnu.org>
+
+ * desktop.el (desktop-path): Bump :version after 2009-09-15 change.
+
+2010-09-06 Stefan Monnier <monnier@iro.umontreal.ca>
* textmodes/bibtex.el:
* proced.el: Update to new email for Roland Winkler <winkler@gnu.org>.
-2010-09-02 Glenn Morris <rgm@gnu.org>
+2010-09-05 Lars Magne Ingebrigtsen <larsi@gnus.org>
- * desktop.el (desktop-path): Bump :version after 2009-09-15 change.
+ * net/imap.el (imap-message-map): Remove optional buffer parameter,
+ since no callers use it.
+ (imap-message-get): Ditto.
+ (imap-message-put): Ditto.
+ (imap-mailbox-map): Ditto.
+ (imap-mailbox-put): Ditto.
+ (imap-mailbox-get): Ditto.
+ (imap-mailbox-get): Revert last change for this function.
+
+2010-09-05 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * net/imap.el (imap-fetch-safe): Remove function, and alter all
+ callers to use `imap-fetch' instead. According to the comments, this
+ should be safe, since all other IMAP clients use the 1:* syntax.
+ (imap-enable-exchange-bug-workaround): Remove.
+ (imap-debug): Remove -- doesn't seem very useful.
+
+2010-09-05 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * net/imap.el (imap-log): New convenience function used throughout
+ instead of repeating the same code all over the place.
+
+2010-09-05 David De La Harpe Golden <david@harpegolden.net>
+
+ * mouse.el (mouse-save-then-kill): Save region to kill-ring
+ when mouse-drag-copy-region is non-nil (Bug#6956).
+
+2010-09-05 Chong Yidong <cyd@stupidchicken.com>
+
+ * dired.el (dired-ls-sorting-switches, dired-sort-by-name-regexp):
+ Improve regexps (Bug#6987).
+ (dired-sort-toggle): Search more robustly for -t flag.
+
+ * files.el (get-free-disk-space): Search more robustly for
+ "available" column. Suggested by Ehud Karni
+ <ehud@unix.mvs.co.il>.
+
+2010-09-05 Juanma Barranquero <lekktu@gmail.com>
+
+ * international/uni-bidi.el:
+ * international/uni-category.el:
+ * international/uni-combining.el:
+ * international/uni-decimal.el:
+ * international/uni-mirrored.el:
+ * international/uni-name.el: Regenerate.
+
+2010-09-04 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * electric.el (electric-indent-post-self-insert-function):
+ Don't reindent with a sloppy indentation function.
+
+ * emacs-lisp/syntax.el (syntax-ppss): More sanity check to catch
+ border case in change-log-mode.
+
+2010-09-04 Chong Yidong <cyd@stupidchicken.com>
+
+ * progmodes/compile.el (compilation-error-regexp-alist-alist):
+ Remove ruby regexp; handle Ruby errors with gcc-include and gnu.
+ Recognize leading tab in gcc-include regexp. Ignore names with
+ leading "from" or "in" in gnu regexp (Bug#6937).
+
+2010-09-04 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Avoid global recursive calls to kill-buffer-hooks; fit into 80 cols.
+ * textmodes/ispell.el (ispell-process-buffer-name): Remove.
+ (ispell-start-process): Avoid setq and simplify logic.
+ (ispell-init-process): Setup kill-buffer-hook locally when needed.
+ (kill-buffer-hook): Don't use it globally with code that uses
+ expand-file-name since that may call kill-buffer via
+ code_conversion_restore.
+
+2010-09-04 Noorul Islam K M <noorul@noorul.com> (tiny change)
+
+ * emacs-lisp/package.el (package-directory-list): Only call
+ file-name-nondirectory on a string.
+
+2010-09-02 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/package.el (package--download-one-archive):
+ Ensure that archive-contents is valid before saving it.
+ (package-activate-1, package-mark-obsolete, define-package)
+ (package-compute-transaction, package-list-maybe-add): Use push.
+
+2010-09-03 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Use SMIE's blink-paren for octave-mode.
+ * progmodes/octave-mod.el (octave-font-lock-close-quotes):
+ Backslashes do not escape single-quotes, single-quotes do.
+ (octave-block-else-regexp, octave-block-end-regexp)
+ (octave-block-match-alist): Remove.
+ (octave-smie-bnf-table): New var, with old content.
+ (octave-smie-op-levels): Use it.
+ (octave-smie-closer-alist): New var.
+ (octave-mode): Use it. Setup smie-blink-matching and electric-indent.
+ (octave-blink-matching-block-open): Remove.
+ (octave-reindent-then-newline-and-indent, octave-electric-semi)
+ (octave-electric-space): Let self-insert-command run expand-abbrev and
+ blink parens.
+
+ * electric.el (electricity): New group.
+ (electric-indent-chars): New var.
+ (electric-indent-post-self-insert-function): New fun.
+ (electric-indent-mode): New minor mode.
+ (electric-pair-skip-self): New custom.
+ (electric-pair-post-self-insert-function): New function.
+ (electric-pair-mode): New minor mode.
+
+ * calc/calc-aent.el (calcAlg-blink-matching-check): New fun, to replace
+ calcAlg-blink-matching-open.
+ (calc-alg-ent-map, calc-alg-ent-esc-map): Initialize in the declaration.
+ (calc-do-alg-entry): Only touch the part of the keymap that varies.
+ Use the new blink-matching-check-function.
+
+ Provide blink-matching support to SMIE.
+ * emacs-lisp/smie.el (smie-bnf-closer-alist): New function.
+ (smie-blink-matching-triggers, smie-blink-matching-inners): New vars.
+ (smie-blink-matching-check, smie-blink-matching-open): New functions.
+
+ * simple.el (newline): Fix last change to properly remove itself from
+ the hook.
+
+2010-09-02 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * simple.el (newline): Eliminate optimization.
+ Use post-self-insert-hook to set hard-newline and things before
+ running post-self-insert-hook.
+ (blink-matching-check-mismatch): New function.
+ (blink-matching-check-function): New variable.
+ (blink-matching-open): Use them.
+ Skip back forward over prefix chars skipped by forward-sexp.
+ Don't check if the parens are backslash escaped.
+ (blink-paren-post-self-insert-function): Check backslash escaping here.
+
+2010-09-02 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/package.el (package-menu-mode-map):
+ Change package-menu-revert bindings to revert-buffer.
+ (package-menu-mode): Set revert-buffer-function.
+ (package-menu-revert): Doc fix.
+
+2010-09-02 Agustín Martín <agustin.martin@hispalinux.es>
+
+ * textmodes/ispell.el (ispell-init-process): Use "~/" as
+ `default-directory' unless using Ispell per-directory personal
+ dictionaries and not in a mini-buffer under XEmacs.
+ (kill-buffer-hook): Do not kill ispell process on exit when
+ `ispell-process-directory' is "~/". (Bug#6143)
+
+2010-09-02 Jan Djärv <jan.h.d@swipnet.se>
+
+ * simple.el (kill-new): Call interprogram-cut-function with only
+ one argument.
+
+ * term.el (term-mouse-paste): Don't call x-get-cutbuffer.
+ Remove cut buffer from error message.
+
+ * term/x-win.el (x-select-text):
+ * term/pc-win.el (x-selection-value):
+ * term/ns-win.el (x-selection-value):
+ * eshell/em-term.el:
+ * w32-fns.el (x-get-selection-value):
+ * mouse-sel.el (mouse-sel-set-selection-function):
+ * frame.el (display-selections-p): Remove cut-buffer in documentation.
+
+ * term/x-win.el: Update documentation for x-last-selected-text-*.
+ (x-last-selected-text-cut, x-last-selected-text-cut-encoded)
+ (x-last-cut-buffer-coding, x-cut-buffer-max): Remove.
+ (x-select-text): Remove argument PUSH, update documentation.
+ Remove cut-buffer code.
+ (x-selection-value-internal): Was previously x-selection-value.
+ (x-selection-value): Rename from x-cut-buffer-or-selection-value.
+ Update documentation, remove cut-buffer code.
+ Call x-selection-value-internal.
+ (x-clipboard-yank): Call x-selection-value-internal.
+ (x-initialize-window-system): Remove setting of x-cut-buffer-max.
+
+ * term/pc-win.el (x-last-selected-text):
+ x-cut-buffer-or-selection-value renamed to x-selection-value
+ (x-select-text): Remove argument PUSH, update documentation.
+
+ * term/ns-win.el (x-setup-function-keys, ns-last-selected-text):
+ x-cut-buffer-or-selection-value renamed to x-selection-value
+ (x-selection-value): Renamed from x-cut-buffer-or-selection-value.
+ (x-select-text): Remove argument PUSH, update documentation.
+
+ * emacs-lisp/cl-macs.el (x-get-cutbuffer, x-get-cut-buffer): Remove.
+
+ * w32-fns.el (x-last-selected-text):
+ x-cut-buffer-or-selection-value renamed to x-selection-value.
+ (x-cut-buffer-max): Remove.
+ (x-select-text): Remove argument PUSH, update documentation.
+
+ * simple.el (interprogram-cut-function): Remove mention of PUSH.
+
+ * select.el (x-get-cut-buffer, x-set-cut-buffer): Remove.
+
+ * mouse-sel.el (mouse-sel-get-selection-function):
+ x-cut-buffer-or-selection-value renamed to x-selection-value.
+ (x-select-text): Remove optional push.
+
+2010-09-01 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * simple.el (blink-paren-function): Move from C to here.
+ (blink-paren-post-self-insert-function): New function.
+ (post-self-insert-hook): Use it.
+
+ * emacs-lisp/pcase.el (pcase-split-memq):
+ Fix overenthusiastic optimisation.
+ (pcase-u1): Handle the case of a lambda pred.
2010-08-31 Kenichi Handa <handa@m17n.org>
@@ -947,6 +4081,234 @@
characters in the element vector.
(standard-display-european): Likewise.
+2010-08-31 Masatake YAMATO <yamato@redhat.com>
+
+ * textmodes/nroff-mode.el (nroff-view): New command.
+ (nroff-mode-map): Bind it to C-c C-c.
+
+2010-08-31 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/smie.el (smie-down-list): New command.
+
+ Remove old indentation and navigation code on octave-mode.
+ * progmodes/octave-mod.el (octave-mode-map): Remap down-list to
+ smie-down-list rather than add a binding for octave-down-block.
+ (octave-mark-block, octave-blink-matching-block-open):
+ Rely on forward-sexp-function.
+ (octave-fill-paragraph): Don't narrow, so you can use
+ indent-according-to-mode.
+ (octave-block-begin-regexp, octave-block-begin-or-end-regexp): Remove.
+ (octave-in-block-p, octave-re-search-forward-kw)
+ (octave-re-search-backward-kw, octave-indent-calculate)
+ (octave-end-as-array-index-p, octave-block-end-offset)
+ (octave-scan-blocks, octave-forward-block, octave-backward-block)
+ (octave-down-block, octave-backward-up-block, octave-up-block)
+ (octave-before-magic-comment-p, octave-indent-line): Remove.
+
+2010-08-31 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/package.el (package--read-archive-file): Just use
+ `read', to avoid copying an additional string.
+ (package-menu-mode): Set header-line-format here.
+ (package-menu-refresh, package-menu-revert): Signal an error if
+ not in the Package Menu.
+ (package-menu-package-list): New var.
+ (package--generate-package-list): Operate on the current buffer;
+ don't assume that it is *Packages*, since the user may rename it.
+ Allow persistent package listings and sort keys using
+ package-menu-package-list and package-menu-package-sort-key.
+ (package-menu--version-predicate): Fix version calculation.
+ (package-menu-sort-by-column): Don't select the window.
+ (package--list-packages): Create the *Packages* buffer.
+ Set package-menu-package-list-key.
+ (list-packages): Sorting by status is now the default.
+ (package-buffer-info): Use match-string-no-properties.
+ (define-package): Add a &rest argument for future proofing, but
+ don't use it yet.
+ (package-install-from-buffer, package-install-buffer-internal):
+ Merge into a single function, package-install-from-buffer.
+ (package-install-file): Change caller.
+
+ * finder.el: Load finder-inf using `require'.
+ (finder-list-matches): Sorting by status is now the default.
+ (finder-compile-keywords): Simpify printing.
+
+2010-08-30 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/octave-mod.el (octave-font-lock-keywords): Use regexp-opt.
+ (octave-mode-map): Remove special bindings for forward/backward-block
+ and octave-backward-up-block. Use smie-close-block.
+ (octave-continuation-marker-regexp): New var.
+ (octave-continuation-regexp): Use it.
+ (octave-operator-table, octave-smie-op-levels)
+ (octave-operator-regexp, octave-smie-indent-rules): New vars.
+ (octave-smie-backward-token, octave-smie-forward-token): New funs.
+ (octave-mode): Use SMIE.
+ (octave-close-block): Delete.
+
+2010-08-30 Eli Zaretskii <eliz@gnu.org>
+
+ * menu-bar.el (menu-bar-edit-menu) <"Paste">: Check selection in
+ CLIPBOARD, not in PRIMARY. (Bug#6944)
+
+2010-08-30 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/smie.el (smie-indent-offset-rule): Let :parent take
+ a list of parents.
+ (smie-indent-column): Allow indirection through variables.
+
+ * composite.el (save-buffer-state): Delete, unused.
+ * font-lock.el (save-buffer-state): Use with-silent-modifications.
+ (font-lock-default-fontify-region): Use with-syntax-table.
+ * jit-lock.el (with-buffer-unmodified): Remove.
+ (with-buffer-prepared-for-jit-lock): Use with-silent-modifications.
+
+ Use `declare' in defmacros.
+ * window.el (save-selected-window):
+ * subr.el (with-temp-file, with-temp-message, with-syntax-table):
+ * progmodes/python.el (def-python-skeleton):
+ * net/dbus.el (dbus-ignore-errors):
+ * jka-cmpr-hook.el (with-auto-compression-mode):
+ * international/mule.el (with-category-table):
+ * emacs-lisp/timer.el (with-timeout):
+ * emacs-lisp/lisp-mnt.el (lm-with-file):
+ * emacs-lisp/eieio.el (with-slots):
+ * emacs-lisp/easymenu.el (easy-menu-define):
+ * emacs-lisp/debug.el (debugger-env-macro):
+ * emacs-lisp/cl-compat.el (Multiple-value-bind, Multiple-value-setq)
+ (Multiple-value-call, Multiple-value-prog1):
+ * emacs-lisp/cl-seq.el (cl-parsing-keywords, cl-check-key)
+ (cl-check-test-nokey, cl-check-test, cl-check-match): Move indent and
+ edebug rule to definition.
+ * emacs-lisp/lisp-mode.el (save-selected-window)
+ (with-current-buffer, combine-after-change-calls)
+ (with-output-to-string, with-temp-file, with-temp-buffer)
+ (with-temp-message, with-syntax-table, read-if, eval-after-load)
+ (dolist, dotimes, when, unless):
+ * emacs-lisp/byte-run.el (inline): Remove indent rule, redundant.
+
+2010-08-29 Chong Yidong <cyd@stupidchicken.com>
+
+ * finder.el: Require `package'.
+ (finder-known-keywords): Tweak descriptions. Retire `oop' keyword.
+ (finder-package-info): Var deleted.
+ (finder-keywords-hash, finder--builtins-alist): New vars.
+ (finder-compile-keywords): Compute package--builtins and
+ finder-keywords-hash instead of finder-keywords-hash, respecting
+ the "Package" header.
+ (finder-unknown-keywords, finder-list-matches):
+ Use finder-keywords-hash and package--list-packages.
+ (finder-mode): Don't set font-lock-defaults.
+ (finder-exit): We don't use "*Finder-package*" and "*Finder
+ Category*" buffers anymore.
+
+ * emacs-lisp/package.el (package--builtins-base): Var deleted.
+ (package--builtins): Set default value to nil.
+ (package-initialize): Load precomputed value of package--builtins
+ from finder-inf.el.
+ (package-alist, package-compute-transaction)
+ (package-download-transaction): Improve docstring.
+ (package-read-all-archive-contents): Do not change
+ package--builtins here.
+ (list-packages): Make package-list-packages an alias for this.
+ Sort by status by default.
+ (package--list-packages): Add optional PACKAGES arg.
+ (describe-package-1): Use font-lock-face property. For built-in
+ packages, insert file commentary.
+ (package--generate-package-list): Rename from
+ package-list-packages-internal; all callers changed. Add optional
+ PACKAGES arg. Add alphabetical sort fallbacks.
+ (package-menu--version-predicate, package-menu--status-predicate)
+ (package-menu--description-predicate)
+ (package-menu--name-predicate): New functions.
+
+ * info.el (Info-finder-find-node): Search package-alist instead of
+ finder-package-info.
+
+2010-08-29 Chong Yidong <cyd@stupidchicken.com>
+
+ * subr.el (version-regexp-alist): Don't use "a" and "b" for
+ "alpha" and "beta".
+ (version-to-list): Handle versions like "10.3d".
+
+2010-08-28 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/macroexp.el (macroexpand-all-1): Use pcase.
+ (macroexp-accumulate): Use `declare'.
+
+2010-08-27 Vinicius Jose Latorre <viniciusjl@ig.com.br>
+
+ * whitespace.el (whitespace-style): Adjust type declaration.
+
+2010-08-26 Magnus Henoch <magnus.henoch@gmail.com>
+
+ * net/tramp-gvfs.el (tramp-gvfs-handle-copy-file): Do not pass
+ empty argument to gvfs-copy.
+
+2010-08-26 Chong Yidong <cyd@stupidchicken.com>
+
+ * net/tramp-compat.el (tramp-compat-delete-file): Rewrite to
+ handle new TRASH arg of `delete-file'.
+
+2010-08-26 Christian Lynbech <christian.lynbech@tieto.com> (tiny change)
+
+ * net/tramp.el (tramp-handle-insert-directory): Don't use
+ `forward-word', its default syntax could be changed.
+
+2010-08-26 Toru TSUNEYOSHI <t_tuneyosi@hotmail.com>
+ Michael Albinus <michael.albinus@gmx.de>
+
+ Implement compression for inline methods.
+
+ * net/tramp.el (tramp-inline-compress-start-size): New defcustom.
+ (tramp-copy-size-limit): Allow also nil.
+ (tramp-inline-compress-commands): New defconst.
+ (tramp-find-inline-compress, tramp-get-inline-compress)
+ (tramp-get-inline-coding): New defuns.
+ (tramp-get-remote-coding, tramp-get-local-coding): Remove,
+ replaced by `tramp-get-inline-coding'.
+ (tramp-handle-file-local-copy, tramp-handle-write-region)
+ (tramp-method-out-of-band-p): Use `tramp-get-inline-coding'.
+
+2010-08-26 Noah Lavine <noah549@gmail.com> (tiny change)
+
+ Detect ssh 'ControlMaster' argument automatically in some cases.
+
+ * net/tramp.el (tramp-detect-ssh-controlmaster): New defun.
+ (tramp-default-method): Use it.
+
+2010-08-26 Karel Klíč <kklic@redhat.com>
+
+ * net/tramp.el (tramp-file-name-for-operation):
+ Add file-selinux-context.
+
+2010-08-26 Łukasz Stelmach <lukasz.stelmach@iem.pw.edu.pl> (tiny change)
+
+ * play/cookie1.el (read-cookie): Fix off-by-one error (bug#6921).
+
+2010-08-26 Chong Yidong <cyd@stupidchicken.com>
+
+ * simple.el (beginning-of-buffer, end-of-buffer): Doc fix
+ (Bug#6907).
+
+2010-08-26 Nathan Weizenbaum <nweiz@cressida.sea.corp.google.com> (tiny change)
+
+ * progmodes/js.el: Make indentation more customizable (Bug#6914).
+ (js-paren-indent-offset, js-square-indent-offset)
+ (js-curly-indent-offset): New options.
+ (js--proper-indentation): Use them.
+
+2010-08-26 Daniel Colascione <dan.colascione@gmail.com>
+
+ * progmodes/sh-script.el (sh-get-indent-info): Use syntax-ppss
+ instead of inspecting font-lock properties (Bug#6916).
+
+2010-08-26 David Reitter <david.reitter@gmail.com>
+
+ * server.el (server-visit-files): Run pre-command-hook and
+ post-command-hook for each buffer while it is current (Bug#6910).
+ (server-execute): Do not run hooks here.
+
2010-08-26 Michael Albinus <michael.albinus@gmx.de>
Sync with Tramp 2.1.19.
@@ -1158,62 +4520,120 @@
* net/trampver.el: Update release number.
-2010-08-26 Magnus Henoch <magnus.henoch@gmail.com>
+2010-08-26 Chong Yidong <cyd@stupidchicken.com>
- * net/tramp-gvfs.el (tramp-gvfs-handle-copy-file): Do not pass
- empty argument to gvfs-copy.
+ * help.el (help-map): Bind `C-h P' to describe-package.
-2010-08-26 Chong Yidong <cyd@stupidchicken.com>
+ * menu-bar.el (menu-bar-describe-menu): Add describe-package.
- * net/tramp-compat.el (tramp-compat-delete-file): Rewrite to
- handle new TRASH arg of `delete-file'.
+ * emacs-lisp/package.el (package-refresh-contents): Catch errors
+ when downloading archives.
+ (describe-package-1): Add package commentary.
+ (package-install-button-action): New function.
+ (package-menu-mode-map): Bind ? to package-menu-describe-package.
+ (package-menu-view-commentary): Function removed.
+ (package-list-packages-internal): Hide the `package' package too.
-2010-08-26 Christian Lynbech <christian.lynbech@tieto.com> (tiny change)
+2010-08-25 Kenichi Handa <handa@m17n.org>
- * net/tramp.el (tramp-handle-insert-directory): Don't use
- `forward-word', its default syntax could be changed.
+ * language/misc-lang.el ("Arabic"): New language environment.
+ Setup composition-function-table for Arabic characters.
-2010-08-26 Toru TSUNEYOSHI <t_tuneyosi@hotmail.com>
- Michael Albinus <michael.albinus@gmx.de>
+ * international/fontset.el (setup-default-fontset): Fix typo for
+ arabic OTF spec (fini->fina).
- Implement compression for inline methods.
+2010-08-25 Jan Djärv <jan.h.d@swipnet.se>
- * net/tramp.el (tramp-inline-compress-start-size): New defcustom.
- (tramp-copy-size-limit): Allow also nil.
- (tramp-inline-compress-commands): New defconst.
- (tramp-find-inline-compress, tramp-get-inline-compress)
- (tramp-get-inline-coding): New defuns.
- (tramp-get-remote-coding, tramp-get-local-coding): Remove,
- replaced by `tramp-get-inline-coding'.
- (tramp-handle-file-local-copy, tramp-handle-write-region)
- (tramp-method-out-of-band-p): Use `tramp-get-inline-coding'.
+ * menu-bar.el (menu-bar-set-tool-bar-position): Set frame parameter
+ on all frames.
-2010-08-26 Noah Lavine <noah549@gmail.com> (tiny change)
+2010-08-24 Vinicius Jose Latorre <viniciusjl@ig.com.br>
- Detect ssh 'ControlMaster' argument automatically in some cases.
+ * whitespace.el: Allow cleaning up blanks without blank
+ visualization (Bug#6651). Adjust help window for
+ whitespace-toggle-options (Bug#6479). Allow to use fill-column
+ instead of whitespace-line-column (from EmacsWiki). New version
+ 13.1.
+ (whitespace-style): Added new value 'face. Adjust docstring.
+ (whitespace-space, whitespace-hspace, whitespace-tab):
+ Adjust foreground property face.
+ (whitespace-line-column): Adjust docstring and type declaration.
+ (whitespace-style-value-list, whitespace-toggle-option-alist)
+ (whitespace-help-text): Adjust const initialization.
+ (whitespace-toggle-options, global-whitespace-toggle-options):
+ Adjust docstring.
+ (whitespace-display-window, whitespace-interactive-char)
+ (whitespace-style-face-p, whitespace-color-on): Adjust code.
+ (whitespace-help-scroll): New fun.
- * net/tramp.el (tramp-detect-ssh-controlmaster): New defun.
- (tramp-default-method): Use it.
+2010-08-24 Chong Yidong <cyd@stupidchicken.com>
-2010-08-26 Karel Klíč <kklic@redhat.com>
+ * emacs-lisp/package.el (list-packages): Alias for
+ package-list-packages.
- * net/tramp.el (tramp-file-name-for-operation):
- Add file-selinux-context.
+2010-08-24 Kevin Ryde <user42@zip.com.au>
-2010-08-26 Łukasz Stelmach <lukasz.stelmach@iem.pw.edu.pl> (tiny change)
+ * textmodes/flyspell.el (flyspell-check-tex-math-command): Doc fix
+ (Bug#5651).
- * play/cookie1.el (read-cookie): Fix off-by-one error (bug#6921).
+ * progmodes/ruby-mode.el (ruby): Add defgroup.
-2010-08-26 Chong Yidong <cyd@stupidchicken.com>
+2010-08-24 Chong Yidong <cyd@stupidchicken.com>
- * simple.el (beginning-of-buffer, end-of-buffer): Doc fix
- (Bug#6907).
+ * progmodes/python.el: Add Ipython support (Bug#5390).
+ (python-shell-prompt-alist)
+ (python-shell-continuation-prompt-alist): New options.
+ (python--set-prompt-regexp): New function.
+ (inferior-python-mode, run-python, python-shell):
+ Require ansi-color. Use python--set-prompt-regexp to set the comint
+ prompt based on the Python interpreter.
+ (python--prompt-regexp): New var.
+ (python-check-comint-prompt)
+ (python-comint-output-filter-function): Use it.
+ (run-python): Use a pipe (Bug#5694).
+
+2010-08-24 Fabian Ezequiel Gallina <galli.87@gmail.com> (tiny change)
+
+ * progmodes/python.el (python-send-region): Send a different
+ Python command if Ipython is in use.
+ (python-check-version): Use a Python command to find the version.
+
+2010-08-24 Chong Yidong <cyd@stupidchicken.com>
+
+ * mouse.el (mouse-yank-primary): Avoid setting primary when
+ deactivating the mark (Bug#6872).
-2010-08-23 Chris Foote <chris@foote.com.au> (tiny change)
+2010-08-23 Chris Foote <chris@foote.com.au> (tiny change)
* progmodes/python.el (python-block-pairs): Allow use of "finally"
with "else" (Bug#3991).
+2010-08-23 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/dbus.el: Accept UNIX domain sockets as bus address.
+ (top): Don't initialize `dbus-registered-objects-table' anymore,
+ this is done in dbusbind,c.
+ (dbus-check-event): Adapt test for bus.
+ (dbus-return-values-table, dbus-unregister-service)
+ (dbus-event-bus-name, dbus-introspect, dbus-register-property):
+ Adapt doc string.
+
+2010-08-23 Juanma Barranquero <lekktu@gmail.com>
+
+ * ido.el (ido-use-virtual-buffers): Fix typo in docstring.
+
+2010-08-22 Juri Linkov <juri@jurta.org>
+
+ * simple.el (read-extended-command): New function with the logic
+ for `completing-read' moved to Elisp from `execute-extended-command'.
+ Use `function-called-at-point' in `minibuffer-default-add-function'
+ to get a command name for M-n (bug#5364, bug#5214).
+
+2010-08-22 Chong Yidong <cyd@stupidchicken.com>
+
+ * startup.el (command-line-1): Issue warning for ignored arguments
+ --unibyte, etc (Bug#6886).
+
2010-08-22 Leo <sdl.web@gmail.com>
* net/rcirc.el (rcirc-add-or-remove): Accept a list of elements.
@@ -1224,45 +4644,29 @@
* emacs-lisp/easy-mmode.el (define-minor-mode): Doc fix (Bug#6880).
-2010-08-21 Vinicius Jose Latorre <viniciusjl@ig.com.br>
-
- * whitespace.el: Fix slow cursor movement (Bug#6172). Reported by
- Christoph Groth <cwg@falma.de> and Liu Xin <x_liu@neusoft.com>.
- New version 13.0.
- (whitespace-empty-at-bob-regexp, whitespace-empty-at-eob-regexp):
- Adjust initialization.
- (whitespace-bob-marker, whitespace-eob-marker)
- (whitespace-buffer-changed): New vars.
- (whitespace-cleanup, whitespace-color-on, whitespace-color-off)
- (whitespace-empty-at-bob-regexp, whitespace-empty-at-eob-regexp)
- (whitespace-post-command-hook, whitespace-display-char-on):
- Adjust code.
- (whitespace-looking-back, whitespace-buffer-changed): New funs.
- (whitespace-space-regexp, whitespace-tab-regexp): Eliminate funs.
-
-2010-08-21 Leo <sdl.web@gmail.com>
+2010-08-22 Leo <sdl.web@gmail.com>
Fix buffer-list rename&refresh after killing a buffer in ido.
- * lisp/ido.el: Revert Óscar's.
+ * ido.el: Revert Óscar's.
(ido-kill-buffer-at-head): Exit the minibuffer with ido-exit=refresh.
Remember the buffers at head, rather than their name.
- * lisp/iswitchb.el (iswitchb-kill-buffer): Re-make the list.
+ * iswitchb.el (iswitchb-kill-buffer): Re-make the list.
-2010-08-21 Kirk Kelsey <kirk.kelsey@0x4b.net> (tiny change)
+2010-08-22 Kirk Kelsey <kirk.kelsey@0x4b.net> (tiny change)
Stefan Monnier <monnier@iro.umontreal.ca>
* progmodes/make-mode.el (makefile-fill-paragraph): Account for the
extra backslash added to each line (bug#6890).
-2010-08-21 Stefan Monnier <monnier@iro.umontreal.ca>
+2010-08-22 Stefan Monnier <monnier@iro.umontreal.ca>
* subr.el (read-key): Don't echo keystrokes (bug#6883).
-2010-08-21 Glenn Morris <rgm@gnu.org>
+2010-08-22 Glenn Morris <rgm@gnu.org>
* menu-bar.el (menu-bar-games-menu): Add landmark.
-2010-08-20 Glenn Morris <rgm@gnu.org>
+2010-08-22 Glenn Morris <rgm@gnu.org>
* align.el (align-regexp): Make group and spacing arguments
use the interactive defaults when non-interactive. (Bug#6698)
@@ -1272,41 +4676,355 @@
(mail-text-start): Remove declaration.
(rmail-retry-failure): Require sendmail.
-2010-08-19 Stefan Monnier <monnier@iro.umontreal.ca>
+2010-08-22 Chong Yidong <cyd@stupidchicken.com>
* subr.el (read-key): Don't hide the menu-bar entries (bug#6881).
-2010-08-18 Michael Albinus <michael.albinus@gmx.de>
+2010-08-22 Michael Albinus <michael.albinus@gmx.de>
* progmodes/flymake.el (flymake-start-syntax-check-process):
Use `start-file-process' in order to let it run also on remote hosts.
-2010-08-18 Kenichi Handa <handa@m17n.org>
+2010-08-22 Kenichi Handa <handa@m17n.org>
* files.el: Add `word-wrap' as safe local variable.
-2010-08-18 Glenn Morris <rgm@gnu.org>
+2010-08-22 Glenn Morris <rgm@gnu.org>
* woman.el (woman-translate): Case matters. (Bug#6849)
-2010-08-14 Chong Yidong <cyd@stupidchicken.com>
+2010-08-22 Chong Yidong <cyd@stupidchicken.com>
* simple.el (kill-region): Doc fix (Bug#6787).
-2010-08-14 Glenn Morris <rgm@gnu.org>
+2010-08-22 Glenn Morris <rgm@gnu.org>
* calendar/diary-lib.el (diary-header-line-format):
Fit it to the window, not the frame.
-2010-08-11 Andreas Schwab <schwab@linux-m68k.org>
+2010-08-22 Andreas Schwab <schwab@linux-m68k.org>
* subr.el (ignore-errors): Add debug declaration.
-2010-08-09 Geoff Gole <geoffgole@gmail.com> (tiny change)
+2010-08-22 Geoff Gole <geoffgole@gmail.com> (tiny change)
* whitespace.el (whitespace-color-off): Remove post-command-hook
locally.
+2010-08-21 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * vc/add-log.el (add-log-file-name): Don't get confused by symlinks.
+
+2010-08-21 Chong Yidong <cyd@stupidchicken.com>
+
+ * cus-edit.el (custom-group-value-create): Add extra newline
+ before end line (Bug#6876).
+
+2010-08-21 Chong Yidong <cyd@stupidchicken.com>
+
+ * mouse.el (mouse-save-then-kill): Don't save region to kill ring
+ when extending it. Before killing on the second click, check if
+ the buffer is the correct one. Doc fix.
+ (mouse-secondary-save-then-kill): Allow usage without first
+ calling mouse-start-secondary, by defaulting to point. Don't save
+ an empty secondary selection. Doc fix.
+
+2010-08-21 Vinicius Jose Latorre <viniciusjl@ig.com.br>
+
+ * whitespace.el: Fix slow cursor movement (Bug#6172). Reported by
+ Christoph Groth <cwg@falma.de> and Liu Xin <x_liu@neusoft.com>.
+ New version 13.0.
+ (whitespace-empty-at-bob-regexp, whitespace-empty-at-eob-regexp):
+ Adjust initialization.
+ (whitespace-bob-marker, whitespace-eob-marker)
+ (whitespace-buffer-changed): New vars.
+ (whitespace-cleanup, whitespace-color-on, whitespace-color-off)
+ (whitespace-empty-at-bob-regexp, whitespace-empty-at-eob-regexp)
+ (whitespace-post-command-hook, whitespace-display-char-on):
+ Adjust code.
+ (whitespace-looking-back, whitespace-buffer-changed): New funs.
+ (whitespace-space-regexp, whitespace-tab-regexp): Fun eliminated.
+
+2010-08-19 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * files.el (locate-file-completion-table): Only list the .el and .elc
+ extensions if there's no other choice (bug#5955).
+
+ * facemenu.el (facemenu-self-insert-data): New var.
+ (facemenu-post-self-insert-function, facemenu-set-self-insert-face):
+ New functions.
+ (facemenu-add-face): Use them.
+
+ * simple.el (blink-matching-open): Obey forward-sexp-function.
+
+2010-08-18 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * simple.el (prog-mode-map): New var.
+ (prog-indent-sexp): New command.
+
+ * progmodes/octave-mod.el (octave-mode-menu): Make toggle buttons.
+
+ * progmodes/prolog.el (smie): Require.
+
+ * emacs-lisp/smie.el (smie-default-backward-token)
+ (smie-default-forward-token): Strip properties.
+ (smie-next-sexp): Be more careful with associative operators.
+ (smie-forward-sexp-command): Generalize.
+ (smie-backward-sexp-command): Simplify.
+ (smie-closer-alist): New var.
+ (smie-close-block): New command.
+ (smie-indent-debug-log): New var.
+ (smie-indent-offset-rule): Add a few more cases.
+ (smie-indent-column): New function.
+ (smie-indent-after-keyword): Use it.
+ (smie-indent-keyword): Use it.
+ Fix up the opener code's point position.
+ (smie-indent-comment): Only applies at BOL.
+ (smie-indent-debug): New command.
+
+ * emacs-lisp/autoload.el (make-autoload): Preload the macros's
+ declarations that are useful before running the macro.
+
+2010-08-18 Joakim Verona <joakim@verona.se>
+
+ * image.el (imagemagick-types-inhibit): New variable.
+ (imagemagick-register-types): New function.
+ * image-mode.el (image-transform-properties): New function.
+ (image-transform-set-scale, image-transform-fit-to-height)
+ (image-transform-set-rotation, image-transform-set-resize)
+ (image-transform-fit-to-width, image-transform-fit-to-height):
+ New functions.
+ (image-toggle-display-image): Support image transforms.
+
+2010-08-18 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * image.el (create-animated-image): Don't add heuristic mask to image
+ (Bug#6839).
+
+2010-08-18 Jan Djärv <jan.h.d@swipnet.se>
+
+ * term/ns-win.el (ns-get-pasteboard, ns-set-pasteboard):
+ Use QCLIPBOARD instead of QPRIMARY (Bug#6677).
+
+2010-08-17 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/lisp.el (up-list): Obey forward-sexp-function if set.
+
+ Font-lock '...' strings, plus various simplifications and fixes.
+ * progmodes/octave-mod.el (octave-font-lock-keywords): Use regexp-opt.
+ (octave-font-lock-close-quotes): New function.
+ (octave-font-lock-syntactic-keywords): New var.
+ (octave-mode): Use it. Set beginning-of-defun-function.
+ (octave-mode-map): Don't override the <foo>-defun commands.
+ (octave-mode-menu): Pass it directly to easy-menu-define;
+ remove (now generic) <foo>-defun commands; use info-lookup-symbol.
+ (octave-block-match-alist): Fix up last change so that
+ octave-close-block uses the more specific keyword.
+ (info-lookup-mode): Silence byte-compiler.
+ (octave-beginning-of-defun): Not interactive any more.
+ Optimize slightly.
+ (octave-end-of-defun, octave-mark-defun, octave-in-defun-p): Remove.
+ (octave-indent-defun, octave-send-defun): Use mark-defun instead.
+ (octave-completion-at-point-function): Make sure point is within
+ beg..end.
+ (octave-reindent-then-newline-and-indent):
+ Use reindent-then-newline-and-indent.
+ (octave-add-octave-menu): Remove.
+
+2010-08-17 Jan Djärv <jan.h.d@swipnet.se>
+
+ * mail/emacsbug.el (report-emacs-bug-insert-to-mailer)
+ (report-emacs-bug-can-use-xdg-email): New functions.
+ (report-emacs-bug): Set can-xdg-email to result of
+ report-emacs-bug-can-use-xdg-email. If can-xdg-email bind
+ \C-cm to report-emacs-bug-insert-to-mailer and add help text
+ about it.
+
+ * net/browse-url.el (browse-url-default-browser): Add cond
+ for browse-url-xdg-open.
+ (browse-url-can-use-xdg-open, browse-url-xdg-open): New functions.
+
+2010-08-17 Glenn Morris <rgm@gnu.org>
+
+ * progmodes/cc-engine.el (c-new-BEG, c-new-END)
+ (c-fontify-recorded-types-and-refs): Define for compiler.
+ * progmodes/cc-mode.el (c-new-BEG, c-new-END): Move definitions
+ before use.
+
+ * calendar/icalendar.el (icalendar--convert-recurring-to-diary):
+ Fix format call.
+
+2010-08-17 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-handle-make-symbolic-link): Flush file
+ properties.
+ (tramp-handle-process-file): Call the program in a subshell, in
+ order to preserve working directory.
+ (tramp-action-password): Hide password prompt before next run.
+ (tramp-process-actions): Widen connection buffer for the trace.
+
+2010-08-16 Deniz Dogan <deniz.a.m.dogan@gmail.com>
+
+ * net/rcirc.el (rcirc-log-process-buffers): New option.
+ (rcirc-print): Use it.
+ (rcirc-generate-log-filename): New function.
+ (rcirc-log-filename-function): Change default to
+ rcirc-generate-log-filename (Bug#6828).
+
+2010-08-16 Chong Yidong <cyd@stupidchicken.com>
+
+ * simple.el (deactivate-mark): If select-active-regions is `only',
+ only set selection for temporarily active regions.
+
+ * cus-start.el: Change defcustom for select-active-regions.
+
+2010-08-15 Chong Yidong <cyd@stupidchicken.com>
+
+ * mouse.el (mouse--drag-set-mark-and-point): New function.
+ (mouse-drag-track): Use LOCATION arg to push-mark.
+ Use mouse--drag-set-mark-and-point to take click-count into
+ consideration when updating point and mark (Bug#6840).
+
+2010-08-15 Chong Yidong <cyd@stupidchicken.com>
+
+ * progmodes/compile.el (compilation-error-regexp-alist-alist):
+ Give the Ruby rule a lower priority than Gnu (Bug#6778).
+
+2010-08-14 Štěpán Němec <stepnem@gmail.com> (tiny change)
+
+ * font-lock.el (lisp-font-lock-keywords-2):
+ Add combine-after-change-calls, condition-case-no-debug,
+ with-demoted-errors, and with-silent-modifications (Bug#6025).
+
+2010-08-14 Kevin Ryde <user42@zip.com.au>
+
+ * emacs-lisp/copyright.el (copyright-update-year)
+ (copyright-update): Temporary switch-to-buffer to ensure the
+ buffer change being queried is visible (Bug#5394).
+
+2010-08-14 Tom Tromey <tromey@redhat.com>
+
+ * progmodes/etags.el (tags-file-name): Mark safe if stringp
+ (Bug#6733).
+
+2010-08-14 Eli Zaretskii <eliz@gnu.org>
+
+ * mouse.el (mouse-yank-primary): Fix mouse-2 on MS-Windows and
+ MS-DOS. (Bug#6689)
+
+2010-08-13 Jan Djärv <jan.h.d@swipnet.se>
+
+ * menu-bar.el (menu-bar-set-tool-bar-position): New function.
+ (menu-bar-showhide-tool-bar-menu-customize-enable-left)
+ (menu-bar-showhide-tool-bar-menu-customize-enable-right)
+ (menu-bar-showhide-tool-bar-menu-customize-enable-top)
+ (menu-bar-showhide-tool-bar-menu-customize-enable-bottom):
+ Call menu-bar-set-tool-bar-position.
+
+2010-08-12 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/octave-mod.el (octave-mode-syntax-table): Use the new "c"
+ comment style (bug#6834).
+ * progmodes/scheme.el (scheme-mode-syntax-table):
+ * emacs-lisp/lisp-mode.el (lisp-mode-syntax-table): Remove spurious
+ "b" flag in "' 14b" syntax.
+
+ * progmodes/octave-mod.el (octave-mode-map): Remove special bindings
+ for (un)commenting the region and performing completion.
+ (octave-mode-menu): Use standard commands for help and completion.
+ (octave-mode-syntax-table): Support %{..%} comments (sort of).
+ (octave-mode): Use define-derived-mode.
+ Set completion-at-point-functions and don't set columns.
+ Don't disable adaptive-fill-regexp.
+ (octave-describe-major-mode, octave-comment-region)
+ (octave-uncomment-region, octave-comment-indent)
+ (octave-indent-for-comment): Remove.
+ (octave-indent-calculate): Rename from calculate-octave-indent.
+ (octave-indent-line, octave-fill-paragraph): Update caller.
+ (octave-initialize-completions): No need to make an alist.
+ (octave-completion-at-point-function): New function.
+ (octave-complete-symbol): Use it.
+ (octave-insert-defun): Use define-skeleton.
+
+ * progmodes/octave-mod.el (octave-mode): Set comment-add.
+ (octave-mode-map): Use comment-dwim (bug#6829).
+
+2010-08-12 Antoine Levitt <antoine.levitt@gmail.com> (tiny change)
+
+ * cus-edit.el (custom-save-variables, custom-save-faces): Fix up
+ indentation of inserted comment.
+
+2010-08-11 Jan Djärv <jan.h.d@swipnet.se>
+
+ * faces.el (region): Add type gtk that uses gtk colors.
+
+ * dynamic-setting.el (dynamic-setting-handle-config-changed-event):
+ Handle theme-name change.
+
+2010-08-10 Michael R. Mauger <mmaug@yahoo.com>
+
+ * progmodes/sql.el: Version 2.5
+ (sql-product-alist): Add :prompt-cont-regexp property for several
+ database products.
+ (sql-prompt-cont-regexp): New variable.
+ (sql-output-newline-count, sql-output-by-send):
+ New variables. Record number of newlines in input text.
+ (sql-send-string): Handle multiple filters and count newlines.
+ (sql-send-magic-terminator): Count terminator newline.
+ (sql-interactive-remove-continuation-prompt): Filters output to
+ remove continuation prompts; one for each newline.
+ (sql-interactive-mode): Set up new variables, prompt regexp and
+ output filter.
+ (sql-mode-sqlite-font-lock-keywords): Correct some keywords.
+ (sql-make-alternate-buffer-name): Correct buffer name in edge cases.
+
+2010-08-10 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/pcase.el: New file.
+
+2010-08-10 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-vc-registered-read-file-names): Read input
+ as here-document, otherwise the command could exceed maximum
+ length of command line.
+ (tramp-handle-vc-registered): Call script accordingly.
+ Reported by Toru TSUNEYOSHI <t_tuneyosi@hotmail.com>.
+
+2010-08-10 Kenichi Handa <handa@m17n.org>
+
+ * language/hebrew.el: Exclude U+05C3 (Hebrew SOF PASUQ) from the
+ composable pattern.
+
+2010-08-09 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/package.el (package-version-split)
+ (package--version-first-nonzero, package-version-compare):
+ Functions removed.
+ (package-directory-list, package-load-all-descriptors)
+ (package--built-in, package-activate, define-package)
+ (package-installed-p, package-compute-transaction)
+ (package-read-all-archive-contents)
+ (package--add-to-archive-contents, package-buffer-info)
+ (package-tar-file-info, package-list-packages-internal):
+ Use version-to-list and version-list-*.
+
+ * emacs-lisp/package-x.el (package-upload-buffer-internal):
+ Use version-to-list.
+ (package-upload-buffer-internal): Use version-list-<=.
+
+2010-08-09 Kenichi Handa <handa@m17n.org>
+
+ * language/hebrew.el: Exclude U+05BD (Hebrew MAQAF) from the
+ composable pattern.
+
+2010-08-08 Chong Yidong <cyd@stupidchicken.com>
+
+ * tutorial.el (tutorial--default-keys): C-d is now bound to
+ delete-forward-char (Bug#6826).
+
+ * mouse.el (mouse-drag-track): Remove accidentally-removed check
+ for `double' value of mouse-1-click-follows-link (Bug#6807).
+
2010-08-08 Johan Bockgård <bojohan@gnu.org>
* replace.el (replace-highlight): Bind isearch-forward and
@@ -1317,22 +5035,21 @@
(isearch-lazy-highlight-new-loop, isearch-lazy-highlight-search):
(isearch-lazy-highlight-update): Use it.
-2010-08-06 Kenichi Handa <handa@m17n.org>
+2010-08-08 Kenichi Handa <handa@m17n.org>
* international/mule.el (define-charset): Store NAME as :base property.
(ctext-non-standard-encodings-table): Pay attention to charset aliases.
(ctext-pre-write-conversion): Sort ctext-standard-encodings by the
current priority. Force using the designation of the specific
- charset by adding `charset' text property. Improve the whole
- algorithm.
+ charset by adding `charset' text property. Improve the whole algorithm.
-2010-08-05 Juanma Barranquero <lekktu@gmail.com>
+2010-08-08 Juanma Barranquero <lekktu@gmail.com>
* emulation/pc-select.el (pc-selection-mode-hook)
(copy-region-as-kill-nomark, beginning-of-buffer-mark)
(pc-selection-mode): Fix typos in docstrings.
-2010-08-04 Kenichi Handa <handa@m17n.org>
+2010-08-08 Kenichi Handa <handa@m17n.org>
* language/cyrillic.el: Don't add "microsoft-cp1251" to
ctext-non-standard-encodings-alist here.
@@ -1349,11 +5066,11 @@
(ctext-no-compositions): Doc fix.
(compound-text-with-extensions): Doc fix.
-2010-08-04 Stefan Monnier <monnier@iro.umontreal.ca>
+2010-08-08 Stefan Monnier <monnier@iro.umontreal.ca>
* simple.el (exchange-dot-and-mark): Mark obsolete, finally.
-2010-08-03 Juanma Barranquero <lekktu@gmail.com>
+2010-08-08 Juanma Barranquero <lekktu@gmail.com>
* progmodes/which-func.el (which-func-format): Split help-echo text
into lines, like other mode-line tooltips.
@@ -1361,64 +5078,535 @@
* server.el (server-start): When using TCP sockets, force IPv4
and use a literal 127.0.0.1 for localhost. (Related to bug#6781.)
-2010-08-02 Stefan Monnier <monnier@iro.umontreal.ca>
+2010-08-08 Stefan Monnier <monnier@iro.umontreal.ca>
* bindings.el (complete-symbol): Run completion-at-point as a fallback.
-2010-08-02 Juanma Barranquero <lekktu@gmail.com>
+2010-08-08 Juanma Barranquero <lekktu@gmail.com>
* term.el (term-delimiter-argument-list): Reflow docstring.
(term-read-input-ring, term-write-input-ring, term-send-input)
(term-bol, term-erase-in-display, serial-supported-or-barf):
Fix typos in docstrings.
-2010-08-02 Stefan Monnier <monnier@iro.umontreal.ca>
+2010-08-08 Stefan Monnier <monnier@iro.umontreal.ca>
* bindings.el (function-key-map): Add a S-tab => backtab fallback.
-2010-08-01 Juanma Barranquero <lekktu@gmail.com>
+2010-08-08 Juanma Barranquero <lekktu@gmail.com>
* dabbrev.el (dabbrev-completion): Fix typo in docstring.
-2010-08-01 MON KEY <monkey@sandpframing.com> (tiny change)
+2010-08-08 MON KEY <monkey@sandpframing.com> (tiny change)
* emacs-lisp/syntax.el (syntax-ppss-toplevel-pos):
Fix typo in docstring (bug#6747).
-2010-07-30 Leo <sdl.web@gmail.com>
+2010-08-08 Leo <sdl.web@gmail.com>
* eshell/esh-io.el (eshell-get-target): Better detection of
read-only file (Bug#6762).
-2010-07-30 Juanma Barranquero <lekktu@gmail.com>
+2010-08-08 Juanma Barranquero <lekktu@gmail.com>
* align.el (align-default-spacing): Doc fix.
(align-region-heuristic, align-regexp): Fix typos in docstrings.
-2010-07-23 Juanma Barranquero <lekktu@gmail.com>
+2010-08-08 Stephen Peters <speters@itasoftware.com>
- * help-fns.el (find-lisp-object-file-name): Doc fix (bug#6494).
+ * calendar/icalendar.el
+ (icalendar--split-value): Fix splitting regexp. (Bug#6766)
+ (icalendar--get-weekday-numbers): New.
+ (icalendar--convert-recurring-to-diary): Handle multiple byday
+ values in weekly rules. (Bug#6766)
-2010-07-19 Juanma Barranquero <lekktu@gmail.com>
+2010-08-08 Ulf Jasper <ulf.jasper@web.de>
+
+ * calendar/icalendar.el (icalendar-uid-format): Doc fix.
+ (icalendar--create-uid, icalendar-export-region)
+ (icalendar--parse-summary-and-rest): Code formatting.
+
+2010-08-08 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc.el (calc-trail-mode,calc-refresh): Use `face' property
+ to italicize headers.
+ (calc-highlight-selections-with-faces): New variable.
+ (calc-selected-face, calc-nonselected-face): New faces.
+
+ * calc/calccomp.el (math-comp-highlight-string): Use
+ `calc-highlight-selections-with-faces' to determine how to highlight
+ sub-formulas.
+
+ * calc/calc-sel.el (calc-show-selections): Change message to when
+ using faces to highlight selections.
+
+2010-08-07 Michael R. Mauger <mmaug@yahoo.com>
+
+ * progmodes/sql.el (sql-mode-sqlite-font-lock-keywords):
+ Add SQLite 3 keywords, functions and datatypes.
+ (sql-interactive-mode): Remove `comint-process-echoes' set to t
+ (Bug#6686).
+
+2010-08-07 Chong Yidong <cyd@stupidchicken.com>
+
+ * simple.el (select-active-regions): Move to keyboard.c.
+ (deactivate-mark): Used saved-region-selection.
+ (select-active-region): Function removed.
+ (activate-mark, set-mark, push-mark-command)
+ (handle-shift-selection): Don't call it.
+ (keyboard-quit): Avoid adding the region to the window selection.
+
+ * mouse.el (mouse-drag-track): Remove hacks to deal with old
+ select-active-regions implementation.
+ (mouse-yank-at-click): Doc fix.
+
+ * cus-start.el: Add custom declaration for select-active-regions.
+
+2010-08-07 Eli Zaretskii <eliz@gnu.org>
+
+ * simple.el (delete-forward-char): Doc fix.
+
+ * tutorial.el (help-with-tutorial): Hack safe file-local variables
+ after reading the tutorial.
+
+2010-08-06 Alan Mackenzie <bug-cc-mode@gnu.org>
+
+ * progmodes/cc-cmds.el (c-mask-paragraph, c-fill-paragraph):
+ Fix for the case that a C style comment has its delimiters alone on
+ their respective lines.
+
+2010-08-06 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-handle-start-file-process): Set connection
+ property "vec".
+ (tramp-process-sentinel): Use it for flushing the cache.
+ We cannot do it via the process buffer, the buffer could be deleted
+ already when running the sentinel.
+
+2010-08-06 Jürgen Hötzel <juergen@archlinux.org> (tiny change)
+
+ * comint.el (comint-mode): Make directory tracking functions
+ functional on remote files. (Bug#6764)
+
+2010-08-06 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc/diff-mode.el (diff-mode-shared-map): Bind g to revert-buffer.
+
+2010-08-05 Eli Zaretskii <eliz@gnu.org>
+
+ * emacs-lisp/find-gc.el (find-gc-source-files):
+ Rename unexec.c => unexcoff.c.
+
+ * emacs-lisp/authors.el (authors-fixed-entries):
+ Rename unexec.c => unexcoff.c.
+
+2010-08-05 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-handle-dired-uncache): Flush directory
+ cache, not only file cache.
+ (tramp-process-sentinel): New defun.
+ (tramp-handle-start-file-process): Use it, in order to invalidate
+ file caches.
+
+2010-08-03 Leo <sdl.web@gmail.com>
+
+ * server.el (server-start): Simplify loop.
+
+2010-08-02 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * frame.el (screen-height, screen-width, set-screen-width)
+ (set-screen-height): Remove ancient compatibility aliases.
+
+ * textmodes/fill.el (justify-current-line): Don't add 1 to nspaces
+ when justifying. It seems useless and harmful for ncols=1 (bug#6738).
+
+ * emacs-lisp/timer.el (timer-event-handler): Protect against timers
+ that change current buffer.
+
+2010-08-01 YAMAMOTO Mitsuharu <mituharu@math.s.chiba-u.ac.jp>
+
+ * mouse.el (mouse-fixup-help-message): Match "mouse-2" only at the
+ beginning of the string. Use `string-match-p'. (Bug#6765)
+
+2010-08-01 Jan Djärv <jan.h.d@swipnet.se>
+
+ * cus-start.el (x-gtk-use-system-tooltips): New variable.
+
+2010-08-01 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/package.el (package--list-packages): Fix column alignment.
+ (package--builtins): Tweak descriptions.
+ (package-print-package): Upcase descriptions if necessary.
+ Show all built-in packages in font-lock-builtin-face.
+ (package-list-packages-internal): Omit "emacs" package.
+ Show status of built-in packages as "built-in".
+
+2010-07-31 Chong Yidong <cyd@stupidchicken.com>
+
+ * mouse.el (mouse-save-then-kill): Doc fix. Deactivate mark
+ before killing to preserve the primary selection (Bug#6701).
+
+ * term/x-win.el (x-select-text): Doc fix.
+
+2010-07-31 Nathaniel Flath <flat0103@gmail.com>
+
+ * progmodes/cc-vars.el (c-offsets-alist, c-inside-block-syms)
+ (objc-font-lock-extra-types):
+ * progmodes/cc-mode.el (c-basic-common-init):
+ * progmodes/cc-langs.el (c-make-mode-syntax-table)
+ (c++-make-template-syntax-table)
+ (c-identifier-syntax-modifications, c-symbol-start, c-operators)
+ (c-<-op-cont-regexp, c->-op-cont-regexp, c-class-decl-kwds)
+ (c-brace-list-decl-kwds, c-modifier-kwds, c-prefix-spec-kwds-re)
+ (c-type-list-kwds, c-decl-prefix-re, c-opt-type-suffix-key):
+ * progmodes/cc-fonts.el (c-make-inverse-face)
+ (c-basic-matchers-after):
+ * progmodes/cc-engine.el (c-forward-keyword-clause)
+ (c-forward-<>-arglist, c-forward-<>-arglist-recur)
+ (c-forward-name, c-forward-type, c-forward-decl-or-cast-1)
+ (c-guess-continued-construct, c-guess-basic-syntax):
+ Enhance Java Mode to handle Java 5.0 (Tiger) and Java 6 (Mustang).
+ The above functions were modified or created.
+
+2010-07-31 Jan Djärv <jan.h.d@swipnet.se>
+
+ * faces.el (face-all-attributes): Improve documentation (Bug#6767).
+
+2010-07-31 Eli Zaretskii <eliz@gnu.org>
+
+ * files.el (bidi-paragraph-direction): Define safe local values.
+
+ * language/hebrew.el ("Hebrew"): Add TUTORIAL.he to
+ language-info-alist. Remove outdated FIXME in a comment.
+
+2010-07-31 Alan Mackenzie <acm@muc.de>
+
+ * progmodes/cc-cmds.el (c-mask-paragraph): Fix bug #6688:
+ Auto-fill broken in C/C++ modes.
+
+2010-07-29 Jan Djärv <jan.h.d@swipnet.se>
+
+ * menu-bar.el (menu-bar-showhide-tool-bar-menu-customize-enable-left)
+ (menu-bar-showhide-tool-bar-menu-customize-disable)
+ (menu-bar-showhide-tool-bar-menu-customize-enable-right)
+ (menu-bar-showhide-tool-bar-menu-customize-enable-bottom)
+ (menu-bar-showhide-tool-bar-menu-customize-enable-top): New functions
+ (menu-bar-showhide-tool-bar-menu): If tool bar is moveable,
+ make a menu for Options => toolbar that can move it.
+
+2010-07-29 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/package-x.el (package--make-rss-entry):
+ (package-maint-add-news-item, package--update-news)
+ (package-upload-buffer-internal): New arg ARCHIVE-URL.
+
+ * emacs-lisp/package.el (package-archive-url): Rename from
+ package-archive-id.
+ (package-install): Doc fix.
+ (package-download-single, package-download-tar, package-install)
+ (package-menu-view-commentary): Callers changed.
+
+2010-07-29 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-handle-start-file-process): Check only for
+ `remote-tty' process property.
+ (tramp-open-shell): Don't check for tty.
+ (tramp-open-connection-setup-interactive-shell): Set `remote-tty'
+ process property.
+
+ * progmodes/gdb-mi.el (gdb-init-1): Check also for tty on a remote
+ host.
+
+2010-07-28 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/package.el (package-load-list, package-archives)
+ (package-archive-contents, package-user-dir)
+ (package-directory-list, package--builtins, package-alist)
+ (package-activated-list, package-obsolete-alist): Mark as risky.
+
+2010-07-28 Phil Hagelberg <phil@evri.com>
+
+ Add support for non-default package repositories.
+ * emacs-lisp/package.el (package-archive-base): Var deleted.
+ (package-archives): New variable.
+ (package-archive-contents): Doc fix.
+ (package-load-descriptor): Do nothing if descriptor file is missing.
+ (package--write-file-no-coding): New function.
+ (package-unpack-single): Use it.
+ (package-archive-id): New function.
+ (package-download-single, package-download-tar)
+ (package-menu-view-commentary): Use it.
+ (package-installed-p): Make second argument optional.
+ (package-read-all-archive-contents): New function.
+ (package-initialize): Use it.
+ (package-read-archive-contents): Add ARCHIVE argument.
+ (package--add-to-archive-contents): New function.
+ (package-install): Don't call package-read-archive-contents.
+ (package--download-one-archive): Store archive file in a
+ subdirectory of package-user-dir.
+ (package-menu-execute): Remove spurious line movement.
+
+2010-07-28 Jan Djärv <jan.h.d@swipnet.se>
+
+ * cus-start.el (tool-bar-style): Add text-image-horiz.
+
+2010-07-28 Michael Albinus <michael.albinus@gmx.de>
+
+ * progmodes/gud.el (gud-common-init): Check for remoteness of
+ `file', and not of `default-directory'.
+
+2010-07-28 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-methods): Move hostname to the end in all
+ ssh `tramp-login-args'.
+ (tramp-verbose): Describe verbose level 9.
+ (tramp-open-shell): Check for tty if `tramp-verbose' >= 9.
+ (tramp-open-connection-setup-interactive-shell): Trace stty
+ settings if `tramp-verbose' >= 9.
+ (tramp-handle-start-file-process): Implement tty setting.
+ (Bug#4604, Bug#6360)
+
+ * net/tramp-cmds.el (tramp-bug): Recommend setting of
+ `tramp-verbose' to 9.
+
+2010-07-27 Aaron S. Hawley <ashawley@burlingtontelecom.net>
+
+ * emacs-lisp/re-builder.el (reb-re-syntax, reb-lisp-mode)
+ (reb-lisp-syntax-p, reb-change-syntax, reb-cook-regexp):
+ Remove references to package `lisp-re' (bug#4369).
+
+2010-07-27 Tom Tromey <tromey@redhat.com>
+
+ * progmodes/js.el (js-mode):
+ * progmodes/make-mode.el (makefile-mode):
+ * progmodes/simula.el (simula-mode):
+ * progmodes/tcl.el (tcl-mode): Derive from prog-mode.
+
+2010-07-27 Juanma Barranquero <lekktu@gmail.com>
+
+ * help-fns.el (find-lisp-object-file-name): Doc fix (bug#6494).
* time.el (display-time-day-and-date): Remove spurious * in docstring.
(display-time-world-buffer-name, display-time-world-mode-map):
Fix typos in docstrings.
-2010-07-17 Shyam Karanatt <shyam@swathanthran.in> (tiny change)
+2010-07-27 Shyam Karanatt <shyam@swathanthran.in> (tiny change)
* image-mode.el (image-display-size): New function.
(image-forward-hscroll, image-next-line, image-eol, image-eob)
(image-mode-fit-frame): Use it (Bug#6639).
-2010-07-17 Chong Yidong <cyd@stupidchicken.com>
+2010-07-27 Chong Yidong <cyd@stupidchicken.com>
* dired.el (dired-buffers-for-dir): Handle list values of
dired-directory (Bug#6636).
+2010-07-26 Sam Steingold <sds@gnu.org>
+
+ * mouse.el (mouse-yank-primary, mouse-yank-secondary):
+ Do not call `x-get-selection' the second time, reuse the value.
+
+2010-07-26 Daiki Ueno <ueno@unixuser.org>
+
+ * epa-mail.el (epa-mail-mode-map): Add alternative key bindings
+ which consist of control chars only. Suggested by Richard Stallman.
+
+2010-07-25 Daiki Ueno <ueno@unixuser.org>
+
+ * epa-file.el (epa-file-insert-file-contents): Check if LOCAL-FILE
+ exists before passing an error to find-file-not-found-functions
+ (bug#6723).
+
+2010-07-23 Lukas Huonker <l.huonker@gmail.com>
+
+ * play/tetris.el (tetris-tty-colors, tetris-x-colors, tetris-blank):
+ Remove leading nil element, adjust values.
+ (tetris-shapes, tetris-shape-scores):
+ Change representation of shapes and remove some redundancy.
+ (tetris-get-shape-cell, tetris-shape-width, tetris-draw-next-shape)
+ (tetris-draw-shape, tetris-erase-shape, tetris-test-shape):
+ Adjust for working with new representation of shapes.
+ (tetris-shape-rotations): New function.
+ (tetris-move-bottom, tetris-move-left, tetris-move-right)
+ (tetris-rotate-prev, tetris-rotate-next):
+ Adjust for working with the new version of tetris-test-shape.
+
+2010-07-23 Markus Triska <markus.triska@gmx.at>
+
+ * progmodes/ps-mode.el: Use comint (bug#5954).
+ (ps-run-mode-map): Adapt for comint-mode; omit "\r", [return]..
+ (ps-mode-other-newline): Simplify.
+ (ps-run-mode): Derive from comint-mode instead of
+ fundamental-mode, yielding input history etc.
+ (ps-run-start, ps-run-quit, ps-run-clear, ps-run-region)
+ (ps-run-send-string): Adapt for comint-mode.
+ (ps-run-newline): Remove now unneeded function.
+
+2010-07-23 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-methods): Move hostname to the end in all
+ plink `tramp-login-args'.
+
+2010-07-23 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-open-shell): New defun.
+ (tramp-find-shell, tramp-open-connection-setup-interactive-shell):
+ Use it.
+
+2010-07-23 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-file-name-regexp-unified)
+ (tramp-completion-file-name-regexp-unified): On W32 systems, do
+ not regard the volume letter as remote filename. (Bug#5447)
+
+2010-07-23 Juanma Barranquero <lekktu@gmail.com>
+
+ * custom.el (custom-declare-variable): Give a clearer error message
+ when the docstring is missing (bug#6476).
+
+2010-07-22 Michael R. Mauger <mmaug@yahoo.com>
+
+ * progmodes/sql.el: Version 2.4. Improved Login prompting.
+ (sql-login-params): New widget definition.
+ (sql-oracle-login-params, sql-mysql-login-params)
+ (sql-solid-login-params, sql-sybase-login-params)
+ (sql-informix-login-params, sql-ingres-login-params)
+ (sql-ms-login-params, sql-postgres-login-params)
+ (sql-interbase-login-params, sql-db2-login-params)
+ (sql-linter-login-params): Use it.
+ (sql-sqlite-login-params): Use it; Define "database" parameter as
+ a file name.
+ (sql-sqlite-program): Change to "sqlite3".
+ (sql-comint-sqlite): Make sure database name is complete.
+ (sql-for-each-login): New function.
+ (sql-connect, sql-save-connection): Use it.
+ (sql-get-login-ext): New function.
+ (sql-get-login): Use it.
+ (sql-make-alternate-buffer-name): Handle :file parameters.
+
+2010-07-22 Juanma Barranquero <lekktu@gmail.com>
+
+ * dired.el (dired-no-confirm): Document value t and fix defcustom to
+ accept it (bug#6597). Suggested by Drew Adams <drew.adams@oracle.com>.
+
+2010-07-22 Teemu Likonen <tlikonen@iki.fi> (tiny change)
+
+ * dired.el (dired-mode-map): Use command remapping (bug#6632).
+
+2010-07-22 Lawrence Mitchell <wence@gmx.li>
+
+ * term/vt100.el (vt100-wide-mode): Fix :init-value keyword (bug#6620).
+
+2010-07-21 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-get-ls-command)
+ (tramp-get-ls-command-with-dired): Run tests on "/dev/null"
+ instead of "/".
+
+2010-07-20 Michael R. Mauger <mmaug@yahoo.com>
+
+ * progmodes/sql.el: Version 2.3.
+ (sql-connection-alist): Changed keys from symbols to strings;
+ enhanced the widget definition.
+ (sql-mode-menu): Added submenu to select connections.
+ (sql-interactive-mode-menu): Added "Save Connection" item.
+ (sql-add-product): Fixed menu item.
+ (sql-get-product-feature): Improved error handling.
+ (sql--alt-buffer-part, sql--alt-if-not-empty): Removed.
+ (sql-make-alternate-buffer-name): Simplified.
+ (sql-product-interactive): Handle missing product.
+ (sql-connect): Support string keys, minor improvements.
+ (sql-save-connection): New function.
+ (sql-connection-menu-filter): New function.
+
+2010-07-20 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-file-name-handler): Trace 'quit.
+ (tramp-open-connection-setup-interactive-shell):
+ Apply workaround for IRIX64 bug. Move argument of last
+ `tramp-send-command' where it belongs to.
+
+2010-07-20 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-perl-file-attributes)
+ (tramp-perl-directory-files-and-attributes): Don't pass "$3".
+ (tramp-maybe-open-connection): Use `async-args' and `gw-args' in
+ front of `login-args'.
+
+2010-07-19 Juanma Barranquero <lekktu@gmail.com>
+
+ * time.el (display-time-world-mode): Define with `define-derived-mode'.
+ Set `show-trailing-whitespace' to nil.
+ (display-time-world-display): Simplify.
+
+2010-07-18 Alan Mackenzie <acm@muc.de>
+
+ Enhance `c-file-style' in file/directory local variables.
+ * progmodes/cc-mode.el (c-count-cfss): New function.
+ (c-before-hack-hook): Call `c-set-style' differently according to
+ whether c-file-style was set in file or directory local
+ variables.
+
+2010-07-18 Michael R. Mauger <mmaug@yahoo.com>
+
+ * progmodes/sql.el: Version 2.2.
+ (sql-product, sql-user, sql-database, sql-server, sql-port):
+ Use defcustom :safe keyword rather than putting safe-local-variable
+ property.
+ (sql-password): Use defcustom :risky keyword rather than putting
+ risky-local-variable property.
+ (sql-oracle-login-params, sql-sqlite-login-params)
+ (sql-solid-login-params, sql-sybase-login-params)
+ (sql-informix-login-params, sql-ingres-login-params)
+ (sql-ms-login-params, sql-postgres-login-params)
+ (sql-interbase-login-params, sql-db2-login-params)
+ (sql-linter-login-params): Add `port' option.
+ (sql-get-product-feature): Added NO-INDIRECT parameter.
+ (sql-comint-oracle, sql-comint-sybase)
+ (sql-comint-informix, sql-comint-sqlite, sql-comint-mysql)
+ (sql-comint-solid, sql-comint-ingres, sql-comint-ms)
+ (sql-comint-postgres, sql-comint-interbase, sql-comint-db2)
+ (sql-comint-linter): Renamed sql-connect-* functions to
+ sql-comint-*.
+ (sql-product-alist, sql-mode-menu): Renamed as above and
+ :sqli-connect-func to :sqli-comint-func.
+ (sql-connection): New variable.
+ (sql-interactive-mode): Set it.
+ (sql-connection-alist): New variable.
+ (sql-connect): New function.
+ (sql--alt-buffer-part, sql--alt-if-not-empty)
+ (sql-make-alternate-buffer-name): Improved alternative buffer name.
+
+2010-07-17 Thierry Volpiatto <thierry.volpiatto@gmail.com>
+
+ * image-mode.el (image-bookmark-make-record): Do not set context
+ in an image (Bug#6650).
+
+2010-07-17 Chong Yidong <cyd@stupidchicken.com>
+
+ * simple.el (select-active-region): New function.
+ (push-mark-command, set-mark, activate-mark)
+ (handle-shift-selection): Use it.
+ (deactivate-mark): Don't check for size of region.
+
+ * mouse.el (mouse-drag-track): Use select-active-region.
+
+2010-07-17 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-get-ls-command-with-dired): Make test for
+ "--dired" stronger.
+
+2010-07-17 Chong Yidong <cyd@stupidchicken.com>
+
+ * term/x-win.el (x-select-enable-primary): Change default to nil.
+ (x-select-enable-clipboard): Add :version keyword.
+
+ * mouse.el (mouse-drag-copy-region):
+ * simple.el (select-active-regions): Likewise.
+
2010-07-16 Reiner Steib <Reiner.Steib@gmx.de>
- * vc.el (vc-coding-system-inherit-eol): New defvar.
+ * vc/vc.el (vc-coding-system-inherit-eol): New defvar.
(vc-coding-system-for-diff): Use it to decide whether to inherit
from the file the EOL format for reading the diffs of that file.
(Bug#4451)
@@ -1428,15 +5616,132 @@
* mail/rmailmm.el (rmail-mime-save): Make the temp buffer
unibyte, so compressed attachments are not compressed again.
+2010-07-16 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-handle-shell-command): Don't use hard-wired
+ "/bin/sh" but `tramp-remote-sh' from `tramp-methods'.
+ (tramp-find-shell): Simplify setting connection property.
+ (tramp-get-ls-command): Make test for "--color=never" stronger.
+
+2010-07-15 Simon South <ssouth@member.fsf.org>
+
+ * progmodes/delphi.el (delphi-previous-indent-of): Indent case
+ blocks within record declarations (i.e. variant parts) correctly.
+
+2010-07-15 Simon South <ssouth@member.fsf.org>
+
+ * progmodes/delphi.el (delphi-token-at): Give newlines precedence
+ over literal tokens when parsing so newlines aren't "absorbed" by
+ single-line comments. Corrects the indentation of case blocks
+ that have a comment on the first line.
+
+2010-07-14 Karl Fogel <kfogel@red-bean.com>
+
+ * bookmark.el (bookmark-load-hook): Fix doc string as suggested
+ by Drew Adams (Bug#5504).
+
2010-07-14 Jan Djärv <jan.h.d@swipnet.se>
* xt-mouse.el (xterm-mouse-event-read): Fix for characters > 127
- now that unicode is used (Bug#6594).
+ now that Unicode is used (Bug#6594).
2010-07-14 Chong Yidong <cyd@stupidchicken.com>
- * simple.el (push-mark-command): Set the selection if
- select-active-regions is non-nil.
+ * term/x-win.el (x-select-enable-clipboard): Default to t.
+ (x-initialize-window-system): Don't overwrite Paste menu item.
+
+ * simple.el (select-active-regions): Default to t.
+ (push-mark-command): Don't overwrite primary with empty string.
+
+ * mouse.el: Bind mouse-2 to mouse-yank-primary.
+ (mouse-drag-copy-region): Default to nil.
+
+ * menu-bar.el (menu-bar-enable-clipboard): Don't overwrite
+ Cut/Copy/Paste menu bar items.
+
+2010-07-13 Thierry Volpiatto <thierry.volpiatto@gmail.com>
+
+ Allow C-w when setting a bookmark in a Gnus Article buffer (Bug#5975).
+ Patch applied by Karl Fogel.
+
+ * bookmark.el (bookmark-set): Don't set `bookmark-yank-point'
+ and `bookmark-current-buffer' if they have been already set in
+ another buffer (e.g gnus-art).
+
+2010-07-13 Karl Fogel <kfogel@red-bean.com>
+ Thierry Volpiatto <thierry.volpiatto@gmail.com>
+
+ Preparation for setting bookmarks in Gnus article buffers (Bug#5975).
+
+ * bookmark.el (bookmark-make-record-default): Allow unneeded
+ information to be omitted from the record.
+
+ Adjust declarations and calls:
+
+ * info.el (bookmark-make-record-default): Adjust declaration.
+ (Info-bookmark-make-record): Adjust call.
+
+ * woman.el (bookmark-make-record-default): Adjust declaration.
+ (woman-bookmark-make-record): Adjust call.
+
+ * man.el (bookmark-make-record-default): Adjust declaration.
+ (Man-bookmark-make-record): Adjust call.
+
+ * image-mode.el (bookmark-make-record-default): Adjust declaration.
+
+ * doc-view.el (bookmark-make-record-default): Adjust declaration.
+
+2010-07-13 Karl Fogel <kfogel@red-bean.com>
+
+ * bookmark.el (bookmark-show-annotation): Use `when' instead of `if'.
+ This is also from Thierry Volpiatto's patch in bug #6444. However,
+ because it was extraneous to the functional change in that patch,
+ and causes a re-indendation, I am committing it separately.
+
+2010-07-13 Thierry Volpiatto <thierry.volpiatto@gmail.com>
+
+ * bookmark.el (bookmark-show-annotation): Ensure annotations show,
+ e.g. in Info bookmarks, by using `switch-to-buffer-other-window'.
+ Patch applied by Karl Fogel (Bug#6444).
+
+2010-07-13 Chong Yidong <cyd@stupidchicken.com>
+
+ * frame.el (make-frame): Fix typo in 2010-06-30 change (Bug#6625).
+
+2010-07-13 Adrian Robert <Adrian.B.Robert@gmail.com>
+
+ * term/ns-win.el: Bind M-~ to 'ns-prev-frame (due to Matthew
+ Dempsky; bug#5084). Remove incorrect binding for S-tab.
+ (ns-alternatives-map): Change S-tab binding to backtab
+ (bug#6616).
+
+ * simple.el (normal-erase-is-backspace-setup-frame): Set mode on
+ under ns.
+
+2010-07-12 Andreas Schwab <schwab@linux-m68k.org>
+
+ * language/tai-viet.el ("TaiViet"): Try to fix re-encoding bugs.
+ (Bug#5806)
+
+ * language/tv-util.el (tai-viet-re): Remove format.
+
+2010-07-12 Kenichi Handa <handa@m17n.org>
+
+ * language/hebrew.el: Remove no-byte-compile declaration.
+ Change coding: tag to utf-8. Register hebrew-shape-gstring in
+ composition-function-table for 3-character looking back.
+ (hebrew-font-get-precomposed): New function.
+ (hebrew-shape-gstring): Utilize precomposed glyphs if available.
+
+2010-07-11 Chong Yidong <cyd@stupidchicken.com>
+
+ * mouse.el (mouse-drag-track): Handle select-active-regions
+ (Bug#6612).
+
+2010-07-11 Magnus Henoch <magnus.henoch@gmail.com>
+
+ * net/tramp-gvfs.el (tramp-gvfs-handle-copy-file): Do not pass
+ empty argument to gvfs-copy.
2010-07-10 Glenn Morris <rgm@gnu.org>
@@ -1452,6 +5757,31 @@
* simple.el (use-region-p): Doc fix (Bug#6607).
+2010-07-10 Aleksei Gusev <aleksei.gusev@gmail.com> (tiny change)
+
+ * progmodes/compile.el (compilation-error-regexp-alist-alist):
+ Add regexps for cucumber and ruby.
+
+2010-07-08 Daiki Ueno <ueno@unixuser.org>
+
+ * epa-file.el (epa-file-error, epa-file--find-file-not-found-function)
+ (epa-file-insert-file-contents): Hack to prevent
+ find-file from opening empty buffer when decryption failed
+ (bug#6568).
+
+2010-07-07 Agustín Martín <agustin.martin@hispalinux.es>
+
+ * textmodes/ispell.el (ispell-alternate-dictionary):
+ Use file-readable-p.
+ Return nil if no word-list is found at default locations.
+ (ispell-complete-word-dict): Default to nil.
+ (ispell-command-loop): Use 'word-list' when using lookup-words.
+ (lookup-words): Use ispell-complete-word-dict or
+ ispell-alternate-dictionary. Check for word-list availability
+ and handle errors if needed with better messages (Bug#6539).
+ (ispell-complete-word): Use ispell-complete-word-dict or
+ ispell-alternate-dictionary.
+
2010-07-07 Christoph Scholtes <cschol2112@gmail.com>
* progmodes/python.el (python-font-lock-keywords): Add Python 2.7
@@ -1460,6 +5790,194 @@
2010-07-07 Glenn Morris <rgm@gnu.org>
+ * play/zone.el (top-level): Do not require timer, tabify, or cl.
+ (zone-shift-left): Ignore intangibility, and any errors from
+ forward-char.
+ (zone-shift-right): Remove no-op end-of-line. Ignore intangibility.
+ (zone-pgm-putz-with-case): Use upcase-region rather than inserting,
+ deleting, and copying text properties.
+ (zone-line-specs, zone-pgm-stress): Check forward-line exit status.
+ (zone-pgm-rotate): Handle odd buffers like that of gomoku, where getting
+ to point-max is hard.
+ (zone-fret, zone-fill-out-screen): Replace cl's do with dotimes.
+ (zone-fill-out-screen): Ignore intangibility.
+
+2010-07-05 Chong Yidong <cyd@stupidchicken.com>
+
+ * menu-bar.el (menu-bar-mode):
+ * tool-bar.el (tool-bar-mode): Replace default-frame-alist element
+ if it has been set.
+
+ * mouse.el (mouse-drag-track): Call mouse-start-end to handle
+ word/line selection (Bug#6565).
+
+2010-07-04 Juanma Barranquero <lekktu@gmail.com>
+
+ * net/dbus.el (dbus-send-signal): Declare function.
+
+2010-07-04 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/dbus.el: Implement signal "PropertiesChanged" (from D-Bus 1.3.1).
+ (dbus-register-property): New optional argument EMITS-SIGNAL.
+ (dbus-property-handler): Send signal "PropertiesChanged" if requested.
+
+2010-07-03 Chong Yidong <cyd@stupidchicken.com>
+
+ * mouse.el (mouse-drag-overlay): Variable deleted.
+ (mouse-move-drag-overlay, mouse-show-mark): Functions deleted.
+ (mouse--remap-link-click-p): New function.
+ (mouse-drag-track): Handle dragging by using temporary Transient
+ Mark mode, instead of a special overlay.
+ (mouse-kill-ring-save, mouse-save-then-kill): Don't call
+ mouse-show-mark.
+
+ * mouse-sel.el (mouse-sel-selection-alist): mouse-drag-overlay
+ deleted.
+
+2010-07-02 Juri Linkov <juri@jurta.org>
+
+ * autoinsert.el (auto-insert-alist): Fix readability
+ by using dotted pair notation for lambda.
+
+2010-07-02 Juri Linkov <juri@jurta.org>
+
+ * faces.el (read-face-name): Rename arg `string-describing-default'
+ to `default'. Doc fix. Display the default value in quotes
+ in the prompt. With empty input, return the `default' arg,
+ unless the default value is a string (in which case return nil).
+ (describe-face): Replace the string `default' arg of `read-face-name'
+ with the symbol `default'.
+
+2010-07-02 Chong Yidong <cyd@stupidchicken.com>
+
+ * emulation/viper-cmd.el (viper-delete-backward-char)
+ (viper-del-backward-char-in-insert)
+ (viper-del-backward-char-in-replace, viper-change)
+ (viper-backward-indent): Replace delete-backward-char with
+ delete-char (Bug#6552).
+
+2010-07-01 Chong Yidong <cyd@stupidchicken.com>
+
+ * ruler-mode.el (ruler--save-header-line-format): Fix typos.
+
+2010-06-30 Chong Yidong <cyd@stupidchicken.com>
+
+ * frame.el (make-frame): Add default-frame-alist to the PARAMETERS
+ argument passed to frame-creation-function (Bug#5378).
+
+ * faces.el (x-handle-named-frame-geometry)
+ (x-handle-reverse-video, x-create-frame-with-faces)
+ (face-set-after-frame-default, tty-create-frame-with-faces):
+ Don't separately consult default-frame-alist. It is now passed as the
+ PARAMETER argument.
+
+2010-06-30 Andreas Schwab <schwab@linux-m68k.org>
+
+ * startup.el (command-line): Don't call tool-bar-setup in a
+ tty-only build.
+
+2010-06-30 Chong Yidong <cyd@stupidchicken.com>
+
+ * ruler-mode.el (ruler--save-header-line-format): New fun.
+ (ruler-mode): Use it as a setter function, so as not to overwrite
+ ruler-mode-header-line-format-old if Ruler mode is on (Bug#5370).
+
+2010-06-29 Chong Yidong <cyd@stupidchicken.com>
+
+ * vc/vc.el (vc-deduce-backend): New fun. Handle diff buffers.
+ (vc-root-diff, vc-print-root-log, vc-log-incoming)
+ (vc-log-outgoing): Use it.
+ (vc-diff-internal): Set diff-vc-backend.
+
+ * vc/diff-mode.el (diff-vc-backend): New var.
+
+2010-06-28 Jan Djärv <jan.h.d@swipnet.se>
+
+ * dynamic-setting.el (font-setting-change-default-font):
+ Remove call to message.
+
+2010-06-28 Kenichi Handa <handa@m17n.org>
+
+ * international/quail.el (quail-insert-kbd-layout): Fix the
+ showing of untranslated characters.
+
+2010-06-28 Chong Yidong <cyd@stupidchicken.com>
+
+ * simple.el (delete-active-region): New option.
+ (delete-backward-char): Implement in Lisp.
+ (delete-forward-char): New command.
+
+ * mouse.el (mouse-region-delete-keys): Deleted.
+ (mouse-show-mark): Simplify.
+
+ * bindings.el (global-map): Bind delete and DEL, the former to
+ delete-forward-char.
+
+2010-06-27 Lennart Borgman <lennart.borgman@gmail.com>
+
+ * progmodes/ruby-mode.el (ruby-mode-map): Don't bind TAB.
+ (ruby-mode): Bind indent-line-function (Bug#5119).
+
+2010-06-27 Chong Yidong <cyd@stupidchicken.com>
+
+ * startup.el (command-line): Recognize "0" X resource value.
+
+2010-06-27 Chong Yidong <cyd@stupidchicken.com>
+
+ * startup.el (command-line): Use X resources to set the value of
+ menu-bar-mode and tool-bar-mode, before calling frame-initialize.
+
+ * menu-bar.el (menu-bar-mode):
+ * tool-bar.el (tool-bar-mode): Don't change default-frame-alist.
+ Set init-value to t.
+
+ * frame.el (frame-notice-user-settings): Don't change
+ default-frame-alist based on menu-bar-mode and tool-bar-mode, or
+ vice versa (Bug#2249).
+
+2010-06-26 Eli Zaretskii <eliz@gnu.org>
+
+ * w32-fns.el (w32-convert-standard-filename): Doc fix.
+
+2010-06-25 Agustín Martín <agustin.martin@hispalinux.es>
+
+ * textmodes/flyspell.el (flyspell-check-previous-highlighted-word):
+ Make sure `flyspell-word' re-checks word after function run (Bug#6504).
+
+ * textmodes/ispell.el (ispell-init-process): Make sure ispell and
+ default directories are expanded (Bug#6143).
+
+2010-06-24 Juri Linkov <juri@jurta.org>
+
+ * minibuffer.el (completions-format): Change default from nil to
+ `horizontal'. Remove `nil' value from :type. Doc fix. (Bug#6459)
+
+2010-06-24 Juri Linkov <juri@jurta.org>
+
+ * vc/vc.el (vc-diff-internal): Set `revert-buffer-function'
+ buffer-locally to lambda that re-runs the vc diff command.
+ (Bug#6447)
+
+2010-06-24 Chong Yidong <cyd@stupidchicken.com>
+
+ * kmacro.el (kmacro-call-macro): Don't issue hint message if the
+ echo area is in use (Bug#3412).
+
+2010-06-22 Glenn Morris <rgm@gnu.org>
+
+ * textmodes/texinfmt.el (texinfo-format-region)
+ (texinfo-raise-lower-sections, texinfo-format-separate-node)
+ (texinfo-itemize-item, texinfo-multitable-item, texinfo-alias)
+ (texinfo-format-option, texinfo-noindent):
+ Use line-beginning-position and line-end-position.
+
+ * calc/calc-aent.el, calc/calc-ext.el, calc/calc-lang.el:
+ * calc/calc-store.el, calc/calc-units.el, calc/calc.el:
+ * calc/calccomp.el: Add explicit utf-8 coding cookies to files with
+ utf-8 characters.
+
+2010-06-21 Karl Fogel <kfogel@red-bean.com>
+
* play/zone.el (zone-fall-through-ws): Fix next-line ->
forward-line fallout.
@@ -1482,7 +6000,7 @@
2010-06-30 Dan Nicolaescu <dann@ics.uci.edu>
Avoid displaying files with a nil state in vc-dir.
- * vc-dir.el (vc-dir-update): Obey the noinsert argument in all
+ * vc/vc-dir.el (vc-dir-update): Obey the noinsert argument in all
cases that cause insertion.
(vc-dir-resynch-file): Tell vc-dir-update to avoid inserting files
with a nil state.
@@ -1532,10 +6050,118 @@
`compose-mail-user-agent-warnings', instead of to the
nonexistent `compose-mail-check-user-agent'.
+2010-06-21 Alan Mackenzie <bug-cc-mode@gnu.org>
+
+ Fix an indentation bug:
+
+ * progmodes/cc-mode.el (c-common-init): Initialise c-new-BEG/END.
+ (c-neutralize-syntax-in-and-mark-CPP): c-new-BEG/END: Take account
+ of existing values.
+
+ * progmodes/cc-engine.el (c-clear-<-pair-props-if-match-after)
+ (c-clear->-pair-props-if-match-before): now return t when they've
+ cleared properties, nil otherwise.
+ (c-before-change-check-<>-operators): Set c-new-beg/end correctly
+ by taking account of the existing value.
+
+ * progmodes/cc-defs.el
+ (c-clear-char-property-with-value-function): Fix this to clear the
+ property rather than overwriting it with nil.
+
+2010-06-20 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/package.el (package-print-package): Add link to
+ package description via describe-package.
+ (describe-package-1): List package requirements. Add button to
+ perform installation.
+ (package-menu-describe-package): New command.
+
+ * help-mode.el (help-package): New button type.
+
+2010-06-19 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/package.el: Move package-list-packages binding to
+ menu-bar.el.
+ (describe-package, describe-package-1, package--dir): New funs.
+ (package-activate-1): Use package--dir.
+
+ * emacs-lisp/package-x.el (gnus-article-buffer): Require package.
+
+ * help-mode.el (help-package-def): New button type.
+
+ * menu-bar.el: Move package-list-packages binding here from
+ package.el.
+
+2010-06-19 Gustav Hållberg <gustav@gmail.com> (tiny change)
+
+ * descr-text.el (describe-char): Avoid trailing whitespace. (Bug#6423)
+
+2010-06-18 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/edebug.el (edebug-read-list):
+ Phase out old-style backquotes.
+
+2010-06-17 Juri Linkov <juri@jurta.org>
+
+ * help-mode.el (help-mode): Set buffer-local variable
+ revert-buffer-function to help-mode-revert-buffer.
+ (help-mode-revert-buffer): New function.
+
+ * info.el (Info-revert-find-node): Check for major-mode Info-mode
+ before popping to "*info*" (like in other Info functions).
+ Keep buffer-name in old-buffer-name. Keep Info-history-forward in
+ old-history-forward. Pop to old-buffer-name or "*info*" to
+ recreate the killed buffer. Set Info-history-forward from
+ old-history-forward.
+ (Info-breadcrumbs-depth): Add :group and :version.
+
+2010-06-17 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * emacs-lisp/package.el (package-menu-mode-map): Add a menu.
+
+2010-06-17 Agustín Martín <agustin.martin@hispalinux.es>
+
+ * textmodes/ispell.el (ispell-aspell-find-dictionary): Fix regexp
+ for languages like Portuguese with pt_{BR,PT} and no plain pt.
+
+2010-06-17 Juanma Barranquero <lekktu@gmail.com>
+
+ * emacs-lisp/package.el (package-menu-mode-map):
+ Move initialization into declaration.
+
+ * menu-bar.el (menu-bar-options-menu): Fix typo in menu entry.
+
+2010-06-17 Chong Yidong <cyd@stupidchicken.com>
+
+ * emacs-lisp/package.el (package-archive-base): Point to
+ elpa.gnu.org.
+ (package-enable, package-load-list): New defcustoms.
+ (package-user-dir, package-directory-list): Turn into defcustoms.
+ Don't include package-user-dir in package-directory-list.
+ (package--builtins-base): Don't include Emacs as a "package".
+ (package-subdirectory-regexp): New var.
+ (package-load-all-descriptors, package-compute-transaction)
+ (package-download-transaction): Obey package-load-list.
+ (package-activate-1): Rename from package-do-activate.
+ (package-list-packages-internal): Check package-load-list.
+ (package-load-descriptor, package-generate-autoloads)
+ (package-unpack, package-unpack-single)
+ (package--read-archive-file, package-delete):
+ Use expand-file-name.
+
+ * emacs-lisp/package-x.el: New file. Package uploading
+ functionality split out from package.el.
+
+ * startup.el (command-line): Load packages after reading init file.
+
+2010-06-17 Tom Tromey <tromey@redhat.com>
+
+ * emacs-lisp/package.el: New file.
+
2010-06-22 Dan Nicolaescu <dann@ics.uci.edu>
Fix vc-annotate for renamed files when using Git.
- * vc-git.el (vc-git-find-revision): Deal with empty results from
+ * vc/vc-git.el (vc-git-find-revision): Deal with empty results from
ls-files. Doe not pass the object as a file name to cat-file, it
is not a file name.
(vc-git-annotate-command): Pass the file name using -- to avoid
@@ -1556,28 +6182,28 @@
2010-06-22 Dan Nicolaescu <dann@ics.uci.edu>
Fix annotating other revisions for renamed files in vc-annotate.
- * vc-annotate.el (vc-annotate): Add an optional argument for the
+ * vc/vc-annotate.el (vc-annotate): Add an optional argument for the
VC backend. Use it when non-nil.
- (vc-annotate-warp-revision): Pass the VC backend to vc-annotate
+ (vc-annotate-warp-revision): Pass the VC backend to vc-annotate.
(Bug#6487).
Fix vc-annotate-show-changeset-diff-revision-at-line for git.
- * vc-annotate.el (vc-annotate-show-diff-revision-at-line-internal):
+ * vc/vc-annotate.el (vc-annotate-show-diff-revision-at-line-internal):
Do not pass the file name to the 'previous-revision call when we
don't want a file diff. (Bug#6489)
2010-06-21 Dan Nicolaescu <dann@ics.uci.edu>
Fix finding revisions for renamed files in vc-annotate.
- * vc.el (vc-find-revision): Add an optional argument for
+ * vc/vc.el (vc-find-revision): Add an optional argument for
the VC backend. Use it when non-nil.
- * vc-annotate.el (vc-annotate-find-revision-at-line): Pass the VC
+ * vc/vc-annotate.el (vc-annotate-find-revision-at-line): Pass the VC
backend to vc-find-revision. (Bug#6487)
2010-06-21 Dan Nicolaescu <dann@ics.uci.edu>
Fix reading file names in Git annotate buffers.
- * vc-git.el (vc-git-annotate-extract-revision-at-line):
+ * vc/vc-git.el (vc-git-annotate-extract-revision-at-line):
Remove trailing whitespace. Suggested by Eric Hanchrow. (Bug#6481)
2010-06-20 Alan Mackenzie <acm@muc.de>
@@ -1595,10 +6221,26 @@
2010-06-17 Stefan Monnier <monnier@iro.umontreal.ca>
+ * emacs-lisp/macroexp.el (macroexpand-all-1): Put back special
+ handling for `lambda' (misunderstanding).
+
+2010-06-16 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc-poly.el (math-accum-factors): Make sure that
+ constants aren't distributed after they are factored out.
+
+2010-06-16 Juri Linkov <juri@jurta.org>
+
+ * facemenu.el (list-colors-display): Call `pop-to-buffer' before
+ `list-colors-print'. (Bug#6332)
+
* subr.el (read-quoted-char): Fix up last change (bug#6290).
2010-06-16 Stefan Monnier <monnier@iro.umontreal.ca>
+ * emacs-lisp/macroexp.el (macroexpand-all-1): Don't handle `lambda'
+ specially, since it's a macro. Fix up wrong hint passed to maybe-cons.
+
* font-lock.el (font-lock-major-mode): Rename from
font-lock-mode-major-mode to distinguish it from
global-font-lock-mode's own font-lock-mode-major-mode (bug#6135).
@@ -1606,11 +6248,11 @@
* font-core.el (font-lock-default-function): Adjust users.
(font-lock-mode): Don't set it at all.
-2010-06-15 Stefan Monnier <monnier@iro.umontreal.ca>
+2010-06-16 Stefan Monnier <monnier@iro.umontreal.ca>
- * vc-annotate.el (vc-annotate): Use vc-read-revision.
+ * vc/vc-annotate.el (vc-annotate): Use vc-read-revision.
-2010-06-15 Glenn Morris <rgm@gnu.org>
+2010-06-16 Glenn Morris <rgm@gnu.org>
* calendar/appt.el (appt-time-msg-list): Doc fix.
(appt-check): Let-bind appt-warn-time.
@@ -1618,22 +6260,149 @@
Simplify argument names. Doc fix. Check for integer WARNTIME.
Only add WARNTIME to the output list if non-nil.
-2010-06-15 Ivan Kanis <apple@kanis.eu>
+2010-06-16 Ivan Kanis <apple@kanis.eu>
* calendar/appt.el (appt-check): Let the 3rd element of
appt-time-msg-list specify the warning time.
(appt-add): Add new argument with the warning time. (Bug#5176)
-2010-06-12 Bob Rogers <rogers-emacs@rgrjr.dyndns.org> (tiny change)
+2010-06-16 Bob Rogers <rogers-emacs@rgrjr.dyndns.org>
- * vc-svn.el (vc-svn-after-dir-status): Fix regexp for Subversions
+ * vc/vc-svn.el (vc-svn-after-dir-status): Fix regexp for Subversions
older than version 1.6. (Bug#6361)
-2010-06-12 Helmut Eller <eller.helmut@gmail.com>
+2010-06-16 Helmut Eller <eller.helmut@gmail.com>
* emacs-lisp/cl-macs.el (destructuring-bind): Bind `bind-enquote',
used by cl-do-arglist. (Bug#6408)
+2010-06-16 Agustín Martín <agustin.martin@hispalinux.es>
+
+ * textmodes/ispell.el (ispell-dictionary-base-alist):
+ Fix portuguese casechars/not-casechars for missing 'çÇ'.
+ Suggested by Rolando Pereira (bug#6434).
+
+2010-06-15 Juanma Barranquero <lekktu@gmail.com>
+
+ * facemenu.el (list-colors-sort): Doc fix.
+
+2010-06-15 Bob Rogers <rogers-emacs@rgrjr.dyndns.org>
+
+ * progmodes/sql.el (sql-connect-mysql): Fix typo.
+
+2010-06-14 Juri Linkov <juri@jurta.org>
+
+ Add sort option `list-colors-sort'. (Bug#6332)
+ * facemenu.el (color-rgb-to-hsv): New function.
+ (list-colors-sort): New defcustom.
+ (list-colors-sort-key): New function.
+ (list-colors-display): Doc fix. Sort list according to the option
+ `list-colors-sort'.
+ (list-colors-print): Add HSV values to `help-echo' property of
+ RGB strings.
+
+2010-06-14 Juri Linkov <juri@jurta.org>
+
+ * compare-w.el: Move to the "vc" subdirectory.
+
+2010-06-14 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * image-mode.el (image-mode-map): Remap left-char and right-char.
+
+ * nxml/nxml-mode.el (nxml-indent-line): Standardize indent behavior.
+
+2010-06-12 Chong Yidong <cyd@stupidchicken.com>
+
+ * term/common-win.el (x-colors): Add all the color names defined
+ in rgb.txt (Bug#6332).
+
+ * facemenu.el (list-colors-print): Don't print extra names if it
+ will overflow the window width.
+
+ * vc/log-edit.el (log-edit-font-lock-keywords): Revert 2010-06-02
+ change (Bug#6343).
+
+2010-06-12 Eli Zaretskii <eliz@gnu.org>
+
+ * files.el (make-directory): Doc fix (bug#6396).
+
+2010-06-12 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-remote-process-environment): Protect version
+ string by apostroph.
+ (tramp-shell-prompt-pattern): Do not use a shy group in case of
+ XEmacs.
+ (tramp-file-name-for-operation): Add `call-process-region'.
+ (tramp-set-process-query-on-exit-flag): Fix wrong parentheses.
+
+ * net/tramp-compat.el (top): Do not autoload
+ `tramp-handle-file-remote-p'. Load tramp-util.el and tramp-vc.el
+ only when `start-file-process' is not bound.
+ (tramp-advice-file-expand-wildcards): Do not use
+ `tramp-handle-file-remote-p'.
+ (tramp-compat-make-temp-file): Handle the case, that
+ `make-temp-file' has no third argument EXTENSION.
+
+2010-06-11 Juanma Barranquero <lekktu@gmail.com>
+
+ * makefile.w32-in (WINS_BASIC): Include new directory vc.
+
+ * loadup.el ("vc-hooks", "ediff-hook"): Load from lisp/vc/.
+
+2010-06-11 Juri Linkov <juri@jurta.org>
+
+ * finder.el (finder-known-keywords): Add keyword "vc"
+ for version control.
+
+ * add-log.el, cvs-status.el, diff.el, diff-mode.el, ediff.el,
+ * emerge.el, log-edit.el, log-view.el, pcvs.el, smerge-mode.el,
+ * vc-annotate.el, vc-bzr.el, vc-dir.el, vc-dispatcher.el, vc-git.el,
+ * vc-hg.el, vc-mtn.el, vc.el: Add keyword "vc".
+
+2010-06-11 Juri Linkov <juri@jurta.org>
+
+ Move version control related files to the "vc" subdirectory.
+ * add-log.el, cvs-status.el, diff.el, diff-mode.el, ediff-diff.el,
+ * ediff.el, ediff-help.el, ediff-hook.el, ediff-init.el,
+ * ediff-merg.el, ediff-mult.el, ediff-ptch.el, ediff-util.el,
+ * ediff-vers.el, ediff-wind.el, emerge.el, log-edit.el, log-view.el,
+ * pcvs-defs.el, pcvs.el, pcvs-info.el, pcvs-parse.el, pcvs-util.el,
+ * smerge-mode.el, vc-annotate.el, vc-arch.el, vc-bzr.el, vc-cvs.el,
+ * vc-dav.el, vc-dir.el, vc-dispatcher.el, vc.el, vc-git.el,
+ * vc-hg.el, vc-hooks.el, vc-mtn.el, vc-rcs.el, vc-sccs.el, vc-svn.el:
+ Move files to the "vc" subdirectory.
+
+2010-06-11 Chong Yidong <cyd@stupidchicken.com>
+
+ * comint.el (comint-password-prompt-regexp): Fix 2010-04-10 change
+ (Bug#6367).
+
+2010-06-11 Stephen Eglen <stephen@gnu.org>
+
+ * shell.el: Bind `shell-resync-dirs' to M-RET.
+
+2010-06-10 Michael Albinus <michael.albinus@gmx.de>
+
+ * notifications.el: Move file from lisp/net, because it is
+ supposed to talk locally to the user.
+
+2010-06-10 Julien Danjou <julien@danjou.info>
+
+ * net/notifications.el (notifications-on-action-signal)
+ (notifications-on-closed-signal): Pass notification id as first
+ argument to the callback functions. Add docstrings.
+ (notifications-notify): Fix docstring.
+
+2010-06-10 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/authors.el (authors-ignored-files)
+ (authors-valid-file-names): Add some files.
+
+2010-06-10 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * net/rcirc.el (rcirc-server-alist, rcirc, rcirc-connect): Resolve
+ merge conflict, giving preference to the emacs-23 version of the code.
+
2010-06-09 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/advice.el (ad-compile-function):
@@ -1644,12 +6413,110 @@
(vc-resynch-window): Adjust name.
* vc-hooks.el (vc-find-file-hook): Adjust name.
-2010-06-07 Jonathan Rockway <jon@jrock.us>
+2010-06-09 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/notifications.el (notifications-notify): Fix docstring.
+
+2010-06-09 Juanma Barranquero <lekktu@gmail.com>
+
+ Update to Unicode 6.0.0 beta.
+ * international/charprop.el: Update copyright.
+ * international/mule-cmds.el (ucs-names): Update character ranges.
+ * international/uni-bidi.el:
+ * international/uni-category.el:
+ * international/uni-combining.el:
+ * international/uni-comment.el:
+ * international/uni-decimal.el:
+ * international/uni-decomposition.el:
+ * international/uni-digit.el:
+ * international/uni-lowercase.el:
+ * international/uni-mirrored.el:
+ * international/uni-name.el:
+ * international/uni-numeric.el:
+ * international/uni-old-name.el:
+ * international/uni-titlecase.el:
+ * international/uni-uppercase.el: Regenerate.
+
+2010-06-09 Juanma Barranquero <lekktu@gmail.com>
+
+ * emacs-lisp/smie.el (comment-string-strip): Declare function.
+ (smie-precs-precedence-table): Fix typo in docstring.
+
+ * vc-mtn.el (log-edit-extract-headers): Declare function.
+
+ * vc-hg.el (log-edit-extract-headers): Remove duplicate declaration.
+
+ * net/notifications.el (dbus-register-signal): Declare function.
+ (notifications-notify): Fix typos and reflow docstring.
+
+2010-06-09 Dan Nicolaescu <dann@ics.uci.edu>
+
+ Improve VC create/retrieve tag/branch.
+ * vc.el (vc-create-tag): Do not read the directory name for VCs
+ with repository revision granularity. Adjust the tag/branch
+ prompt. Reset VC properties.
+ (vc-retrieve-tag): Do not read the directory name for VCs
+ with repository revision granularity. Reset VC properties.
+
+2010-06-09 Julien Danjou <julien@danjou.info>
+
+ * net/notifications.el: New file.
+
+2010-06-09 Dan Nicolaescu <dann@ics.uci.edu>
+
+ Add optional support for resetting VC properties.
+ * vc-dispatcher.el (vc-resynch-window): Add new optional argument,
+ call vc-file-clearprops when true.
+ (vc-resynch-buffer): Add new optional argument, pass it down.
+ (vc-resynch-buffers-in-directory): Likewise.
+
+ Improve support for special markup in the VC commit message.
+ * vc-mtn.el (vc-mtn-checkin): Add support for Author: and Date: markup.
+ * vc-hg.el (vc-hg-checkin): Add support for Date:.
+ * vc-git.el (vc-git-checkin):
+ * vc-bzr.el (vc-bzr-checkin): Likewise.
+
+2010-06-09 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/smie.el (smie-indent-keyword): Remove special case that
+ can be handled with a ((:before "fn") (:prev "=>" parent)) rule.
+
+2010-06-07 Martin Pohlack <mp26@os.inf.tu-dresden.de>
+
+ * iimage.el: Remove images as soon as the underlying text is modified.
+ (iimage-modification-hook): New function.
+ (iimage-mode-buffer): Use it.
- * net/rcirc.el: Add support for password authentication.
- (rcirc-server-alist): Add :password keyword.
- (rcirc): Ask for a password, or get it from the server's alist.
- (rcirc-connect): Add password argument. Pass it to server.
+2010-06-07 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/smie.el (smie-indent-offset-rule): Rename from
+ smie-indent-offset-after. Add :prev case. Make a bit more generic.
+ (smie-indent-virtual): Remove `virtual' arg. Update callers.
+ (smie-indent-keyword): Add handling of open-paren keywords.
+ (smie-indent-comment-continue): Don't assume comment-continue.
+
+2010-06-07 Martin Rudalics <rudalics@gmx.at>
+
+ * window.el (pop-to-buffer): Remove the conditional that
+ compares new-window and old-window, so it will reselect
+ the selected window unconditionally.
+ http://lists.gnu.org/archive/html/emacs-devel/2010-06/msg00078.html
+
+2010-06-07 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/smie.el (smie-indent-offset-after)
+ (smie-indent-forward-token, smie-indent-backward-token): New functions.
+ (smie-indent-after-keyword): Use them.
+ (smie-indent-fixindent): Only applies to the indentation of the BOL.
+ (smie-indent-keyword): Tweak the black magic.
+ (smie-indent-comment-continue): Strip comment-continue before use.
+ (smie-indent-functions): Indent comments before keywords.
+
+2010-06-06 Juri Linkov <juri@jurta.org>
+
+ * isearch.el (isearch-lazy-highlight-search): Fix looping
+ by checking for empty match. This syncs this loop with the
+ similar loop in `isearch-search'. (Bug#6362)
2010-06-05 Juanma Barranquero <lekktu@gmail.com>
@@ -1659,18 +6526,152 @@
(dbus-event-bus-name, dbus-introspect-get-interface)
(dbus-introspect-get-argument): Reflow docstrings.
+2010-06-05 Dan Nicolaescu <dann@ics.uci.edu>
+
+ vc-log-incoming/vc-log-outgoing fixes for Git.
+ * vc-git.el (vc-git-log-view-mode): Fix font lock for
+ incoming/outgoing logs.
+ (vc-git-log-outgoing, vc-git-log-incoming): Use @{upstream}
+ instead of vc-git-compute-remote.
+ (vc-git-compute-remote): Remove.
+
2010-06-04 Chong Yidong <cyd@stupidchicken.com>
* term/common-win.el (x-colors): Add "dark green" and "dark
turquoise" (Bug#6332).
+2010-06-04 Juri Linkov <juri@jurta.org>
+
+ * simple.el (kill-new): Fix logic of kill-do-not-save-duplicates.
+ Instead of setting `replace' to t and replacing the same string
+ with itself, don't do certain actions when
+ kill-do-not-save-duplicates is non-nil and string is equal to car
+ of kill-ring: don't call menu-bar-update-yank-menu, don't push
+ interprogram-paste strings to kill-ring, and don't push the input
+ argument `string' to kill-ring.
+ http://lists.gnu.org/archive/html/emacs-devel/2010-06/msg00072.html
+
+2010-06-04 Juanma Barranquero <lekktu@gmail.com>
+
+ * subr.el (directory-sep-char): Move from fileio.c and make a defconst.
+
+2010-06-04 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-gvfs.el (tramp-gvfs-handle-expand-file-name): Expand "~/".
+ (tramp-gvfs-handler-mounted-unmounted)
+ (tramp-gvfs-connection-mounted-p): Handle default-location.
+
+ * net/tramp-smb.el (tramp-smb-handle-delete-directory): Don't try to
+ move files to trash.
+
+2010-06-04 Juanma Barranquero <lekktu@gmail.com>
+
+ * international/mule-cmds.el (nonascii-insert-offset)
+ (nonascii-translation-table): Add obsolescence information.
+
+ * international/mule.el (make-translation-table-from-vector): Doc fix.
+
2010-06-03 Glenn Morris <rgm@gnu.org>
* desktop.el (desktop-clear-preserve-buffers):
Add "*Warnings*" buffer. (Bug#6336)
+2010-06-03 Dan Nicolaescu <dann@ics.uci.edu>
+
+ vc-log-incoming/vc-log-outgoing improvements for Git.
+ * vc-git.el (vc-git-log-outgoing): Use the same format as the
+ short log.
+ (vc-git-log-incoming): Likewise. Run "git fetch" before the log command.
+
+ Add bindings for vc-log-incoming and vc-log-outgoing.
+ * vc-hooks.el (vc-prefix-map): Add bindings for vc-log-incoming
+ and vc-log-outgoing.
+ * vc-dir.el (vc-dir-menu-map): Add menu bindings for vc-log-incoming
+ and vc-log-outgoing.
+
+2010-06-03 Chong Yidong <cyd@stupidchicken.com>
+
+ * net/rcirc.el (rcirc-sort-nicknames): Remove.
+ (rcirc-handler-366): Always sort nicknames.
+
+2010-06-03 Juanma Barranquero <lekktu@gmail.com>
+
+ * emacs-lisp/smie.el (comment-continue): Declare for byte-compiler.
+
+2010-06-03 Chong Yidong <cyd@stupidchicken.com>
+
+ * net/rcirc.el (rcirc-nickname<, rcirc-sort-nicknames-join): Doc fix.
+
+2010-06-03 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * net/rcirc.el (rcirc-sort-nicknames): Change default.
+ (rcirc-sort-nicknames-join): Avoid setq.
+
+2010-06-03 Deniz Dogan <deniz.a.m.dogan@gmail.com>
+
+ * net/rcirc.el (rcirc-sort-nicknames): New custom.
+ (rcirc-nickname<, rcirc-sort-nicknames-join): New funs.
+ (rcirc-handler-366): Use them.
+
+2010-06-03 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Split smie-indent-calculate into more manageable chunks.
+ * emacs-lisp/smie.el (smie-indent-virtual, smie-indent-fixindent)
+ (smie-indent-comment, smie-indent-after-keyword, smie-indent-keyword)
+ (smie-indent-close, smie-indent-comment-continue, smie-indent-bob)
+ (smie-indent-exps): Extract from smie-indent-calculate.
+ (smie-indent-functions): New var.
+ (smie-indent-functions): Use them.
+
+2010-06-02 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/smie.el (smie-indent-hanging-p): Use smie-bolp.
+ (smie-indent-calculate): Simplify and cleanup.
+
+2010-06-02 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-gvfs.el (top): Require url-util.
+ (tramp-gvfs-mount-point): Remove.
+ (tramp-gvfs-stringify-dbus-message, tramp-gvfs-send-command):
+ New defuns.
+ (with-tramp-dbus-call-method): Format trace message.
+ (tramp-gvfs-handle-copy-file, tramp-gvfs-handle-rename-file):
+ Implement backup call, when operation on local files fails.
+ Use progress reporter. Flush properties of changed files.
+ (tramp-gvfs-handle-make-directory): Make more traces.
+ (tramp-gvfs-url-file-name): Hexify file name in url.
+ (tramp-gvfs-fuse-file-name): Take also prefix (like dav shares)
+ into account for the resulting file name.
+ (tramp-gvfs-handler-askquestion): Return dummy mountpoint, when
+ the answer is "no". See `tramp-gvfs-maybe-open-connection'.
+ (tramp-gvfs-handler-mounted-unmounted)
+ (tramp-gvfs-connection-mounted-p): Test also for new mountspec
+ attribute "default_location". Set "prefix" property.
+ (tramp-gvfs-mount-spec): Return both prefix and mountspec.
+ (tramp-gvfs-maybe-open-connection): Test, whether mountpoint
+ exists. Raise an error, if not (due to a corresponding answer
+ "no" in interactive questions, for example).
+
2010-06-02 Dan Nicolaescu <dann@ics.uci.edu>
+ * log-edit.el (log-edit-font-lock-keywords): Make group 4 match lax.
+
+2010-06-01 Juanma Barranquero <lekktu@gmail.com>
+
+ * emacs-lisp/eldoc.el: Add completions for new commands left-* and
+ right-*. (Bug#6265)
+
+2010-06-01 Dan Nicolaescu <dann@ics.uci.edu>
+
+ Add support for vc-log-incoming, improve vc-log-outgoing for Git.
+ * vc-git.el (vc-git-compute-remote): New function.
+ (vc-git-log-outgoing): Use it instead of hard coding a value.
+ (vc-git-log-incoming): New function.
+
+ Improve state updating for VC tag commands.
+ * vc.el (vc-create-tag, vc-retrieve-tag): Call vc-resynch-buffer
+ to update the state of all buffers in the directory.
+
* vc-dir.el (vc-dir-update): Remove entries with a nil state (bug#5539).
2010-06-01 Stefan Monnier <monnier@iro.umontreal.ca>
@@ -1691,6 +6692,56 @@
* subr.el (momentary-string-display): Just use read-event to read
the exit event (Bug#6238).
+2010-05-30 Eli Zaretskii <eliz@gnu.org>
+
+ * international/mule.el (define-coding-system): Doc fix (bug#6313).
+
+2010-05-30 Juanma Barranquero <lekktu@gmail.com>
+
+ * emulation/cua-base.el: Recognize also `right-word' and `left-word'.
+ Suggested by Eli Zaretskii <eliz@gnu.org>.
+
+2010-05-30 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * minibuffer.el (completion-file-name-table): Don't return a boundary
+ past the end of `string' (bug#6299).
+ (completion--file-name-table): Delegate to completion-file-name-table
+ for the `boundaries' case.
+
+2010-05-30 Juanma Barranquero <lekktu@gmail.com>
+
+ * emulation/cua-base.el: Recognize `right-char' and `left-char' as
+ movement commands.
+
+ * progmodes/ada-xref.el (ada-prj-ada-project-path-sep): Set from
+ `path-separator', but maintain compatibility with Emacs 20.2.
+
+2010-05-29 Chong Yidong <cyd@stupidchicken.com>
+
+ * server.el (server-process-filter): Receive parent-id argument
+ from emacsclient.
+ (server-create-window-system-frame): New arg. Pass parent-id as
+ frame parameter.
+
+2010-05-29 Eli Zaretskii <eliz@gnu.org>
+
+ Bidi-sensitive word movement with arrow keys.
+ * subr.el (right-arrow-command, left-arrow-command): Move to
+ bindings.el.
+
+ * bindings.el (right-char, left-char): Move from subr.el and
+ rename from right-arrow-command and left-arrow-command.
+ (right-word, left-word): New functions.
+ (global-map) <right>: Bind to right-char.
+ (global-map) <left>: Bind to left-char.
+ (global-map) <C-right>: Bind to right-word.
+ (global-map) <C-left>: Bind to left-word.
+
+ * ls-lisp.el (ls-lisp-classify-file): New function.
+ (ls-lisp-insert-directory): Call it if switches include -F (bug#6294).
+ (ls-lisp-classify): Call ls-lisp-classify-file.
+ (insert-directory): Remove blanks from switches.
+
2010-05-29 Chong Yidong <cyd@stupidchicken.com>
* ansi-color.el: Delete unused escape sequences (Bug#6085).
@@ -1699,6 +6750,145 @@
(ansi-color-apply-on-region): Delete unrecognized control sequences.
(ansi-color-apply): Build string list before calling concat.
+2010-05-28 Juri Linkov <juri@jurta.org>
+
+ * image-dired.el (image-dired-dired-toggle-marked-thumbs):
+ Replace LOCALP arg of `dired-get-filename' 'no-dir with nil.
+ (Bug#5270)
+
+2010-05-28 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-debug-message): Add `tramp-compat-funcall'
+ to ignored backtrace functions.
+ (with-progress-reporter): Expand docstring.
+ (tramp-handle-delete-file): Implement TRASH argument.
+ (tramp-get-remote-trash): New defun.
+
+2010-05-28 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-compat.el (tramp-compat-delete-file):
+ Use `symbol-value' for backward compatibility.
+
+ * net/tramp.el (tramp-handle-make-symbolic-link)
+ (tramp-handle-load)
+ (tramp-do-copy-or-rename-file-via-buffer)
+ (tramp-do-copy-or-rename-file-directly)
+ (tramp-do-copy-or-rename-file-out-of-band)
+ (tramp-handle-process-file, tramp-handle-call-process-region)
+ (tramp-handle-shell-command, tramp-handle-file-local-copy)
+ (tramp-handle-insert-file-contents, tramp-handle-write-region)
+ (tramp-delete-temp-file-function): Use `delete-file' instead
+ of `tramp-compat-delete-file'.
+
+ * net/tramp-fish.el (tramp-fish-handle-delete-directory)
+ (tramp-fish-handle-make-symbolic-link)
+ (tramp-fish-handle-process-file): Use `delete-file' instead
+ of `tramp-compat-delete-file'.
+
+ * net/tramp-ftp.el (tramp-ftp-file-name-handler):
+ Use `delete-file' instead of `tramp-compat-delete-file'.
+
+ * net/tramp-gvfs.el (tramp-gvfs-handle-delete-file): Rename arg.
+ (tramp-gvfs-handle-write-region): Use `delete-file' instead of
+ `tramp-compat-delete-file'.
+
+ * net/tramp-imap.el (tramp-imap-do-copy-or-rename-file):
+ Use `delete-file' instead of `tramp-compat-delete-file'.
+
+ * net/tramp-smb.el (tramp-smb-handle-copy-file)
+ (tramp-smb-handle-file-local-copy, tramp-smb-handle-rename-file)
+ (tramp-smb-handle-write-region): Use `delete-file' instead of
+ `tramp-compat-delete-file'.
+ (tramp-smb-handle-delete-directory): Use 'trash as arg.
+
+2010-05-27 Chong Yidong <cyd@stupidchicken.com>
+
+ * dired.el (dired-delete-file): New arg TRASH.
+ (dired-internal-do-deletions): New arg TRASH. Use progress reporter.
+ (dired-do-flagged-delete, dired-do-delete): Use trash.
+
+ * speedbar.el (speedbar-item-delete): Allow trashing.
+
+ * files.el (delete-directory): New arg TRASH.
+
+ * net/ange-ftp.el (ange-ftp-del-tmp-name, ange-ftp-delete-file)
+ (ange-ftp-rename-remote-to-remote)
+ (ange-ftp-rename-local-to-remote)
+ (ange-ftp-rename-remote-to-local, ange-ftp-load)
+ (ange-ftp-compress, ange-ftp-uncompress): Remove optional arg from
+ `delete-file'.
+ (ange-ftp-delete-directory): Add optional arg to `delete-file', to
+ allow trashing.
+
+ * net/tramp-compat.el (tramp-compat-delete-file): Rewrite to
+ handle new TRASH arg of `delete-file'.
+
+ * net/tramp.el (tramp-handle-delete-file): Change FORCE arg to TRASH.
+ (tramp-handle-make-symbolic-link, tramp-handle-load)
+ (tramp-do-copy-or-rename-file-via-buffer)
+ (tramp-do-copy-or-rename-file-directly)
+ (tramp-do-copy-or-rename-file-out-of-band)
+ (tramp-handle-process-file, tramp-handle-call-process-region)
+ (tramp-handle-shell-command, tramp-handle-file-local-copy)
+ (tramp-handle-insert-file-contents, tramp-handle-write-region)
+ (tramp-delete-temp-file-function): Use null TRASH arg in
+ tramp-compat-delete-file call.
+
+ * net/tramp-fish.el (tramp-fish-handle-delete-directory)
+ (tramp-fish-handle-delete-file)
+ (tramp-fish-handle-make-symbolic-link)
+ (tramp-fish-handle-process-file): Use null TRASH arg in
+ `tramp-compat-delete-file' call.
+
+ * net/tramp-ftp.el (tramp-ftp-file-name-handler): Use null TRASH
+ arg in `tramp-compat-delete-file' call.
+
+ * net/tramp-gvfs.el (tramp-gvfs-handle-delete-file): Rename arg.
+ (tramp-gvfs-handle-write-region): Use null TRASH arg in
+ `tramp-compat-delete-file' call.
+
+ * net/tramp-imap.el (tramp-imap-handle-delete-file): Rename arg.
+ (tramp-imap-do-copy-or-rename-file): Use null TRASH arg in
+ `tramp-compat-delete-file' call.
+
+ * net/tramp-smb.el (tramp-smb-handle-copy-file)
+ (tramp-smb-handle-file-local-copy, tramp-smb-handle-rename-file)
+ (tramp-smb-handle-write-region): Use null TRASH arg in
+ tramp-compat-delete-file call.
+ (tramp-smb-handle-delete-directory): Use tramp-compat-delete-file.
+ (tramp-smb-handle-delete-file): Rename arg.
+
+ * diff.el (diff-sentinel):
+ * epg.el (epg--make-temp-file, epg-decrypt-string)
+ (epg-verify-string, epg-sign-string, epg-encrypt-string):
+ * jka-compr.el (jka-compr-partial-uncompress)
+ (jka-compr-call-process, jka-compr-write-region):
+ * server.el (server-sentinel): Remove optional arg from
+ delete-file, reverting 2010-05-03 change.
+
+2010-05-27 Chong Yidong <cyd@stupidchicken.com>
+
+ * progmodes/verilog-mode.el (verilog-type-font-keywords):
+ Use font-lock-constant-face, not obsolete font-lock-reference-face.
+
+2010-05-27 Kenichi Handa <handa@m17n.org>
+
+ * language/hebrew.el (hebrew-shape-gstring): Check if a glyph
+ element of GSTRING is nil.
+
+2010-05-27 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/smie.el (smie-forward-token-function)
+ (smie-backward-token-function): New vars.
+ (smie-backward-sexp, smie-forward-sexp)
+ (smie-indent-hanging-p, smie-indent-calculate): Use them.
+ (smie-default-backward-token): Rename from smie-backward-token and
+ skip comments.
+ (smie-default-forward-token): Rename from smie-forward-token and
+ skip comments.
+ (smie-next-sexp): Handle nil results from next-token.
+ (smie-indent-calculate): Add a new case for special `fixindent' comments.
+
2010-05-27 Chong Yidong <cyd@stupidchicken.com>
* progmodes/verilog-mode.el (verilog-type-font-keywords):
@@ -1709,64 +6899,670 @@
* htmlfontify.el (hfy-face-resolve-face): New function.
(hfy-face-to-style): Use it (Bug#6279).
+2010-05-26 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/ada-xref.el (ada-gnat-parse-gpr):
+ * emulation/edt.el (edt-load-keys): Avoid (expand-file-name ".").
+
+2010-05-26 Glenn Morris <rgm@gnu.org>
+
+ * emulation/edt.el (edt-load-keys): Use locate-library.
+
+2010-05-25 Chong Yidong <cyd@stupidchicken.com>
+
+ * log-edit.el (log-edit-strip-single-file-name): Default to nil.
+ (log-edit-changelog-entries): Doc fix.
+ (log-edit-changelog-insert-entries): Args changed.
+ Rename relative filenames in ChangeLog entries. Delete tabs.
+ (log-edit-insert-changelog-entries): Reorganize return value of
+ `log-edit-changelog-entries' to pass filenames to
+ log-edit-changelog-insert-entries.
+
+2010-05-25 Thierry Volpiatto <thierry.volpiatto@gmail.com>
+
+ * dired.el (dired-mode-map): Rebind "\C-t\C-t" from
+ `image-dired-dired-insert-marked-thumbs' to
+ `image-dired-dired-toggle-marked-thumbs'.
+
+ * image-dired.el: Require cl when compiling.
+ (image-dired-dired-toggle-marked-thumbs): Rename from
+ `image-dired-dired-insert-marked-thumbs'. Add ARG. Doc fix.
+ Use interactive spec "P". Set LOCALP arg of `dired-get-filename'
+ to 'no-dir. Skip files whose names don't match
+ `image-file-name-regexp'. When file has a thumbnail overlay,
+ delete it. (Bug#5270)
+
+2010-05-25 Juri Linkov <juri@jurta.org>
+
+ * image-mode.el (image-mode): Add image-after-revert-hook to
+ after-revert-hook.
+ (image-after-revert-hook): New function. (Bug#5669)
+
+2010-05-25 Juri Linkov <juri@jurta.org>
+
+ * image.el (image-animated-p): When delay between animated images
+ is 0, set it to 10 (0.1 sec). (Bug#6258)
+
+2010-05-25 Christian Lynbech <christian.lynbech@tieto.com> (tiny change)
+
+ * net/tramp.el (tramp-handle-insert-directory): Don't use
+ `forward-word', its default syntax could be changed.
+
+2010-05-25 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-progress-reporter-update): New defun.
+ (with-progress-reporter): Use it.
+ (tramp-process-actions):
+ * net/tramp-gvfs.el (tramp-gvfs-handler-askquestion):
+ Preserve current message, in order to let progress reporter continue
+ afterwards. (Bug#6257)
+
+2010-05-25 Glenn Morris <rgm@gnu.org>
+
+ * net/rcirc.el (rcirc-default-user-name, rcirc-default-full-name):
+ Add :version.
+
+2010-05-25 Ryan Yeske <rcyeske@gmail.com>
+
+ * net/rcirc.el (rcirc-default-user-name): Change to "user".
+ (rcirc-default-full-name): Change to "unknown".
+ (rcirc-user-name-history): Add variable.
+
+2010-05-25 Ryan Yeske <rcyeske@gmail.com>
+ Jonathan Rockway <jon@jrock.us>
+
+ * net/rcirc.el (rcirc-server-alist): Add :pass.
+ (rcirc): When prompting for connection parameters, also prompt for
+ username and password.
+ (rcirc-connect): Take a PASS argument. If PASS is non-nil, send
+ value to server when connecting.
+
+2010-05-25 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/smie.el (smie-set-prec2tab): Check override before use.
+ (smie-merge-prec2s): Pass the tables as separate args.
+ (smie-bnf-precedence-table): Adjust call accordingly.
+ (smie-prec2-levels): Set levels at the end.
+
+ Replace Lisp calls to delete-backward-char by delete-char.
+ * bs.el, expand.el, ido.el, image-dired.el, lpr.el, pcomplete.el,
+ * skeleton.el, term.el, time.el, wid-edit.el, woman.el,
+ * calc/calc-graph.el, calc/calc-help.el, calc/calc-incom.el,
+ * calc/calc.el, emacs-lisp/cl-extra.el, emacs-lips/cl-loaddefs.el,
+ * emulation/cua-rect.el, emulation/viper-ex.el, eshell/esh-test.el,
+ * eshell/eshell.el, gnus/gnus-uu.el, gnus/nndoc.el, gnus/nnrss.el,
+ * gnus/rfc2047.el, gnus/utf7.el, international/utf-7.el,
+ * language/ethio-util.el, mh-e/mh-alias.el, mh-e/mh-search.el,
+ * net/imap.el, net/rcirc.el, obsolete/complete.el, play/decipher.el,
+ * progmodes/ada-mode.el, progmodes/cc-awk.el, progmodes/dcl-mode.el,
+ * progmodes/ps-mode.el, progmodes/verilog-mode.el,
+ * progmodes/vhdl-mode.el, textmodes/bibtex.el, textmodes/fill.el,
+ * textmodes/reftex-auc.el, textmodes/rst.el, textmodes/sgml-mode.el,
+ * textmodes/table.el, textmodes/texinfmt.el: Replace Lisp calls to
+ delete-backward-char by calls to delete-char.
+
+2010-05-25 Kenichi Handa <handa@m17n.org>
+
+ * language/hebrew.el (hebrew-shape-gstring): New function.
+ Register it in composition-function-table for all Hebrew combining
+ characters.
+
2010-05-25 Stefan Monnier <monnier@iro.umontreal.ca>
* epa.el (epa--select-keys): Don't explicitly delete the window since
that can fail (e.g. sole window in frame). Use dedication instead.
-2010-05-19 Uday S Reddy <u.s.reddy@cs.bham.ac.uk> (tiny change)
+2010-05-24 Uday S Reddy <u.s.reddy@cs.bham.ac.uk> (tiny change)
* textmodes/fill.el (fill-region): Don't fill past the end (bug#6201).
+2010-05-22 Chong Yidong <cyd@stupidchicken.com>
+
+ * image.el (image-refresh): Define as an alias for image-flush.
+
+ * image-mode.el (image-toggle-display-image): Caller changed.
+
+2010-05-21 Juri Linkov <juri@jurta.org>
+
+ * progmodes/grep.el (grep-read-files): Fix multi-pattern aliases.
+ Remove "all" from grep-files-aliases. Split grep-files-aliases by
+ whitespace, call wildcard-to-regexp on substrings and concat them
+ with "\\|". (Bug#6114)
+
+2010-05-21 Alan Mackenzie <acm@muc.de>
+
+ * progmodes/cc-engine.el (c-parse-state-get-strategy):
+ Replace parameter `here' with `here-' and `here-plus', which sandwich
+ any pertinent CPP construct.
+ (c-remove-stale-state-cache-backwards): Fix a bug which happens
+ when doing (c-parse-state) in a CPP construct: Exclude any "new"
+ CPP construct from taking part in the scanning.
+
+2010-05-21 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-do-copy-or-rename-file)
+ (tramp-handle-file-local-copy, tramp-maybe-open-connection):
+ Tune `with-progress-reporter' messages.
+ (tramp-handle-vc-registered):
+ * net/tramp-fish.el (tramp-fish-handle-file-local-copy)
+ (tramp-fish-handle-insert-file-contents)
+ (tramp-fish-maybe-open-connection):
+ * net/tramp-gvfs.el (tramp-gvfs-maybe-open-connection):
+ * net/tramp-imap.el (tramp-imap-do-copy-or-rename-file)
+ (tramp-imap-handle-insert-file-contents)
+ (tramp-imap-handle-file-local-copy): Use `with-progress-reporter'.
+
+2010-05-21 Juanma Barranquero <lekktu@gmail.com>
+
+ * add-log.el (change-log-font-lock-keywords):
+ Highlight all authors in multi-author entries.
+
+ * smerge-mode.el (smerge-refine-ignore-whitespace)
+ (smerge-refine-weight-hack, smerge-refine, smerge-makeup-conflict):
+ Fix typos in docstrings.
+ (smerge-resolve, smerge-refine-subst): Reflow docstrings.
+
+2010-05-21 Glenn Morris <rgm@gnu.org>
+
+ * progmodes/fortran.el (fortran-mode):
+ * progmodes/f90.el (f90-mode): Derive from prog-mode.
+
+ * loadup.el [CANNOT_DUMP]: Update for bootstrap-emacs no longer
+ having a relative path in src/Makefile.in.
+
+2010-05-20 Kevin Ryde <user42@zip.com.au>
+
+ * help-mode.el (help-make-xrefs): For Info node links turn
+ newlines into spaces. Link node names with newlines are matched
+ by help-xref-info-regexp and buttonized, this change ensures they
+ can be followed successfully with RET. (Bug#6206)
+
+2010-05-20 Juri Linkov <juri@jurta.org>
+
+ * locate.el (locate): Use pop-to-buffer instead of
+ switch-to-buffer-other-window. (Bug#6204)
+
+2010-05-20 Juri Linkov <juri@jurta.org>
+
+ * replace.el (replace-highlight): Fix lazy-highlighting
+ for `M-s w str M-% str RET'.
+
+2009-12-15 Masatake YAMATO <yamato@redhat.com>
+
+ * isearch.el (isearch-yank-word-or-char): Pull next subword
+ when `subword-mode' is activated. (Bug#6220)
+
+2010-05-20 Mark A. Hershberger <mah@everybody.org>
+
+ * isearch.el (isearch-update-post-hook): New hook.
+ (isearch-update): Use the new hook. (Bug#6225)
+
+2010-05-20 Juri Linkov <juri@jurta.org>
+
+ * isearch.el (isearch-mode-map): Bind more keys to isearch-help-map:
+ [f1], [help], and (char-to-string help-char) instead of "\C-h".
+ (Bug#6222)
+
+2010-05-20 Juri Linkov <juri@jurta.org>
+
+ * isearch.el (isearch-yank-string): Use isearch-process-search-string.
+ (Bug#6223)
+
+2010-05-20 Juri Linkov <juri@jurta.org>
+
+ * dired-x.el (dired-jump, dired-jump-other-window): Add arg
+ FILE-NAME to read from the minibuffer when called interactively
+ with prefix argument instead of using buffer-file-name.
+ http://lists.gnu.org/archive/html/emacs-devel/2010-05/msg00534.html
+
+ * dired.el: Update autoloads.
+
+2010-05-20 Chong Yidong <cyd@stupidchicken.com>
+
+ * nxml/nxml-mode.el (nxml-mode-map): Bind C-c / to
+ nxml-finish-element, for consistency with SGML mode.
+
+ * progmodes/octave-mod.el (octave-mode-map): Bind C-c / to
+ octave-close-block.
+
+2010-05-20 Juanma Barranquero <lekktu@gmail.com>
+
+ * composite.el: Require cl when compiling.
+ (reference-point-alist, compose-gstring-for-graphic)
+ (compose-gstring-for-terminal): Fix typos in docstrings.
+
+2010-05-19 Juri Linkov <juri@jurta.org>
+
+ * emacs-lisp/cl-macs.el (window-parameter): Add defsetf with
+ set-window-parameter.
+
+2010-05-19 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-methods): Add `tramp-async-args' attribute
+ where appropriate.
+ (tramp-maybe-open-connection): Use it.
+
+2010-05-19 Eli Zaretskii <eliz@gnu.org>
+
+ * simple.el (move-end-of-line): Make sure we are at line beginning
+ before backing up to end of previous line.
+
+2010-05-19 Michael Albinus <michael.albinus@gmx.de>
+
+ * password-cache.el (password-cache-remove): Fix docstring.
+
+ * net/secrets.el: Autoload the widget functions.
+ (secrets-search-items, secrets-create-item)
+ (secrets-get-attributes, secrets-expand-item): Attributes will be
+ stored on the password database without leading ":", as all other
+ clients do as well.
+ (secrets-mode): Fix docstring.
+ (secrets-show-secrets): Provide it as autoloaded command only when
+ D-Bus support is available. Check existence of Secret Service API.
+
+2010-05-19 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * indent.el (indent-region): Deactivate region (bug#6200).
+
+2010-05-19 Glenn Morris <rgm@gnu.org>
+
+ * vc-dir.el (vc-dir): Don't pop-up-windows. (Bug#6204)
+
+2010-05-19 Kenichi Handa <handa@m17n.org>
+
+ * composite.el: Register compose-gstring-for-graphic in
+ composition-function-table only for combining characters (Mn, Mc, Me).
+
+2010-05-18 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc-trail.el (calc-trail-isearch-forward)
+ (calc-trail-isearch-backward): Ensure that the new window
+ point is set correctly.
+
2010-05-18 Stefan Monnier <monnier@iro.umontreal.ca>
* subr.el (read-quoted-char): Resolve modifiers after key
remapping (bug#6212).
+2010-05-18 Michael Albinus <michael.albinus@gmx.de>
+
+ Add visualization code for secrets.
+ * net/secrets.el (secrets-mode): New major mode.
+ (secrets-show-secrets, secrets-show-collections)
+ (secrets-expand-collection, secrets-expand-item)
+ (secrets-tree-widget-after-toggle-function)
+ (secrets-tree-widget-show-password): New defuns.
+
+2010-05-18 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/smie.el (smie-next-sexp): Break inf-loop at BOB.
+ (smie-backward-sexp, smie-forward-sexp): Remove boundary condition now
+ handled in smie-next-sexp.
+ (smie-indent-calculate): Provide a starting indentation (so the
+ recursion is well-founded ;-).
+
+ Fix handling of non-associative equal levels.
+ * emacs-lisp/smie.el (smie-prec2-levels): Choose distinct levels even
+ when it's not needed.
+ (smie-op-left, smie-op-right): New functions.
+ (smie-next-sexp): New function, extracted from smie-backward-sexp.
+ Better handle equal levels to distinguish the associative case from
+ the "multi-keyword construct" case.
+ (smie-backward-sexp, smie-forward-sexp): Use it.
+
+2010-05-18 Juanma Barranquero <lekktu@gmail.com>
+
+ * progmodes/prolog.el (smie-indent-basic): Declare for byte-compiler.
+
+ * emacs-lisp/smie.el (smie-precs-precedence-table, smie-backward-sexp)
+ (smie-forward-sexp, smie-indent-calculate): Fix typos in docstrings.
+
+2010-05-17 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Provide a simple generic indentation engine and use it for Prolog.
+ * emacs-lisp/smie.el: New file.
+ * progmodes/prolog.el (prolog-smie-op-levels)
+ (prolog-smie-indent-rules): New var.
+ (prolog-mode-variables): Use them to configure SMIE.
+ (prolog-indent-line, prolog-indent-level): Remove.
+
+2010-05-17 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc-vec.el (math-vector-avg): Put the vector elements in
+ order before computing the averages.
+
+2010-05-16 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc-vec.el (calc-histogram):
+ (calcFunc-histogram): Allow vectors as inputs.
+ (math-vector-avg): New function.
+
+ * calc/calc-ext.el (math-group-float): Have the number of digits
+ being grouped depend on the radix (Bug#6189).
+
+2010-05-15 Ken Raeburn <raeburn@raeburn.org>
+
+ * version.el (emacs-copyright, emacs-version): Don't define here,
+ now that emacs.c defines it.
+
+2010-05-15 Eli Zaretskii <eliz@gnu.org>
+
+ * international/mule-cmds.el (mule-menu-keymap): Fix definition of
+ "Describe Language Environment" menu item.
+
+ * language/hebrew.el ("Hebrew", "Windows-1255"): Doc fix.
+
+ Bidi-sensitive movement with arrow keys.
+ * subr.el (right-arrow-command, left-arrow-command): New functions.
+
+ * bindings.el (global-map): Bind them to right and left arrow keys.
+
+ Don't override standard definition of convert-standard-filename.
+ * files.el (convert-standard-filename):
+ Call w32-convert-standard-filename and dos-convert-standard-filename on
+ the corresponding systems.
+
+ * w32-fns.el (w32-convert-standard-filename): Rename from
+ convert-standard-filename. Doc fix.
+
+ * dos-fns.el (dos-convert-standard-filename): Doc fix.
+ (convert-standard-filename): Don't defalias.
+ (register-name-alist, make-register, register-value)
+ (set-register-value, intdos): Obsolete aliases for the
+ corresponding dos-* functions and variables.
+ (dos-intdos): Add a doc string.
+
+2010-05-15 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc-aent.el (math-read-token, math-find-user-tokens):
+ * calc/calc-lang.el (math-read-big-rec, math-lang-read-symbol):
+ (math-compose-tex-func):
+ * calc/calccomp.el (math-compose-expr):
+ * calc/calc-ext.el (math-format-flat-expr-fancy):
+ * calc/calc-store.el (calc-read-var-name):
+ * calc/calc-units.el (calc-explain-units-rec): Allow Greek letters.
+
+ * calc/calc.el (var-π, var-φ, var-γ): New variables.
+ * calc/calc-aent.el (math-read-replacement-list): Add "micro" symbol.
+ * calc/calc-units.el (math-unit-prefixes): Add mu for micro.
+ (math-standard-units): Add units.
+
+2010-05-15 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/asm-mode.el (asm-mode):
+ * progmodes/prolog.el (prolog-mode): Use define-derived-mode.
+
+ * pcomplete.el (pcomplete-completions-at-point): New function,
+ extracted from pcomplete-std-complete.
+ (pcomplete-std-complete): Use it.
+
+2010-05-15 Glenn Morris <rgm@gnu.org>
+
+ * Makefile.in (setwins, setwins_almost, setwins_for_subdirs):
+ Remove references to CVS, RCS and Old directories.
+
+2010-05-14 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc-bin.el (math-format-twos-complement): Group digits when
+ appropriate.
+
+2010-05-14 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/sh-script.el (sh-mode-default-syntax-table): Remove.
+ (sh-mode-syntax-table): Give it a default value instead.
+ (sh-header-marker): Make buffer-local.
+ (sh-mode): Move make-local-variable to the corresponding setq.
+ (sh-add-completer): Avoid gratuitously let-binding a buffer-local var.
+ Use complete-with-action.
+
+ * simple.el (prog-mode): New (abstract) major mode.
+ * emacs-lisp/lisp-mode.el (emacs-lisp-mode, lisp-mode): Use it.
+ * progmodes/sh-script.el (sh-mode): Remove redundant var assignment.
+
+2010-05-14 Juanma Barranquero <lekktu@gmail.com>
+
+ * progmodes/sql.el (sql-oracle-program): Reflow docstring.
+ (sql-oracle-scan-on, sql-sybase-program, sql-product-font-lock)
+ (sql-add-product-keywords, sql-highlight-product, sql-set-product)
+ (sql-make-alternate-buffer-name, sql-placeholders-filter)
+ (sql-escape-newlines-filter, sql-input-sender)
+ (sql-send-magic-terminator, sql-sybase): Fix typos in docstrings.
+
+2010-05-13 Chong Yidong <cyd@stupidchicken.com>
+
+ Add TeX open-block and close-block keybindings to SGML, and vice versa.
+
+ * textmodes/tex-mode.el (tex-mode-map): Bind C-c C-t to
+ latex-open-block and C-c / to latex-close-block.
+
+ * textmodes/sgml-mode.el (sgml-mode-map): Bind C-c C-o to sgml-tag
+ and C-c C-e to sgml-close-tag.
+
+2010-05-13 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (with-progress-reporter): Create reporter object
+ only when the message would be displayed. Handle nested calls.
+ (tramp-handle-load, tramp-handle-file-local-copy)
+ (tramp-handle-insert-file-contents, tramp-handle-write-region)
+ (tramp-maybe-send-script, tramp-find-shell):
+ Use `with-progress-reporter'.
+ (tramp-handle-dired-compress-file, tramp-maybe-open-connection):
+ Fix message text.
+
+ * net/tramp-smb.el (tramp-smb-handle-copy-file)
+ (tramp-smb-handle-file-local-copy, tramp-smb-handle-rename-file)
+ (tramp-smb-handle-write-region, tramp-smb-maybe-open-connection):
+ Use `with-progress-reporter'.
+
+2010-05-13 Agustín Martín <agustin.martin@hispalinux.es>
+
+ * textmodes/ispell.el (ispell-init-process): Do not kill ispell
+ process everytime when spellchecking from the minibuffer (bug#6143).
+
+2010-05-13 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/sh-script.el (sh-mode): Use define-derived-mode.
+
+ * dos-fns.el: Add "dos-" prefix for namespace control.
+ (convert-standard-filename): Define as alias for
+ dos-convert-standard-filename but only if applicable.
+
+2010-05-12 Alan Mackenzie <acm@muc.de>
+
+ * progmodes/cc-cmds.el (c-beginning-of-defun, c-end-of-defun):
+ Push the mark at the start of these functions when appropriate.
+
+2010-05-12 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * minibuffer.el (completion-cycle-threshold): New custom var.
+ (completion--do-completion): Use it.
+ (minibuffer-complete): Use cycling if appropriate.
+
+2010-05-11 Juanma Barranquero <lekktu@gmail.com>
+
+ * dirtrack.el (dirtrackp): Remove defcustom; don't make automatically
+ buffer-local (it's an obsolete alias for `dirtrack-mode') (bug#6173).
+
+2010-05-11 Juri Linkov <juri@jurta.org>
+
+ * scroll-all.el (scroll-all-check-to-scroll):
+ Add `scroll-up-command' and `scroll-down-command' (bug#6164).
+
2010-05-11 Stefan Monnier <monnier@iro.umontreal.ca>
- * tmm.el (tmm-prompt): Don't try to precompute bindings.
- (tmm-get-keymap): Compute shortcuts (bug#6171).
+ * iimage.el (iimage-mode-map): Move initialization into declaration.
+ (iimage-mode-buffer): Use with-silent-modifications.
+ Simplify calling convention. Adjust callers.
+ (iimage-mode): Don't run hook redundantly.
-2010-05-10 Glenn Morris <rgm@gnu.org>
+ * minibuffer.el (completion-pcm--pattern->regex):
+ Fix last change (bug#6160).
- * desktop.el (desktop-save-buffer-p): Don't mistakenly include
- all dired buffers, even tramp ones. (Bug#5755) [Backport from trunk]
+2010-05-10 Juri Linkov <juri@jurta.org>
-2010-05-07 Chong Yidong <cyd@stupidchicken.com>
+ Remove nodes visited during Isearch from the Info history.
+ * info.el (Info-isearch-initial-history)
+ (Info-isearch-initial-history-list): New variables.
+ (Info-isearch-start): Record initial values of
+ Info-isearch-initial-history and Info-isearch-initial-history-list.
+ Add Info-isearch-end to isearch-mode-end-hook.
+ (Info-isearch-end): New function.
- * Version 23.2 released.
+2010-05-10 Michael Albinus <michael.albinus@gmx.de>
-2010-05-03 Chong Yidong <cyd@stupidchicken.com>
+ * net/tramp.el (tramp-do-file-attributes-with-stat): Add space in
+ format string, in order to work around a bug in pdksh.
+ Reported by Gilles Pion <gpion@lfdj.com>.
+ (tramp-handle-verify-visited-file-modtime): Do not send a command
+ when the connection is not established.
+ (tramp-handle-set-file-times): Simplify the check for utc.
+
+2010-05-10 Juanma Barranquero <lekktu@gmail.com>
+
+ Fix use of `filter-buffer-substring' (rework previous change).
+ * emulation/cua-base.el (cua--filter-buffer-noprops): New function.
+ (cua-repeat-replace-region):
+ * emulation/cua-rect.el (cua--extract-rectangle, cua-incr-rectangle):
+ * emulation/cua-gmrk.el (cua-copy-region-to-global-mark)
+ (cua-cut-region-to-global-mark): Use it.
+
+2010-05-09 Michael R. Mauger <mmaug@yahoo.com>
+
+ * progmodes/sql.el: Version 2.1.
+ (sql-product-alist): Redesign structure of product info.
+ (sql-product, sql-user, sql-server, sql-database): Safe variables.
+ (sql-port, sql-port-history): New variables.
+ (sql-interactive-product): New variable.
+ (sql-send-terminator): New variable.
+ (sql-imenu-generic-expression): Add "Types" imenu entry.
+ (sql-oracle-login-params, sql-sqlite-login-params)
+ (sql-mysql-login-params, sql-solid-login-params)
+ (sql-sybase-login-params, sql-informix-login-params)
+ (sql-ingres-login-params, sql-ms-login-params)
+ (sql-postgres-login-params, sql-interbase-login-params)
+ (sql-db2-login-params, sql-linter-login-params)
+ (sql-oracle-scan-on): New variables.
+ (sql-mode-map): Add C-c C-i to start interactive mode.
+ (sql-mode-menu): Update existing menu entries.
+ (sql-font-lock-keywords-builder): Compile-time font-lock optimization.
+ (sql-mode-oracle-font-lock-keywords)
+ (sql-mode-postgres-font-lock-keywords)
+ (sql-mode-ms-font-lock-keywords)
+ (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-mysql-font-lock-keywords)
+ (sql-mode-sqlite-font-lock-keywords)
+ (sql-mode-db2-font-lock-keywords)
+ (sql-mode-linter-font-lock-keywords): Update initialization to
+ reduce run-time complexity.
+ (sql-add-product, sql-del-product): New functions.
+ (sql-set-product-feature, sql-get-product-feature): New functions.
+ (sql-product-font-lock): Update product API.
+ (sql-add-product-keywords): New function.
+ (sql-highlight-product): Update product API.
+ (sql-help-list-products): New function.
+ (sql-help): Dynamically lists free and non-free products.
+ (sql-get-login): Correct bug in handling history and added
+ prompt for port.
+ (sql-copy-column): Copy without properties.
+ (sqli-input-sender): Apply filters to SQLi input.
+ (sql-query-placeholders-and-send): Obey `sql-oracle-scan-on' setting.
+ Implement as a filter.
+ (sql-escape-newlines-filter): Implement as a filter.
+ (sql-remove-tabs-filter): New function.
+ (sql-send-magic-terminator): New function.
+ (sql-send-string): Implement magic terminator.
+ (sql-send-region): Use `sql-send-string'.
+ (sql-interactive-mode): Use product API.
+ (sql-product-interactive): Use product API.
+ (sql-oracle, sql-sybase, sql-informix, sql-sqlite, sql-mysql)
+ (sql-solid, sql-ingres, sql-ms, sql-postgres, sql-interbase)
+ (sql-db2, sql-linter): Use `sql-product-interactive'.
+ (sql-connect): New function.
+ (sql-connect-oracle, sql-connect-sybase, sql-connect-informix)
+ (sql-connect-sqlite, sql-connect-mysql, sql-connect-solid)
+ (sql-connect-ingres, sql-connect-ms, sql-connect-postgres)
+ (sql-connect-interbase, sql-connect-db2, sql-connect-linter):
+ Use `sql-connect'.
+
+2010-05-09 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * minibuffer.el (completion-pcm-complete-word-inserts-delimiters):
+ New custom variable.
+ (completion-pcm--string->pattern): Use it.
+ (completion-pcm--pattern->regex, completion-pcm--pattern->string):
+ Make it handle any symbol as `any'.
+ (completion-pcm--merge-completions): Extract common suffix for the new
+ `prefix' symbol as well.
+ (completion-substring--all-completions): Use the new `prefix' symbol.
+
+2010-05-09 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp-compat.el (byte-compile-not-obsolete-vars): Define if
+ not bound.
+ (tramp-compat-copy-file): Add PRESERVE-SELINUX-CONTEXT.
+ (tramp-compat-funcall): New defmacro.
+ (tramp-compat-line-beginning-position)
+ (tramp-compat-line-end-position)
+ (tramp-compat-temporary-file-directory)
+ (tramp-compat-make-temp-file, tramp-compat-file-attributes)
+ (tramp-compat-copy-file, tramp-compat-copy-directory)
+ (tramp-compat-delete-file, tramp-compat-delete-directory)
+ (tramp-compat-number-sequence, tramp-compat-process-running-p)
+ * net/tramp.el (top, with-progress-reporter)
+ (tramp-rfn-eshadow-setup-minibuffer)
+ (tramp-rfn-eshadow-update-overlay, tramp-handle-set-file-times)
+ (tramp-handle-dired-compress-file, tramp-handle-shell-command)
+ (tramp-completion-mode-p, tramp-check-for-regexp)
+ (tramp-open-connection-setup-interactive-shell)
+ (tramp-compute-multi-hops, tramp-read-passwd, tramp-clear-passwd)
+ (tramp-time-diff, tramp-coding-system-change-eol-conversion)
+ (tramp-set-process-query-on-exit-flag, tramp-unload-tramp)
+ * net/tramp-cmds.el (tramp-cleanup-all-connections)
+ (tramp-reporter-dump-variable, tramp-load-report-modules)
+ (tramp-append-tramp-buffers)
+ * net/tramp-gvfs.el (tramp-gvfs-handle-file-selinux-context): Use it.
+
+ * net/tramp-imap.el (top): Autoload `epg-make-context'.
+
+2010-05-08 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/compile.el (compilation-buffer-modtime): Rename from
+ buffer-modtime. Adjust users.
+
+2010-05-08 Chong Yidong <cyd@stupidchicken.com>
* international/mule.el (auto-coding-alist): Only purecopy
car of each item, not the whole list (Bug#6083).
-2010-05-02 Chong Yidong <cyd@stupidchicken.com>
+2010-05-08 Chong Yidong <cyd@stupidchicken.com>
* progmodes/js.el (js-mode): Make paragraph variables local before
calling c-setup-paragraph-variables (Bug#6071).
-2010-05-01 Eli Zaretskii <eliz@gnu.org>
+2010-05-08 Eli Zaretskii <eliz@gnu.org>
* composite.el (compose-region, reference-point-alist): Fix typos
in the doc strings.
-2010-04-28 Alexander Klimov <alserkli@inbox.ru> (tiny change)
+2010-05-08 Alexander Klimov <alserkli@inbox.ru> (tiny change)
* calc/calc-graph.el (calc-graph-plot): Use the proper form for
gnuplot's "set" command.
-2010-04-26 Juanma Barranquero <lekktu@gmail.com>
+2010-05-08 Juanma Barranquero <lekktu@gmail.com>
* abbrev.el (last-abbrev-text): Doc fix.
(abbrev-prefix-mark): Don't escape parenthesis.
-2010-04-24 Andreas Schwab <schwab@linux-m68k.org>
+2010-05-08 Andreas Schwab <schwab@linux-m68k.org>
* composite.el (find-composition): Doc fix.
-2010-04-24 Juanma Barranquero <lekktu@gmail.com>
+2010-05-08 Juanma Barranquero <lekktu@gmail.com>
* progmodes/sql.el (sql-electric-stuff): Fix typo in tag.
(sql-oracle-program, sql-sqlite-options)
@@ -1783,91 +7579,645 @@
(sql-mode-db2-font-lock-keywords, sql-mode-font-lock-keywords)
(sql-product-feature, sql-highlight-product)
(comint-line-beginning-position, sql-rename-buffer)
- (sql-toggle-pop-to-buffer-after-send-region)
- (sql-oracle, sql-sybase, sql-informix, sql-sqlite, sql-mysql, sql-solid)
+ (sql-toggle-pop-to-buffer-after-send-region sql-oracle)
+ (sql-sybase, sql-informix, sql-sqlite, sql-mysql, sql-solid)
(sql-ingres, sql-ms, sql-postgres, sql-interbase, sql-db2, sql-linter):
Fix typos in docstrings.
-2010-04-23 Juri Linkov <juri@jurta.org>
+2010-05-08 Juri Linkov <juri@jurta.org>
* info.el (Info-fontify-node): Put Info-breadcrumbs to the `display'
property instead of `invisible' and `after-string' (bug#5998).
-2010-04-23 Juri Linkov <juri@jurta.org>
+2010-05-08 Juri Linkov <juri@jurta.org>
* image-mode.el (image-mode-as-text): Fix typo in docstring.
-2010-04-23 Juanma Barranquero <lekktu@gmail.com>
+2010-05-08 Juanma Barranquero <lekktu@gmail.com>
* filecache.el (file-cache-add-directory-list)
(file-cache-add-directory-recursively): Fix typos in docstrings.
-2010-04-22 Kenichi Handa <handa@m17n.org>
+2010-05-08 Kenichi Handa <handa@m17n.org>
* language/indian.el (gurmukhi-composable-pattern): Fix typo.
(gujarati-composable-pattern): Fix typo.
-2010-04-20 Kenichi Handa <handa@m17n.org>
+2010-05-08 Kenichi Handa <handa@m17n.org>
* language/indian.el (oriya-composable-pattern)
(tamil-composable-pattern, malayalam-composable-pattern):
Add two-part vowels to "v" (vowel sign).
-2010-04-20 Chong Yidong <cyd@stupidchicken.com>
+2010-05-08 Chong Yidong <cyd@stupidchicken.com>
* files.el (copy-directory): Handle symlinks (Bug#5982).
- * progmodes/compile.el (compilation-next-error-function):
- Revert 2009-10-12 change (Bug#5983).
-
-2010-04-20 Dan Nicolaescu <dann@ics.uci.edu>
+2010-05-08 Dan Nicolaescu <dann@ics.uci.edu>
* vc-hg.el (vc-hg-state): Use HGRCPATH, not HGRC.
(vc-hg-working-revision): Likewise. Use hg parents, not hg parent
(Bug#5846).
-2010-04-20 Glenn Morris <rgm@gnu.org>
+2010-05-08 Glenn Morris <rgm@gnu.org>
* emacs-lisp/lisp.el (lisp-completion-at-point): Give it a doc string.
* minibuffer.el (completion-at-point): Doc fix.
-2010-04-17 Dan Nicolaescu <dann@ics.uci.edu>
+2010-05-08 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * electric.el (Electric-command-loop): Minor tweak.
+
+ * ebuff-menu.el (electric-buffer-list): Try and make it behave a bit
+ better with dedicated windows.
+
+2010-05-07 Chong Yidong <cyd@stupidchicken.com>
+
+ * Version 23.2 released.
+
+2010-05-07 Deniz Dogan <deniz.a.m.dogan@gmail.com> (tiny change)
+ Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Highlight vendor specific properties.
+ * textmodes/css-mode.el (css-proprietary-nmstart-re): New var.
+ (css-proprietary-property): New face.
+ (css-font-lock-keywords): Use them.
+
+2010-05-07 Eli Zaretskii <eliz@gnu.org>
+
+ * cus-start.el (all): Add native condition for tool-bar-* symbols.
+
+2010-05-07 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * textmodes/dns-mode.el (auto-mode-alist): Add entry for .zone files.
+ * files.el (auto-mode-alist): Remove redundant entries.
+
+ * files.el (auto-save-mode): Move to simple.el to fix bootstrap.
+ * simple.el (auto-save-mode): Move from files.el.
+ * minibuffer.el (completion--common-suffix): Fix copy&paste error.
+
+2010-05-07 Christian von Roques <roques@mti.ag> (tiny change)
+
+ * epg.el (epg-key-capablity-alist): Add "D" flag (Bug#5592).
+
+2010-05-07 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * mail/binhex.el (binhex-decode-region-internal)
+ * mail/uudecode.el (uudecode-decode-region-internal)
+ * net/dns.el (dns-read-string-name, dns-write, dns-read)
+ (dns-read-type, dns-query)
+ * pgg-parse.el (pgg-parse-armor)
+ * pgg.el (pgg-verify-region)
+ * sha1.el (sha1-string-external): Don't run set-buffer-multibyte for
+ XEmacs.
+
+ * net/imap.el (imap-disable-multibyte): Redefine it as a macro.
+
+2010-05-07 Juanma Barranquero <lekktu@gmail.com>
+
+ * progmodes/cperl-mode.el (cperl-mode-unload-function): New function.
+
+ Fix use of `filter-buffer-substring' (4th arg NOPROPS removed).
+ * emulation/cua-base.el (cua-repeat-replace-region):
+ * emulation/cua-gmrk.el (cua-copy-region-to-global-mark)
+ (cua-cut-region-to-global-mark):
+ Remove text properties with `set-text-properties'.
+
+2010-05-06 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (top, with-progress-reporter):
+ Use `symbol-function' inside `funcall'.
+
+ * net/tramp-compat.el (tramp-compat-file-attributes)
+ (tramp-compat-delete-file, tramp-compat-delete-directory):
+ Handle only `wrong-number-of-arguments' error.
+
+ * net/tramp-gvfs.el (tramp-gvfs-handle-copy-file): Fix typo.
+ (tramp-gvfs-handle-file-selinux-context): Use `symbol-function'
+ inside `funcall'.
+
+2010-05-06 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * minibuffer.el (completion--sreverse, completion--common-suffix):
+ New functions.
+ (completion-pcm--merge-completions): Extract common suffix when safe.
+
+ * emacs-lisp/easy-mmode.el (define-minor-mode):
+ Make :variable more flexible.
+ * files.el (auto-save-mode): Use it to define using define-minor-mode.
+
+2010-05-05 Juri Linkov <juri@jurta.org>
+
+ Add `slow' and `history' tags to the desktop data.
+
+ * info.el (Info-virtual-nodes) [*Index*]: Add `slow' tag.
+ (Info-virtual-files) [*Apropos*]: Add `slow' tag.
+ (Info-finder-find-node): Require `finder.el' to be able
+ to restore node from the desktop.
+ (Info-desktop-buffer-misc-data): Save all nodes. Save additional
+ data `Info-history' and `slow' tag in the assoc list.
+ (Info-restore-desktop-buffer): Don't restore nodes with the
+ `slow' tag. Restore `Info-history'.
+
+2010-05-05 Michael Albinus <michael.albinus@gmx.de>
+
+ Add FORCE argument to `delete-file'.
+
+ * net/ange-ftp.el (ange-ftp-del-tmp-name): Make it a defun,
+ forcing to delete the temporary file.
+ (ange-ftp-delete-file): Add FORCE arg.
+ (ange-ftp-rename-remote-to-remote)
+ (ange-ftp-rename-local-to-remote, ange-ftp-rename-remote-to-local)
+ (ange-ftp-load, ange-ftp-compress, ange-ftp-uncompress):
+ Force file deletion.
+
+ * net/tramp-compat.el (tramp-compat-delete-file): New defun.
+
+ * net/tramp.el (tramp-handle-delete-file): Add FORCE arg.
+ (tramp-handle-make-symbolic-link, tramp-handle-load)
+ (tramp-do-copy-or-rename-file-via-buffer)
+ (tramp-do-copy-or-rename-file-directly)
+ (tramp-do-copy-or-rename-file-out-of-band)
+ (tramp-handle-process-file, tramp-handle-call-process-region)
+ (tramp-handle-shell-command, tramp-handle-file-local-copy)
+ (tramp-handle-insert-file-contents, tramp-handle-write-region)
+ (tramp-delete-temp-file-function): Use `tramp-compat-delete-file'.
+
+ * net/tramp-fish.el (tramp-fish-handle-delete-file): Add FORCE arg.
+ (tramp-fish-handle-make-symbolic-link)
+ (tramp-fish-handle-process-file): Use `tramp-compat-delete-file'.
+
+ * net/tramp-ftp.el (tramp-ftp-file-name-handler):
+ Use `tramp-compat-delete-file'.
+
+ * net/tramp-gvfs.el (tramp-gvfs-handle-delete-file): Add FORCE arg.
+ (tramp-gvfs-handle-write-region): Use `tramp-compat-delete-file'.
+
+ * net/tramp-imap.el (tramp-imap-handle-delete-file): Add FORCE arg.
+ (tramp-imap-do-copy-or-rename-file): Use `tramp-compat-delete-file'.
+
+ * net/tramp-smb.el (tramp-smb-handle-delete-file): Add FORCE arg.
+ (tramp-smb-handle-copy-file, tramp-smb-handle-file-local-copy)
+ (tramp-smb-handle-rename-file, tramp-smb-handle-write-region):
+ Use `tramp-compat-delete-file'.
+
+2010-05-05 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Minor cleanups.
+ * subr.el (add-minor-mode): Use push.
+ * mail/supercite.el (sc-electric-mode): Use more descriptive arg name.
+ * emulation/edt.el (edt-select-mode): Simplify.
+
+ Use define-minor-mode in more cases.
+ * term/tvi970.el (tvi970-set-keypad-mode):
+ * simple.el (auto-fill-mode, overwrite-mode, binary-overwrite-mode)
+ (normal-erase-is-backspace-mode):
+ * scroll-bar.el (scroll-bar-mode): Use it and define-minor-mode.
+ (set-scroll-bar-mode-1): (Re)move to its sole caller.
+ (get-scroll-bar-mode): New function.
+ * emacs-lisp/cl-macs.el (eq): Handle a non-variable first arg.
+
+ Use define-minor-mode for less obvious cases.
+ * emacs-lisp/easy-mmode.el (define-minor-mode): Add :variable keyword.
+ * emacs-lisp/cl-macs.el (terminal-parameter, eq): Add setf method.
+ * international/iso-ascii.el (iso-ascii-mode):
+ * frame.el (auto-raise-mode, auto-lower-mode):
+ * composite.el (global-auto-composition-mode): Use define-minor-mode.
+
+2010-05-04 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-methods): Remove "-q" from `tramp-login-args'
+ in order to see error messages for failed logins.
+
+2010-05-03 Chong Yidong <cyd@stupidchicken.com>
+
+ * diff.el (diff-sentinel):
+
+ * epg.el (epg--make-temp-file, epg-decrypt-string)
+ (epg-verify-string, epg-sign-string, epg-encrypt-string):
+
+ * jka-compr.el (jka-compr-partial-uncompress)
+ (jka-compr-call-process, jka-compr-write-region, jka-compr-load):
+
+ * server.el (server-sentinel): Use delete-file's new FORCE arg
+ (Bug#6070).
+
+2010-05-03 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Use define-minor-mode where applicable.
+ * view.el (view-mode):
+ * type-break.el (type-break-query-mode)
+ (type-break-mode-line-message-mode):
+ * textmodes/reftex.el (reftex-mode):
+ * term/vt100.el (vt100-wide-mode):
+ * tar-mode.el (tar-subfile-mode):
+ * savehist.el (savehist-mode):
+ * ibuf-ext.el (ibuffer-auto-mode):
+ * composite.el (auto-composition-mode):
+ * progmodes/vhdl-mode.el (vhdl-electric-mode, vhdl-stutter-mode):
+ Use define-minor-mode.
+ (vhdl-mode): Use static mode-line format.
+ (vhdl-mode-line-update): Delete.
+ (vhdl-create-mode-menu, vhdl-activate-customizations)
+ (vhdl-hs-minor-mode): Don't bother calling it.
+
+2010-05-02 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * simple.el (with-wrapper-hook): Move.
+ (buffer-substring-filters): Mark obsolete.
+ (filter-buffer-substring-functions): New variable.
+ (filter-buffer-substring): Use it. Remove unused arg `noprops'.
+
+2010-05-01 Toru TSUNEYOSHI <t_tuneyosi@hotmail.com>
+ Michael Albinus <michael.albinus@gmx.de>
+
+ Implement compression for inline methods.
+
+ * net/tramp.el (tramp-inline-compress-start-size): New defcustom.
+ (tramp-copy-size-limit): Allow also nil.
+ (tramp-inline-compress-commands): New defconst.
+ (tramp-find-inline-compress, tramp-get-inline-compress)
+ (tramp-get-inline-coding): New defuns.
+ (tramp-get-remote-coding, tramp-get-local-coding): Remove,
+ replaced by `tramp-get-inline-coding'.
+ (tramp-handle-file-local-copy, tramp-handle-write-region)
+ (tramp-method-out-of-band-p): Use `tramp-get-inline-coding'.
+
+2010-05-01 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * bindings.el (mode-line-abbrev-mode, mode-line-auto-fill-mode):
+ Remove unused functions.
+
+ * emacs-lisp/lisp-mode.el (lisp-mode): Use define-derived-mode.
+ Set find-tag-default-function as a variable rather than a property.
+
+ * minibuffer.el (tags-completion-at-point-function): Move to etags.el.
+ * progmodes/etags.el (tags-completion-at-point-function):
+ Remove left over interactive spec. Add autoloading stub.
+ (complete-tag): Use tags-completion-at-point-function.
+
+2010-04-30 Chong Yidong <cyd@stupidchicken.com>
+
+ * minibuffer.el (tags-completion-at-point-function): Fix return value.
+
+2010-04-29 Chong Yidong <cyd@stupidchicken.com>
+
+ * ido.el (ido-init-completion-maps): Remove C-v binding.
+ (ido-minibuffer-setup): Don't set cua-inhibit-cua-keys (Bug#5765).
+
+2010-04-29 Chong Yidong <cyd@stupidchicken.com>
+
+ * minibuffer.el (tags-completion-at-point-function): New function.
+ (completion-at-point-functions): Use it.
+
+ * progmodes/etags.el (complete-tag): Revert last change.
+
+2010-04-29 Alan Mackenzie <acm@muc.de>
+
+ * progmodes/cc-mode.el (c-extend-region-for-CPP): Fix an
+ off-by-one error (in end of macro position).
+
+2010-04-29 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * net/browse-url.el (browse-url-firefox-program): Use iceweasel if
+ firefox is absent. Don't autoload.
+ (browse-url-galeon-program): Don't autoload.
+
+2010-04-28 Chong Yidong <cyd@stupidchicken.com>
+
+ * bindings.el (complete-symbol): Move into minibuffer.el.
+
+ * minibuffer.el (complete-tag): Move from etags.el. If tags
+ completion cannot be performed, return nil instead of signalling
+ an error.
+ (completion-at-point): Make it an alias for complete-symbol.
+ (complete-symbol): Move from bindings.el, and replace with the
+ body of completion-at-point.
+
+ * progmodes/etags.el (complete-tag): Move to minibuffer.el.
+
+2010-04-28 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-remote-selinux-p): New defun.
+ (tramp-handle-file-selinux-context)
+ (tramp-handle-set-file-selinux-context): Use it.
+
+2010-04-28 Sam Steingold <sds@gnu.org>
+
+ * progmodes/bug-reference.el (bug-reference-url-format): Mark as
+ `safe-local-variable' if the value is a string or a symbol with
+ the property `bug-reference-url-format'.
+
+2010-04-28 Chong Yidong <cyd@stupidchicken.com>
+
+ * progmodes/bug-reference.el (bug-reference-url-format):
+ Revert 2010-04-27 change due to security risk.
+
+2010-04-28 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Make it possible to locally disable a globally enabled mode.
+ * simple.el (fundamental-mode): Run fundamental-mode-hook.
+ * emacs-lisp/derived.el (define-derived-mode): Use fundamental-mode
+ rather than kill-all-local-variables so it runs fundamental-mode-hook.
+ * emacs-lisp/easy-mmode.el (define-globalized-minor-mode):
+ Use fundamental-mode-hook to run MODE-enable-in-buffers earlier, so
+ that subsequent hooks get a chance to disable it.
+
+2010-04-27 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/easy-mmode.el (define-globalized-minor-mode):
+ Avoid re-enabling a minor mode after the user turned the minor mode
+ off if MODE-enable-in-buffers is run twice (typically once from
+ fundamental-mode's after-change-major-mode-hook and a second time from
+ run-mode-hook's own after-change-major-mode-hook).
+
+ * emacs-lisp/lisp.el (lisp-complete-symbol): Fail gracefully.
+
+2010-04-27 Sam Steingold <sds@gnu.org>
+
+ * progmodes/bug-reference.el (bug-reference-url-format): Mark as
+ `safe-local-variable' if the value is a string or a function, as
+ documented and implemented on 2010-04-02.
+
+2010-04-27 Juanma Barranquero <lekktu@gmail.com>
+
+ * ido.el (ido-buffer-internal): Bind `ido-use-virtual-buffers' to nil
+ when method is 'kill.
+
+2010-04-27 Agustín Martín <agustin.martin@hispalinux.es>
+
+ * textmodes/ispell.el (ispell-init-process): Fix personal dictionary
+ condition in default directory check.
+ (ispell-init-process,ispell-kill-ispell,kill-buffer-hook):
+ Kill ispell process when killing its associated buffer.
+
+2010-04-27 Jan Djärv <jan.h.d@swipnet.se>
+
+ * desktop.el (desktop-kill): ask-if-new: Ask if desktop file exists,
+ but we aren't using it.
+
+2010-04-25 Jan Djärv <jan.h.d@swipnet.se>
+
+ * tool-bar.el (tool-bar-local-item-from-menu): Revert unintended
+ checkin in 2010-04-23T16:26:11Z!monnier@iro.umontreal.ca.
+
+2010-04-24 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/authors.el (authors-obsolete-files-regexps):
+ Ignore VCS-ignore files, and deleted nextstep preferences files.
+ (authors-ignored-files): Ignore deleted cedet test files, and "*.el".
+ (authors-ambiguous-files): New list.
+ (authors-valid-file-names): Add some deleted files.
+ (authors-renamed-files-alist): Add font-setting.el, edt-user.doc.
+ (authors-disambiguate-file-name): New function. (Bug#5501)
+ (authors-canonical-file-name): Doc fix.
+ Don't warn about obsolete files.
+ (authors-canonical-file-name, authors-scan-el):
+ Use authors-disambiguate-file-name.
+
+ * hfy-cmap.el (htmlfontify-load-rgb-file, hfy-fallback-colour-values):
+ Add autoload cookies.
+ (htmlfontify-unload-rgb-file, hfy-fallback-colour-values): Add docs.
+ (generated-autoload-file): Set file-local value to "htmlfontify.el".
+ * htmlfontify.el (caddr, cadddr): Remove fallback definitions.
+ They have definitions / compiler macros in cl.el.
+ (htmlfontify-load-rgb-file, hfy-fallback-colour-values):
+ Replace manual autoloads with generated ones.
+ (htmlfontify-unload-rgb-file): Remove autoload.
+ * Makefile.in (autoloads): Ensure htmlfontify.el is writable.
+
+2010-04-23 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/bytecomp.el (byte-compile-set-default): New function.
+ (byte-compile-setq-default): Optimize for the
+ single-var case and don't call byte-compile-form in this case to avoid
+ inf-loop with byte-compile-set-default.
+
+ * progmodes/compile.el (compilation-start): Abbreviate default directory.
+
+2010-04-23 Michael Albinus <michael.albinus@gmx.de>
+
+ Implement SELINUX backends.
+
+ * net/tramp.el (tramp-file-name-handler-alist):
+ Add `file-selinux-context' and `set-file-selinux-context'.
+ (tramp-handle-file-selinux-context)
+ (tramp-handle-set-file-selinux-context): New defuns.
+ (tramp-handle-copy-file, tramp-do-copy-or-rename-file):
+ Handle PRESERVE-SELINUX-CONTEXT.
+
+ * net/tramp-gvfs.el (tramp-gvfs-file-name-handler-alist):
+ Add `file-selinux-context' and `set-file-selinux-context'.
+ (tramp-gvfs-handle-file-selinux-context)
+ (tramp-gvfs-handle-set-file-selinux-context): New defuns.
+ (tramp-gvfs-handle-copy-file): Handle PRESERVE-SELINUX-CONTEXT.
+
+ * net/ange-ftp.el (ange-ftp-copy-file):
+ * net/tramp-fish.el (tramp-fish-handle-copy-file):
+ * net/tramp-imap.el (tramp-imap-handle-copy-file):
+ * net/tramp-smb.el (tramp-smb-handle-copy-file):
+ Add PRESERVE-SELINUX-CONTEXT.
+
+2010-04-22 Michael Albinus <michael.albinus@gmx.de>
+
+ Synchronize with Tramp repository.
+
+ * net/tramp.el (with-connection-property, tramp-completion-mode-p)
+ (tramp-action-process-alive, tramp-action-out-of-band)
+ (tramp-check-for-regexp, tramp-file-name-p, tramp-equal-remote)
+ (tramp-exists-file-name-handler): Fix docstring.
+ (with-progress-reporter): New defmacro.
+ (tramp-do-copy-or-rename-file, tramp-handle-dired-compress-file)
+ (tramp-maybe-open-connection): Use it.
+
+2010-04-22 Noah Lavine <noah549@gmail.com> (tiny change)
+
+ Detect ssh 'ControlMaster' argument automatically in some cases.
+
+ * net/tramp.el (tramp-detect-ssh-controlmaster): New defun.
+ (tramp-default-method): Use it.
+
+2010-04-22 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-handle-copy-file): Add new optional
+ parameter `preserve-selinux-context'.
+ (tramp-file-name-for-operation): Add `set-file-selinux-context'.
+
+2010-04-22 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-completion-handle-file-name-all-completions):
+ Ensure, that non remote files are still checked. Oops.
+
+2010-04-21 Michael Albinus <michael.albinus@gmx.de>
+
+ Fix Bug#5840.
+
+ * icomplete.el (icomplete-completions): Use `non-essential'.
+
+ * net/tramp.el (tramp-connectable-p): New defun.
+ (tramp-handle-expand-file-name)
+ (tramp-completion-handle-file-name-all-completions)
+ (tramp-completion-handle-file-name-completion): Use it.
+
+2010-04-21 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/lisp.el (lisp-completion-at-point): Try and handle errors.
+
+2010-04-21 Jan Djärv <jan.h.d@swipnet.se>
+
+ * vc-dir.el (vc-dir-tool-bar-map): Add :label on some tool bar items.
+
+ * tool-bar.el (tool-bar-setup): Add :label on some tool bar items.
+
+ * loadup.el: Load dynamic-setting.el if feature dynamic-setting
+ is present.
+
+ * info.el (info-tool-bar-map): Add labels.
+
+ * cus-start.el (all): Add tool-bar-style and tool-bar-max-label-size.
+
+ * cus-edit.el (custom-commands): Add labels for tool bar.
+ (custom-buffer-create-internal, Custom-mode): Adjust for
+ labels in custom-commands.
+
+ * dynamic-setting.el: Renamed from font-setting.el.
+
+2010-04-21 John Wiegley <jwiegley@gmail.com>
+
+ * ido.el (ido-init-completion-maps): For ido-switch-buffer, C-o
+ toggles the use of virtual buffers.
+ (ido-buffer-internal): Guard `ido-use-virtual-buffers' global value.
+ (ido-toggle-virtual-buffers): New function.
+
+2010-04-21 Juanma Barranquero <lekktu@gmail.com>
+
+ Use `define-derived-mode'; fix window selection; doc fixes.
+ * play/tetris.el (tetris, tetris-update-speed-function)
+ (tetris-tty-colors, tetris-x-colors, tetris-move-bottom)
+ (tetris-move-left, tetris-move-right, tetris-rotate-prev)
+ (tetris-rotate-next, tetris-end-game, tetris-start-game)
+ (tetris-pause-game): Fix typos in docstrings.
+ (tetris-mode-map, tetris-null-map):
+ Move initialization into declaration.
+ (tetris-mode): Define with `define-derived-mode';
+ set show-trailing-whitespace to nil.
+ (tetris): Prefer window already displaying the "*Tetris*" buffer.
+
+2010-04-21 Karel Klíč <kklic@redhat.com>
+
+ * files.el (backup-buffer): Handle SELinux context, and return it
+ if a backup was made by renaming.
+ (backup-buffer-copy): Set SELinux context to the target file.
+ (basic-save-buffer): Set SELinux context of the newly written file.
+ (basic-save-buffer-1): Now it also returns any SELinux context.
+ (basic-save-buffer-2): Set SELinux context of the newly created file,
+ and return it.
+ * net/tramp.el (tramp-file-name-for-operation):
+ Add file-selinux-context.
+
+2010-04-21 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Make the log-edit comments use RFC822 format throughout.
+
+ * vc.el (vc-checkin, vc-modify-change-comment):
+ Adjust to new vc-start/finish-logentry.
+ (vc-find-conflicted-file): New command.
+ (vc-transfer-file): Adjust to new vc-checkin.
+ (vc-next-action): Improve scoping.
+
+ * vc-hg.el (vc-hg-log-edit-mode): Remove.
+ (vc-hg-checkin): Remove extra arg. Use log-edit-extract-headers.
+
+ * vc-git.el (vc-git-log-edit-mode): Remove.
+ (vc-git-checkin): Remove extra arg. Use log-edit-extract-headers.
+ (vc-git-commits-coding-system): Rename from git-commits-coding-system.
+
+ * vc-dispatcher.el (vc-log-edit): Shorten names for log-edit-show-files.
+ (vc-start-logentry): Remove argument `extra'.
+ (vc-finish-logentry): Remove extra args.
+
+ * vc-bzr.el (vc-bzr-log-edit-mode): Remove.
+ (vc-bzr-checkin): Remove extra arg. Use log-edit-extract-headers.
+ (vc-bzr-conflicted-files): New function.
+
+ * log-edit.el (log-edit-extra-flags)
+ (log-edit-before-checkin-process): Remove.
+ (log-edit-summary, log-edit-header, log-edit-unknown-header): New faces.
+ (log-edit-headers-alist): New var.
+ (log-edit-header-contents-regexp): New const.
+ (log-edit-match-to-eoh): New function.
+ (log-edit-font-lock-keywords): Use them.
+ (log-edit): Insert a "Summary:" header as default.
+ (log-edit-mode): Mark font-lock rules as case-insensitive.
+ (log-edit-done): Cleanup headers.
+ (log-view-process-buffer): Remove.
+ (log-edit-extract-headers): New function to replace it.
+
+2010-04-20 Juanma Barranquero <lekktu@gmail.com>
+
+ * subr.el (default-direction-reversed): Remove obsolescence info.
+
+2010-04-20 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * vc-dispatcher.el (vc-finish-logentry): Don't mess so badly with the
+ windows/frames.
+
+ * emacs-lisp/lisp.el (lisp-completion-at-point): Complete around point.
+ I.e. include text after point in the completion region.
+ Also, return nil when we're not after/in a symbol.
+
+ * international/mule-cmds.el (view-hello-file): Don't fiddle with the
+ default enable-multibyte-characters.
+
+2010-04-19 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * international/mule.el: Help the user choose a valid coding-system.
+ (read-buffer-file-coding-system): New function.
+ (set-buffer-file-coding-system): Use it. Prompt the user if the
+ coding-system cannot encode all the chars.
+
+ * vc-bzr.el: Use standard *vc* and *vc-diff* buffers.
+ (vc-bzr-shelve-show, vc-bzr-shelve-apply)
+ (vc-bzr-shelve-apply-and-keep, vc-bzr-shelve-snapshot):
+ Don't use *vc-bzr-shelve*.
+
+2010-04-19 Dan Nicolaescu <dann@ics.uci.edu>
Fix the version number for added files.
* vc-hg.el (vc-hg-working-revision): Check if the file is
registered after hg parent fails (Bug#5961).
-2010-04-17 Glenn Morris <rgm@gnu.org>
+2010-04-19 Glenn Morris <rgm@gnu.org>
* htmlfontify.el (htmlfontify-buffer)
(htmlfontify-copy-and-link-dir): Autoload entry points.
-2010-04-17 Magnus Henoch <magnus.henoch@gmail.com>
+2010-04-19 Magnus Henoch <magnus.henoch@gmail.com>
* vc-hg.el (vc-hg-annotate-extract-revision-at-line): Expand file
name relative to the project root (Bug#5960).
-2010-04-16 Glenn Morris <rgm@gnu.org>
+2010-04-19 Glenn Morris <rgm@gnu.org>
* vc-git.el (vc-git-print-log): Doc fix.
-2010-04-14 Óscar Fuentes <ofv@wanadoo.es>
+2010-04-19 Óscar Fuentes <ofv@wanadoo.es>
* ido.el (ido-file-internal): Fix 2009-12-02 change.
-2010-04-14 Christoph <cschol2112@googlemail.com> (tiny change)
+2010-04-19 Christoph <cschol2112@googlemail.com> (tiny change)
* progmodes/grep.el (grep-compute-defaults): Fix handling of host
default settings (Bug#5928).
-2010-04-10 Glenn Morris <rgm@gnu.org>
+2010-04-19 Glenn Morris <rgm@gnu.org>
* progmodes/fortran.el (fortran-match-and-skip-declaration):
New function.
(fortran-font-lock-keywords-3): Use it. (Bug#1385)
-2010-04-07 Kenichi Handa <handa@m17n.org>
+2010-04-19 Kenichi Handa <handa@m17n.org>
* language/indian.el (malayalam-composable-pattern): Fix previous
change (add U+0D4D "SIGN VIRAMA").
@@ -1877,12 +8227,12 @@
(kannada-composable-pattern): Fix U+0CB0 and typo in the regexp.
(malayalam-composable-pattern): Fix U+0D4D and typo in the regexp.
-2010-04-06 Chong Yidong <cyd@stupidchicken.com>
+2010-04-19 Chong Yidong <cyd@stupidchicken.com>
* textmodes/tex-mode.el (latex-mode): Revert 2008-03-03 change to
paragraph-separate (Bug#5821).
-2010-04-05 Juri Linkov <juri@jurta.org>
+2010-04-19 Juri Linkov <juri@jurta.org>
Put breadcrumbs on overlay instead of inserting to buffer (bug#5809).
@@ -1899,17 +8249,538 @@
property and `after-string' set to the string returned by
`Info-breadcrumbs'.
-2010-04-03 Chong Yidong <cyd@stupidchicken.com>
+2010-04-19 Chong Yidong <cyd@stupidchicken.com>
* help.el (help-window-setup-finish): Doc fix (Bug#5830).
Reported by monkey@sandpframing.com.
-2010-03-30 Tomas Abrahamsson <tab@lysator.liu.se>
+2010-04-19 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * tmm.el (tmm-prompt): Remove obsolete call to x-popup-menu.
+ (tmm-get-keymap): Add key-binding shortcuts now that they're not
+ available in the "keyseq cache" any more.
+
+ * custom.el (defcustom): Add edebug spec.
+
+2010-04-18 Juri Linkov <juri@jurta.org>
+
+ Test for special mode-class in view-buffer instead of view-file (bug#5513).
+
+ * view.el (view-file, view-buffer): Move test for special mode-class
+ from view-file to view-buffer.
+
+ * tar-mode.el (tar-extract): Turn if's into one cond
+ like in arc-mode.el.
+
+2010-04-18 Juri Linkov <juri@jurta.org>
+
+ Add 7z archive format support (bug#5475).
+
+ * arc-mode.el (archive-zip-extract): Try to find 7z executable.
+ (archive-7z-extract): New defcustom.
+ (archive-find-type): Add magic string for 7z.
+ (archive-extract-by-stdout): Add new optional arg `stderr-file'.
+ If `stderr-file' is non-nil, use `(t stderr-file)' for the
+ `buffer' arg of `call-process'.
+ (archive-zip-extract): Check `archive-zip-extract' for "7z" and
+ call the function `archive-7z-extract' with the variable
+ `archive-7z-extract' let-bound to `archive-zip-extract'.
+ (archive-7z-summarize, archive-7z-extract): New functions.
+
+ * international/mule.el (auto-coding-alist):
+ * files.el (auto-mode-alist): Add 7z file extension.
+
+2010-04-18 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * loadup.el: Setup hash-cons for pure data.
+
+ Fix duplicate entries in cedet's loaddefs.el files.
+ * emacs-lisp/autoload.el (autoload-file-load-name): Be more clever.
+ Should make most file-local generated-autoload-file unnecessary.
+ (print-readably): Silence warnings.
+ (autoload-find-destination): Take load-name as an arg to make sure
+ it's the same as the one that will be in the file.
+ (autoload-generate-file-autoloads): Adjust to above changes.
+ Try to make the dataflow a bit simpler.
+
+ * cvs-status.el (cvs-refontify): Remove unused.
+
+2010-04-18 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc.el (calc-mode-map): Bind "O" to `calc-missing-key'.
+
+ * calc/calc-bin.el (calc-radix): Have the "O" option turn on
+ twos-complement mode.
+
+2010-04-17 Jay Belanger <jay.p.belanger@gmail.com>
+
+ * calc/calc-ext.el (calc-init-extensions): Add keybinding for
+ 'calc-option'. Add `calc-option-prefix-help' to calc-help autoloads.
+ (calc-inverse): Add "Option" to message, as appropriate.
+ (calc-hyperbolic): Add "Option" to message, as appropriate.
+ (calc-option, calc-is-option): New functions.
+
+ * calc/calc-help.el (calc-full-help): Add `calc-option-help'.
+ (calc-option-prefix-help): New function.
+
+ * calc/calc-misc.el (calc-help): Add "Option" entry.
+
+ * calc/calc.el (calc-local-var-list): Add `calc-option-flag'.
+ (calc-option-flag): New variable.
+ (calc-do): Set `calc-option-flag to nil.
+ (calc-set-mode-line): Add "Opt " as appropriate.
+
+2010-04-16 Juri Linkov <juri@jurta.org>
+
+ Move scrolling commands from simple.el to window.el
+ because their primitives are implemented in window.c.
+
+ * simple.el (scroll-error-top-bottom)
+ (scroll-up-command, scroll-down-command, scroll-up-line)
+ (scroll-down-line, scroll-other-window-down)
+ (beginning-of-buffer-other-window, end-of-buffer-other-window):
+ * window.el (scroll-error-top-bottom)
+ (scroll-up-command, scroll-down-command, scroll-up-line)
+ (scroll-down-line, scroll-other-window-down)
+ (beginning-of-buffer-other-window, end-of-buffer-other-window):
+ Move from simple.el to window.el because their primitives are
+ implemented in window.c.
+
+2010-04-16 Juri Linkov <juri@jurta.org>
+
+ * isearch.el (isearch-lookup-scroll-key): Check both
+ `isearch-scroll' and `scroll-command' properties.
+ (scroll-up, scroll-down): Remove `isearch-scroll' property.
+
+ * mwheel.el (mwheel-scroll): Remove `isearch-scroll' property.
+
+ * simple.el (scroll-up-command, scroll-down-command)
+ (scroll-up-line, scroll-down-line): Remove `isearch-scroll' property.
+
+2010-04-15 Juri Linkov <juri@jurta.org>
+
+ * simple.el (scroll-up-command, scroll-down-command)
+ (scroll-up-line, scroll-down-line): Put `scroll-command'
+ property on the these symbols. Remove them from
+ `scroll-preserve-screen-position-commands'.
+
+ * mwheel.el (mwheel-scroll): Put `scroll-command' and
+ `isearch-scroll' properties on the `mwheel-scroll' symbol.
+ Remove it from `scroll-preserve-screen-position-commands'.
+
+ * isearch.el (isearch-allow-scroll): Doc fix.
+
+2010-04-15 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-error-with-buffer): Don't show the
+ connection buffer when we are in completion mode.
+ (tramp-file-name-handler): Catch the error for some operations
+ when we are in completion mode. This gives the user the chance to
+ correct the file name in the minibuffer.
+
+2010-04-15 Glenn Morris <rgm@gnu.org>
+
+ * progmodes/verilog-mode.el (verilog-forward-sexp): Avoid free variable.
+
+2010-04-15 Juanma Barranquero <lekktu@gmail.com>
+
+ Simplify by using `define-derived-mode'.
+ * info.el (Info-mode):
+ * calendar/todo-mode.el (todo-mode):
+ * play/gomoku.el (gomoku-mode): Define with `define-derived-mode'.
+ (gomoku-mode-map): Move initialization into declaration.
+
+2010-04-14 Michael Albinus <michael.albinus@gmx.de>
+
+ Fix Bug#5840.
+ * ido.el (ido-file-name-all-completions-1):
+ * minibuffer.el (minibuffer-completion-help):
+ * net/tramp.el (tramp-completion-mode-p): Use `non-essential'.
+
+2010-04-14 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * simple.el (non-essential): New var.
+
+ Add a new field `location' to bookmarks for non-file bookmarks.
+ * bookmark.el (bookmark-location): Use the new field, if present.
+ (bookmark-insert-location): Undo last change, not needed any more.
+ * man.el (Man-bookmark-make-record):
+ * woman.el (woman-bookmark-make-record): Add `location' field.
+
+2010-04-14 Juri Linkov <juri@jurta.org>
+
+ * simple.el (scroll-error-top-bottom): New defcustom.
+ (scroll-up-command, scroll-down-command): Use it. Doc fix.
+
+ * emulation/pc-select.el (pc-select-override-scroll-error):
+ Obsolete in favor of `scroll-error-top-bottom'.
+
+2010-04-14 Juri Linkov <juri@jurta.org>
+
+ * tutorial.el (tutorial--default-keys): Rebind `C-v' to
+ `scroll-up-command' and `M-v' to `scroll-down-command'.
+
+ * emulation/cua-rect.el (cua--init-rectangles):
+ * forms.el (forms--change-commands):
+ * image-mode.el (image-mode-map):
+ Remap scroll-down-command and scroll-up-command
+ in addition to scroll-down and scroll-up.
+
+2010-04-14 Juri Linkov <juri@jurta.org>
+
+ * mwheel.el (scroll-preserve-screen-position-commands):
+ Add mwheel-scroll to this list of commands.
+
+ * simple.el (scroll-preserve-screen-position-commands):
+ Add scroll-up-command, scroll-down-command, scroll-up-line,
+ scroll-down-line to this list of commands.
+
+2010-04-13 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * obsolete/complete.el: Move from lisp/complete.el.
+
+ * pcomplete.el (pcomplete-here*): Fix mistaken change (bug#5935).
+
+ * emacs-lisp/easy-mmode.el (define-minor-mode): Passing a nil argument
+ to the minor mode function now turns the mode ON unconditionally.
+
+2010-04-12 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * vc-dir.el (vc-dir-kill-line): New command.
+ (vc-dir-mode-map): Bind it to C-k.
+
+ * bookmark.el (bookmark-insert-location): Handle a nil filename.
+
+ * woman.el: Add bookmark declarations to silence the compiler.
+ (bookmark-prop-get): Use `man-args' rather than `filename' as a first
+ step to compatibility between man and woman bookmarks.
+ Adjust for Man-default-bookmark-title renaming.
+ (woman-bookmark-jump): Adjust accordingly. Don't forget to autoload.
+
+ * man.el: Add bookmark declarations to silence the compiler.
+ (Man-name-local-regexp): Make it match NAME as well.
+ (Man-getpage-in-background): Return the buffer.
+ (Man-notify-when-ready): Use `case'.
+ (man-set-default-bookmark-title): Rename to Man-default-bookmark-title.
+ Don't hardcode "NAME". Simplify.
+ (Man-bookmark-make-record): Use Man-arguments rather than buffer-name.
+ Rename from Man-bookmark-make-record.
+ (Man-bookmark-jump): Rename from man-bookmark-jump. Simplify now that
+ we have the actual man-args. Use Man-getpage-in-background rather
+ than `man' since the arg is already processed. Let bookmark.el do the
+ window handling. Only wait for the relevant process.
+ Don't forget to autoload.
+
+ * bookmark.el (bookmark-default-file): Use locate-user-emacs-file.
+
+2010-04-12 Thierry Volpiatto <thierry.volpiatto@gmail.com>
+
+ * woman.el (woman-bookmark-make-record, woman-bookmark-jump):
+ New functions.
+ (woman-mode): Setup bookmark support.
+
+ * man.el (man-set-default-bookmark-title, man-bookmark-make-record)
+ (man-bookmark-jump): New functions.
+ (Man-mode): Setup bookmark support.
+
+2010-04-10 Jari Aalto <jari.aalto@cante.net>
+
+ * comint.el (comint-password-prompt-regexp): Use regexp-opt, and
+ recognize ssh-keygen prompt (Bug#2817).
+
+2010-04-10 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp.el (tramp-do-copy-or-rename-file): Add progress reporter.
+
+2010-04-10 Michael Albinus <michael.albinus@gmx.de>
+
+ Synchronize with Tramp repository.
+
+ * net/tramp.el (tramp-completion-function-alist)
+ (tramp-file-name-regexp, tramp-chunksize)
+ (tramp-local-coding-commands, tramp-remote-coding-commands):
+ Fix docstring.
+ (tramp-remote-process-environment): Use `format' instead of `concat'.
+ (tramp-handle-directory-files-and-attributes)
+ (tramp-get-remote-path): Use `copy-tree'.
+ (tramp-handle-file-name-all-completions): Backward/ XEmacs
+ compatibility: Use `completion-ignore-case' if
+ `read-file-name-completion-ignore-case' does not exist.
+ (tramp-do-copy-or-rename-file-directly): Do not use
+ `tramp-handle-file-remote-p'.
+ (tramp-do-copy-or-rename-file-out-of-band):
+ Use `tramp-compat-delete-directory'.
+ (tramp-do-copy-or-rename-file-out-of-band)
+ (tramp-compute-multi-hops, tramp-maybe-open-connection):
+ Use `format-spec-make'.
+ (tramp-find-foreign-file-name-handler)
+ (tramp-advice-make-auto-save-file-name)
+ (tramp-set-auto-save-file-modes): Remove superfluous check for
+ `stringp'. This is done inside `tramp-tramp-file-p'.
+ (tramp-debug-outline-regexp): New defconst.
+ (tramp-get-debug-buffer): Use it.
+ (tramp-check-for-regexp): Use (forward-line 1).
+ (tramp-set-auto-save-file-modes): Adapt version check.
+
+ * net/tramp-compat.el (tramp-advice-file-expand-wildcards):
+ Wrap call of `featurep' for 2nd argument.
+ (tramp-compat-make-temp-file): Simplify fallback implementation.
+ (tramp-compat-copy-tree): Remove function.
+ (tramp-compat-delete-directory): Provide implementation for older
+ Emacsen.
+
+ * net/tramp-fish.el (tramp-fish-handle-directory-files-and-attributes):
+ Do not use `tramp-fish-handle-file-attributes.
+
+ * net/trampver.el: Update release number.
+
+2010-04-10 Glenn Morris <rgm@gnu.org>
+
+ * progmodes/compile.el (compilation-save-buffers-predicate):
+ Add missing :version tag.
+
+2010-04-09 Sam Steingold <sds@gnu.org>
+
+ * progmodes/compile.el (compilation-save-buffers-predicate):
+ Remove the "autoload" cookie.
+
+ * progmodes/bug-reference.el (turn-on-bug-reference-mode)
+ (turn-on-bug-reference-prog-mode): Remove, `bug-reference-mode'
+ and `bug-reference-prog-mode' can be used in hooks directly.
+
+2010-04-09 Dan Nicolaescu <dann@ics.uci.edu>
+
+ Add --author support to git commit.
+ * vc-git.el (vc-git-checkin): Pass extra-args to the commit command.
+ (vc-git-log-edit-mode): New minor mode.
+ (log-edit-mode, log-edit-extra-flags, log-edit-mode):
+ New declarations.
+
+2010-04-09 Eric Raymond <esr@snark.thyrsus.com>
+
+ * vc-hooks.el, vc-git.el: Improve documentation comments.
+
+2010-04-08 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Fix some of the problems in defsubst* (bug#5728).
+ * emacs-lisp/cl-macs.el (defsubst*): Don't substitute non-trivial args.
+ (cl-defsubst-expand): Do the substitutions simultaneously (bug#5728).
+
+2010-04-07 Sam Steingold <sds@gnu.org>
+
+ * progmodes/compile.el (compilation-save-buffers-predicate):
+ New custom variable.
+ (compile, recompile): Pass it to `save-some-buffers'.
+
+2010-04-07 Jan Djärv <jan.h.d@swipnet.se>
+
+ * wid-edit.el (widget-choose): Move cursor to the second line of
+ the buffer (Bug#5695).
+
+2010-04-07 Dan Nicolaescu <dann@ics.uci.edu>
+
+ Add new VC methods: vc-log-incoming and vc-log-outgoing.
+ * vc.el (vc-print-log-setup-buttons): New function split out from
+ vc-print-log-internal.
+ (vc-log-internal-common): New function, a parametrized version of
+ vc-print-log-internal.
+ (vc-print-log-internal): Just call vc-log-internal-common with the
+ right arguments.
+ (vc-incoming-outgoing-internal):
+ (vc-log-incoming, vc-log-outgoing): New functions.
+ (vc-log-view-type): New permanent local variable.
+
+ * vc-hooks.el (vc-menu-map): Bind vc-log-incoming and vc-log-outgoing.
+
+ * vc-bzr.el (vc-bzr-log-view-mode): Use vc-log-view-type instead
+ of the dynamic bound vc-short-log.
+ (vc-bzr-log-incoming, vc-bzr-log-outgoing): New functions.
+
+ * vc-git.el (vc-git-log-outgoing): New function.
+ (vc-git-log-view-mode): Use vc-log-view-type instead
+ of the dynamic bound vc-short-log.
+
+ * vc-hg.el (vc-hg-log-view-mode): Use vc-log-view-type instead
+ of the dynamic bound vc-short-log. Highlight the tag.
+ (vc-hg-log-incoming, vc-hg-log-outgoing): New functions.
+ (vc-hg-outgoing, vc-hg-incoming, vc-hg-outgoing-mode):
+ (vc-hg-incoming-mode): Remove.
+ (vc-hg-extra-menu-map): Do not bind vc-hg-incoming and vc-hg-outgoing.
+
+2010-04-07 Dan Nicolaescu <dann@ics.uci.edu>
+
+ Fix default-directory for vc-root-diff.
+ * vc.el (vc-root-diff): Bind default-directory to the root
+ directory for the diff command.
+
+2010-04-07 Michael McNamara <mac@mail.brushroad.com>
+
+ * progmodes/verilog-mode.el (verilog-forward-sexp):
+ (verilog-calc-1): Support "disable fork" and "fork wait" multi
+ word keywords, suggested by Steve Pearlmutter.
+ (verilog-pretty-declarations): Support lineup of declarations in
+ port lists.
+ (verilog-skip-backward-comments, verilog-skip-forward-comment-p):
+ fix bug for /* / comments.
+ (verilog-backward-syntactic-ws, verilog-forward-syntactic-ws):
+ Speed up and simplfy as this is never called with a bound.
+ (verilog-pretty-declarations): Enhance to line up declarations
+ inside a parameter list, suggested by Alan Morgan.
+ (verilog-pretty-expr): Tune assignment regular expression match
+ string for corner cases; also use markers instead of character
+ number as indent changes the later.
+
+2010-04-07 Wilson Snyder <wsnyder@wsnyder.org>
+
+ * progmodes/verilog-mode.el (verilog-type-keywords): Fix pulldown
+ as missing keyword.
+ (verilog-read-sub-decls-line): Fix comments in AUTO_TEMPLATE
+ causing truncation of AUTOWIRE signals. Reported by Bruce Tennant.
+ (verilog-auto-inst, verilog-auto-inst-port): Add vl_mbits for
+ AUTO_TEMPLATEs needing multiple array bits. Suggested by Bruce
+ Tennant.
+ (verilog-keywords):
+ (verilog-1800-2005-keywords, verilog-1800-2009-keywords): Add IEEE
+ 1800-2009 keywords, including "global.".
+
+2010-04-06 John Wiegley <jwiegley@gmail.com>
+
+ * ido.el (ido-add-virtual-buffers-to-list): Fix duplicated names
+ appearing in buffer list (if a live buffer name matched a recentf
+ file basename). Should use uniquify to offer a real solution.
+
+2010-04-06 John Wiegley <jwiegley@gmail.com>
+
+ * ido.el (ido-use-virtual-buffers, ido-virtual): Move a ChangeLog
+ comment to code, and add a :version tag.
+ (ido-virtual-buffers): Move defvar to fix byte-compiler warning.
+
+2010-04-06 Juanma Barranquero <lekktu@gmail.com>
+
+ Enable recentf-mode if using virtual buffers.
+ * ido.el (recentf-list): Declare for byte-compiler.
+ (ido-virtual-buffers): Move up to silence byte-compiler. Add docstring.
+ (ido-make-buffer-list): Simplify.
+ (ido-add-virtual-buffers-to-list): Simplify. Enable recentf-mode.
+
+2010-04-05 Juri Linkov <juri@jurta.org>
+
+ Scrolling commands which scroll a line instead of full screen.
+ http://lists.gnu.org/archive/html/emacs-devel/2010-03/msg01452.html
+
+ * simple.el (scroll-up-line, scroll-down-line): New commands.
+ Put property isearch-scroll=t on them.
+
+ * emulation/ws-mode.el (scroll-down-line, scroll-up-line):
+ Remove commands.
+
+2010-04-05 Juri Linkov <juri@jurta.org>
+
+ Scrolling commands which do not signal errors at top/bottom.
+ http://lists.gnu.org/archive/html/emacs-devel/2010-03/msg01452.html
+
+ * simple.el (scroll-up-command, scroll-down-command): New commands.
+ Put property isearch-scroll=t on them.
+
+ * bindings.el (global-map): Rebind [prior] from `scroll-down' to
+ `scroll-down-command' and [next] from `scroll-up' to
+ `scroll-up-command'.
+
+ * emulation/cua-base.el: Put property CUA=move on
+ `scroll-up-command' and `scroll-down-command'.
+ (cua--init-keymaps): Remap `scroll-up-command' to `cua-scroll-up'
+ and `scroll-down-command' to `cua-scroll-down'.
+
+2010-04-05 Juanma Barranquero <lekktu@gmail.com>
+
+ * help.el (describe-mode): Return nil.
+
+2010-04-04 John Wiegley <jwiegley@gmail.com>
+
+ * ido.el (ido-use-virtual-buffers): New variable to indicate
+ whether "virtual buffer" support is enabled for IDO.
+ (ido-virtual): Face used to indicate virtual buffers in the list.
+ (ido-buffer-internal): If a buffer is chosen, and no such buffer
+ exists, but a virtual buffer of that name does (which would be why
+ it was in the list), recreate the buffer by reopening the file.
+ (ido-make-buffer-list): If virtual buffers are being used, call
+ `ido-add-virtual-buffers-to-list' before the make list hook.
+ (ido-virtual-buffers): New variable which contains a copy of the
+ current contents of the `recentf-list', albeit pared down for the
+ sake of speed, and with proper faces applied.
+ (ido-add-virtual-buffers-to-list): Using the `recentf-list',
+ create a list of "virtual buffers" to present to the user in
+ addition to the currently open set. Note that this logic could
+ get rather slow if that list is too large. With the default
+ `recentf-max-saved-items' of 200, there is little speed penalty.
+
+2010-04-03 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * font-lock.el: Require CL when compiling.
+ (font-lock-turn-on-thing-lock): Use `case'.
+
+2010-04-03 Eli Zaretskii <eliz@gnu.org>
+
+ * emacs-lisp/authors.el (authors-fixed-entries): Add entry for Eli
+ Zaretskii.
+
+2010-04-02 Juri Linkov <juri@jurta.org>
+
+ * ehelp.el (electric-help-orig-major-mode):
+ New buffer-local variable.
+ (electric-help-mode): Set it to original major-mode. Doc fix.
+ (with-electric-help): Use `electric-help-orig-major-mode' instead
+ of (default-value 'major-mode). Doc fix.
+ http://lists.gnu.org/archive/html/emacs-devel/2010-04/msg00069.html
+
+2010-04-02 Sam Steingold <sds@gnu.org>
+
+ * vc-hg.el (vc-hg-push, vc-hg-pull): Use `apply' when calling
+ `vc-hg-command' with a list of flags.
+
+ * progmodes/bug-reference.el (bug-reference-bug-regexp):
+ Also accept "patch" and "RFE".
+ (bug-reference-fontify): `bug-reference-url-format' can also be a
+ function to be able to handle the bug kind.
+ (turn-on-bug-reference-mode, turn-on-bug-reference-prog-mode): Add.
+
+2010-04-02 Jan Djärv <jan.h.d@swipnet.se>
+
+ * tmm.el (tmm-get-keymap): Check with symbolp before passing
+ value to fboundp, it may not be a symbol.
+
+2010-03-31 Chong Yidong <cyd@stupidchicken.com>
+
+ * cus-edit.el (custom-buffer-sort-alphabetically): Update :version.
+
+2010-03-31 Juri Linkov <juri@jurta.org>
+
+ * simple.el (next-line, previous-line): Re-throw a signal
+ with `signal' instead of using `ding'.
+ http://lists.gnu.org/archive/html/emacs-devel/2010-03/msg01432.html
+
+2010-03-31 Juri Linkov <juri@jurta.org>
+
+ * simple.el (keyboard-escape-quit): Raise deselecting the active
+ region higher than exiting the minibuffer.
+ http://lists.gnu.org/archive/html/emacs-devel/2010-03/msg00904.html
+
+2010-03-31 Juri Linkov <juri@jurta.org>
+
+ * image.el (image-animated-p): Use `image-metadata' instead of
+ `image-extension-data'. Get GIF extenstion data from metadata
+ property `extension-data'.
+
+2010-03-31 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * simple.el (append-to-buffer): Simplify.
+
+2010-03-31 Tomas Abrahamsson <tab@lysator.liu.se>
* textmodes/artist.el (artist-mode): Fix typo in docstring.
Reported by Alex Schröder <kensanata@gmail.com>. (Bug#5807)
-2010-03-30 Kenichi Handa <handa@m17n.org>
+2010-03-31 Kenichi Handa <handa@m17n.org>
* language/sinhala.el (composition-function-table): Fix regexp for
the new Unicode specification.
@@ -1923,13 +8794,13 @@
(telugu-composable-pattern): New variables to cope with the new
Unicode specification. Use them in composition-function-table.
-2010-03-29 Stefan Monnier <monnier@iro.umontreal.ca>
+2010-03-31 Stefan Monnier <monnier@iro.umontreal.ca>
Make tmm-menubar work for the Buffers menu again (bug#5726).
* tmm.el (tmm-prompt): Also handle keymap entries in the form of
vectors rather than cons cells, as used in menu-bar-update-buffers.
-2010-03-28 Chong Yidong <cyd@stupidchicken.com>
+2010-03-31 Chong Yidong <cyd@stupidchicken.com>
* progmodes/js.el (js-auto-indent-flag, js-mode-map)
(js-insert-and-indent): Revert 2009-08-15 change, restoring
@@ -1937,41 +8808,127 @@
* mail/sendmail.el (mail-default-directory): Doc fix.
-2010-03-27 Chong Yidong <cyd@stupidchicken.com>
+2010-03-31 Chong Yidong <cyd@stupidchicken.com>
* mail/sendmail.el (mail-default-directory): Doc fix.
-2010-03-27 Eli Zaretskii <eliz@gnu.org>
+2010-03-31 Eli Zaretskii <eliz@gnu.org>
* subr.el (version-regexp-alist, version-to-list)
(version-list-<, version-list-=, version-list-<=)
(version-list-not-zero, version<, version<=, version=): Doc fix.
(Bug#5744).
-2010-03-26 YAMAMOTO Mitsuharu <mituharu@math.s.chiba-u.ac.jp>
- Nick Roberts <nickrob@snap.net.nz>
-
- * progmodes/gdb-ui.el (gdb-apple-test): New function.
- (gdb-init-1): Use it.
-
-2010-02-10 Dan Nicolaescu <dann@ics.uci.edu>
+2010-02-31 Dan Nicolaescu <dann@ics.uci.edu>
* vc.el (vc-root-diff): Doc fix.
-2010-03-25 Chong Yidong <cyd@stupidchicken.com>
+2010-03-31 Chong Yidong <cyd@stupidchicken.com>
* vc.el (vc-print-log, vc-print-root-log): Doc fix.
* simple.el (append-to-buffer): Fix last change.
-2010-03-24 Chong Yidong <cyd@stupidchicken.com>
+2010-03-31 Chong Yidong <cyd@stupidchicken.com>
* simple.el (append-to-buffer): Ensure that point is preserved if
BUFFER is the current buffer. Suggested by YAMAMOTO Mitsuharu.
(Bug#5749)
+2010-03-31 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * files.el (auto-mode-case-fold): Change default to t.
+
+2010-03-30 Juri Linkov <juri@jurta.org>
+
+ * dired-x.el (dired-omit-mode): Doc fix.
+
+2010-03-30 Juri Linkov <juri@jurta.org>
+
+ * replace.el (occur-accumulate-lines): Move occur-engine related
+ functions `occur-accumulate-lines' and `occur-engine-add-prefix'
+ to be located after `occur-engine'.
+
+2010-03-30 Juri Linkov <juri@jurta.org>
+
+ Make occur handle multi-line matches cleanly with context.
+ http://lists.gnu.org/archive/html/emacs-devel/2010-03/msg01280.html
+
+ * replace.el (occur-accumulate-lines): Add optional arg `pt'.
+ (occur-engine): Add local variables `ret', `prev-after-lines',
+ `prev-lines'. Use more arguments for `occur-context-lines'.
+ Set first elem of its returned list to `data', and the second elem
+ to `prev-after-lines'. Don't print the separator line.
+ In the end, print remaining context after-lines.
+ (occur-context-lines): Add new arguments `begpt', `endpt',
+ `lines', `prev-lines', `prev-after-lines'. Rewrite to combine
+ after-lines of the previous match with before-lines of the
+ current match and not overlap them. Return a list with two
+ values: the output line and the list of context after-lines.
+
+2010-03-30 Juri Linkov <juri@jurta.org>
+
+ * replace.el (occur-accumulate-lines): Fix a bug where the first
+ context line at the beginning of the buffer was missing.
+
+2010-03-30 Eli Zaretskii <eliz@gnu.org>
+
+ * files.el: Make bidi-display-reordering safe variable for boolean
+ values.
+
+2010-03-29 Phil Hagelberg <phil@evri.com>
+ Chong Yidong <cyd@stupidchicken.com>
+
+ * subr.el: Extend progress reporters to perform "spinning".
+ (progress-reporter-update, progress-reporter-do-update):
+ Handle non-numeric value arguments.
+ (progress-reporter--pulse-characters): New var.
+
+2010-03-28 Chong Yidong <cyd@stupidchicken.com>
+
+ * progmodes/compile.el (compilation-start): Fix regexp detection
+ of initial cd command (Bug#5771).
+
+2010-03-28 Stefan Guath <stefan@automata.se> (tiny change)
+
+ * find-dired.el (find-dired): Use read-directory-name (Bug#5777).
+
+2010-03-27 Nick Roberts <nickrob@snap.net.nz>
+
+ Restore GDB/MI fuctionality removed by 2009-12-29T07:15:34Z!nickrob@snap.net.nz.
+ * progmodes/gdb-mi.el: Restore.
+ * progmodes/gdb-ui.el: Remove.
+ * progmodes/gud.el: Re-accommodate for gdb-mi.el.
+
+2010-03-25 Glenn Morris <rgm@gnu.org>
+
+ * desktop.el (desktop-save-buffer-p): Don't mistakenly include
+ all dired buffers, even tramp ones. (Bug#5755)
+
+2010-03-25 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Add "union tags" in mpc.el.
+ * mpc.el: Remove backward compatibility code.
+ (mpc-browser-tags): Change default.
+ (mpc--find-memoize-union-tags): New var.
+ (mpc-cmd-flush, mpc-cmd-special-tag-p): New fun.
+ (mpc-cmd-find): Handle the case where the playlist does not exist.
+ Handle union-tags.
+ (mpc-cmd-list): Use mpc-cmd-special-tag-p. Handle union-tags.
+ (mpc-cmd-add): Use mpc-cmd-flush.
+ (mpc-tagbrowser-tag-name): New fun.
+ (mpc-tagbrowser-buf): Use it.
+ (mpc-songs-refresh): Use cond. Move to point-min as a fallback.
+
2010-03-24 Stefan Monnier <monnier@iro.umontreal.ca>
+ Misc cleanup.
+ * progmodes/make-mode.el (makefile-bsdmake-rule-action-regex):
+ Use replace-regexp-in-string.
+ (makefile-mode-abbrev-table): Merge defvar and define-abbrev-table.
+ (makefile-imake-mode-syntax-table): Move init into defvar.
+ (makefile-mode): Use define-derived-mode.
+
* progmodes/make-mode.el (makefile-rule-action-regex): Backtrack less.
(makefile-make-font-lock-keywords): Adjust rule since submatch 1 may
not be present any more.
@@ -1981,15 +8938,20 @@
* faces.el (set-face-attribute): Fix typo in docstring.
(face-valid-attribute-values): Reflow docstring.
-2010-03-23 Glenn Morris <rgm@gnu.org>
+2010-03-24 Glenn Morris <rgm@gnu.org>
* textmodes/flyspell.el (sgml-lexical-context): Autoload it (Bug#5752).
-2010-03-21 Chong Yidong <cyd@stupidchicken.com>
+2010-03-24 Chong Yidong <cyd@stupidchicken.com>
* indent.el (indent-for-tab-command): Doc fix.
-2010-03-22 Juanma Barranquero <lekktu@gmail.com>
+2010-03-24 Alan Mackenzie <acm@muc.de>
+
+ * progmodes/cc-engine.el (c-remove-stale-state-cache):
+ Fix off-by-one error. Fixes bug #5747.
+
+2010-03-24 Juanma Barranquero <lekktu@gmail.com>
* image-dired.el (image-dired-display-thumbs): Fix typo in docstring.
(image-dired-read-comment): Doc fix.
@@ -2011,35 +8973,31 @@
(reftex-cite-punctuation, reftex-search-unrecursed-path-first)
(reftex-highlight-selection): Fix typos in docstrings.
-2010-03-19 Juanma Barranquero <lekktu@gmail.com>
+2010-03-24 Juanma Barranquero <lekktu@gmail.com>
* minibuffer.el (completion-in-region-functions): Fix docstring typos.
-2010-03-18 Glenn Morris <rgm@gnu.org>
+2010-03-24 Glenn Morris <rgm@gnu.org>
* mail/rmail.el (rmail-highlight-face): Restore option deleted
2008-02-13 without comment; mark it obsolete.
(rmail-highlight-headers): Use rmail-highlight-face once more.
-2010-03-16 Chong Yidong <cyd@stupidchicken.com>
+2010-03-24 Chong Yidong <cyd@stupidchicken.com>
* woman.el (woman2-process-escapes): Only consume the newline if
the filler character is on a line by itself (Bug#5729).
-2010-03-16 Kenichi Handa <handa@m17n.org>
+2010-03-24 Kenichi Handa <handa@m17n.org>
* language/indian.el (devanagari-composable-pattern): Add more
consonants.
-2010-03-14 Michael Albinus <michael.albinus@gmx.de>
+2010-03-24 Michael Albinus <michael.albinus@gmx.de>
* net/trampver.el: Update release number.
-2010-03-13 Glenn Morris <rgm@gnu.org>
-
- * Makefile.in (ELCFILES): Add cedet/semantic/imenu.el.
-
-2010-03-13 Michael Albinus <michael.albinus@gmx.de>
+2010-03-24 Michael Albinus <michael.albinus@gmx.de>
* net/tramp.el (tramp-find-executable):
Use `tramp-get-connection-buffer'. Make the regexp for checking
@@ -2048,14 +9006,428 @@
(tramp-open-connection-setup-interactive-shell): Remove workaround
for OpenSolaris bug, it is not needed anymore.
-2010-03-12 Glenn Morris <rgm@gnu.org>
+2010-03-24 Glenn Morris <rgm@gnu.org>
* emacs-lisp/cl-macs.el (defsubst*): Add autoload cookie. (Bug#4427)
-2010-03-11 Wilson Snyder <wsnyder@wsnyder.org>
+2010-03-24 Wilson Snyder <wsnyder@wsnyder.org>
* files.el (auto-mode-alist): Accept more verilog file patterns.
+2010-03-24 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * vc-dir.el (vc-dir-headers): Abbreviate the working dir.
+
+2010-03-24 Glenn Morris <rgm@gnu.org>
+
+ * vc-bzr.el (vc-bzr-log-edit-mode): Add --fixes support to
+ log-edit-before-checkin-process.
+
+ * vc.el (vc-modify-change-comment): Pass MODE to vc-start-logentry.
+
+ * vc.el, vc-bzr.el, vc-hg.el (log-edit-mode): Declare.
+
+ * vc-dispatcher.el (vc-start-logentry): Doc fix.
+ (log-view-process-buffer, log-edit-extra-flags): Declare.
+
+ * log-edit.el (log-edit-before-checkin-process): Doc fix.
+
+2010-03-23 Sam Steingold <sds@gnu.org>
+
+ Fix bug#5620: recalculate all markers on compilation buffer
+ modifications, not on file modifications.
+ * progmodes/compile.el (buffer-modtime): New buffer-local variable:
+ the buffer modification time, for buffers not associated with files.
+ (compilation-mode): Create it.
+ (compilation-filter): Update it.
+ (compilation-next-error-function): Use it instead of
+ `visited-file-modtime' for timestamp.
+
+2010-03-23 Juri Linkov <juri@jurta.org>
+
+ Implement Occur multi-line matches.
+ http://lists.gnu.org/archive/html/emacs-devel/2010-03/msg01044.html
+
+ * replace.el (occur): Doc fix.
+ (occur-engine): Set `begpt' to the beginning of the first line.
+ Set `endpt' to the end of the last match line. At first, count
+ line numbers between `origpt' and `begpt'. Split out code from
+ `out-line' variable to new let-bindings `match-prefix' and
+ `match-str'. In `out-line' add non-numeric prefix to all
+ non-first lines of multi-line matches. Finally, count lines
+ between `begpt' and `endpt' and add to `lines'.
+
+2010-03-23 Juri Linkov <juri@jurta.org>
+
+ * replace.el (occur-accumulate-lines, occur-engine):
+ Use `occur-engine-line' instead of duplicate code.
+ (occur-engine-line): New function created from duplicate code
+ in `occur-accumulate-lines' and `occur-engine'.
+
+ * replace.el (occur-engine-line): Add optional arg `keep-props'.
+ (occur-accumulate-lines, occur-engine): Add arg `keep-props'.
+
+2010-03-23 Juri Linkov <juri@jurta.org>
+
+ * finder.el: Remove TODO tasks.
+
+ * info.el (Info-finder-find-node): Add node "all"
+ with all package info. Handle a list of multiple keywords
+ separated by comma.
+ (info-finder): In interactive use with a prefix argument,
+ use `completing-read-multiple' to read a list of keywords
+ separated by comma.
+
+2010-03-23 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Add a new completion style `substring'.
+ * minibuffer.el (completion-basic--pattern): New function.
+ (completion-basic-try-completion, completion-basic-all-completions):
+ Use it.
+ (completion-substring--all-completions)
+ (completion-substring-try-completion)
+ (completion-substring-all-completions): New functions.
+ (completion-styles-alist): New style `substring'.
+
+2010-03-22 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Get rid of .elc files after removal of the corresponding .el.
+ * Makefile.in (compile-clean): New target.
+ (compile-main): Use it.
+
+2010-03-22 Jan Djärv <jan.h.d@swipnet.se>
+
+ * Makefile.in (compile-main): cd to $(lisp) in a sub-shell, so we
+ don't do make there. When compiling with separate object dir, there
+ is no Makefile there.
+
+2010-03-22 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Get rid of the ELCFILES abomination, again.
+ * Makefile.in (update-elclist, ELCFILES, compile-last): Remove.
+ (all, compile): Don't call compile-last.
+ (compile-main): Build the "elcfiles" list dynamically.
+ (compile-targets): New (internal) target.
+
+2010-03-21 Andreas Schwab <schwab@linux-m68k.org>
+
+ * Makefile.in (top_srcdir): Define.
+ (abs_top_builddir): Define.
+ (srcdir): Don't append `/..'.
+ (EMACS): Use ${abs_top_builddir}.
+ (all, compile, compile-always, compile-last): Don't set emacswd.
+ (update-subdirs, update-authors): Use $(top_srcdir) instead of
+ $(srcdir).
+ (lisp): Use $(srcdir) instead of @srcdir@.
+
+2010-03-21 Juri Linkov <juri@jurta.org>
+
+ Fix message of multi-line occur regexps and multi-buffer header lines.
+ http://lists.gnu.org/archive/html/emacs-devel/2010-03/msg00457.html
+
+ * replace.el (occur-1): Don't display regexp if it is longer
+ than window-width. Use `query-replace-descr' to display regexp.
+ (occur-engine): Don't display regexp in the buffer header for
+ multi-buffer occur. Display a separate header line with total
+ match count and regexp for multi-buffer occur.
+ Use `query-replace-descr' to display regexp.
+
+2010-03-20 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * net/secrets.el: Fix parenthesis.
+ (secrets-enabled): Fix parenthesis.
+
+2010-03-20 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Use more relative file and directory names.
+ * Makefile.in (EMACS): Arrange for it to work when we chdir.
+ (setwins, setwins_almost, setwins_for_subdirs):
+ Don't `cd'; output relative names.
+ (all, compile, compile-always, compile-last): Set emacswd.
+ (custom-deps, finder-data, autoloads, update-subdirs, compile-last):
+ Just cd to the lisp source dir so we can use relative file names.
+
+ * outline.el (hide-sublevels): Unfix the paren non-typo! (bug#5738).
+
+2010-03-20 Glenn Morris <rgm@gnu.org>
+
+ * textmodes/rst.el: Use faces for font-lock customization, and make the
+ old -face variables obsolete.
+ (rst-block, rst-external, rst-definition, rst-directive, rst-comment)
+ (rst-emphasis1, rst-emphasis2, rst-literal, rst-reference): New faces.
+ (rst-block-face, rst-external-face, rst-definition-face)
+ (rst-directive-face, rst-comment-face, rst-emphasis1-face)
+ (rst-emphasis2-face, rst-literal-face, rst-reference-face):
+ Make obsolete.
+ (rst-font-lock-keywords-function): Update for above changes.
+
+2010-03-20 Juri Linkov <juri@jurta.org>
+
+ * s-region.el:
+ * obsolete/s-region.el: Move to obsolete.
+
+2010-03-19 Juanma Barranquero <lekktu@gmail.com>
+
+ * vc-dispatcher.el (vc-do-command): Remove reference to `vc-path'.
+
+2010-03-19 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * vc-hooks.el (vc-path): Remove variable and obsolete declaration.
+
+2010-03-19 Dan Nicolaescu <dann@ics.uci.edu>
+
+ Add special markup processing for commit logs.
+ * log-edit.el (log-edit-extra-flags): New variable.
+ (log-edit): Add new argument MODE. Use that mode when non-nil
+ instead of the log-view-mode.
+ (log-view-process-buffer): New function.
+
+ * vc.el: Document that the checkin method takes optional
+ arguments. Document new backend specific method: log-view-mode.
+ (vc-default-log-edit-mode): New function.
+ (vc-checkin): Use a backend specific log-view-mode.
+ Pass extra arguments to the checkin method.
+ (vc-modify-change-comment): Pass a dummy extra argument.
+
+ * vc-dispatcher.el (vc-log-edit): Add a mode argument, pass it to
+ log-edit.
+ (vc-start-logentry): Add a mode argument, pass it to vc-log-edit.
+ (vc-finish-logentry): Process the log buffer before passing it
+ down. Pass log-edit-extra-flags.
+
+ * vc-bzr.el (vc-bzr-checkin): Pass extra arguments to the commit
+ command.
+ (log-edit-extra-flags, log-edit-before-checkin-process):
+ New declarations.
+
+ * vc-hg.el (vc-hg-checkin): Pass extra arguments to the commit
+ command.
+ (log-edit-extra-flags, log-edit-before-checkin-process):
+ New declarations.
+ (vc-hg-log-edit-mode): New derived mode.
+
+ * vc-arch.el (vc-arch-checkin):
+ * vc-cvs.el (vc-cvs-checkin):
+ * vc-git.el (vc-git-checkin):
+ * vc-mtn.el (vc-mtn-checkin):
+ * vc-rcs.el (vc-rcs-checkin):
+ * vc-sccs.el (vc-sccs-checkin):
+ * vc-svn.el (vc-svn-checkin): Add an optional ignored argument.
+
+2010-03-19 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * outline.el (hide-sublevels): Don't hide trailing newline (and fix
+ parent typo).
+
+2010-03-19 Glenn Morris <rgm@gnu.org>
+
+ * password-cache.el (password-cache, password-cache-expiry): Autoload.
+
+2010-03-18 Glenn Morris <rgm@gnu.org>
+
+ * emacs-lisp/autoload.el (autoload-rubric): Doc fix.
+
+ * replace.el (query-replace-history): Give it a doc string.
+ (map-query-replace-regexp): Use query-replace-from-history-variable
+ and query-replace-to-history-variable.
+
+ * mail/hashcash.el (declare-function): Remove duplicate definition.
+
+ * mail/emacsbug.el (report-emacs-bug-pretest-address):
+ Make it an obsolete alias for report-emacs-bug-address.
+ (message-strip-special-text-properties): Declare.
+ (report-emacs-bug): Remove test for a pretest bug address.
+ Combine message-mode-specific code.
+
+ * mail/supercite.el: Don't require sendmail.
+ (mh-in-header-p): Declare rather than using with-no-warnings.
+ (sc-no-blank-line-or-header): Use rfc822-goto-eoh rather than
+ mail-header-end. Don't bind mysterious variable `kill-lines-magic'.
+
+ * calendar/cal-french.el: Convert to utf-8.
+
+ * files.el (interpreter-mode-alist): Use emacs-lisp-mode for
+ Emacs scripts.
+
+2010-03-16 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/secrets.el (secrets-enabled): New variable. Use it instead
+ of a subfeature.
+
+2010-03-15 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/secrets.el (top): Register the D-Bus signals only when the
+ service "org.freedesktop.secrets" can be pinged.
+ Provide subfeature `enabled'.
+
+2010-03-14 Juri Linkov <juri@jurta.org>
+
+ Add finder unknown keywords.
+
+ * finder.el (finder-unknown-keywords): New function.
+
+ * info.el (Info-finder-find-node): Use `finder-unknown-keywords'
+ to create a Finder node with unknown keywords.
+
+2010-03-14 Juri Linkov <juri@jurta.org>
+
+ * finder.el (finder-compile-keywords): Replace `princ' with
+ `prin1' on a list of symbols interned from keyword strings.
+
+ * emacs-lisp/lisp-mnt.el (lm-keywords-list): If `keywords' contains
+ a comma, then split keywords using a comma and optional whitespace.
+ Otherwise, split by whitespace.
+
+ * complete.el:
+ * face-remap.el:
+ * log-view.el:
+ * net/hmac-def.el:
+ * net/hmac-md5.el:
+ * net/netrc.el:
+ * progmodes/mixal-mode.el: Fix keywords.
+
+2010-03-13 Michael Albinus <michael.albinus@gmx.de>
+
+ * Makefile.in (ELCFILES): Add net/secrets.elc.
+
+ * net/secrets.el: New file.
+
+2010-03-12 Chong Yidong <cyd@stupidchicken.com>
+
+ * facemenu.el (list-colors-display, list-colors-print): New arg
+ callback. Use it to allow selecting colors.
+
+ * wid-edit.el (widget-image-insert): Insert image prop even if the
+ current display is non-graphic.
+ (widget-field-value-set): New fun.
+ (editable-field): Use it.
+ (widget-field-value-get): Clean up unused var.
+ (widget-color-value-create, widget-color--choose-action):
+ New funs. Allow using list-colors-display to choose color.
+
+2010-03-12 Chong Yidong <cyd@stupidchicken.com>
+
+ * cus-edit.el: Resort topmost custom groups.
+ (custom-buffer-sort-alphabetically): Default to t.
+ (customize-apropos): Use apropos-parse-pattern.
+ (custom-search-field): New var.
+ (custom-buffer-create-internal): Add custom-apropos search field.
+ (custom-add-parent-links): Don't display parent doc.
+ (custom-group-value-create): Don't sort top-level custom group.
+ (custom-magic-value-create): Show visibility button before option name.
+
+ (custom-variable-state): New fun, from custom-variable-state-set.
+ (custom-variable-state-set): Use it.
+ (custom-group-value-create): Hide options with standard values
+ using the :hidden-states property. Use progress reporter.
+
+ (custom-show): Simplify.
+ (custom-visibility): Disable images by default.
+ (custom-variable): New property :hidden-states.
+ (custom-variable-value-create): Enable images for
+ custom-visibility widgets. Use :hidden-states property to
+ determine initial visibility.
+
+ * wid-edit.el (widget-image-find): Give images center ascent.
+ (visibility): Add :on-image and :off-image properties.
+ (widget-visibility-value-create): Use them.
+
+2010-03-12 Chong Yidong <cyd@stupidchicken.com>
+
+ * cus-edit.el (processes): Remove from development group.
+ (oop, hypermedia): Delete group.
+ (comm): Promote to top-level group.
+
+ * net/browse-url.el (browse-url):
+ * net/xesam.el (xesam):
+ * net/tramp.el (tramp):
+ * net/goto-addr.el (goto-address):
+ * net/ange-ftp.el (ange-ftp): Put in comm group.
+
+ * view.el (view): Remove from editing group.
+
+ * uniquify.el (uniquify): Put in files group.
+
+ * net/browse-url.el (browse-url):
+ * ps-print.el (postscript): Put in external group.
+
+ * cus-edit.el (outlines):
+ * textmodes/text-mode.el (text-mode-hook):
+ * textmodes/table.el (table):
+ * textmodes/picture.el (picture):
+ * outline.el (outlines): Put in wp group.
+
+ * nxml/nxml-mode.el (nxml): Remove from wp group.
+
+ * net/tramp-imap.el (tramp-imap): Put in tramp group.
+
+ * mail/metamail.el (metamail): Remove from hypermedia group.
+
+ * cus-edit.el (abbrev):
+ * whitespace.el (whitespace):
+ * vcursor.el (vcursor):
+ * reveal.el (reveal):
+ * hl-line.el (hl-line): Put in convenience group.
+
+ * epg-config.el (epg): Put in data group.
+
+ * emulation/pc-select.el (pc-select): Put in emulations group.
+
+ * calculator.el (calculator): Put in applications group.
+
+2010-03-12 Dan Nicolaescu <dann@ics.uci.edu>
+
+ Add .dir-locals.el support for file-less buffers.
+ * files.el (hack-local-variables): Split out code to apply local
+ variable settings ...
+ (hack-local-variables-apply): ... here. New function.
+ (hack-dir-local-variables): Use the default directory for when the
+ buffer does not have an associated file.
+ (hack-dir-local-variables-non-file-buffer): New function.
+ * diff-mode.el (diff-mode):
+ * vc-annotate.el (vc-annotate-mode):
+ * vc-dir.el (vc-dir-mode):
+ * log-edit.el (log-edit-mode):
+ * log-view.el (log-view-mode): Call hack-dir-local-variables-non-file-buffer.
+
+2010-03-12 Dan Nicolaescu <dann@ics.uci.edu>
+
+ Add support for shelving snapshots and for showing shelves.
+ * vc-bzr.el (vc-bzr-shelve-show, vc-bzr-shelve-show-at-point)
+ (vc-bzr-shelve-apply-and-keep-at-point, vc-bzr-shelve-snapshot):
+ New functions.
+ (vc-bzr-shelve-map, vc-bzr-shelve-menu-map)
+ (vc-bzr-extra-menu-map): Map them.
+
+2010-03-11 Glenn Morris <rgm@gnu.org>
+
+ * cus-edit.el (customize-changed-options-previous-release):
+ Bump to 23.1.
+
+ * image.el (image-animate-max-time): Fix :version tag.
+
+2010-03-10 Chong Yidong <cyd@stupidchicken.com>
+
+ * Branch for 23.2.
+
+2010-03-10 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * vc-git.el (vc-git-revision-table): Include remote branches.
+
+2010-03-10 Kim F. Storm <storm@cua.dk>
+
+ Animated image API.
+ http://lists.gnu.org/archive/html/emacs-devel/2010-03/msg00211.html
+
+ * image.el (image-animate-max-time): New defcustom.
+ (image-animated-types): New defconst.
+ (create-animated-image, image-animate-timer)
+ (image-animate-start, image-animate-stop, image-animate-timeout)
+ (image-animated-p): New functions.
+
+ * image-mode.el (image-toggle-display-image):
+ Replace `create-image' with `create-animated-image'.
+
2010-03-09 Miles Bader <miles@gnu.org>
* vc-git.el (vc-git-print-log): Use "tformat:" for shortlog,
@@ -2205,11 +9577,6 @@
* files.el (hack-local-variables-filter): For eval forms, also
check safe-local-variable-p (Bug#5636).
-2010-02-24 Eduard Wiebe <usenet@pusto.de>
-
- * javascript.el (wisent-javascript-jv-expand-tag): Avoid c(ad)ddr
- and use c(ad)r of cddr (Bug#5640).
-
2010-02-22 Michael Albinus <michael.albinus@gmx.de>
* net/tramp.el (tramp-do-copy-or-rename-file-out-of-band): Protect
@@ -2564,7 +9931,7 @@
2010-02-03 Michael Albinus <michael.albinus@gmx.de>
* net/ange-ftp.el (ange-ftp-insert-directory): Parse directory
- also in case of (and (not full) (not wildcard)). This is needed,
+ also in case of (and (not full) (not wildcard)). This is needed
when dired is called with a list of files, which are not in
`default-directory'. (Bug#5478)
@@ -2698,7 +10065,7 @@
* vc-bzr.el (vc-bzr-revision-table): New function.
-2010-01-25 Eric Hanchrow <eric.hanchrow@gmail.com> (tiny change)
+2010-01-25 Eric Hanchrow <eric.hanchrow@gmail.com>
* vc-git.el (vc-git-dir-status-goto-stage): Pass --relative to the
diff-index command. This requires at least git-1.5.5. (Bug#1589).
@@ -3198,7 +10565,7 @@
2010-01-02 Karl Fogel <kfogel@red-bean.com>
- * bookmark.el (bookmark-bmenu-any-marks): New function
+ * bookmark.el (bookmark-bmenu-any-marks): New function.
(bookmark-bmenu-save): Clear buffer modification if no marks.
2010-01-02 Karl Fogel <kfogel@red-bean.com>
@@ -3387,7 +10754,7 @@
(tramp-advice-file-expand-wildcards): Remove it.
* net/tramp-compat.el (top): Autoload `tramp-handle-file-remote-p'.
- (tramp-advice-file-expand-wildcards): Moved from tramp.el.
+ (tramp-advice-file-expand-wildcards): Move from tramp.el.
Activate advice for older GNU Emacs versions. (Bug#5237)
2009-12-17 Juanma Barranquero <lekktu@gmail.com>
@@ -3409,7 +10776,7 @@
2009-12-17 Juri Linkov <juri@jurta.org>
- Make `dired-diff' more safe. (Bug#5225)
+ Make `dired-diff' safer. (Bug#5225)
* dired-aux.el (dired-diff): Signal an error when `file' equals to
`current' or when `file' is a directory of the `current' file.
@@ -3598,7 +10965,7 @@
2009-12-09 Vivek Dasmohapatra <vivek@etla.org>
- Drop some properties to avoid surprises.
+ Drop some properties to avoid surprises (bug#5002).
* htmlfontify.el (hfy-ignored-properties): New defcustom.
(hfy-fontify-buffer): Use it.
@@ -4903,7 +12270,7 @@
* Makefile.in (ELCFILES): Adapt to subword.el move.
2009-11-21 Thierry Volpiatto <thierry.volpiatto@gmail.com>
- Stefan Monnier <monnier@iro.umontreal.ca>
+ Stefan Monnier <monnier@iro.umontreal.ca>
* bookmark.el (bookmark-bmenu-bookmark-column): Remove var.
(bookmark-bmenu-list): Save name on `bookmark-name-prop' text-prop.
@@ -6795,6 +14162,12 @@
(tar-header-block-tokenize): Decode the username and groupname.
(tar-chown-entry, tar-chgrp-entry): Encode the names (bug#4730).
+2009-10-17 Eric Ludlam <zappo@gnu.org>
+
+ * emacs-lisp/eieio-base.el (eieio-persistent-save): If buffer
+ contains multibyte characters, choose first applicable coding
+ system automatically.
+
2009-10-17 Stefan Monnier <monnier@iro.umontreal.ca>
* international/mule-cmds.el (select-safe-coding-system): If the file
@@ -7741,6 +15114,10 @@
* term/w32-win.el (setup-default-fontset, set-fontset-font):
Remove unused declarations.
+2009-09-30 Eric Ludlam <zappo@gnu.org>
+
+ * emacs-lisp/eieio.el (boolean-p): Delete.
+
2009-09-30 Glenn Morris <rgm@gnu.org>
* emacs-lisp/authors.el (authors-ignored-files): Add "js2-mode.el".
@@ -7830,6 +15207,17 @@
* net/tramp-imap.el: New package.
+2009-09-28 Eric Ludlam <zappo@gnu.org>
+
+ * emacs-lisp/chart.el:
+ * emacs-lisp/eieio-base.el:
+ * emacs-lisp/eieio-comp.el:
+ * emacs-lisp/eieio-custom.el:
+ * emacs-lisp/eieio-datadebug.el:
+ * emacs-lisp/eieio-opt.el:
+ * emacs-lisp/eieio-speedbar.el:
+ * emacs-lisp/eieio.el: New files.
+
2009-09-27 Vinicius Jose Latorre <viniciusjl@ig.com.br>
* whitespace.el (whitespace-trailing-regexp)
@@ -8197,7 +15585,7 @@
* textmodes/fill.el: Convert to utf-8 encoding.
(fill-french-nobreak-p): Remove redundant » and « inherited from our
- pre-unicode days.
+ pre-Unicode days.
* add-log.el (change-log-fill-forward-paragraph): New function.
(change-log-mode): Use it so fill-region DTRT.
@@ -8345,7 +15733,7 @@
indent buffer only if called interactively (Bug#4452).
2009-09-19 Juanma Barranquero <lekktu@gmail.com>
- Eli Zaretskii <eliz@gnu.org>
+ Eli Zaretskii <eliz@gnu.org>
This fixes bug#4197 (merged to bug#865, though not identical).
* server.el (server-auth-dir): Add docstring note about FAT32.
@@ -9162,7 +16550,7 @@
Don't call substitute-in-file-name on diary-file.
2009-09-03 Eduard Wiebe <usenet@pusto.de>
- Stefan Monnier <monnier@iro.umontreal.ca>
+ Stefan Monnier <monnier@iro.umontreal.ca>
* mail/footnote.el (footnote-prefix): Make it a defcustom.
(footnote-mode-map): Move initialization into the declaration.
@@ -10273,7 +17661,7 @@
* progmodes/hideshow.el (hs-special-modes-alist): Add js-mode entry.
2009-08-14 Daniel Colascione <dan.colascione@gmail.com>
- Karl Landstrom <karl.landstrom@brgeight.se>
+ Karl Landstrom <karl.landstrom@brgeight.se>
* progmodes/js.el: New file.
@@ -12040,7 +19428,7 @@
XZ is the successor to LZMA: <http://tukaani.org/xz/>
2009-06-22 Dmitry Dzhus <dima@sphinx.net.ru>
- Nick Roberts <nickrob@snap.net.nz>
+ Nick Roberts <nickrob@snap.net.nz>
* progmodes/gdb-mi.el: Pull further modified changes from Dmitry's
repository (http://sphinx.net.ru/hg/gdb-mi/).
@@ -12077,7 +19465,7 @@ See ChangeLog.14 for earlier changes.
;; coding: utf-8
;; End:
- Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+ Copyright (C) 2009, 2010 Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -12093,5 +19481,3 @@ See ChangeLog.14 for earlier changes.
You should have received a copy of the GNU General Public License
along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;; arch-tag: d3e45e38-19e2-49b6-8dc2-7cb26adcc5a1
diff --git a/lisp/ChangeLog.1 b/lisp/ChangeLog.1
index f5be5b6f1f8..6855c935746 100644
--- a/lisp/ChangeLog.1
+++ b/lisp/ChangeLog.1
@@ -173,7 +173,7 @@
1986-03-15 Bill Rozas (jinx@prep)
- * scheme.el: (scheme-zap-name) Uses expand-file-name to obtain an
+ * scheme.el (scheme-zap-name): Uses expand-file-name to obtain an
absolute pathname.
1986-03-15 Richard M. Stallman (rms@prep)
@@ -184,7 +184,7 @@
1986-03-13 Bill Rozas (jinx@prep)
- * scheme.el: (scheme-zap-name) change it back to fromedit.zap
+ * scheme.el (scheme-zap-name): Change it back to fromedit.zap
since that is where scheme expects it and it is too much work to
change scheme right now. This interface is obsolete anyway, but
some people (athena) still use it.
@@ -384,7 +384,7 @@
* info.el (Info-find-node):
Fix braino.
Also, allow abbreviations for node names.
- Info-tagify: insert tags in forward order so that
+ (Info-tagify): Insert tags in forward order so that
an abbrev finds the textually first possibility rather than the
last.
@@ -660,7 +660,7 @@
1985-12-27 Richard Mlynarik (mly@prep)
* view.el:
- Various: Fix cases of "view" => "View" which were missed. Damn.
+ Various: Fix cases of "view" => "View" which were missed. Damn.
1985-12-27 Richard M. Stallman (rms@prep)
@@ -990,7 +990,7 @@
* info.el:
(Info-select-node): Was searching unboundedly for "execute:".
(Info-follow-reference): Was called Info-footnote.
- Also, handle presence of spaces and newlines in ref names.
+ Also, handle presence of spaces and newlines in ref names.
(Info-extract-menu-node-name): Handle presence of spaces and
newlines in the node name.
(Info-menu): Handle presence of spaces and newlines in item
@@ -1021,8 +1021,6 @@
in the *compilation* buffer, thus allowing buffers to have local
compilation-error-regexp variables.
- (provide 'compile)
-
1985-12-05 Richard M. Stallman (rms@prep)
* files.el (recover-file):
@@ -1139,7 +1137,7 @@
1985-11-27 Richard Mlynarik (mly@prep)
- * rnews.el: (news-mode, news-set-mode-line):
+ * rnews.el (news-mode, news-set-mode-line):
Get rid of news-mode-group-string.
* rnews.el (news-unsubscribe-internal):
@@ -1465,7 +1463,7 @@
1985-10-28 Richard M. Stallman (rms@prep)
* rmail.el, rmailsum.el, rmailkwd.el, rmailmsc.el,
- rmailout.el, rmailedit.el:
+ * rmailout.el, rmailedit.el:
Install thoroughly rewritten rmail with many new features.
* debug.el (debug, debugger-mode):
@@ -1495,7 +1493,7 @@
* mouseinit.el
Delete this file. Put its contents in files
- term-bg.el, term-bgnv.el, term-bgrv.el, term-bbn.el
+ term-bg.el, term-bgnv.el, term-bgrv.el, term-bbn.el.
(Perhaps there should be a subdirectory emacs/lisp/term/ ??)
1985-10-23 Richard M. Stallman (rms@prep)
@@ -1616,7 +1614,7 @@
1985-10-17 Richard Mlynarik (mly@mit-prep)
- * rnews.el: (news-save-item-in-file)
+ * rnews.el (news-save-item-in-file):
Append to file, rather than overwriting.
* isearch.el
@@ -1915,7 +1913,7 @@
* texinfo.el:
Change syntax for @xref and @pxref to use braces.
- Change syntax for @node to read entire line
+ Change syntax for @node to read entire line.
(new function texinfo-format-parse-line-args for that).
Change paragraph-separate, etc., so only directives without
braces separate paragraphs. When formatting, discard all of the
@@ -2178,8 +2176,8 @@
"c-continued-statement-offset" as in the documentation and manual
* rmail.el (rmail-find):
- Hack default of last search string, hack reverse search
- (-ve prefix arg)
+ Hack default of last search string, hack reverse search.
+ (-ve prefix arg):
Make "-" be negative-argument
1985-07-23 Richard Mlynarik (mly@mit-prep)
@@ -2534,7 +2532,7 @@
* lisp-mode.el: First form of prog1 is distinguished.
- * loaddefs.el: autoload functions from chistory.el and echistory.el.
+ * loaddefs.el: Autoload functions from chistory.el and echistory.el.
* chistory.el:
New file containing two alternatives to `repeat-complex-command'
@@ -2590,7 +2588,7 @@
* ebuff-menu.el: Make M-C-v scroll-other-window instead of
scroll-down. Make M-v scroll-down.
- * ebuff-menu.el, echistory.el: Made them use electric.
+ * ebuff-menu.el, echistory.el: Made them use electric.
* electric.el:
New module for packages that retain control until some event
@@ -3097,10 +3095,10 @@
* sendmail.el, loaddefs.el
added send-mail-function; initially sendmail-send-it
- (also, mail-yank-ignored-headers had a typo)
+ (also, mail-yank-ignored-headers had a typo).
* rmail.el (rmail-get-new-mail, convert-to-babyl-format, ...)
- loaddefs.el
+ * loaddefs.el:
Remodularize inbox parsing. Add support(?) for mmdf inboxes.
Note that I can't seem to define definitive documentation of
what this format is; however the code installed seems to work
@@ -3167,7 +3165,7 @@
1985-05-16 K. Shane Hartman (shane@mit-prep)
* dired.el: Put dired-rename-file, dired-copy file-on keys. Make
- them change buffer if appropriate. Put dired-mark-backup-files,
+ them change buffer if appropriate. Put dired-mark-backup-files,
dired-mark-temp-files on keys. Eliminate possibility of looping
at last line in dired-repeat-over-filenames.
@@ -3196,53 +3194,56 @@
replace loop so that replacing continues after moving back to
previous.
- * add-log.el: add prefix arg to add-change-log-entry so will
+ * add-log.el: Add prefix arg to add-change-log-entry so will
prompt for information if desired. If there is an entry for today,
make sure login-name is same before using it, else make new entry.
Use auto-fill-mode.
1985-05-12 Richard M. Stallman (rms@mit-prep)
- * lisp-mode.el: defined lisp-mode-commands, lisp-mode-variables.
+ * lisp-mode.el: Defined lisp-mode-commands, lisp-mode-variables.
Added external-lisp-mode.
Made doc strings mention mode hook variables.
- * shell.el: defined functions `lisp' and `inferior-lisp-mode'.
+ * shell.el: Defined functions `lisp' and `inferior-lisp-mode'.
Renamed shell-send-defun... to lisp-send-defun...
and made them use process "lisp", buffer *lisp*.
- * text-mode.el: made indented-text-mode not call text-mode.
+ * text-mode.el: Made indented-text-mode not call text-mode.
Made doc strings mention mode hook variables.
* c-mode.el: Made doc strings mention mode hook variables.
- * add-log.el
+ * add-log.el:
Change format used for change log entries.
Select indented-text-mode for the change log file.
1985-05-12 K. Shane Hartman (shane@mit-ajax)
- simple.el: suppress matching close paren if preceded
+
+ * simple.el: Suppress matching close paren if preceded
by char syntax \.
- mim-mode.el: flush private paren blinker in favor of default.
- add-log.el: change mode-string to mode-name so reflected in
+ * mim-mode.el: Flush private paren blinker in favor of default.
+ * add-log.el: Change mode-string to mode-name so reflected in
mode-line. change \\W to \\sW when looking for place to add.
1985-05-12 Richard M. Stallman (rms@mit-prep)
- simple.el: modified open-line to insert newlines before
+
+ * simple.el: Modified open-line to insert newlines before
an existing one before dot. This makes better redisplay.
- dired.el: Installed Shane's changes that allow user to choose
+ * dired.el: Installed Shane's changes that allow user to choose
switches to use.
1985-05-11 Richard M. Stallman (rms@mit-prep)
- rmail.el: if given file name as argument,
+
+ * rmail.el: If given file name as argument,
correctly displays one message of that file
but does not try to get new mail.
- simple.el: Fix what-line bug: line # too high by 1 if not at bol.
+ * simple.el: Fix what-line bug: line # too high by 1 if not at bol.
Put in blink-matching-paren-distance,
and check for wrong kinds of parens matching.
- time.el: Put in display-time-day-and-date flag,
+ * time.el: Put in display-time-day-and-date flag,
to display day and date in addition to the time.
- startup.el: Call lisp-interaction-mode-hook if defined.
+ * startup.el: Call lisp-interaction-mode-hook if defined.
Set current buffer variables from defaults
in case user's init file has changed them.
diff --git a/lisp/ChangeLog.10 b/lisp/ChangeLog.10
index 50b82e13a15..32c3688f935 100644
--- a/lisp/ChangeLog.10
+++ b/lisp/ChangeLog.10
@@ -1357,7 +1357,7 @@
2003-06-10 Rajesh Vaidheeswarran <rv@gnu.org>
- * whitespace.el (whitespace-version): Bump to 3.3
+ * whitespace.el (whitespace-version): Bump to 3.3.
(whitespace-cleanup): Respect user preference for silence
* whitespace.el: Remove :tag in commentary :link. Remove empty
@@ -1645,7 +1645,7 @@
(bibtex-version): Remove support for bug reporting.
(bibtex-field-delimiters, bibtex-entry-delimiters)
(bibtex-sort-ignore-string-entries, bibtex-maintain-sorted-entries)
- Replace make-variable-buffer-local by make-local-variable for
+ Replace make-variable-buffer-local by make-local-variable.
(bibtex-entry-format): New tag `required-fields'.
(bibtex-maintain-sorted-entries): New var.
(bibtex-sort-entry-class, bibtex-sort-entry-class-alist): New vars.
@@ -4069,9 +4069,9 @@
(ccl-encode-mule-utf-16-le-with-signature)
(ccl-encode-mule-utf-16-be-with-signature): New CCL programs.
(mule-utf-16-post-read-conversion): New function.
- (mule-utf-16-le-with-signature, mule-utf-16-be-with-signature),
+ (mule-utf-16-le-with-signature, mule-utf-16-be-with-signature)
(mule-utf-16): New coding systems.
- (utf-16-le-with-signature, utf-16-be-with-signature),
+ (utf-16-le-with-signature, utf-16-be-with-signature)
(utf-16): Aliases of the above coding systems.
2003-04-08 Martin Stjernholm <bug-cc-mode@gnu.org>
@@ -4109,7 +4109,7 @@
Other cleanups.
Command line option --no-desktop introduced.
(desktop-read): Record buffers in the desktop file in
- the same order as that in the buffer list,
+ the same order as that in the buffer list.
(desktop-save): Put buffers in the order given in desktop file,
regardless of what handlers do.
(desktop-file-version): New variable. Version number of desktop
@@ -4757,7 +4757,7 @@
* files.el (insert-directory): Decode by what specified.
* language/japan-util.el (setup-japanese-environment-internal):
- By defalt, use japanese-iso-8bit for file names, and prefer
+ By default, use japanese-iso-8bit for file names, and prefer
japanese-shift-jis on DOS and Windows.
* international/quail.el (quail-show-guidance-buf): Make the quail
@@ -7684,7 +7684,7 @@
* gdb-ui.el : Remove inappropriate key-bindings.
(gdb-info-breakpoints-custom, gdb-goto-bp-this-line):
Parse correctly when breakpoint has no line number.
- (def-gdb-auto-update-handler, gdb-info-locals-handler),
+ (def-gdb-auto-update-handler, gdb-info-locals-handler)
(gdb-display-end): Avoid using insert-buffer.
(gdb-frames-select-by-mouse): Rename gdb-frames-mouse-select.
@@ -20177,10 +20177,10 @@
2002-01-05 Andre Spiegel <spiegel@gnu.org>
- * vc.el (vc-branch-part): Return nil if there's no `.'
+ * vc.el (vc-branch-part): Return nil if there's no `.'.
(vc-default-previous-version): Renamed from vc-previous-version.
New args BACKEND and FILE. Return nil for revision numbers
- without a `.'
+ without a `.'.
(vc-version-diff): Call vc-BACKEND-previous-version.
(vc-steal-lock): Steal lock before composing mail, so that no mail
is sent when the stealing goes wrong. And we'll actually see the
@@ -21636,7 +21636,7 @@
2001-11-26 Sam Steingold <sds@gnu.org>
* frame.el (show-trailing-whitespace): Remove :set argument (the
- value was essentially identical to the defalt).
+ value was essentially identical to the default).
2001-11-26 Pavel Janík <Pavel@Janik.cz>
@@ -23253,11 +23253,11 @@
lambda expression.
(ps-mode-menu-main): Submenu with options on/off was replaced with
a toggle button.
- (ps-mode, ps-run-mode): Define with `define-derived-mode'
+ (ps-mode, ps-run-mode): Define with `define-derived-mode'.
(ps-mode): Autoload cookie added on same line as comment.
(ps-mode-tabkey, ps-mode-backward-delete-char):
(ps-mode-r-balance): Replace `delete-horizontal-space' and
- `indent-to' with `indent-line-to'
+ `indent-to' with `indent-line-to'.
(ps-mode-print-buffer, ps-mode-print-region): Use `funcall'
instead of `eval'.
(ps-mode-print-region): Use `with-temp-buffer'.
@@ -23464,7 +23464,7 @@
(vc-default-annotate-current-time): Added.
* vc-cvs.el (vc-cvs-annotate-difference): Removed to generic
- version in vc.el, with
+ version in vc.el.
(vc-cvs-annotate-current-time): Added, as override of default.
(vc-cvs-annotate-time): Added. Taken mostly from the (now removed)
`vc-cvs-annotate-difference'.
diff --git a/lisp/ChangeLog.11 b/lisp/ChangeLog.11
index 86bf9434fc9..5b9fa028a9d 100644
--- a/lisp/ChangeLog.11
+++ b/lisp/ChangeLog.11
@@ -84,7 +84,7 @@
2004-12-30 Andreas Leue <al@sphenon.de>
- * textmodes/artist.el (artist-version): 1.2.6
+ * textmodes/artist.el (artist-version): 1.2.6.
(artist-prev-next-op-alist): New variable.
(artist-select-next-op-in-list): New function.
(artist-select-prev-op-in-list): New function.
@@ -380,7 +380,7 @@
(calculator-radix-grouping-digits)
(calculator-radix-grouping-separator):
New defcustoms for the new radix grouping mode functionality.
- (calculator-mode-hook): Now used in electric mode too,
+ (calculator-mode-hook): Now used in electric mode too.
(calculator): Call it.
(calculator-mode-map): Some new keys.
(calculator-message): New function. Some new calls.
@@ -2000,7 +2000,7 @@
(math-rewrite, math-rewrite-phase): Replace variable expr by
declared variable.
(math-rewrite-heads-heads, math-rewrite-heads-skips)
- (math-rewrite-heads-blanks ): New variables.
+ (math-rewrite-heads-blanks): New variables.
(math-rewrite-heads, math-rewrite-heads-rec): Replace variables
heads, skips and blanks by declared variables.
(math-rwcomp-subst-old, math-rwcomp-subst-new)
@@ -2239,7 +2239,7 @@
(math-so-far, math-integ-expr, math-expr-parts, calc-low)
(calc-high, math-solve-var, math-solve-full, math-solve-vars)
(math-try-solve-sign, math-solve-b, math-solve-system-vv)
- (math-solve-res): New variables
+ (math-solve-res): New variables.
(math-derivative, calcFunc-deriv, calcFunc-tderiv)
(math-integral, math-replace-integral-parts)
(math-integrate-by-parts, calc-dump-integral-cache)
@@ -4692,7 +4692,7 @@
mark mode (to include the current match to region boundaries).
Push the search string to `query-replace-from-history-variable'.
Add prompt "Query replace regexp" for isearch-regexp.
- Add region beginning/end as last arguments of `perform-replace.'
+ Add region beginning/end as last arguments of `perform-replace'.
(isearch-query-replace-regexp): Replace code by the call to
`isearch-query-replace' with arg `t'.
@@ -9809,7 +9809,7 @@
(compile): Additional argument for interactive compiles like TeX.
- * progmodes/grep.el (kill-grep): Move here from compile.el
+ * progmodes/grep.el (kill-grep): Move here from compile.el.
(grep-error, grep-hit-face, grep-error-face)
(grep-mode-font-lock-keywords): New variables.
(grep-regexp-alist): Simplify regexp and add `binary' case.
@@ -10944,12 +10944,12 @@
(rsf-bbdb-auto-delete-spam-entries): Rename from
rmail-bbdb-auto-delete-spam-bbdb-entries. The cc: field is
scanned together with the recipients field for spam testing; Don't
- delete spam message if rmail-delete-after-output is non-nil;
+ delete spam message if rmail-delete-after-output is non-nil.
(rsf-check-field): New function, extracted from code in
rmail-spam-filter to ease addition of header fields like
- content-type:;
+ content-type:.
(message-content-type): New variable. The content-type: field was
- added also in defcustom of rsf-definitions-alist;
+ added also in defcustom of rsf-definitions-alist.
(rmail-spam-filter): Replace repeated test code for header fields
by calls to check-field; change the call to
rmail-output-to-rmail-file such that rmail-current-message stays
@@ -11474,7 +11474,7 @@
2003-12-29 Stuart Herring <herring@lanl.gov> (tiny change)
* comint.el (comint-watch-for-password-prompt): Pass `string' as
- arg to send-invisible
+ arg to send-invisible.
(send-invisible): Doc fix. The argument is now a prompt, not the
string to send.
(comint-read-noecho): Doc fix.
@@ -11494,7 +11494,7 @@
* net/zone-mode.el (zone-mode): Use write-file-functions, not
write-file-hooks.
-2003-12-29 Eric Hanchrow <offby1@blarg.net> (tiny change)
+2003-12-29 Eric Hanchrow <offby1@blarg.net>
* autorevert.el (auto-revert-interval): Doc fix.
@@ -11832,7 +11832,7 @@
(ido-saved-vc-hb): Rename from ido-saved-vc-mt. Uses changed.
(ido-no-final-slash): New defun.
(ido-make-prompt, ido-file-internal, ido-toggle-vc)
- (ido-read-file-name): ): Toggle VC checking via
+ (ido-read-file-name): Toggle VC checking via
vc-handled-backends instead of vc-master-templates.
(ido-file-internal): Handle ido-use-url-at-point and
ido-use-filename-at-point via code borrowed from ffap-guesser.
@@ -12922,7 +12922,7 @@
* emacs-lisp/tq.el (tq-create): Fix mixed up unquote style.
-2003-09-12 Eric Hanchrow <offby1@blarg.net> (tiny change)
+2003-09-12 Eric Hanchrow <offby1@blarg.net>
* dired.el (dired-mode-map): Fix typo.
@@ -12951,7 +12951,7 @@
Ensure that recentf correctly updates the menu bar.
* recentf.el (recentf-menu-path,recentf-menu-before): Doc fix.
(recentf-menu-bar): New function.
- (recentf-clear-data): Use it
+ (recentf-clear-data): Use it.
(recentf-update-menu): Likewise. Use easy-menu-add-item instead
of easy-menu-change.
@@ -13500,7 +13500,7 @@
(reftex-toc-split-windows-fraction): New option.
(reftex-recenter-toc-when-idle): Search *toc* window on all
visible frames.
- (reftex-toc): Additional parameter REUSE
+ (reftex-toc): Additional parameter REUSE.
(reftex-toc-recenter): Remember current frame. Call `reftex-toc'
with REUSE argument.
(reftex-recenter-toc-when-idle): Reset `current-prefix-arg' for
@@ -14153,7 +14153,7 @@
erroneously in previous version.
(bibtex-string-files): Docstring reflects new parsing scheme.
(bibtex-autokey-transcriptions): Merge some rewrite entries, fix
- docstring, add # as one of the chars to crush
+ docstring, add # as one of the chars to crush.
(bibtex-autokey-prefix-string, bibtex-autokey-names)
(bibtex-autokey-names-stretch, bibtex-autokey-additional-names)
(bibtex-autokey-name-change-strings)
@@ -14229,7 +14229,7 @@
preamble entries.
(bibtex-fill-field-bounds): New function.
(bibtex-fill-field): New command. Bound to fill-paragraph-function.
- (bibtex-fill-entry): Use bibtex-fill-field-bounds
+ (bibtex-fill-entry): Use bibtex-fill-field-bounds.
(bibtex-String): Use bibtex-strings. Always obey
bibtex-sort-ignore-string-entries.
diff --git a/lisp/ChangeLog.12 b/lisp/ChangeLog.12
index c242095fb07..b95219ab332 100644
--- a/lisp/ChangeLog.12
+++ b/lisp/ChangeLog.12
@@ -943,7 +943,7 @@
2007-03-20 Richard Stallman <rms@gnu.org>
* textmodes/ispell.el (ispell-call-process): New function.
- Defends against bad `default-directory.'
+ Defends against bad `default-directory'.
(ispell-check-version, ispell-find-aspell-dictionaries)
(ispell-get-aspell-config-value, lookup-words): Call it.
(ispell-call-process-region): New function.
@@ -1606,7 +1606,7 @@
(org-set-frame-title, org-show-reference)
(org-unhighlight-once, org-verify-change-for-undo): New functions.
(org-show-variable): Remove command.
- (org-add-log-maybe): New arguments STATE, FINDPOS
+ (org-add-log-maybe): New arguments STATE, FINDPOS.
(org-table-sort-lines): Rewrite from scratch.
(org-link-search): New argument AVOID-POS.
(org-print-icalendar-entries): Remove argument CATEGORY.
@@ -2528,7 +2528,7 @@
* files.el (find-alternate-file): Revert query message to Emacs 21
version.
-2007-01-20 Eric Hanchrow <offby1@blarg.net> (tiny change)
+2007-01-20 Eric Hanchrow <offby1@blarg.net>
* progmodes/cperl-mode.el (cperl-electric-keywords): Document in
the doc string how to use personal abbrevs without electric keywords.
@@ -2938,7 +2938,7 @@
2006-12-30 Jan Djärv <jan.h.d@swipnet.se>
- * scroll-bar.el (previous-scroll-bar-mode): New variable
+ * scroll-bar.el (previous-scroll-bar-mode): New variable.
(set-scroll-bar-mode): Set previous-scroll-bar-mode.
(scroll-bar-mode): Use previous-scroll-bar-mode if set.
@@ -5438,7 +5438,7 @@
(cperl-to-comment-or-eol): Do not call `cperl-update-syntaxification'
recursively.
Bound `next-single-property-change' via `point-max'.
- (cperl-unwind-to-safe): Bound likewise
+ (cperl-unwind-to-safe): Bound likewise.
(cperl-font-lock-fontify-region-function): Likewise.
(cperl-find-pods-heres): Mark as recursive for `cperl-to-comment-or-eol'
Initialization of `cperl-font-lock-multiline-start' could be
@@ -5480,7 +5480,7 @@
(cperl-calculate-indent): `char-after' could be nil...
(cperl-find-pods-heres): REx can start after "[" too.
Highlight (??{}) in RExen too.
- (cperl-maybe-white-and-comment-rex): New constant
+ (cperl-maybe-white-and-comment-rex): New constant.
(cperl-white-and-comment-rex): Likewise.
XXXX Not very efficient, but hard to make
better while keeping 1 group.
@@ -5526,7 +5526,7 @@
Syntax-mark a {}-part of (?{}) as "comment"
(it was the ()-part)
Better logic to distinguish what is what in REx
- (cperl-tips-faces): Document REx highlighting
+ (cperl-tips-faces): Document REx highlighting.
(cperl-praise): Mention REx syntax highlight etc.
After 5.17:
@@ -5566,7 +5566,7 @@
(cperl-indent-comment-at-column-0): New customization variable.
(cperl-comment-indent): Indentation after $#a would increase by 1.
(cperl-mode): Make `defun-prompt-regexp' grok BEGIN/END etc.
- (cperl-find-pods-heres): Mark CODE of s///e as `syntax-type' `multiline'
+ (cperl-find-pods-heres): Mark CODE of s///e as `syntax-type' `multiline'.
(cperl-at-end-of-expr): Would fail if @BAR=12 follows after ";".
(cperl-init-faces): If `cperl-highlight-variables-indiscriminately'
highlight $ in $foo too (UNTESTED).
@@ -5579,7 +5579,7 @@
(cperl-style-alist): Likewise.
(cperl-fix-line-spacing): Support `cperl-merge-trailing-else' being nil,
and `cperl-extra-newline-before-brace' etc
- being t
+ being t.
(cperl-indent-exp): Plans B and C to find continuation blocks even
if `cperl-extra-newline-before-brace' is t.
@@ -7296,7 +7296,7 @@
(gdb-stack-position): New variable.
(gdb-starting, gdb-exited): Reset gdb-stack-position to nil.
(gdb-frames-mode): Set gdb-stack-position to nil.
- Add to overlay-arrow-variable-list
+ Add to overlay-arrow-variable-list.
(gdb-reset): Delete gdb-stack-position from above list.
2006-08-14 Jan Djärv <jan.h.d@swipnet.se>
@@ -7459,7 +7459,7 @@
* avoid.el (mouse-avoidance-animating-pointer): New var.
(mouse-avoidance-nudge-mouse): Use it.
(mouse-avoidance-banish): Rename from mouse-avoidance-banish-hook.
- (mouse-avoidance-exile): Rename from mouse-avoidance-exile-hook
+ (mouse-avoidance-exile): Rename from mouse-avoidance-exile-hook.
(mouse-avoidance-fancy): Rename from mouse-avoidance-fancy-hook.
Don't activate if currently animating. All callers changed.
@@ -7791,7 +7791,7 @@
* textmodes/table.el: Add move-beginning-of-line and
move-end-of-line to Point Motion Only Group.
-2006-07-22 Eric Hanchrow <offby1@blarg.net> (tiny change)
+2006-07-22 Eric Hanchrow <offby1@blarg.net>
* progmodes/delphi.el (delphi-fill-comment): Use save-restriction.
@@ -8723,7 +8723,7 @@
* progmodes/gdb-ui.el (gdb-same-frame): New option.
(gud-old-arrow, gdb-frame-begin, gdb-printing): New variables.
(gdb-init-1): Initialise them.
- (gdb-starting): Reset gdb-printing
+ (gdb-starting): Reset gdb-printing.
(gdb-starting): Save value of gud-overlay-arrow-position.
(gdb-frame-begin): Set gdb-frame-begin, gdb-printing.
(gdb-stopped): Don't look for source if calling procedure e.g "p a ()".
@@ -9460,7 +9460,7 @@
links to BibTeX database entries..
(org-get-current-options, org-set-regexps-and-options):
Implement logging as a startup option.
- (org-store-link): Make sure context string is never empty
+ (org-store-link): Make sure context string is never empty.
(org-insert-link): Use relative path when possible.
(org-at-item-checklet-p): New function.
(org-shifttab, org-shiftmetaleft, org-shiftmetaright)
@@ -10197,7 +10197,7 @@
(gdb-init-1, gdb-post-prompt): ...and references to it.
(gdb-frame-handler): Strip directory name from filename if present.
- * progmodes/gud.el (gdb-force-update): Delete defvar
+ * progmodes/gud.el (gdb-force-update): Delete defvar.
(gud-speedbar-buttons): ...and references to it. Use window-start
to try to keep position in watch expression.
@@ -10246,7 +10246,7 @@
* diff-mode.el (diff-mode-shared-map): Don't bind M-W, M-U, M-C,
M-r, M-R, M-A, M-SPC or M-DEL.
- (diff-mode-map): diff-refine-hunk now on C-c C-w
+ (diff-mode-map): diff-refine-hunk now on C-c C-w.
(diff-mode-map): Bind C-c C-e, C-c C-n, C-c C-r, C-c C-u.
* help-mode.el (help-mode): view-exit-action calls delete-window
@@ -10862,7 +10862,7 @@
(org-edit-agenda-file-list, org-store-new-agenda-file-list)
(org-read-agenda-file-list): New functions.
(org-table-edit-field)
- (org-table-create-or-convert-from-region): New commands
+ (org-table-create-or-convert-from-region): New commands.
(org-table-toggle-vline-visibility): Command removed.
(org-table-convert-region): Made a command.
(orgtbl-delete-backward-char, orgtbl-delete-char): Remove commands.
@@ -10881,7 +10881,7 @@
Optional argument unrestricted means ignore any restrictions.
(org-install-agenda-files-menu): Find a buffer in Org-mode before
trying to modify the menu. Use generalized access to
- `org-agenda-files.'
+ `org-agenda-files'.
(org-agenda-list, org-todo-list, org-cycle-agenda-files)
(org-agenda-file-to-front, org-remove-file, org-diary)
(org-tags-view, org-export-icalendar-all-agenda-files)
@@ -13666,7 +13666,7 @@
(thumbs-resize-image): Rename from thumbs-resize-image-interactive.
Use increment argument to enlarge/shrink. Preserve point.
(thumbs-shrink-image): Rename from thumbs-resize-image-size-down.
- (thumbs-enlarge-image): Rename from thumbs-resize-image-size-up
+ (thumbs-enlarge-image): Rename from thumbs-resize-image-size-up.
(thumbs-show-thumbs-list): Set thumbs-buffer to current-buffer.
(thumbs-mark, thumbs-unmark): Preserve point.
(thumbs-modify-image): Keep old temp files and use to modify.
@@ -16160,7 +16160,7 @@
(c-after-statement-terminator-p): Adapt for virtual semicolons;
check more rigorously for "end of macro".
(c-back-over-illiterals, c-forward-over-illiterals): Adapt for
- virtual semicolons;
+ virtual semicolons.
(c-beginning-of-statement): Adapt for virtual semicolons; Separate
out the code for forward movement into ...
(c-end-of-statement): Now contains the code for forward movement,
@@ -19706,7 +19706,7 @@
(allout-mode): Use key-binding substitution in the docstring.
(allout-kill-line): Spell-out kill ring data structure mutation
instead of using byte-compiler-complaint-provoking `pop'.
- (allout-insert-listified): Use `insert' rather than `insert-string'
+ (allout-insert-listified): Use `insert' rather than `insert-string'.
(allout-toggle-current-subtree-encryption): Update docstring, adjust
to new gpp-based encryption, use new `allout-encrypted-topic-p'.
(allout-encrypt-string): Totally revamped vis new underlying
@@ -20588,7 +20588,7 @@
* progmodes/gud.el (gud-speedbar-menu-items): Use :visible
instead of :active.
-2005-10-08 Eric Hanchrow <offby1@blarg.net> (tiny change)
+2005-10-08 Eric Hanchrow <offby1@blarg.net>
* textmodes/ispell.el (ispell-check-version):
Ignore hyphen, and all that follows, in aspell's version text.
@@ -20757,13 +20757,13 @@
* progmodes/gdb-ui.el (gdb-info-breakpoints-custom):
Put `font-lock-function-name-face'.
(gdb-info-frames-custom): Put `font-lock-function-name-face'
- and `font-lock-variable-name-face'
+ and `font-lock-variable-name-face'.
(gdb-registers-font-lock-keywords): New font lock keywords definition.
(gdb-registers-mode): Use `gdb-registers-font-lock-keywords'.
(gdb-memory-font-lock-keywords): New font lock keywords definition.
(gdb-memory-mode): Use `gdb-memory-font-lock-keywords'.
(gdb-local-font-lock-keywords): New font lock keywords definition.
- (gdb-locals-mode): Use `gdb-local-font-lock-keywords'
+ (gdb-locals-mode): Use `gdb-local-font-lock-keywords'.
(gdb-threads-font-lock-keywords): New font lock keywords definition.
(gdb-threads-mode): Use `gdb-threads-font-lock-keywords'.
@@ -29165,7 +29165,7 @@
* jit-lock.el (jit-lock-stealth-time): Change default value to 16.
(jit-lock-stealth-nice): Change default value to 0.5.
-2005-04-23 Eric Hanchrow <offby1@blarg.net> (tiny change)
+2005-04-23 Eric Hanchrow <offby1@blarg.net>
* abbrev.el (write-abbrev-file): Write table entries in
alphabetical order by table name.
@@ -29352,7 +29352,7 @@
* loadhist.el (unload-feature): Update for new format of load-history.
Simplify the code.
- * mail/rmail.el (rmail-ignored-headers): Ignore more headers
+ * mail/rmail.el (rmail-ignored-headers): Ignore more headers.
(rmail-font-lock-keywords): Don't fontify the text of a citation.
* mail/sendmail.el (mail-font-lock-keywords):
@@ -29421,7 +29421,7 @@
(org-evaluate-time-range): Insert at point instead of directly
after time range.
(org-first-headline-recenter, org-subtree-end-visible-p)
- (org-optimize-window-after-visibility-change): New functions
+ (org-optimize-window-after-visibility-change): New functions.
(org-agenda-post-command-hook): Don't allow point at end of line,
to make sure it always hits the text properties.
(org-agenda-next-date-line, org-agenda-previous-date-line):
@@ -29603,13 +29603,13 @@
2005-04-11 Jan Djärv <jan.h.d@swipnet.se>
- * dired.el (dired-mode): Use dnd-* instead of x-dnd-*
+ * dired.el (dired-mode): Use dnd-* instead of x-dnd-*.
(dired-dnd-handle-local-file): Call dnd-get-local-file-name.
(dired-dnd-handle-file): Call dnd-get-local-file-uri.
* cus-edit.el (dnd): New group.
- * term/w32-win.el (dnd): Require dnd
+ * term/w32-win.el (dnd): Require dnd.
(w32-drag-n-drop): Call dnd-handle-one-url.
* x-dnd.el: Require dnd.
@@ -31918,7 +31918,7 @@
* progmodes/gdb-ui.el (gdb-var-update-handler)
(gdb-speedbar-timer-fn): Ensure speedbar updates with new values
- for watch expressions,
+ for watch expressions.
(gdb-var-create-handler): Don't set speedbar-update-flag.
(gdb-post-prompt): Simplify test for speedbar.
@@ -32509,7 +32509,7 @@
(bibtex-field-list, bibtex-find-crossref): Fix typos in error messages.
2005-01-24 Dan Nicolaescu <dann@ics.uci.edu>
- Juri Linkov <juri@jurta.org>
+ Juri Linkov <juri@jurta.org>
* textmodes/reftex-global.el (reftex-isearch-push-state-function)
(reftex-isearch-pop-state-function, reftex-isearch-isearch-search)
@@ -32781,14 +32781,14 @@
2005-01-15 James R. Van Zandt <jrvz@comcast.net> (tiny change)
* progmodes/sh-script.el: Code copied from make-mode.el
- with small changes,
+ with small changes.
(sh-mode-map): Bind C-c C-\.
(sh-backslash-column, sh-backslash-align): New variables.
(sh-backslash-region, sh-append-backslash): New functions.
2005-01-15 Sergey Poznyakoff <gray@Mirddin.farlep.net>
- * mail/rmail.el: Updated to work with movemail from GNU Mailutils
+ * mail/rmail.el: Updated to work with movemail from GNU Mailutils.
(rmail-pop-password, rmail-pop-password-required): Move to
rmail-obsolete group.
(rmail-set-pop-password): Rename to rmail-set-remote-password.
@@ -32892,7 +32892,7 @@
* textmodes/reftex-vars.el (reftex-cite-format-builtin):
Add optional arguments to most cite commands.
- (reftex-cite-cleanup-optional-args): New option
+ (reftex-cite-cleanup-optional-args): New option.
(reftex-cite-prompt-optional-args): New option.
(reftex-trust-label-prefix): New option.
diff --git a/lisp/ChangeLog.13 b/lisp/ChangeLog.13
index b561ba75ba5..d8ec37390f1 100644
--- a/lisp/ChangeLog.13
+++ b/lisp/ChangeLog.13
@@ -721,7 +721,7 @@
char-width-table. Don't make ethiopic and tibetan double column.
* textmodes/fill.el (fill-find-break-point-function-table):
- Don't set it up in defvar.
+ Don't set it up in defvar.
(fill-nospace-between-words-table): New variable.
(fill-delete-newlines): Check fill-nospace-between-words-table
instead of charset property nospace-between-words.
@@ -1498,7 +1498,7 @@
(ps-header-footer-string): Delete function.
(ps-encode-header-string-function): New variable.
(ps-generate-header-line): Call ps-encode-header-string-function.
- (ps-basic-plot-string-function): New variable
+ (ps-basic-plot-string-function): New variable.
(ps-begin-job): Set ps-basic-plot-string-function and
ps-encode-header-string-function. For setting up headers and
footers, don't use caches such as ps-rh-cache. Don't call
@@ -1588,7 +1588,7 @@
* international/mule.el (ctext-non-standard-encodings-alist):
Rename from non-standard-icccm-encodings-alist.
- (ctext-non-standard-encodings-regexp): New variable
+ (ctext-non-standard-encodings-regexp): New variable.
(ctext-post-read-conversion): Full rewrite.
(ctext-non-standard-designations-alist): Rename from
non-standard-designations-alist.
@@ -1872,8 +1872,8 @@
2008-02-01 Dave Love <fx@gnu.org>
* emacs-lisp/byte-opt.el (side-effect-free-fns):
- Add string-make-unibyte string-make-multibyte string-to-multibyte
- string-as-multibyte string-as-unibyte.
+ Add string-make-unibyte string-make-multibyte string-to-multibyte
+ string-as-multibyte string-as-unibyte.
2008-02-01 Dave Love <fx@gnu.org>
@@ -3983,7 +3983,7 @@
* ibuffer.el (ibuffer-mode): Fix typo in previous change.
2008-01-17 Vinicius Jose Latorre <viniciusjl@ig.com.br>
- Miles Bader <miles@gnu.org>
+ Miles Bader <miles@gnu.org>
* blank-mode.el: New file. Minor mode to visualize (HARD) SPACE,
TAB, NEWLINE. Miles Bader <miles@gnu.org> wrote the original code
@@ -5479,7 +5479,7 @@
(verilog-insert-indices): Escape braces in doc strings.
2007-12-08 Michael McNamara <mac@verilog.com>
- Wilson Snyder <wsnyder@wsnyder.org>
+ Wilson Snyder <wsnyder@wsnyder.org>
* progmodes/verilog-mode.el: New file.
@@ -7162,7 +7162,7 @@
* doc-view.el (doc-view-search-backward, doc-view-search):
Fix assignment to free variable bug.
-2007-11-16 Martin Pohlack <mp26@os.inf.tu-dresden.de> (tiny change)
+2007-11-16 Martin Pohlack <mp26@os.inf.tu-dresden.de>
* emulation/pc-select.el (pc-select-shifted-mark): New var.
(ensure-mark): Set it.
@@ -8210,7 +8210,7 @@
(allout-end-of-line): Preserve mark activation status when jumping.
(allout-open-topic): Account for opening after a child that
contains a hidden trailing newline. Preserve match data.
- Run allout-structure-added-hook
+ Run allout-structure-added-hook.
(allout-encrypt-decrypted): Preserve match data.
(allout-toggle-current-subtree-exposure): Add new interactive
function for toggle subtree exposure - suggested by tassilo.
@@ -9881,7 +9881,7 @@
(org-find-base-buffer-visiting): Catch the case that there is no
buffer visiting the file.
(org-property-or-variable-value): New function.
- (org-todo): Use `org-property-or-variable-value'
+ (org-todo): Use `org-property-or-variable-value'.
(org-agenda-compact-blocks): New option.
(org-prepare-agenda, org-agenda-list): Use `org-agenda-compact-blocks'.
(org-agenda-schedule, org-agenda-deadline):
@@ -10228,7 +10228,7 @@
* progmodes/cperl-mode.el: Merge upstream 5.23.
(cperl-where-am-i): Remove function.
- (cperl-backward-to-noncomment): Don't go too far when skipping POD/HEREs
+ (cperl-backward-to-noncomment): Don't go too far when skipping POD/HEREs.
(cperl-sniff-for-indent): De-invert [string] and [comment].
When looking for label, skip s:m:y:tr.
(cperl-indent-line): Likewise.
@@ -13485,7 +13485,7 @@
Use native Emacs functions, when appropriate.
2007-08-01 Dan Nicolaescu <dann@ics.uci.edu>
- Stefan Monnier <monnier@iro.umontreal.ca>
+ Stefan Monnier <monnier@iro.umontreal.ca>
* vc.el: Document new VC operation `extra-menu'.
@@ -13494,7 +13494,7 @@
* menu-bar.el (menu-bar-vc-filter): New function.
(menu-bar-tools-menu): Use it as a filter.
-2007-08-01 Eric Hanchrow <offby1@blarg.net> (tiny change)
+2007-08-01 Eric Hanchrow <offby1@blarg.net>
* ibuf-ext.el (ibuffer-mark-old-buffers): Docstring fix.
diff --git a/lisp/ChangeLog.14 b/lisp/ChangeLog.14
index 1a22e27a816..cfb6b84269c 100644
--- a/lisp/ChangeLog.14
+++ b/lisp/ChangeLog.14
@@ -1,3 +1,7 @@
+2009-02-07 Dave Love <fx@gnu.org>
+
+ * net/tls.el (open-tls-stream): Don't query killing process.
+
2009-06-21 Chong Yidong <cyd@stupidchicken.com>
* Branch for 23.1.
@@ -1029,7 +1033,7 @@
* paren.el (show-paren-function):
* simple.el (kill-forward-chars, kill-backward-chars):
- Use (+/- (point) N), instead of `forward-point'.
+ Use (+/- (point) N), instead of `forward-point'.
2009-03-19 Glenn Morris <rgm@gnu.org>
@@ -2144,7 +2148,7 @@
* emacs-lisp/find-func.el (find-library-name, find-library):
Doc fixes. (Part of bug#2270)
-2009-02-10 Eric Hanchrow <eric.hanchrow@gmail.com> (tiny change)
+2009-02-10 Eric Hanchrow <eric.hanchrow@gmail.com>
* env.el (getenv): When FRAME is non-nil, pass the frame environment
to `getenv-internal', not the frame. (Bug#2259)
@@ -3012,12 +3016,12 @@
Don't activate node nil. (Bug#1569)
2009-01-22 Paul Reilly <pmr@pajato.com>
- Henrik Enberg <enberg@printf.se>
- Alex Schroeder <alex@gnu.org>
- Chong Yidong <cyd@stupidchicken.com>
- Richard M Stallman <rms@gnu.org>
- Glenn Morris <rgm@gnu.org>
- Juanma Barranquero <lekktu@gmail.com>
+ Henrik Enberg <enberg@printf.se>
+ Alex Schroeder <alex@gnu.org>
+ Chong Yidong <cyd@stupidchicken.com>
+ Richard M Stallman <rms@gnu.org>
+ Glenn Morris <rgm@gnu.org>
+ Juanma Barranquero <lekktu@gmail.com>
* mail/rmail.el: Code implementing Rmail-mbox functionality.
(rmail-attribute-header, rmail-keyword-header)
@@ -4310,7 +4314,7 @@
was orderly adjusted, nil otherwise.
2008-12-12 Juanma Barranquero <lekktu@gmail.com>
- Stefan Monnier <monnier@iro.umontreal.ca>
+ Stefan Monnier <monnier@iro.umontreal.ca>
* server.el (server-sentinel): Uncomment code to delete connection file.
(server-start): Save the connection file in the server property list.
@@ -4369,7 +4373,7 @@
terminal variable assignment.
2008-12-10 Yukihiro Matsumoto <matz@ruby-lang.org>
- Nobuyoshi Nakada <nobu@ruby-lang.org>
+ Nobuyoshi Nakada <nobu@ruby-lang.org>
* progmodes/ruby-mode.el: New file.
@@ -5599,7 +5603,7 @@
New aliases, to satisfy `define-derived-mode' expectations.
2008-11-15 Glenn Morris <rgm@gnu.org>
- Martin Rudalics <rudalics@gmx.at>
+ Martin Rudalics <rudalics@gmx.at>
* emacs-lisp/find-func.el (find-function-advised-original): New.
(find-function-C-source, find-function-noselect):
@@ -6514,7 +6518,7 @@
(hl-line-unhighlight, global-hl-line-unhighlight): Use `when'.
(hl-line-sticky-flag): Remove spurious * in docstring.
-2008-10-14 Eric Hanchrow <offby1@blarg.net> (tiny change)
+2008-10-14 Eric Hanchrow <offby1@blarg.net>
* vc-git.el (vc-git-show-log-entry): Include the revision in the
search string.
@@ -8625,7 +8629,7 @@
2008-07-31 Alan Mackenzie <acm@muc.de>
- * progmodes/cc-mode.el (c-before-hack-hook): New function
+ * progmodes/cc-mode.el (c-before-hack-hook): New function.
(Top Level): Install c-before-hack-hook on
before-hack-local-variables-hook, rather than
c-postprocess-file-styles on hack-local-variables-hook.
@@ -10308,8 +10312,8 @@
(newsticker--treeview-propertize-tag): Show item title in tooltip.
2008-06-20 Martin Blais <blais@furius.ca>
- Stefan Merten <smerten@oekonux.de>
- David Goodger <goodger@python.org>
+ Stefan Merten <smerten@oekonux.de>
+ David Goodger <goodger@python.org>
* textmodes/rst.el: New file.
@@ -10627,7 +10631,7 @@
* term/linux.el (terminal-init-linux): Load t-mouse.
2008-06-13 Stefan Monnier <monnier@iro.umontreal.ca>
- Drew Adams <drew.adams@oracle.com>
+ Drew Adams <drew.adams@oracle.com>
* info.el (Info-breadcrumbs-depth): New var.
(Info-insert-breadcrumbs): New function.
@@ -18798,7 +18802,7 @@
for useful options.
2008-03-01 Dan Nicolaescu <dann@ics.uci.edu>
- Glenn Morris <rgm@gnu.org>
+ Glenn Morris <rgm@gnu.org>
* emacs-lisp/bytecomp.el (byte-recompile-directory)
(byte-compile-file, batch-byte-compile, batch-byte-compile-file):
diff --git a/lisp/ChangeLog.2 b/lisp/ChangeLog.2
index e3193944011..90c00dc6360 100644
--- a/lisp/ChangeLog.2
+++ b/lisp/ChangeLog.2
@@ -3717,9 +3717,9 @@
1986-08-07 Richard Mlynarik (mly@prep)
* rfc822.el, loaddefs.el, mail-utils.el:
- Hairy address parser, used only if mail-use-rfc822 is non-nil
+ Hairy address parser, used only if mail-use-rfc822 is non-nil.
(It is nil by default, so if one doesn't like or need the hair of
- this file, then one is never troubled by it)
+ this file, then one is never troubled by it.)
* disassemble.el, loaddefs.el:
Code from doug@csli.stanford.edu modified by mly.
diff --git a/lisp/ChangeLog.3 b/lisp/ChangeLog.3
index 26b872af9bb..4c36aa94509 100644
--- a/lisp/ChangeLog.3
+++ b/lisp/ChangeLog.3
@@ -172,7 +172,7 @@
Choose string< or < as predicate.
Reorder messages by exchanging them, with inhibit-quit bound.
(rmail-fetch-field): Start by widening.
- (rmail-sortable-date-strng): Deleted.
+ (rmail-sortable-date-string): Deleted.
(rmail-make-date-sortable): New function, used instead.
* paths.el (gnus-local-organization): Renamed from ...-your-...
@@ -2619,7 +2619,7 @@
* frame.el (frame-initialize): Fix error syntax.
(toggle-horizontal-scroll-bar): Likewise.
- (toggle-horizontal-scroll-bar): Renamed from set-horizontal-bar
+ (toggle-horizontal-scroll-bar): Renamed from set-horizontal-bar.
(toggle-vertical-scroll-bar): Likewise.
(toggle-auto-lower, toggle-auto-raise): Likewise.
(set-foreground-color, set-background-color):
@@ -10344,7 +10344,7 @@
(list-diary-entries, mark-diary-entries)
(include-other-diary-files, mark-included-diary-files):
Added the possibility of `shared diary files' with a recursive
- include mechanism like the C preprocessor
+ include mechanism like the C preprocessor.
(list-calendar-holidays): Eliminated the 'special class of holidays,
rewriting the entire mechanism to make it more general.
(calendar-holiday-function-float): Changed the 'float class of
@@ -12091,7 +12091,7 @@
1988-12-12 Richard Stallman (rms@mole.ai.mit.edu)
- * telnet.el (telnet-send-input): Save input in telnet-previous-input
+ * telnet.el (telnet-send-input): Save input in telnet-previous-input.
(telnet-mode): Make that var buffer-local.
(telnet-copy-last-input): New fn to yank that var; now on C-c C-y.
diff --git a/lisp/ChangeLog.5 b/lisp/ChangeLog.5
index cd36210f7fc..8cb0e343a1a 100644
--- a/lisp/ChangeLog.5
+++ b/lisp/ChangeLog.5
@@ -193,8 +193,8 @@
ispell-menu-map, ispell-menu-lucid, and ispell-menu-map-needed
so users can more easily modify and upgrade entries.
(ispell-dictionary-alist): Once more a single variable.
- (ispell-required-version): Documentation changes
- (ispell-skip-sgml): Documentation changes
+ (ispell-required-version): Documentation changes.
+ (ispell-skip-sgml): Documentation changes.
(ispell-command-loop): `mode-line-format' now shows misspelled word.
(ispell-message-text-end): Can now process postscript version 1.
(ispell-message-start-skip): New variable for block skips, set up for
@@ -584,7 +584,7 @@
19.28 and earlier and XEmacs 19.11 and earlier.
* ediff.el (ediff-patch-buffer): Now handles buffers that don't
visit any file.
- (ediff-windows): Renamed to ediff-windows-wordwise, added
+ (ediff-windows): Renamed to ediff-windows-wordwise.
(ediff-windows-linewise): New function.
Changed ediff-small/large-regions to ediff-regions-wordwise/linewise.
@@ -783,7 +783,7 @@
* mail-extr.el (mail-extr-all-letters-but-separators):
Reinstate \377, the bug in search.c is apparently gone.
- (mail-extr-first-letters): Add 8-bit characters
+ (mail-extr-first-letters): Add 8-bit characters.
(mail-extr-last-letters): Ditto.
* simple.el (indent-for-comment): Move to beginning of line only
@@ -889,7 +889,7 @@
(ada-end-stmt-re): Add "separate" body parts, "else", and
"package <Id> is".
(ada-subprogram-start-re): Add "entry", "protected" and
- "package body"
+ "package body".
(ada-indent-function): Handle "elsif" the same way as "if", added
"separate" for no indent.
(ada-get-indent-type): If "type ... is .." is followed by code on
@@ -1328,7 +1328,7 @@
ones the numbers of subexpressions to refer to.
(vc-cvs-status): New per-file property, only used in the CVS case.
(vc-cvs-status): New function.
- (vc-log-info): Adapted to new version of vc-parse-buffer
+ (vc-log-info): Adapted to new version of vc-parse-buffer.
(vc-fetch-properties): Adapted to new version of vc-parse-buffer.
Better search regexp for CVS latest version.
(vc-log-info): Search for branch version only in the RCS case,
@@ -1800,7 +1800,7 @@
(vc-consult-rcs-headers): New function.
(vc-branch-version): New per-file property, refers
to the RCS version selected by `rcs -b'.
- (vc-workfile-version): New function. Also new per-file property
+ (vc-workfile-version): New function. Also new per-file property.
(vc-consult-headers): New parameter variable.
(vc-mistrust-permissions): Default set to `nil'.
(vc-locking-user): Property is now cached. The other functions
@@ -2145,7 +2145,7 @@
1995-04-03 David Kågedal <davidk@lysator.liu.se>
* tempo.el (tempo-insert):
- Added the P tag and modified the s tag accordingly
+ Added the P tag and modified the s tag accordingly.
(tempo-insert-named): Checks for valid name, insert mark otherwise.
* tempo.el (tempo-dolist): Changed (cadr ...) to (car (cdr ...)).
@@ -2457,7 +2457,7 @@
(enriched-delq-1, enriched-make-list-uniq)
(enriched-make-relatively-unique, enriched-common-tail)
(enriched-reorder, enriched-insert-annotations)
- (enriched-loc-annotations, enriched-annotate-change
+ (enriched-loc-annotations, enriched-annotate-change)
(enriched-encode-unknown): Move to format.el. Names changed.
(enriched-display-table): Copy standard table if there is one,
@@ -3365,7 +3365,7 @@
(ispell-command-loop): Properly adjust screen with different settings
of ispell-choices-win-default-height.
(check-ispell-version): Use fundamental-mode as default-major-mode.
- (ispell-change-dictionary): Remove unnecessary process kills
+ (ispell-change-dictionary): Remove unnecessary process kills.
(ispell-region): Fold sgml support in with tib checking.
(ispell-message): Skips checking of forwarded messages.
@@ -3526,7 +3526,7 @@
1995-02-02 Richard Stallman <rms@pogo.gnu.ai.mit.edu>
- * c-mode.el (c-mode-map): No binding for c-fill-paragraph
+ * c-mode.el (c-mode-map): No binding for c-fill-paragraph.
(c-fill-paragraph): Return t.
(c-mode): Put c-fill-paragraph in fill-paragraph-function.
@@ -3770,7 +3770,7 @@
* tempo.el (tempo-insert-template): Quoted transient-mark-mode
Expansion around region now puts point at the first mark.
- * tempo.el (tempo-region-start, tempo-region-stop): New variables
+ * tempo.el (tempo-region-start, tempo-region-stop): New variables.
(tempo-insert-template, tempo-insert): Don't affect the
mark. Check for Transient Mark mode.
@@ -3965,7 +3965,7 @@
Keybinding for bold-italic changed from M-g o to M-g l; M-g o is
now "other".
(facemenu-justification-menu, facemenu-indentation-menu):
- New submenus, moved from enriched.el
+ New submenus, moved from enriched.el.
(list-colors-display, facemenu-color-equal): New functions.
(facemenu-menu): Added "Display Faces" item.
(facemenu-new-faces-at-end): New variable.
@@ -4554,18 +4554,18 @@
reference keys before they are used.
(bibtex-generate-autokey, bibtex-clean-entry): New function to
generate an autokey if necessary.
- (bibtex-autokey-names, bibtex-autokey-name-change-strings,
- bibtex-autokey-name-length, bibtex-autokey-name-separator,
- bibtex-autokey-year-length, bibtex-autokey-titlewords,
- bibtex-autokey-title-terminators,
- bibtex-autokey-titlewords-stretch,
- bibtex-autokey-titleword-first-ignore,
- bibtex-autokey-titleword-abbrevs,
- bibtex-autokey-titleword-change-strings,
- bibtex-autokey-titleword-length,
- bibtex-autokey-titleword-separator,
- bibtex-autokey-name-year-separator,
- bibtex-autokey-year-title-separator): New variables related to
+ (bibtex-autokey-names, bibtex-autokey-name-change-strings)
+ (bibtex-autokey-name-length, bibtex-autokey-name-separator)
+ (bibtex-autokey-year-length, bibtex-autokey-titlewords)
+ (bibtex-autokey-title-terminators)
+ (bibtex-autokey-titlewords-stretch)
+ (bibtex-autokey-titleword-first-ignore)
+ (bibtex-autokey-titleword-abbrevs)
+ (bibtex-autokey-titleword-change-strings)
+ (bibtex-autokey-titleword-length)
+ (bibtex-autokey-titleword-separator)
+ (bibtex-autokey-name-year-separator)
+ (bibtex-autokey-year-title-separator): New variables related to
bibtex-generate-autokey.
(bibtex-find-entry-location): Optional second parameter maybedup
to tell it that entering a duplicate entry isn't to report by an
@@ -4591,14 +4591,14 @@
(validate-bibtex-buffer): Completely rewritten to validate, if
buffer is syntactically correct.
(find-bibtex-duplicates): Moved into validate-bibtex-buffer.
- (ispell-abstract, bibtex-ispell-abstract, ispell-bibtex-entry,
- bibtex-ispell-entry, beginning-of-bibtex-entry,
- bibtex-beginning-of-entry, end-of-bibtex-entry,
- bibtex-end-of-entry, hide-bibtex-entry-bodies,
- bibtex-hide-entry-bodies, narrow-to-bibtex-entry,
- bibtex-narrow-to-entry, sort-bibtex-entries, bibtex-sort-entries,
- validate-bibtex-buffer, bibtex-validate-buffer,
- find-bibtex-entry-location, bibtex-find-entry-location): All
+ (ispell-abstract, bibtex-ispell-abstract, ispell-bibtex-entry)
+ (bibtex-ispell-entry, beginning-of-bibtex-entry)
+ (bibtex-beginning-of-entry, end-of-bibtex-entry)
+ (bibtex-end-of-entry, hide-bibtex-entry-bodies)
+ (bibtex-hide-entry-bodies, narrow-to-bibtex-entry)
+ (bibtex-narrow-to-entry, sort-bibtex-entries, bibtex-sort-entries)
+ (validate-bibtex-buffer, bibtex-validate-buffer)
+ (find-bibtex-entry-location, bibtex-find-entry-location): All
interactive functions are renamed, so that any interface function
begins with "bibtex-". Mapping:
ispell-abstract --> bibtex-ispell-abstract
@@ -4610,8 +4610,8 @@
sort-bibtex-entries --> bibtex-sort-entries
validate-bibtex-buffer --> bibtex-validate-buffer
find-bibtex-entry-location --> bibtex-find-entry-location
- (bibtex-maintain-sorted-entries,
- bibtex-sort-ignore-string-entries): Default is now t.
+ (bibtex-maintain-sorted-entries)
+ (bibtex-sort-ignore-string-entries): Default is now t.
(bibtex-complete-string): String list is built from additional
string list bibtex-predefined-string and current strings in file.
(string-equalp): Deleted and substituted by string-equal.
@@ -4633,8 +4633,8 @@
(bibtex-current-entry-label, put-string-on-kill-ring): Deleted
(AUCTeX provides all the functionality needed for citation
completion).
- (bibtex-enclosing-reference, bibtex-pop-previous, bibtex-pop-next,
- bibtex-clean-entry): Hacked for speed (bibtex-pop-previous and
+ (bibtex-enclosing-reference, bibtex-pop-previous, bibtex-pop-next)
+ (bibtex-clean-entry): Hacked for speed (bibtex-pop-previous and
bibtex-pop-next were to slow for larger BibTeX files).
(bibtex-pop-previous, bibtex-pop-next): Delimiters from previous
or next entry are changed to actual delimiters if necessary.
@@ -4657,7 +4657,7 @@
bibtex-pop-next didn't work, probably due to a bug in
re-search-forward).
(several functions): Added support for {} as field delimiters
- (better than '"' for accented characters.
+ (better than '"' for accented characters).
(bibtex-clean-entry): If optional field crossref is empty or
missing, former optional fields (if bibtex-include-OPTcrossref was
t) are necessary again. bibtex-clean-entry complains if they are
@@ -4825,8 +4825,8 @@
1994-12-09 Ken Stevens <stevensk@afit.af.mil>
* ispell.el: Added ispell-offset for version consistency.
- (ispell-dictionary-alist): Updated dictionaries & better match defaults
- (ispell-alternate-dictionary): Added /usr/shar path
+ (ispell-dictionary-alist): Updated dictionaries & better match defaults.
+ (ispell-alternate-dictionary): Added /usr/shar path.
(ispell-menu-map-needed): Redo changes that made this incompatible
with earlier versions of Emacs19.
(ispell-required-version): Changed to assure version 3.1.12 accessed.
@@ -6112,7 +6112,7 @@
1994-10-07 Richard Stallman <rms@mole.gnu.ai.mit.edu>
* mouse.el (mouse-major-mode-menu): New function, on C-mouse-3.
- (mouse-major-mode-menu-1): New function
+ (mouse-major-mode-menu-1): New function.
(mouse-set-font): Move it to C-mouse-2.
* font-lock.el (font-lock-defaults-alist): Delete most modes--all
@@ -6534,7 +6534,7 @@
* cc-mode.el (c-progress-info, c-progress-init)
(c-progress-update, c-progress-fini):
- New vars/defuns for better long indentation progress reporting
+ New vars/defuns for better long indentation progress reporting.
(c-indent-exp, c-indent-region): Use them.
* cc-mode.el (c-guess-basic-syntax):
@@ -6542,7 +6542,7 @@
find proper relpos of an arglist-cont.
* cc-mode.el (c-offset-alist-default):
- statement-case-open default offset is zero
+ statement-case-open default offset is zero.
(c-skip-case-statement-forward): New function.
(c-guess-basic-syntax): CASE 15: use c-skip-case-statement-forward in
proper places to find the real relpos of statement's inside switch
@@ -7051,7 +7051,7 @@
* ediff.el (ediff-toggle-read-only, ediff-patch-file): Check out
version controlled files before their buffers are modified.
(ediff-local-checkout-flag, ediff-toggle-read-only-function):
- New variables.
+ New variables.
* ediff.el (ediff-find-file, ediff-patch-file): Were getting
confused by symbolic links. Fixed.
@@ -8050,7 +8050,7 @@
1994-07-23 enami tsugutomo <enami@sys.ptg.sony.co.jp>
* lisp/add-log.el (add-log-current-defun): Skip doc string
- correctly even if it ends with line that starts space.
+ correctly even if it ends with line that starts space.
1994-07-22 Ed Reingold <reingold@albert.gnu.ai.mit.edu>
@@ -8795,9 +8795,9 @@
`gnus-uu-asynchronous' variable set.
(gnus-uu-ctl-map): Removed the keystrokes `C-c C-v C-h' and
`C-c C-v h' from the keymap.
- (gnus-uu-decode-and-view-all-articles,
- (gnus-uu-decode-and-view-all-unread-articles,
- (gnus-uu-decode-and-save-all-unread-articles,
+ (gnus-uu-decode-and-view-all-articles)
+ (gnus-uu-decode-and-view-all-unread-articles)
+ (gnus-uu-decode-and-save-all-unread-articles)
(gnus-uu-decode-and-save-all-articles): Accept prefix arg for # files.
(gnus-uu-uustrip-article-as): Waits for uudecode to finish before
further treatment of the resulting files.
@@ -9194,11 +9194,11 @@
* solar.el (solar-sunrise, solar-sunset): Fix doc string.
(solar-time-string): Rewritten.
(solar-adj-time-for-dst): New function.
- (solar-sunrise-sunset, diary-sabbath-candles,
- solar-equinoxes-solstices): Revised to use the rewritten and new fcns.
+ (solar-sunrise-sunset, diary-sabbath-candles)
+ (solar-equinoxes-solstices): Revised to use the rewritten and new fcns.
* calendar.el (solar-holidays): Revised to use the rewritten and
- new fcns.
+ new fcns.
* lunar.el (lunar-phase): Revised to use the rewritten and new fcns.
diff --git a/lisp/ChangeLog.6 b/lisp/ChangeLog.6
index 2ba61dc516e..e5bd7fa9d27 100644
--- a/lisp/ChangeLog.6
+++ b/lisp/ChangeLog.6
@@ -1420,7 +1420,7 @@
Added default constants.
(simula-emacs-features): New constant to hold information
on which flavor if emacs is running (from cc-mode.el).
- (simula-mode-menu): Menu definition for Lucid Emacs
+ (simula-mode-menu): Menu definition for Lucid Emacs.
(simula-mode-map): Bound new command simula-indent-exp to C-M-q
and added lots of commands to [menu-bar].
(simula-popup-menu): New function for Lucid menus.
@@ -1577,7 +1577,7 @@
(gomoku-winning-qtuple-beg, gomoku-winning-qtuple-end)
(gomoku-winning-qtuple-dx, gomoku-winning-qtuple-dy): Pseudo variables
only used for non-functional argument passing deleted.
- (gomoku-cross-winning-qtuple): Accordingly deleted function and
+ (gomoku-cross-winning-qtuple): Accordingly deleted function.
(gomoku-check-filled-qtuple): Accordingly adapted.
(gomoku-cross-qtuple): Don't be confused by tabs.
(gomoku-move-down, gomoku-move-up): Simplified because point is always
@@ -2455,7 +2455,7 @@
* ediff-init.el (ediff-hide-face): New function.
(ediff-collect-diffs-metajob): Fixed.
- (ediff-check-for-cl-seq): Function deleted
+ (ediff-check-for-cl-seq): Function deleted.
(ediff-abbreviate-file-name): Now a defun.
(ediff-has-face-support-p): New function. Ediff now supports
faces whenever possible.
@@ -2475,7 +2475,7 @@
(run-ediff-from-cvs-buffer): New function. Moved all
version-control-related stuff to a new file, ediff-vers.el.
- * ediff-util.el (ediff-save-buffer-in-file): New function
+ * ediff-util.el (ediff-save-buffer-in-file): New function.
(ediff-visible-region): No longer narrows the merge buffer.
(ediff-status-info): Now tells if we are focusing on regions where
both buffers differ from the ancestor.
@@ -3687,7 +3687,7 @@
When changing the environment, avoid need for setenv.
1996-01-05 Karl Eichwalder <ke@ke.Central.DE>
- Karl Fogel <kfogel@floss.red-bean.com>
+ Karl Fogel <kfogel@floss.red-bean.com>
* bookmark.el: "cyclic.com" addresses changed to "red-bean.com".
(bookmark-bmenu-mode-map): Don't bind C-k.
@@ -5837,7 +5837,7 @@
1995-10-09 Roland McGrath <roland@churchy.gnu.ai.mit.edu>
* etags.el (tags-table-check-computed-list): Map
- tags-expand-table-name over lists of included tables.
+ tags-expand-table-name over lists of included tables.
1995-10-09 Erik Naggum <erik@naggum.no>
@@ -5884,7 +5884,7 @@
* ediff-meta.el: New file.
* ediff-hook.el: New file.
- * ediff.el: Moved menubar definitions to a new file, ediff-hook.el
+ * ediff.el: Moved menubar definitions to a new file, ediff-hook.el.
(ediff-files, ediff-merge-files): Better file-name defaults.
(ediff-split-string): New function.
(ediff-exec-process): Now handles diff args separated by space.
@@ -6855,11 +6855,11 @@
1995-08-15 Daniel Pfeiffer <Daniel.Pfeiffer@Informatik.START.dbp.de>
- * skeleton.el (skeleton-pair-insert-maybe): Plain insert in Ovwrt mode
+ * skeleton.el (skeleton-pair-insert-maybe): Plain insert in Ovwrt mode.
(skeleton-insert): If skeleton doesn't fit in window, put beginning
at top before going to _ point.
(skeleton-internal-list): Rewritten so that resume: sections pertain
- only to inferior skeletons and make str available there
+ only to inferior skeletons and make str available there.
(skeleton-read): Don't quit and remove partial skeleton when empty
string entered for outer iterator. Added implicit argument `input'.
(define-skeleton, skeleton-insert, skeleton-internal-list): Use `x
@@ -7301,7 +7301,7 @@
1995-07-22 Daniel Pfeiffer <Daniel.Pfeiffer@Informatik.START.dbp.de>
* apropos.el: Add latest changes of old library and some more.
- (apropos): Only show unbound symbols when do-all
+ (apropos): Only show unbound symbols when do-all.
(apropos-documentation-check-elc-file): New copied function.
(apropos-command): Also use `apropos-do-all' when called as function.
(apropos-print-doc): Renamed from `apropos-print-documentation', i
@@ -7632,7 +7632,7 @@
(apropos-use-faces, apropos-local-map): New variables.
(apropos-command): New name for `command-apropos' no longer in help.el.
(apropos-value): New command.
- (apropos-documentation): New name for `super-apropos'
+ (apropos-documentation): New name for `super-apropos'.
(apropos-follow, apropos-mouse-follow): New commands for hypertext.
(apropos-describe-plist): New function.
@@ -7644,8 +7644,8 @@
* skeleton.el: Partly rewritten and extended.
(skeleton-filter, skeleton-untabify, skeleton-further-elements)
- (skeleton-abbrev-cleanup): New variables
- (skeleton-proxy, skeleton-abbrev-cleanup): New functions
+ (skeleton-abbrev-cleanup): New variables.
+ (skeleton-proxy, skeleton-abbrev-cleanup): New functions.
(skeleton-insert): Sublanguage element < must now be handled via
`skeleton-further-elements' (used only in sh-script and ada). Lisp
expressions can be quoted to ignore the return value.
@@ -7798,7 +7798,7 @@
1995-06-29 David M. Smith <D.M.Smith@lancaster.ac.uk>
- * ielm.el (ielm-font-lock-keywords): New variable
+ * ielm.el (ielm-font-lock-keywords): New variable.
(inferior-emacs-lisp-mode): Use it for font-lock support
1995-06-29 Bryan O'Sullivan <bos@Eng.Sun.COM>
diff --git a/lisp/ChangeLog.7 b/lisp/ChangeLog.7
index cc813b263c0..c68d02bc3d2 100644
--- a/lisp/ChangeLog.7
+++ b/lisp/ChangeLog.7
@@ -2749,7 +2749,7 @@
* abbrev.el: Likewise.
1998-05-26 Emilio Lopes <Emilio.Lopes@Physik.TU-Muenchen.DE>
- Karl Fogel <kfogel@red-bean.com>
+ Karl Fogel <kfogel@red-bean.com>
* bookmark.el: Changes so bookmark list mode works with Info:
(bookmark-jump-noselect): Use an inner save-window-excursion.
@@ -7738,7 +7738,7 @@
1997-12-09 Kenichi HANDA <handa@nora.etl.go.jp>
* language/korea-util.el (setup-korean-environment):
- Bind C-f9 (intead of C-f10) to quail-hangul-switch-symbol-ksc.
+ Bind C-f9 (instead of C-f10) to quail-hangul-switch-symbol-ksc.
* language/korean.el: Documentation for "Korean" language
environment adjusted for the above change.
diff --git a/lisp/ChangeLog.8 b/lisp/ChangeLog.8
index d14bf04a56b..6127667ac7e 100644
--- a/lisp/ChangeLog.8
+++ b/lisp/ChangeLog.8
@@ -104,7 +104,7 @@
version numbering regexp list
change-log-version-number-regexp-list.
(change-log-find-version): Renamed to
- change-log-version-number-search
+ change-log-version-number-search.
(add-log-file-name-function): New.
(change-log-search-vc-number): Added END parameter. Added doc
string to function.
@@ -338,7 +338,7 @@
1999-12-15 Carsten Dominik <dominik@astro.uva.nl>
* textmodes/reftex.el (reftex-compile-variables): Respect new
- structure of `reftex-index-macro'
+ structure of `reftex-index-macro'.
(reftex-compile-variables): Use the changed structure of
`reftex-label-alist'.
@@ -448,7 +448,7 @@
ps-mule-prepare-cmpchar-font): Deleted.
(ps-mule-string-encoding): New arg NO-SETFONT.
(ps-mule-bitmap-prologue): In Postscript code of BuildGlyphCommon,
- check Composing, not Cmpchar
+ check Composing, not Cmpchar.
(ps-mule-initialize): Set ps-mule-composition-prologue-generated
to nil.
(ps-mule-begin-job): Check existence of new composition.
@@ -978,7 +978,7 @@
(font-lock-add-keywords): Rename `major-mode' into `mode'.
(font-lock-remove-keywords): Added a dummy `mode' argument for
potential future support.
- (font-lock-fontify-anchored-keywords,
+ (font-lock-fontify-anchored-keywords)
(font-lock-fontify-keywords-region): Only handle multiline strings
if necessary (avoids a pathological behavior in (f.ex) diff-mode).
@@ -1603,7 +1603,7 @@
the new backquote syntax.
(smbclient-program, smbclient-program-options)
(smbclient-prompt-regexp, smbclient-font-lock-keywords): New
- variables
+ variables.
(smbclient, smbclient-list-shares): New functions
1999-11-12 Sam Steingold <sds@ksp.com>
@@ -1858,7 +1858,7 @@
* whitespace.el: Test for existence of `defcustom' and `defgroup'
using fboundp instead of assuming that these are not present in
particular flavors of emacs.
- (whitespace-version): Update to 2.8
+ (whitespace-version): Update to 2.8.
(whitespace-display-in-modeline): Add custom variable to control
displaying the whitespace errors on the modeline based on
suggestion from <klaus.berndl@sdm.de>
@@ -2136,17 +2136,17 @@
1999-10-19 Peter Kleiweg <kleiweg@let.rug.nl>
* progmodes/ps-mode.el (ps-mode-print-function): Fix default
- value: \"lpr\" changed to "lpr"
- (ps-mode-version): New constant
- (ps-mode-show-version): New function, added key in ps-mode-map
- (ps-run-messages): Removed
+ value: \"lpr\" changed to "lpr".
+ (ps-mode-version): New constant.
+ (ps-mode-show-version): New function, added key in ps-mode-map.
+ (ps-run-messages): Removed.
(ps-run-font-lock-keywords-2): New defcustom variable replacing
ps-run-messages. These keywords now include the value of
ps-run-prompt, making its fontification customizable.
(ps-run-init): Removed \\n from docstring, it is now added when
- the value is used
+ the value is used.
(ps-run-font-lock-keywords-1): Added checking for initial ^ in
- ps-run-prompt
+ ps-run-prompt.
(ps-mode): Added ps-run-font-lock-keywords-2 to list of
customizable variables in doc-string (its equivalent
ps-run-messages was missing in previous version of the doc-string).
@@ -2271,7 +2271,7 @@
1999-10-14 Stefan Monnier <monnier@cs.yale.edu>
* ange-ftp.el (ange-ftp-make-tmp-name, ange-ftp-del-tmp-name):
- * browse-url.el (browse-url-of-buffer, browse-url-delete-temp-file),
+ * browse-url.el (browse-url-of-buffer, browse-url-delete-temp-file)
(browse-url-temp-file-list, browse-url-delete-temp-file-list):
* ediff-util.el (ediff-make-temp-file):
* ediff-vers.el (ediff-pcl-cvs-view-revision):
@@ -2830,7 +2830,7 @@
(custom-buffer-create-internal): Obey custom-raised-buttons,
Custom-buffer-done.
(custom-button-face): Make it `released-button'.
- (custom-button-pressed-face): Make it `pressed-button'
+ (custom-button-pressed-face): Make it `pressed-button'.
(custom-mode-map): Bind "q" to Custom-buffer-done.
(custom-mode): Deal with raised/pressed buttons.
@@ -2987,7 +2987,7 @@
font-lock-defaults setting.
(java-properties-generic-mode): Supports both ! and # as comment
characters.
- (java-properties-generic-mode): Added an imenu-generic-expression
+ (java-properties-generic-mode): Added an imenu-generic-expression.
(java-properties-generic-mode): Reworked to support the various
different ways to separate name and value (viz, '=', ':' and
whitespace).
@@ -3483,7 +3483,7 @@
(reftex-toc-find-section): Use new version of `reftex-nearest-match'.
(reftex-insert-docstruct): Adapted to work with the index stuff.
(reftex-parse-from-file): Find index entries as well.
- (reftex-toc-toggle-index): New function
+ (reftex-toc-toggle-index): New function.
(reftex-toc-map): `i' is now used to toggle the index, File
boundaries has been moved to `F'.
(reftex-select-label-map): Toggling display of file boundaries is
@@ -3506,7 +3506,7 @@
(reftex-index-section-letters, reftex-index-include-context)
(reftex-index-follow-mode, reftex-index-header-face)
(reftex-index-section-face, reftex-index-tag-face)
- (reftex-index-face): New options
+ (reftex-index-face): New options.
(reftex-index-map, reftex-index-menu, reftex-last-index-file)
(reftex-index-tag, reftex-index-return-marker)
(reftex-index-restriction-indicator, reftex-index-restriction-data)
@@ -3514,9 +3514,9 @@
(reftex-index-key-end-re, reftex-find-index-entry-regexp-format)
(reftex-everything-regexp-no-index, reftex-index-re)
(reftex-macros-with-index, reftex-index-macro-alist): New variables.
- (reftex-index-help, reftex-index-macros-builtin,
+ (reftex-index-help, reftex-index-macros-builtin)
(reftex-key-to-index-macro-alist, reftex-query-index-macro-prompt)
- (reftex-query-index-macro-help): New constants
+ (reftex-query-index-macro-help): New constants.
(reftex-index-selection-or-word, reftex-index)
(reftex-default-index, reftex-update-default-index)
(reftex-index-complete-tag, reftex-index-select-tag)
@@ -3607,7 +3607,7 @@
window; and poles can be oriented horizontally. Face support is
thrown in gratuitously.
(hanoi): Changed default number of rings back to 3.
- (hanoi-unix, hanoi-unix-64): New commands
+ (hanoi-unix, hanoi-unix-64): New commands.
(hanoi-horizontal-flag, hanoi-move-period, hanoi-use-faces,
hanoi-pole-face, hanoi-base-face, hanoi-even-ring-face,
hanoi-odd-ring-face): New variables.
@@ -5777,20 +5777,20 @@
1999-03-12 Eric M. Ludlam <zappo@ultranet.com>
* speedbar.el: Added commentary about stealthy functions.
- (speedbar-message) new function.
- (speedbar-y-or-n-p): New function
- (speedbar-with-attached-buffer) Moved macro before reference.
+ (speedbar-message): New function.
+ (speedbar-y-or-n-p): New function.
+ (speedbar-with-attached-buffer): Moved macro before reference.
Now uses `save-selected-window'.
- (speedbar-mouse-hscroll, speedbar-track-mouse, speedbar-refresh,
- speedbar-generic-item-info, speedbar-item-info-file-helper,
- speedbar-item-delete, speedbar-insert-generic-list,
- speedbar-timer-fn, speedbar-check-vc-this-line,
- speedbar-check-obj-this-line, speedbar-fetch-dynamic-etags,
- speedbar-buffers-item-info) Use speedbar-message.
- (speedbar-item-info) Limit `message-log-max'.
- (speedbar-item-load, speedbar-item-copy, speedbar-item-rename,
- speedbar-item-delete, speedbar-item-object-delete,
- speedbar-buffer-kill-buffer) Use speedbar-y-or-n-p.
+ (speedbar-mouse-hscroll, speedbar-track-mouse, speedbar-refresh)
+ (speedbar-generic-item-info, speedbar-item-info-file-helper)
+ (speedbar-item-delete, speedbar-insert-generic-list)
+ (speedbar-timer-fn, speedbar-check-vc-this-line)
+ (speedbar-check-obj-this-line, speedbar-fetch-dynamic-etags)
+ (speedbar-buffers-item-info): Use speedbar-message.
+ (speedbar-item-info): Limit `message-log-max'.
+ (speedbar-item-load, speedbar-item-copy, speedbar-item-rename)
+ (speedbar-item-delete, speedbar-item-object-delete)
+ (speedbar-buffer-kill-buffer): Use speedbar-y-or-n-p.
1999-03-10 Kenichi Handa <handa@mulelab.etl.go.jp>
@@ -6230,7 +6230,7 @@
1999-02-12 Alex Schroeder <a.schroeder@bsiag.ch>
- * sql.el: Set version to 1.3.2
+ * sql.el: Set version to 1.3.2.
(sql-solid-program): Added support for solid.
(sql-help): Doc mentions sql-solid.
(sql-solid): Entry function for Solid.
@@ -6384,7 +6384,7 @@
coding-system-list here.
* international/mule.el (coding-system-lessp): Moved here from
- mule-util.el
+ mule-util.el.
(add-to-coding-system-list): New function.
(make-subsidiary-coding-system, make-coding-system,
define-coding-system-alias): Use it instead of setting
@@ -6721,7 +6721,7 @@
(speedbar-add-mode-functions-list) Improve doc.
(speedbar-line-token) New function.
(speedbar-dired) Fix order of directories in -shown-directories.
- (speedbar-line-path): Default return is default-directory
+ (speedbar-line-path): Default return is default-directory.
(speedbar-buffers-line-path): Return is dir name only.
(speedbar-mode-functions-list): New variable.
(speedbar-mouse-item-info): Rewrote to be a replaceable fn.
@@ -7321,7 +7321,7 @@
1998-12-29 Masatake Yamato <masata-y@tori.aist-nara.ac.jp>
* page-ext.el: Added mouse-selection feature for pages directory buffer.
- (pages-directory-map): Bind mouse-2
+ (pages-directory-map): Bind mouse-2.
(pages-copy-header-and-position): Put text property.
(pages-directory-goto-with-mouse): New function.
@@ -7399,7 +7399,7 @@
(cperl-after-block-p): Likewise.
(cperl-after-block-and-statement-beg): Likewise.
(cperl-after-block-p): After END/BEGIN we are a block.
- (cperl-after-expr-p): Skip labels when checking
+ (cperl-after-expr-p): Skip labels when checking.
(cperl-indent-region): Make a marker for END - text added/removed.
Disable hooks during the call (how to call them later?).
Now indents 820-line-long function in 6.5 sec (including
@@ -7462,7 +7462,7 @@
(cperl-fix-line-spacing): Sped up to bail out early.
(x-color-defined-p): Was not compiling on XEmacs
Was defmacro'ed with a tick. Remove another def.
- (cperl-clobber-lisp-bindings): If set, C-c variants are the old ones
+ (cperl-clobber-lisp-bindings): If set, C-c variants are the old ones.
(cperl-unwind-to-safe): New function.
(cperl-fontify-syntaxically): Use `cperl-unwind-to-safe' to start at
reasonable position.
@@ -7512,7 +7512,7 @@
(cperl-etags-goto-tag-location): New macro.
(cperl-version): New variable. New menu entry
random docstrings: References to "future" 20.3 removed.
- Menu was described as `CPerl' instead of `Perl'
+ Menu was described as `CPerl' instead of `Perl'.
(perl-font-lock-keywords): Would not highlight `sub foo($$);'.
(cperl-toggle-construct-fix): Was toggling to t instead of 1.
(cperl-ps-print-init): Associate `cperl-array-face', `cperl-hash-face'
@@ -8808,14 +8808,14 @@
enable-kinsoku.
* simple.el (do-auto-fill): Don't check kinsoku-enable here.
- Don't call kinsoku directly, intead call fill-find-break-point.
+ Don't call kinsoku directly, instead call fill-find-break-point.
* textmodes/fill.el: Setup `fill-find-break-point-function'
property to character sets which require `kinsoku' processing for
filling.
(fill-find-break-point): New function.
(fill-region-as-paragraph): Don't check kinsoku-enable here.
- Don't call kinsoku directly, intead call fill-find-break-point.
+ Don't call kinsoku directly, instead call fill-find-break-point.
1998-10-18 Richard Stallman <rms@psilocin.ai.mit.edu>
@@ -8972,7 +8972,7 @@
set unconditional-jump to nil.
(ccl-compile-read-multibyte-character): Return nil.
(ccl-compile-write-multibyte-character): Likewise.
- (ccl-compile-translate-character): Likewise
+ (ccl-compile-translate-character): Likewise.
(ccl-compile-map-multiple): Likewise.
(ccl-compile-map-single): Likewise.
@@ -9055,7 +9055,7 @@
* net-utils.el (ftp, nslookup): Require comint.
(network-service-connection): Likewise.
- (whois-server-name): Defaults to whois.arin.net
+ (whois-server-name): Defaults to whois.arin.net.
(whois-server-list, whois-server-tld, whois-guess-server): New var.
(whois): Tries to guess the appropriate top-level domain server.
(whois-get-tld): New function.
@@ -9599,7 +9599,7 @@
(reftex-view-cr-cite, reftex-view-cr-ref, reftex-end-of-bib-entry):
New functions.
(reftex-auto-view-crossref): New value `window' allowed.
- (reftex-view-crossref-when-idle): Process new `window' option in
+ (reftex-view-crossref-when-idle): Process new `window' option.
(reftex-translate-to-ascii-function): New default.
(reftex-label-illegal-re): Default changed, removed Latin1.
(reftex-latin1-to-ascii): New function.
@@ -9639,7 +9639,7 @@
(checkdoc-this-string-valid): When converting a comment into a doc
string, make sure " chars are \".
(checkdoc-sentencespace-region-engine): Only do double space check
- if based on the variable `sentence-end-double-space'
+ if based on the variable `sentence-end-double-space'.
(checkdoc-this-string-valid-engine): ? ends valid sentence.
(checkdoc-proper-noun-region-engine): Exclude items in URLs
diff --git a/lisp/ChangeLog.9 b/lisp/ChangeLog.9
index 5f1a501af37..d6e9d2f8bcc 100644
--- a/lisp/ChangeLog.9
+++ b/lisp/ChangeLog.9
@@ -242,8 +242,8 @@
(cperl-find-pods-heres): Could access `font-lock-comment-face' in -nw.
No -nw-compile time warnings now.
(cperl-find-tags): TAGS file had too short substring-to-search.
- Be less verbose in non-interactive mode
- (imenu-example--create-perl-index): Set index-marker after name
+ Be less verbose in non-interactive mode.
+ (imenu-example--create-perl-index): Set index-marker after name.
(cperl-outline-regexp): New variable.
(cperl-outline-level): Made compatible with `cperl-outline-regexp'.
(cperl-mode): Made use `cperl-outline-regexp'.
@@ -479,7 +479,7 @@
(help-setup-xref, help-xref-following, help-make-xrefs)
(help-xref-button, help-insert-xref-button, help-xref-interned)
(help-xref-go-back, help-go-back, help-do-xref, help-follow)
- (help-xref-on-pp): Functions moved into `help-mode.el'
+ (help-xref-on-pp): Functions moved into `help-mode.el'.
(help-mode-map, help-xref-stack, help-xref-stack-item)
(help-highlight-p, help-highlight-face, help-back-label)
(help-xref-symbol-regexp, help-xref-mule-regexp)
@@ -1188,7 +1188,7 @@
2001-09-07 Eli Zaretskii <eliz@is.elta.co.il>
* textmodes/ispell.el (ispell-dictionary-alist-4): Add "german"
- and "german8", for the new German orthography dictionaries,
+ and "german8", for the new German orthography dictionaries.
(ispell-dictionary-alist-5, ispell-dictionary-alist-6): Rearrange
the entries, to keep the line length balanced for loaddefs.el.
@@ -2072,7 +2072,7 @@
* ediff-init.el (ediff-with-syntax-table): New macro, uses
with-syntax-table.
- (ediff-coding-system-for-read): From ediff-diff.el
+ (ediff-coding-system-for-read): From ediff-diff.el.
(ediff-coding-system-for-write): New variable.
(ediff-highest-priority): Fixed the bug having to do with disappearing
overlays.
@@ -2739,8 +2739,8 @@
2001-06-27 Francesco Potortì <pot@gnu.org>
- * uniquify.el: (uniquify-rationalize-file-buffer-names):
- Undo previous change.
+ * uniquify.el (uniquify-rationalize-file-buffer-names):
+ Undo previous change.
2001-06-27 Francesco Potortì <pot@gnu.org>
@@ -5978,7 +5978,7 @@
* shell.el (shell-write-history-on-exit): Make sure that we are in
the shell buffer (M-x tex-file RET inserted the error message into
- the TeX buffer).
+ the TeX buffer).
2001-01-27 Eli Zaretskii <eliz@is.elta.co.il>
@@ -6812,7 +6812,7 @@
to nil.
* tooltip.el (tooltip-frame-parameters): Remove colors.
- (tooltip): New face
+ (tooltip): New face.
(tooltip-set-param): New function.
(tooltip-show): Set up color frame parameters from face `tooltip'.
Display the tooltip text in face `tooltip'.
@@ -8804,7 +8804,7 @@
2000-11-12 Dave Love <fx@gnu.org>
- * mail/feedmail.el: Fix header,
+ * mail/feedmail.el: Fix header.
(feedmail) <defgroup>: Add :link.
* view.el: Use local-map property, not keymap on mode-line string.
@@ -10715,7 +10715,7 @@
* iswitchb.el (iswitchb-mode): Add :require.
* info.el (Info-goto-node, Info-menu): Doc fix.
- (Info-mode-menu): Bind beginning-of-buffer, Info-edit
+ (Info-mode-menu): Bind beginning-of-buffer, Info-edit.
(info-tool-bar-map): New variable.
(Info-mode): Use it.
(Info-edit-map): Define all in defvar.
@@ -11010,7 +11010,7 @@
* net/net-utils.el (nslookup-font-lock-keywords)
(ftp-font-lock-keywords, smbclient-font-lock-keywords):
- Only set if window-system is non-nil
+ Only set if window-system is non-nil.
(net-utils-run-program): Returns buffer.
(network-connection-reconnect): Added this function.
@@ -11025,13 +11025,13 @@
(generic-mode-alist): Renamed to generic-mode-list.
(generic-find-file-regexp): Default changed to "^#".
(generic-read-type): Uses completing read on generic-mode-list.
- (generic-mode-sanity-check): removed this function.
- (generic-add-to-auto-mode): Removed this function
+ (generic-mode-sanity-check): Removed this function.
+ (generic-add-to-auto-mode): Removed this function.
(generic-mode-internal): Bind mode-specific definitions
into function instead of putting them in alist.
(generic-mode-set-comments): Reworked extensively.
- (generic-mode-find-file-hook): Simplified regexp searching
- (generic-make-keywords-list): Omit extra pair of parens
+ (generic-mode-find-file-hook): Simplified regexp searching.
+ (generic-make-keywords-list): Omit extra pair of parens.
* find-lisp.el (find-lisp-find-files-internal):
Make sure directory name ends with "/".
@@ -11040,7 +11040,7 @@
Regexp now allows leading whitespace.
(rc-generic-mode): Added eval-when-compile
around generic-make-keywords-list.
- Deleted duplicate regexp
+ Deleted duplicate regexp.
(rul-generic-mode): Added eval-when-compile
around generic-make-keywords-list.
(etc-fstab-generic-mode): New generic mode.
@@ -11356,7 +11356,7 @@
(comint-insert-clicked-input): Be more careful to find the overlay.
Use this-command-keys rather than hardcoding mouse-2.
- * font-lock.el: Replace confusing (,@ with ,
+ * font-lock.el: Replace confusing (,@ with ,.
(tex-font-lock-keywords-1, tex-font-lock-keywords-2):
Don't use regexp-opt-depth. Spice up the regexp for args.
Don't distinguish between cmds that can take an opt arg or not.
@@ -11885,7 +11885,7 @@
New functions, used instead of non-`strokes-' versions..
(strokes-mouse-event-p): Rewritten.
(strokes-event-closest-point): Avoid event-point.
- (strokes-get-grid-position): Avoid cdadr, caadr
+ (strokes-get-grid-position): Avoid cdadr, caadr.
(strokes-read-stroke, strokes-read-complex-stroke): Avoid levents
functions.
(strokes-help): Use with-output-to-temp-buffer.
@@ -12205,7 +12205,7 @@
2000-09-05 Stefan Monnier <monnier@cs.yale.edu>
- * vc.el: (toplevel): Don't require `dired' at run-time.
+ * vc.el (toplevel): Don't require `dired' at run-time.
(vc-dired-resynch-file): Remove autoload cookie.
2000-09-05 Andre Spiegel <spiegel@gnu.org>
@@ -12998,7 +12998,7 @@
`vc-locking-user' semantics.
(vc-backend-merge): Remove.
- * vc-rcs.el, vc-scc.el: (vc-{sc,r}cs-check{in,out}): Update 'vc-state
+ * vc-rcs.el, vc-scc.el (vc-{sc,r}cs-check{in,out}): Update 'vc-state
rather than 'vc-locking-user.
* vc-rcs-hooks.el (vc-rcs-consult-headers): Adapt to new `vc-state'.
@@ -14110,14 +14110,14 @@
* locate.el (locate): Cleaned up locate command's interactive prompting
Thanks to François_Pinard <pinard@iro.umontreal.ca> for suggestions.
- * filecache.el (file-cache-case-fold-search): New variable
- (file-cache-assoc-function): New variable
+ * filecache.el (file-cache-case-fold-search): New variable.
+ (file-cache-assoc-function): New variable.
(file-cache-minibuffer-complete): Use file-cache-assoc-function.
- Use file-cache-case-fold-search variable
- (file-cache-add-file): Use file-cache-assoc-function
- (file-cache-delete-file): likewise
- (file-cache-directory-name): likewise
- (file-cache-debug-read-from-minibuffer): likewise
+ Use file-cache-case-fold-search variable.
+ (file-cache-add-file): Use file-cache-assoc-function.
+ (file-cache-delete-file): Likewise.
+ (file-cache-directory-name): Likewise.
+ (file-cache-debug-read-from-minibuffer): Likewise.
2000-08-28 Gerd Moellmann <gerd@gnu.org>
@@ -14191,12 +14191,12 @@
* international/ja-dic-cnv.el: Renamed from skkdic-cnv.el.
Provide ja-dic-cnv instead of skkdic-cnv.
- (ja-dic-filename): Renamed from skkdic-filename. Referers changed
+ (ja-dic-filename): Renamed from skkdic-filename. Referers changed.
(iso-2022-7bit-short): Add safe-charsets property.
(skkdic-convert-postfix): Search Japanese chou-on character in
addition to Hiragana character.
(skkdic-convert-prefix, skkdic-collect-okuri-nasi): Likewise.
- (skkdic-convert): Change file names from skkdic.el to ja-dic.el
+ (skkdic-convert): Change file names from skkdic.el to ja-dic.el.
(batch-skkdic-convert): Likewise.
* international/ja-dic-utl.el: Renamed from skkdic-utl.el.
@@ -14389,12 +14389,12 @@
(ispell-dictionary-alist-4): Fixed regexp in francais-tex
dictionary, added italiano dictionary.
(ispell-skip-region-alist): Removed regexp thrashing when `-' is a
- word character
+ word character.
(ispell-tex-skip-alists): Added psfig support.
(ispell-skip-html): Renamed from ispell-skip-sgml.
(ispell-begin-skip-region-regexp, ispell-skip-region)
(ispell-minor-check): Improved html skipping support to skip across
- code, and recognize `&' commands without proper `;' syntax;
+ code, and recognize `&' commands without proper `;' syntax.
(ispell-process-line): Fix alignment error when manually
correcting spelling.
(ispell): Fix comment string.
@@ -14515,7 +14515,7 @@
(goto-address-url-face, goto-address-url-mouse-face)
(goto-address-mail-face, goto-address-mail-mouse-face): Doc fix.
(goto-address-url-regexp): Use thing-at-point-url-regexp.
- (goto-address-fontify, goto-address-at-mouse): Simplify,
+ (goto-address-fontify, goto-address-at-mouse): Simplify.
(goto-address-at-point): browse-url-url-at-point,
goto-address-find-address-at-point can return nil.
(goto-address-find-address-at-point): Return nil on failure.
@@ -15318,8 +15318,8 @@
leading comma nicely. Extended to handle member initializers
too.
- * cc-engine.el: (c-beginning-of-inheritance-list,
- c-guess-basic-syntax): Fixed recognition of inheritance lists
+ * cc-engine.el (c-beginning-of-inheritance-list)
+ (c-guess-basic-syntax): Fixed recognition of inheritance lists
when the lines begins with a comma.
* cc-vars.el (c-offsets-alist): Changed default for
@@ -15501,23 +15501,23 @@
ada-xref.el before ada-prj.el, so that the Project menu is created
when ada-prj tries to add to it.
(ada-activate-keys-for-case): Suppress the characters that are not
- part of the Ada syntax. Better compatibility with else-mode
+ part of the Ada syntax. Better compatibility with else-mode.
(ada-adjust-case-interactive): When auto-casing is not active,
correctly insert newlines (used to insert only ^M). Prevent the
syntax table from being changed in case of an error
(or '_' becomes part of a word and some commands are confused).
Do nothing if ada-auto-case is nil.
- (ada-after-keyword-p): Ignore keywords that are also attributes
- (ada-batch-reformat): Update usage comment
- (ada-call-from-contextual-menu): New function
+ (ada-after-keyword-p): Ignore keywords that are also attributes.
+ (ada-batch-reformat): Update usage comment.
+ (ada-call-from-contextual-menu): New function.
(ada-case-read-exceptions): Reinitialize the casing exception list
first to nil first, so that the casing exception file can be
shared.
(ada-check-defun-name): Handles "configure" keyword for gnatdist
files.
(ada-compile-goto-error): Fix regexp used to detect a file:line
- anywhere in the error message
- (ada-contextual-menu-last-point): New variable
+ anywhere in the error message.
+ (ada-contextual-menu-last-point): New variable.
(ada-create-keymap): If the variable delete-key-deletes-forward is
t on XEmacs, it means that DEL should delete one character
forward.
@@ -15544,21 +15544,21 @@
are not in fact seeing "end if". Ignore "when" statements except
when initial keyword was "begin". Fix handling of nested
procedures. Add a recursive call to this function to skip over
- other 'end' statmts. Fix indentation for "when .. => begin"
+ other 'end' statmts. Fix indentation for "when .. => begin".
(ada-in-open-paren-p): Fix indentation for complex boolean
expressions, where 'and then', 'or else' and parenthesis
statements are mixed up.
(ada-in-paramlist-p): Skip comments while searching for the
beginning Fix handling of operator declarations.
- (ada-indent-align-comments): New variable
+ (ada-indent-align-comments): New variable.
(ada-indent-current): Change the syntax table only in the
protected section, so that we are sure it is restored correctly.
(ada-indent-on-previous-lines): Use ada-use-indent and
- ada-with-indent Correctly indent "select ... then"
+ ada-with-indent. Correctly indent "select ... then".
(ada-indent-region): Slight speedup.
(ada-indent-renames): New variable.
(ada-last-which-function-subprog, ada-last-which-function-line):
- New variables
+ New variables.
(ada-looking-at-semi-private): Correctly indent the 'private'
keyword when it is the first word in a package declaration.
(ada-loose-case-word): Stop searching if at the end of the buffer.
@@ -15568,8 +15568,8 @@
(ada-mode): Add support for abbrev-mode, outline-mode and
which-func-mode Override the old find-file.el entry in
ff-special-constructs since it is using the obsolete
- ada-spec-suffix variable
- (ada-no-auto-case): New function
+ ada-spec-suffix variable.
+ (ada-no-auto-case): New function.
(ada-scan-paramlist): When parsing the argument type, accept
spaces (as in "X 'Class", generated by Rational Rose).
(ada-other-file-name): No longer loads the other file.
@@ -15578,41 +15578,41 @@
(ada-search-ignore-complex-boolean): New function.
(ada-uncomment-region): Emacs21 already knows how to delete
comments not starting in the first column.
- (ada-use-indent): New variable
+ (ada-use-indent): New variable.
(ada-which-function): New function.
- (ada-with-indent): New variable
- (ada-xemacs): evaluate it at compile time too, so that ada-mode.el
+ (ada-with-indent): New variable.
+ (ada-xemacs): Evaluate it at compile time too, so that ada-mode.el
can be batch-compiled from the command line.
* ada-xref.el: Got rid of all byte-compiler warnings on Emacs.
Add to the menu when the file is loaded, not in ada-mode-hook.
Add -toolbar to the default ddd command Switches moved from
ada-prj-default-comp-cmd and ada-prj-default-make-cmd to
- ada-prj-default-comp-opt
- (ada-add-ada-menu): Remove the map and name parameters Add the Ada
- Reference Manual to the menu
- (ada-check-current): rewritten as a call to ada-compile-current
+ ada-prj-default-comp-opt.
+ (ada-add-ada-menu): Remove the map and name parameters. Add the Ada
+ Reference Manual to the menu.
+ (ada-check-current): Rewritten as a call to ada-compile-current.
(ada-compile): Removed.
(ada-compile-application, ada-compile-current, ada-check-current):
Set the compilation-search-path so that compile.el automatically
finds the sources in src_dir. Automatic scrolling of the
compilation buffer. C-uC-cC-c asks for confirmation before
- compiling
- (ada-compile-current): New parameter, prj-field
+ compiling.
+ (ada-compile-current): New parameter, prj-field.
(ada-complete-identifier): Load the .ali file before doing
- processing
+ processing.
(ada-find-ali-file-in-dir): prepend build_dir to obj_dir to
conform to gnatmake's behavior.
- (ada-find-file-in-dir): New function
- (ada-find-references): Set the environment variables for gnatfind
+ (ada-find-file-in-dir): New function.
+ (ada-find-references): Set the environment variables for gnatfind.
(ada-find-src-file-in-dir): New function.
- (ada-first-non-nil): Removed
+ (ada-first-non-nil): Removed.
(ada-gdb-application): Add support for jdb, the java debugger.
(ada-get-ada-file-name): Load the original-file first if not done
yet.
(ada-get-all-references): Handles the new ali syntax (parent types
are found between <>).
- (ada-initialize-runtime-library): New function
+ (ada-initialize-runtime-library): New function.
(ada-mode-hook): Always load a project file when a file is opened,
so that the casing exceptions are correctly read.
(ada-operator-re): Add all missing operators ("abs", "rem", "**").
@@ -15623,36 +15623,36 @@
src_dir to initialize ada-search-directories and
compilation-search-path,... Add the standard runtime library to
the search path for find-file.
- (ada-prj-default-debugger): Was missing an opening '{'
+ (ada-prj-default-debugger): Was missing an opening '{'.
(ada-prj-default-bind-opt, ada-prj-default-link-opt): New
variables.
- (ada-prj-default-gnatmake-opt): New variable
+ (ada-prj-default-gnatmake-opt): New variable.
(ada-prj-find-prj-file): Handles non-file buffers For non-Ada
buffers, the project file is the default one Save the windows
configuration before displaying the menu.
- (ada-prj-src-dir, ada-prj-obj-dir, ada-prj-comp-opt,...): Removed
+ (ada-prj-src-dir, ada-prj-obj-dir, ada-prj-comp-opt,...): Removed.
(ada-read-identifier): Fix xrefs on operators (for "mod", "and",
...) regexp-quote identifiers names to support operators +,
-,... in regexps.
(ada-remote): New function.
(ada-run-application): Erase the output buffer before starting the
run Support remote execution of the application. Use
- call-process, or the arguments are incorrectly parsed
+ call-process, or the arguments are incorrectly parsed.
(ada-set-default-project-file): Reread the content of the active
project file, not the one from the current buffer When a project
file is set as the default project, all directories are
automatically associated with it.
- (ada-set-environment): New function
- (ada-treat-cmd-string): New special variable ${current}
+ (ada-set-environment): New function.
+ (ada-treat-cmd-string): New special variable ${current}.
(ada-treat-cmd-string): Revised. The substitution is now done for
- any ${...} substring
+ any ${...} substring.
(ada-xref-current): If no body was found, compiles the spec
instead. Setup ADA_{SOURCE,OBJECTS}_PATH before running the
compiler to get rid of command line length limitations.
- (ada-xref-get-project-field): New function
- (ada-xref-project-files): New variable
+ (ada-xref-get-project-field): New function.
+ (ada-xref-project-files): New variable.
(ada-xref-runtime-library-specs-path)
- (ada-xref-runtime-library-ali-path): New variables
+ (ada-xref-runtime-library-ali-path): New variables.
(ada-xref-set-default-prj-values): Default run command now does a
cd to the build directory. New field: main_unit Provide a default
file name even if the current buffer has no prj file.
@@ -15661,10 +15661,10 @@
Rewritten to show a tabbed-dialog.
(ada-prj-add-ada-menu): Remove the map and name parameters.
(ada-prj-display-page, ada-prj-field, ada-prj-initialize-values):
- New function
- (ada-prj-load-directory, ada-prj-subdirs-of): New functions
- (ada-prj-load-from-file): New function
- (ada-prj-save): Always save fields that depend on the current buffer
+ New function.
+ (ada-prj-load-directory, ada-prj-subdirs-of): New functions.
+ (ada-prj-load-from-file): New function.
+ (ada-prj-save): Always save fields that depend on the current buffer.
(ada-prj-show-value): New function
* ada-stmt.el (ada-stmt-add-to-ada-menu): Hide the menu if not in
@@ -17470,14 +17470,14 @@
* speedbar.el (speedbar-easymenu-definition-base): Image toggle fix.
(speedbar-insert-button): Invisible text property fix.
- (speedbar-directory-plus): Renamed from speedbar-directory-+
- (speedbar-directory-minus): Renamed from speedbar-directory--
- (speedbar-page-plus): Renamed from speedbar-file-+
- (speedbar-page-minus): Renamed from speedbar-file--
- (speedbar-page): Renamed from speedbar-file-
- (speedbar-tag): Renamed from speedbar-tag-
- (speedbar-tag-plus): Renamed from speedbar-tag-+
- (speedbar-tag-minus): Renamed from speedbar-tag--
+ (speedbar-directory-plus): Renamed from speedbar-directory-+.
+ (speedbar-directory-minus): Renamed from speedbar-directory--.
+ (speedbar-page-plus): Renamed from speedbar-file-+.
+ (speedbar-page-minus): Renamed from speedbar-file--.
+ (speedbar-page): Renamed from speedbar-file-.
+ (speedbar-tag): Renamed from speedbar-tag-.
+ (speedbar-tag-plus): Renamed from speedbar-tag-+.
+ (speedbar-tag-minus): Renamed from speedbar-tag--.
(speedbar-expand-image-button-alist): Use above renames.
* sb-dir-plus.xpm: Renamed from sb-dir+.xpm
@@ -17861,7 +17861,7 @@
(speedbar-visiting-tag-hook): Set new defaults. Added options.
(speedbar-reconfigure-keymaps-hook): New variable.
(speedbar-frame-parameters): Updated documentation.
- (speedbar-use-imenu-flag): Updated custom tag
+ (speedbar-use-imenu-flag): Updated custom tag.
(speedbar-dynamic-tags-function-list): New variable.
(speedbar-tag-hierarchy-method): Updated doc & custom.
(speedbar-indentation-width, speedbar-indentation-width) New
@@ -17877,7 +17877,7 @@
`force-mode-line-update'.
(speedbar-mode, speedbar-quick-mouse, speedbar-click)
(speedbar-double-click): Use `speedbar-mouse-set-point' instead of
- `mouse-set-point'
+ `mouse-set-point'.
(speedbar-reconfigure-keymaps): Run configure keymap hooks.
(speedbar-item-info-tag-helper): Revamped to handle a wider range
of arbitrary text, and new helper functions.
@@ -17893,11 +17893,11 @@
(speedbar-apply-one-tag-hierarchy-method): Deleted (and replaced).
(speedbar-sort-tag-hierarchy, speedbar-prefix-group-tag-hierarchy)
(speedbar-trim-words-tag-hierarchy)
- (speedbar-simple-group-tag-hierarchy): New functions
+ (speedbar-simple-group-tag-hierarchy): New functions.
(speedbar-create-tag-hierarchy): Update doc, use new tag hooks.
(speedbar-insert-imenu-list, speedbar-insert-etags-list): New
functions.
- (speedbar-mouse-set-point): New function
+ (speedbar-mouse-set-point): New function.
(speedbar-power-click): Updated documentation.
(speedbar-line-token, speedbar-goto-this-file): Handle more types
of tag prefix text.
@@ -17916,7 +17916,7 @@
"Revert Buffer" menu items.
(speedbar-buffer-buttons-engine): Be smarter when creating a
filename tag (for expansion purposes.).
- (speedbar-highlight-one-tag-line,
+ (speedbar-highlight-one-tag-line)
(speedbar-unhighlight-one-tag-line, speedbar-recenter-to-top)
(speedbar-recenter): New functions.
(defimage-speedbar): Image loading abstraction.
@@ -18748,13 +18748,13 @@
2000-03-30 Peter Breton <pbreton@ne.mediaone.net>
* net/net-utils.el:
- (network-connection-host, network-connection-service): New variables
- (network-connection-mode): New mode, derived from comint-mode
+ (network-connection-host, network-connection-service): New variables.
+ (network-connection-mode): New mode, derived from comint-mode.
(network-connection-mode-setup): New function, saves host and
service information in local variables.
* lisp/locate.el:
- (locate-word-at-point): Added this function
+ (locate-word-at-point): Added this function.
(locate): Default to using locate-word-at-point as input
Run dired-mode-hook
@@ -19574,7 +19574,7 @@
(backward-kill-word): Revert addition of * to interactive spec --
it's a feature.
- * paragraphs.el: (kill-paragraph, backward-kill-paragraph)
+ * paragraphs.el (kill-paragraph, backward-kill-paragraph)
(backward-kill-sentence, kill-sentence): Likewise.
* gud.el (gud-jdb-build-class-source-alist): Prepend space to
@@ -19918,7 +19918,7 @@
2000-02-10 Dave Love <fx@gnu.org>
- * wid-edit.el: (widgets) [defgroup]: Remove url link.
+ * wid-edit.el (widgets) [defgroup]: Remove url link.
(widget-color-choice-list, widget-color-history, widget-mouse-help):
Deleted.
(widget-specify-field, widget-specify-button): Don't use
@@ -20347,7 +20347,7 @@
* simple.el (eval-expression): Don't bind debug-on-error if
eval-expression-debug-on-error is nil. Detect changed
debug-on-error, and propagate new value to global binding, if
- eval-expression-debug-on-error is non-nil,
+ eval-expression-debug-on-error is non-nil.
(eval-expression-debug-on-error): Change doc string.
2000-01-11 Richard M. Stallman <rms@gnu.org>
diff --git a/lisp/Makefile.in b/lisp/Makefile.in
index dd93ec44e93..2b2081a25d0 100644
--- a/lisp/Makefile.in
+++ b/lisp/Makefile.in
@@ -19,19 +19,23 @@
SHELL = /bin/sh
-lisp=@srcdir@
-VPATH=@srcdir@
-srcdir=@srcdir@/..
+srcdir = @srcdir@
+top_srcdir = @top_srcdir@
+abs_top_builddir = @abs_top_builddir@
+lisp = $(srcdir)
+VPATH = $(srcdir)
# You can specify a different executable on the make command line,
# e.g. "make EMACS=../src/emacs ...".
-EMACS = ../src/emacs
+# We sometimes change directory before running Emacs (typically when
+# building out-of-tree, we chdir to the source directory), so we need
+# to use an absolute file name.
+EMACS = ${abs_top_builddir}/src/emacs
-# Command line flags for Emacs. This must include --multibyte,
-# otherwise some files will not compile.
+# Command line flags for Emacs.
-EMACSOPT = -batch --no-site-file --multibyte
+EMACSOPT = -batch --no-site-file
# Extra flags to pass to the byte compiler
BYTE_COMPILE_EXTRA_FLAGS =
@@ -52,7 +56,8 @@ ETAGS = ../lib-src/etags
LOADDEFS = $(lisp)/calendar/cal-loaddefs.el \
$(lisp)/calendar/diary-loaddefs.el \
$(lisp)/calendar/hol-loaddefs.el \
- $(lisp)/mh-e/mh-loaddefs.el
+ $(lisp)/mh-e/mh-loaddefs.el \
+ $(lisp)/net/tramp-loaddefs.el
# Elisp files auto-generated.
AUTOGENEL = loaddefs.el \
@@ -79,29 +84,26 @@ COMPILE_FIRST = \
emacs = EMACSLOADPATH=$(lisp) LC_ALL=C $(EMACS) $(EMACSOPT)
# Common command to find subdirectories
-
-setwins=subdirs=`(cd $$wd; find . -type d -print)`; \
+setwins=subdirs=`(find . -type d -print)`; \
for file in $$subdirs; do \
- case $$file in */Old | */RCS | */CVS | */CVS/* | */.* | */.*/* | */=* ) ;; \
- *) wins="$$wins $$wd/$$file" ;; \
+ case $$file in */.* | */.*/* | */=* ) ;; \
+ *) wins="$$wins $$file" ;; \
esac; \
done
# Find all subdirectories except `obsolete' and `term'.
-
-setwins_almost=subdirs=`(cd $$wd; find . -type d -print)`; \
+setwins_almost=subdirs=`(find . -type d -print)`; \
for file in $$subdirs; do \
- case $$file in */Old | */RCS | */CVS | */CVS/* | */.* | */.*/* | */=* | */obsolete | */term ) ;; \
- *) wins="$$wins $$wd/$$file" ;; \
+ case $$file in */.* | */.*/* | */=* | */obsolete | */term ) ;; \
+ *) wins="$$wins $$file" ;; \
esac; \
done
# Find all subdirectories in which we might want to create subdirs.el
-
-setwins_for_subdirs=subdirs=`(cd $$wd; find . -type d -print)`; \
+setwins_for_subdirs=subdirs=`(find . -type d -print)`; \
for file in $$subdirs; do \
- case $$file in */Old | */RCS | */CVS | */CVS/* | */.* | */.*/* | */=* | */cedet* ) ;; \
- *) wins="$$wins $$wd/$$file" ;; \
+ case $$file in */.* | */.*/* | */=* | */cedet* ) ;; \
+ *) wins="$$wins $$file" ;; \
esac; \
done
@@ -110,8 +112,6 @@ setwins_for_subdirs=subdirs=`(cd $$wd; find . -type d -print)`; \
# cus-load and finder-inf are not explicitly requested by anything, so
# we add them here to make sure they get built.
all: compile-main $(lisp)/cus-load.el $(lisp)/finder-inf.el
- @: Let us check that we byte-compiled all the files.
- $(MAKE) $(MFLAGS) compile-last EMACS=$(EMACS)
doit:
@@ -132,14 +132,14 @@ doit:
$(lisp)/cus-load.el:
$(MAKE) $(MFLAGS) custom-deps
custom-deps: doit
- wd=$(lisp); $(setwins_almost); \
+ cd $(lisp); $(setwins_almost); \
echo Directories: $$wins; \
$(emacs) -l cus-dep --eval '(setq generated-custom-dependencies-file "$(lisp)/cus-load.el")' -f custom-make-dependencies $$wins
$(lisp)/finder-inf.el:
$(MAKE) $(MFLAGS) finder-data
finder-data: doit
- wd=$(lisp); $(setwins_almost); \
+ cd $(lisp); $(setwins_almost); \
echo Directories: $$wins; \
$(emacs) -l finder --eval '(setq generated-finder-keywords-file "$(lisp)/finder-inf.el")' -f finder-compile-keywords-make-dist $$wins
@@ -148,8 +148,8 @@ finder-data: doit
autoloads: $(LOADDEFS) doit
chmod +w $(lisp)/ps-print.el $(lisp)/emulation/tpu-edt.el \
$(lisp)/emacs-lisp/cl-loaddefs.el $(lisp)/mail/rmail.el \
- $(lisp)/dired.el $(lisp)/ibuffer.el
- wd=$(lisp); $(setwins_almost); \
+ $(lisp)/dired.el $(lisp)/ibuffer.el $(lisp)/htmlfontify.el
+ cd $(lisp); $(setwins_almost); \
echo Directories: $$wins; \
$(emacs) -l autoload --eval '(setq generated-autoload-file "$(lisp)/loaddefs.el")' -f batch-update-autoloads $$wins
@@ -158,9 +158,9 @@ autoloads: $(LOADDEFS) doit
$(lisp)/subdirs.el:
$(MAKE) $(MFLAGS) update-subdirs
update-subdirs: doit
- wd=$(lisp); $(setwins_for_subdirs); \
+ cd $(lisp); $(setwins_for_subdirs); \
for file in $$wins; do \
- $(srcdir)/update-subdirs $$file; \
+ $(top_srcdir)/update-subdirs $$file; \
done;
updates: update-subdirs autoloads finder-data custom-deps
@@ -174,1295 +174,12 @@ cvs-update: bzr-update
# Update the AUTHORS file.
update-authors:
- $(emacs) -l authors -f batch-update-authors $(srcdir)/etc/AUTHORS $(srcdir)
+ $(emacs) -l authors -f batch-update-authors $(top_srcdir)/etc/AUTHORS $(top_srcdir)
TAGS TAGS-LISP: $(lisptagsfiles1) $(lisptagsfiles2) $(lisptagsfiles3) $(lisptagsfiles4)
els=`echo $(lisptagsfiles1) $(lisptagsfiles2) $(lisptagsfiles3) $(lisptagsfiles4) | sed -e "s,$(lisp)/[^ ]*loaddefs[^ ]*,," -e "s,$(lisp)/ldefs-boot[^ ]*,,"`; \
${ETAGS} -o $@ $$els
-.PHONY: update-elclist
-
-## Post-bootstrap, find the list of .elc files and use sed to update
-## ELCFILES in Makefile.in.
-## Errors in the final sed are non-fatal, since they have no effect on
-## building Emacs. chmod +w is for CVSREAD=1.
-## "echo" is non-portable with regards to backslashes, eg between zsh
-## and bash. Hence the use of sed on line 2 below (line 1 seems to be OK).
-## http://lists.gnu.org/archive/html/emacs-devel/2008-05/msg01535.html
-update-elclist:
- echo "/^ELCFILES/,/^$$/c\\" > temp.sed
- echo "ELCFILES =" | sed -e 's/$$/ \\\\\\/' >> temp.sed
- LC_COLLATE=C ls $(lisp)/*.elc $(lisp)/*/*.elc $(lisp)/*/*/*.elc $(lisp)/*/*/*/*.elc | sed -e "s|^$(lisp)| \$$(lisp)|" -e 's/$$/ \\\\\\/' -e '$$ s/ \\\\//' >> temp.sed
- echo "" >> temp.sed
- -sed -f temp.sed $(lisp)/Makefile.in > temp-elcfiles || rm temp-elcfiles
- rm temp.sed
- @test -f temp-elcfiles || echo "Maintainer warning: failed to update Makefile.in. You can ignore this if you are not an Emacs developer."
- if test -f temp-elcfiles; then \
- chmod +w $(lisp)/Makefile.in; \
- mv -f temp-elcfiles $(lisp)/Makefile.in; \
- fi
- -(LC_COLLATE=C ls $(lisp)/*.elc $(lisp)/*/*.elc $(lisp)/*/*/*.elc $(lisp)/*/*/*/*.elc | sed 's/elc$$/el/'; \
- LC_COLLATE=C ls $(lisp)/*.el $(lisp)/*/*.el $(lisp)/*/*/*.el $(lisp)/*/*/*/*.el; \
- LC_COLLATE=C ls $(lisp)/*.el $(lisp)/*/*.el $(lisp)/*/*/*.el $(lisp)/*/*/*/*.el) | \
- sort | uniq -u | while read extra; do \
- echo "Found left over byte-compiled file: $${extra}c !!" ;\
- done
-
-## Explicitly list the .elc files, for the sake of parallel builds.
-## http://lists.gnu.org/archive/html/bug-gnu-emacs/2008-05/msg00016.html
-## This can probably be done more elegantly, but needs to be portable.
-ELCFILES = \
- $(lisp)/abbrev.elc \
- $(lisp)/abbrevlist.elc \
- $(lisp)/add-log.elc \
- $(lisp)/align.elc \
- $(lisp)/allout.elc \
- $(lisp)/ansi-color.elc \
- $(lisp)/apropos.elc \
- $(lisp)/arc-mode.elc \
- $(lisp)/array.elc \
- $(lisp)/autoarg.elc \
- $(lisp)/autoinsert.elc \
- $(lisp)/autorevert.elc \
- $(lisp)/avoid.elc \
- $(lisp)/battery.elc \
- $(lisp)/bindings.elc \
- $(lisp)/bookmark.elc \
- $(lisp)/bs.elc \
- $(lisp)/buff-menu.elc \
- $(lisp)/button.elc \
- $(lisp)/calc/calc-aent.elc \
- $(lisp)/calc/calc-alg.elc \
- $(lisp)/calc/calc-arith.elc \
- $(lisp)/calc/calc-bin.elc \
- $(lisp)/calc/calc-comb.elc \
- $(lisp)/calc/calc-cplx.elc \
- $(lisp)/calc/calc-embed.elc \
- $(lisp)/calc/calc-ext.elc \
- $(lisp)/calc/calc-fin.elc \
- $(lisp)/calc/calc-forms.elc \
- $(lisp)/calc/calc-frac.elc \
- $(lisp)/calc/calc-funcs.elc \
- $(lisp)/calc/calc-graph.elc \
- $(lisp)/calc/calc-help.elc \
- $(lisp)/calc/calc-incom.elc \
- $(lisp)/calc/calc-keypd.elc \
- $(lisp)/calc/calc-lang.elc \
- $(lisp)/calc/calc-macs.elc \
- $(lisp)/calc/calc-map.elc \
- $(lisp)/calc/calc-math.elc \
- $(lisp)/calc/calc-menu.elc \
- $(lisp)/calc/calc-misc.elc \
- $(lisp)/calc/calc-mode.elc \
- $(lisp)/calc/calc-mtx.elc \
- $(lisp)/calc/calc-nlfit.elc \
- $(lisp)/calc/calc-poly.elc \
- $(lisp)/calc/calc-prog.elc \
- $(lisp)/calc/calc-rewr.elc \
- $(lisp)/calc/calc-rules.elc \
- $(lisp)/calc/calc-sel.elc \
- $(lisp)/calc/calc-stat.elc \
- $(lisp)/calc/calc-store.elc \
- $(lisp)/calc/calc-stuff.elc \
- $(lisp)/calc/calc-trail.elc \
- $(lisp)/calc/calc-undo.elc \
- $(lisp)/calc/calc-units.elc \
- $(lisp)/calc/calc-vec.elc \
- $(lisp)/calc/calc-yank.elc \
- $(lisp)/calc/calc.elc \
- $(lisp)/calc/calcalg2.elc \
- $(lisp)/calc/calcalg3.elc \
- $(lisp)/calc/calccomp.elc \
- $(lisp)/calc/calcsel2.elc \
- $(lisp)/calculator.elc \
- $(lisp)/calendar/appt.elc \
- $(lisp)/calendar/cal-bahai.elc \
- $(lisp)/calendar/cal-china.elc \
- $(lisp)/calendar/cal-coptic.elc \
- $(lisp)/calendar/cal-dst.elc \
- $(lisp)/calendar/cal-french.elc \
- $(lisp)/calendar/cal-hebrew.elc \
- $(lisp)/calendar/cal-html.elc \
- $(lisp)/calendar/cal-islam.elc \
- $(lisp)/calendar/cal-iso.elc \
- $(lisp)/calendar/cal-julian.elc \
- $(lisp)/calendar/cal-mayan.elc \
- $(lisp)/calendar/cal-menu.elc \
- $(lisp)/calendar/cal-move.elc \
- $(lisp)/calendar/cal-persia.elc \
- $(lisp)/calendar/cal-tex.elc \
- $(lisp)/calendar/cal-x.elc \
- $(lisp)/calendar/calendar.elc \
- $(lisp)/calendar/diary-lib.elc \
- $(lisp)/calendar/holidays.elc \
- $(lisp)/calendar/icalendar.elc \
- $(lisp)/calendar/lunar.elc \
- $(lisp)/calendar/parse-time.elc \
- $(lisp)/calendar/solar.elc \
- $(lisp)/calendar/time-date.elc \
- $(lisp)/calendar/timeclock.elc \
- $(lisp)/calendar/todo-mode.elc \
- $(lisp)/case-table.elc \
- $(lisp)/cdl.elc \
- $(lisp)/cedet/cedet-cscope.elc \
- $(lisp)/cedet/cedet-files.elc \
- $(lisp)/cedet/cedet-global.elc \
- $(lisp)/cedet/cedet-idutils.elc \
- $(lisp)/cedet/cedet.elc \
- $(lisp)/cedet/data-debug.elc \
- $(lisp)/cedet/ede.elc \
- $(lisp)/cedet/ede/auto.elc \
- $(lisp)/cedet/ede/autoconf-edit.elc \
- $(lisp)/cedet/ede/base.elc \
- $(lisp)/cedet/ede/cpp-root.elc \
- $(lisp)/cedet/ede/custom.elc \
- $(lisp)/cedet/ede/dired.elc \
- $(lisp)/cedet/ede/emacs.elc \
- $(lisp)/cedet/ede/files.elc \
- $(lisp)/cedet/ede/generic.elc \
- $(lisp)/cedet/ede/linux.elc \
- $(lisp)/cedet/ede/locate.elc \
- $(lisp)/cedet/ede/make.elc \
- $(lisp)/cedet/ede/makefile-edit.elc \
- $(lisp)/cedet/ede/pconf.elc \
- $(lisp)/cedet/ede/pmake.elc \
- $(lisp)/cedet/ede/proj-archive.elc \
- $(lisp)/cedet/ede/proj-aux.elc \
- $(lisp)/cedet/ede/proj-comp.elc \
- $(lisp)/cedet/ede/proj-elisp.elc \
- $(lisp)/cedet/ede/proj-info.elc \
- $(lisp)/cedet/ede/proj-misc.elc \
- $(lisp)/cedet/ede/proj-obj.elc \
- $(lisp)/cedet/ede/proj-prog.elc \
- $(lisp)/cedet/ede/proj-scheme.elc \
- $(lisp)/cedet/ede/proj-shared.elc \
- $(lisp)/cedet/ede/proj.elc \
- $(lisp)/cedet/ede/project-am.elc \
- $(lisp)/cedet/ede/shell.elc \
- $(lisp)/cedet/ede/simple.elc \
- $(lisp)/cedet/ede/source.elc \
- $(lisp)/cedet/ede/speedbar.elc \
- $(lisp)/cedet/ede/srecode.elc \
- $(lisp)/cedet/ede/system.elc \
- $(lisp)/cedet/ede/util.elc \
- $(lisp)/cedet/inversion.elc \
- $(lisp)/cedet/mode-local.elc \
- $(lisp)/cedet/pulse.elc \
- $(lisp)/cedet/semantic.elc \
- $(lisp)/cedet/semantic/analyze.elc \
- $(lisp)/cedet/semantic/analyze/complete.elc \
- $(lisp)/cedet/semantic/analyze/debug.elc \
- $(lisp)/cedet/semantic/analyze/fcn.elc \
- $(lisp)/cedet/semantic/analyze/refs.elc \
- $(lisp)/cedet/semantic/bovine.elc \
- $(lisp)/cedet/semantic/bovine/c-by.elc \
- $(lisp)/cedet/semantic/bovine/c.elc \
- $(lisp)/cedet/semantic/bovine/debug.elc \
- $(lisp)/cedet/semantic/bovine/el.elc \
- $(lisp)/cedet/semantic/bovine/gcc.elc \
- $(lisp)/cedet/semantic/bovine/make-by.elc \
- $(lisp)/cedet/semantic/bovine/make.elc \
- $(lisp)/cedet/semantic/bovine/scm-by.elc \
- $(lisp)/cedet/semantic/bovine/scm.elc \
- $(lisp)/cedet/semantic/chart.elc \
- $(lisp)/cedet/semantic/complete.elc \
- $(lisp)/cedet/semantic/ctxt.elc \
- $(lisp)/cedet/semantic/db-debug.elc \
- $(lisp)/cedet/semantic/db-ebrowse.elc \
- $(lisp)/cedet/semantic/db-el.elc \
- $(lisp)/cedet/semantic/db-file.elc \
- $(lisp)/cedet/semantic/db-find.elc \
- $(lisp)/cedet/semantic/db-global.elc \
- $(lisp)/cedet/semantic/db-javascript.elc \
- $(lisp)/cedet/semantic/db-mode.elc \
- $(lisp)/cedet/semantic/db-ref.elc \
- $(lisp)/cedet/semantic/db-typecache.elc \
- $(lisp)/cedet/semantic/db.elc \
- $(lisp)/cedet/semantic/debug.elc \
- $(lisp)/cedet/semantic/decorate.elc \
- $(lisp)/cedet/semantic/decorate/include.elc \
- $(lisp)/cedet/semantic/decorate/mode.elc \
- $(lisp)/cedet/semantic/dep.elc \
- $(lisp)/cedet/semantic/doc.elc \
- $(lisp)/cedet/semantic/ede-grammar.elc \
- $(lisp)/cedet/semantic/edit.elc \
- $(lisp)/cedet/semantic/find.elc \
- $(lisp)/cedet/semantic/format.elc \
- $(lisp)/cedet/semantic/fw.elc \
- $(lisp)/cedet/semantic/grammar-wy.elc \
- $(lisp)/cedet/semantic/grammar.elc \
- $(lisp)/cedet/semantic/html.elc \
- $(lisp)/cedet/semantic/ia-sb.elc \
- $(lisp)/cedet/semantic/ia.elc \
- $(lisp)/cedet/semantic/idle.elc \
- $(lisp)/cedet/semantic/imenu.elc \
- $(lisp)/cedet/semantic/java.elc \
- $(lisp)/cedet/semantic/lex-spp.elc \
- $(lisp)/cedet/semantic/lex.elc \
- $(lisp)/cedet/semantic/mru-bookmark.elc \
- $(lisp)/cedet/semantic/sb.elc \
- $(lisp)/cedet/semantic/scope.elc \
- $(lisp)/cedet/semantic/senator.elc \
- $(lisp)/cedet/semantic/sort.elc \
- $(lisp)/cedet/semantic/symref.elc \
- $(lisp)/cedet/semantic/symref/cscope.elc \
- $(lisp)/cedet/semantic/symref/filter.elc \
- $(lisp)/cedet/semantic/symref/global.elc \
- $(lisp)/cedet/semantic/symref/grep.elc \
- $(lisp)/cedet/semantic/symref/idutils.elc \
- $(lisp)/cedet/semantic/symref/list.elc \
- $(lisp)/cedet/semantic/tag-file.elc \
- $(lisp)/cedet/semantic/tag-ls.elc \
- $(lisp)/cedet/semantic/tag-write.elc \
- $(lisp)/cedet/semantic/tag.elc \
- $(lisp)/cedet/semantic/texi.elc \
- $(lisp)/cedet/semantic/util-modes.elc \
- $(lisp)/cedet/semantic/util.elc \
- $(lisp)/cedet/semantic/wisent.elc \
- $(lisp)/cedet/semantic/wisent/comp.elc \
- $(lisp)/cedet/semantic/wisent/java-tags.elc \
- $(lisp)/cedet/semantic/wisent/javascript.elc \
- $(lisp)/cedet/semantic/wisent/javat-wy.elc \
- $(lisp)/cedet/semantic/wisent/js-wy.elc \
- $(lisp)/cedet/semantic/wisent/python-wy.elc \
- $(lisp)/cedet/semantic/wisent/python.elc \
- $(lisp)/cedet/semantic/wisent/wisent.elc \
- $(lisp)/cedet/srecode.elc \
- $(lisp)/cedet/srecode/args.elc \
- $(lisp)/cedet/srecode/compile.elc \
- $(lisp)/cedet/srecode/cpp.elc \
- $(lisp)/cedet/srecode/ctxt.elc \
- $(lisp)/cedet/srecode/dictionary.elc \
- $(lisp)/cedet/srecode/document.elc \
- $(lisp)/cedet/srecode/el.elc \
- $(lisp)/cedet/srecode/expandproto.elc \
- $(lisp)/cedet/srecode/extract.elc \
- $(lisp)/cedet/srecode/fields.elc \
- $(lisp)/cedet/srecode/filters.elc \
- $(lisp)/cedet/srecode/find.elc \
- $(lisp)/cedet/srecode/getset.elc \
- $(lisp)/cedet/srecode/insert.elc \
- $(lisp)/cedet/srecode/java.elc \
- $(lisp)/cedet/srecode/map.elc \
- $(lisp)/cedet/srecode/mode.elc \
- $(lisp)/cedet/srecode/semantic.elc \
- $(lisp)/cedet/srecode/srt-mode.elc \
- $(lisp)/cedet/srecode/srt-wy.elc \
- $(lisp)/cedet/srecode/srt.elc \
- $(lisp)/cedet/srecode/table.elc \
- $(lisp)/cedet/srecode/template.elc \
- $(lisp)/cedet/srecode/texi.elc \
- $(lisp)/chistory.elc \
- $(lisp)/cmuscheme.elc \
- $(lisp)/comint.elc \
- $(lisp)/compare-w.elc \
- $(lisp)/complete.elc \
- $(lisp)/completion.elc \
- $(lisp)/composite.elc \
- $(lisp)/cus-dep.elc \
- $(lisp)/cus-edit.elc \
- $(lisp)/cus-face.elc \
- $(lisp)/cus-start.elc \
- $(lisp)/cus-theme.elc \
- $(lisp)/custom.elc \
- $(lisp)/cvs-status.elc \
- $(lisp)/dabbrev.elc \
- $(lisp)/delim-col.elc \
- $(lisp)/delsel.elc \
- $(lisp)/descr-text.elc \
- $(lisp)/desktop.elc \
- $(lisp)/dframe.elc \
- $(lisp)/diff-mode.elc \
- $(lisp)/diff.elc \
- $(lisp)/dired-aux.elc \
- $(lisp)/dired-x.elc \
- $(lisp)/dired.elc \
- $(lisp)/dirtrack.elc \
- $(lisp)/disp-table.elc \
- $(lisp)/dnd.elc \
- $(lisp)/doc-view.elc \
- $(lisp)/dos-fns.elc \
- $(lisp)/dos-vars.elc \
- $(lisp)/dos-w32.elc \
- $(lisp)/double.elc \
- $(lisp)/ebuff-menu.elc \
- $(lisp)/echistory.elc \
- $(lisp)/ediff-diff.elc \
- $(lisp)/ediff-help.elc \
- $(lisp)/ediff-hook.elc \
- $(lisp)/ediff-init.elc \
- $(lisp)/ediff-merg.elc \
- $(lisp)/ediff-mult.elc \
- $(lisp)/ediff-ptch.elc \
- $(lisp)/ediff-util.elc \
- $(lisp)/ediff-vers.elc \
- $(lisp)/ediff-wind.elc \
- $(lisp)/ediff.elc \
- $(lisp)/edmacro.elc \
- $(lisp)/ehelp.elc \
- $(lisp)/electric.elc \
- $(lisp)/elide-head.elc \
- $(lisp)/emacs-lisp/advice.elc \
- $(lisp)/emacs-lisp/assoc.elc \
- $(lisp)/emacs-lisp/authors.elc \
- $(lisp)/emacs-lisp/autoload.elc \
- $(lisp)/emacs-lisp/avl-tree.elc \
- $(lisp)/emacs-lisp/backquote.elc \
- $(lisp)/emacs-lisp/benchmark.elc \
- $(lisp)/emacs-lisp/bindat.elc \
- $(lisp)/emacs-lisp/byte-opt.elc \
- $(lisp)/emacs-lisp/byte-run.elc \
- $(lisp)/emacs-lisp/bytecomp.elc \
- $(lisp)/emacs-lisp/chart.elc \
- $(lisp)/emacs-lisp/check-declare.elc \
- $(lisp)/emacs-lisp/checkdoc.elc \
- $(lisp)/emacs-lisp/cl-extra.elc \
- $(lisp)/emacs-lisp/cl-indent.elc \
- $(lisp)/emacs-lisp/cl-macs.elc \
- $(lisp)/emacs-lisp/cl-seq.elc \
- $(lisp)/emacs-lisp/cl.elc \
- $(lisp)/emacs-lisp/copyright.elc \
- $(lisp)/emacs-lisp/crm.elc \
- $(lisp)/emacs-lisp/cust-print.elc \
- $(lisp)/emacs-lisp/debug.elc \
- $(lisp)/emacs-lisp/derived.elc \
- $(lisp)/emacs-lisp/disass.elc \
- $(lisp)/emacs-lisp/easy-mmode.elc \
- $(lisp)/emacs-lisp/easymenu.elc \
- $(lisp)/emacs-lisp/edebug.elc \
- $(lisp)/emacs-lisp/eieio-base.elc \
- $(lisp)/emacs-lisp/eieio-comp.elc \
- $(lisp)/emacs-lisp/eieio-custom.elc \
- $(lisp)/emacs-lisp/eieio-datadebug.elc \
- $(lisp)/emacs-lisp/eieio-opt.elc \
- $(lisp)/emacs-lisp/eieio-speedbar.elc \
- $(lisp)/emacs-lisp/eieio.elc \
- $(lisp)/emacs-lisp/eldoc.elc \
- $(lisp)/emacs-lisp/elint.elc \
- $(lisp)/emacs-lisp/elp.elc \
- $(lisp)/emacs-lisp/ewoc.elc \
- $(lisp)/emacs-lisp/find-func.elc \
- $(lisp)/emacs-lisp/find-gc.elc \
- $(lisp)/emacs-lisp/float-sup.elc \
- $(lisp)/emacs-lisp/generic.elc \
- $(lisp)/emacs-lisp/gulp.elc \
- $(lisp)/emacs-lisp/helper.elc \
- $(lisp)/emacs-lisp/lisp-mnt.elc \
- $(lisp)/emacs-lisp/lisp-mode.elc \
- $(lisp)/emacs-lisp/lisp.elc \
- $(lisp)/emacs-lisp/macroexp.elc \
- $(lisp)/emacs-lisp/map-ynp.elc \
- $(lisp)/emacs-lisp/pp.elc \
- $(lisp)/emacs-lisp/re-builder.elc \
- $(lisp)/emacs-lisp/regexp-opt.elc \
- $(lisp)/emacs-lisp/regi.elc \
- $(lisp)/emacs-lisp/ring.elc \
- $(lisp)/emacs-lisp/rx.elc \
- $(lisp)/emacs-lisp/shadow.elc \
- $(lisp)/emacs-lisp/smie.elc \
- $(lisp)/emacs-lisp/sregex.elc \
- $(lisp)/emacs-lisp/syntax.elc \
- $(lisp)/emacs-lisp/tcover-ses.elc \
- $(lisp)/emacs-lisp/tcover-unsafep.elc \
- $(lisp)/emacs-lisp/testcover.elc \
- $(lisp)/emacs-lisp/timer.elc \
- $(lisp)/emacs-lisp/tq.elc \
- $(lisp)/emacs-lisp/trace.elc \
- $(lisp)/emacs-lisp/unsafep.elc \
- $(lisp)/emacs-lisp/warnings.elc \
- $(lisp)/emacs-lock.elc \
- $(lisp)/emerge.elc \
- $(lisp)/emulation/crisp.elc \
- $(lisp)/emulation/cua-base.elc \
- $(lisp)/emulation/cua-gmrk.elc \
- $(lisp)/emulation/cua-rect.elc \
- $(lisp)/emulation/edt-lk201.elc \
- $(lisp)/emulation/edt-mapper.elc \
- $(lisp)/emulation/edt-pc.elc \
- $(lisp)/emulation/edt-vt100.elc \
- $(lisp)/emulation/edt.elc \
- $(lisp)/emulation/keypad.elc \
- $(lisp)/emulation/pc-mode.elc \
- $(lisp)/emulation/pc-select.elc \
- $(lisp)/emulation/tpu-edt.elc \
- $(lisp)/emulation/tpu-extras.elc \
- $(lisp)/emulation/tpu-mapper.elc \
- $(lisp)/emulation/vi.elc \
- $(lisp)/emulation/vip.elc \
- $(lisp)/emulation/viper-cmd.elc \
- $(lisp)/emulation/viper-ex.elc \
- $(lisp)/emulation/viper-init.elc \
- $(lisp)/emulation/viper-keym.elc \
- $(lisp)/emulation/viper-macs.elc \
- $(lisp)/emulation/viper-mous.elc \
- $(lisp)/emulation/viper-util.elc \
- $(lisp)/emulation/viper.elc \
- $(lisp)/emulation/ws-mode.elc \
- $(lisp)/env.elc \
- $(lisp)/epa-dired.elc \
- $(lisp)/epa-file.elc \
- $(lisp)/epa-hook.elc \
- $(lisp)/epa-mail.elc \
- $(lisp)/epa.elc \
- $(lisp)/epg-config.elc \
- $(lisp)/epg.elc \
- $(lisp)/erc/erc-autoaway.elc \
- $(lisp)/erc/erc-backend.elc \
- $(lisp)/erc/erc-button.elc \
- $(lisp)/erc/erc-capab.elc \
- $(lisp)/erc/erc-compat.elc \
- $(lisp)/erc/erc-dcc.elc \
- $(lisp)/erc/erc-ezbounce.elc \
- $(lisp)/erc/erc-fill.elc \
- $(lisp)/erc/erc-goodies.elc \
- $(lisp)/erc/erc-hecomplete.elc \
- $(lisp)/erc/erc-ibuffer.elc \
- $(lisp)/erc/erc-identd.elc \
- $(lisp)/erc/erc-imenu.elc \
- $(lisp)/erc/erc-join.elc \
- $(lisp)/erc/erc-lang.elc \
- $(lisp)/erc/erc-list.elc \
- $(lisp)/erc/erc-log.elc \
- $(lisp)/erc/erc-match.elc \
- $(lisp)/erc/erc-menu.elc \
- $(lisp)/erc/erc-netsplit.elc \
- $(lisp)/erc/erc-networks.elc \
- $(lisp)/erc/erc-notify.elc \
- $(lisp)/erc/erc-page.elc \
- $(lisp)/erc/erc-pcomplete.elc \
- $(lisp)/erc/erc-replace.elc \
- $(lisp)/erc/erc-ring.elc \
- $(lisp)/erc/erc-services.elc \
- $(lisp)/erc/erc-sound.elc \
- $(lisp)/erc/erc-speedbar.elc \
- $(lisp)/erc/erc-spelling.elc \
- $(lisp)/erc/erc-stamp.elc \
- $(lisp)/erc/erc-track.elc \
- $(lisp)/erc/erc-truncate.elc \
- $(lisp)/erc/erc-xdcc.elc \
- $(lisp)/erc/erc.elc \
- $(lisp)/eshell/em-alias.elc \
- $(lisp)/eshell/em-banner.elc \
- $(lisp)/eshell/em-basic.elc \
- $(lisp)/eshell/em-cmpl.elc \
- $(lisp)/eshell/em-dirs.elc \
- $(lisp)/eshell/em-glob.elc \
- $(lisp)/eshell/em-hist.elc \
- $(lisp)/eshell/em-ls.elc \
- $(lisp)/eshell/em-pred.elc \
- $(lisp)/eshell/em-prompt.elc \
- $(lisp)/eshell/em-rebind.elc \
- $(lisp)/eshell/em-script.elc \
- $(lisp)/eshell/em-smart.elc \
- $(lisp)/eshell/em-term.elc \
- $(lisp)/eshell/em-unix.elc \
- $(lisp)/eshell/em-xtra.elc \
- $(lisp)/eshell/esh-arg.elc \
- $(lisp)/eshell/esh-cmd.elc \
- $(lisp)/eshell/esh-ext.elc \
- $(lisp)/eshell/esh-io.elc \
- $(lisp)/eshell/esh-mode.elc \
- $(lisp)/eshell/esh-module.elc \
- $(lisp)/eshell/esh-opt.elc \
- $(lisp)/eshell/esh-proc.elc \
- $(lisp)/eshell/esh-test.elc \
- $(lisp)/eshell/esh-util.elc \
- $(lisp)/eshell/esh-var.elc \
- $(lisp)/eshell/eshell.elc \
- $(lisp)/expand.elc \
- $(lisp)/ezimage.elc \
- $(lisp)/face-remap.elc \
- $(lisp)/facemenu.elc \
- $(lisp)/faces.elc \
- $(lisp)/ffap.elc \
- $(lisp)/filecache.elc \
- $(lisp)/files-x.elc \
- $(lisp)/files.elc \
- $(lisp)/filesets.elc \
- $(lisp)/find-cmd.elc \
- $(lisp)/find-dired.elc \
- $(lisp)/find-file.elc \
- $(lisp)/find-lisp.elc \
- $(lisp)/finder.elc \
- $(lisp)/flow-ctrl.elc \
- $(lisp)/foldout.elc \
- $(lisp)/follow.elc \
- $(lisp)/font-core.elc \
- $(lisp)/font-lock.elc \
- $(lisp)/font-setting.elc \
- $(lisp)/format-spec.elc \
- $(lisp)/format.elc \
- $(lisp)/forms.elc \
- $(lisp)/frame.elc \
- $(lisp)/fringe.elc \
- $(lisp)/generic-x.elc \
- $(lisp)/gnus/auth-source.elc \
- $(lisp)/gnus/canlock.elc \
- $(lisp)/gnus/compface.elc \
- $(lisp)/gnus/deuglify.elc \
- $(lisp)/gnus/earcon.elc \
- $(lisp)/gnus/ecomplete.elc \
- $(lisp)/gnus/flow-fill.elc \
- $(lisp)/gnus/gmm-utils.elc \
- $(lisp)/gnus/gnus-agent.elc \
- $(lisp)/gnus/gnus-art.elc \
- $(lisp)/gnus/gnus-async.elc \
- $(lisp)/gnus/gnus-audio.elc \
- $(lisp)/gnus/gnus-bcklg.elc \
- $(lisp)/gnus/gnus-bookmark.elc \
- $(lisp)/gnus/gnus-cache.elc \
- $(lisp)/gnus/gnus-cite.elc \
- $(lisp)/gnus/gnus-cus.elc \
- $(lisp)/gnus/gnus-delay.elc \
- $(lisp)/gnus/gnus-demon.elc \
- $(lisp)/gnus/gnus-diary.elc \
- $(lisp)/gnus/gnus-dired.elc \
- $(lisp)/gnus/gnus-draft.elc \
- $(lisp)/gnus/gnus-dup.elc \
- $(lisp)/gnus/gnus-eform.elc \
- $(lisp)/gnus/gnus-ems.elc \
- $(lisp)/gnus/gnus-fun.elc \
- $(lisp)/gnus/gnus-group.elc \
- $(lisp)/gnus/gnus-int.elc \
- $(lisp)/gnus/gnus-kill.elc \
- $(lisp)/gnus/gnus-logic.elc \
- $(lisp)/gnus/gnus-mh.elc \
- $(lisp)/gnus/gnus-ml.elc \
- $(lisp)/gnus/gnus-mlspl.elc \
- $(lisp)/gnus/gnus-move.elc \
- $(lisp)/gnus/gnus-msg.elc \
- $(lisp)/gnus/gnus-nocem.elc \
- $(lisp)/gnus/gnus-picon.elc \
- $(lisp)/gnus/gnus-range.elc \
- $(lisp)/gnus/gnus-registry.elc \
- $(lisp)/gnus/gnus-salt.elc \
- $(lisp)/gnus/gnus-score.elc \
- $(lisp)/gnus/gnus-setup.elc \
- $(lisp)/gnus/gnus-sieve.elc \
- $(lisp)/gnus/gnus-soup.elc \
- $(lisp)/gnus/gnus-spec.elc \
- $(lisp)/gnus/gnus-srvr.elc \
- $(lisp)/gnus/gnus-start.elc \
- $(lisp)/gnus/gnus-sum.elc \
- $(lisp)/gnus/gnus-topic.elc \
- $(lisp)/gnus/gnus-undo.elc \
- $(lisp)/gnus/gnus-util.elc \
- $(lisp)/gnus/gnus-uu.elc \
- $(lisp)/gnus/gnus-vm.elc \
- $(lisp)/gnus/gnus-win.elc \
- $(lisp)/gnus/gnus.elc \
- $(lisp)/gnus/html2text.elc \
- $(lisp)/gnus/ietf-drums.elc \
- $(lisp)/gnus/legacy-gnus-agent.elc \
- $(lisp)/gnus/mail-parse.elc \
- $(lisp)/gnus/mail-prsvr.elc \
- $(lisp)/gnus/mail-source.elc \
- $(lisp)/gnus/mailcap.elc \
- $(lisp)/gnus/message.elc \
- $(lisp)/gnus/messcompat.elc \
- $(lisp)/gnus/mm-bodies.elc \
- $(lisp)/gnus/mm-decode.elc \
- $(lisp)/gnus/mm-encode.elc \
- $(lisp)/gnus/mm-extern.elc \
- $(lisp)/gnus/mm-partial.elc \
- $(lisp)/gnus/mm-url.elc \
- $(lisp)/gnus/mm-util.elc \
- $(lisp)/gnus/mm-uu.elc \
- $(lisp)/gnus/mm-view.elc \
- $(lisp)/gnus/mml-sec.elc \
- $(lisp)/gnus/mml-smime.elc \
- $(lisp)/gnus/mml.elc \
- $(lisp)/gnus/mml1991.elc \
- $(lisp)/gnus/mml2015.elc \
- $(lisp)/gnus/nnagent.elc \
- $(lisp)/gnus/nnbabyl.elc \
- $(lisp)/gnus/nndb.elc \
- $(lisp)/gnus/nndiary.elc \
- $(lisp)/gnus/nndir.elc \
- $(lisp)/gnus/nndoc.elc \
- $(lisp)/gnus/nndraft.elc \
- $(lisp)/gnus/nneething.elc \
- $(lisp)/gnus/nnfolder.elc \
- $(lisp)/gnus/nngateway.elc \
- $(lisp)/gnus/nnheader.elc \
- $(lisp)/gnus/nnimap.elc \
- $(lisp)/gnus/nnir.elc \
- $(lisp)/gnus/nnkiboze.elc \
- $(lisp)/gnus/nnlistserv.elc \
- $(lisp)/gnus/nnmail.elc \
- $(lisp)/gnus/nnmaildir.elc \
- $(lisp)/gnus/nnmairix.elc \
- $(lisp)/gnus/nnmbox.elc \
- $(lisp)/gnus/nnmh.elc \
- $(lisp)/gnus/nnml.elc \
- $(lisp)/gnus/nnnil.elc \
- $(lisp)/gnus/nnoo.elc \
- $(lisp)/gnus/nnrss.elc \
- $(lisp)/gnus/nnslashdot.elc \
- $(lisp)/gnus/nnsoup.elc \
- $(lisp)/gnus/nnspool.elc \
- $(lisp)/gnus/nntp.elc \
- $(lisp)/gnus/nnultimate.elc \
- $(lisp)/gnus/nnvirtual.elc \
- $(lisp)/gnus/nnwarchive.elc \
- $(lisp)/gnus/nnweb.elc \
- $(lisp)/gnus/nnwfm.elc \
- $(lisp)/gnus/pop3.elc \
- $(lisp)/gnus/qp.elc \
- $(lisp)/gnus/rfc1843.elc \
- $(lisp)/gnus/rfc2045.elc \
- $(lisp)/gnus/rfc2047.elc \
- $(lisp)/gnus/rfc2104.elc \
- $(lisp)/gnus/rfc2231.elc \
- $(lisp)/gnus/score-mode.elc \
- $(lisp)/gnus/sieve-manage.elc \
- $(lisp)/gnus/sieve-mode.elc \
- $(lisp)/gnus/sieve.elc \
- $(lisp)/gnus/smiley.elc \
- $(lisp)/gnus/smime.elc \
- $(lisp)/gnus/spam-report.elc \
- $(lisp)/gnus/spam-stat.elc \
- $(lisp)/gnus/spam-wash.elc \
- $(lisp)/gnus/spam.elc \
- $(lisp)/gnus/starttls.elc \
- $(lisp)/gnus/utf7.elc \
- $(lisp)/gnus/webmail.elc \
- $(lisp)/gnus/yenc.elc \
- $(lisp)/gs.elc \
- $(lisp)/help-at-pt.elc \
- $(lisp)/help-fns.elc \
- $(lisp)/help-macro.elc \
- $(lisp)/help-mode.elc \
- $(lisp)/help.elc \
- $(lisp)/hex-util.elc \
- $(lisp)/hexl.elc \
- $(lisp)/hfy-cmap.elc \
- $(lisp)/hi-lock.elc \
- $(lisp)/hilit-chg.elc \
- $(lisp)/hippie-exp.elc \
- $(lisp)/hl-line.elc \
- $(lisp)/htmlfontify.elc \
- $(lisp)/ibuf-ext.elc \
- $(lisp)/ibuf-macs.elc \
- $(lisp)/ibuffer.elc \
- $(lisp)/icomplete.elc \
- $(lisp)/ido.elc \
- $(lisp)/ielm.elc \
- $(lisp)/iimage.elc \
- $(lisp)/image-dired.elc \
- $(lisp)/image-file.elc \
- $(lisp)/image-mode.elc \
- $(lisp)/image.elc \
- $(lisp)/imenu.elc \
- $(lisp)/indent.elc \
- $(lisp)/info-look.elc \
- $(lisp)/info-xref.elc \
- $(lisp)/info.elc \
- $(lisp)/informat.elc \
- $(lisp)/international/ccl.elc \
- $(lisp)/international/characters.elc \
- $(lisp)/international/fontset.elc \
- $(lisp)/international/isearch-x.elc \
- $(lisp)/international/iso-ascii.elc \
- $(lisp)/international/iso-cvt.elc \
- $(lisp)/international/iso-transl.elc \
- $(lisp)/international/ja-dic-cnv.elc \
- $(lisp)/international/ja-dic-utl.elc \
- $(lisp)/international/kinsoku.elc \
- $(lisp)/international/kkc.elc \
- $(lisp)/international/latexenc.elc \
- $(lisp)/international/latin1-disp.elc \
- $(lisp)/international/mule-cmds.elc \
- $(lisp)/international/mule-conf.elc \
- $(lisp)/international/mule-diag.elc \
- $(lisp)/international/mule-util.elc \
- $(lisp)/international/mule.elc \
- $(lisp)/international/ogonek.elc \
- $(lisp)/international/quail.elc \
- $(lisp)/international/robin.elc \
- $(lisp)/international/titdic-cnv.elc \
- $(lisp)/international/ucs-normalize.elc \
- $(lisp)/international/utf-7.elc \
- $(lisp)/isearch.elc \
- $(lisp)/isearchb.elc \
- $(lisp)/iswitchb.elc \
- $(lisp)/jit-lock.elc \
- $(lisp)/jka-cmpr-hook.elc \
- $(lisp)/jka-compr.elc \
- $(lisp)/json.elc \
- $(lisp)/kermit.elc \
- $(lisp)/kmacro.elc \
- $(lisp)/language/china-util.elc \
- $(lisp)/language/chinese.elc \
- $(lisp)/language/cyril-util.elc \
- $(lisp)/language/cyrillic.elc \
- $(lisp)/language/ethio-util.elc \
- $(lisp)/language/ethiopic.elc \
- $(lisp)/language/european.elc \
- $(lisp)/language/hanja-util.elc \
- $(lisp)/language/ind-util.elc \
- $(lisp)/language/indian.elc \
- $(lisp)/language/japan-util.elc \
- $(lisp)/language/korea-util.elc \
- $(lisp)/language/lao-util.elc \
- $(lisp)/language/thai-util.elc \
- $(lisp)/language/thai-word.elc \
- $(lisp)/language/tibet-util.elc \
- $(lisp)/language/tibetan.elc \
- $(lisp)/language/tv-util.elc \
- $(lisp)/language/viet-util.elc \
- $(lisp)/language/vietnamese.elc \
- $(lisp)/ledit.elc \
- $(lisp)/linum.elc \
- $(lisp)/loadhist.elc \
- $(lisp)/locate.elc \
- $(lisp)/log-edit.elc \
- $(lisp)/log-view.elc \
- $(lisp)/longlines.elc \
- $(lisp)/lpr.elc \
- $(lisp)/ls-lisp.elc \
- $(lisp)/macros.elc \
- $(lisp)/mail/binhex.elc \
- $(lisp)/mail/emacsbug.elc \
- $(lisp)/mail/feedmail.elc \
- $(lisp)/mail/footnote.elc \
- $(lisp)/mail/hashcash.elc \
- $(lisp)/mail/mail-extr.elc \
- $(lisp)/mail/mail-hist.elc \
- $(lisp)/mail/mail-utils.elc \
- $(lisp)/mail/mailabbrev.elc \
- $(lisp)/mail/mailalias.elc \
- $(lisp)/mail/mailclient.elc \
- $(lisp)/mail/mailheader.elc \
- $(lisp)/mail/mailpost.elc \
- $(lisp)/mail/metamail.elc \
- $(lisp)/mail/mspools.elc \
- $(lisp)/mail/reporter.elc \
- $(lisp)/mail/rfc2368.elc \
- $(lisp)/mail/rfc822.elc \
- $(lisp)/mail/rmail-spam-filter.elc \
- $(lisp)/mail/rmail.elc \
- $(lisp)/mail/rmailedit.elc \
- $(lisp)/mail/rmailkwd.elc \
- $(lisp)/mail/rmailmm.elc \
- $(lisp)/mail/rmailmsc.elc \
- $(lisp)/mail/rmailout.elc \
- $(lisp)/mail/rmailsort.elc \
- $(lisp)/mail/rmailsum.elc \
- $(lisp)/mail/sendmail.elc \
- $(lisp)/mail/smtpmail.elc \
- $(lisp)/mail/supercite.elc \
- $(lisp)/mail/uce.elc \
- $(lisp)/mail/undigest.elc \
- $(lisp)/mail/unrmail.elc \
- $(lisp)/mail/uudecode.elc \
- $(lisp)/makesum.elc \
- $(lisp)/man.elc \
- $(lisp)/master.elc \
- $(lisp)/mb-depth.elc \
- $(lisp)/md4.elc \
- $(lisp)/menu-bar.elc \
- $(lisp)/mh-e/mh-alias.elc \
- $(lisp)/mh-e/mh-buffers.elc \
- $(lisp)/mh-e/mh-comp.elc \
- $(lisp)/mh-e/mh-e.elc \
- $(lisp)/mh-e/mh-folder.elc \
- $(lisp)/mh-e/mh-funcs.elc \
- $(lisp)/mh-e/mh-identity.elc \
- $(lisp)/mh-e/mh-inc.elc \
- $(lisp)/mh-e/mh-junk.elc \
- $(lisp)/mh-e/mh-letter.elc \
- $(lisp)/mh-e/mh-limit.elc \
- $(lisp)/mh-e/mh-mime.elc \
- $(lisp)/mh-e/mh-print.elc \
- $(lisp)/mh-e/mh-scan.elc \
- $(lisp)/mh-e/mh-search.elc \
- $(lisp)/mh-e/mh-seq.elc \
- $(lisp)/mh-e/mh-show.elc \
- $(lisp)/mh-e/mh-speed.elc \
- $(lisp)/mh-e/mh-thread.elc \
- $(lisp)/mh-e/mh-tool-bar.elc \
- $(lisp)/mh-e/mh-utils.elc \
- $(lisp)/mh-e/mh-xface.elc \
- $(lisp)/midnight.elc \
- $(lisp)/minibuf-eldef.elc \
- $(lisp)/minibuffer.elc \
- $(lisp)/misc.elc \
- $(lisp)/misearch.elc \
- $(lisp)/mouse-copy.elc \
- $(lisp)/mouse-drag.elc \
- $(lisp)/mouse-sel.elc \
- $(lisp)/mouse.elc \
- $(lisp)/mpc.elc \
- $(lisp)/msb.elc \
- $(lisp)/mwheel.elc \
- $(lisp)/net/ange-ftp.elc \
- $(lisp)/net/browse-url.elc \
- $(lisp)/net/dbus.elc \
- $(lisp)/net/dig.elc \
- $(lisp)/net/dns.elc \
- $(lisp)/net/eudc-bob.elc \
- $(lisp)/net/eudc-export.elc \
- $(lisp)/net/eudc-hotlist.elc \
- $(lisp)/net/eudc-vars.elc \
- $(lisp)/net/eudc.elc \
- $(lisp)/net/eudcb-bbdb.elc \
- $(lisp)/net/eudcb-ldap.elc \
- $(lisp)/net/eudcb-mab.elc \
- $(lisp)/net/eudcb-ph.elc \
- $(lisp)/net/goto-addr.elc \
- $(lisp)/net/hmac-def.elc \
- $(lisp)/net/hmac-md5.elc \
- $(lisp)/net/imap-hash.elc \
- $(lisp)/net/imap.elc \
- $(lisp)/net/ldap.elc \
- $(lisp)/net/mairix.elc \
- $(lisp)/net/net-utils.elc \
- $(lisp)/net/netrc.elc \
- $(lisp)/net/newst-backend.elc \
- $(lisp)/net/newst-plainview.elc \
- $(lisp)/net/newst-reader.elc \
- $(lisp)/net/newst-ticker.elc \
- $(lisp)/net/newst-treeview.elc \
- $(lisp)/net/newsticker.elc \
- $(lisp)/net/ntlm.elc \
- $(lisp)/net/quickurl.elc \
- $(lisp)/net/rcirc.elc \
- $(lisp)/net/rcompile.elc \
- $(lisp)/net/rlogin.elc \
- $(lisp)/net/sasl-cram.elc \
- $(lisp)/net/sasl-digest.elc \
- $(lisp)/net/sasl-ntlm.elc \
- $(lisp)/net/sasl.elc \
- $(lisp)/net/snmp-mode.elc \
- $(lisp)/net/socks.elc \
- $(lisp)/net/telnet.elc \
- $(lisp)/net/tls.elc \
- $(lisp)/net/tramp-cache.elc \
- $(lisp)/net/tramp-cmds.elc \
- $(lisp)/net/tramp-compat.elc \
- $(lisp)/net/tramp-fish.elc \
- $(lisp)/net/tramp-ftp.elc \
- $(lisp)/net/tramp-gvfs.elc \
- $(lisp)/net/tramp-gw.elc \
- $(lisp)/net/tramp-imap.elc \
- $(lisp)/net/tramp-smb.elc \
- $(lisp)/net/tramp-uu.elc \
- $(lisp)/net/tramp.elc \
- $(lisp)/net/trampver.elc \
- $(lisp)/net/webjump.elc \
- $(lisp)/net/xesam.elc \
- $(lisp)/net/zeroconf.elc \
- $(lisp)/newcomment.elc \
- $(lisp)/novice.elc \
- $(lisp)/nxml/nxml-enc.elc \
- $(lisp)/nxml/nxml-glyph.elc \
- $(lisp)/nxml/nxml-maint.elc \
- $(lisp)/nxml/nxml-mode.elc \
- $(lisp)/nxml/nxml-ns.elc \
- $(lisp)/nxml/nxml-outln.elc \
- $(lisp)/nxml/nxml-parse.elc \
- $(lisp)/nxml/nxml-rap.elc \
- $(lisp)/nxml/nxml-uchnm.elc \
- $(lisp)/nxml/nxml-util.elc \
- $(lisp)/nxml/rng-cmpct.elc \
- $(lisp)/nxml/rng-dt.elc \
- $(lisp)/nxml/rng-loc.elc \
- $(lisp)/nxml/rng-maint.elc \
- $(lisp)/nxml/rng-match.elc \
- $(lisp)/nxml/rng-nxml.elc \
- $(lisp)/nxml/rng-parse.elc \
- $(lisp)/nxml/rng-pttrn.elc \
- $(lisp)/nxml/rng-uri.elc \
- $(lisp)/nxml/rng-util.elc \
- $(lisp)/nxml/rng-valid.elc \
- $(lisp)/nxml/rng-xsd.elc \
- $(lisp)/nxml/xmltok.elc \
- $(lisp)/nxml/xsd-regexp.elc \
- $(lisp)/obsolete/awk-mode.elc \
- $(lisp)/obsolete/cl-compat.elc \
- $(lisp)/obsolete/fast-lock.elc \
- $(lisp)/obsolete/iso-acc.elc \
- $(lisp)/obsolete/iso-insert.elc \
- $(lisp)/obsolete/iso-swed.elc \
- $(lisp)/obsolete/lazy-lock.elc \
- $(lisp)/obsolete/levents.elc \
- $(lisp)/obsolete/lmenu.elc \
- $(lisp)/obsolete/lucid.elc \
- $(lisp)/obsolete/old-whitespace.elc \
- $(lisp)/obsolete/options.elc \
- $(lisp)/obsolete/resume.elc \
- $(lisp)/obsolete/rnews.elc \
- $(lisp)/obsolete/rnewspost.elc \
- $(lisp)/obsolete/sc.elc \
- $(lisp)/obsolete/scribe.elc \
- $(lisp)/obsolete/swedish.elc \
- $(lisp)/obsolete/sym-comp.elc \
- $(lisp)/obsolete/vc-mcvs.elc \
- $(lisp)/obsolete/x-menu.elc \
- $(lisp)/org/org-agenda.elc \
- $(lisp)/org/org-archive.elc \
- $(lisp)/org/org-ascii.elc \
- $(lisp)/org/org-attach.elc \
- $(lisp)/org/org-bbdb.elc \
- $(lisp)/org/org-bibtex.elc \
- $(lisp)/org/org-clock.elc \
- $(lisp)/org/org-colview.elc \
- $(lisp)/org/org-compat.elc \
- $(lisp)/org/org-crypt.elc \
- $(lisp)/org/org-datetree.elc \
- $(lisp)/org/org-docbook.elc \
- $(lisp)/org/org-exp-blocks.elc \
- $(lisp)/org/org-exp.elc \
- $(lisp)/org/org-faces.elc \
- $(lisp)/org/org-feed.elc \
- $(lisp)/org/org-footnote.elc \
- $(lisp)/org/org-freemind.elc \
- $(lisp)/org/org-gnus.elc \
- $(lisp)/org/org-habit.elc \
- $(lisp)/org/org-html.elc \
- $(lisp)/org/org-icalendar.elc \
- $(lisp)/org/org-id.elc \
- $(lisp)/org/org-indent.elc \
- $(lisp)/org/org-info.elc \
- $(lisp)/org/org-inlinetask.elc \
- $(lisp)/org/org-install.elc \
- $(lisp)/org/org-irc.elc \
- $(lisp)/org/org-jsinfo.elc \
- $(lisp)/org/org-latex.elc \
- $(lisp)/org/org-list.elc \
- $(lisp)/org/org-mac-message.elc \
- $(lisp)/org/org-macs.elc \
- $(lisp)/org/org-mew.elc \
- $(lisp)/org/org-mhe.elc \
- $(lisp)/org/org-mobile.elc \
- $(lisp)/org/org-mouse.elc \
- $(lisp)/org/org-plot.elc \
- $(lisp)/org/org-protocol.elc \
- $(lisp)/org/org-publish.elc \
- $(lisp)/org/org-remember.elc \
- $(lisp)/org/org-rmail.elc \
- $(lisp)/org/org-src.elc \
- $(lisp)/org/org-table.elc \
- $(lisp)/org/org-timer.elc \
- $(lisp)/org/org-vm.elc \
- $(lisp)/org/org-w3m.elc \
- $(lisp)/org/org-wl.elc \
- $(lisp)/org/org-xoxo.elc \
- $(lisp)/org/org.elc \
- $(lisp)/outline.elc \
- $(lisp)/paren.elc \
- $(lisp)/password-cache.elc \
- $(lisp)/pcmpl-cvs.elc \
- $(lisp)/pcmpl-gnu.elc \
- $(lisp)/pcmpl-linux.elc \
- $(lisp)/pcmpl-rpm.elc \
- $(lisp)/pcmpl-unix.elc \
- $(lisp)/pcomplete.elc \
- $(lisp)/pcvs-defs.elc \
- $(lisp)/pcvs-info.elc \
- $(lisp)/pcvs-parse.elc \
- $(lisp)/pcvs-util.elc \
- $(lisp)/pcvs.elc \
- $(lisp)/pgg-def.elc \
- $(lisp)/pgg-gpg.elc \
- $(lisp)/pgg-parse.elc \
- $(lisp)/pgg-pgp.elc \
- $(lisp)/pgg-pgp5.elc \
- $(lisp)/pgg.elc \
- $(lisp)/play/5x5.elc \
- $(lisp)/play/animate.elc \
- $(lisp)/play/blackbox.elc \
- $(lisp)/play/bubbles.elc \
- $(lisp)/play/cookie1.elc \
- $(lisp)/play/decipher.elc \
- $(lisp)/play/dissociate.elc \
- $(lisp)/play/doctor.elc \
- $(lisp)/play/dunnet.elc \
- $(lisp)/play/fortune.elc \
- $(lisp)/play/gamegrid.elc \
- $(lisp)/play/gametree.elc \
- $(lisp)/play/gomoku.elc \
- $(lisp)/play/handwrite.elc \
- $(lisp)/play/hanoi.elc \
- $(lisp)/play/landmark.elc \
- $(lisp)/play/life.elc \
- $(lisp)/play/meese.elc \
- $(lisp)/play/morse.elc \
- $(lisp)/play/mpuz.elc \
- $(lisp)/play/pong.elc \
- $(lisp)/play/snake.elc \
- $(lisp)/play/solitaire.elc \
- $(lisp)/play/spook.elc \
- $(lisp)/play/studly.elc \
- $(lisp)/play/tetris.elc \
- $(lisp)/play/yow.elc \
- $(lisp)/play/zone.elc \
- $(lisp)/printing.elc \
- $(lisp)/proced.elc \
- $(lisp)/progmodes/ada-mode.elc \
- $(lisp)/progmodes/ada-prj.elc \
- $(lisp)/progmodes/ada-stmt.elc \
- $(lisp)/progmodes/ada-xref.elc \
- $(lisp)/progmodes/antlr-mode.elc \
- $(lisp)/progmodes/asm-mode.elc \
- $(lisp)/progmodes/autoconf.elc \
- $(lisp)/progmodes/bug-reference.elc \
- $(lisp)/progmodes/cap-words.elc \
- $(lisp)/progmodes/cc-align.elc \
- $(lisp)/progmodes/cc-awk.elc \
- $(lisp)/progmodes/cc-bytecomp.elc \
- $(lisp)/progmodes/cc-cmds.elc \
- $(lisp)/progmodes/cc-compat.elc \
- $(lisp)/progmodes/cc-defs.elc \
- $(lisp)/progmodes/cc-engine.elc \
- $(lisp)/progmodes/cc-fonts.elc \
- $(lisp)/progmodes/cc-langs.elc \
- $(lisp)/progmodes/cc-menus.elc \
- $(lisp)/progmodes/cc-mode.elc \
- $(lisp)/progmodes/cc-styles.elc \
- $(lisp)/progmodes/cc-vars.elc \
- $(lisp)/progmodes/cfengine.elc \
- $(lisp)/progmodes/cmacexp.elc \
- $(lisp)/progmodes/compile.elc \
- $(lisp)/progmodes/cperl-mode.elc \
- $(lisp)/progmodes/cpp.elc \
- $(lisp)/progmodes/cwarn.elc \
- $(lisp)/progmodes/dcl-mode.elc \
- $(lisp)/progmodes/delphi.elc \
- $(lisp)/progmodes/ebnf-abn.elc \
- $(lisp)/progmodes/ebnf-bnf.elc \
- $(lisp)/progmodes/ebnf-dtd.elc \
- $(lisp)/progmodes/ebnf-ebx.elc \
- $(lisp)/progmodes/ebnf-iso.elc \
- $(lisp)/progmodes/ebnf-otz.elc \
- $(lisp)/progmodes/ebnf-yac.elc \
- $(lisp)/progmodes/ebnf2ps.elc \
- $(lisp)/progmodes/ebrowse.elc \
- $(lisp)/progmodes/etags.elc \
- $(lisp)/progmodes/executable.elc \
- $(lisp)/progmodes/f90.elc \
- $(lisp)/progmodes/flymake.elc \
- $(lisp)/progmodes/fortran.elc \
- $(lisp)/progmodes/gdb-ui.elc \
- $(lisp)/progmodes/glasses.elc \
- $(lisp)/progmodes/grep.elc \
- $(lisp)/progmodes/gud.elc \
- $(lisp)/progmodes/hideif.elc \
- $(lisp)/progmodes/hideshow.elc \
- $(lisp)/progmodes/icon.elc \
- $(lisp)/progmodes/idlw-complete-structtag.elc \
- $(lisp)/progmodes/idlw-help.elc \
- $(lisp)/progmodes/idlw-shell.elc \
- $(lisp)/progmodes/idlw-toolbar.elc \
- $(lisp)/progmodes/idlwave.elc \
- $(lisp)/progmodes/inf-lisp.elc \
- $(lisp)/progmodes/js.elc \
- $(lisp)/progmodes/ld-script.elc \
- $(lisp)/progmodes/m4-mode.elc \
- $(lisp)/progmodes/make-mode.elc \
- $(lisp)/progmodes/mantemp.elc \
- $(lisp)/progmodes/meta-mode.elc \
- $(lisp)/progmodes/mixal-mode.elc \
- $(lisp)/progmodes/modula2.elc \
- $(lisp)/progmodes/octave-inf.elc \
- $(lisp)/progmodes/octave-mod.elc \
- $(lisp)/progmodes/pascal.elc \
- $(lisp)/progmodes/perl-mode.elc \
- $(lisp)/progmodes/prolog.elc \
- $(lisp)/progmodes/ps-mode.elc \
- $(lisp)/progmodes/python.elc \
- $(lisp)/progmodes/ruby-mode.elc \
- $(lisp)/progmodes/scheme.elc \
- $(lisp)/progmodes/sh-script.elc \
- $(lisp)/progmodes/simula.elc \
- $(lisp)/progmodes/sql.elc \
- $(lisp)/progmodes/subword.elc \
- $(lisp)/progmodes/tcl.elc \
- $(lisp)/progmodes/vera-mode.elc \
- $(lisp)/progmodes/verilog-mode.elc \
- $(lisp)/progmodes/vhdl-mode.elc \
- $(lisp)/progmodes/which-func.elc \
- $(lisp)/progmodes/xscheme.elc \
- $(lisp)/ps-bdf.elc \
- $(lisp)/ps-def.elc \
- $(lisp)/ps-mule.elc \
- $(lisp)/ps-print.elc \
- $(lisp)/ps-samp.elc \
- $(lisp)/recentf.elc \
- $(lisp)/rect.elc \
- $(lisp)/register.elc \
- $(lisp)/repeat.elc \
- $(lisp)/replace.elc \
- $(lisp)/reposition.elc \
- $(lisp)/reveal.elc \
- $(lisp)/rfn-eshadow.elc \
- $(lisp)/rot13.elc \
- $(lisp)/ruler-mode.elc \
- $(lisp)/s-region.elc \
- $(lisp)/savehist.elc \
- $(lisp)/saveplace.elc \
- $(lisp)/sb-image.elc \
- $(lisp)/scroll-all.elc \
- $(lisp)/scroll-bar.elc \
- $(lisp)/scroll-lock.elc \
- $(lisp)/select.elc \
- $(lisp)/server.elc \
- $(lisp)/ses.elc \
- $(lisp)/sha1.elc \
- $(lisp)/shadowfile.elc \
- $(lisp)/shell.elc \
- $(lisp)/simple.elc \
- $(lisp)/skeleton.elc \
- $(lisp)/smerge-mode.elc \
- $(lisp)/sort.elc \
- $(lisp)/soundex.elc \
- $(lisp)/speedbar.elc \
- $(lisp)/startup.elc \
- $(lisp)/strokes.elc \
- $(lisp)/subr.elc \
- $(lisp)/t-mouse.elc \
- $(lisp)/tabify.elc \
- $(lisp)/talk.elc \
- $(lisp)/tar-mode.elc \
- $(lisp)/tempo.elc \
- $(lisp)/term.elc \
- $(lisp)/term/common-win.elc \
- $(lisp)/term/internal.elc \
- $(lisp)/term/ns-win.elc \
- $(lisp)/term/pc-win.elc \
- $(lisp)/term/rxvt.elc \
- $(lisp)/term/sun.elc \
- $(lisp)/term/sup-mouse.elc \
- $(lisp)/term/tty-colors.elc \
- $(lisp)/term/tvi970.elc \
- $(lisp)/term/vt100.elc \
- $(lisp)/term/w32-win.elc \
- $(lisp)/term/w32console.elc \
- $(lisp)/term/x-win.elc \
- $(lisp)/term/xterm.elc \
- $(lisp)/terminal.elc \
- $(lisp)/textmodes/artist.elc \
- $(lisp)/textmodes/bib-mode.elc \
- $(lisp)/textmodes/bibtex-style.elc \
- $(lisp)/textmodes/bibtex.elc \
- $(lisp)/textmodes/conf-mode.elc \
- $(lisp)/textmodes/css-mode.elc \
- $(lisp)/textmodes/dns-mode.elc \
- $(lisp)/textmodes/enriched.elc \
- $(lisp)/textmodes/fill.elc \
- $(lisp)/textmodes/flyspell.elc \
- $(lisp)/textmodes/ispell.elc \
- $(lisp)/textmodes/makeinfo.elc \
- $(lisp)/textmodes/nroff-mode.elc \
- $(lisp)/textmodes/page-ext.elc \
- $(lisp)/textmodes/page.elc \
- $(lisp)/textmodes/paragraphs.elc \
- $(lisp)/textmodes/picture.elc \
- $(lisp)/textmodes/po.elc \
- $(lisp)/textmodes/refbib.elc \
- $(lisp)/textmodes/refer.elc \
- $(lisp)/textmodes/refill.elc \
- $(lisp)/textmodes/reftex-auc.elc \
- $(lisp)/textmodes/reftex-cite.elc \
- $(lisp)/textmodes/reftex-dcr.elc \
- $(lisp)/textmodes/reftex-global.elc \
- $(lisp)/textmodes/reftex-index.elc \
- $(lisp)/textmodes/reftex-parse.elc \
- $(lisp)/textmodes/reftex-ref.elc \
- $(lisp)/textmodes/reftex-sel.elc \
- $(lisp)/textmodes/reftex-toc.elc \
- $(lisp)/textmodes/reftex-vars.elc \
- $(lisp)/textmodes/reftex.elc \
- $(lisp)/textmodes/remember.elc \
- $(lisp)/textmodes/rst.elc \
- $(lisp)/textmodes/sgml-mode.elc \
- $(lisp)/textmodes/spell.elc \
- $(lisp)/textmodes/table.elc \
- $(lisp)/textmodes/tex-mode.elc \
- $(lisp)/textmodes/texinfmt.elc \
- $(lisp)/textmodes/texinfo.elc \
- $(lisp)/textmodes/texnfo-upd.elc \
- $(lisp)/textmodes/text-mode.elc \
- $(lisp)/textmodes/tildify.elc \
- $(lisp)/textmodes/two-column.elc \
- $(lisp)/textmodes/underline.elc \
- $(lisp)/thingatpt.elc \
- $(lisp)/thumbs.elc \
- $(lisp)/time-stamp.elc \
- $(lisp)/time.elc \
- $(lisp)/timezone.elc \
- $(lisp)/tmm.elc \
- $(lisp)/tool-bar.elc \
- $(lisp)/tooltip.elc \
- $(lisp)/tree-widget.elc \
- $(lisp)/tutorial.elc \
- $(lisp)/type-break.elc \
- $(lisp)/uniquify.elc \
- $(lisp)/url/url-about.elc \
- $(lisp)/url/url-auth.elc \
- $(lisp)/url/url-cache.elc \
- $(lisp)/url/url-cid.elc \
- $(lisp)/url/url-cookie.elc \
- $(lisp)/url/url-dav.elc \
- $(lisp)/url/url-dired.elc \
- $(lisp)/url/url-expand.elc \
- $(lisp)/url/url-file.elc \
- $(lisp)/url/url-ftp.elc \
- $(lisp)/url/url-gw.elc \
- $(lisp)/url/url-handlers.elc \
- $(lisp)/url/url-history.elc \
- $(lisp)/url/url-http.elc \
- $(lisp)/url/url-imap.elc \
- $(lisp)/url/url-irc.elc \
- $(lisp)/url/url-ldap.elc \
- $(lisp)/url/url-mailto.elc \
- $(lisp)/url/url-methods.elc \
- $(lisp)/url/url-misc.elc \
- $(lisp)/url/url-news.elc \
- $(lisp)/url/url-nfs.elc \
- $(lisp)/url/url-ns.elc \
- $(lisp)/url/url-parse.elc \
- $(lisp)/url/url-privacy.elc \
- $(lisp)/url/url-proxy.elc \
- $(lisp)/url/url-util.elc \
- $(lisp)/url/url-vars.elc \
- $(lisp)/url/url.elc \
- $(lisp)/userlock.elc \
- $(lisp)/vc-annotate.elc \
- $(lisp)/vc-arch.elc \
- $(lisp)/vc-bzr.elc \
- $(lisp)/vc-cvs.elc \
- $(lisp)/vc-dav.elc \
- $(lisp)/vc-dir.elc \
- $(lisp)/vc-dispatcher.elc \
- $(lisp)/vc-git.elc \
- $(lisp)/vc-hg.elc \
- $(lisp)/vc-hooks.elc \
- $(lisp)/vc-mtn.elc \
- $(lisp)/vc-rcs.elc \
- $(lisp)/vc-sccs.elc \
- $(lisp)/vc-svn.elc \
- $(lisp)/vc.elc \
- $(lisp)/vcursor.elc \
- $(lisp)/view.elc \
- $(lisp)/vt-control.elc \
- $(lisp)/vt100-led.elc \
- $(lisp)/w32-fns.elc \
- $(lisp)/w32-vars.elc \
- $(lisp)/wdired.elc \
- $(lisp)/whitespace.elc \
- $(lisp)/wid-browse.elc \
- $(lisp)/wid-edit.elc \
- $(lisp)/widget.elc \
- $(lisp)/windmove.elc \
- $(lisp)/window.elc \
- $(lisp)/winner.elc \
- $(lisp)/woman.elc \
- $(lisp)/x-dnd.elc \
- $(lisp)/xml.elc \
- $(lisp)/xt-mouse.elc
-
# The src/Makefile.in has its own set of dependencies and when they decide
# that one Lisp file needs to be re-compiled, we had better recompile it as
# well, otherwise every subsequent make will again call us, until we finally
@@ -1491,17 +208,53 @@ compile-onefile:
# An old-fashioned suffix rule, which, according to the GNU Make manual,
# cannot have prerequisites.
-# Note that if a .el file is removed from the repository without
-# updating ELCFILES, make will abort.
.el.elc:
@echo Compiling $<
@$(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $<
-.PHONY: compile-first compile-main compile-last compile compile-always
+.PHONY: compile-first compile-main compile compile-always
compile-first: $(COMPILE_FIRST)
-compile-main: $(ELCFILES)
+# In `compile-main' we could directly do
+# ... | xargs $(MAKE) $(MFLAGS) EMACS="$(EMACS)"
+# and it works, but it generates a lot of messages like
+# make[2]: « gnus/gnus-mlspl.elc » is up to date.
+# so instead, we use "xargs echo" to split the list of file into manageable
+# chunks and then use an intermediate `compile-targets' target so the
+# actual targets (the .elc files) are not mentioned as targets on the
+# make command line.
+
+
+.PHONY: compile-targets
+# TARGETS is set dynamically in the recursive call from `compile-main'.
+compile-targets: $(TARGETS)
+
+# Compile all the Elisp files that need it. Beware: it approximates
+# `no-byte-compile', so watch out for false-positives!
+compile-main: compile-clean
+ @(cd $(lisp); $(setwins); \
+ els=`echo "$$wins " | sed -e 's|/\./|/|g' -e 's|/\. | |g' -e 's| |/*.el |g'`; \
+ for el in $$els; do \
+ test -f $$el || continue; \
+ test ! -f $${el}c && GREP_OPTIONS= grep '^;.*no-byte-compile: t' $$el > /dev/null && continue; \
+ echo "$${el}c"; \
+ done | xargs echo) | \
+ while read chunk; do \
+ $(MAKE) $(MFLAGS) compile-targets EMACS="$(EMACS)" TARGETS="$$chunk"; \
+ done
+
+.PHONY: compile-clean
+# Erase left-over .elc files that do not have a corresponding .el file.
+compile-clean:
+ @cd $(lisp); $(setwins); \
+ elcs=`echo "$$wins " | sed -e 's|/\./|/|g' -e 's|/\. | |g' -e 's| |/*.elc |g'`; \
+ for el in `echo $$elcs | sed -e 's/\.elc/\.el/g'`; do \
+ if test -f "$$el" -o \! -f "$${el}c"; then :; else \
+ echo rm "$${el}c"; \
+ rm "$${el}c"; \
+ fi \
+ done
# Compile all Lisp files, but don't recompile those that are up to
# date. Some .el files don't get compiled because they set the
@@ -1511,10 +264,6 @@ compile-main: $(ELCFILES)
# sub-makes that run rules that use it, for the sake of some non-GNU makes.
compile: $(LOADDEFS) autoloads compile-first
$(MAKE) $(MFLAGS) compile-main EMACS=$(EMACS)
- $(MAKE) $(MFLAGS) compile-last EMACS=$(EMACS)
-
-## Doing this causes make install to dump another emacs.
-# $(MAKE) $(MFLAGS) update-elclist
# Compile all Lisp files. This is like `compile' but compiles files
# unconditionally. Some files don't actually get compiled because they
@@ -1523,20 +272,6 @@ compile-always: doit
cd $(lisp); rm -f *.elc */*.elc */*/*.elc */*/*/*.elc
$(MAKE) $(MFLAGS) compile EMACS=$(EMACS)
-## In case any files are missing from ELCFILES.
-compile-last:
- @wd=$(lisp); $(setwins); \
- els=`echo "$$wins " | sed -e 's|/\./|/|g' -e 's|/\. | |g' -e 's| |/*.el |g'`; \
- for el in $$els; do \
- test -f $$el || continue; \
- test -f $${el}c && continue; \
- GREP_OPTIONS= grep 'no-byte-compile: t' $$el > /dev/null && continue; \
- sel=`echo $$el | sed "s|^$(lisp)|\\$$(lisp)|"`; \
- echo "Maintainer warning: $$sel missing from \$$ELCFILES?"; \
- echo "Compiling $$el"; \
- $(emacs) $(BYTE_COMPILE_EXTRA_FLAGS) -f batch-byte-compile $$el || exit 1; \
- done
-
compile-calc:
for el in $(lisp)/calc/*.el; do \
echo Compiling $$el; \
@@ -1556,8 +291,7 @@ compile-after-backup: backup-compiled-files compile-always
# Recompile all Lisp files which are newer than their .elc files and compile
# new ones.
-# This has the same effect as compile-main (followed up with compile-last,
-# if ELCFILES is out of date). recompile has some advantages:
+# This has the same effect as compile-main. recompile has some advantages:
# i) It is faster (on a single processor), since it only has to start
# Emacs once. It was 33% faster on a test with a random 10% of the .el
# files needing recompilation.
@@ -1596,6 +330,24 @@ $(MH_E_DIR)/mh-loaddefs.el: $(MH_E_SRC)
--eval "(setq make-backup-files nil)" \
-f batch-update-autoloads $(MH_E_DIR)
+# Update TRAMP internal autoloads. Maybe we could move trmp*.el into
+# an own subdirectory. OTOH, it does not hurt to keep them in
+# lisp/net.
+TRAMP_DIR = $(lisp)/net
+TRAMP_SRC = $(TRAMP_DIR)/tramp.el $(TRAMP_DIR)/tramp-cache.el \
+ $(TRAMP_DIR)/tramp-cmds.el $(TRAMP_DIR)/tramp-compat.el \
+ $(TRAMP_DIR)/tramp-ftp.el $(TRAMP_DIR)/tramp-gvfs.el \
+ $(TRAMP_DIR)/tramp-gw.el $(TRAMP_DIR)/tramp-imap.el \
+ $(TRAMP_DIR)/tramp-sh.el $(TRAMP_DIR)/tramp-smb.el \
+ $(TRAMP_DIR)/tramp-uu.el $(TRAMP_DIR)/trampver.el
+
+$(TRAMP_DIR)/tramp-loaddefs.el: $(TRAMP_SRC)
+ $(emacs) -l autoload \
+ --eval "(setq generate-autoload-cookie \";;;###tramp-autoload\")" \
+ --eval "(setq generated-autoload-file \"$@\")" \
+ --eval "(setq make-backup-files nil)" \
+ -f batch-update-autoloads $(TRAMP_DIR)
+
CAL_DIR = $(lisp)/calendar
## Those files that may contain internal calendar autoload cookies.
## Avoids circular dependency warning for *-loaddefs.el.
diff --git a/lisp/abbrev.el b/lisp/abbrev.el
index a1fc3f90bf6..9d0e86fbce8 100644
--- a/lisp/abbrev.el
+++ b/lisp/abbrev.el
@@ -1,10 +1,11 @@
;;; abbrev.el --- abbrev mode commands for Emacs
-;; Copyright (C) 1985, 1986, 1987, 1992, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1986, 1987, 1992, 2001, 2002, 2003, 2004, 2005,
+;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: abbrev convenience
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -56,18 +57,10 @@ define global abbrevs instead."
"Toggle Abbrev mode in the current buffer.
With optional argument ARG, turn abbrev mode on if ARG is
positive, otherwise turn it off. In Abbrev mode, inserting an
-abbreviation causes it to expand and be replaced by its expansion.")
+abbreviation causes it to expand and be replaced by its expansion."
+ ;; It's defined in C, this stops the d-m-m macro defining it again.
+ :variable abbrev-mode)
-(defcustom abbrev-mode nil
- "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.
-Interactively, use the command `abbrev-mode'
-to enable or disable Abbrev mode in the current buffer."
- :type 'boolean
- :group 'abbrev-mode)
(put 'abbrev-mode 'safe-local-variable 'booleanp)
@@ -926,5 +919,4 @@ SORTFUN is passed to `sort' to change the default ordering."
(provide 'abbrev)
-;; arch-tag: dbd6f3ae-dfe3-40ba-b00f-f9e3ff960df5
;;; abbrev.el ends here
diff --git a/lisp/abbrevlist.el b/lisp/abbrevlist.el
index bf51a3dc418..5f9cbee2cf5 100644
--- a/lisp/abbrevlist.el
+++ b/lisp/abbrevlist.el
@@ -6,6 +6,7 @@
;; Maintainer: FSF
;; Keywords: abbrev
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/allout.el b/lisp/allout.el
index 666c62246d4..b497c82f0b3 100644
--- a/lisp/allout.el
+++ b/lisp/allout.el
@@ -1,12 +1,12 @@
;;; allout.el --- extensive outline mode for use alone and with other modes
-;; Copyright (C) 1992, 1993, 1994, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 1993, 1994, 2001, 2002, 2003, 2004, 2005, 2006,
+;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Ken Manheimer <ken dot manheimer at gmail dot com>
;; Maintainer: Ken Manheimer <ken dot manheimer at gmail dot com>
;; Created: Dec 1991 -- first release to usenet
-;; Version: 2.2.1
+;; Version: 2.2.2
;; Keywords: outlines wp languages
;; Website: http://myriadicity.net/Sundry/EmacsAllout
@@ -98,21 +98,145 @@
;;;_* USER CUSTOMIZATION VARIABLES:
-;;;_ > defgroup allout
+;;;_ > defgroup allout, allout-keybindings
(defgroup allout nil
"Extensive outline mode for use alone and with other modes."
:prefix "allout-"
:group 'outlines)
+(defgroup allout-keybindings nil
+ "Allout outline mode keyboard bindings configuration."
+ :group 'allout)
;;;_ + Layout, Mode, and Topic Header Configuration
-;;;_ = allout-command-prefix
+(defvar allout-command-prefix) ; defined below
+(defvar allout-mode-map)
+
+;;;_ > allout-keybindings incidentals:
+;;;_ > allout-bind-keys &optional varname value
+(defun allout-bind-keys (&optional varname value)
+ "Rebuild the `allout-mode-map' according to the keybinding specs.
+
+Useful standalone, to init the map, or in customizing the
+respective allout-mode keybinding variables, `allout-command-prefix',
+`allout-prefixed-keybindings', and `allout-unprefixed-keybindings'"
+ ;; Set the customization variable, if any:
+ (when varname
+ (set-default varname value))
+ (let ((map (make-sparse-keymap))
+ key)
+ (when (boundp 'allout-prefixed-keybindings)
+ ;; Be tolerant of the moments when the variables are first being defined.
+ (dolist (entry allout-prefixed-keybindings)
+ (define-key map
+ ;; XXX vector vs non-vector key descriptions?
+ (vconcat allout-command-prefix
+ (car (read-from-string (car entry))))
+ (cadr entry))))
+ (when (boundp 'allout-unprefixed-keybindings)
+ (dolist (entry allout-unprefixed-keybindings)
+ (define-key map (car (read-from-string (car entry))) (cadr entry))))
+ (setq allout-mode-map map)
+ map
+ ))
+;;;_ = allout-command-prefix
(defcustom allout-command-prefix "\C-c "
"Key sequence to be used as prefix for outline mode command key bindings.
Default is '\C-c<space>'; just '\C-c' is more short-and-sweet, if you're
willing to let allout use a bunch of \C-c keybindings."
:type 'string
+ :group 'allout-keybindings
+ :set 'allout-bind-keys)
+;;;_ = allout-keybindings-binding
+(define-widget 'allout-keybindings-binding 'lazy
+ "Structure of allout keybindings customization items."
+ :type '(repeat
+ (list (string :tag "Key" :value "[(meta control shift ?f)]")
+ (function :tag "Function name"
+ :value allout-forward-current-level))))
+;;;_ = allout-prefixed-keybindings
+(defcustom allout-prefixed-keybindings
+ '(("[(control ?n)]" allout-next-visible-heading)
+ ("[(control ?p)]" allout-previous-visible-heading)
+;; ("[(control ?u)]" allout-up-current-level)
+ ("[(control ?f)]" allout-forward-current-level)
+ ("[(control ?b)]" allout-backward-current-level)
+ ("[(control ?a)]" allout-beginning-of-current-entry)
+ ("[(control ?e)]" allout-end-of-entry)
+ ("[(control ?i)]" allout-show-children)
+ ("[(control ?i)]" allout-show-children)
+ ("[(control ?s)]" allout-show-current-subtree)
+ ("[(control ?t)]" allout-toggle-current-subtree-exposure)
+ ("[(control ?h)]" allout-hide-current-subtree)
+ ("[?h]" allout-hide-current-subtree)
+ ("[(control ?o)]" allout-show-current-entry)
+ ("[?!]" allout-show-all)
+ ("[?x]" allout-toggle-current-subtree-encryption)
+ ("[? ]" allout-open-sibtopic)
+ ("[?.]" allout-open-subtopic)
+ ("[?,]" allout-open-supertopic)
+ ("[?']" allout-shift-in)
+ ("[?>]" allout-shift-in)
+ ("[?<]" allout-shift-out)
+ ("[(control ?m)]" allout-rebullet-topic)
+ ("[?*]" allout-rebullet-current-heading)
+ ("[?']" allout-number-siblings)
+ ("[(control ?k)]" allout-kill-topic)
+ ("[??]" allout-copy-topic-as-kill)
+ ("[?@]" allout-resolve-xref)
+ ("[?=?c]" allout-copy-exposed-to-buffer)
+ ("[?=?i]" allout-indented-exposed-to-buffer)
+ ("[?=?t]" allout-latexify-exposed)
+ ("[?=?p]" allout-flatten-exposed-to-buffer)
+ )
+ "Allout-mode key bindings that are prefixed with `allout-command-prefix'.
+
+See `allout-unprefixed-keybindings' for the list of keybindings
+that are not prefixed.
+
+Use vector format for the keys:
+ - put literal keys after a '?' question mark, eg: '?a', '?.'
+ - enclose control, shift, or meta-modified keys as sequences within
+ parentheses, with the literal key, as above, preceded by the name(s)
+ of the modifers, eg: [(control ?a)]
+See the existing keys for examples.
+
+Functions can be bound to multiple keys, but binding keys to
+multiple functions will not work - the last binding for a key
+prevails."
+ :type 'allout-keybindings-binding
+ :group 'allout-keybindings
+ :set 'allout-bind-keys
+ )
+;;;_ = allout-unprefixed-keybindings
+(defcustom allout-unprefixed-keybindings
+ '(("[(control ?k)]" allout-kill-line)
+ ("[??(meta ?k)]" allout-copy-line-as-kill)
+ ("[(control ?y)]" allout-yank)
+ ("[??(meta ?y)]" allout-yank-pop)
+ )
+ "Allout-mode functions bound to keys without any added prefix.
+
+This is in contrast to the majority of allout-mode bindings on
+`allout-prefixed-bindings', whose bindings are created with a
+preceeding command key.
+
+Use vector format for the keys:
+ - put literal keys after a '?' question mark, eg: '?a', '?.'
+ - enclose control, shift, or meta-modified keys as sequences within
+ parentheses, with the literal key, as above, preceded by the name(s)
+ of the modifers, eg: [(control ?a)]
+See the existing keys for examples."
+ :type 'allout-keybindings-binding
+ :group 'allout-keybindings
+ :set 'allout-bind-keys
+ )
+
+;;;_ = allout-preempt-trailing-ctrl-h
+(defcustom allout-preempt-trailing-ctrl-h nil
+ "Use <prefix>-\C-h, instead of leaving it for describe-prefix-bindings?"
+ :type 'boolean
:group 'allout)
;;;_ = allout-keybindings-list
@@ -133,9 +257,13 @@ unless optional third, non-nil element is present.")
("\C-a" allout-beginning-of-current-entry)
("\C-e" allout-end-of-entry)
; Exposure commands:
- ("\C-i" allout-show-children)
+ ([(control i)] allout-show-children) ; xemacs translates "\C-i" to tab
+ ("\C-i" allout-show-children) ; but we still need this for hotspot
("\C-s" allout-show-current-subtree)
- ("\C-h" allout-hide-current-subtree)
+ ;; binding to \C-h is included if allout-preempt-trailing-ctrl-h,
+ ;; so user controls whether or not to preempt the conventional ^H
+ ;; binding to help-command.
+ ("\C-h" allout-hide-current-subtree)
("\C-t" allout-toggle-current-subtree-exposure)
("h" allout-hide-current-subtree)
("\C-o" allout-show-current-entry)
@@ -753,7 +881,7 @@ disable auto-saves for that file."
;;;_ + Developer
;;;_ = allout-developer group
(defgroup allout-developer nil
- "Settings for topic encryption features of allout outliner."
+ "Allout settings developers care about, including topic encryption and more."
:group 'allout)
;;;_ = allout-run-unit-tests-on-load
(defcustom allout-run-unit-tests-on-load nil
@@ -792,7 +920,7 @@ For details, see `allout-toggle-current-subtree-encryption's docstring."
;;;_ #1 Internal Outline Formatting and Configuration
;;;_ : Version
;;;_ = allout-version
-(defvar allout-version "2.2.1"
+(defvar allout-version "2.2.2"
"Version of currently loaded outline package. (allout.el)")
;;;_ > allout-version
(defun allout-version (&optional here)
@@ -1163,6 +1291,13 @@ See doc string for `allout-keybindings-list' for format of binding list."
(car (cdr cell)))))))
keymap-list)
map))
+;;;_ > allout-mode-map-adjustments (base-map)
+(defun allout-mode-map-adjustments (base-map)
+ "Do conditional additions to specified base-map, like inclusion of \\C-h."
+ (if allout-preempt-trailing-ctrl-h
+ (cons '("\C-h" allout-hide-current-subtree) base-map)
+ base-map)
+ )
;;;_ : Menu bar
(defvar allout-mode-exposure-menu)
(defvar allout-mode-editing-menu)
@@ -1278,7 +1413,7 @@ The settings are stored on `allout-mode-prior-settings'."
(void-variable nil)))
(when (not (assoc name allout-mode-prior-settings))
;; Not already added as a resumption, create the prior setting entry.
- (if (local-variable-p name)
+ (if (local-variable-p name (current-buffer))
;; is already local variable -- preserve the prior value:
(push (list name prior-value) allout-mode-prior-settings)
;; wasn't local variable, indicate so for resumption by killing
@@ -1541,6 +1676,14 @@ and the place for the cursor after the decryption is done."
(goto-char (cadr allout-after-save-decrypt))
(setq allout-after-save-decrypt nil))
)
+;;;_ > allout-called-interactively-p ()
+(defmacro allout-called-interactively-p ()
+ "A version of called-interactively-p independent of emacs version."
+ ;; ... to ease maintenance of allout without betraying deprecation.
+ (if (equal (subr-arity (symbol-function 'called-interactively-p))
+ '(0 . 0))
+ '(called-interactively-p)
+ '(called-interactively-p 'interactive)))
;;;_ = allout-inhibit-aberrance-doublecheck nil
;; In some exceptional moments, disparate topic depths need to be allowed
;; momentarily, eg when one topic is being yanked into another and they're
@@ -1554,7 +1697,7 @@ and the place for the cursor after the decryption is done."
This should only be momentarily let-bound non-nil, not set
non-nil in a lasting way.")
-;;;_ #2 Mode activation
+;;;_ #2 Mode environment and activation
;;;_ = allout-explicitly-deactivated
(defvar allout-explicitly-deactivated nil
"If t, `allout-mode's last deactivation was deliberate.
@@ -1590,7 +1733,7 @@ the following two lines in your Emacs init file:
\(allout-init t)"
(interactive)
- (if (called-interactively-p 'interactive)
+ (if (allout-called-interactively-p)
(progn
(setq mode
(completing-read
@@ -1614,7 +1757,7 @@ the following two lines in your Emacs init file:
(cond ((not mode)
(set find-file-hook-var-name
(delq hook (symbol-value find-file-hook-var-name)))
- (if (called-interactively-p 'interactive)
+ (if (allout-called-interactively-p)
(message "Allout outline mode auto-activation inhibited.")))
((eq mode 'report)
(if (not (memq hook (symbol-value find-file-hook-var-name)))
@@ -1656,7 +1799,7 @@ the following two lines in your Emacs init file:
(setplist 'allout-exposure-category nil)
(put 'allout-exposure-category 'invisible 'allout)
(put 'allout-exposure-category 'evaporate t)
- ;; XXX We use isearch-open-invisible *and* isearch-mode-end-hook. The
+ ;; ??? We use isearch-open-invisible *and* isearch-mode-end-hook. The
;; latter would be sufficient, but it seems that a separate behavior --
;; the _transient_ opening of invisible text during isearch -- is keyed to
;; presence of the isearch-open-invisible property -- even though this
@@ -2116,9 +2259,11 @@ OPEN: A TOPIC that is not CLOSED, though its OFFSPRING or BODY may be."
(defun allout-setup-mode-map ()
"Establish allout-mode bindings."
(setq-default allout-mode-map
- (produce-allout-mode-map allout-keybindings-list))
+ (produce-allout-mode-map
+ (allout-mode-map-adjustments allout-keybindings-list)))
(setq allout-mode-map
- (produce-allout-mode-map allout-keybindings-list))
+ (produce-allout-mode-map
+ (allout-mode-map-adjustments allout-keybindings-list)))
(substitute-key-definition 'beginning-of-line
'allout-beginning-of-line
allout-mode-map global-map)
@@ -2153,7 +2298,7 @@ OPEN: A TOPIC that is not CLOSED, though its OFFSPRING or BODY may be."
;;;_ - Position Assessment
;;;_ > allout-hidden-p (&optional pos)
(defsubst allout-hidden-p (&optional pos)
- "Non-nil if the character after point is invisible."
+ "Non-nil if the character after point was made invisible by allout."
(eq (get-char-property (or pos (point)) 'invisible) 'allout))
;;;_ > allout-overlay-insert-in-front-handler (ol after beg end
@@ -2162,8 +2307,8 @@ OPEN: A TOPIC that is not CLOSED, though its OFFSPRING or BODY may be."
&optional prelen)
"Shift the overlay so stuff inserted in front of it is excluded."
(if after
- ;; XXX Shouldn't moving the overlay should be unnecessary, if overlay
- ;; front-advance on the overlay worked as it should?
+ ;; ??? Shouldn't moving the overlay should be unnecessary, if overlay
+ ;; front-advance on the overlay worked as expected?
(move-overlay ol (1+ beg) (overlay-end ol))))
;;;_ > allout-overlay-interior-modification-handler (ol after beg end
;;; &optional prelen)
@@ -2225,8 +2370,9 @@ See `allout-overlay-interior-modification-handler' for details."
(save-excursion
(goto-char beg)
(let ((overlay (allout-get-invisibility-overlay)))
- (allout-overlay-interior-modification-handler
- overlay nil beg end nil)))))
+ (if overlay
+ (allout-overlay-interior-modification-handler
+ overlay nil beg end nil))))))
;;;_ > allout-isearch-end-handler (&optional overlay)
(defun allout-isearch-end-handler (&optional overlay)
"Reconcile allout outline exposure on arriving in hidden text after isearch.
@@ -2239,13 +2385,13 @@ function can also be used as an `isearch-mode-end-hook'."
(allout-show-to-offshoot)))
;;;_ #3 Internal Position State-Tracking -- "allout-recent-*" funcs
-;;; All the basic outline functions that directly do string matches to
-;;; evaluate heading prefix location set the variables
-;;; `allout-recent-prefix-beginning' and `allout-recent-prefix-end'
-;;; when successful. Functions starting with `allout-recent-' all
-;;; use this state, providing the means to avoid redundant searches
-;;; for just-established data. This optimization can provide
-;;; significant speed improvement, but it must be employed carefully.
+;; All the basic outline functions that directly do string matches to
+;; evaluate heading prefix location set the variables
+;; `allout-recent-prefix-beginning' and `allout-recent-prefix-end'
+;; when successful. Functions starting with `allout-recent-' all
+;; use this state, providing the means to avoid redundant searches
+;; for just-established data. This optimization can provide
+;; significant speed improvement, but it must be employed carefully.
;;;_ = allout-recent-prefix-beginning
(defvar allout-recent-prefix-beginning 0
"Buffer point of the start of the last topic prefix encountered.")
@@ -2508,7 +2654,7 @@ Outermost is first."
;;;_ > allout-end-of-current-line ()
(defun allout-end-of-current-line ()
"Move to the end of line, past concealed text if any."
- ;; XXX This is for symmetry with `allout-beginning-of-current-line' --
+ ;; This is for symmetry with `allout-beginning-of-current-line' --
;; `move-end-of-line' doesn't suffer the same problem as
;; `move-beginning-of-line'.
(let ((inhibit-field-text-motion t))
@@ -2527,7 +2673,7 @@ Outermost is first."
(progn
(if (and (not (bolp))
(allout-hidden-p (1- (point))))
- (goto-char (previous-single-char-property-change
+ (goto-char (allout-previous-single-char-property-change
(1- (point)) 'invisible)))
(move-beginning-of-line 1))
(allout-depth)
@@ -2573,9 +2719,20 @@ Outermost is first."
(allout-back-to-current-heading)
(allout-end-of-current-line))
(t
- (if (not (and transient-mark-mode mark-active))
+ (if (not (allout-mark-active-p))
(push-mark))
(allout-end-of-entry))))))
+;;;_ > allout-mark-active-p ()
+(defun allout-mark-active-p ()
+ "True if the mark is currently or always active."
+ ;; `(cond (boundp...))' (or `(if ...)') invokes special byte-compiler
+ ;; provisions, at least in fsf emacs to prevent warnings about lack of,
+ ;; eg, region-active-p.
+ (cond ((boundp 'mark-active)
+ mark-active)
+ ((fboundp 'region-active-p)
+ (region-active-p))
+ (t)))
;;;_ > allout-next-heading ()
(defsubst allout-next-heading ()
"Move to the heading for the topic (possibly invisible) after this one.
@@ -2888,8 +3045,8 @@ otherwise skip white space between bullet and ensuing text."
(if (not (allout-current-depth))
nil
(1- allout-recent-prefix-end)))
-;;;_ > allout-back-to-current-heading ()
-(defun allout-back-to-current-heading ()
+;;;_ > allout-back-to-current-heading (&optional interactive)
+(defun allout-back-to-current-heading (&optional interactive)
"Move to heading line of current topic, or beginning if not in a topic.
If interactive, we position at the end of the prefix.
@@ -2897,11 +3054,13 @@ If interactive, we position at the end of the prefix.
Return value of resulting point, unless we started outside
of (before any) topics, in which case we return nil."
+ (interactive "p")
+
(allout-beginning-of-current-line)
(let ((bol-point (point)))
(if (allout-goto-prefix-doublechecked)
(if (<= (point) bol-point)
- (if (called-interactively-p 'interactive)
+ (if interactive
(allout-end-of-prefix)
(point))
(goto-char (point-min))
@@ -2955,20 +3114,20 @@ excluded as delimiting whitespace between topics.
Returns the value of point."
(interactive)
(allout-end-of-subtree t include-trailing-blank))
-;;;_ > allout-beginning-of-current-entry ()
-(defun allout-beginning-of-current-entry ()
+;;;_ > allout-beginning-of-current-entry (&optional interactive)
+(defun allout-beginning-of-current-entry (&optional interactive)
"When not already there, position point at beginning of current topic header.
If already there, move cursor to bullet for hot-spot operation.
\(See `allout-mode' doc string for details of hot-spot operation.)"
- (interactive)
+ (interactive "p")
(let ((start-point (point)))
(move-beginning-of-line 1)
(if (< 0 (allout-current-depth))
(goto-char allout-recent-prefix-end)
(goto-char (point-min)))
(allout-end-of-prefix)
- (if (and (called-interactively-p 'interactive)
+ (if (and interactive
(= (point) start-point))
(goto-char (allout-current-bullet-pos)))))
;;;_ > allout-end-of-entry (&optional inclusive)
@@ -3018,9 +3177,9 @@ collapsed."
(while (and (< depth allout-recent-depth)
(setq last-ascended (allout-ascend))))
(goto-char allout-recent-prefix-beginning)
- (if (called-interactively-p 'interactive) (allout-end-of-prefix))
+ (if (allout-called-interactively-p) (allout-end-of-prefix))
(and last-ascended allout-recent-depth))))
-;;;_ > allout-ascend ()
+;;;_ > allout-ascend (&optional dont-move-if-unsuccessful)
(defun allout-ascend (&optional dont-move-if-unsuccessful)
"Ascend one level, returning resulting depth if successful, nil if not.
@@ -3046,7 +3205,7 @@ which case point is returned to its original starting location."
(goto-char bolevel)
(allout-depth)
nil))))
- (if (called-interactively-p 'interactive) (allout-end-of-prefix))))
+ (if (allout-called-interactively-p) (allout-end-of-prefix))))
;;;_ > allout-descend-to-depth (depth)
(defun allout-descend-to-depth (depth)
"Descend to depth DEPTH within current topic.
@@ -3074,7 +3233,7 @@ Returning depth if successful, nil if not."
(if (not (allout-ascend))
(progn (goto-char start-point)
(error "Can't ascend past outermost level"))
- (if (called-interactively-p 'interactive) (allout-end-of-prefix))
+ (if (allout-called-interactively-p) (allout-end-of-prefix))
allout-recent-prefix-beginning)))
;;;_ - Linear
@@ -3219,7 +3378,7 @@ Presumes point is at the start of a topic prefix."
(let ((depth (allout-depth)))
(while (allout-previous-sibling depth nil))
(prog1 allout-recent-depth
- (if (called-interactively-p 'interactive) (allout-end-of-prefix)))))
+ (if (allout-called-interactively-p) (allout-end-of-prefix)))))
;;;_ > allout-next-visible-heading (arg)
(defun allout-next-visible-heading (arg)
"Move to the next ARG'th visible heading line, backward if arg is negative.
@@ -3272,7 +3431,7 @@ A heading line is one that starts with a `*' (or that `allout-regexp'
matches)."
(interactive "p")
(prog1 (allout-next-visible-heading (- arg))
- (if (called-interactively-p 'interactive) (allout-end-of-prefix))))
+ (if (allout-called-interactively-p) (allout-end-of-prefix))))
;;;_ > allout-forward-current-level (arg)
(defun allout-forward-current-level (arg)
"Position point at the next heading of the same level.
@@ -3293,7 +3452,7 @@ Returns resulting position, else nil if none found."
(allout-previous-sibling)
(allout-next-sibling)))
(setq arg (1- arg)))
- (if (not (called-interactively-p 'interactive))
+ (if (not (allout-called-interactively-p))
nil
(allout-end-of-prefix)
(if (not (zerop arg))
@@ -3306,7 +3465,7 @@ Returns resulting position, else nil if none found."
(defun allout-backward-current-level (arg)
"Inverse of `allout-forward-current-level'."
(interactive "p")
- (if (called-interactively-p 'interactive)
+ (if (allout-called-interactively-p)
(let ((current-prefix-arg (* -1 arg)))
(call-interactively 'allout-forward-current-level))
(allout-forward-current-level (* -1 arg))))
@@ -3391,8 +3550,10 @@ this-command accordingly.
Returns the qualifying command, if any, else nil."
(interactive)
- (let* ((key-string (if (numberp last-command-event)
- (char-to-string last-command-event)))
+ (let* ((modified (event-modifiers last-command-event))
+ (key-string (if (numberp last-command-event)
+ (char-to-string
+ (event-basic-type last-command-event))))
(key-num (cond ((numberp last-command-event) last-command-event)
;; for XEmacs character type:
((and (fboundp 'characterp)
@@ -3406,6 +3567,7 @@ Returns the qualifying command, if any, else nil."
(if (and
;; exclude control chars and escape:
+ (not modified)
(<= 33 key-num)
(setq mapped-binding
(or (and (assoc key-string allout-keybindings-list)
@@ -3413,22 +3575,22 @@ Returns the qualifying command, if any, else nil."
(cadr (assoc key-string allout-keybindings-list)))
;; translate as a keybinding:
(key-binding (vconcat allout-command-prefix
- (char-to-string
- (if (and (<= 97 key-num) ; "a"
- (>= 122 key-num)) ; "z"
- (- key-num 96) key-num)))
+ (vector
+ (if (and (<= 97 key-num) ; "a"
+ (>= 122 key-num)) ; "z"
+ (- key-num 96) key-num)))
t))))
;; Qualified as an allout command -- do hot-spot operation.
(setq allout-post-goto-bullet t)
- ;; accept-defaults nil, or else we'll get allout-item-icon-key-handler.
- (setq mapped-binding (key-binding (char-to-string key-num))))
+ ;; accept-defaults nil, or else we get allout-item-icon-key-handler.
+ (setq mapped-binding (key-binding (vector key-num))))
(while (keymapp mapped-binding)
(setq mapped-binding
(lookup-key mapped-binding (vector (read-char)))))
- (if mapped-binding
- (setq this-command mapped-binding)))))
+ (when mapped-binding
+ (setq this-command mapped-binding)))))
;;;_ > allout-find-file-hook ()
(defun allout-find-file-hook ()
@@ -3457,7 +3619,7 @@ Offer one suitable for current depth DEPTH as default."
(setq choice (solicit-char-in-string
(format "Select bullet: %s ('%s' default): "
sans-escapes
- (substring-no-properties default-bullet))
+ (allout-substring-no-properties default-bullet))
sans-escapes
t)))
(message "")
@@ -4455,9 +4617,9 @@ Topic exposure is marked with text-properties, to be used by
(if (not (allout-hidden-p))
(setq next
(max (1+ (point))
- (next-single-char-property-change (point)
- 'invisible
- nil end))))
+ (allout-next-single-char-property-change (point)
+ 'invisible
+ nil end))))
(if (or (not next) (eq prev next))
;; still not at start of hidden area -- must not be any left.
(setq done t)
@@ -4496,9 +4658,8 @@ Topic exposure is marked with text-properties, to be used by
(while (not done)
;; at or advance to start of next annotation:
(if (not (get-text-property (point) 'allout-was-hidden))
- (setq next (next-single-char-property-change (point)
- 'allout-was-hidden
- nil end)))
+ (setq next (allout-next-single-char-property-change
+ (point) 'allout-was-hidden nil end)))
(if (or (not next) (eq prev next))
;; no more or not advancing -- must not be any left.
(setq done t)
@@ -4508,9 +4669,8 @@ Topic exposure is marked with text-properties, to be used by
;; still not at start of annotation.
(setq done t)
;; advance to just after end of this annotation:
- (setq next (next-single-char-property-change (point)
- 'allout-was-hidden
- nil end))
+ (setq next (allout-next-single-char-property-change
+ (point) 'allout-was-hidden nil end))
(overlay-put (make-overlay prev next nil 'front-advance)
'category 'allout-exposure-category)
(allout-deannotate-hidden prev next)
@@ -4725,7 +4885,7 @@ by pops to non-distinctive yanks. Bug..."
(save-match-data
(save-excursion
(let* ((text-start allout-recent-prefix-end)
- (heading-end (progn (end-of-line) (point))))
+ (heading-end (point-at-eol)))
(goto-char text-start)
(setq file-name
(if (re-search-forward "\\s-\\(\\S-*\\)" heading-end t)
@@ -4766,7 +4926,10 @@ invoked.)"
(when (featurep 'xemacs)
(let ((props (symbol-plist 'allout-exposure-category)))
(while props
- (overlay-put o (pop props) (pop props)))))))
+ (condition-case nil
+ ;; as of 2008-02-27, xemacs lacks modification-hooks
+ (overlay-put o (pop props) (pop props))
+ (error nil)))))))
(run-hooks 'allout-view-change-hook)
(run-hook-with-args 'allout-exposure-change-hook from to flag))
;;;_ > allout-flag-current-subtree (flag)
@@ -4845,7 +5008,7 @@ point of non-opened subtree?)"
(to-reveal (or (allout-chart-to-reveal chart chart-level)
;; interactive, show discontinuous children:
(and chart
- (called-interactively-p 'interactive)
+ (allout-called-interactively-p)
(save-excursion
(allout-back-to-current-heading)
(setq depth (allout-current-depth))
@@ -5672,8 +5835,7 @@ environment. Leaves point at the end of the line."
(let ((inhibit-field-text-motion t))
(beginning-of-line)
(let ((beg (point))
- (end (progn (end-of-line)(point))))
- (goto-char beg)
+ (end (point-at-eol)))
(save-match-data
(while (re-search-forward "\\\\"
;;"\\\\\\|\\{\\|\\}\\|\\_\\|\\$\\|\\\"\\|\\&\\|\\^\\|\\-\\|\\*\\|#"
@@ -5976,7 +6138,7 @@ See `allout-toggle-current-subtree-encryption' for more details."
;; they're encrypted, so the coding system is set to accommodate
;; them.
(setq buffer-file-coding-system
- (select-safe-coding-system subtree-beg subtree-end))
+ (allout-select-safe-coding-system subtree-beg subtree-end))
;; if the coding system for the text being encrypted is different
;; than that prevailing, then there a real risk that the coding
;; system can't be noticed by emacs when the file is visited. to
@@ -6119,7 +6281,7 @@ Returns the resulting string, or nil if the transformation fails."
(insert text)
;; convey the text characteristics of the original buffer:
- (set-buffer-multibyte multibyte)
+ (allout-set-buffer-multibyte multibyte)
(when encoding
(set-buffer-file-coding-system encoding)
(if (not decrypt)
@@ -6831,6 +6993,14 @@ If BEG is bigger than END we return 0."
((atom (car list)) (cons (car list) (allout-flatten (cdr list))))
(t (append (allout-flatten (car list)) (allout-flatten (cdr list))))))
;;;_ : Compatibility:
+;;;_ : xemacs undo-in-progress provision:
+(unless (boundp 'undo-in-progress)
+ (defvar undo-in-progress nil
+ "Placeholder defvar for XEmacs compatibility from allout.el.")
+ (defadvice undo-more (around allout activate)
+ ;; This defadvice used only in emacs that lack undo-in-progress, eg xemacs.
+ (let ((undo-in-progress t)) ad-do-it)))
+
;;;_ > allout-mark-marker to accommodate divergent emacsen:
(defun allout-mark-marker (&optional force buffer)
"Accommodate the different signature for `mark-marker' across Emacsen.
@@ -6941,7 +7111,7 @@ To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
(skip-chars-backward "^\n"))
(vertical-motion 0))
)
-;;;_ > move-end-of-line if necessary -- older emacs, xemacs
+;;;_ > move-end-of-line if necessary -- Emacs < 22.1, xemacs
(if (not (fboundp 'move-end-of-line))
(defun move-end-of-line (arg)
"Move point to end of current line as displayed.
@@ -6991,6 +7161,42 @@ To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
(setq arg 1)
(setq done t)))))))
)
+;;;_ > allout-next-single-char-property-change -- alias unless lacking
+(defalias 'allout-next-single-char-property-change
+ (if (fboundp 'next-single-char-property-change)
+ 'next-single-char-property-change
+ 'next-single-property-change)
+ ;; No docstring because xemacs defalias doesn't support it.
+ )
+;;;_ > allout-previous-single-char-property-change -- alias unless lacking
+(defalias 'allout-previous-single-char-property-change
+ (if (fboundp 'previous-single-char-property-change)
+ 'previous-single-char-property-change
+ 'previous-single-property-change)
+ ;; No docstring because xemacs defalias doesn't support it.
+ )
+;;;_ > allout-set-buffer-multibyte
+;; define as alias first, so byte compiler is happy.
+(defalias 'allout-set-buffer-multibyte 'set-buffer-multibyte)
+;; then supplant with definition if underlying alias absent.
+(if (not (fboundp 'set-buffer-multibyte))
+ (defun allout-set-buffer-multibyte (is-multibyte)
+ (setq enable-multibyte-characters is-multibyte))
+ )
+;;;_ > allout-select-safe-coding-system
+(defalias 'allout-select-safe-coding-system
+ (if (fboundp 'select-safe-coding-system)
+ 'select-safe-coding-system
+ 'detect-coding-region)
+ )
+;;;_ > allout-substring-no-properties
+;; define as alias first, so byte compiler is happy.
+(defalias 'allout-substring-no-properties 'substring-no-properties)
+;; then supplant with definition if underlying alias absent.
+(if (not (fboundp 'substring-no-properties))
+ (defun allout-substring-no-properties (string &optional start end)
+ (substring string (or start 0) end))
+ )
;;;_ #10 Unfinished
;;;_ > allout-bullet-isearch (&optional bullet)
@@ -7022,7 +7228,7 @@ To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
;;;_ > allout-tests-obliterate-variable (name)
(defun allout-tests-obliterate-variable (name)
"Completely unbind variable with NAME."
- (if (local-variable-p name) (kill-local-variable name))
+ (if (local-variable-p name (current-buffer)) (kill-local-variable name))
(while (boundp name) (makunbound name)))
;;;_ > allout-test-resumptions ()
(defvar allout-tests-globally-unbound nil
@@ -7041,11 +7247,12 @@ To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
(allout-tests-obliterate-variable 'allout-tests-globally-unbound)
(allout-add-resumptions '(allout-tests-globally-unbound t))
(assert (not (default-boundp 'allout-tests-globally-unbound)))
- (assert (local-variable-p 'allout-tests-globally-unbound))
+ (assert (local-variable-p 'allout-tests-globally-unbound (current-buffer)))
(assert (boundp 'allout-tests-globally-unbound))
(assert (equal allout-tests-globally-unbound t))
(allout-do-resumptions)
- (assert (not (local-variable-p 'allout-tests-globally-unbound)))
+ (assert (not (local-variable-p 'allout-tests-globally-unbound
+ (current-buffer))))
(assert (not (boundp 'allout-tests-globally-unbound))))
;; ensure that variable with prior global value is resumed
@@ -7054,10 +7261,11 @@ To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
(setq allout-tests-globally-true t)
(allout-add-resumptions '(allout-tests-globally-true nil))
(assert (equal (default-value 'allout-tests-globally-true) t))
- (assert (local-variable-p 'allout-tests-globally-true))
+ (assert (local-variable-p 'allout-tests-globally-true (current-buffer)))
(assert (equal allout-tests-globally-true nil))
(allout-do-resumptions)
- (assert (not (local-variable-p 'allout-tests-globally-true)))
+ (assert (not (local-variable-p 'allout-tests-globally-true
+ (current-buffer))))
(assert (boundp 'allout-tests-globally-true))
(assert (equal allout-tests-globally-true t)))
@@ -7068,16 +7276,16 @@ To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
(assert (not (default-boundp 'allout-tests-locally-true))
nil (concat "Test setup mistake -- variable supposed to"
" not have global binding, but it does."))
- (assert (local-variable-p 'allout-tests-locally-true)
+ (assert (local-variable-p 'allout-tests-locally-true (current-buffer))
nil (concat "Test setup mistake -- variable supposed to have"
" local binding, but it lacks one."))
(allout-add-resumptions '(allout-tests-locally-true nil))
(assert (not (default-boundp 'allout-tests-locally-true)))
- (assert (local-variable-p 'allout-tests-locally-true))
+ (assert (local-variable-p 'allout-tests-locally-true (current-buffer)))
(assert (equal allout-tests-locally-true nil))
(allout-do-resumptions)
(assert (boundp 'allout-tests-locally-true))
- (assert (local-variable-p 'allout-tests-locally-true))
+ (assert (local-variable-p 'allout-tests-locally-true (current-buffer)))
(assert (equal allout-tests-locally-true t))
(assert (not (default-boundp 'allout-tests-locally-true))))
@@ -7096,22 +7304,24 @@ To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
'(allout-tests-locally-true 4))
;; reestablish many of the basic conditions are maintained after re-add:
(assert (not (default-boundp 'allout-tests-globally-unbound)))
- (assert (local-variable-p 'allout-tests-globally-unbound))
+ (assert (local-variable-p 'allout-tests-globally-unbound (current-buffer)))
(assert (equal allout-tests-globally-unbound 2))
(assert (default-boundp 'allout-tests-globally-true))
- (assert (local-variable-p 'allout-tests-globally-true))
+ (assert (local-variable-p 'allout-tests-globally-true (current-buffer)))
(assert (equal allout-tests-globally-true 3))
(assert (not (default-boundp 'allout-tests-locally-true)))
- (assert (local-variable-p 'allout-tests-locally-true))
+ (assert (local-variable-p 'allout-tests-locally-true (current-buffer)))
(assert (equal allout-tests-locally-true 4))
(allout-do-resumptions)
- (assert (not (local-variable-p 'allout-tests-globally-unbound)))
+ (assert (not (local-variable-p 'allout-tests-globally-unbound
+ (current-buffer))))
(assert (not (boundp 'allout-tests-globally-unbound)))
- (assert (not (local-variable-p 'allout-tests-globally-true)))
+ (assert (not (local-variable-p 'allout-tests-globally-true
+ (current-buffer))))
(assert (boundp 'allout-tests-globally-true))
(assert (equal allout-tests-globally-true t))
(assert (boundp 'allout-tests-locally-true))
- (assert (local-variable-p 'allout-tests-locally-true))
+ (assert (local-variable-p 'allout-tests-locally-true (current-buffer)))
(assert (equal allout-tests-locally-true t))
(assert (not (default-boundp 'allout-tests-locally-true))))
@@ -7147,5 +7357,4 @@ To ignore intangibility, bind `inhibit-point-motion-hooks' to t."
;;allout-layout: (0 : -1 -1 0)
;;End:
-;; arch-tag: cf38fbc3-c044-450f-8bff-afed8ba5681c
;;; allout.el ends here
diff --git a/lisp/ansi-color.el b/lisp/ansi-color.el
index 00162c99219..6bc95fa8d94 100644
--- a/lisp/ansi-color.el
+++ b/lisp/ansi-color.el
@@ -244,9 +244,9 @@ A possible way to install this would be:
(when (boundp 'font-lock-syntactic-keywords)
(remove-text-properties beg end '(syntax-table nil)))
;; instead of just using (remove-text-properties beg end '(face
- ;; nil)), we find regions with a non-nil face test-property, skip
+ ;; nil)), we find regions with a non-nil face text-property, skip
;; positions with the ansi-color property set, and remove the
- ;; remaining face test-properties.
+ ;; remaining face text-properties.
(while (setq beg (text-property-not-all beg end 'face nil))
(setq beg (or (text-property-not-all beg end 'ansi-color t) end))
(when (get-text-property beg 'face)
diff --git a/lisp/apropos.el b/lisp/apropos.el
index 09de0c08e19..d62721e157c 100644
--- a/lisp/apropos.el
+++ b/lisp/apropos.el
@@ -6,6 +6,7 @@
;; Author: Joe Wells <jbw@bigbird.bu.edu>
;; Daniel Pfeiffer <occitan@esperanto.org> (rewrite)
;; Keywords: help
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el
index 1cb3ade9a2d..a86203a47db 100644
--- a/lisp/arc-mode.el
+++ b/lisp/arc-mode.el
@@ -52,17 +52,17 @@
;; ARCHIVE TYPES: Currently only the archives below are handled, but the
;; structure for handling just about anything is in place.
;;
-;; Arc Lzh Zip Zoo Rar
-;; ----------------------------------------
-;; View listing Intern Intern Intern Intern Y
-;; Extract member Y Y Y Y Y
-;; Save changed member Y Y Y Y N
-;; Add new member N N N N N
-;; Delete member Y Y Y Y N
-;; Rename member Y Y N N N
-;; Chmod - Y Y - N
-;; Chown - Y - - N
-;; Chgrp - Y - - N
+;; Arc Lzh Zip Zoo Rar 7z
+;; --------------------------------------------
+;; View listing Intern Intern Intern Intern Y Y
+;; Extract member Y Y Y Y Y Y
+;; Save changed member Y Y Y Y N N
+;; Add new member N N N N N N
+;; Delete member Y Y Y Y N N
+;; Rename member Y Y N N N N
+;; Chmod - Y Y - N N
+;; Chown - Y - - N N
+;; Chgrp - Y - - N N
;;
;; Special thanks to Bill Brodie <wbrodie@panix.com> for very useful tips
;; on the first released version of this package.
@@ -217,17 +217,17 @@ Archive and member name will be added."
;; Zip archive configuration
(defcustom archive-zip-extract
- (if (and (not (executable-find "unzip"))
- (executable-find "pkunzip"))
- '("pkunzip" "-e" "-o-")
- '("unzip" "-qq" "-c"))
+ (cond ((executable-find "unzip") '("unzip" "-qq" "-c"))
+ ((executable-find "7z") '("7z" "x" "-so"))
+ ((executable-find "pkunzip") '("pkunzip" "-e" "-o-"))
+ (t '("unzip" "-qq" "-c")))
"Program and its options to run in order to extract a zip file member.
Extraction should happen to standard output. Archive and member name will
be added."
:type '(list (string :tag "Program")
- (repeat :tag "Options"
- :inline t
- (string :format "%v")))
+ (repeat :tag "Options"
+ :inline t
+ (string :format "%v")))
:group 'archive-zip)
;; For several reasons the latter behavior is not desirable in general.
@@ -315,6 +315,20 @@ Archive and member name will be added."
:inline t
(string :format "%v")))
:group 'archive-zoo)
+;; ------------------------------
+;; 7z archive configuration
+
+(defcustom archive-7z-extract
+ '("7z" "x" "-so")
+ "Program and its options to run in order to extract a 7z file member.
+Extraction should happen to standard output. Archive and member name will
+be added."
+ :type '(list (string :tag "Program")
+ (repeat :tag "Options"
+ :inline t
+ (string :format "%v")))
+ :group 'archive-7z)
+
;; -------------------------------------------------------------------------
;;; Section: Variables
@@ -602,7 +616,7 @@ the mode is invalid. If ERROR is nil then nil will be returned."
(defun archive-get-lineno ()
(if (>= (point) archive-file-list-start)
(count-lines archive-file-list-start
- (save-excursion (beginning-of-line) (point)))
+ (line-beginning-position))
0))
(defun archive-get-descr (&optional noerror)
@@ -732,6 +746,7 @@ archive.
((and (looking-at "MZ")
(re-search-forward "Rar!" (+ (point) 100000) t))
'rar-exe)
+ ((looking-at "7z\274\257\047\034") '7z)
(t (error "Buffer format not recognized")))))
;; -------------------------------------------------------------------------
@@ -1047,8 +1062,8 @@ using `make-temp-file', and the generated name is returned."
(archive-maybe-update t))
(or (not (buffer-name buffer))
(cond
- (view-p (view-buffer
- buffer (and just-created 'kill-buffer-if-not-modified)))
+ (view-p
+ (view-buffer buffer (and just-created 'kill-buffer-if-not-modified)))
((eq other-window-p 'display) (display-buffer buffer))
(other-window-p (switch-to-buffer-other-window buffer))
(t (switch-to-buffer buffer))))))
@@ -1081,11 +1096,11 @@ using `make-temp-file', and the generated name is returned."
(archive-delete-local tmpfile)
success))
-(defun archive-extract-by-stdout (archive name command)
+(defun archive-extract-by-stdout (archive name command &optional stderr-file)
(apply 'call-process
(car command)
nil
- t
+ (if stderr-file (list t stderr-file) t)
nil
(append (cdr command) (list archive name))))
@@ -1787,8 +1802,13 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(apply 'vector (nreverse files))))
(defun archive-zip-extract (archive name)
- (if (member-ignore-case (car archive-zip-extract) '("pkunzip" "pkzip"))
- (archive-*-extract archive name archive-zip-extract)
+ (cond
+ ((member-ignore-case (car archive-zip-extract) '("pkunzip" "pkzip"))
+ (archive-*-extract archive name archive-zip-extract))
+ ((equal (car archive-zip-extract) "7z")
+ (let ((archive-7z-extract archive-zip-extract))
+ (archive-7z-extract archive name)))
+ (t
(archive-extract-by-stdout
archive
;; unzip expands wildcards in NAME, so we need to quote it. But
@@ -1800,7 +1820,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(equal (car archive-zip-extract) "unzip"))
(shell-quote-argument name)
name)
- archive-zip-extract)))
+ archive-zip-extract))))
(defun archive-zip-write-file-member (archive descr)
(archive-*-write-file-member
@@ -2008,7 +2028,65 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(if tmpbuf (kill-buffer tmpbuf))
(delete-file tmpfile))))
+;; -------------------------------------------------------------------------
+;;; Section: 7z Archives
+(defun archive-7z-summarize ()
+ (let ((maxname 10)
+ (maxsize 5)
+ (file buffer-file-name)
+ (files ()))
+ (with-temp-buffer
+ (call-process "7z" nil t nil "l" "-slt" file)
+ (goto-char (point-min))
+ (re-search-forward "^-+\n")
+ (while (re-search-forward "^Path = \\(.*\\)\n" nil t)
+ (goto-char (match-end 0))
+ (let ((name (match-string 1))
+ (size (save-excursion
+ (and (re-search-forward "^Size = \\(.*\\)\n")
+ (match-string 1))))
+ (time (save-excursion
+ (and (re-search-forward "^Modified = \\(.*\\)\n")
+ (match-string 1)))))
+ (if (> (length name) maxname) (setq maxname (length name)))
+ (if (> (length size) maxsize) (setq maxsize (length size)))
+ (push (vector name name nil nil time nil nil size)
+ files))))
+ (setq files (nreverse files))
+ (goto-char (point-min))
+ (let* ((format (format " %%%ds %%s %%s" maxsize))
+ (sep (format format (make-string maxsize ?-) "-------------------" ""))
+ (column (length sep)))
+ (insert (format format "Size " "Date Time " " Filename") "\n")
+ (insert sep (make-string maxname ?-) "\n")
+ (archive-summarize-files (mapcar (lambda (desc)
+ (let ((text
+ (format format
+ (aref desc 7)
+ (aref desc 4)
+ (aref desc 1))))
+ (vector text
+ column
+ (length text))))
+ files))
+ (insert sep (make-string maxname ?-) "\n")
+ (apply 'vector files))))
+
+(defun archive-7z-extract (archive name)
+ (let ((tmpfile (make-temp-file "7z-stderr")))
+ ;; 7z doesn't provide a `quiet' option to suppress non-essential
+ ;; stderr messages. So redirect stderr to a temp file and display it
+ ;; in the echo area when it contains error messages.
+ (prog1 (archive-extract-by-stdout
+ archive name archive-7z-extract tmpfile)
+ (with-temp-buffer
+ (insert-file-contents tmpfile)
+ (unless (search-forward "Everything is Ok" nil t)
+ (message "%s" (buffer-string)))
+ (delete-file tmpfile)))))
+
+;; -------------------------------------------------------------------------
;;; Section `ar' archives.
;; TODO: we currently only handle the basic format of ar archives,
@@ -2135,5 +2213,4 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(provide 'arc-mode)
-;; arch-tag: e5966a01-35ec-4f27-8095-a043a79b457b
;;; arc-mode.el ends here
diff --git a/lisp/array.el b/lisp/array.el
index d68aaa5cf62..1f04e8ef724 100644
--- a/lisp/array.el
+++ b/lisp/array.el
@@ -1,7 +1,7 @@
;;; array.el --- array editing commands for GNU Emacs
;; Copyright (C) 1987, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010 Free Software Foundation, Inc.
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: David M. Brown
;; Maintainer: FSF
@@ -748,9 +748,7 @@ of `array-rows-numbered'."
(defun current-line ()
"Return the current buffer line at point. The first line is 0."
- (save-excursion
- (beginning-of-line)
- (count-lines (point-min) (point))))
+ (count-lines (point-min) (line-beginning-position)))
(defun move-to-column-untabify (column)
"Move to COLUMN on the current line, untabifying if necessary.
@@ -775,32 +773,30 @@ Return COLUMN."
;;; Array mode.
-(defvar array-mode-map nil
+(defvar array-mode-map
+ (let ((map (make-keymap)))
+ (define-key map "\M-ad" 'array-display-local-variables)
+ (define-key map "\M-am" 'array-make-template)
+ (define-key map "\M-ae" 'array-expand-rows)
+ (define-key map "\M-ar" 'array-reconfigure-rows)
+ (define-key map "\M-a=" 'array-what-position)
+ (define-key map "\M-ag" 'array-goto-cell)
+ (define-key map "\M-af" 'array-fill-rectangle)
+ (define-key map "\C-n" 'array-next-row)
+ (define-key map "\C-p" 'array-previous-row)
+ (define-key map "\C-f" 'array-forward-column)
+ (define-key map "\C-b" 'array-backward-column)
+ (define-key map "\M-n" 'array-copy-down)
+ (define-key map "\M-p" 'array-copy-up)
+ (define-key map "\M-f" 'array-copy-forward)
+ (define-key map "\M-b" 'array-copy-backward)
+ (define-key map "\M-\C-n" 'array-copy-row-down)
+ (define-key map "\M-\C-p" 'array-copy-row-up)
+ (define-key map "\M-\C-f" 'array-copy-column-forward)
+ (define-key map "\M-\C-b" 'array-copy-column-backward)
+ map)
"Keymap used in array mode.")
-(if array-mode-map
- ()
- (setq array-mode-map (make-keymap))
- ;; Bind keys.
- (define-key array-mode-map "\M-ad" 'array-display-local-variables)
- (define-key array-mode-map "\M-am" 'array-make-template)
- (define-key array-mode-map "\M-ae" 'array-expand-rows)
- (define-key array-mode-map "\M-ar" 'array-reconfigure-rows)
- (define-key array-mode-map "\M-a=" 'array-what-position)
- (define-key array-mode-map "\M-ag" 'array-goto-cell)
- (define-key array-mode-map "\M-af" 'array-fill-rectangle)
- (define-key array-mode-map "\C-n" 'array-next-row)
- (define-key array-mode-map "\C-p" 'array-previous-row)
- (define-key array-mode-map "\C-f" 'array-forward-column)
- (define-key array-mode-map "\C-b" 'array-backward-column)
- (define-key array-mode-map "\M-n" 'array-copy-down)
- (define-key array-mode-map "\M-p" 'array-copy-up)
- (define-key array-mode-map "\M-f" 'array-copy-forward)
- (define-key array-mode-map "\M-b" 'array-copy-backward)
- (define-key array-mode-map "\M-\C-n" 'array-copy-row-down)
- (define-key array-mode-map "\M-\C-p" 'array-copy-row-up)
- (define-key array-mode-map "\M-\C-f" 'array-copy-column-forward)
- (define-key array-mode-map "\M-\C-b" 'array-copy-column-backward))
(put 'array-mode 'mode-class 'special)
@@ -905,5 +901,4 @@ Entering array mode calls the function `array-mode-hook'."
(provide 'array)
-;; arch-tag: 0086605d-79fe-4a1a-992a-456417261f80
;;; array.el ends here
diff --git a/lisp/autoinsert.el b/lisp/autoinsert.el
index b3a594d31d4..9a8001875e0 100644
--- a/lisp/autoinsert.el
+++ b/lisp/autoinsert.el
@@ -126,10 +126,10 @@ If this contains a %s, that will be replaced by the matching rule."
_ "\n\\begin{document}\n" _
"\n\\end{document}")
- (("/bin/.*[^/]\\'" . "Shell-Script mode magic number")
- lambda ()
+ (("/bin/.*[^/]\\'" . "Shell-Script mode magic number") .
+ (lambda ()
(if (eq major-mode (default-value 'major-mode))
- (sh-mode)))
+ (sh-mode))))
(ada-mode . ada-header)
diff --git a/lisp/avoid.el b/lisp/avoid.el
index adfb1dd78c8..4b713b827b6 100644
--- a/lisp/avoid.el
+++ b/lisp/avoid.el
@@ -278,7 +278,8 @@ redefine this function to suit your own tastes."
(defun mouse-avoidance-ignore-p ()
(let ((mp (mouse-position)))
- (or executing-kbd-macro ; don't check inside macro
+ (or (not (frame-pointer-visible-p)) ; The pointer is hidden
+ executing-kbd-macro ; don't check inside macro
(null (cadr mp)) ; don't move unless in an Emacs frame
(not (eq (car mp) (selected-frame)))
;; Don't do anything if last event was a mouse event.
diff --git a/lisp/bindings.el b/lisp/bindings.el
index 3ce21a578d5..e9a4c559169 100644
--- a/lisp/bindings.el
+++ b/lisp/bindings.el
@@ -6,6 +6,7 @@
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -62,24 +63,6 @@ corresponding to the mode line clicked."
(force-mode-line-update)))
-(defun mode-line-abbrev-mode (event)
- "Turn off `abbrev-mode' from the mode-line."
- (interactive "e")
- (save-selected-window
- (select-window (posn-window (event-start event)))
- (abbrev-mode)
- (force-mode-line-update)))
-
-
-(defun mode-line-auto-fill-mode (event)
- "Turn off `auto-fill-mode' from the mode-line."
- (interactive "e")
- (save-selected-window
- (select-window (posn-window (event-start event)))
- (auto-fill-mode)
- (force-mode-line-update)))
-
-
(defvar mode-line-input-method-map
(let ((map (make-sparse-keymap)))
(define-key map [mode-line mouse-2]
@@ -335,7 +318,7 @@ Keymap to display on column and line numbers.")
mouse-2: Make current window occupy the whole frame\n\
mouse-3: Remove current window from display")
(recursive-edit-help-echo "Recursive edit, type C-M-c to get out")
- (dashes (propertize "--" 'help-echo help-echo))
+ (spaces (propertize " " 'help-echo help-echo))
(standard-mode-line-format
(list
"%e"
@@ -351,9 +334,10 @@ mouse-3: Remove current window from display")
'(vc-mode vc-mode)
(propertize " " 'help-echo help-echo)
'mode-line-modes
- `(which-func-mode ("" which-func-format ,dashes))
- `(global-mode-string ("" global-mode-string ,dashes))
- (propertize "-%-" 'help-echo help-echo)))
+ `(which-func-mode ("" which-func-format ,spaces))
+ `(global-mode-string ("" global-mode-string ,spaces))
+ `(:eval (unless (display-graphic-p)
+ ,(propertize "-%-" 'help-echo help-echo)))))
(standard-mode-line-modes
(list
(propertize "%[" 'help-echo recursive-edit-help-echo)
@@ -379,7 +363,7 @@ mouse-3: Toggle minor modes"
'mouse-2 #'mode-line-widen))
(propertize ")" 'help-echo help-echo)
(propertize "%]" 'help-echo recursive-edit-help-echo)
- (propertize "--" 'help-echo help-echo)))
+ spaces))
(standard-mode-line-position
`((-3 ,(propertize
@@ -671,30 +655,6 @@ is okay. See `mode-line-format'.")
(define-key esc-map "\t" 'complete-symbol)
-(defun complete-symbol (arg)
- "Perform tags completion on the text around point.
-If a tags table is loaded, call `complete-tag'.
-Otherwise, if Semantic is active, call `semantic-ia-complete-symbol'.
-
-With a prefix argument, this command does completion within
-the collection of symbols listed in the index of the manual for the
-language you are using."
- (interactive "P")
- (cond (arg
- (info-complete-symbol))
- ((or tags-table-list tags-file-name)
- (complete-tag))
- ((and (fboundp 'semantic-ia-complete-symbol)
- (fboundp 'semantic-active-p)
- (semantic-active-p))
- (semantic-ia-complete-symbol))
- (completion-at-point-functions (completion-at-point))
- (t
- (error "%s"
- (substitute-command-keys
- "No completions available; use \\[visit-tags-table] \
-or \\[semantic-mode]")))))
-
;; Reduce total amount of space we must allocate during this function
;; that we will not need to keep permanently.
(garbage-collect)
@@ -720,6 +680,63 @@ or \\[semantic-mode]")))))
;but they are not assigned to keys there.
(put 'narrow-to-region 'disabled t)
+;; Moving with arrows in bidi-sensitive direction.
+(defun right-char (&optional n)
+ "Move point N characters to the right (to the left if N is negative).
+On reaching beginning or end of buffer, stop and signal error.
+
+Depending on the bidirectional context, this may move either forward
+or backward in the buffer. This is in contrast with \\[forward-char]
+and \\[backward-char], which see."
+ (interactive "^p")
+ (if (eq (current-bidi-paragraph-direction) 'left-to-right)
+ (forward-char n)
+ (backward-char n)))
+
+(defun left-char ( &optional n)
+ "Move point N characters to the left (to the right if N is negative).
+On reaching beginning or end of buffer, stop and signal error.
+
+Depending on the bidirectional context, this may move either backward
+or forward in the buffer. This is in contrast with \\[backward-char]
+and \\[forward-char], which see."
+ (interactive "^p")
+ (if (eq (current-bidi-paragraph-direction) 'left-to-right)
+ (backward-char n)
+ (forward-char n)))
+
+(defun right-word (&optional n)
+ "Move point N words to the right (to the left if N is negative).
+
+Depending on the bidirectional context, this may move either forward
+or backward in the buffer. This is in contrast with \\[forward-word]
+and \\[backward-word], which see.
+
+Value is normally t.
+If an edge of the buffer or a field boundary is reached, point is left there
+there and the function returns nil. Field boundaries are not noticed
+if `inhibit-field-text-motion' is non-nil."
+ (interactive "^p")
+ (if (eq (current-bidi-paragraph-direction) 'left-to-right)
+ (forward-word n)
+ (backward-word n)))
+
+(defun left-word (&optional n)
+ "Move point N words to the left (to the right if N is negative).
+
+Depending on the bidirectional context, this may move either backward
+or forward in the buffer. This is in contrast with \\[backward-word]
+and \\[forward-word], which see.
+
+Value is normally t.
+If an edge of the buffer or a field boundary is reached, point is left there
+there and the function returns nil. Field boundaries are not noticed
+if `inhibit-field-text-motion' is non-nil."
+ (interactive "^p")
+ (if (eq (current-bidi-paragraph-direction) 'left-to-right)
+ (backward-word n)
+ (forward-word n)))
+
(defvar narrow-map (make-sparse-keymap)
"Keymap for narrowing commands.")
(define-key ctl-x-map "n" narrow-map)
@@ -807,6 +824,9 @@ or \\[semantic-mode]")))))
(setq i (1+ i))))
(define-key global-map [?\C-\M--] 'negative-argument)
+(define-key global-map "\177" 'delete-backward-char)
+(define-key global-map "\C-d" 'delete-char)
+
(define-key global-map "\C-k" 'kill-line)
(define-key global-map "\C-w" 'kill-region)
(define-key esc-map "w" 'kill-ring-save)
@@ -870,12 +890,12 @@ or \\[semantic-mode]")))))
(define-key global-map [C-home] 'beginning-of-buffer)
(define-key global-map [M-home] 'beginning-of-buffer-other-window)
(define-key esc-map [home] 'beginning-of-buffer-other-window)
-(define-key global-map [left] 'backward-char)
+(define-key global-map [left] 'left-char)
(define-key global-map [up] 'previous-line)
-(define-key global-map [right] 'forward-char)
+(define-key global-map [right] 'right-char)
(define-key global-map [down] 'next-line)
-(define-key global-map [prior] 'scroll-down)
-(define-key global-map [next] 'scroll-up)
+(define-key global-map [prior] 'scroll-down-command)
+(define-key global-map [next] 'scroll-up-command)
(define-key global-map [C-up] 'backward-paragraph)
(define-key global-map [C-down] 'forward-paragraph)
(define-key global-map [C-prior] 'scroll-right)
@@ -914,7 +934,7 @@ or \\[semantic-mode]")))))
;; (define-key global-map [clearline] 'function-key-error)
(define-key global-map [insertline] 'open-line)
(define-key global-map [deleteline] 'kill-line)
-(define-key global-map [deletechar] 'delete-char)
+(define-key global-map [deletechar] 'delete-forward-char)
;; (define-key global-map [backtab] 'function-key-error)
;; (define-key global-map [f1] 'function-key-error)
;; (define-key global-map [f2] 'function-key-error)
@@ -1075,8 +1095,8 @@ or \\[semantic-mode]")))))
(global-set-key [M-left] 'backward-word)
(define-key esc-map [left] 'backward-word)
;; ilya@math.ohio-state.edu says these bindings are standard on PC editors.
-(global-set-key [C-right] 'forward-word)
-(global-set-key [C-left] 'backward-word)
+(global-set-key [C-right] 'right-word)
+(global-set-key [C-left] 'left-word)
;; This is not quite compatible, but at least is analogous
(global-set-key [C-delete] 'kill-word)
(global-set-key [C-backspace] 'backward-kill-word)
diff --git a/lisp/bookmark.el b/lisp/bookmark.el
index 9515837fc28..11883febb07 100644
--- a/lisp/bookmark.el
+++ b/lisp/bookmark.el
@@ -1,7 +1,8 @@
;;; bookmark.el --- set bookmarks, maybe annotate them, jump to them later
-;; Copyright (C) 1993, 1994, 1995, 1996, 1997, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1994, 1995, 1996, 1997, 2001, 2002, 2003, 2004,
+;; 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Karl Fogel <kfogel@red-bean.com>
;; Maintainer: Karl Fogel <kfogel@red-bean.com>
@@ -92,7 +93,7 @@ To specify the file in which to save them, modify the variable
(if bookmark-file
;; In case user set `bookmark-file' in her .emacs:
bookmark-file
- (convert-standard-filename "~/.emacs.bmk"))
+ (locate-user-emacs-file "bookmarks" ".emacs.bmk"))
"File in which to save bookmarks by default."
:type 'file
:group 'bookmark)
@@ -528,26 +529,36 @@ old one."
(setq bookmark-current-bookmark stripped-name)
(bookmark-bmenu-surreptitiously-rebuild-list)))
-(defun bookmark-make-record-default (&optional point-only)
+(defun bookmark-make-record-default (&optional no-file no-context posn)
"Return the record describing the location of a new bookmark.
-Must be at the correct position in the buffer in which the bookmark is
-being set.
-If POINT-ONLY is non-nil, then only return the subset of the
-record that pertains to the location within the buffer."
- `(,@(unless point-only `((filename . ,(bookmark-buffer-file-name))))
- (front-context-string
- . ,(if (>= (- (point-max) (point)) bookmark-search-size)
- (buffer-substring-no-properties
- (point)
- (+ (point) bookmark-search-size))
- nil))
- (rear-context-string
- . ,(if (>= (- (point) (point-min)) bookmark-search-size)
- (buffer-substring-no-properties
- (point)
- (- (point) bookmark-search-size))
- nil))
- (position . ,(point))))
+Point should be at the buffer in which the bookmark is being set,
+and normally should be at the position where the bookmark is desired,
+but see the optional arguments for other possibilities.
+
+If NO-FILE is non-nil, then only return the subset of the
+record that pertains to the location within the buffer, leaving off
+the part that records the filename.
+
+If NO-CONTEXT is non-nil, do not include the front- and rear-context
+strings in the record -- the position is enough.
+
+If POSN is non-nil, record POSN as the point instead of `(point)'."
+ `(,@(unless no-file `((filename . ,(bookmark-buffer-file-name))))
+ ,@(unless no-context `((front-context-string
+ . ,(if (>= (- (point-max) (point))
+ bookmark-search-size)
+ (buffer-substring-no-properties
+ (point)
+ (+ (point) bookmark-search-size))
+ nil))))
+ ,@(unless no-context `((rear-context-string
+ . ,(if (>= (- (point) (point-min))
+ bookmark-search-size)
+ (buffer-substring-no-properties
+ (point)
+ (- (point) bookmark-search-size))
+ nil))))
+ (position . ,(or posn (point)))))
;;; File format stuff
@@ -773,33 +784,40 @@ Use \\[bookmark-delete] to remove bookmarks (you give it a name and
it removes only the first instance of a bookmark with that name from
the list of bookmarks.)"
(interactive (list nil current-prefix-arg))
- (let* ((record (bookmark-make-record))
- (default (car record)))
+ (unwind-protect
+ (let* ((record (bookmark-make-record))
+ (default (car record)))
+
+ (bookmark-maybe-load-default-file)
+ ;; Don't set `bookmark-yank-point' and `bookmark-current-buffer'
+ ;; if they have been already set in another buffer. (e.g gnus-art).
+ (unless (and bookmark-yank-point
+ bookmark-current-buffer)
+ (setq bookmark-yank-point (point))
+ (setq bookmark-current-buffer (current-buffer)))
+
+ (let ((str
+ (or name
+ (read-from-minibuffer
+ (format "Set bookmark (%s): " default)
+ nil
+ bookmark-minibuffer-read-name-map
+ nil nil default))))
+ (and (string-equal str "") (setq str default))
+ (bookmark-store str (cdr record) no-overwrite)
+
+ ;; Ask for an annotation buffer for this bookmark
+ (when bookmark-use-annotations
+ (bookmark-edit-annotation str))))
+ (setq bookmark-yank-point nil)
+ (setq bookmark-current-buffer nil)))
- (bookmark-maybe-load-default-file)
-
- (setq bookmark-yank-point (point))
- (setq bookmark-current-buffer (current-buffer))
-
- (let ((str
- (or name
- (read-from-minibuffer
- (format "Set bookmark (%s): " default)
- nil
- bookmark-minibuffer-read-name-map
- nil nil default))))
- (and (string-equal str "") (setq str default))
- (bookmark-store str (cdr record) no-overwrite)
-
- ;; Ask for an annotation buffer for this bookmark
- (when bookmark-use-annotations
- (bookmark-edit-annotation str)))))
(defun bookmark-kill-line (&optional newline-too)
"Kill from point to end of line.
If optional arg NEWLINE-TOO is non-nil, delete the newline too.
Does not affect the kill ring."
- (let ((eol (save-excursion (end-of-line) (point))))
+ (let ((eol (line-end-position)))
(delete-region (point) eol)
(if (and newline-too (looking-at "\n"))
(delete-char 1))))
@@ -1176,7 +1194,7 @@ minibuffer history list `bookmark-history'."
(or no-history (bookmark-maybe-historicize-string bookmark))
(let ((start (point)))
(prog1
- (insert (bookmark-location bookmark)) ; *Return this line*
+ (insert (bookmark-location bookmark))
(if (display-mouse-p)
(add-text-properties
start
@@ -1191,10 +1209,16 @@ minibuffer history list `bookmark-history'."
(defalias 'bookmark-locate 'bookmark-insert-location)
(defun bookmark-location (bookmark)
- "Return the name of the file associated with BOOKMARK, or nil if none.
+ "Return a description of the location of BOOKMARK.
BOOKMARK may be a bookmark name (a string) or a bookmark record."
(bookmark-maybe-load-default-file)
- (bookmark-get-filename bookmark))
+ ;; We could call the `handler' and ask for it to construct a description
+ ;; dynamically: it would open up several new possibilities, but it
+ ;; would have the major disadvantage of forcing to load each and
+ ;; every handler when the user calls bookmark-menu.
+ (or (bookmark-prop-get bookmark 'location)
+ (bookmark-get-filename bookmark)
+ "-- Unknown location --"))
;;;###autoload
@@ -1661,7 +1685,7 @@ mainly for debugging, and should not be necessary in normal use."
(while (< (point) (point-max))
(let ((bmrk (bookmark-bmenu-bookmark)))
(push bmrk bookmark-bmenu-hidden-bookmarks)
- (let ((start (save-excursion (end-of-line) (point))))
+ (let ((start (line-end-position)))
(move-to-column bookmark-bmenu-file-column t)
;; Strip off `mouse-face' from the white spaces region.
(if (display-mouse-p)
@@ -1727,15 +1751,15 @@ last full line, move to the last full line. The return value is undefined."
"Display the annotation for bookmark named BOOKMARK in a buffer,
if an annotation exists."
(let ((annotation (bookmark-get-annotation bookmark)))
- (if (and annotation (not (string-equal annotation "")))
- (save-excursion
- (let ((old-buf (current-buffer)))
- (pop-to-buffer (get-buffer-create "*Bookmark Annotation*") t)
- (delete-region (point-min) (point-max))
- ;; (insert (concat "Annotation for bookmark '" bookmark "':\n\n"))
- (insert annotation)
- (goto-char (point-min))
- (pop-to-buffer old-buf))))))
+ (when (and annotation (not (string-equal annotation "")))
+ (save-excursion
+ (let ((old-buf (current-buffer)))
+ (pop-to-buffer (get-buffer-create "*Bookmark Annotation*") t)
+ (delete-region (point-min) (point-max))
+ ;; (insert (concat "Annotation for bookmark '" bookmark "':\n\n"))
+ (insert annotation)
+ (goto-char (point-min))
+ (switch-to-buffer-other-window old-buf))))))
(defun bookmark-show-all-annotations ()
@@ -2173,7 +2197,7 @@ strings returned are not."
;; Load Hook
(defvar bookmark-load-hook nil
- "Hook run at the end of loading bookmark.")
+ "Hook run at the end of loading library `bookmark.el'.")
;; Exit Hook, called from kill-emacs-hook
(defvar bookmark-exit-hook nil
@@ -2202,5 +2226,4 @@ This also runs `bookmark-exit-hook'."
(provide 'bookmark)
-;; arch-tag: 139f519a-dd0c-4b8d-8b5d-f9fcf53ca8f6
;;; bookmark.el ends here
diff --git a/lisp/bs.el b/lisp/bs.el
index ef2e5834edc..0ce7670201d 100644
--- a/lisp/bs.el
+++ b/lisp/bs.el
@@ -1152,7 +1152,7 @@ and move point to current buffer."
(dolist (buffer list)
(bs--insert-one-entry buffer)
(insert "\n"))
- (delete-backward-char 1)
+ (delete-char -1)
(bs--set-window-height)
(bs--goto-current-buffer)
(font-lock-fontify-buffer)
diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el
index 9ec78309f9d..21fdada22c2 100644
--- a/lisp/buff-menu.el
+++ b/lisp/buff-menu.el
@@ -1,10 +1,12 @@
;;; buff-menu.el --- buffer menu main function and support functions -*- coding:utf-8 -*-
-;; Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 2000, 2001, 2002,
+;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: convenience
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -302,9 +304,7 @@ negative ARG, display other buffers as well."
(defun Buffer-menu-buffer (error-if-non-existent-p)
"Return buffer described by this line of buffer menu."
- (let* ((where (save-excursion
- (beginning-of-line)
- (+ (point) Buffer-menu-buffer-column)))
+ (let* ((where (+ (line-beginning-position) Buffer-menu-buffer-column))
(name (and (not (eobp)) (get-text-property where 'buffer-name)))
(buf (and (not (eobp)) (get-text-property where 'buffer))))
(if name
@@ -923,5 +923,4 @@ For more information, see the function `buffer-menu'."
(set-buffer-modified-p nil)
(current-buffer))))
-;; arch-tag: e7dfcfc9-6cb2-46e4-bf55-8ef1936d83c6
;;; buff-menu.el ends here
diff --git a/lisp/button.el b/lisp/button.el
index 2a9a49c399a..c771474da3a 100644
--- a/lisp/button.el
+++ b/lisp/button.el
@@ -5,6 +5,7 @@
;;
;; Author: Miles Bader <miles@gnu.org>
;; Keywords: extensions
+;; Package: emacs
;;
;; This file is part of GNU Emacs.
;;
diff --git a/lisp/calc/.arch-inventory b/lisp/calc/.arch-inventory
deleted file mode 100644
index e4e8f8239ce..00000000000
--- a/lisp/calc/.arch-inventory
+++ /dev/null
@@ -1,4 +0,0 @@
-# Auto-generated lisp files, which ignore
-precious ^(.*-loaddefs)\.el$
-
-# arch-tag: 5258f69e-459b-449b-bdd7-bdbd5f948cb9
diff --git a/lisp/calc/README b/lisp/calc/README
index 9e095252fc1..b23666018e5 100644
--- a/lisp/calc/README
+++ b/lisp/calc/README
@@ -72,6 +72,19 @@ opinions.
Summary of changes to "Calc"
------- -- ------- -- ----
+Emacs 24.1
+
+* Calc no longer uses the tex prefix for TeX specific unit
+names when using TeX or LaTeX mode.
+
+* Added option to highlight selections using faces.
+
+* Gave `calc-histogram' the option of using a vector to determine the bins.
+
+* Added "O" option prefix.
+
+* Used "O" prefix to "d r" (`calc-radix') to turn on twos-complement mode.
+
Emacs 23.2
* Added twos-complement display.
diff --git a/lisp/calc/calc-aent.el b/lisp/calc/calc-aent.el
index 58e30a237f9..472133be84f 100644
--- a/lisp/calc/calc-aent.el
+++ b/lisp/calc/calc-aent.el
@@ -1,7 +1,7 @@
;;; calc-aent.el --- algebraic entry functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004, 2005,
+;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -315,10 +315,24 @@ The value t means abort and give an error message.")
calc-dollar-used 0)))
(calc-handle-whys))))
-(defvar calc-alg-ent-map nil
+(defvar calc-alg-ent-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map minibuffer-local-map)
+ (define-key map "'" 'calcAlg-previous)
+ (define-key map "`" 'calcAlg-edit)
+ (define-key map "\C-m" 'calcAlg-enter)
+ (define-key map "\C-j" 'calcAlg-enter)
+ map)
"The keymap used for algebraic entry.")
-(defvar calc-alg-ent-esc-map nil
+(defvar calc-alg-ent-esc-map
+ (let ((map (make-keymap))
+ (i 33))
+ (set-keymap-parent map esc-map)
+ (while (< i 127)
+ (define-key map (vector i) 'calcAlg-escape)
+ (setq i (1+ i)))
+ map)
"The keymap used for escapes in algebraic entry.")
(defvar calc-alg-exp)
@@ -326,19 +340,8 @@ The value t means abort and give an error message.")
;;;###autoload
(defun calc-do-alg-entry (&optional initial prompt no-normalize history)
(let* ((calc-buffer (current-buffer))
- (blink-paren-function 'calcAlg-blink-matching-open)
+ (blink-matching-check-function 'calcAlg-blink-matching-check)
(calc-alg-exp 'error))
- (unless calc-alg-ent-map
- (setq calc-alg-ent-map (copy-keymap minibuffer-local-map))
- (define-key calc-alg-ent-map "'" 'calcAlg-previous)
- (define-key calc-alg-ent-map "`" 'calcAlg-edit)
- (define-key calc-alg-ent-map "\C-m" 'calcAlg-enter)
- (define-key calc-alg-ent-map "\C-j" 'calcAlg-enter)
- (let ((i 33))
- (setq calc-alg-ent-esc-map (copy-keymap esc-map))
- (while (< i 127)
- (aset (nth 1 calc-alg-ent-esc-map) i 'calcAlg-escape)
- (setq i (1+ i)))))
(define-key calc-alg-ent-map "\e" nil)
(if (eq calc-algebraic-mode 'total)
(define-key calc-alg-ent-map "\e" calc-alg-ent-esc-map)
@@ -430,18 +433,9 @@ The value t means abort and give an error message.")
exp))
(exit-minibuffer))))
-(defun calcAlg-blink-matching-open ()
- (let ((rightpt (point))
- (leftpt nil)
- (rightchar (preceding-char))
- leftchar
- rightsyntax
- leftsyntax)
- (save-excursion
- (condition-case ()
- (setq leftpt (scan-sexps rightpt -1)
- leftchar (char-after leftpt))
- (error nil)))
+(defun calcAlg-blink-matching-check (leftpt rightpt)
+ (let ((rightchar (char-before rightpt))
+ (leftchar (if leftpt (char-after leftpt))))
(if (and leftpt
(or (and (= rightchar ?\))
(= leftchar ?\[))
@@ -450,20 +444,9 @@ The value t means abort and give an error message.")
(save-excursion
(goto-char leftpt)
(looking-at ".+\\(\\.\\.\\|\\\\dots\\|\\\\ldots\\)")))
- (let ((leftsaved (aref (syntax-table) leftchar))
- (rightsaved (aref (syntax-table) rightchar)))
- (unwind-protect
- (progn
- (cond ((= leftchar ?\[)
- (aset (syntax-table) leftchar (cons 4 ?\)))
- (aset (syntax-table) rightchar (cons 5 ?\[)))
- (t
- (aset (syntax-table) leftchar (cons 4 ?\]))
- (aset (syntax-table) rightchar (cons 5 ?\())))
- (blink-matching-open))
- (aset (syntax-table) leftchar leftsaved)
- (aset (syntax-table) rightchar rightsaved)))
- (blink-matching-open))))
+ ;; [2..5) perfectly valid!
+ nil
+ (blink-matching-check-mismatch leftpt rightpt))))
;;;###autoload
(defun calc-alg-digit-entry ()
@@ -510,6 +493,7 @@ The value t means abort and give an error message.")
("≥" ">=")
("≦" "<=")
("≧" ">=")
+ ("µ" "μ")
;; fractions
("¼" "(1:4)") ; 1/4
("½" "(1:2)") ; 1/2
@@ -608,9 +592,9 @@ in Calc algebraic input.")
(setq math-exp-str (math-remove-percentsigns math-exp-str)))
(if calc-language-input-filter
(setq math-exp-str (funcall calc-language-input-filter math-exp-str)))
- (while (setq math-exp-token
+ (while (setq math-exp-token
(string-match "\\.\\.\\([^.]\\|.[^.]\\)" math-exp-str))
- (setq math-exp-str
+ (setq math-exp-str
(concat (substring math-exp-str 0 math-exp-token) "\\dots"
(substring math-exp-str (+ math-exp-token 2)))))
(math-build-parse-table)
@@ -675,11 +659,11 @@ in Calc algebraic input.")
(cond ((and (stringp (car p))
(or (> (length (car p)) 1) (equal (car p) "$")
(equal (car p) "\""))
- (string-match "[^a-zA-Z0-9]" (car p)))
+ (string-match "[^a-zA-Zα-ωΑ-Ω0-9]" (car p)))
(let ((s (regexp-quote (car p))))
- (if (string-match "\\`[a-zA-Z0-9]" s)
+ (if (string-match "\\`[a-zA-Zα-ωΑ-Ω0-9]" s)
(setq s (concat "\\<" s)))
- (if (string-match "[a-zA-Z0-9]\\'" s)
+ (if (string-match "[a-zA-Zα-ωΑ-Ω0-9]\\'" s)
(setq s (concat s "\\>")))
(or (assoc s math-toks)
(progn
@@ -711,22 +695,24 @@ in Calc algebraic input.")
(math-read-token)))
((and (memq ch calc-user-token-chars)
(let ((case-fold-search nil))
- (eq (string-match
+ (eq (string-match
calc-user-tokens math-exp-str math-exp-pos)
math-exp-pos)))
(setq math-exp-token 'punc
math-expr-data (math-match-substring math-exp-str 0)
math-exp-pos (match-end 0)))
((or (and (>= ch ?a) (<= ch ?z))
- (and (>= ch ?A) (<= ch ?Z)))
- (string-match
+ (and (>= ch ?A) (<= ch ?Z))
+ (and (>= ch ?α) (<= ch ?ω))
+ (and (>= ch ?Α) (<= ch ?Ω)))
+ (string-match
(cond
((and (memq calc-language calc-lang-allow-underscores)
(memq calc-language calc-lang-allow-percentsigns))
- "[a-zA-Z0-9_'#]*")
+ "[a-zA-Zα-ωΑ-Ω0-9_'#]*")
((memq calc-language calc-lang-allow-underscores)
- "[a-zA-Z0-9_#]*")
- (t "[a-zA-Z0-9'#]*"))
+ "[a-zA-Zα-ωΑ-Ω0-9_#]*")
+ (t "[a-zA-Zα-ωΑ-Ω0-9'#]*"))
math-exp-str math-exp-pos)
(setq math-exp-token 'symbol
math-exp-pos (match-end 0)
@@ -742,19 +728,19 @@ in Calc algebraic input.")
(eq (string-match "_\\.?[0-9]" math-exp-str math-exp-pos)
math-exp-pos)
(or (eq math-exp-pos 0)
- (and (not (memq calc-language
+ (and (not (memq calc-language
calc-lang-allow-underscores))
- (eq (string-match "[^])}\"a-zA-Z0-9'$]_"
+ (eq (string-match "[^])}\"a-zA-Zα-ωΑ-Ω0-9'$]_"
math-exp-str (1- math-exp-pos))
(1- math-exp-pos))))))
(or (and (memq calc-language calc-lang-c-type-hex)
(string-match "0[xX][0-9a-fA-F]+" math-exp-str math-exp-pos))
- (string-match "_?\\([0-9]+.?0*@ *\\)?\\([0-9]+.?0*' *\\)?\\(0*\\([2-9]\\|1[0-4]\\)\\(#[#]?\\|\\^\\^\\)[0-9a-dA-D.]+[eE][-+_]?[0-9]+\\|0*\\([2-9]\\|[0-2][0-9]\\|3[0-6]\\)\\(#[#]?\\|\\^\\^\\)[0-9a-zA-Z:.]+\\|[0-9]+:[0-9:]+\\|[0-9.]+\\([eE][-+_]?[0-9]+\\)?\"?\\)?"
+ (string-match "_?\\([0-9]+.?0*@ *\\)?\\([0-9]+.?0*' *\\)?\\(0*\\([2-9]\\|1[0-4]\\)\\(#[#]?\\|\\^\\^\\)[0-9a-dA-D.]+[eE][-+_]?[0-9]+\\|0*\\([2-9]\\|[0-2][0-9]\\|3[0-6]\\)\\(#[#]?\\|\\^\\^\\)[0-9a-zA-Zα-ωΑ-Ω:.]+\\|[0-9]+:[0-9:]+\\|[0-9.]+\\([eE][-+_]?[0-9]+\\)?\"?\\)?"
math-exp-str math-exp-pos))
(setq math-exp-token 'number
math-expr-data (math-match-substring math-exp-str 0)
math-exp-pos (match-end 0)))
- ((and (setq adfn
+ ((and (setq adfn
(assq ch (get calc-language 'math-lang-read-symbol)))
(eval (nth 1 adfn)))
(eval (nth 2 adfn)))
@@ -807,8 +793,8 @@ in Calc algebraic input.")
(defun math-read-expr-level (exp-prec &optional exp-term)
(let* ((math-expr-opers (math-expr-ops))
- (x (math-read-factor))
- (first t)
+ (x (math-read-factor))
+ (first t)
op op2)
(while (and (or (and calc-user-parse-table
(setq op (calc-check-user-syntax x exp-prec))
@@ -829,8 +815,8 @@ in Calc algebraic input.")
(memq math-exp-token '(symbol number dollar hash))
(equal math-expr-data "(")
(and (equal math-expr-data "[")
- (not (equal
- (get calc-language
+ (not (equal
+ (get calc-language
'math-function-open) "["))
(not (and math-exp-keep-spaces
(eq (car-safe x) 'vec)))))
@@ -1138,8 +1124,8 @@ If the current Calc language does not use placeholders, return nil."
(eq math-exp-token 'end)))
(throw 'syntax "Expected `)'"))
(math-read-token)
- (if (and (memq calc-language
- calc-lang-parens-are-subscripts)
+ (if (and (memq calc-language
+ calc-lang-parens-are-subscripts)
args
(require 'calc-ext)
(let ((calc-matrix-mode 'scalar))
@@ -1181,7 +1167,7 @@ If the current Calc language does not use placeholders, return nil."
(substring (symbol-name (cdr v))
4))
(cdr v))))))
- (while (and (memq calc-language
+ (while (and (memq calc-language
calc-lang-brackets-are-subscripts)
(equal math-expr-data "["))
(math-read-token)
@@ -1281,6 +1267,7 @@ If the current Calc language does not use placeholders, return nil."
(provide 'calc-aent)
;; Local variables:
+;; coding: utf-8
;; generated-autoload-file: "calc-loaddefs.el"
;; End:
diff --git a/lisp/calc/calc-alg.el b/lisp/calc/calc-alg.el
index 6a85be14aeb..47cdae52a13 100644
--- a/lisp/calc/calc-alg.el
+++ b/lisp/calc/calc-alg.el
@@ -1659,11 +1659,11 @@
;; math-is-poly-rec.
(defvar math-is-poly-degree)
(defvar math-is-poly-loose)
-(defvar var)
+(defvar math-var)
-(defun math-is-polynomial (expr var &optional math-is-poly-degree math-is-poly-loose)
+(defun math-is-polynomial (expr math-var &optional math-is-poly-degree math-is-poly-loose)
(let* ((math-poly-base-variable (if math-is-poly-loose
- (if (eq math-is-poly-loose 'gen) var '(var XXX XXX))
+ (if (eq math-is-poly-loose 'gen) math-var '(var XXX XXX))
math-poly-base-variable))
(poly (math-is-poly-rec expr math-poly-neg-powers)))
(and (or (null math-is-poly-degree)
@@ -1672,11 +1672,11 @@
(defun math-is-poly-rec (expr negpow)
(math-poly-simplify
- (or (cond ((or (equal expr var)
+ (or (cond ((or (equal expr math-var)
(eq (car-safe expr) '^))
(let ((pow 1)
(expr expr))
- (or (equal expr var)
+ (or (equal expr math-var)
(setq pow (nth 2 expr)
expr (nth 1 expr)))
(or (eq math-poly-mult-powers 1)
@@ -1690,7 +1690,7 @@
(equal math-poly-mult-powers
(nth 1 m))
(setq math-poly-mult-powers (nth 1 m)))
- (or (equal expr var)
+ (or (equal expr math-var)
(eq math-poly-mult-powers 1))
(car m)))))
(if (consp pow)
@@ -1698,7 +1698,7 @@
(setq pow (math-to-simple-fraction pow))
(and (eq (car-safe pow) 'frac)
math-poly-frac-powers
- (equal expr var)
+ (equal expr math-var)
(setq math-poly-frac-powers
(calcFunc-lcm math-poly-frac-powers
(nth 2 pow))))))
@@ -1706,10 +1706,10 @@
(setq pow (math-mul pow math-poly-frac-powers)))
(if (integerp pow)
(if (and (= pow 1)
- (equal expr var))
+ (equal expr math-var))
(list 0 1)
(if (natnump pow)
- (let ((p1 (if (equal expr var)
+ (let ((p1 (if (equal expr math-var)
(list 0 1)
(math-is-poly-rec expr nil)))
(n pow)
@@ -1749,7 +1749,7 @@
math-is-poly-degree))
(math-poly-mul p1 p2))))))
((eq (car expr) '/)
- (and (or (not (math-poly-depends (nth 2 expr) var))
+ (and (or (not (math-poly-depends (nth 2 expr) math-var))
(and negpow
(math-is-poly-rec (nth 2 expr) nil)
(setq math-poly-neg-powers
@@ -1759,13 +1759,13 @@
(mapcar (function (lambda (x) (math-div x (nth 2 expr))))
p1))))
((and (eq (car expr) 'calcFunc-exp)
- (equal var '(var e var-e)))
- (math-is-poly-rec (list '^ var (nth 1 expr)) negpow))
+ (equal math-var '(var e var-e)))
+ (math-is-poly-rec (list '^ math-var (nth 1 expr)) negpow))
((and (eq (car expr) 'calcFunc-sqrt)
math-poly-frac-powers)
(math-is-poly-rec (list '^ (nth 1 expr) '(frac 1 2)) negpow))
(t nil))
- (and (or (not (math-poly-depends expr var))
+ (and (or (not (math-poly-depends expr math-var))
math-is-poly-loose)
(not (eq (car expr) 'vec))
(list expr)))))
diff --git a/lisp/calc/calc-bin.el b/lisp/calc/calc-bin.el
index 7af60e92140..4ab698ea640 100644
--- a/lisp/calc/calc-bin.el
+++ b/lisp/calc/calc-bin.el
@@ -175,7 +175,7 @@ the size of a Calc bignum digit.")
(progn
(calc-change-mode
(list 'calc-number-radix 'calc-twos-complement-mode)
- (list n (and (or (= n 2) (= n 8) (= n 16)) arg)) t)
+ (list n (or arg (calc-is-option))) t)
;; also change global value so minibuffer sees it
(setq-default calc-number-radix calc-number-radix))
(setq n calc-number-radix))
@@ -845,6 +845,8 @@ the size of a Calc bignum digit.")
(len (length num)))
(if (< len digs)
(setq num (concat (make-string (- digs len) ?0) num))))
+ (when calc-group-digits
+ (setq num (math-group-float num)))
(concat
(number-to-string calc-number-radix)
"##"
diff --git a/lisp/calc/calc-ext.el b/lisp/calc/calc-ext.el
index 61ec3573282..18e63655ecf 100644
--- a/lisp/calc/calc-ext.el
+++ b/lisp/calc/calc-ext.el
@@ -1,7 +1,7 @@
;;; calc-ext.el --- various extension functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004, 2005,
+;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -104,6 +104,7 @@
(define-key calc-mode-map "J" 'calc-conj)
(define-key calc-mode-map "L" 'calc-ln)
(define-key calc-mode-map "N" 'calc-eval-num)
+ (define-key calc-mode-map "O" 'calc-option)
(define-key calc-mode-map "P" 'calc-pi)
(define-key calc-mode-map "Q" 'calc-sqrt)
(define-key calc-mode-map "R" 'calc-round)
@@ -959,7 +960,7 @@ math-read-brackets math-reduce-cols math-reduce-vec math-transpose)
("calc-yank" calc-alg-edit calc-clean-newlines
calc-do-grab-rectangle calc-do-grab-region calc-finish-stack-edit
-calc-copy-to-register calc-insert-register
+calc-copy-to-register calc-insert-register
calc-append-to-register calc-prepend-to-register
calc-force-refresh calc-locate-cursor-element calc-show-edit-buffer)
@@ -988,7 +989,7 @@ calc-floor calc-idiv calc-increment calc-mant-part calc-max calc-min
calc-round calc-scale-float calc-sign calc-trunc calc-xpon-part)
("calc-bin" calc-and calc-binary-radix calc-clip calc-twos-complement-mode
-calc-decimal-radix calc-diff calc-hex-radix calc-leading-zeros
+calc-decimal-radix calc-diff calc-hex-radix calc-leading-zeros
calc-lshift-arith calc-lshift-binary calc-not calc-octal-radix calc-or calc-radix
calc-rotate-binary calc-rshift-arith calc-rshift-binary calc-word-size
calc-xor)
@@ -1045,7 +1046,7 @@ calc-graph-zero-x calc-graph-zero-y)
calc-d-prefix-help calc-describe-function calc-describe-key
calc-describe-key-briefly calc-describe-variable calc-f-prefix-help
calc-full-help calc-g-prefix-help calc-help-prefix
-calc-hyperbolic-prefix-help calc-inv-hyp-prefix-help
+calc-hyperbolic-prefix-help calc-inv-hyp-prefix-help calc-option-prefix-help
calc-inverse-prefix-help calc-j-prefix-help calc-k-prefix-help
calc-m-prefix-help calc-r-prefix-help calc-s-prefix-help
calc-t-prefix-help calc-u-prefix-help calc-v-prefix-help)
@@ -1408,9 +1409,18 @@ calc-kill calc-kill-region calc-yank))))
(with-current-buffer calc-main-buffer
calc-hyperbolic-flag)
calc-hyperbolic-flag))
- (msg (if hyp-flag
- "Inverse Hyperbolic..."
- "Inverse...")))
+ (opt-flag (if (or
+ (eq major-mode 'calc-keypad-mode)
+ (eq major-mode 'calc-trail-mode))
+ (with-current-buffer calc-main-buffer
+ calc-option-flag)
+ calc-option-flag))
+ (msg
+ (cond
+ ((and opt-flag hyp-flag) "Option Inverse Hyperbolic...")
+ (hyp-flag "Inverse Hyperbolic...")
+ (opt-flag "Option Inverse...")
+ (t "Inverse..."))))
(calc-fancy-prefix 'calc-inverse-flag msg n)))
(defconst calc-fancy-prefix-map
@@ -1489,9 +1499,18 @@ calc-kill calc-kill-region calc-yank))))
(with-current-buffer calc-main-buffer
calc-inverse-flag)
calc-inverse-flag))
- (msg (if inv-flag
- "Inverse Hyperbolic..."
- "Hyperbolic...")))
+ (opt-flag (if (or
+ (eq major-mode 'calc-keypad-mode)
+ (eq major-mode 'calc-trail-mode))
+ (with-current-buffer calc-main-buffer
+ calc-option-flag)
+ calc-option-flag))
+ (msg
+ (cond
+ ((and opt-flag inv-flag) "Option Inverse Hyperbolic...")
+ (opt-flag "Option Hyperbolic...")
+ (inv-flag "Inverse Hyperbolic...")
+ (t "Hyperbolic..."))))
(calc-fancy-prefix 'calc-hyperbolic-flag msg n)))
(defun calc-hyperbolic-func ()
@@ -1504,6 +1523,31 @@ calc-kill calc-kill-region calc-yank))))
(defun calc-is-hyperbolic ()
calc-hyperbolic-flag)
+(defun calc-option (&optional n)
+ (interactive "P")
+ (let* ((inv-flag (if (or
+ (eq major-mode 'calc-keypad-mode)
+ (eq major-mode 'calc-trail-mode))
+ (with-current-buffer calc-main-buffer
+ calc-inverse-flag)
+ calc-inverse-flag))
+ (hyp-flag (if (or
+ (eq major-mode 'calc-keypad-mode)
+ (eq major-mode 'calc-trail-mode))
+ (with-current-buffer calc-main-buffer
+ calc-hyperbolic-flag)
+ calc-hyperbolic-flag))
+ (msg
+ (cond
+ ((and hyp-flag inv-flag) "Option Inverse Hyperbolic...")
+ (hyp-flag "Option Hyperbolic...")
+ (inv-flag "Option Inverse...")
+ (t "Option..."))))
+ (calc-fancy-prefix 'calc-option-flag msg n)))
+
+(defun calc-is-option ()
+ calc-option-flag)
+
(defun calc-keep-args (&optional n)
(interactive "P")
(calc-fancy-prefix 'calc-keep-args-flag "Keep args..." n))
@@ -1658,8 +1702,8 @@ calc-kill calc-kill-region calc-yank))))
(defun calc-execute-extended-command (n)
(interactive "P")
(let* ((prompt (concat (calc-num-prefix-name n) "M-x "))
- (cmd (intern
- (completing-read prompt obarray 'commandp t "calc-"
+ (cmd (intern
+ (completing-read prompt obarray 'commandp t "calc-"
'calc-extended-command-history))))
(setq prefix-arg n)
(command-execute cmd)))
@@ -3239,7 +3283,7 @@ If X is not an error form, return 1."
(concat "-" (math-format-flat-expr (nth 1 a) 1000)))
(t
(concat (math-remove-dashes
- (if (string-match "\\`calcFunc-\\([a-zA-Z0-9']+\\)\\'"
+ (if (string-match "\\`calcFunc-\\([a-zA-Zα-ωΑ-Ω0-9']+\\)\\'"
(symbol-name (car a)))
(math-match-substring (symbol-name (car a)) 1)
(symbol-name (car a))))
@@ -3425,7 +3469,8 @@ If X is not an error form, return 1."
(defun math-group-float (str) ; [X X]
(let* ((pt (or (string-match "[^0-9a-zA-Z]" str) (length str)))
- (g (if (integerp calc-group-digits) (math-abs calc-group-digits) 3))
+ (g (if (integerp calc-group-digits) (math-abs calc-group-digits)
+ (if (memq calc-number-radix '(2 16)) 4 3)))
(i pt))
(if (and (integerp calc-group-digits) (< calc-group-digits 0))
(while (< (setq i (+ (1+ i) g)) (length str))
@@ -3455,5 +3500,9 @@ A key may contain additional specs for Inverse, Hyperbolic, and Inv+Hyp.")
(provide 'calc-ext)
+;; Local variables:
+;; coding: utf-8
+;; End:
+
;; arch-tag: 1814ba7f-a390-49dc-9e25-a5adc205e97e
;;; calc-ext.el ends here
diff --git a/lisp/calc/calc-frac.el b/lisp/calc/calc-frac.el
index a01f5b8b9fa..265f0b325b9 100644
--- a/lisp/calc/calc-frac.el
+++ b/lisp/calc/calc-frac.el
@@ -205,16 +205,32 @@
n temp))
(math-div n d)))
-
-
(defun calcFunc-fdiv (a b) ; [R I I] [Public]
- (if (Math-num-integerp a)
- (if (Math-num-integerp b)
- (if (Math-zerop b)
- (math-reject-arg a "*Division by zero")
- (math-make-frac (math-trunc a) (math-trunc b)))
- (math-reject-arg b 'integerp))
- (math-reject-arg a 'integerp)))
+ (cond
+ ((Math-num-integerp a)
+ (cond
+ ((Math-num-integerp b)
+ (if (Math-zerop b)
+ (math-reject-arg a "*Division by zero")
+ (math-make-frac (math-trunc a) (math-trunc b))))
+ ((eq (car-safe b) 'frac)
+ (if (Math-zerop (nth 1 b))
+ (math-reject-arg a "*Division by zero")
+ (math-make-frac (math-mul (math-trunc a) (nth 2 b)) (nth 1 b))))
+ (t (math-reject-arg b 'integerp))))
+ ((eq (car-safe a) 'frac)
+ (cond
+ ((Math-num-integerp b)
+ (if (Math-zerop b)
+ (math-reject-arg a "*Division by zero")
+ (math-make-frac (cadr a) (math-mul (nth 2 a) (math-trunc b)))))
+ ((eq (car-safe b) 'frac)
+ (if (Math-zerop (nth 1 b))
+ (math-reject-arg a "*Division by zero")
+ (math-make-frac (math-mul (nth 1 a) (nth 2 b)) (math-mul (nth 2 a) (nth 1 b)))))
+ (t (math-reject-arg b 'integerp))))
+ (t
+ (math-reject-arg a 'integerp))))
(provide 'calc-frac)
diff --git a/lisp/calc/calc-graph.el b/lisp/calc/calc-graph.el
index 9af89ab6c3a..9fefaa73d79 100644
--- a/lisp/calc/calc-graph.el
+++ b/lisp/calc/calc-graph.el
@@ -433,7 +433,7 @@
(while (memq (preceding-char) '(?\s ?\t))
(forward-char -1))
(if (eq (preceding-char) ?\,)
- (delete-backward-char 1))))
+ (delete-char -1))))
(with-current-buffer calcbuf
(setq cache-env (list calc-angle-mode
calc-complex-mode
diff --git a/lisp/calc/calc-help.el b/lisp/calc/calc-help.el
index 0b2240f78c4..47c95130641 100644
--- a/lisp/calc/calc-help.el
+++ b/lisp/calc/calc-help.el
@@ -128,7 +128,7 @@ C-w Describe how there is no warranty for Calc."
(dig2 (char-after (match-beginning 3))))
(delete-region (match-end 1) (match-end 0))
(goto-char (match-beginning 1))
- (delete-backward-char 1)
+ (delete-char -1)
(delete-char 5)
(insert (format "%c .. %c" (min dig1 dig2) (max dig1 dig2)))))
(goto-char (point-min)))))
@@ -446,6 +446,7 @@ C-w Describe how there is no warranty for Calc."
'(calc-inverse-prefix-help
calc-hyperbolic-prefix-help
calc-inv-hyp-prefix-help
+ calc-option-prefix-help
calc-a-prefix-help
calc-b-prefix-help
calc-c-prefix-help
@@ -512,6 +513,11 @@ C-w Describe how there is no warranty for Calc."
"I H + a S (general invert func); v h (rtail)")
"inverse-hyperbolic" nil))
+(defun calc-option-prefix-help ()
+ (interactive)
+ (calc-do-prefix-help
+ '("")
+ "option" nil))
(defun calc-f-prefix-help ()
(interactive)
diff --git a/lisp/calc/calc-incom.el b/lisp/calc/calc-incom.el
index 6244c0d97e1..43811721146 100644
--- a/lisp/calc/calc-incom.el
+++ b/lisp/calc/calc-incom.el
@@ -176,9 +176,9 @@
(defun calc-digit-dots ()
(if (eq calc-prev-char ?.)
(progn
- (delete-backward-char 1)
+ (delete-char -1)
(if (calc-minibuffer-contains ".*\\.\\'")
- (delete-backward-char 1))
+ (delete-char -1))
(setq calc-prev-char 'dots
last-command-event 32)
(if calc-prev-prev-char
@@ -188,7 +188,7 @@
(erase-buffer))
(exit-minibuffer)))
;; just ignore extra decimal point, anticipating ".."
- (delete-backward-char 1)))
+ (delete-char -1)))
(defun calc-dots ()
(interactive)
diff --git a/lisp/calc/calc-keypd.el b/lisp/calc/calc-keypd.el
index e4dc5f5a88b..f0a37ad3b74 100644
--- a/lisp/calc/calc-keypd.el
+++ b/lisp/calc/calc-keypd.el
@@ -1,7 +1,7 @@
;;; calc-keypd.el --- mouse-capable keypad input for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004, 2005,
+;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -390,9 +390,7 @@
(interactive)
(unless (eq major-mode 'calc-keypad-mode)
(error "Must be in *Calc Keypad* buffer for this command"))
- (let* ((row (save-excursion
- (beginning-of-line)
- (count-lines (point-min) (point))))
+ (let* ((row (count-lines (point-min) (point-at-bol)))
(y (/ row 2))
(x (/ (current-column) (if (>= y 4) 6 5)))
radix frac inv
@@ -619,5 +617,4 @@
(provide 'calc-keypd)
-;; arch-tag: 4ba0d360-2bb6-40b8-adfa-eb373765b3f9
;;; calc-keypd.el ends here
diff --git a/lisp/calc/calc-lang.el b/lisp/calc/calc-lang.el
index cd30232feee..6c0a65f5567 100644
--- a/lisp/calc/calc-lang.el
+++ b/lisp/calc/calc-lang.el
@@ -1,7 +1,7 @@
;;; calc-lang.el --- calc language functions
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004, 2005,
+;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -214,7 +214,7 @@
(put 'pascal 'math-lang-read-symbol
'((?\$
(eq (string-match
- "\\(\\$[0-9a-fA-F]+\\)\\($\\|[^0-9a-zA-Z]\\)"
+ "\\(\\$[0-9a-fA-F]+\\)\\($\\|[^0-9a-zA-Zα-ωΑ-Ω]\\)"
math-exp-str math-exp-pos)
math-exp-pos)
(setq math-exp-token 'number
@@ -312,7 +312,7 @@
(put 'fortran 'math-lang-read-symbol
'((?\.
- (eq (string-match "\\.[a-zA-Z][a-zA-Z][a-zA-Z]?\\."
+ (eq (string-match "\\.[a-zA-Zα-ωΑ-Ω][a-zA-Zα-ωΑ-Ω][a-zA-Zα-ωΑ-Ω]?\\."
math-exp-str math-exp-pos) math-exp-pos)
(setq math-exp-token 'punc
math-expr-data (upcase (math-match-substring math-exp-str 0))
@@ -335,7 +335,7 @@
(add-to-list 'calc-lang-allow-underscores 'fortran)
(add-to-list 'calc-lang-parens-are-subscripts 'fortran)
-;; The next few variables are local to math-read-exprs in calc-aent.el
+;; The next few variables are local to math-read-exprs in calc-aent.el
;; and math-read-expr in calc-ext.el, but are set in functions they call.
(defvar math-exp-token)
@@ -379,12 +379,12 @@
((= n 1)
(message "TeX language mode with \\hbox{func}(\\hbox{var})"))
((> n 1)
- (message
+ (message
"TeX language mode with \\hbox{func}(\\hbox{var}) and multiline matrices"))
((= n -1)
(message "TeX language mode with \\func(\\hbox{var})"))
((< n -1)
- (message
+ (message
"TeX language mode with \\func(\\hbox{var}) and multiline matrices")))))
(defun calc-latex-language (n)
@@ -399,12 +399,12 @@
((= n 1)
(message "LaTeX language mode with \\text{func}(\\text{var})"))
((> n 1)
- (message
+ (message
"LaTeX language mode with \\text{func}(\\text{var}) and multiline matrices"))
((= n -1)
(message "LaTeX language mode with \\func(\\text{var})"))
((< n -1)
- (message
+ (message
"LaTeX language mode with \\func(\\text{var}) and multiline matrices")))))
(put 'tex 'math-lang-name "TeX")
@@ -498,7 +498,7 @@
(intv . math-compose-tex-intv)))
(put 'tex 'math-variable-table
- '(
+ '(
;; The Greek letters
( \\alpha . var-alpha )
( \\beta . var-beta )
@@ -540,6 +540,16 @@
( \\Psi . var-Psi )
( \\omega . var-omega )
( \\Omega . var-Omega )
+ ;; Units
+ ( pt . var-texpt )
+ ( pc . var-texpc )
+ ( bp . var-texbp )
+ ( dd . var-texdd )
+ ( cc . var-texcc )
+ ( sp . var-texsp )
+ ( pint . var-pt )
+ ( parsec . var-pc)
+
;; Others
( \\ell . var-ell )
( \\infty . var-inf )
@@ -603,9 +613,9 @@
'((?\\
(< math-exp-pos (1- (length math-exp-str)))
(progn
- (or (string-match "\\\\hbox *{\\([a-zA-Z0-9]+\\)}"
+ (or (string-match "\\\\hbox *{\\([a-zA-Zα-ωΑ-Ω0-9]+\\)}"
math-exp-str math-exp-pos)
- (string-match "\\(\\\\\\([a-zA-Z]+\\|[^a-zA-Z]\\)\\)"
+ (string-match "\\(\\\\\\([a-zA-Zα-ωΑ-Ω]+\\|[^a-zA-Zα-ωΑ-Ω]\\)\\)"
math-exp-str math-exp-pos))
(setq math-exp-token 'symbol
math-exp-pos (match-end 0)
@@ -630,7 +640,7 @@
(defun math-compose-tex-matrix (a &optional ltx)
(if (cdr a)
- (cons (append (math-compose-vector (cdr (car a)) " & " 0)
+ (cons (append (math-compose-vector (cdr (car a)) " & " 0)
(if ltx '(" \\\\ ") '(" \\cr ")))
(math-compose-tex-matrix (cdr a) ltx))
(list (math-compose-vector (cdr (car a)) " & " 0))))
@@ -691,7 +701,7 @@
(defun math-compose-tex-var (a prec)
(if (and calc-language-option
(not (= calc-language-option 0))
- (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'"
+ (string-match "\\`[a-zA-Zα-ωΑ-Ω][a-zA-Zα-ωΑ-Ω0-9]+\\'"
(symbol-name (nth 1 a))))
(if (eq calc-language 'latex)
(format "\\text{%s}" (symbol-name (nth 1 a)))
@@ -702,7 +712,7 @@
(let (left right)
(if (and calc-language-option
(not (= calc-language-option 0))
- (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'" func))
+ (string-match "\\`[a-zA-Zα-ωΑ-Ω][a-zA-Zα-ωΑ-Ω0-9]+\\'" func))
(if (< (prefix-numeric-value calc-language-option) 0)
(setq func (format "\\%s" func))
(setq func (if (eq calc-language 'latex)
@@ -722,7 +732,7 @@
(setq left "{" right "}"))
(t (setq left calc-function-open
right calc-function-close)))
- (list 'horiz func
+ (list 'horiz func
left
(math-compose-vector (cdr a) ", " 0)
right)))
@@ -824,11 +834,11 @@
'((?\\
(< math-exp-pos (1- (length math-exp-str)))
(progn
- (or (string-match "\\\\hbox *{\\([a-zA-Z0-9]+\\)}"
+ (or (string-match "\\\\hbox *{\\([a-zA-Zα-ωΑ-Ω0-9]+\\)}"
math-exp-str math-exp-pos)
- (string-match "\\\\text *{\\([a-zA-Z0-9]+\\)}"
+ (string-match "\\\\text *{\\([a-zA-Zα-ωΑ-Ω0-9]+\\)}"
math-exp-str math-exp-pos)
- (string-match "\\(\\\\\\([a-zA-Z]+\\|[^a-zA-Z]\\)\\)"
+ (string-match "\\(\\\\\\([a-zA-Zα-ωΑ-Ω]+\\|[^a-zA-Zα-ωΑ-Ω]\\)\\)"
math-exp-str math-exp-pos))
(setq math-exp-token 'symbol
math-exp-pos (match-end 0)
@@ -866,7 +876,7 @@
(and right
(setq math-exp-str (copy-sequence math-exp-str))
(aset math-exp-str right ?\]))))))))))
-
+
(defun math-latex-parse-frac (f val)
(let (numer denom)
(setq numer (car (math-read-expr-list)))
@@ -988,7 +998,7 @@
(cdr (math-transpose a)))
'("}")))))
-(put 'eqn 'math-var-formatter
+(put 'eqn 'math-var-formatter
(function
(lambda (a prec)
(let (v)
@@ -1011,7 +1021,7 @@
(intern (substring (symbol-name (nth 2 a)) 0 -1))))
prec)
(symbol-name (nth 1 a))))))))
-
+
(defconst math-eqn-special-funcs
'( calcFunc-log
calcFunc-ln calcFunc-exp
@@ -1022,7 +1032,7 @@
calcFunc-arcsin calcFunc-arccos calcFunc-arctan
calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh))
-(put 'eqn 'math-func-formatter
+(put 'eqn 'math-func-formatter
(function
(lambda (func a)
(let (left right)
@@ -1035,8 +1045,8 @@
(not (math-tex-expr-is-flat (nth 1 a))))
(setq left "{left ( "
right " right )}"))
-
- ((and
+
+ ((and
(memq (car a) math-eqn-special-funcs)
(= (length a) 2)
(or (Math-realp (nth 1 a))
@@ -1069,7 +1079,7 @@
("above" punc ",")))
(put 'eqn 'math-lang-adjust-words
- (function
+ (function
(lambda ()
(let ((code (assoc math-expr-data math-eqn-ignore-words)))
(cond ((null code))
@@ -1189,21 +1199,21 @@
( Gamma . var-gamma)))
(put 'yacas 'math-parse-table
- '((("Deriv(" 0 ")" 0)
+ '((("Deriv(" 0 ")" 0)
calcFunc-deriv (var ArgB var-ArgB) (var ArgA var-ArgA))
- (("D(" 0 ")" 0)
+ (("D(" 0 ")" 0)
calcFunc-deriv (var ArgB var-ArgB) (var ArgA var-ArgA))
- (("Integrate(" 0 ")" 0)
+ (("Integrate(" 0 ")" 0)
calcFunc-integ (var ArgB var-ArgB)(var ArgA var-ArgA))
- (("Integrate(" 0 "," 0 "," 0 ")" 0)
- calcFunc-integ (var ArgD var-ArgD) (var ArgA var-ArgA)
+ (("Integrate(" 0 "," 0 "," 0 ")" 0)
+ calcFunc-integ (var ArgD var-ArgD) (var ArgA var-ArgA)
(var ArgB var-ArgB) (var ArgC var-ArgC))
- (("Subst(" 0 "," 0 ")" 0)
- calcFunc-subst (var ArgC var-ArgC) (var ArgA var-ArgA)
+ (("Subst(" 0 "," 0 ")" 0)
+ calcFunc-subst (var ArgC var-ArgC) (var ArgA var-ArgA)
(var ArgB var-ArgB))
- (("Taylor(" 0 "," 0 "," 0 ")" 0)
- calcFunc-taylor (var ArgD var-ArgD)
- (calcFunc-eq (var ArgA var-ArgA) (var ArgB var-ArgB))
+ (("Taylor(" 0 "," 0 "," 0 ")" 0)
+ calcFunc-taylor (var ArgD var-ArgD)
+ (calcFunc-eq (var ArgA var-ArgA) (var ArgB var-ArgB))
(var ArgC var-ArgC))))
(put 'yacas 'math-oper-table
@@ -1356,7 +1366,7 @@
(math-compose-expr (nth 2 a) -1)
(if (not (nth 3 a))
")"
- (concat
+ (concat
","
(math-compose-expr (nth 3 a) -1)
","
@@ -1393,7 +1403,7 @@
'(("+" + 100 100)
("-" - 100 134)
("*" * 120 120)
- ("." * 130 129)
+ ("." * 130 129)
("/" / 120 120)
("u-" neg -1 180)
("u+" ident -1 180)
@@ -1494,9 +1504,9 @@
(nth 3 args))))
(put 'maxima 'math-parse-table
- '((("if" 0 "then" 0 "else" 0)
- calcFunc-if
- (var ArgA var-ArgA)
+ '((("if" 0 "then" 0 "else" 0)
+ calcFunc-if
+ (var ArgA var-ArgA)
(var ArgB var-ArgB)
(var ArgC var-ArgC))))
@@ -1572,7 +1582,7 @@
(lambda (a)
(list 'horiz
"matrix("
- (math-compose-vector (cdr a)
+ (math-compose-vector (cdr a)
(concat math-comp-comma " ")
math-comp-vector-prec)
")"))))
@@ -1734,7 +1744,7 @@ order to Calc's."
(nth 0 args))))
(put 'giac 'math-parse-table
- '((("set" 0)
+ '((("set" 0)
calcFunc-rdup
(var ArgA var-ArgA))))
@@ -1748,7 +1758,7 @@ order to Calc's."
"Compose the arguments to a Calc function in reverse order.
This is used for various language modes which have functions in reverse
order to Calc's."
- (list 'horiz (nth 1 fn)
+ (list 'horiz (nth 1 fn)
"("
(math-compose-expr (nth 2 a) 0)
","
@@ -1770,7 +1780,7 @@ order to Calc's."
(list 'horiz
(math-compose-expr (nth 1 a) 1000)
"["
- (math-compose-expr
+ (math-compose-expr
(calc-normalize (list '- (nth 2 a) 1)) 0)
"]")))))
@@ -2001,7 +2011,7 @@ order to Calc's."
(list 'horiz
"matrix("
math-comp-left-bracket
- (math-compose-vector (cdr a)
+ (math-compose-vector (cdr a)
(concat math-comp-comma " ")
math-comp-vector-prec)
math-comp-right-bracket
@@ -2044,9 +2054,9 @@ order to Calc's."
(defvar math-read-big-baseline)
(defvar math-read-big-h2)
-;; The variables math-rb-h1, math-rb-h2, math-rb-v1 and math-rb-v2
-;; are local to math-read-big-rec, but are used by math-read-big-char,
-;; math-read-big-emptyp and math-read-big-balance which are called by
+;; The variables math-rb-h1, math-rb-h2, math-rb-v1 and math-rb-v2
+;; are local to math-read-big-rec, but are used by math-read-big-char,
+;; math-read-big-emptyp and math-read-big-balance which are called by
;; math-read-big-rec.
;; math-rb-h2 is also local to math-read-big-bigp in calc-ext.el,
;; which calls math-read-big-balance.
@@ -2055,40 +2065,40 @@ order to Calc's."
(defvar math-rb-v1)
(defvar math-rb-v2)
-(defun math-read-big-rec (math-rb-h1 math-rb-v1 math-rb-h2 math-rb-v2
+(defun math-read-big-rec (math-rb-h1 math-rb-v1 math-rb-h2 math-rb-v2
&optional baseline prec short)
(or prec (setq prec 0))
;; Clip whitespace above or below.
- (while (and (< math-rb-v1 math-rb-v2)
+ (while (and (< math-rb-v1 math-rb-v2)
(math-read-big-emptyp math-rb-h1 math-rb-v1 math-rb-h2 (1+ math-rb-v1)))
(setq math-rb-v1 (1+ math-rb-v1)))
- (while (and (< math-rb-v1 math-rb-v2)
+ (while (and (< math-rb-v1 math-rb-v2)
(math-read-big-emptyp math-rb-h1 (1- math-rb-v2) math-rb-h2 math-rb-v2))
(setq math-rb-v2 (1- math-rb-v2)))
;; If formula is a single line high, normal parser can handle it.
(if (<= math-rb-v2 (1+ math-rb-v1))
(if (or (<= math-rb-v2 math-rb-v1)
- (> math-rb-h1 (length (setq math-rb-v2
+ (> math-rb-h1 (length (setq math-rb-v2
(nth math-rb-v1 math-read-big-lines)))))
(math-read-big-error math-rb-h1 math-rb-v1)
(setq math-read-big-baseline math-rb-v1
math-read-big-h2 math-rb-h2
math-rb-v2 (nth math-rb-v1 math-read-big-lines)
- math-rb-h2 (math-read-expr
- (substring math-rb-v2 math-rb-h1
+ math-rb-h2 (math-read-expr
+ (substring math-rb-v2 math-rb-h1
(min math-rb-h2 (length math-rb-v2)))))
(if (eq (car-safe math-rb-h2) 'error)
- (math-read-big-error (+ math-rb-h1 (nth 1 math-rb-h2))
+ (math-read-big-error (+ math-rb-h1 (nth 1 math-rb-h2))
math-rb-v1 (nth 2 math-rb-h2))
math-rb-h2))
;; Clip whitespace at left or right.
- (while (and (< math-rb-h1 math-rb-h2)
+ (while (and (< math-rb-h1 math-rb-h2)
(math-read-big-emptyp math-rb-h1 math-rb-v1 (1+ math-rb-h1) math-rb-v2))
(setq math-rb-h1 (1+ math-rb-h1)))
- (while (and (< math-rb-h1 math-rb-h2)
+ (while (and (< math-rb-h1 math-rb-h2)
(math-read-big-emptyp (1- math-rb-h2) math-rb-v1 math-rb-h2 math-rb-v2))
(setq math-rb-h2 (1- math-rb-h2)))
@@ -2107,7 +2117,7 @@ order to Calc's."
(/= (aref line math-rb-h1) ?\ )
(if (and (= (aref line math-rb-h1) ?\-)
;; Make sure it's not a minus sign.
- (or (and (< (1+ math-rb-h1) len)
+ (or (and (< (1+ math-rb-h1) len)
(= (aref line (1+ math-rb-h1)) ?\-))
(/= (math-read-big-char math-rb-h1 (1- v)) ?\ )
(/= (math-read-big-char math-rb-h1 (1+ v)) ?\ )))
@@ -2166,7 +2176,7 @@ order to Calc's."
;; Binomial coefficient.
((and (= other-char ?\()
(= (math-read-big-char (1+ math-rb-h1) v) ?\ )
- (= (string-match "( *)" (nth v math-read-big-lines)
+ (= (string-match "( *)" (nth v math-read-big-lines)
math-rb-h1) math-rb-h1))
(setq h (match-end 0))
(math-read-big-emptyp math-rb-h1 math-rb-v1 (1+ math-rb-h1) v nil t)
@@ -2180,7 +2190,7 @@ order to Calc's."
;; Minus sign.
((= other-char ?\-)
- (setq p (list 'neg (math-read-big-rec (1+ math-rb-h1) math-rb-v1
+ (setq p (list 'neg (math-read-big-rec (1+ math-rb-h1) math-rb-v1
math-rb-h2 math-rb-v2 v 250 t))
v math-read-big-baseline
h math-read-big-h2))
@@ -2199,10 +2209,10 @@ order to Calc's."
(if (= sep ?\])
(math-read-big-error (1- h) v "Expected `)'"))
(if (= sep ?\))
- (setq p (math-read-big-rec
+ (setq p (math-read-big-rec
(1+ math-rb-h1) math-rb-v1 (1- h) math-rb-v2 v))
(setq hmid (math-read-big-balance h v "(")
- p (list p
+ p (list p
(math-read-big-rec h math-rb-v1 (1- hmid) math-rb-v2 v))
h hmid)
(cond ((= sep ?\.)
@@ -2301,9 +2311,11 @@ order to Calc's."
;; Variable name or function call.
((or (and (>= other-char ?a) (<= other-char ?z))
- (and (>= other-char ?A) (<= other-char ?Z)))
+ (and (>= other-char ?A) (<= other-char ?Z))
+ (and (>= other-char ?α) (<= other-char ?ω))
+ (and (>= other-char ?Α) (<= other-char ?Ω)))
(setq line (nth v math-read-big-lines))
- (string-match "\\([a-zA-Z'_]+\\) *" line math-rb-h1)
+ (string-match "\\([a-zA-Zα-ωΑ-Ω'_]+\\) *" line math-rb-h1)
(setq h (match-end 1)
widest (match-end 0)
p (math-match-substring line 1))
@@ -2345,7 +2357,7 @@ order to Calc's."
(math-read-big-emptyp math-rb-h1 math-rb-v1 h v nil t)
(math-read-big-emptyp math-rb-h1 (1+ v) h math-rb-v2 nil t)))
- ;; Now left term is bounded by math-rb-h1, math-rb-v1, h, math-rb-v2;
+ ;; Now left term is bounded by math-rb-h1, math-rb-v1, h, math-rb-v2;
;; baseline = v.
(if baseline
(or (= v baseline)
@@ -2387,12 +2399,12 @@ order to Calc's."
(cond ((eq (nth 3 widest) -1)
(setq p (list (nth 1 widest) p)))
((equal (car widest) "?")
- (let ((y (math-read-big-rec h math-rb-v1 math-rb-h2
+ (let ((y (math-read-big-rec h math-rb-v1 math-rb-h2
math-rb-v2 baseline nil t)))
(or (= (math-read-big-char math-read-big-h2 baseline) ?\:)
(math-read-big-error math-read-big-h2 baseline "Expected `:'"))
(setq p (list (nth 1 widest) p y
- (math-read-big-rec
+ (math-read-big-rec
(1+ math-read-big-h2) math-rb-v1 math-rb-h2 math-rb-v2
baseline (nth 3 widest) t))
h math-read-big-h2)))
@@ -2481,5 +2493,9 @@ order to Calc's."
(provide 'calc-lang)
+;; Local variables:
+;; coding: utf-8
+;; End:
+
;; arch-tag: 483bfe15-f290-4fef-bb7d-ce65be687f2e
;;; calc-lang.el ends here
diff --git a/lisp/calc/calc-misc.el b/lisp/calc/calc-misc.el
index b6b2917f0fe..890e624ecb4 100644
--- a/lisp/calc/calc-misc.el
+++ b/lisp/calc/calc-misc.el
@@ -35,6 +35,7 @@
(declare-function calc-inv-hyp-prefix-help "calc-help" ())
(declare-function calc-inverse-prefix-help "calc-help" ())
(declare-function calc-hyperbolic-prefix-help "calc-help" ())
+(declare-function calc-option-prefix-help "calc-help" ())
(declare-function calc-explain-why "calc-stuff" (why &optional more))
(declare-function calc-clear-command-flag "calc-ext" (f))
(declare-function calc-roll-down-with-selections "calc-sel" (n m))
@@ -219,7 +220,7 @@ Calc user interface as before (either C-x * C or C-x * K; initially C-x * C).
(let ((msgs
'("Press `h' for complete help; press `?' repeatedly for a summary"
"Letter keys: Negate; Precision; Yank; Why; Xtended cmd; Quit"
- "Letter keys: SHIFT + Undo, reDo; Keep-args; Inverse, Hyperbolic"
+ "Letter keys: SHIFT + Undo, reDo; Keep-args; Inverse, Hyperbolic, Option"
"Letter keys: SHIFT + sQrt; Sin, Cos, Tan; Exp, Ln, logB"
"Letter keys: SHIFT + Floor, Round; Abs, conJ, arG; Pi"
"Letter keys: SHIFT + Num-eval; More-recn; eXec-kbd-macro"
@@ -245,20 +246,22 @@ Calc user interface as before (either C-x * C or C-x * K; initially C-x * C).
(calc-inv-hyp-prefix-help)
(calc-inverse-prefix-help))
(calc-hyperbolic-prefix-help))
- (setq calc-help-phase
- (if (eq this-command last-command)
- (% (1+ calc-help-phase) (1+ (length msgs)))
- 0))
- (let ((msg (nth calc-help-phase msgs)))
- (message "%s" (if msg
- (concat msg ":"
- (make-string (- (apply 'max
- (mapcar 'length
- msgs))
- (length msg)) 32)
- " [?=MORE]")
- "")))))))
-
+ (if calc-option-flag
+ (calc-option-prefix-help)
+ (setq calc-help-phase
+ (if (eq this-command last-command)
+ (% (1+ calc-help-phase) (1+ (length msgs)))
+ 0))
+ (let ((msg (nth calc-help-phase msgs)))
+ (message "%s" (if msg
+ (concat msg ":"
+ (make-string (- (apply 'max
+ (mapcar 'length
+ msgs))
+ (length msg)) 32)
+ " [?=MORE]")
+ ""))))))))
+
diff --git a/lisp/calc/calc-poly.el b/lisp/calc/calc-poly.el
index a994ace6fb6..f268a032d14 100644
--- a/lisp/calc/calc-poly.el
+++ b/lisp/calc/calc-poly.el
@@ -663,7 +663,7 @@
(cons 'vec (cons (nth 1 facs) (cons (list 'vec fac pow)
(cdr (cdr facs)))))
(cons 'vec (cons (list 'vec fac pow) (cdr facs))))))))
- (math-mul (math-pow fac pow) facs)))
+ (math-mul (math-pow fac pow) (math-factor-protect facs))))
(defun math-factor-poly-coefs (p &optional square-free) ; uses "x"
(let (t1 t2 temp)
diff --git a/lisp/calc/calc-prog.el b/lisp/calc/calc-prog.el
index 5e4adace91e..91017627699 100644
--- a/lisp/calc/calc-prog.el
+++ b/lisp/calc/calc-prog.el
@@ -627,7 +627,8 @@
(error "Separator not allowed with { ... }?"))
(if (string-match "\\`\"" sep)
(setq sep (read-from-string sep)))
- (setq sep (calc-fix-token-name sep))
+ (if (> (length sep) 0)
+ (setq sep (calc-fix-token-name sep)))
(setq part (nconc part
(list (list sym p
(and (> (length sep) 0)
diff --git a/lisp/calc/calc-sel.el b/lisp/calc/calc-sel.el
index 084b9ea2b6a..c485fdd168a 100644
--- a/lisp/calc/calc-sel.el
+++ b/lisp/calc/calc-sel.el
@@ -309,6 +309,8 @@
(setq n (1+ n))))
(calc-clear-command-flag 'position-point)))
+(defvar calc-highlight-selections-with-faces)
+
(defun calc-show-selections (arg)
(interactive "P")
(calc-wrapper
@@ -330,8 +332,12 @@
(setcar (nthcdr 2 calc-selection-cache-entry) nil)
(calc-change-current-selection sel)))))
(message (if calc-show-selections
- "Displaying only selected part of formulas"
- "Displaying all but selected part of formulas"))))
+ (if calc-highlight-selections-with-faces
+ "De-emphasizing all but selected part of formulas"
+ "Displaying only selected part of formulas")
+ (if calc-highlight-selections-with-faces
+ "Emphasizing selected part of formulas"
+ "Displaying all but selected part of formulas")))))
;; The variables calc-final-point-line and calc-final-point-column
;; are declared in calc.el, and are used throughout.
diff --git a/lisp/calc/calc-store.el b/lisp/calc/calc-store.el
index 5ec21eee887..b82ed08c557 100644
--- a/lisp/calc/calc-store.el
+++ b/lisp/calc/calc-store.el
@@ -1,7 +1,7 @@
;;; calc-store.el --- value storage functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004, 2005,
+;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -197,12 +197,12 @@
(minibuffer-completion-predicate
(lambda (x) (boundp (intern (concat "var-" x)))))
(minibuffer-completion-confirm t))
- (read-from-minibuffer
- prompt nil calc-var-name-map nil
+ (read-from-minibuffer
+ prompt nil calc-var-name-map nil
'calc-read-var-name-history)))))
(setq calc-aborted-prefix "")
(and (not (equal var "var-"))
- (if (string-match "\\`\\([-a-zA-Z0-9]+\\) *:?=" var)
+ (if (string-match "\\`\\([-a-zA-Zα-ωΑ-Ω0-9]+\\) *:?=" var)
(if (null calc-given-value-flag)
(error "Assignment is not allowed in this command")
(let ((svar (intern (substring var 0 (match-end 1)))))
@@ -677,5 +677,9 @@
(provide 'calc-store)
+;; Local variables:
+;; coding: utf-8
+;; End:
+
;; arch-tag: 2fbfec82-a521-42ca-bcd8-4f254ae6313e
;;; calc-store.el ends here
diff --git a/lisp/calc/calc-trail.el b/lisp/calc/calc-trail.el
index 9bbb4178fd3..20dc1d1b99e 100644
--- a/lisp/calc/calc-trail.el
+++ b/lisp/calc/calc-trail.el
@@ -108,20 +108,28 @@
(defun calc-trail-isearch-forward ()
(interactive)
(calc-with-trail-buffer
- (save-window-excursion
- (select-window (get-buffer-window (current-buffer)))
- (let ((search-exit-char ?\r))
- (isearch-forward)))
- (calc-trail-here)))
+ (let ((win (get-buffer-window (current-buffer)))
+ pos)
+ (save-window-excursion
+ (select-window win)
+ (isearch-forward)
+ (setq pos (point)))
+ (goto-char pos)
+ (set-window-point win pos)
+ (calc-trail-here))))
(defun calc-trail-isearch-backward ()
(interactive)
(calc-with-trail-buffer
- (save-window-excursion
- (select-window (get-buffer-window (current-buffer)))
- (let ((search-exit-char ?\r))
- (isearch-backward)))
- (calc-trail-here)))
+ (let ((win (get-buffer-window (current-buffer)))
+ pos)
+ (save-window-excursion
+ (select-window win)
+ (isearch-backward)
+ (setq pos (point)))
+ (goto-char pos)
+ (set-window-point win pos)
+ (calc-trail-here))))
(defun calc-trail-yank (arg)
(interactive "P")
diff --git a/lisp/calc/calc-units.el b/lisp/calc/calc-units.el
index 6dd3e4911b7..8fd1983ac6d 100644
--- a/lisp/calc/calc-units.el
+++ b/lisp/calc/calc-units.el
@@ -1,7 +1,7 @@
;;; calc-units.el --- unit conversion functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004, 2005,
+;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -36,13 +36,13 @@
;;; Units table last updated 9-Jan-91 by Ulrich Mueller (ulm@vsnhd1.cern.ch)
;;; with some additions by Przemek Klosowski (przemek@rrdstrad.nist.gov)
-;;; Updated April 2002 by Jochen Kpper
+;;; Updated April 2002 by Jochen Küpper
;;; Updated August 2007, using
;;; CODATA (http://physics.nist.gov/cuu/Constants/index.html)
;;; NIST (http://physics.nist.gov/Pubs/SP811/appenB9.html)
;;; ESUWM (Encyclopaedia of Scientific Units, Weights and
-;;; Measures, by Franois Cardarelli)
+;;; Measures, by François Cardarelli)
;;; All conversions are exact unless otherwise noted.
(defvar math-standard-units
@@ -57,23 +57,23 @@
"149597870691 m (*)")
;; (approx) NASA JPL (http://neo.jpl.nasa.gov/glossary/au.html)
( lyr "c yr" "Light Year" )
- ( pc "3.0856775854*10^16 m" "Parsec" nil
+ ( pc "3.0856775854*10^16 m" "Parsec (**)" nil
"3.0856775854 10^16 m (*)") ;; (approx) ESUWM
( nmi "1852 m" "Nautical Mile" )
( fath "6 ft" "Fathom" )
( fur "660 ft" "Furlong")
( mu "1 um" "Micron" )
( mil "(1/1000) in" "Mil" )
- ( point "(1/72) in" "Point (1/72 inch)" )
+ ( point "(1/72) in" "Point (PostScript convention)" )
( Ang "10^(-10) m" "Angstrom" )
( mfi "mi+ft+in" "Miles + feet + inches" )
;; TeX lengths
- ( texpt "(100/7227) in" "Point (TeX conventions)" )
- ( texpc "12 texpt" "Pica" )
- ( texbp "point" "Big point (TeX conventions)" )
- ( texdd "(1238/1157) texpt" "Didot point" )
- ( texcc "12 texdd" "Cicero" )
- ( texsp "(1/65536) texpt" "Scaled TeX point" )
+ ( texpt "(100/7227) in" "Point (TeX convention) (**)" )
+ ( texpc "12 texpt" "Pica (TeX convention) (**)" )
+ ( texbp "point" "Big point (TeX convention) (**)" )
+ ( texdd "(1238/1157) texpt" "Didot point (TeX convention) (**)" )
+ ( texcc "12 texdd" "Cicero (TeX convention) (**)" )
+ ( texsp "(1/65536) texpt" "Scaled TeX point (TeX convention) (**)" )
;; Area
( hect "10000 m^2" "*Hectare" )
@@ -86,7 +86,7 @@
( l "L" "Liter" )
( gal "4 qt" "US Gallon" )
( qt "2 pt" "Quart" )
- ( pt "2 cup" "Pint" )
+ ( pt "2 cup" "Pint (**)" )
( cup "8 ozfl" "Cup" )
( ozfl "2 tbsp" "Fluid Ounce" )
( floz "2 tbsp" "Fluid Ounce" )
@@ -210,6 +210,7 @@
"1.602176487 10^-19 C (*)") ;;(approx) CODATA
( V "W/A" "Volt" )
( ohm "V/A" "Ohm" )
+ ( Ω "ohm" "Ohm" )
( mho "A/V" "Mho" )
( S "A/V" "Siemens" )
( F "C/V" "Farad" )
@@ -259,7 +260,9 @@
"6.62606896 10^-34 J s (*)")
( hbar "h / (2 pi)" "Planck's constant" ) ;; Exact
( mu0 "4 pi 10^(-7) H/m" "Permeability of vacuum") ;; Exact
+ ( μ0 "mu0" "Permeability of vacuum") ;; Exact
( eps0 "1 / (mu0 c^2)" "Permittivity of vacuum" )
+ ( ε0 "eps0" "Permittivity of vacuum" )
( G "6.67428*10^(-11) m^3/(kg s^2)" "Gravitational constant" nil
"6.67428 10^-11 m^3/(kg s^2) (*)")
( Nav "6.02214179*10^(23) / mol" "Avogadro's constant" nil
@@ -272,12 +275,16 @@
"1.674927211 10^-27 kg (*)")
( mmu "1.88353130*10^(-28) kg" "Muon rest mass" nil
"1.88353130 10^-28 kg (*)")
+ ( mμ "mmu" "Muon rest mass" nil
+ "1.88353130 10^-28 kg (*)")
( Ryd "10973731.568527 /m" "Rydberg's constant" nil
"10973731.568527 /m (*)")
( k "1.3806504*10^(-23) J/K" "Boltzmann's constant" nil
"1.3806504 10^-23 J/K (*)")
( alpha "7.2973525376*10^(-3)" "Fine structure constant" nil
"7.2973525376 10^-3 (*)")
+ ( α "alpha" "Fine structure constant" nil
+ "7.2973525376 10^-3 (*)")
( muB "927.400915*10^(-26) J/T" "Bohr magneton" nil
"927.400915 10^-26 J/T (*)")
( muN "5.05078324*10^(-27) J/T" "Nuclear magneton" nil
@@ -316,6 +323,7 @@ that the combined units table will be rebuilt.")
( ?c (^ 10 -2) "Centi" )
( ?m (^ 10 -3) "Milli" )
( ?u (^ 10 -6) "Micro" )
+ ( ?μ (^ 10 -6) "Micro" )
( ?n (^ 10 -9) "Nano" )
( ?p (^ 10 -12) "Pico" )
( ?f (^ 10 -15) "Femto" )
@@ -581,8 +589,8 @@ If EXPR is nil, return nil."
(let ((name (or (nth 2 u) (symbol-name (car u)))))
(if (eq (aref name 0) ?\*)
(setq name (substring name 1)))
- (if (string-match "[^a-zA-Z0-9']" name)
- (if (string-match "^[a-zA-Z0-9' ()]*$" name)
+ (if (string-match "[^a-zA-Zα-ωΑ-Ω0-9']" name)
+ (if (string-match "^[a-zA-Zα-ωΑ-Ω0-9' ()]*$" name)
(while (setq pos (string-match "[ ()]" name))
(setq name (concat (substring name 0 pos)
(if (eq (aref name pos) 32) "-" "")
@@ -592,7 +600,7 @@ If EXPR is nil, return nil."
(setq name (concat (nth 2 (assq (aref (symbol-name
(nth 1 expr)) 0)
math-unit-prefixes))
- (if (and (string-match "[^a-zA-Z0-9']" name)
+ (if (and (string-match "[^a-zA-Zα-ωΑ-Ω0-9']" name)
(not (memq (car u) '(mHg gf))))
(concat "-" name)
(downcase name)))))
@@ -1523,7 +1531,12 @@ If EXPR is nil, return nil."
(indent-to 15)
(insert " " (nth 2 u) "\n")
(while (eq (car (car (setq uptr (cdr uptr)))) 0)))
- (insert "\n"))
+ (insert "\n\n")
+ (insert "(**) When in TeX or LaTeX display mode, the TeX specific unit\n"
+ "names will not use the `tex' prefix; the unit name for a\n"
+ "TeX point will be `pt' instead of `texpt', for example.\n"
+ "To avoid conflicts, the unit names for pint and parsec will\n"
+ "be `pint' and `parsec' instead of `pt' and `pc'."))
(view-mode)
(message "Formatting units table...done"))
(setq math-units-table-buffer-valid t)
@@ -1540,8 +1553,8 @@ If EXPR is nil, return nil."
(provide 'calc-units)
-;; Local Variables:
-;; coding: iso-latin-1
+;; Local variables:
+;; coding: utf-8
;; End:
;; arch-tag: e993314f-3adc-4191-be61-4ef8874881c4
diff --git a/lisp/calc/calc-vec.el b/lisp/calc/calc-vec.el
index c4de362ab36..5b807a55491 100644
--- a/lisp/calc/calc-vec.el
+++ b/lisp/calc/calc-vec.el
@@ -451,16 +451,18 @@
(calc-enter-result 1 "grad" (list 'calcFunc-grade (calc-top-n 1))))))
(defun calc-histogram (n)
- (interactive "NNumber of bins: ")
+ (interactive "P")
+ (unless (natnump n)
+ (setq n (math-read-expr (read-string "Centers of bins: "))))
(calc-slow-wrapper
(if calc-hyperbolic-flag
(calc-enter-result 2 "hist" (list 'calcFunc-histogram
(calc-top-n 2)
(calc-top-n 1)
- (prefix-numeric-value n)))
+ n))
(calc-enter-result 1 "hist" (list 'calcFunc-histogram
(calc-top-n 1)
- (prefix-numeric-value n))))))
+ n)))))
(defun calc-transpose (arg)
(interactive "P")
@@ -1135,22 +1137,53 @@
(if (Math-vectorp wts)
(or (= (length vec) (length wts))
(math-dimension-error)))
- (or (natnump n)
- (math-reject-arg n 'fixnatnump))
- (let ((res (make-vector n 0))
- (vp vec)
- (wvec (Math-vectorp wts))
- (wp wts)
- bin)
- (while (setq vp (cdr vp))
- (setq bin (car vp))
- (or (natnump bin)
- (setq bin (math-floor bin)))
- (and (natnump bin)
- (< bin n)
- (aset res bin (math-add (aref res bin)
- (if wvec (car (setq wp (cdr wp))) wts)))))
- (cons 'vec (append res nil))))
+ (cond ((natnump n)
+ (let ((res (make-vector n 0))
+ (vp vec)
+ (wvec (Math-vectorp wts))
+ (wp wts)
+ bin)
+ (while (setq vp (cdr vp))
+ (setq bin (car vp))
+ (or (natnump bin)
+ (setq bin (math-floor bin)))
+ (and (natnump bin)
+ (< bin n)
+ (aset res bin
+ (math-add (aref res bin)
+ (if wvec (car (setq wp (cdr wp))) wts)))))
+ (cons 'vec (append res nil))))
+ ((Math-vectorp n) ;; n is a vector of midpoints
+ (let* ((bds (math-vector-avg n))
+ (res (make-vector (1- (length n)) 0))
+ (vp (cdr vec))
+ (wvec (Math-vectorp wts))
+ (wp wts)
+ num)
+ (while vp
+ (setq num (car vp))
+ (let ((tbds (cdr bds))
+ (i 0))
+ (while (and tbds (Math-lessp (car tbds) num))
+ (setq i (1+ i))
+ (setq tbds (cdr tbds)))
+ (aset res i
+ (math-add (aref res i)
+ (if wvec (car (setq wp (cdr wp))) wts))))
+ (setq vp (cdr vp)))
+ (cons 'vec (append res nil))))
+ (t
+ (math-reject-arg n "*Expecting an integer or vector"))))
+
+;;; Replace a vector [a b c ...] with a vector of averages
+;;; [(a+b)/2 (b+c)/2 ...]
+(defun math-vector-avg (vec)
+ (let ((vp (sort (copy-sequence (cdr vec)) 'math-beforep))
+ (res nil))
+ (while (and vp (cdr vp))
+ (setq res (cons (math-div (math-add (car vp) (cadr vp)) 2) res)
+ vp (cdr vp)))
+ (cons 'vec (reverse res))))
;;; Set operations.
diff --git a/lisp/calc/calc-yank.el b/lisp/calc/calc-yank.el
index 63b3cb03322..0588f31de15 100644
--- a/lisp/calc/calc-yank.el
+++ b/lisp/calc/calc-yank.el
@@ -1,7 +1,7 @@
;;; calc-yank.el --- kill-ring functionality for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004, 2005,
+;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -282,11 +282,8 @@ With prefix arg, also delete the region."
(setq single t)
(setq arg (prefix-numeric-value arg))
(if (= arg 0)
- (save-excursion
- (beginning-of-line)
- (setq top (point))
- (end-of-line)
- (setq bot (point)))
+ (setq top (point-at-bol)
+ bot (point-at-eol))
(save-excursion
(setq top (point))
(forward-line arg)
@@ -713,5 +710,4 @@ To cancel the edit, simply kill the *Calc Edit* buffer."
;; generated-autoload-file: "calc-loaddefs.el"
;; End:
-;; arch-tag: ca61019e-caca-4daa-b32c-b6afe372d5b5
;;; calc-yank.el ends here
diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el
index 2a6ec97ef5c..e0560465a99 100644
--- a/lisp/calc/calc.el
+++ b/lisp/calc/calc.el
@@ -419,12 +419,33 @@ in normal mode."
:group 'calc
:type 'boolean)
-(defcustom calc-undo-length
+(defcustom calc-undo-length
100
"The number of undo steps that will be preserved when Calc is quit."
:group 'calc
:type 'integer)
+(defcustom calc-highlight-selections-with-faces
+ nil
+ "If non-nil, use a separate face to indicate selected sub-formulas.
+If `calc-show-selections' is non-nil, then selected sub-formulas are shown
+by displaying the rest of the formula in `calc-nonselected-face'.
+If `calc-show-selections' is nil, then selected sub-formulas are shown
+by displaying the sub-formula in `calc-selected-face'."
+ :group 'calc
+ :type 'boolean)
+
+(defface calc-nonselected-face
+ '((t :inherit shadow
+ :slant italic))
+ "Face used to show the non-selected portion of a formula."
+ :group 'calc)
+
+(defface calc-selected-face
+ '((t :weight bold))
+ "Face used to show the selected portion of a formula."
+ :group 'calc)
+
(defvar calc-bug-address "jay.p.belanger@gmail.com"
"Address of the maintainer of Calc, for use by `report-calc-bug'.")
@@ -797,6 +818,7 @@ Used by `calc-user-invocation'.")
calc-matrix-mode
calc-inverse-flag
calc-hyperbolic-flag
+ calc-option-flag
calc-keep-args-flag
calc-angle-mode
calc-number-radix
@@ -926,6 +948,8 @@ Used by `calc-user-invocation'.")
"If non-nil, next operation is Inverse.")
(defvar calc-hyperbolic-flag nil
"If non-nil, next operation is Hyperbolic.")
+(defvar calc-option-flag nil
+ "If non-nil, next operation has Optional behavior.")
(defvar calc-keep-args-flag nil
"If non-nil, next operation should not remove its arguments from stack.")
(defvar calc-function-open "("
@@ -996,9 +1020,12 @@ Used by `calc-user-invocation'.")
(defvar math-working-step-2 nil)
(defvar var-i '(special-const (math-imaginary 1)))
(defvar var-pi '(special-const (math-pi)))
+(defvar var-π '(special-const (math-pi)))
(defvar var-e '(special-const (math-e)))
(defvar var-phi '(special-const (math-phi)))
+(defvar var-φ '(special-const (math-phi)))
(defvar var-gamma '(special-const (math-gamma-const)))
+(defvar var-γ '(special-const (math-gamma-const)))
(defvar var-Modes '(special-const (math-get-modes-vec)))
(mapc (lambda (v) (or (boundp v) (set v nil)))
@@ -1038,7 +1065,7 @@ Used by `calc-user-invocation'.")
(mapc (lambda (x) (define-key map (char-to-string x) 'undefined))
"lOW")
(mapc (lambda (x) (define-key map (char-to-string x) 'calc-missing-key))
- (concat "ABCDEFGHIJKLMNPQRSTUVXZabcdfghjkmoprstuvwxyz"
+ (concat "ABCDEFGHIJKLMNOPQRSTUVXZabcdfghjkmoprstuvwxyz"
":\\|!()[]<>{},;=~`\C-k\C-w\C-_"))
(define-key map "\M-w" 'calc-missing-key)
(define-key map "\M-k" 'calc-missing-key)
@@ -1227,7 +1254,7 @@ the trail buffer."
;; Eventually, prompt user with a list of buffers using embedded mode.
(when (and
info-list
- (yes-or-no-p
+ (yes-or-no-p
(concat "This Calc stack is being used for embedded mode. Kill anyway?")))
(while info-list
(with-current-buffer (car (car info-list))
@@ -1379,8 +1406,7 @@ commands given here will actually operate on the *Calculator* stack."
(set (make-local-variable 'calc-main-buffer) buf))
(when (= (buffer-size) 0)
(let ((buffer-read-only nil))
- (insert (propertize (concat "Emacs Calculator Trail\n")
- 'font-lock-face 'italic))))
+ (insert (propertize "Emacs Calculator Trail\n" 'face 'italic))))
(run-mode-hooks 'calc-trail-mode-hook))
(defun calc-create-buffer ()
@@ -1619,6 +1645,7 @@ See calc-keypad for details."
(calc-select-buffer)
(setq calc-inverse-flag nil
calc-hyperbolic-flag nil
+ calc-option-flag nil
calc-keep-args-flag nil)))
(when (memq 'do-edit calc-command-flags)
(switch-to-buffer (get-buffer-create "*Calc Edit*")))
@@ -1757,6 +1784,7 @@ See calc-keypad for details."
(> (calc-stack-size) 0)
(calc-top 1 'sel)) "Sel " "")
(if calc-display-dirty "Dirty " "")
+ (if calc-option-flag "Opt " "")
(if calc-inverse-flag "Inv " "")
(if calc-hyperbolic-flag "Hyp " "")
(if calc-keep-args-flag "Keep " "")
@@ -1968,7 +1996,7 @@ See calc-keypad for details."
(erase-buffer)
(when calc-show-banner
(insert (propertize "--- Emacs Calculator Mode ---\n"
- 'font-lock-face 'italic)))
+ 'face 'italic)))
(while thing
(goto-char (point-min))
(when calc-show-banner
@@ -2378,7 +2406,7 @@ See calc-keypad for details."
(progn
(require 'calc-ext)
(calc-digit-dots))
- (delete-backward-char 1)
+ (delete-char -1)
(beep)
(calc-temp-minibuffer-message " [Bad format]"))))))
(setq calc-prev-prev-char calc-prev-char
@@ -3401,7 +3429,7 @@ largest Emacs integer.")
(Math-lessp a math-half-2-word-size))
(and (Math-integer-negp a)
(require 'calc-ext)
- (let ((comparison
+ (let ((comparison
(math-compare (Math-integer-neg a) math-half-2-word-size)))
(or (= comparison 0)
(= comparison -1))))))
@@ -3545,7 +3573,7 @@ largest Emacs integer.")
(math-normalize
(save-match-data
(cond
-
+
;; Integers (most common case)
((string-match "\\` *\\([0-9]+\\) *\\'" s)
(let ((digs (math-match-substring s 1)))
@@ -3557,22 +3585,22 @@ largest Emacs integer.")
(if (<= (length digs) (* 2 math-bignum-digit-length))
(string-to-number digs)
(cons 'bigpos (math-read-bignum digs))))))
-
+
;; Clean up the string if necessary
((string-match "\\`\\(.*\\)[ \t\n]+\\([^\001]*\\)\\'" s)
(math-read-number (concat (math-match-substring s 1)
(math-match-substring s 2))))
-
+
;; Plus and minus signs
((string-match "^[-_+]\\(.*\\)$" s)
(let ((val (math-read-number (math-match-substring s 1))))
(and val (if (eq (aref s 0) ?+) val (math-neg val)))))
-
+
;; Forms that require extensions module
((string-match "[^-+0-9eE.]" s)
(require 'calc-ext)
(math-read-number-fancy s))
-
+
;; Decimal point
((string-match "^\\([0-9]*\\)\\.\\([0-9]*\\)$" s)
(let ((int (math-match-substring s 1))
@@ -3585,7 +3613,7 @@ largest Emacs integer.")
(list 'float
(math-add (math-scale-int int flen) frac)
(- flen)))))))
-
+
;; "e" notation
((string-match "^\\(.*\\)[eE]\\([-+]?[0-9]+\\)$" s)
(let ((mant (math-match-substring s 1))
@@ -3596,7 +3624,7 @@ largest Emacs integer.")
(and mant exp (Math-realp mant) (> exp -4000000) (< exp 4000000)
(let ((mant (math-float mant)))
(list 'float (nth 1 mant) (+ (nth 2 mant) exp)))))))
-
+
;; Syntax error!
(t nil)))))
@@ -3789,7 +3817,7 @@ See Info node `(calc)Defining Functions'."
(setq unread-command-event nil)
(setq unread-command-events nil)))
-(defcalcmodevar math-2-word-size
+(defcalcmodevar math-2-word-size
(math-read-number-simple "4294967296")
"Two to the power of `calc-word-size'.")
@@ -3806,5 +3834,9 @@ See Info node `(calc)Defining Functions'."
(provide 'calc)
+;; Local variables:
+;; coding: utf-8
+;; End:
+
;; arch-tag: 0c3b170c-4ce6-4eaf-8d9b-5834d1fe938f
;;; calc.el ends here
diff --git a/lisp/calc/calcalg2.el b/lisp/calc/calcalg2.el
index 2b45ce1b2f0..4bee751ad41 100644
--- a/lisp/calc/calcalg2.el
+++ b/lisp/calc/calcalg2.el
@@ -1886,9 +1886,9 @@
;; math-scan-for-limits.
(defvar calc-low)
(defvar calc-high)
-(defvar var)
+(defvar math-var)
-(defun calcFunc-table (expr var &optional calc-low calc-high step)
+(defun calcFunc-table (expr math-var &optional calc-low calc-high step)
(or calc-low
(setq calc-low '(neg (var inf var-inf)) calc-high '(var inf var-inf)))
(or calc-high (setq calc-high calc-low calc-low 1))
@@ -1917,7 +1917,7 @@
(math-working-step-2 (1+ count))
(math-working-step 0))
(setq expr (math-evaluate-expr
- (math-expr-subst expr var '(var DUMMY var-DUMMY))))
+ (math-expr-subst expr math-var '(var DUMMY var-DUMMY))))
(while (>= count 0)
(setq math-working-step (1+ math-working-step)
var-DUMMY calc-low
@@ -1940,7 +1940,7 @@
(calc-record-why 'integerp calc-high))
(calc-record-why 'integerp calc-low)))
(append (list (or math-tabulate-function 'calcFunc-table)
- expr var)
+ expr math-var)
(and (not (and (equal calc-low '(neg (var inf var-inf)))
(equal calc-high '(var inf var-inf))))
(list calc-low calc-high))
@@ -1950,11 +1950,11 @@
(cond ((Math-primp x))
((and (eq (car x) 'calcFunc-subscr)
(Math-vectorp (nth 1 x))
- (math-expr-contains (nth 2 x) var))
+ (math-expr-contains (nth 2 x) math-var))
(let* ((calc-next-why nil)
- (low-val (math-solve-for (nth 2 x) 1 var nil))
+ (low-val (math-solve-for (nth 2 x) 1 math-var nil))
(high-val (math-solve-for (nth 2 x) (1- (length (nth 1 x)))
- var nil))
+ math-var nil))
temp)
(and low-val (math-realp low-val)
high-val (math-realp high-val))
diff --git a/lisp/calc/calccomp.el b/lisp/calc/calccomp.el
index c7d3469abe0..6923cd7693a 100644
--- a/lisp/calc/calccomp.el
+++ b/lisp/calc/calccomp.el
@@ -1,7 +1,7 @@
;;; calccomp.el --- composition functions for Calc
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004, 2005,
+;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -50,19 +50,19 @@
;;;
;;; (tag X C) Composition C corresponds to sub-expression X
-;; math-comp-just and math-comp-comma-spc are local to
-;; math-compose-expr, but are used by math-compose-matrix, which is
+;; math-comp-just and math-comp-comma-spc are local to
+;; math-compose-expr, but are used by math-compose-matrix, which is
;; called by math-compose-expr
(defvar math-comp-just)
(defvar math-comp-comma-spc)
-;; math-comp-vector-prec is local to math-compose-expr, but is used by
-;; math-compose-matrix and math-compose-rows, which are called by
+;; math-comp-vector-prec is local to math-compose-expr, but is used by
+;; math-compose-matrix and math-compose-rows, which are called by
;; math-compose-expr.
(defvar math-comp-vector-prec)
-;; math-comp-left-bracket, math-comp-right-bracket and math-comp-comma are
-;; local to math-compose-expr, but are used by math-compose-rows, which is
+;; math-comp-left-bracket, math-comp-right-bracket and math-comp-comma are
+;; local to math-compose-expr, but are used by math-compose-rows, which is
;; called by math-compose-expr.
(defvar math-comp-left-bracket)
(defvar math-comp-right-bracket)
@@ -100,7 +100,7 @@
(list 'tag a (math-compose-expr a prec))))
((and (not (consp a)) (not (integerp a)))
(concat "'" (prin1-to-string a)))
- ((setq spfn (assq (car-safe a)
+ ((setq spfn (assq (car-safe a)
(get calc-language 'math-special-function-table)))
(setq spfn (cdr spfn))
(if (consp spfn)
@@ -111,12 +111,12 @@
(and (nth 1 calc-frac-format) (Math-integerp a)))
(if (and
calc-language
- (not (memq calc-language
+ (not (memq calc-language
'(flat big unform))))
(let ((aa (math-adjust-fraction a))
(calc-frac-format nil))
(math-compose-expr (list '/
- (if (memq calc-language
+ (if (memq calc-language
calc-lang-slash-idiv)
(math-float (nth 1 aa))
(nth 1 aa))
@@ -281,22 +281,22 @@
(cdr a)
(if full rows 3) t)))))
(if (or calc-full-vectors (< (length a) 7))
- (if (and
+ (if (and
(setq spfn (get calc-language 'math-matrix-formatter))
(math-matrixp a))
(funcall spfn a)
(list 'horiz
math-comp-left-bracket
- (math-compose-vector (cdr a)
+ (math-compose-vector (cdr a)
(concat math-comp-comma " ")
math-comp-vector-prec)
math-comp-right-bracket))
(list 'horiz
math-comp-left-bracket
(math-compose-vector (list (nth 1 a) (nth 2 a) (nth 3 a))
- (concat math-comp-comma " ")
+ (concat math-comp-comma " ")
math-comp-vector-prec)
- math-comp-comma
+ math-comp-comma
(if (setq spfn (get calc-language 'math-dots))
(concat " " spfn)
" ...")
@@ -663,6 +663,8 @@
(and prevc nextc
(or (and (>= nextc ?a) (<= nextc ?z))
(and (>= nextc ?A) (<= nextc ?Z))
+ (and (>= nextc ?α) (<= nextc ?ω))
+ (and (>= nextc ?Α) (<= nextc ?Ω))
(and (>= nextc ?0) (<= nextc ?9))
(memq nextc '(?. ?_ ?#
?\( ?\[ ?\{))
@@ -732,7 +734,7 @@
(not (math-tex-expr-is-flat (nth 1 a))))))
(list 'horiz
(if lr "\\left" "")
- (if (string-match "\\`u\\([^a-zA-Z]\\)\\'" (car op))
+ (if (string-match "\\`u\\([^a-zA-Zα-ωΑ-Ω]\\)\\'" (car op))
(substring (car op) 1)
(car op))
(if (or lr (> (length (car op)) 2)) " " "")
@@ -758,7 +760,7 @@
(t
(let ((rhs (math-compose-expr (nth 1 a) (nth 3 op))))
(list 'horiz
- (let ((ops (if (string-match "\\`u\\([^a-zA-Z]\\)\\'"
+ (let ((ops (if (string-match "\\`u\\([^a-zA-Zα-ωΑ-Ω]\\)\\'"
(car op))
(substring (car op) 1)
(car op))))
@@ -806,7 +808,7 @@
(setq func (car func2)))
(setq func (math-remove-dashes
(if (string-match
- "\\`calcFunc-\\([a-zA-Z0-9']+\\)\\'"
+ "\\`calcFunc-\\([a-zA-Zα-ωΑ-Ω0-9']+\\)\\'"
(symbol-name func))
(math-match-substring (symbol-name func) 1)
(symbol-name func))))
@@ -867,7 +869,7 @@
math-comp-vector-prec)
(if (= col cols)
""
- (concat
+ (concat
math-comp-comma-spc " ")))))
a)))
res)))
@@ -878,7 +880,7 @@
(if (<= count 0)
(if (< count 0)
(math-compose-rows (cdr a) -1 nil)
- (cons (concat
+ (cons (concat
(let ((mdots (get calc-language 'math-dots)))
(if mdots
(concat " " mdots)
@@ -1117,7 +1119,7 @@
(if (memq prec '(196 201)) ")" "")))))
;; The variables math-svo-c, math-svo-wid and math-svo-off are local
-;; to math-stack-value-offset in calc.el, but are used by
+;; to math-stack-value-offset in calc.el, but are used by
;; math-stack-value-offset-fancy, which is called by math-stack-value-offset..
(defvar math-svo-c)
(defvar math-svo-wid)
@@ -1193,11 +1195,11 @@
;;; of the formula.
;; The variables math-comp-full-width, math-comp-highlight, math-comp-word,
-;; math-comp-level, math-comp-margin and math-comp-buf are local to
-;; math-comp-to-string-flat, but are used by math-comp-to-string-flat-term,
+;; math-comp-level, math-comp-margin and math-comp-buf are local to
+;; math-comp-to-string-flat, but are used by math-comp-to-string-flat-term,
;; which is called by math-comp-to-string-flat.
-;; math-comp-highlight and math-comp-buf are also local to
-;; math-comp-simplify-term and math-comp-simplify respectively, but are used
+;; math-comp-highlight and math-comp-buf are also local to
+;; math-comp-simplify-term and math-comp-simplify respectively, but are used
;; by math-comp-add-string.
(defvar math-comp-full-width)
(defvar math-comp-highlight)
@@ -1242,7 +1244,7 @@
(cond ((not (consp c))
(if math-comp-highlight
(setq c (math-comp-highlight-string c)))
- (setq math-comp-word (if (= (length math-comp-word) 0) c
+ (setq math-comp-word (if (= (length math-comp-word) 0) c
(concat math-comp-word c))
math-comp-pos (+ math-comp-pos (length c))))
@@ -1337,16 +1339,19 @@
(defun math-comp-highlight-string (s)
(setq s (copy-sequence s))
- (let ((i (length s)))
- (while (>= (setq i (1- i)) 0)
- (or (memq (aref s i) '(32 ?\n))
- (aset s i (if calc-show-selections ?\. ?\#)))))
- s)
-
+ (if calc-highlight-selections-with-faces
+ (if (not calc-show-selections)
+ (propertize s 'face 'calc-selected-face)
+ (propertize s 'face 'calc-nonselected-face))
+ (let ((i (length s)))
+ (while (>= (setq i (1- i)) 0)
+ (or (memq (aref s i) '(32 ?\n))
+ (aset s i (if calc-show-selections ?\. ?\#)))))
+ s))
;; The variable math-comp-sel-tag is local to calc-find-selected-part
-;; in calc-sel.el, but is used by math-comp-sel-flat-term and
-;; math-comp-add-string-sel, which are called (indirectly) by
+;; in calc-sel.el, but is used by math-comp-sel-flat-term and
+;; math-comp-add-string-sel, which are called (indirectly) by
;; calc-find-selected-part.
(defvar math-comp-sel-tag)
@@ -1666,5 +1671,9 @@
(provide 'calccomp)
+;; Local variables:
+;; coding: utf-8
+;; End:
+
;; arch-tag: 7c45d10a-a286-4dab-af49-7ae8989fbf78
;;; calccomp.el ends here
diff --git a/lisp/calculator.el b/lisp/calculator.el
index 3d865fba0ef..d03b2082bdb 100644
--- a/lisp/calculator.el
+++ b/lisp/calculator.el
@@ -54,7 +54,7 @@
:prefix "calculator"
:version "21.1"
:group 'tools
- :group 'convenience)
+ :group 'applications)
(defcustom calculator-electric-mode nil
"Run `calculator' electrically, in the echo area.
diff --git a/lisp/calendar/.arch-inventory b/lisp/calendar/.arch-inventory
deleted file mode 100644
index c70974836a5..00000000000
--- a/lisp/calendar/.arch-inventory
+++ /dev/null
@@ -1,4 +0,0 @@
-# Auto-generated lisp files, which ignore
-precious ^(.*-loaddefs)\.el$
-
-# arch-tag: 6246cac0-cd69-4d59-8677-c1451a4d5831
diff --git a/lisp/calendar/appt.el b/lisp/calendar/appt.el
index 8dae260ca39..d6f4f9862d6 100644
--- a/lisp/calendar/appt.el
+++ b/lisp/calendar/appt.el
@@ -6,6 +6,7 @@
;; Author: Neil Mager <neilm@juliet.ll.mit.edu>
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
+;; Package: calendar
;; This file is part of GNU Emacs.
@@ -82,17 +83,6 @@
:prefix "appt-"
:group 'calendar)
-(defcustom appt-issue-message t
- "Non-nil means check for appointments in the diary buffer.
-To be detected, the diary entry must have the format described in the
-documentation of the function `appt-check'."
- :type 'boolean
- :group 'appt)
-
-(make-obsolete-variable 'appt-issue-message
- "use the function `appt-activate', and the \
-variable `appt-display-format' instead." "22.1")
-
(defcustom appt-message-warning-time 12
"Time in minutes before an appointment that the warning begins."
:type 'integer
@@ -103,41 +93,20 @@ variable `appt-display-format' instead." "22.1")
:type 'boolean
:group 'appt)
-(defcustom appt-visible t
- "Non-nil means display appointment message in echo area.
-This variable is only relevant if `appt-msg-window' is nil."
- :type 'boolean
- :group 'appt)
-
-(make-obsolete-variable 'appt-visible 'appt-display-format "22.1")
-
-(defcustom appt-msg-window t
- "Non-nil means display appointment message in another window.
-If non-nil, this variable overrides `appt-visible'."
- :type 'boolean
- :group 'appt)
-
-(make-obsolete-variable 'appt-msg-window 'appt-display-format "22.1")
-
;; TODO - add popup.
-(defcustom appt-display-format 'ignore
+(defcustom appt-display-format 'window
"How appointment reminders should be displayed.
The options are:
window - use a separate window
echo - use the echo area
nil - no visible reminder.
-See also `appt-audible' and `appt-display-mode-line'.
-
-The default value is 'ignore, which means to fall back on the value
-of the (obsolete) variables `appt-msg-window' and `appt-visible'."
+See also `appt-audible' and `appt-display-mode-line'."
:type '(choice
(const :tag "Separate window" window)
(const :tag "Echo-area" echo)
- (const :tag "No visible display" nil)
- (const :tag "Backwards compatibility setting - choose another value"
- ignore))
+ (const :tag "No visible display" nil))
:group 'appt
- :version "22.1")
+ :version "24.1") ; no longer inherit from deleted obsolete variables
(defcustom appt-display-mode-line t
"Non-nil means display minutes to appointment and time on the mode line.
@@ -235,28 +204,19 @@ If this is non-nil, appointment checking is active.")
The string STRING describes the appointment, due in integer MINS minutes.
The format of the visible reminder is controlled by `appt-display-format'.
The variable `appt-audible' controls the audible reminder."
- ;; Let-binding for backwards compatibility. Remove when obsolete
- ;; vars appt-msg-window and appt-visible are dropped.
- (let ((appt-display-format
- (if (eq appt-display-format 'ignore)
- (cond (appt-msg-window 'window)
- (appt-visible 'echo))
- appt-display-format)))
- (if appt-audible (beep 1))
- (cond ((eq appt-display-format 'window)
- (funcall appt-disp-window-function
- (number-to-string mins)
- ;; TODO - use calendar-month-abbrev-array rather than %b?
- (format-time-string "%a %b %e " (current-time))
- string)
- (run-at-time (format "%d sec" appt-display-duration)
- nil
- appt-delete-window-function))
- ((eq appt-display-format 'echo)
- (message "%s" string)))))
-
-
-(defvar diary-selective-display)
+ (if appt-audible (beep 1))
+ (cond ((eq appt-display-format 'window)
+ (funcall appt-disp-window-function
+ (number-to-string mins)
+ ;; TODO - use calendar-month-abbrev-array rather than %b?
+ (format-time-string "%a %b %e " (current-time))
+ string)
+ (run-at-time (format "%d sec" appt-display-duration)
+ nil
+ appt-delete-window-function))
+ ((eq appt-display-format 'echo)
+ (message "%s" string))))
+
(defun appt-check (&optional force)
"Check for an appointment and update any reminder display.
@@ -325,7 +285,7 @@ displayed in a window:
(mode-line-only (unless full-check appt-now-displayed))
now cur-comp-time appt-comp-time appt-warn-time)
(when (or full-check mode-line-only)
- (save-excursion
+ (save-excursion ; FIXME ?
;; Convert current time to minutes after midnight (12.01am = 1).
(setq now (decode-time)
cur-comp-time (+ (* 60 (nth 2 now)) (nth 1 now)))
@@ -334,48 +294,22 @@ displayed in a window:
(null appt-prev-comp-time) ; first check
(< cur-comp-time appt-prev-comp-time)) ; new day
(ignore-errors
- (if appt-display-diary
- (let ((diary-hook
- (if (assoc 'appt-make-list diary-hook)
- diary-hook
- (cons 'appt-make-list diary-hook))))
- (diary))
- (let* ((diary-display-function 'appt-make-list)
- (d-buff (find-buffer-visiting diary-file))
- (selective
- (if d-buff ; diary buffer exists
- (with-current-buffer d-buff
- diary-selective-display)))
- d-buff2)
+ (let ((diary-hook (if (assoc 'appt-make-list diary-hook)
+ diary-hook
+ (cons 'appt-make-list diary-hook))))
+ (if appt-display-diary
+ (diary)
;; Not displaying the diary, so we can ignore
;; diary-number-of-entries. Since appt.el only
;; works on a daily basis, no need for more entries.
- ;; FIXME why not using diary-list-entries with
- ;; non-nil LIST-ONLY?
- (diary 1)
- ;; If the diary buffer existed before this command,
- ;; restore its display state. Otherwise, kill it.
- (and (setq d-buff2 (find-buffer-visiting diary-file))
- (if d-buff
- (or selective
- (with-current-buffer d-buff2
- (if diary-selective-display
- ;; diary-show-all-entries displays
- ;; the diary buffer.
- (diary-unhide-everything))))
- ;; FIXME does not kill any included diary files.
- ;; The real issue is that (diary) should not
- ;; have the side effect of visiting all the
- ;; diary files. It is not really appt.el's job to
- ;; clean up this mess...
- (kill-buffer d-buff2)))))))
+ (diary-list-entries (calendar-current-date) 1 t)))))
(setq appt-prev-comp-time cur-comp-time
appt-mode-string nil
appt-display-count nil)
;; If there are entries in the list, and the user wants a
;; message issued, get the first time off of the list and
;; calculate the number of minutes until the appointment.
- (when (and appt-issue-message appt-time-msg-list)
+ (when appt-time-msg-list
(setq appt-comp-time (caar (car appt-time-msg-list))
appt-warn-time (or (nth 3 (car appt-time-msg-list))
appt-message-warning-time)
@@ -512,6 +446,7 @@ sMinutes before the appointment to start warning: ")
(and warntime
(not (integerp warntime))
(error "Argument WARNTIME must be an integer, or nil"))
+ (or appt-timer (appt-activate))
(let ((time-msg (list (list (appt-convert-time time))
(concat time " " msg) t)))
;; It is presently non-sensical to have multiple warnings about
@@ -522,7 +457,6 @@ sMinutes before the appointment to start warning: ")
(setq appt-time-msg-list
(appt-sort-list (nconc appt-time-msg-list (list time-msg)))))))
-;;;###autoload
(defun appt-delete ()
"Delete an appointment from the list of appointments."
(interactive)
@@ -542,8 +476,7 @@ sMinutes before the appointment to start warning: ")
(defvar number)
(defvar original-date)
(defvar diary-entries-list)
-;; Autoload for the old way of using this package. Can be removed sometime.
-;;;###autoload
+
(defun appt-make-list ()
"Update the appointments list from today's diary buffer.
The time must be at the beginning of a line for it to be
@@ -552,92 +485,86 @@ the function `appt-check'). We assume that the variables DATE and
NUMBER hold the arguments that `diary-list-entries' received.
They specify the range of dates that the diary is being processed for.
-Any appointments made with `appt-add' are not affected by this function.
-
-For backwards compatibility, this function activates the
-appointment package (if it is not already active)."
- ;; See comments above appt-activate defun.
- (if (not appt-timer)
- (appt-activate 1)
- ;; We have something to do if the range of dates that the diary is
- ;; considering includes the current date.
- (if (and (not (calendar-date-compare
- (list (calendar-current-date))
- (list original-date)))
- (calendar-date-compare
- (list (calendar-current-date))
- (list (calendar-gregorian-from-absolute
- (+ (calendar-absolute-from-gregorian original-date)
- number)))))
- (save-excursion
- ;; Clear the appointments list, then fill it in from the diary.
- (dolist (elt appt-time-msg-list)
- ;; Delete any entries that were not made with appt-add.
- (unless (nth 2 elt)
- (setq appt-time-msg-list
- (delq elt appt-time-msg-list))))
- (if diary-entries-list
- ;; Cycle through the entry-list (diary-entries-list)
- ;; looking for entries beginning with a time. If the
- ;; entry begins with a time, add it to the
- ;; appt-time-msg-list. Then sort the list.
- (let ((entry-list diary-entries-list)
- (new-time-string "")
- time-string)
- ;; Below, we assume diary-entries-list was in date
- ;; order. It is, unless something on
- ;; diary-list-entries-hook has changed it, eg
- ;; diary-include-other-files (bug#7019). It must be
- ;; in date order if number = 1.
- (and diary-list-entries-hook
- appt-display-diary
- (not (eq diary-number-of-entries 1))
- (not (memq (car (last diary-list-entries-hook))
- '(diary-sort-entries sort-diary-entries)))
- (setq entry-list (sort entry-list 'diary-entry-compare)))
- ;; Skip diary entries for dates before today.
- (while (and entry-list
- (calendar-date-compare
- (car entry-list) (list (calendar-current-date))))
- (setq entry-list (cdr entry-list)))
- ;; Parse the entries for today.
- (while (and entry-list
- (calendar-date-equal
- (calendar-current-date) (caar entry-list)))
- (setq time-string (cadr (car entry-list)))
- (while (string-match appt-time-regexp time-string)
- (let* ((beg (match-beginning 0))
- ;; Get just the time for this appointment.
- (only-time (match-string 0 time-string))
- ;; Find the end of this appointment
- ;; (the start of the next).
- (end (string-match
- (concat "\n[ \t]*" appt-time-regexp)
- time-string
- (match-end 0)))
- ;; Get the whole string for this appointment.
- (appt-time-string
- (substring time-string beg end))
- (appt-time (list (appt-convert-time only-time)))
- (time-msg (list appt-time appt-time-string)))
- ;; Add this appointment to appt-time-msg-list.
- (setq appt-time-msg-list
- (nconc appt-time-msg-list (list time-msg))
- ;; Discard this appointment from the string.
- time-string
- (if end (substring time-string end) ""))))
- (setq entry-list (cdr entry-list)))))
- (setq appt-time-msg-list (appt-sort-list appt-time-msg-list))
- ;; Convert current time to minutes after midnight (12:01am = 1),
- ;; so that elements in the list that are earlier than the
- ;; present time can be removed.
- (let* ((now (decode-time))
- (cur-comp-time (+ (* 60 (nth 2 now)) (nth 1 now)))
- (appt-comp-time (caar (car appt-time-msg-list))))
- (while (and appt-time-msg-list (< appt-comp-time cur-comp-time))
- (setq appt-time-msg-list (cdr appt-time-msg-list))
- (if appt-time-msg-list
- (setq appt-comp-time (caar (car appt-time-msg-list))))))))))
+Any appointments made with `appt-add' are not affected by this function."
+ ;; We have something to do if the range of dates that the diary is
+ ;; considering includes the current date.
+ (if (and (not (calendar-date-compare
+ (list (calendar-current-date))
+ (list original-date)))
+ (calendar-date-compare
+ (list (calendar-current-date))
+ (list (calendar-gregorian-from-absolute
+ (+ (calendar-absolute-from-gregorian original-date)
+ number)))))
+ (save-excursion
+ ;; Clear the appointments list, then fill it in from the diary.
+ (dolist (elt appt-time-msg-list)
+ ;; Delete any entries that were not made with appt-add.
+ (unless (nth 2 elt)
+ (setq appt-time-msg-list
+ (delq elt appt-time-msg-list))))
+ (if diary-entries-list
+ ;; Cycle through the entry-list (diary-entries-list)
+ ;; looking for entries beginning with a time. If the
+ ;; entry begins with a time, add it to the
+ ;; appt-time-msg-list. Then sort the list.
+ (let ((entry-list diary-entries-list)
+ (new-time-string "")
+ time-string)
+ ;; Below, we assume diary-entries-list was in date
+ ;; order. It is, unless something on
+ ;; diary-list-entries-hook has changed it, eg
+ ;; diary-include-other-files (bug#7019). It must be
+ ;; in date order if number = 1.
+ (and diary-list-entries-hook
+ appt-display-diary
+ (not (eq diary-number-of-entries 1))
+ (not (memq (car (last diary-list-entries-hook))
+ '(diary-sort-entries sort-diary-entries)))
+ (setq entry-list (sort entry-list 'diary-entry-compare)))
+ ;; Skip diary entries for dates before today.
+ (while (and entry-list
+ (calendar-date-compare
+ (car entry-list) (list (calendar-current-date))))
+ (setq entry-list (cdr entry-list)))
+ ;; Parse the entries for today.
+ (while (and entry-list
+ (calendar-date-equal
+ (calendar-current-date) (caar entry-list)))
+ (setq time-string (cadr (car entry-list)))
+ (while (string-match appt-time-regexp time-string)
+ (let* ((beg (match-beginning 0))
+ ;; Get just the time for this appointment.
+ (only-time (match-string 0 time-string))
+ ;; Find the end of this appointment
+ ;; (the start of the next).
+ (end (string-match
+ (concat "\n[ \t]*" appt-time-regexp)
+ time-string
+ (match-end 0)))
+ ;; Get the whole string for this appointment.
+ (appt-time-string
+ (substring time-string beg end))
+ (appt-time (list (appt-convert-time only-time)))
+ (time-msg (list appt-time appt-time-string)))
+ ;; Add this appointment to appt-time-msg-list.
+ (setq appt-time-msg-list
+ (nconc appt-time-msg-list (list time-msg))
+ ;; Discard this appointment from the string.
+ time-string
+ (if end (substring time-string end) ""))))
+ (setq entry-list (cdr entry-list)))))
+ (setq appt-time-msg-list (appt-sort-list appt-time-msg-list))
+ ;; Convert current time to minutes after midnight (12:01am = 1),
+ ;; so that elements in the list that are earlier than the
+ ;; present time can be removed.
+ (let* ((now (decode-time))
+ (cur-comp-time (+ (* 60 (nth 2 now)) (nth 1 now)))
+ (appt-comp-time (caar (car appt-time-msg-list))))
+ (while (and appt-time-msg-list (< appt-comp-time cur-comp-time))
+ (setq appt-time-msg-list (cdr appt-time-msg-list))
+ (if appt-time-msg-list
+ (setq appt-comp-time (caar (car appt-time-msg-list)))))))))
(defun appt-sort-list (appt-list)
@@ -677,30 +604,6 @@ It is intended for use with `write-file-functions'."
(appt-check t)))
nil)
-;; In Emacs-21.3, the manual documented the following procedure to
-;; activate this package:
-;; (display-time)
-;; (add-hook 'diary-hook 'appt-make-list)
-;; (diary 0)
-;; The display-time call was not necessary, AFAICS.
-;; What was really needed was to add the hook and load this file.
-;; Calling (diary 0) once the hook had been added was in some sense a
-;; roundabout way of loading this file. This file used to have code at
-;; the top-level that set up the appt-timer and global-mode-string.
-;; One way to maintain backwards compatibility would be to call
-;; (appt-activate 1) at top-level. However, this goes against the
-;; convention that just loading an Emacs package should not activate
-;; it. Instead, we make appt-make-list activate the package (after a
-;; suggestion from rms). This means that one has to call diary in
-;; order to get it to work, but that is in line with the old (weird,
-;; IMO) documented behavior for activating the package.
-;; Actually, since (diary 0) does not run diary-hook, I don't think
-;; the documented behavior in Emacs-21.3 would ever have worked.
-;; Oh well, at least with the changes to appt-make-list it will now
-;; work as well as it ever did.
-;; The new method is just to use (appt-activate 1).
-;; -- gmorris
-
;;;###autoload
(defun appt-activate (&optional arg)
"Toggle checking of appointments.
@@ -716,15 +619,21 @@ ARG is positive, otherwise off."
(when appt-timer
(cancel-timer appt-timer)
(setq appt-timer nil))
- (when appt-active
- (add-hook 'write-file-functions 'appt-update-list)
- (setq appt-timer (run-at-time t 60 'appt-check)
- global-mode-string
- (append global-mode-string '(appt-mode-string)))
- (appt-check t))))
+ (if appt-active
+ (progn
+ (add-hook 'write-file-functions 'appt-update-list)
+ (setq appt-timer (run-at-time t 60 'appt-check)
+ global-mode-string
+ (append global-mode-string '(appt-mode-string)))
+ (appt-check t)
+ (message "Appointment reminders enabled%s"
+ ;; Someone might want to use appt-add without a diary.
+ (if (ignore-errors (diary-check-diary-file))
+ ""
+ " (no diary file found)")))
+ (message "Appointment reminders disabled"))))
(provide 'appt)
-;; arch-tag: bf5791c4-8921-499e-a26f-772b1788d347
;;; appt.el ends here
diff --git a/lisp/calendar/cal-bahai.el b/lisp/calendar/cal-bahai.el
index 7270d423409..7b8f61a7a84 100644
--- a/lisp/calendar/cal-bahai.el
+++ b/lisp/calendar/cal-bahai.el
@@ -6,6 +6,7 @@
;; Author: John Wiegley <johnw@gnu.org>
;; Keywords: calendar
;; Human-Keywords: Bahá'í calendar, Bahá'í, Baha'i, Bahai, calendar, diary
+;; Package: calendar
;; This file is part of GNU Emacs.
diff --git a/lisp/calendar/cal-china.el b/lisp/calendar/cal-china.el
index f9946c18045..0fc63e7eaac 100644
--- a/lisp/calendar/cal-china.el
+++ b/lisp/calendar/cal-china.el
@@ -7,6 +7,7 @@
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: Chinese calendar, calendar, holidays, diary
+;; Package: calendar
;; This file is part of GNU Emacs.
diff --git a/lisp/calendar/cal-coptic.el b/lisp/calendar/cal-coptic.el
index 16cc6672727..69612edab38 100644
--- a/lisp/calendar/cal-coptic.el
+++ b/lisp/calendar/cal-coptic.el
@@ -7,6 +7,7 @@
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: Coptic calendar, Ethiopic calendar, calendar, diary
+;; Package: calendar
;; This file is part of GNU Emacs.
diff --git a/lisp/calendar/cal-dst.el b/lisp/calendar/cal-dst.el
index c541caa5696..d27bc8480a7 100644
--- a/lisp/calendar/cal-dst.el
+++ b/lisp/calendar/cal-dst.el
@@ -8,6 +8,7 @@
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: daylight saving time, calendar, diary, holidays
+;; Package: calendar
;; This file is part of GNU Emacs.
diff --git a/lisp/calendar/cal-french.el b/lisp/calendar/cal-french.el
index 1ee290f5aa9..98a118f232f 100644
--- a/lisp/calendar/cal-french.el
+++ b/lisp/calendar/cal-french.el
@@ -1,12 +1,14 @@
;;; cal-french.el --- calendar functions for the French Revolutionary calendar
;; Copyright (C) 1988, 1989, 1992, 1994, 1995, 1997, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: French Revolutionary calendar, calendar, diary
+;; Package: calendar
;; This file is part of GNU Emacs.
@@ -40,8 +42,8 @@
"Array of month names in the French calendar.")
(defconst calendar-french-multibyte-month-name-array
- ["Vendmiaire" "Brumaire" "Frimaire" "Nivse" "Pluvise" "Ventse"
- "Germinal" "Floral" "Prairial" "Messidor" "Thermidor" "Fructidor"]
+ ["Vendémiaire" "Brumaire" "Frimaire" "Nivôse" "Pluviôse" "Ventôse"
+ "Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"]
"Array of multibyte month names in the French calendar.")
(defconst calendar-french-day-name-array
@@ -55,8 +57,8 @@
"Array of special day names in the French calendar.")
(defconst calendar-french-multibyte-special-days-array
- ["de la Vertu" "du Gnie" "du Travail" "de la Raison" "des Rcompenses"
- "de la Rvolution"]
+ ["de la Vertu" "du Génie" "du Travail" "de la Raison" "des Récompenses"
+ "de la Révolution"]
"Array of multibyte special day names in the French calendar.")
(defun calendar-french-accents-p ()
@@ -174,13 +176,13 @@ Defaults to today's date if DATE is not given."
(cond
((< y 1) "")
((= m 13) (format (if (calendar-french-accents-p)
- "Jour %s de l'Anne %d de la Rvolution"
+ "Jour %s de l'Année %d de la Révolution"
"Jour %s de l'Anne'e %d de la Re'volution")
(aref (calendar-french-special-days-array) (1- d))
y))
(t (format
(if (calendar-french-accents-p)
- "%d %s an %d de la Rvolution"
+ "%d %s an %d de la Révolution"
"%d %s an %d de la Re'volution")
d
(aref (calendar-french-month-name-array) (1- m))
@@ -208,7 +210,7 @@ Echo French Revolutionary date unless NOECHO is non-nil."
(year (progn
(calendar-read
(if (calendar-french-accents-p)
- "Anne de la Rvolution (>0): "
+ "Année de la Révolution (>0): "
"Anne'e de la Re'volution (>0): ")
(lambda (x) (> x 0))
(number-to-string
@@ -264,5 +266,9 @@ Echo French Revolutionary date unless NOECHO is non-nil."
(provide 'cal-french)
+;; Local Variables:
+;; coding: utf-8
+;; End:
+
;; arch-tag: 7e8045a3-8609-46b5-9cde-cf40ce541cf9
;;; cal-french.el ends here
diff --git a/lisp/calendar/cal-hebrew.el b/lisp/calendar/cal-hebrew.el
index 2a7556ff322..366fb2396fc 100644
--- a/lisp/calendar/cal-hebrew.el
+++ b/lisp/calendar/cal-hebrew.el
@@ -8,6 +8,7 @@
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: Hebrew calendar, calendar, diary
+;; Package: calendar
;; This file is part of GNU Emacs.
@@ -375,7 +376,7 @@ or ALL is non-nil."
(list (calendar-gregorian-from-absolute (1+ abs-r-h))
"Rosh HaShanah (second day)")
(list (calendar-gregorian-from-absolute
- (if (= (% abs-r-h 7) 4) (+ abs-r-h 3) (+ abs-r-h 2)))
+ (+ abs-r-h (if (= (% abs-r-h 7) 4) 3 2)))
"Tzom Gedaliah")
(list (calendar-gregorian-from-absolute
(calendar-dayname-on-or-before 6 (+ 7 abs-r-h)))
@@ -453,70 +454,71 @@ or ALL is non-nil."
(list (calendar-gregorian-from-absolute (+ abs-p 50))
"Shavuot"))
(when (or all calendar-hebrew-all-holidays-flag)
- (list
- (list (calendar-gregorian-from-absolute
- (calendar-dayname-on-or-before 6 (- abs-p 43)))
- "Shabbat Shekalim")
- (list (calendar-gregorian-from-absolute
- (calendar-dayname-on-or-before 6 (- abs-p 30)))
- "Shabbat Zachor")
- (list (calendar-gregorian-from-absolute
- (if (= (% abs-p 7) 2) (- abs-p 33) (- abs-p 31)))
- "Fast of Esther")
- (list (calendar-gregorian-from-absolute (- abs-p 31))
- "Erev Purim")
- (list (calendar-gregorian-from-absolute (- abs-p 30))
- "Purim")
- (list (calendar-gregorian-from-absolute
- (if (zerop (% abs-p 7)) (- abs-p 28) (- abs-p 29)))
- "Shushan Purim")
- (list (calendar-gregorian-from-absolute
- (- (calendar-dayname-on-or-before 6 (- abs-p 14)) 7))
- "Shabbat Parah")
- (list (calendar-gregorian-from-absolute
- (calendar-dayname-on-or-before 6 (- abs-p 14)))
- "Shabbat HaHodesh")
- (list (calendar-gregorian-from-absolute
- (calendar-dayname-on-or-before 6 (1- abs-p)))
- "Shabbat HaGadol")
- (list (calendar-gregorian-from-absolute (1- abs-p))
- "Erev Passover")
- (list (calendar-gregorian-from-absolute (1+ abs-p))
- "Passover (second day)")
- (list (calendar-gregorian-from-absolute (+ abs-p 2))
- "Hol Hamoed Passover (first day)")
- (list (calendar-gregorian-from-absolute (+ abs-p 3))
- "Hol Hamoed Passover (second day)")
- (list (calendar-gregorian-from-absolute (+ abs-p 4))
- "Hol Hamoed Passover (third day)")
- (list (calendar-gregorian-from-absolute (+ abs-p 5))
- "Hol Hamoed Passover (fourth day)")
- (list (calendar-gregorian-from-absolute (+ abs-p 6))
- "Passover (seventh day)")
- (list (calendar-gregorian-from-absolute (+ abs-p 7))
- "Passover (eighth day)")
- (list (calendar-gregorian-from-absolute
- (if (zerop (% (+ abs-p 12) 7))
- (+ abs-p 13)
- (+ abs-p 12)))
- "Yom HaShoah")
- (list (calendar-gregorian-from-absolute
- (if (zerop (% abs-p 7))
- (+ abs-p 18)
- (if (= (% abs-p 7) 6)
- (+ abs-p 19)
- (if (= (% abs-p 7) 2)
- (+ abs-p 21)
- (+ abs-p 20)))))
- "Yom HaAtzma'ut")
- (list (calendar-gregorian-from-absolute (+ abs-p 33))
- "Lag BaOmer")
- (list (calendar-gregorian-from-absolute (+ abs-p 43))
- "Yom Yerushalaim")
- (list (calendar-gregorian-from-absolute (+ abs-p 49))
- "Erev Shavuot")
- (list (calendar-gregorian-from-absolute (+ abs-p 51))
- "Shavuot (second day)"))))))))
+ (let ((wday (% abs-p 7)))
+ (list
+ (list (calendar-gregorian-from-absolute
+ (calendar-dayname-on-or-before 6 (- abs-p 43)))
+ "Shabbat Shekalim")
+ (list (calendar-gregorian-from-absolute
+ (calendar-dayname-on-or-before 6 (- abs-p 30)))
+ "Shabbat Zachor")
+ (list (calendar-gregorian-from-absolute
+ (- abs-p (if (= wday 2) 33 31)))
+ "Fast of Esther")
+ (list (calendar-gregorian-from-absolute (- abs-p 31))
+ "Erev Purim")
+ (list (calendar-gregorian-from-absolute (- abs-p 30))
+ "Purim")
+ (list (calendar-gregorian-from-absolute
+ (- abs-p (if (zerop wday) 28 29)))
+ "Shushan Purim")
+ (list (calendar-gregorian-from-absolute
+ (- (calendar-dayname-on-or-before 6 (- abs-p 14)) 7))
+ "Shabbat Parah")
+ (list (calendar-gregorian-from-absolute
+ (calendar-dayname-on-or-before 6 (- abs-p 14)))
+ "Shabbat HaHodesh")
+ (list (calendar-gregorian-from-absolute
+ (calendar-dayname-on-or-before 6 (1- abs-p)))
+ "Shabbat HaGadol")
+ (list (calendar-gregorian-from-absolute (1- abs-p))
+ "Erev Passover")
+ (list (calendar-gregorian-from-absolute (1+ abs-p))
+ "Passover (second day)")
+ (list (calendar-gregorian-from-absolute (+ abs-p 2))
+ "Hol Hamoed Passover (first day)")
+ (list (calendar-gregorian-from-absolute (+ abs-p 3))
+ "Hol Hamoed Passover (second day)")
+ (list (calendar-gregorian-from-absolute (+ abs-p 4))
+ "Hol Hamoed Passover (third day)")
+ (list (calendar-gregorian-from-absolute (+ abs-p 5))
+ "Hol Hamoed Passover (fourth day)")
+ (list (calendar-gregorian-from-absolute (+ abs-p 6))
+ "Passover (seventh day)")
+ (list (calendar-gregorian-from-absolute (+ abs-p 7))
+ "Passover (eighth day)")
+ (list (calendar-gregorian-from-absolute
+ (+ abs-p (if (zerop (% (+ abs-p 12) 7))
+ 13
+ 12)))
+ "Yom HaShoah")
+ (list (calendar-gregorian-from-absolute
+ (+ abs-p
+ ;; If falls on Sat or Fri, moves to preceding Thurs.
+ ;; If falls on Mon, moves to Tues (since 2004).
+ (cond ((zerop wday) 18) ; Sat
+ ((= wday 6) 19) ; Fri
+ ((= wday 2) 21) ; Mon
+ (t 20))))
+ "Yom HaAtzma'ut")
+ (list (calendar-gregorian-from-absolute (+ abs-p 33))
+ "Lag BaOmer")
+ (list (calendar-gregorian-from-absolute (+ abs-p 43))
+ "Yom Yerushalaim")
+ (list (calendar-gregorian-from-absolute (+ abs-p 49))
+ "Erev Shavuot")
+ (list (calendar-gregorian-from-absolute (+ abs-p 51))
+ "Shavuot (second day)")))))))))
;;;###holiday-autoload
(define-obsolete-function-alias 'holiday-passover-etc
@@ -526,18 +528,19 @@ or ALL is non-nil."
(defun holiday-hebrew-tisha-b-av ()
"List of dates around Tisha B'Av, as visible in calendar window."
(when (memq displayed-month '(5 6 7 8 9))
- (let ((abs-t-a (calendar-hebrew-to-absolute
- (list 5 9 (+ displayed-year 3760)))))
+ (let* ((abs-t-a (calendar-hebrew-to-absolute
+ (list 5 9 (+ displayed-year 3760))))
+ (wday (% abs-t-a 7)))
(holiday-filter-visible-calendar
(list
(list (calendar-gregorian-from-absolute
- (if (= (% abs-t-a 7) 6) (- abs-t-a 20) (- abs-t-a 21)))
+ (- abs-t-a (if (= wday 6) 20 21)))
"Tzom Tammuz")
(list (calendar-gregorian-from-absolute
(calendar-dayname-on-or-before 6 abs-t-a))
"Shabbat Hazon")
(list (calendar-gregorian-from-absolute
- (if (= (% abs-t-a 7) 6) (1+ abs-t-a) abs-t-a))
+ (if (= wday 6) (1+ abs-t-a) abs-t-a))
"Tisha B'Av")
(list (calendar-gregorian-from-absolute
(calendar-dayname-on-or-before 6 (+ abs-t-a 7)))
@@ -556,7 +559,7 @@ Includes: Tal Umatar, Tzom Teveth, Tu B'Shevat, Shabbat Shirah, and
Kiddush HaHamah."
(let ((m displayed-month)
(y displayed-year)
- year h-year s-s)
+ year h-year)
(append
(holiday-julian
11
@@ -590,20 +593,17 @@ Kiddush HaHamah."
(calendar-extract-year
(calendar-hebrew-from-absolute
(calendar-absolute-from-gregorian
- (list m (calendar-last-day-of-month m y) y)))))
- s-s
- (calendar-hebrew-from-absolute
- (if (= 6
- (% (calendar-hebrew-to-absolute
- (list 7 1 h-year))
- 7))
- (calendar-dayname-on-or-before
- 6 (calendar-hebrew-to-absolute
- (list 11 17 h-year)))
- (calendar-dayname-on-or-before
- 6 (calendar-hebrew-to-absolute
- (list 11 16 h-year))))))
- (calendar-extract-day s-s))
+ (list m (calendar-last-day-of-month m y) y))))))
+ (calendar-extract-day
+ (calendar-hebrew-from-absolute
+ (calendar-dayname-on-or-before
+ 6 (calendar-hebrew-to-absolute
+ (list 11
+ (if (= 6
+ (% (calendar-hebrew-to-absolute
+ (list 7 1 h-year))
+ 7))
+ 17 16) h-year))))))
"Shabbat Shirah")
(and (progn
(setq m displayed-month
@@ -1161,5 +1161,4 @@ use when highlighting the day in the calendar."
(provide 'cal-hebrew)
-;; arch-tag: aaab6718-7712-42ac-a32d-28fe1f944f3c
;;; cal-hebrew.el ends here
diff --git a/lisp/calendar/cal-html.el b/lisp/calendar/cal-html.el
index 33066b201bf..d4210027600 100644
--- a/lisp/calendar/cal-html.el
+++ b/lisp/calendar/cal-html.el
@@ -7,6 +7,7 @@
;; Keywords: calendar
;; Human-Keywords: calendar, diary, HTML
;; Created: 23 Aug 2002
+;; Package: calendar
;; This file is part of GNU Emacs.
diff --git a/lisp/calendar/cal-islam.el b/lisp/calendar/cal-islam.el
index 1c09f1db113..da631a9710a 100644
--- a/lisp/calendar/cal-islam.el
+++ b/lisp/calendar/cal-islam.el
@@ -7,6 +7,7 @@
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: Islamic calendar, calendar, diary
+;; Package: calendar
;; This file is part of GNU Emacs.
diff --git a/lisp/calendar/cal-iso.el b/lisp/calendar/cal-iso.el
index 0762860b0ba..3c5055defb6 100644
--- a/lisp/calendar/cal-iso.el
+++ b/lisp/calendar/cal-iso.el
@@ -7,6 +7,7 @@
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: ISO calendar, calendar, diary
+;; Package: calendar
;; This file is part of GNU Emacs.
diff --git a/lisp/calendar/cal-julian.el b/lisp/calendar/cal-julian.el
index d1cea19be40..0cf9388a4b0 100644
--- a/lisp/calendar/cal-julian.el
+++ b/lisp/calendar/cal-julian.el
@@ -7,6 +7,7 @@
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: Julian calendar, Julian day number, calendar, diary
+;; Package: calendar
;; This file is part of GNU Emacs.
diff --git a/lisp/calendar/cal-mayan.el b/lisp/calendar/cal-mayan.el
index de079b122c7..d2e4810fa82 100644
--- a/lisp/calendar/cal-mayan.el
+++ b/lisp/calendar/cal-mayan.el
@@ -8,6 +8,7 @@
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: Mayan calendar, Maya, calendar, diary
+;; Package: calendar
;; This file is part of GNU Emacs.
diff --git a/lisp/calendar/cal-menu.el b/lisp/calendar/cal-menu.el
index 521cd2dce2d..877be9556fb 100644
--- a/lisp/calendar/cal-menu.el
+++ b/lisp/calendar/cal-menu.el
@@ -8,6 +8,7 @@
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: calendar, popup menus, menu bar
+;; Package: calendar
;; This file is part of GNU Emacs.
diff --git a/lisp/calendar/cal-move.el b/lisp/calendar/cal-move.el
index 89e45bef779..e569e8c424c 100644
--- a/lisp/calendar/cal-move.el
+++ b/lisp/calendar/cal-move.el
@@ -7,6 +7,7 @@
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: calendar
+;; Package: calendar
;; This file is part of GNU Emacs.
diff --git a/lisp/calendar/cal-persia.el b/lisp/calendar/cal-persia.el
index 95ae2f165bb..5c624ddcf01 100644
--- a/lisp/calendar/cal-persia.el
+++ b/lisp/calendar/cal-persia.el
@@ -7,6 +7,7 @@
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: Persian calendar, calendar, diary
+;; Package: calendar
;; This file is part of GNU Emacs.
diff --git a/lisp/calendar/cal-tex.el b/lisp/calendar/cal-tex.el
index 46fb0869787..e6ba1ad3439 100644
--- a/lisp/calendar/cal-tex.el
+++ b/lisp/calendar/cal-tex.el
@@ -8,6 +8,7 @@
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: Calendar, LaTeX
+;; Package: calendar
;; This file is part of GNU Emacs.
diff --git a/lisp/calendar/cal-x.el b/lisp/calendar/cal-x.el
index 90a4c5d33b8..377646147b9 100644
--- a/lisp/calendar/cal-x.el
+++ b/lisp/calendar/cal-x.el
@@ -8,6 +8,7 @@
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: calendar, dedicated frames
+;; Package: calendar
;; This file is part of GNU Emacs.
diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el
index 219e489a2eb..231c92f417d 100644
--- a/lisp/calendar/diary-lib.el
+++ b/lisp/calendar/diary-lib.el
@@ -1,7 +1,8 @@
;;; diary-lib.el --- diary functions
;; Copyright (C) 1989, 1990, 1992, 1993, 1994, 1995, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
;; Maintainer: Glenn Morris <rgm@gnu.org>
@@ -304,28 +305,48 @@ If this variable is nil, years must be written in full."
:type 'boolean
:group 'diary)
+(defun diary-outlook-format-1 (body)
+ "Return a replace-match template for an element of `diary-outlook-formats'.
+Returns a string using match elements 1-5, where:
+1 = month name, 2 = day, 3 = year, 4 = time, 5 = location; also uses
+%s = message subject. BODY is the string from which the matches derive."
+ (let* ((monthname (match-string 1 body))
+ (day (match-string 2 body))
+ (year (match-string 3 body))
+ ;; Blech.
+ (month (catch 'found
+ (dotimes (i (length calendar-month-name-array))
+ (if (string-equal (aref calendar-month-name-array i)
+ monthname)
+ (throw 'found (1+ i))))
+ nil)))
+ ;; If we could convert the monthname to a numeric month, we can
+ ;; use the standard function calendar-date-string.
+ (concat (if month
+ (calendar-date-string (list month (string-to-number day)
+ (string-to-number year)))
+ (cond ((eq calendar-date-style 'iso) "\\3 \\1 \\2") ; YMD
+ ((eq calendar-date-style 'european) "\\2 \\1 \\3") ; DMY
+ (t "\\1 \\2 \\3"))) ; MDY
+ "\n \\4 %s, \\5")))
+;; TODO Sometimes the time is in a different time-zone to the one you
+;; are in. Eg in PST, you might still get an email referring to:
+;; "7:00 PM-8:00 PM. Greenwich Standard Time".
+;; Note that it doesn't use a standard abbreviation for the timezone,
+;; or anything helpful like that.
+;; Sigh, this could cause the meeting to even be on a different day
+;; to that given in the When: string.
+;; These things seem to come in a multipart mail with a calendar part,
+;; it's probably better to use that rather than this whole thing.
+;; So this is unlikely to get improved.
+
+;; TODO Is the format of these messages actually documented anywhere?
(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"))
+ '(;; When: Tuesday, November 9, 2010 7:00 PM-8:00 PM. Greenwich Standard Time
+ ;; Where: Meeting room B
+ ("[ \t\n]*When: [[:alpha:]]+, \\([[:alpha:]]+\\) \\([0-9][0-9]*\\), \
+\\([0-9]\\{4\\}\\),? \\(.+\\)\n\
+\\(?:Where: \\(.+\n\\)\\)?" . diary-outlook-format-1))
"Alist of regexps matching message text and replacement text.
The regexp must match the start of the message text containing an
@@ -487,8 +508,6 @@ in the displayed three-month calendar."
(diary-check-diary-file)
(diary-list-entries (calendar-cursor-to-date t) arg))
-(define-obsolete-function-alias 'view-diary-entries 'diary-view-entries "22.1")
-
;;;###cal-autoload
(defun diary-view-other-diary-entries (arg dfile)
@@ -594,19 +613,20 @@ The entry is added to the list as (DATE STRING SPECIFIER LOCATOR
GLOBCOLOR), where LOCATOR has the form (MARKER FILENAME LITERAL),
FILENAME being the file containing the diary entry."
(when (and date string)
- (if diary-file-name-prefix
- (let ((prefix (funcall diary-file-name-prefix-function
- (buffer-file-name))))
- (or (string-equal prefix "")
- (setq string (format "[%s] %s" prefix string)))))
- (and diary-modify-entry-list-string-function
- (setq string (funcall diary-modify-entry-list-string-function
- string)))
- (setq diary-entries-list
- (append diary-entries-list
- (list (list date string specifier
- (list marker (buffer-file-name) literal)
- globcolor))))))
+ ;; b-f-n is nil if we are visiting an include file in a temp-buffer.
+ (let ((dfile (or (buffer-file-name) diary-file)))
+ (if diary-file-name-prefix
+ (let ((prefix (funcall diary-file-name-prefix-function dfile)))
+ (or (string-equal prefix "")
+ (setq string (format "[%s] %s" prefix string)))))
+ (and diary-modify-entry-list-string-function
+ (setq string (funcall diary-modify-entry-list-string-function
+ string)))
+ (setq diary-entries-list
+ (append diary-entries-list
+ (list (list date string specifier
+ (list marker dfile literal)
+ globcolor)))))))
(define-obsolete-function-alias 'add-to-diary-list 'diary-add-to-list "23.1")
@@ -700,7 +720,6 @@ of the appropriate type."
(1+ (calendar-absolute-from-gregorian gdate))))))
(goto-char (point-min)))
-(defvar diary-including) ; dynamically bound in diary-include-other-diary-files
(defvar diary-included-files nil
"List of any diary files included in the last call to `diary-list-entries'.")
@@ -759,66 +778,74 @@ LIST-ONLY is non-nil, in which case it just returns the list."
(let* ((original-date date) ; save for possible use in the hooks
(date-string (calendar-date-string date))
(diary-buffer (find-buffer-visiting diary-file))
- diary-entries-list file-glob-attrs)
- (or (bound-and-true-p diary-including)
- (setq diary-included-files nil))
- (message "Preparing diary...")
- (save-current-buffer
- (if (not diary-buffer)
- (set-buffer (find-file-noselect diary-file t))
- (set-buffer diary-buffer)
- (or (verify-visited-file-modtime diary-buffer)
- (revert-buffer t t)))
- ;; Setup things like the header-line-format and invisibility-spec.
- (if (eq major-mode (default-value 'major-mode))
- (diary-mode)
- ;; This kludge is to make customizations to
- ;; diary-header-line-flag after diary has been displayed
- ;; take effect. Unconditionally calling (diary-mode)
- ;; clobbers file local variables.
- ;; http://lists.gnu.org/archive/html/emacs-pretest-bug/2007-03/msg00363.html
- ;; http://lists.gnu.org/archive/html/emacs-pretest-bug/2007-04/msg00404.html
- (if (eq major-mode 'diary-mode)
- (setq header-line-format (and diary-header-line-flag
- diary-header-line-format))))
- ;; d-s-p is passed to the diary display function.
- (let ((diary-saved-point (point)))
- (save-excursion
- (save-restriction
- (widen) ; bug#5093
- (setq file-glob-attrs (cadr (diary-pull-attrs nil "")))
- (with-syntax-table diary-syntax-table
- (goto-char (point-min))
- (unless list-only
- (let ((ol (make-overlay (point-min) (point-max) nil t nil)))
- (set (make-local-variable 'diary-selective-display) t)
- (overlay-put ol 'invisible 'diary)
- (overlay-put ol 'evaporate t)))
- (dotimes (idummy number)
- (let ((sexp-found (diary-list-sexp-entries date))
- (entry-found (diary-list-entries-2
- date diary-nonmarking-symbol
- file-glob-attrs list-only)))
- (if diary-list-include-blanks
- (or sexp-found entry-found
- (diary-add-to-list date "" "" "" "")))
- (setq date
- (calendar-gregorian-from-absolute
- (1+ (calendar-absolute-from-gregorian date)))))))
- (goto-char (point-min))
- (run-hooks 'diary-nongregorian-listing-hook
- 'diary-list-entries-hook)
- (unless list-only
- (if (and diary-display-function
- (listp diary-display-function))
- ;; Backwards compatibility.
- (run-hooks 'diary-display-function)
- (funcall (or diary-display-function
- 'diary-simple-display))))
- (run-hooks 'diary-hook)
- diary-entries-list)))))))
-
-(define-obsolete-function-alias 'list-diary-entries 'diary-list-entries "22.1")
+ ;; Dynamically bound in diary-include-other-diary-files.
+ (d-incp (and (boundp 'diary-including) diary-including))
+ diary-entries-list file-glob-attrs temp-buff)
+ (unless d-incp
+ (setq diary-included-files nil)
+ (message "Preparing diary..."))
+ (unwind-protect
+ (with-current-buffer (or diary-buffer
+ (if list-only
+ (setq temp-buff (generate-new-buffer
+ " *diary-temp*"))
+ (find-file-noselect diary-file t)))
+ (if diary-buffer
+ (or (verify-visited-file-modtime diary-buffer)
+ (revert-buffer t t)))
+ (if temp-buff
+ ;; If including, caller has already verified it is readable.
+ (insert-file-contents diary-file)
+ ;; Setup things like the header-line-format and invisibility-spec.
+ (if (eq major-mode (default-value 'major-mode))
+ (diary-mode)
+ ;; This kludge is to make customizations to
+ ;; diary-header-line-flag after diary has been displayed
+ ;; take effect. Unconditionally calling (diary-mode)
+ ;; clobbers file local variables.
+ ;; http://lists.gnu.org/archive/html/emacs-pretest-bug/2007-03/msg00363.html
+ ;; http://lists.gnu.org/archive/html/emacs-pretest-bug/2007-04/msg00404.html
+ (if (eq major-mode 'diary-mode)
+ (setq header-line-format (and diary-header-line-flag
+ diary-header-line-format)))))
+ ;; d-s-p is passed to the diary display function.
+ (let ((diary-saved-point (point)))
+ (save-excursion
+ (save-restriction
+ (widen) ; bug#5093
+ (setq file-glob-attrs (cadr (diary-pull-attrs nil "")))
+ (with-syntax-table diary-syntax-table
+ (goto-char (point-min))
+ (unless list-only
+ (let ((ol (make-overlay (point-min) (point-max) nil t nil)))
+ (set (make-local-variable 'diary-selective-display) t)
+ (overlay-put ol 'invisible 'diary)
+ (overlay-put ol 'evaporate t)))
+ (dotimes (idummy number)
+ (let ((sexp-found (diary-list-sexp-entries date))
+ (entry-found (diary-list-entries-2
+ date diary-nonmarking-symbol
+ file-glob-attrs list-only)))
+ (if diary-list-include-blanks
+ (or sexp-found entry-found
+ (diary-add-to-list date "" "" "" "")))
+ (setq date
+ (calendar-gregorian-from-absolute
+ (1+ (calendar-absolute-from-gregorian date)))))))
+ (goto-char (point-min))
+ (run-hooks 'diary-nongregorian-listing-hook
+ 'diary-list-entries-hook)
+ (unless list-only
+ (if (and diary-display-function
+ (listp diary-display-function))
+ ;; Backwards compatibility.
+ (run-hooks 'diary-display-function)
+ (funcall (or diary-display-function
+ 'diary-simple-display))))
+ (run-hooks 'diary-hook)))))
+ (and temp-buff (buffer-name temp-buff) (kill-buffer temp-buff)))
+ (or d-incp (message "Preparing diary...done"))
+ diary-entries-list)))
(defun diary-unhide-everything ()
"Show all invisible text in the diary."
@@ -829,7 +856,7 @@ LIST-ONLY is non-nil, in which case it just returns the list."
(kill-local-variable 'mode-line-format))
(defvar original-date) ; bound in diary-list-entries
-(defvar number)
+;(defvar number) ; already declared above
(defun diary-include-other-diary-files ()
"Include the diary entries from other diary files with those of `diary-file'.
@@ -846,20 +873,18 @@ the variable `diary-include-string'."
nil t)
(let ((diary-file (match-string-no-properties 1))
(diary-list-entries-hook 'diary-include-other-diary-files)
- (diary-display-function 'ignore)
(diary-including t)
- diary-hook diary-list-include-blanks)
+ diary-hook diary-list-include-blanks efile)
(if (file-exists-p diary-file)
(if (file-readable-p diary-file)
- (unwind-protect
- (setq diary-included-files
- (append diary-included-files
- (list (expand-file-name diary-file)))
- diary-entries-list
- (append diary-entries-list
- (diary-list-entries original-date number)))
- (with-current-buffer (find-buffer-visiting diary-file)
- (diary-unhide-everything)))
+ (if (member (setq efile (expand-file-name diary-file))
+ diary-included-files)
+ (error "Recursive diary include for %s" diary-file)
+ (setq diary-included-files
+ (append diary-included-files (list efile))
+ diary-entries-list
+ (append diary-entries-list
+ (diary-list-entries original-date number t))))
(beep)
(message "Can't read included diary file %s" diary-file)
(sleep-for 2))
@@ -928,8 +953,7 @@ in the mode line. This is an option for `diary-display-function'."
(let ((window (display-buffer (current-buffer))))
;; d-s-p is passed from diary-list-entries.
(set-window-point window diary-saved-point)
- (set-window-start window (point-min))))
- (message "Preparing diary...done"))))
+ (set-window-start window (point-min)))))))
(define-obsolete-function-alias 'simple-diary-display
'diary-simple-display "23.1")
@@ -1051,8 +1075,7 @@ This is an option for `diary-display-function'."
(if (eq major-mode 'diary-fancy-display-mode)
(run-hooks 'diary-fancy-display-mode-hook)
(diary-fancy-display-mode))
- (calendar-set-mode-line date-string)
- (message "Preparing diary...done"))))
+ (calendar-set-mode-line date-string))))
(define-obsolete-function-alias 'fancy-diary-display
'diary-fancy-display "23.1")
@@ -1126,9 +1149,6 @@ is created."
(derived-mode-p 'calendar-mode)))
(fit-window-to-buffer win)))))
-(define-obsolete-function-alias 'show-all-diary-entries
- 'diary-show-all-entries "22.1")
-
;;;###autoload
(defun diary-mail-entries (&optional ndays)
"Send a mail message showing diary entries for next NDAYS days.
@@ -2332,6 +2352,7 @@ return a font-lock pattern matching array of MONTHS and marking SYMBOL."
;;; Fancy Diary Mode.
+;; FIXME does not update upon changes to the name-arrays.
(defvar diary-fancy-date-pattern
(concat
(let ((dayname (diary-name-pattern calendar-day-name-array nil t))
@@ -2413,37 +2434,27 @@ Fontify the region between BEG and END, quietly unless VERBOSE is non-nil."
;; 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'.
-
-(defvar subject) ; bound in diary-from-outlook-gnus
-(defvar body)
+;; message formats recognized are customizable through `diary-outlook-formats'.
-(defun diary-from-outlook-internal (&optional test-only)
+(defun diary-from-outlook-internal (subject body &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.
+SUBJECT and BODY are strings giving the message subject and body.
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))
+ (dolist (fmt diary-outlook-formats)
+ (when (eq 0 (string-match (car fmt) body))
(unless test-only
- (setq format-string (cdr (nth i diary-outlook-formats)))
+ (setq format-string (cdr fmt))
(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.
(diary-make-entry
(format (replace-match (if (functionp format-string)
(funcall format-string body)
format-string)
t nil (match-string 0 body))
- subject))
- (save-buffer))))
+ subject)))))
(throw 'finished t))))
nil))
@@ -2471,9 +2482,9 @@ automatically."
(save-restriction
(gnus-narrow-to-body)
(buffer-string)))))
- (when (diary-from-outlook-internal t)
+ (when (diary-from-outlook-internal subject body t)
(when (or noconfirm (y-or-n-p "Snarf diary entry? "))
- (diary-from-outlook-internal)
+ (diary-from-outlook-internal subject body)
(message "Diary entry added"))))))
(custom-add-option 'gnus-article-prepare-hook 'diary-from-outlook-gnus)
@@ -2486,15 +2497,17 @@ Unless the optional argument NOCONFIRM is non-nil (which is the case when
this function is called interactively), then if an entry is found the
user is asked to confirm its addition."
(interactive "p")
+ ;; FIXME maybe the body needs rmail-mm decoding, in which case
+ ;; there is no single buffer with both body and subject, sigh.
(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 (diary-from-outlook-internal subject body t)
(when (or noconfirm (y-or-n-p "Snarf diary entry? "))
- (diary-from-outlook-internal)
+ (diary-from-outlook-internal subject body)
(message "Diary entry added"))))))
(defun diary-from-outlook (&optional noconfirm)
@@ -2514,5 +2527,4 @@ user is asked to confirm its addition."
(provide 'diary-lib)
-;; arch-tag: 22dd506e-2e33-410d-9ae1-095a0c1b2010
;;; diary-lib.el ends here
diff --git a/lisp/calendar/holidays.el b/lisp/calendar/holidays.el
index 0cafc85a24b..275c8a5ca29 100644
--- a/lisp/calendar/holidays.el
+++ b/lisp/calendar/holidays.el
@@ -1,11 +1,13 @@
;;; holidays.el --- holiday functions for the calendar package
;; Copyright (C) 1989, 1990, 1992, 1993, 1994, 1997, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: holidays, calendar
+;; Package: calendar
;; This file is part of GNU Emacs.
@@ -42,6 +44,9 @@
;; explicitly load this file.
;;;###autoload
+(define-obsolete-variable-alias 'general-holidays
+ 'holiday-general-holidays "23.1")
+;;;###autoload
(defcustom holiday-general-holidays
(mapcar 'purecopy
'((holiday-fixed 1 1 "New Year's Day")
@@ -67,11 +72,11 @@ See the documentation for `calendar-holidays' for details."
:group 'holidays)
;;;###autoload
(put 'holiday-general-holidays 'risky-local-variable t)
-;;;###autoload
-(define-obsolete-variable-alias 'general-holidays
- 'holiday-general-holidays "23.1")
;;;###autoload
+(define-obsolete-variable-alias 'oriental-holidays
+ 'holiday-oriental-holidays "23.1")
+;;;###autoload
(defcustom holiday-oriental-holidays
(mapcar 'purecopy
'((holiday-chinese-new-year)
@@ -92,11 +97,10 @@ See the documentation for `calendar-holidays' for details."
:group 'holidays)
;;;###autoload
(put 'holiday-oriental-holidays 'risky-local-variable t)
-;;;###autoload
-(define-obsolete-variable-alias 'oriental-holidays
- 'holiday-oriental-holidays "23.1")
;;;###autoload
+(define-obsolete-variable-alias 'local-holidays 'holiday-local-holidays "23.1")
+;;;###autoload
(defcustom holiday-local-holidays nil
"Local holidays.
See the documentation for `calendar-holidays' for details."
@@ -104,10 +108,10 @@ See the documentation for `calendar-holidays' for details."
:group 'holidays)
;;;###autoload
(put 'holiday-local-holidays 'risky-local-variable t)
-;;;###autoload
-(define-obsolete-variable-alias 'local-holidays 'holiday-local-holidays "23.1")
;;;###autoload
+(define-obsolete-variable-alias 'other-holidays 'holiday-other-holidays "23.1")
+;;;###autoload
(defcustom holiday-other-holidays nil
"User defined holidays.
See the documentation for `calendar-holidays' for details."
@@ -115,8 +119,6 @@ See the documentation for `calendar-holidays' for details."
:group 'holidays)
;;;###autoload
(put 'holiday-other-holidays 'risky-local-variable t)
-;;;###autoload
-(define-obsolete-variable-alias 'other-holidays 'holiday-other-holidays "23.1")
;;;###autoload
(defvar hebrew-holidays-1
@@ -218,6 +220,9 @@ See the documentation for `calendar-holidays' for details."
(make-obsolete-variable 'hebrew-holidays-4 'hebrew-holidays "23.1")
;;;###autoload
+(define-obsolete-variable-alias 'hebrew-holidays
+ 'holiday-hebrew-holidays "23.1")
+;;;###autoload
(defcustom holiday-hebrew-holidays
(mapcar 'purecopy
'((holiday-hebrew-passover)
@@ -234,11 +239,11 @@ See the documentation for `calendar-holidays' for details."
:group 'holidays)
;;;###autoload
(put 'holiday-hebrew-holidays 'risky-local-variable t)
-;;;###autoload
-(define-obsolete-variable-alias 'hebrew-holidays
- 'holiday-hebrew-holidays "23.1")
;;;###autoload
+(define-obsolete-variable-alias 'christian-holidays
+ 'holiday-christian-holidays "23.1")
+;;;###autoload
(defcustom holiday-christian-holidays
(mapcar 'purecopy
'((holiday-easter-etc) ; respects calendar-christian-all-holidays-flag
@@ -256,11 +261,11 @@ See the documentation for `calendar-holidays' for details."
:group 'holidays)
;;;###autoload
(put 'holiday-christian-holidays 'risky-local-variable t)
-;;;###autoload
-(define-obsolete-variable-alias 'christian-holidays
- 'holiday-christian-holidays "23.1")
;;;###autoload
+(define-obsolete-variable-alias 'islamic-holidays
+ 'holiday-islamic-holidays "23.1")
+;;;###autoload
(defcustom holiday-islamic-holidays
(mapcar 'purecopy
'((holiday-islamic-new-year)
@@ -280,11 +285,10 @@ See the documentation for `calendar-holidays' for details."
:group 'holidays)
;;;###autoload
(put 'holiday-islamic-holidays 'risky-local-variable t)
-;;;###autoload
-(define-obsolete-variable-alias 'islamic-holidays
- 'holiday-islamic-holidays "23.1")
;;;###autoload
+(define-obsolete-variable-alias 'bahai-holidays 'holiday-bahai-holidays "23.1")
+;;;###autoload
(defcustom holiday-bahai-holidays
(mapcar 'purecopy
'((holiday-bahai-new-year)
@@ -304,10 +308,10 @@ See the documentation for `calendar-holidays' for details."
:group 'holidays)
;;;###autoload
(put 'holiday-bahai-holidays 'risky-local-variable t)
-;;;###autoload
-(define-obsolete-variable-alias 'bahai-holidays 'holiday-bahai-holidays "23.1")
;;;###autoload
+(define-obsolete-variable-alias 'solar-holidays 'holiday-solar-holidays "23.1")
+;;;###autoload
(defcustom holiday-solar-holidays
(mapcar 'purecopy
'((solar-equinoxes-solstices)
@@ -327,8 +331,6 @@ See the documentation for `calendar-holidays' for details."
:group 'holidays)
;;;###autoload
(put 'holiday-solar-holidays 'risky-local-variable t)
-;;;###autoload
-(define-obsolete-variable-alias 'solar-holidays 'holiday-solar-holidays "23.1")
;; This one should not be autoloaded, else .emacs changes of
;; holiday-general-holidays etc have no effect.
@@ -918,5 +920,4 @@ is non-nil)."
(provide 'holidays)
-;; arch-tag: 48eb3117-75a7-4dbe-8fd9-873c3cbb0d37
;;; holidays.el ends here
diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el
index a07402aa031..0be138906b6 100644
--- a/lisp/calendar/icalendar.el
+++ b/lisp/calendar/icalendar.el
@@ -7,6 +7,7 @@
;; Created: August 2002
;; Keywords: calendar
;; Human-Keywords: calendar, diary, iCalendar, vCalendar
+;; Version: 0.19
;; This file is part of GNU Emacs.
@@ -212,15 +213,15 @@ if nil they are ignored."
(defcustom icalendar-uid-format
"emacs%t%c"
- "Format of unique ID code (UID) for each iCalendar object.
-The following specifiers are available:
+ "Format of unique ID code (UID) for each iCalendar object.
+The following specifiers are available:
%c COUNTER, an integer value that is increased each time a uid is
- generated. This may be necessary for systems which do not
+ generated. This may be necessary for systems which do not
provide time-resolution finer than a second.
%h HASH, a hash value of the diary entry,
%s DTSTART, the start date (excluding time) of the diary entry,
%t TIMESTAMP, a unique creation timestamp,
-%u USERNAME, the user-login-name.
+%u USERNAME, the variable `user-login-name'.
For example, a value of \"%s_%h@mydomain.com\" will generate a
UID code for each entry composed of the time of the event, a hash
@@ -427,7 +428,7 @@ children."
(goto-char (point-min))
(while
(re-search-forward
- "\\([A-Za-z0-9-]+\\)=\\(\\([^;,:]+\\)\\|\"\\([^\"]+\\)\"\\);?"
+ "\\([A-Za-z0-9-]+\\)=\\(\\([^;:]+\\)\\|\"\\([^\"]+\\)\"\\);?"
nil t)
(setq param-name (intern (match-string 1)))
(setq param-value (match-string 2))
@@ -744,6 +745,20 @@ Note that this silently ignores seconds."
;; Error:
-1))
+(defun icalendar--get-weekday-numbers (abbrevweekdays)
+ "Return the list of numbers for the comma-separated ABBREVWEEKDAYS."
+ (when abbrevweekdays
+ (let* ((num -1)
+ (weekday-alist (mapcar (lambda (day)
+ (progn
+ (setq num (1+ num))
+ (cons (downcase day) num)))
+ icalendar--weekday-array)))
+ (delq nil
+ (mapcar (lambda (abbrevday)
+ (cdr (assoc abbrevday weekday-alist)))
+ (split-string (downcase abbrevweekdays) ","))))))
+
(defun icalendar--get-weekday-abbrev (weekday)
"Return the abbreviated WEEKDAY."
(catch 'found
@@ -912,21 +927,21 @@ current iCalendar object, as a string. Increase
`icalendar--uid-count'. Returns the UID string."
(let ((uid icalendar-uid-format))
- (setq uid (replace-regexp-in-string
- "%c"
+ (setq uid (replace-regexp-in-string
+ "%c"
(format "%d" icalendar--uid-count)
uid t t))
(setq icalendar--uid-count (1+ icalendar--uid-count))
- (setq uid (replace-regexp-in-string
+ (setq uid (replace-regexp-in-string
"%t"
(format "%d%d%d" (car (current-time))
(cadr (current-time))
- (car (cddr (current-time))))
+ (car (cddr (current-time))))
uid t t))
- (setq uid (replace-regexp-in-string
- "%h"
+ (setq uid (replace-regexp-in-string
+ "%h"
(format "%d" (abs (sxhash entry-full))) uid t t))
- (setq uid (replace-regexp-in-string
+ (setq uid (replace-regexp-in-string
"%u" (or user-login-name "UNKNOWN_USER") uid t t))
(let ((dtstart (if (string-match "^DTSTART[^:]*:\\([0-9]*\\)" contents)
(substring contents (match-beginning 1) (match-end 1))
@@ -1008,7 +1023,7 @@ FExport diary data into iCalendar file: ")
(if url
(setq contents (concat contents "\nURL:" url))))
- (setq header (concat "\nBEGIN:VEVENT\nUID:"
+ (setq header (concat "\nBEGIN:VEVENT\nUID:"
(icalendar--create-uid entry-full contents)))
(setq result (concat result header contents "\nEND:VEVENT")))
;; handle errors
@@ -1126,7 +1141,7 @@ Returns an alist."
(list "%u"
(concat "\\(" icalendar-import-format-url "\\)??"))))
;; Need the \' regexp in order to detect multi-line items
- (setq s (concat "\\`"
+ (setq s (concat "\\`"
(icalendar--rris "%s" "\\(.*?\\)" s nil t)
"\\'"))
(if (string-match s summary-and-rest)
@@ -2057,39 +2072,48 @@ END-T is the event's end time in diary format."
))
)
(cond ((string-equal frequency "WEEKLY")
- (if (not start-t)
- (progn
- ;; weekly and all-day
- (icalendar--dmsg "weekly all-day")
- (if until
- (setq result
- (format
- (concat "%%%%(and "
- "(diary-cyclic %d %s) "
- "(diary-block %s %s))")
- (* interval 7)
- dtstart-conv
- dtstart-conv
- (if count until-1-conv until-conv)
- ))
- (setq result
- (format "%%%%(and (diary-cyclic %d %s))"
- (* interval 7)
- dtstart-conv))))
- ;; weekly and not all-day
- (let* ((byday (cadr (assoc 'BYDAY rrule-props)))
- (weekday
- (icalendar--get-weekday-number byday)))
+ (let* ((byday (cadr (assoc 'BYDAY rrule-props)))
+ (weekdays
+ (icalendar--get-weekday-numbers byday))
+ (weekday-clause
+ (when (> (length weekdays) 1)
+ (format "(memq (calendar-day-of-week date) '%s) "
+ weekdays))))
+ (if (not start-t)
+ (progn
+ ;; weekly and all-day
+ (icalendar--dmsg "weekly all-day")
+ (if until
+ (setq result
+ (format
+ (concat "%%%%(and "
+ "%s"
+ "(diary-block %s %s))")
+ (or weekday-clause
+ (format "(diary-cyclic %d %s) "
+ (* interval 7)
+ dtstart-conv))
+ dtstart-conv
+ (if count until-1-conv until-conv)
+ ))
+ (setq result
+ (format "%%%%(and %s(diary-cyclic %d %s))"
+ (or weekday-clause "")
+ (if weekday-clause 1 (* interval 7))
+ dtstart-conv))))
+ ;; weekly and not all-day
(icalendar--dmsg "weekly not-all-day")
(if until
(setq result
(format
(concat "%%%%(and "
- "(diary-cyclic %d %s) "
+ "%s"
"(diary-block %s %s)) "
"%s%s%s")
- (* interval 7)
- dtstart-conv
+ (or weekday-clause
+ (format "(diary-cyclic %d %s) "
+ (* interval 7)
+ dtstart-conv))
dtstart-conv
until-conv
(or start-t "")
@@ -2100,10 +2124,11 @@ END-T is the event's end time in diary format."
;; DTEND;VALUE=DATE-TIME:20030919T113000
(setq result
(format
- "%%%%(and (diary-cyclic %s %s)) %s%s%s"
- (* interval 7)
- dtstart-conv
- (or start-t "")
+ "%%%%(and %s(diary-cyclic %d %s)) %s%s%s"
+ (or weekday-clause "")
+ (if weekday-clause 1 (* interval 7))
+ dtstart-conv
+ (or start-t "")
(if end-t "-" "") (or end-t "")))))))
;; yearly
((string-equal frequency "YEARLY")
diff --git a/lisp/calendar/lunar.el b/lisp/calendar/lunar.el
index 37a68888854..58111a036d1 100644
--- a/lisp/calendar/lunar.el
+++ b/lisp/calendar/lunar.el
@@ -7,6 +7,7 @@
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: moon, lunar phases, calendar, diary
+;; Package: calendar
;; This file is part of GNU Emacs.
diff --git a/lisp/calendar/parse-time.el b/lisp/calendar/parse-time.el
index fd62d909f36..71e32b9db4c 100644
--- a/lisp/calendar/parse-time.el
+++ b/lisp/calendar/parse-time.el
@@ -220,5 +220,4 @@ unknown are returned as nil."
(provide 'parse-time)
-;; arch-tag: 07066094-45a8-4c68-b307-86195e2c1103
;;; parse-time.el ends here
diff --git a/lisp/calendar/solar.el b/lisp/calendar/solar.el
index 8116597ad02..b7a728461f0 100644
--- a/lisp/calendar/solar.el
+++ b/lisp/calendar/solar.el
@@ -8,6 +8,7 @@
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: sunrise, sunset, equinox, solstice, calendar, diary, holidays
+;; Package: calendar
;; This file is part of GNU Emacs.
diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el
index 914d2d33928..1bd04d7ed3b 100644
--- a/lisp/calendar/time-date.el
+++ b/lisp/calendar/time-date.el
@@ -39,9 +39,6 @@
;;; Code:
-;; Only necessary for `declare' when compiling Gnus with Emacs 21.
-(eval-when-compile (require 'cl))
-
(defmacro with-decoded-time-value (varlist &rest body)
"Decode a time value and bind it according to VARLIST, then eval BODY.
@@ -97,45 +94,42 @@ and type 2 is the list (HIGH LOW MICRO)."
(autoload 'timezone-make-date-arpa-standard "timezone")
;;;###autoload
+;; `parse-time-string' isn't sufficiently general or robust. It fails
+;; to grok some of the formats that timezone does (e.g. dodgy
+;; post-2000 stuff from some Elms) and either fails or returns bogus
+;; values. timezone-make-date-arpa-standard should help.
(defun date-to-time (date)
"Parse a string DATE that represents a date-time and return a time value.
If DATE lacks timezone information, GMT is assumed."
(condition-case ()
- (apply 'encode-time
- (parse-time-string
- ;; `parse-time-string' isn't sufficiently general or
- ;; robust. It fails to grok some of the formats that
- ;; timezone does (e.g. dodgy post-2000 stuff from some
- ;; Elms) and either fails or returns bogus values. Lars
- ;; reverted this change, but that loses non-trivially
- ;; often for me. -- fx
- (timezone-make-date-arpa-standard date)))
- (error (error "Invalid date: %s" date))))
+ (apply 'encode-time (parse-time-string date))
+ (error (condition-case ()
+ (apply 'encode-time
+ (parse-time-string
+ (timezone-make-date-arpa-standard date)))
+ (error (error "Invalid date: %s" date))))))
;; Bit of a mess. Emacs has float-time since at least 21.1.
;; This file is synced to Gnus, and XEmacs packages may have been written
;; using time-to-seconds from the Gnus library.
-;;;###autoload(if (and (fboundp 'float-time)
-;;;###autoload (subrp (symbol-function 'float-time)))
+;;;###autoload(if (or (featurep 'emacs)
+;;;###autoload (and (fboundp 'float-time)
+;;;###autoload (subrp (symbol-function 'float-time))))
;;;###autoload (progn
;;;###autoload (defalias 'time-to-seconds 'float-time)
;;;###autoload (make-obsolete 'time-to-seconds 'float-time "21.1"))
;;;###autoload (autoload 'time-to-seconds "time-date"))
-(eval-and-compile
- (unless (and (fboundp 'float-time)
- (subrp (symbol-function 'float-time)))
- (defun time-to-seconds (time)
- "Convert time value TIME to a floating point number."
- (with-decoded-time-value ((high low micro time))
- (+ (* 1.0 high 65536)
- low
- (/ micro 1000000.0))))))
-
(eval-when-compile
- (unless (fboundp 'with-no-warnings)
- (defmacro with-no-warnings (&rest body)
- `(progn ,@body))))
+ (or (featurep 'emacs)
+ (and (fboundp 'float-time)
+ (subrp (symbol-function 'float-time)))
+ (defun time-to-seconds (time)
+ "Convert time value TIME to a floating point number."
+ (with-decoded-time-value ((high low micro time))
+ (+ (* 1.0 high 65536)
+ low
+ (/ micro 1000000.0))))))
;;;###autoload
(defun seconds-to-time (seconds)
@@ -146,7 +140,7 @@ If DATE lacks timezone information, GMT is assumed."
;;;###autoload
(defun time-less-p (t1 t2)
- "Say whether time value T1 is less than time value T2."
+ "Return non-nil if time value T1 is earlier than time value T2."
(with-decoded-time-value ((high1 low1 micro1 t1)
(high2 low2 micro2 t2))
(or (< high1 high2)
@@ -259,17 +253,15 @@ The Gregorian date Sunday, December 31, 1bce is imaginary."
(- (/ (1- year) 100)) ; - century years
(/ (1- year) 400)))) ; + Gregorian leap years
-(eval-and-compile
- (if (and (fboundp 'float-time)
- (subrp (symbol-function 'float-time)))
- (defun time-to-number-of-days (time)
- "Return the number of days represented by TIME.
-The number of days will be returned as a floating point number."
- (/ (float-time time) (* 60 60 24)))
- (defun time-to-number-of-days (time)
- "Return the number of days represented by TIME.
-The number of days will be returned as a floating point number."
- (/ (with-no-warnings (time-to-seconds time)) (* 60 60 24)))))
+(defun time-to-number-of-days (time)
+ "Return the number of days represented by TIME.
+Returns a floating point number."
+ (/ (funcall (eval-when-compile
+ (if (or (featurep 'emacs)
+ (and (fboundp 'float-time)
+ (subrp (symbol-function 'float-time))))
+ 'float-time
+ 'time-to-seconds)) time) (* 60 60 24)))
;;;###autoload
(defun safe-date-to-time (date)
@@ -317,10 +309,10 @@ This function does not work for SECONDS greater than `most-positive-fixnum'."
(setq start (match-end 0)
spec (match-string 1 string))
(unless (string-equal spec "%")
- ;; `assoc-string' is not available in Emacs 21. So when compiling
- ;; Gnus (`time-date.el' is part of Gnus) with Emacs 21, we get a
- ;; warning here. But `format-seconds' is not used anywhere in Gnus so
- ;; it's not a real problem. --rsteib
+ ;; `assoc-string' is not available in XEmacs. So when compiling
+ ;; Gnus (`time-date.el' is part of Gnus) with XEmacs, we get
+ ;; a warning here. But `format-seconds' is not used anywhere in
+ ;; Gnus so it's not a real problem. --rsteib
(or (setq match (assoc-string spec units t))
(error "Bad format specifier: `%s'" spec))
(if (assoc-string spec usedunits t)
@@ -364,5 +356,4 @@ This function does not work for SECONDS greater than `most-positive-fixnum'."
(provide 'time-date)
-;; arch-tag: addcf07b-b20a-465b-af72-550b8ac5190f
;;; time-date.el ends here
diff --git a/lisp/calendar/timeclock.el b/lisp/calendar/timeclock.el
index 32e0bf61380..d28b0a56c3f 100644
--- a/lisp/calendar/timeclock.el
+++ b/lisp/calendar/timeclock.el
@@ -543,11 +543,8 @@ non-nil, the amount returned will be relative to past time worked."
(message "%s" string)
string)))
-(defsubst timeclock-time-to-seconds (time)
- "Convert TIME to a floating point number."
- (+ (* (car time) 65536.0)
- (cadr time)
- (/ (or (nth 2 time) 0) 1000000.0)))
+(defalias 'timeclock-time-to-seconds (if (fboundp 'float-time) 'float-time
+ 'time-to-seconds))
(defsubst timeclock-seconds-to-time (seconds)
"Convert SECONDS (a floating point number) to an Emacs time structure."
@@ -1419,5 +1416,4 @@ HTML-P is non-nil, HTML markup is added."
(if (file-readable-p timeclock-file)
(timeclock-reread-log))
-;; arch-tag: a0be3377-deb6-44ec-b9a2-a7be28436a40
;;; timeclock.el ends here
diff --git a/lisp/calendar/todo-mode.el b/lisp/calendar/todo-mode.el
index 6e8aac171c1..8fd41163eaf 100644
--- a/lisp/calendar/todo-mode.el
+++ b/lisp/calendar/todo-mode.el
@@ -918,17 +918,9 @@ If INCLUDE-SEP is non-nil, return point after the separator."
;; As calendar reads .todo-do before todo-mode is loaded.
;;;###autoload
-(defun todo-mode ()
- "Major mode for editing TODO lists.
-
-\\{todo-mode-map}"
- (interactive)
- (kill-all-local-variables)
- (setq major-mode 'todo-mode)
- (setq mode-name "TODO")
- (use-local-map todo-mode-map)
- (easy-menu-add todo-menu)
- (run-mode-hooks 'todo-mode-hook))
+(define-derived-mode todo-mode nil "TODO"
+ "Major mode for editing TODO lists."
+ (easy-menu-add todo-menu))
(defvar date)
(defvar entry)
diff --git a/lisp/case-table.el b/lisp/case-table.el
index 53d30bf2819..1e5974d7d1a 100644
--- a/lisp/case-table.el
+++ b/lisp/case-table.el
@@ -6,6 +6,7 @@
;; Author: Howard Gayle
;; Maintainer: FSF
;; Keywords: i18n
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/cedet/ChangeLog b/lisp/cedet/ChangeLog
index a483d3b70c8..efe7e4d4255 100644
--- a/lisp/cedet/ChangeLog
+++ b/lisp/cedet/ChangeLog
@@ -1,4 +1,45 @@
-2010-10-29 Glenn Morris <rgm@gnu.org>
+2010-11-12 Glenn Morris <rgm@gnu.org>
+
+ * semantic/wisent/comp.el: Remove unnecessary eval-when-compiles.
+
+2010-11-10 Glenn Morris <rgm@gnu.org>
+
+ * semantic/bovine/c.el: Test system-type with memq.
+
+2010-11-09 Glenn Morris <rgm@gnu.org>
+
+ * semantic/lex.el (semantic-lex-ignore-comments, semantic-flex):
+ * semantic/grammar.el (semantic-grammar-epilogue):
+ * ede/speedbar.el (ede-find-nearest-file-line):
+ * ede/pmake.el (ede-proj-makefile-insert-dist-rules):
+ * ede/autoconf-edit.el (autoconf-delete-parameter):
+ Use point-at-bol and point-at-eol.
+
+2010-11-07 Glenn Morris <rgm@gnu.org>
+
+ * ede/proj-elisp.el (ede-proj-flush-autoconf): Use point-at-bol.
+
+2010-11-01 Glenn Morris <rgm@gnu.org>
+
+ * semantic/bovine/c.el (semantic-analyze-split-name): Move before use.
+
+ * semantic/symref/cscope.el (ede-toplevel):
+ * semantic/symref.el (ede-toplevel):
+ * semantic/tag-file.el (ede-toplevel):
+ * ede.el (ede-toplevel): Fix declarations.
+
+2010-10-31 Glenn Morris <rgm@gnu.org>
+
+ * ede/proj-elisp.el (project-compile-target): Fix previous change.
+ * semantic/ede-grammar.el (project-compile-target): Fix previous change.
+
+2010-10-31 Julien Danjou <julien@danjou.info>
+
+ * ede/proj-elisp.el (project-compile-target):
+ * semantic/ede-grammar.el (project-compile-target):
+ Use `byte-recompile-file'.
+
+2010-10-31 Glenn Morris <rgm@gnu.org>
* mode-local.el (mode-local-augment-function-help):
* semantic/analyze/debug.el (semantic-analyzer-debug-add-buttons):
@@ -6,12 +47,6 @@
(semantic-symref-rb-toggle-expand-tag): Replace inappropriate uses
of toggle-read-only.
-2010-10-12 Juanma Barranquero <lekktu@gmail.com>
-
- * semantic/symref/list.el (semantic-symref-list-rename-open-hits):
- Fix typo in message.
- (semantic-symref-list-map-open-hits): Fix typo in docstring.
-
2010-09-30 Chong Yidong <cyd@stupidchicken.com>
* semantic/bovine/el.el:
@@ -25,8 +60,8 @@
* semantic/db-typecache.el (semanticdb-typecache-find-default):
* semantic/imenu.el (semantic-create-imenu-index):
* semantic/grammar.el (semantic--grammar-macro-function-tag):
- * semantic/fw.el (semanticdb-without-unloaded-file-searches):
- Fix require. Suggested by David Engster.
+ * semantic/fw.el (semanticdb-without-unloaded-file-searches): Fix
+ require. Suggested by David Engster.
* semantic/bovine/c-by.el: Regenerate.
@@ -49,6 +84,14 @@
* ede/simple.el (ede-project-class-files):
* ede/cpp-root.el (ede-project-class-files): Fix require name.
+2010-09-25 Juanma Barranquero <lekktu@gmail.com>
+
+ * semantic/lex.el (semantic-ignore-comments): Doc fix.
+
+ * semantic/symref/list.el (semantic-symref-list-rename-open-hits):
+ Fix typo in error message.
+ (semantic-symref-list-map-open-hits): Fix typo in docstring.
+
2010-09-21 Eric Ludlam <zappo@gnu.org>
Synch SRecode to CEDET 1.0.
@@ -437,7 +480,85 @@
* ede/cpp-root.el (ede-set-project-variables): Fix feature name
(bug#6231).
-2010-04-18 Chong Yidong <cyd@stupidchicken.com>
+2010-05-02 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Use a mode-line spec rather than a static string in Semantic.
+ * semantic/util-modes.el:
+ (semantic-minor-modes-format): New var to replace...
+ (semantic-minor-modes-status): Remove.
+ (semantic-mode-line-update): Construct a mode-line spec rather than
+ a static string so that mouse buttons can be used on individual minor
+ modes and so that semantic-mode-line-update only needs to be called
+ when global settings are changed.
+ (semantic-add-minor-mode, semantic-toggle-minor-mode-globally):
+ Call semantic-mode-line-update.
+ (semantic-toggle-minor-mode-globally): Don't assume mode is on
+ minor-mode-alist, check semantic-minor-mode-alist as well.
+ (semantic-stickyfunc-mode, semantic-show-parser-state-auto-marker)
+ (semantic-show-parser-state-marker, semantic-show-parser-state-mode)
+ (semantic-show-unmatched-syntax-mode, semantic-highlight-edits-mode):
+ * semantic/mru-bookmark.el (semantic-mru-bookmark-mode):
+ * semantic/idle.el (semantic-idle-scheduler-mode)
+ (define-semantic-idle-service, semantic-idle-summary-mode):
+ * semantic/decorate/mode.el (semantic-decoration-mode):
+ Don't call semantic-mode-line-update any more.
+
+2010-05-02 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Use define-minor-mode in CEDET where applicable.
+
+ * srecode/mode.el (srecode-minor-mode,global-srecode-minor-mode):
+ Use define-minor-mode.
+
+ * semantic/util-modes.el (semantic-add-minor-mode):
+ Remove unused arg `keymap' and code redundant with define-minor-mode.
+ (semantic-toggle-minor-mode-globally): Only handle arg -1 and 1.
+ (semantic-stickyfunc-mode, global-semantic-show-unmatched-syntax-mode)
+ (semantic-highlight-func-mode, global-semantic-show-parser-state-mode)
+ (global-semantic-highlight-edits-mode, semantic-highlight-edits-mode)
+ (semantic-show-unmatched-syntax-mode, semantic-show-parser-state-mode)
+ (global-semantic-stickyfunc-mode, global-semantic-highlight-func-mode):
+ Use define-minor-mode.
+ (semantic-stickyfunc-mode-setup, semantic-highlight-edits-mode-setup)
+ (semantic-show-unmatched-syntax-mode-setup)
+ (semantic-show-parser-state-mode-setup)
+ (semantic-highlight-func-mode-setup): Inline into sole caller.
+
+ * semantic/mru-bookmark.el (global-semantic-mru-bookmark-mode)
+ (semantic-mru-bookmark-mode): Use define-minor-mode.
+ (semantic-mru-bookmark-mode-setup): Inline into sole caller.
+
+ * semantic/idle.el (define-semantic-idle-service):
+ Use define-minor-mode and inline setup function into its sole caller.
+ (semantic-idle-scheduler-mode-setup)
+ (semantic-idle-summary-mode-setup): Inline into sole caller.
+ (global-semantic-idle-scheduler-mode, semantic-idle-scheduler-mode):
+ Use define-minor-mode.
+
+ * semantic/decorate/mode.el (global-semantic-decoration-mode)
+ (semantic-decoration-mode): Use define-minor-mode.
+ (semantic-decoration-mode-setup): Inline into sole caller.
+
+ * ede/dired.el (ede-dired-minor-mode): Initialize in declaration.
+ (ede-dired-minor-mode): Use define-minor-mode and derived-mode-p.
+ (ede-dired-add-to-target): Use dolist.
+
+2010-04-29 Chong Yidong <cyd@stupidchicken.com>
+
+ * semantic.el (semantic-completion-at-point-function):
+ New function.
+ (semantic-mode): Use semantic-completion-at-point-function for
+ completion-at-point-functions instead.
+
+2010-04-28 Chong Yidong <cyd@stupidchicken.com>
+
+ * semantic.el (semantic-mode): When enabled, add
+ semantic-ia-complete-symbol to completion-at-point-functions.
+
+ * semantic/ia.el (semantic-ia-complete-symbol): Return nil
+ if Semantic is not active.
+
+2010-04-19 Chong Yidong <cyd@stupidchicken.com>
* ede/pmake.el (ede-proj-makefile-insert-variables):
Don't destroy list before using it.
@@ -452,6 +573,13 @@
* srecode/table.el (srecode-template-table): Fix docstring typo.
+2010-03-24 Glenn Morris <rgm@gnu.org>
+
+ * semantic/bovine/c.el (semantic-c-describe-environment):
+ Consistently check ede-object is bound throughout.
+
+ * ede/project-am.el (ede-shell-run-something): Declare.
+
2010-03-13 Eric M. Ludlam <zappo@gnu.org>
* semantic/imenu.el: New file, from the CEDET repository
@@ -469,6 +597,11 @@
* ede/make.el (ede-make-check-version): Use
with-current-buffer instead of save-excursion.
+2010-02-24 Eduard Wiebe <usenet@pusto.de>
+
+ * semantic/wisent/javascript.el (wisent-javascript-jv-expand-tag):
+ Avoid c(ad)ddr and use c(ad)r of cddr (Bug#5640).
+
2010-02-16 Chong Yidong <cyd@stupidchicken.com>
* data-debug.el (data-debug): Move to extensions group.
@@ -843,8 +976,8 @@
* semantic/tag.el (semantic--tag-link-list-to-buffer):
Use mapc rather than mapcar because the return value is never used.
- * srecode/template.el, cedet/semantic/wisent/javascript.el:
- * semantic/wisent/java-tags.el, cedet/semantic/texi.el:
+ * srecode/template.el, semantic/wisent/javascript.el:
+ * semantic/wisent/java-tags.el, semantic/texi.el:
* semantic/html.el:
Suppress harmless warnings about setting up semantic-imenu (not
part of Emacs) variables.
@@ -998,10 +1131,6 @@
* semantic/idle.el (semantic-idle-tag-highlight):
Use semantic-idle-summary-highlight-face as the highlighting.
- * emacs-lisp/eieio-base.el (eieio-persistent-save): If buffer
- contains multibyte characters, choose first applicable coding
- system automatically.
-
* ede/project-am.el (project-run-target): New method.
(project-run-target): New method.
@@ -1329,10 +1458,6 @@
* srecode/expandproto.el: Fix provide statement.
-2009-09-30 Eric Ludlam <zappo@gnu.org>
-
- * emacs-lisp/eieio.el (boolean-p): Delete.
-
2009-09-30 Sascha Wilde <wilde@sha-bang.de>
* ede/srecode.el: Fix provide statement.
@@ -1378,15 +1503,6 @@
2009-09-28 Eric Ludlam <zappo@gnu.org>
- * emacs-lisp/chart.el:
- * emacs-lisp/eieio-base.el:
- * emacs-lisp/eieio-comp.el:
- * emacs-lisp/eieio-custom.el:
- * emacs-lisp/eieio-datadebug.el:
- * emacs-lisp/eieio-opt.el:
- * emacs-lisp/eieio-speedbar.el:
- * emacs-lisp/eieio.el: New files.
-
* cedet-cscope.el:
* cedet-files.el:
* cedet-global.el:
diff --git a/lisp/cedet/cedet-cscope.el b/lisp/cedet/cedet-cscope.el
index 33bbc612d79..211c7fb4b01 100644
--- a/lisp/cedet/cedet-cscope.el
+++ b/lisp/cedet/cedet-cscope.el
@@ -3,6 +3,7 @@
;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
+;; Package: cedet
;; This file is part of GNU Emacs.
diff --git a/lisp/cedet/cedet-files.el b/lisp/cedet/cedet-files.el
index 9dacf062288..bb7137ddad2 100644
--- a/lisp/cedet/cedet-files.el
+++ b/lisp/cedet/cedet-files.el
@@ -3,6 +3,7 @@
;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
+;; Package: cedet
;; This file is part of GNU Emacs.
diff --git a/lisp/cedet/cedet-global.el b/lisp/cedet/cedet-global.el
index cedd1dd1162..da4e618a749 100644
--- a/lisp/cedet/cedet-global.el
+++ b/lisp/cedet/cedet-global.el
@@ -3,6 +3,7 @@
;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <eric@siege-engine.com>
+;; Package: cedet
;; This file is part of GNU Emacs.
diff --git a/lisp/cedet/cedet-idutils.el b/lisp/cedet/cedet-idutils.el
index 7abf3c3320b..627a458b657 100644
--- a/lisp/cedet/cedet-idutils.el
+++ b/lisp/cedet/cedet-idutils.el
@@ -5,6 +5,7 @@
;; Author: Eric M. Ludlam <eric@siege-engine.com>
;; Version: 0.2
;; Keywords: OO, lisp
+;; Package: cedet
;; This file is part of GNU Emacs.
diff --git a/lisp/cedet/cedet.el b/lisp/cedet/cedet.el
index 26452f20c17..80a092ab9ea 100644
--- a/lisp/cedet/cedet.el
+++ b/lisp/cedet/cedet.el
@@ -5,7 +5,7 @@
;; Author: David Ponce <david@dponce.com>
;; Maintainer: Eric M. Ludlam <zappo@gnu.org>
-;; Version: 0.2
+;; Version: 1.0pre7
;; Keywords: OO, lisp
;; This file is part of GNU Emacs.
diff --git a/lisp/cedet/data-debug.el b/lisp/cedet/data-debug.el
index ed8441d2df0..f48de002fe3 100644
--- a/lisp/cedet/data-debug.el
+++ b/lisp/cedet/data-debug.el
@@ -5,6 +5,7 @@
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 0.2
;; Keywords: OO, lisp
+;; Package: cedet
;; This file is part of GNU Emacs.
diff --git a/lisp/cedet/ede.el b/lisp/cedet/ede.el
index 43212b626e7..849cc05019e 100644
--- a/lisp/cedet/ede.el
+++ b/lisp/cedet/ede.el
@@ -1,10 +1,11 @@
;;; ede.el --- Emacs Development Environment gloss
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make
+;; Version: 1.0pre7
;; This file is part of GNU Emacs.
@@ -55,7 +56,7 @@
(declare-function ede-directory-project-p "ede/files")
(declare-function ede-find-subproject-for-directory "ede/files")
(declare-function ede-project-directory-remove-hash "ede/files")
-(declare-function ede-toplevel "ede/files")
+(declare-function ede-toplevel "ede/base")
(declare-function ede-toplevel-project "ede/files")
(declare-function ede-up-directory "ede/files")
(declare-function semantic-lex-make-spp-table "semantic/lex-spp")
@@ -1277,5 +1278,4 @@ is the project to use, instead of `ede-current-project'."
(ede-speedbar-file-setup)
(add-hook 'speedbar-load-hook 'ede-speedbar-file-setup))
-;; arch-tag: 0e1e0eba-484f-4119-abdb-30951f725705
;;; ede.el ends here
diff --git a/lisp/cedet/ede/autoconf-edit.el b/lisp/cedet/ede/autoconf-edit.el
index df976bf17af..7f96699a07e 100644
--- a/lisp/cedet/ede/autoconf-edit.el
+++ b/lisp/cedet/ede/autoconf-edit.el
@@ -1,6 +1,7 @@
;;; ede/autoconf-edit.el --- Keymap for autoconf
-;; Copyright (C) 1998, 1999, 2000, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 1999, 2000, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project
@@ -381,9 +382,7 @@ INDEX starts at 1."
(down-list 1)
(re-search-forward ", ?" nil nil (1- index))
(let ((end (save-excursion
- (re-search-forward ",\\|)" (save-excursion
- (end-of-line)
- (point)))
+ (re-search-forward ",\\|)" (point-at-eol))
(forward-char -1)
(point))))
(setq autoconf-deleted-text (buffer-substring (point) end))
@@ -417,5 +416,4 @@ to Makefiles, or other files using Autoconf substitution."
(provide 'ede/autoconf-edit)
-;; arch-tag: 5932c433-4fd4-4d5e-ab35-8effd95a405f
;;; ede/autoconf-edit.el ends here
diff --git a/lisp/cedet/ede/dired.el b/lisp/cedet/ede/dired.el
index b6c5ca7c721..59644a03ec8 100644
--- a/lisp/cedet/ede/dired.el
+++ b/lisp/cedet/ede/dired.el
@@ -27,57 +27,46 @@
;; This provides a dired interface to EDE, allowing users to modify
;; their project file by adding files (or whatever) directly from a
;; dired buffer.
-
+(eval-when-compile (require 'cl))
(require 'easymenu)
(require 'dired)
(require 'ede)
;;; Code:
-(defvar ede-dired-minor-mode nil
- "Non-nil when in ede dired minor mode.")
-(make-variable-buffer-local 'ede-dired-minor-mode)
-
-(defvar ede-dired-keymap nil
+(defvar ede-dired-keymap
+ (let ((map (make-sparse-keymap)))
+ (define-key map ".a" 'ede-dired-add-to-target)
+ (define-key map ".t" 'ede-new-target)
+ (define-key map ".s" 'ede-speedbar)
+ (define-key map ".C" 'ede-compile-project)
+ (define-key map ".d" 'ede-make-dist)
+
+ (easy-menu-define
+ ede-dired-menu map "EDE Dired Minor Mode Menu"
+ '("Project"
+ [ "Add files to target" ede-dired-add-to-target (ede-current-project) ]
+ ( "Build" :filter ede-build-forms-menu)
+ "-"
+ [ "Create Project" ede-new (not (ede-current-project)) ]
+ [ "Create Target" ede-new-target (ede-current-project) ]
+ "-"
+ ( "Customize Project" :filter ede-customize-forms-menu )
+ [ "View Project Tree" ede-speedbar (ede-current-project) ]
+ ))
+ map)
"Keymap used for ede dired minor mode.")
-(if ede-dired-keymap
- nil
- (setq ede-dired-keymap (make-sparse-keymap))
- (define-key ede-dired-keymap ".a" 'ede-dired-add-to-target)
- (define-key ede-dired-keymap ".t" 'ede-new-target)
- (define-key ede-dired-keymap ".s" 'ede-speedbar)
- (define-key ede-dired-keymap ".C" 'ede-compile-project)
- (define-key ede-dired-keymap ".d" 'ede-make-dist)
-
- (easy-menu-define
- ede-dired-menu ede-dired-keymap "EDE Dired Minor Mode Menu"
- '("Project"
- [ "Add files to target" ede-dired-add-to-target (ede-current-project) ]
- ( "Build" :filter ede-build-forms-menu)
- "-"
- [ "Create Project" ede-new (not (ede-current-project)) ]
- [ "Create Target" ede-new-target (ede-current-project) ]
- "-"
- ( "Customize Project" :filter ede-customize-forms-menu )
- [ "View Project Tree" ede-speedbar (ede-current-project) ]
- ))
- )
-
-(defun ede-dired-minor-mode (&optional arg)
+(define-minor-mode ede-dired-minor-mode
"A minor mode that should only be activated in DIRED buffers.
-If ARG is nil, toggle, if it is a positive number, force on, if
+If ARG is nil or a positive number, force on, if
negative, force off."
- (interactive "P")
- (if (not (or (eq major-mode 'dired-mode)
- (eq major-mode 'vc-dired-mode)))
- (error "Not in DIRED mode"))
- (setq ede-dired-minor-mode
- (not (or (and (null arg) ede-dired-minor-mode)
- (<= (prefix-numeric-value arg) 0))))
- (if (and (not (ede-directory-project-p default-directory))
- (not (interactive-p)))
- (setq ede-dired-minor-mode nil))
- )
+ :lighter " EDE" :keymap ede-dired-keymap
+ (unless (derived-mode-p 'dired-mode)
+ (setq ede-dired-minor-mode nil)
+ (error "Not in DIRED mode"))
+ (unless (or (ede-directory-project-p default-directory)
+ (interactive-p))
+ (setq ede-dired-minor-mode nil)))
(defun ede-dired-add-to-target (target)
"Add a file, or all marked files into a TARGET."
@@ -85,24 +74,13 @@ negative, force off."
(let ((ede-object (ede-current-project)))
(ede-invoke-method 'project-interactive-select-target
"Add files to Target: "))))
- (let ((files (dired-get-marked-files t)))
- (while files
- (project-add-file target (car files))
- ;; Find the buffer for this files, and set its ede-object
- (if (get-file-buffer (car files))
- (with-current-buffer (get-file-buffer (car files))
- (setq ede-object nil)
- (setq ede-object (ede-buffer-object (current-buffer)))))
- ;; Increment.
- (setq files (cdr files)))))
-
-;; Minor mode management.
-(add-to-list 'minor-mode-alist '(ede-dired-minor-mode " EDE"))
-(let ((a (assoc 'ede-dired-minor-mode minor-mode-map-alist)))
- (if a
- (setcdr a ede-dired-keymap)
- (add-to-list 'minor-mode-map-alist (cons 'ede-dired-minor-mode
- ede-dired-keymap))))
+ (dolist (file (dired-get-marked-files t))
+ (project-add-file target file)
+ ;; Find the buffer for this files, and set its ede-object
+ (if (get-file-buffer file)
+ (with-current-buffer (get-file-buffer file)
+ (setq ede-object nil)
+ (setq ede-object (ede-buffer-object (current-buffer)))))))
(provide 'ede/dired)
diff --git a/lisp/cedet/ede/pmake.el b/lisp/cedet/ede/pmake.el
index 94874d031b7..b8e7c5f61a6 100644
--- a/lisp/cedet/ede/pmake.el
+++ b/lisp/cedet/ede/pmake.el
@@ -1,7 +1,7 @@
;;; ede-pmake.el --- EDE Generic Project Makefile code generator.
-;;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make
@@ -565,10 +565,7 @@ Argument THIS is the target that should insert stuff."
(cond ((eq (cdr sv) 'share)
;; This variable may be shared between multiple targets.
(if (re-search-backward (concat "\\$(" (car sv) ")")
- (save-excursion
- (beginning-of-line)
- (point))
- t)
+ (point-at-bol) t)
;; If its already in the dist target, then skip it.
nil
(setq sv (car sv))))
@@ -693,5 +690,4 @@ Argument TARGETS are the targets we should depend on for TAGS."
(provide 'ede/pmake)
-;; arch-tag: 7ad8e19f-cdee-484c-8caf-f15cb0fc4df2
;;; ede/pmake.el ends here
diff --git a/lisp/cedet/ede/proj-elisp.el b/lisp/cedet/ede/proj-elisp.el
index 879f36ff4e2..744f345fcf8 100644
--- a/lisp/cedet/ede/proj-elisp.el
+++ b/lisp/cedet/ede/proj-elisp.el
@@ -1,7 +1,7 @@
;;; ede-proj-elisp.el --- EDE Generic Project Emacs Lisp support
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make
@@ -129,18 +129,13 @@ Bonus: Return a cons cell: (COMPILED . UPTODATE)."
(utd 0))
(mapc (lambda (src)
(let* ((fsrc (expand-file-name src dir))
- (elc (concat (file-name-sans-extension fsrc) ".elc"))
- )
- (if (or (not (file-exists-p elc))
- (file-newer-than-file-p fsrc elc))
- (progn
- (setq comp (1+ comp))
- (byte-compile-file fsrc))
+ (elc (concat (file-name-sans-extension fsrc) ".elc")))
+ (if (eq (byte-recompile-file fsrc nil 0) t)
+ (setq comp (1+ comp))
(setq utd (1+ utd)))))
(oref obj source))
(message "All Emacs Lisp sources are up to date in %s" (object-name obj))
- (cons comp utd)
- ))
+ (cons comp utd)))
(defmethod ede-update-version-in-source ((this ede-proj-target-elisp) version)
"In a Lisp file, updated a version string for THIS to VERSION.
@@ -250,10 +245,7 @@ is found, such as a `-version' variable, or the standard header."
(let ((path (match-string 1)))
(if (string= path "nil")
nil
- (delete-region (save-excursion (beginning-of-line) (point))
- (save-excursion (end-of-line)
- (forward-char 1)
- (point))))))))))
+ (delete-region (point-at-bol) (point-at-bol 2)))))))))
;;;
;; Autoload generators
@@ -390,5 +382,4 @@ Argument THIS is the target which needs to insert an info file."
(provide 'ede/proj-elisp)
-;; arch-tag: 3802c94b-d04d-4ecf-9bab-b29ed6e77588
;;; ede/proj-elisp.el ends here
diff --git a/lisp/cedet/ede/project-am.el b/lisp/cedet/ede/project-am.el
index a76ea7138a8..ccfb1a242b4 100644
--- a/lisp/cedet/ede/project-am.el
+++ b/lisp/cedet/ede/project-am.el
@@ -401,6 +401,8 @@ Argument COMMAND is the command to use for compiling the target."
(funcall project-am-debug-target-function cmd))
(kill-buffer tb))))
+(declare-function ede-shell-run-something "ede/shell")
+
(defmethod project-run-target ((obj project-am-objectcode))
"Run the current project target in comint buffer."
(require 'ede/shell)
diff --git a/lisp/cedet/ede/speedbar.el b/lisp/cedet/ede/speedbar.el
index 466705175ed..8658a654b16 100644
--- a/lisp/cedet/ede/speedbar.el
+++ b/lisp/cedet/ede/speedbar.el
@@ -1,7 +1,7 @@
;;; ede/speedbar.el --- Speedbar viewing of EDE projects
-;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2005, 2007, 2008, 2009, 2010
-;;; Free Software Foundation, Inc.
+;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2005, 2007, 2008,
+;; 2009, 2010 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make, tags
@@ -176,10 +176,7 @@ Argument DIR is the directory from which to derive the list of objects."
(beginning-of-line)
(looking-at "^\\([0-9]+\\):")
(let ((depth (string-to-number (match-string 1))))
- (while (not (re-search-forward "[]] [^ ]"
- (save-excursion (end-of-line)
- (point))
- t))
+ (while (not (re-search-forward "[]] [^ ]" (point-at-eol) t))
(re-search-backward (format "^%d:" (1- depth)))
(setq depth (1- depth)))
(speedbar-line-token))))
@@ -358,5 +355,4 @@ INDENT is the current indentation level."
;; generated-autoload-load-name: "ede/speedbar"
;; End:
-;; arch-tag: 56721fc9-8eb5-4115-8511-18cf8397ec87
;;; ede/speedbar.el ends here
diff --git a/lisp/cedet/semantic/bovine/c.el b/lisp/cedet/semantic/bovine/c.el
index 011be1cb006..1b441a27d2b 100644
--- a/lisp/cedet/semantic/bovine/c.el
+++ b/lisp/cedet/semantic/bovine/c.el
@@ -94,8 +94,8 @@ NOTE: In process of obsoleting this."
;; Compiler options need to show up after path setup, but before
;; the preprocessor section.
-(when (member system-type '(gnu gnu/linux darwin cygwin))
- (semantic-gcc-setup))
+(if (memq system-type '(gnu gnu/linux darwin cygwin))
+ (semantic-gcc-setup))
;;; Pre-processor maps
;;
@@ -1002,6 +1002,13 @@ if something is a constructor. Value should be:
where typename is the name of the type, and typeoftype is \"class\"
or \"struct\".")
+(define-mode-local-override semantic-analyze-split-name c-mode (name)
+ "Split up tag names on colon (:) boundaries."
+ (let ((ans (split-string name ":")))
+ (if (= (length ans) 1)
+ name
+ (delete "" ans))))
+
(defun semantic-c-reconstitute-token (tokenpart declmods typedecl)
"Reconstitute a token TOKENPART with DECLMODS and TYPEDECL.
This is so we don't have to match the same starting text several times.
@@ -1559,13 +1566,6 @@ These are constants which are of type TYPE."
(string= (semantic-tag-type type) "enum"))
(semantic-tag-type-members type)))
-(define-mode-local-override semantic-analyze-split-name c-mode (name)
- "Split up tag names on colon (:) boundaries."
- (let ((ans (split-string name ":")))
- (if (= (length ans) 1)
- name
- (delete "" ans))))
-
(define-mode-local-override semantic-analyze-unsplit-name c-mode (namelist)
"Assemble the list of names NAMELIST into a namespace name."
(mapconcat 'identity namelist "::"))
@@ -1840,8 +1840,9 @@ For types with a :parent, create faux namespaces to put TAG into."
ede-object
(arrayp semantic-lex-spp-project-macro-symbol-obarray))
(princ "\n Project symbol map:\n")
- (princ " Your project symbol map is derived from the EDE object:\n ")
- (princ (object-print ede-object))
+ (when (and (boundp 'ede-object) ede-object)
+ (princ " Your project symbol map is derived from the EDE object:\n ")
+ (princ (object-print ede-object)))
(princ "\n\n")
(let ((macros nil))
(mapatoms
@@ -1870,5 +1871,4 @@ For types with a :parent, create faux namespaces to put TAG into."
;; generated-autoload-load-name: "semantic/bovine/c"
;; End:
-;; arch-tag: 263951a8-0f18-445d-8e73-eb8f9ac8e2a3
;;; semantic/bovine/c.el ends here
diff --git a/lisp/cedet/semantic/decorate/mode.el b/lisp/cedet/semantic/decorate/mode.el
index c5dee1676b6..3c7549c6d0c 100644
--- a/lisp/cedet/semantic/decorate/mode.el
+++ b/lisp/cedet/semantic/decorate/mode.el
@@ -224,46 +224,34 @@ Flush functions from `semantic-decorate-pending-decoration-hook'."
;; Generic mode for handling basic highlighting and decorations.
;;
-(defcustom global-semantic-decoration-mode nil
- "*If non-nil, enable global use of command `semantic-decoration-mode'.
-When this mode is activated, decorations specified by
-`semantic-decoration-styles'."
- :group 'semantic
- :group 'semantic-modes
- :type 'boolean
- :require 'semantic/decorate/mode
- :initialize 'custom-initialize-default
- :set (lambda (sym val)
- (global-semantic-decoration-mode (if val 1 -1))))
-
;;;###autoload
-(defun global-semantic-decoration-mode (&optional arg)
+(define-minor-mode global-semantic-decoration-mode
"Toggle global use of option `semantic-decoration-mode'.
Decoration mode turns on all active decorations as specified
-by `semantic-decoration-styles'.
-If ARG is positive, enable, if it is negative, disable.
-If ARG is nil, then toggle."
- (interactive "P")
- (setq global-semantic-decoration-mode
- (semantic-toggle-minor-mode-globally
- 'semantic-decoration-mode arg)))
+by `semantic-decoration-styles'."
+ :global t :group 'semantic :group 'semantic-modes
+ ;; Not needed because it's autoloaded instead.
+ ;; :require 'semantic/decorate/mode
+ (semantic-toggle-minor-mode-globally
+ 'semantic-decoration-mode (if global-semantic-decoration-mode 1 -1)))
(defcustom semantic-decoration-mode-hook nil
"Hook run at the end of function `semantic-decoration-mode'."
:group 'semantic
:type 'hook)
-;;;;###autoload
-(defvar semantic-decoration-mode nil
- "Non-nil if command `semantic-decoration-mode' is enabled.
-Use the command `semantic-decoration-mode' to change this variable.")
-(make-variable-buffer-local 'semantic-decoration-mode)
-
-(defun semantic-decoration-mode-setup ()
- "Setup the `semantic-decoration-mode' minor mode.
-The minor mode can be turned on only if the semantic feature is available
-and the current buffer was set up for parsing. Return non-nil if the
+(define-minor-mode semantic-decoration-mode
+ "Minor mode for decorating tags.
+Decorations are specified in `semantic-decoration-styles'.
+You can define new decoration styles with
+`define-semantic-decoration-style'.
+With prefix argument ARG, turn on if positive, otherwise off. The
+minor mode can be turned on only if semantic feature is available and
+the current buffer was set up for parsing. Return non-nil if the
minor mode is enabled."
+;;
+;;\\{semantic-decoration-map}"
+ nil nil nil
(if semantic-decoration-mode
(if (not (and (featurep 'semantic) (semantic-active-p)))
(progn
@@ -280,8 +268,7 @@ minor mode is enabled."
'semantic-decorate-tags-after-full-reparse nil t)
;; Add decorations to available tags. The above hooks ensure
;; that new tags will be decorated when they become available.
- (semantic-decorate-add-decorations (semantic-fetch-available-tags))
- )
+ (semantic-decorate-add-decorations (semantic-fetch-available-tags)))
;; Remove decorations from available tags.
(semantic-decorate-clear-decorations (semantic-fetch-available-tags))
;; Cleanup any leftover crap too.
@@ -290,41 +277,10 @@ minor mode is enabled."
(remove-hook 'semantic-after-partial-cache-change-hook
'semantic-decorate-tags-after-partial-reparse t)
(remove-hook 'semantic-after-toplevel-cache-change-hook
- 'semantic-decorate-tags-after-full-reparse t)
- )
- semantic-decoration-mode)
-
-(defun semantic-decoration-mode (&optional arg)
- "Minor mode for decorating tags.
-Decorations are specified in `semantic-decoration-styles'.
-You can define new decoration styles with
-`define-semantic-decoration-style'.
-With prefix argument ARG, turn on if positive, otherwise off. The
-minor mode can be turned on only if semantic feature is available and
-the current buffer was set up for parsing. Return non-nil if the
-minor mode is enabled."
-;;
-;;\\{semantic-decoration-map}"
- (interactive
- (list (or current-prefix-arg
- (if semantic-decoration-mode 0 1))))
- (setq semantic-decoration-mode
- (if arg
- (>
- (prefix-numeric-value arg)
- 0)
- (not semantic-decoration-mode)))
- (semantic-decoration-mode-setup)
- (run-hooks 'semantic-decoration-mode-hook)
- (if (called-interactively-p 'interactive)
- (message "decoration-mode minor mode %sabled"
- (if semantic-decoration-mode "en" "dis")))
- (semantic-mode-line-update)
- semantic-decoration-mode)
+ 'semantic-decorate-tags-after-full-reparse t)))
(semantic-add-minor-mode 'semantic-decoration-mode
- ""
- nil)
+ "")
(defun semantic-decorate-tags-after-full-reparse (tag-list)
"Add decorations after a complete reparse of the current buffer.
diff --git a/lisp/cedet/semantic/ede-grammar.el b/lisp/cedet/semantic/ede-grammar.el
index 184e23c9505..90c72990ca9 100644
--- a/lisp/cedet/semantic/ede-grammar.el
+++ b/lisp/cedet/semantic/ede-grammar.el
@@ -1,6 +1,7 @@
;;; semantic/ede-grammar.el --- EDE support for Semantic Grammar Files
-;;; Copyright (C) 2003, 2004, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2004, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: project, make
@@ -133,11 +134,8 @@ Lays claim to all -by.el, and -wy.el files."
(save-excursion
(semantic-grammar-create-package))
(save-buffer)
- (let ((cf (concat (semantic-grammar-package) ".el")))
- (if (or (not (file-exists-p cf))
- (file-newer-than-file-p src cf))
- (byte-compile-file cf)))))
- (oref obj source)))
+ (byte-recompile-file (concat (semantic-grammar-package) ".el") nil 0)))
+ (oref obj source)))
(message "All Semantic Grammar sources are up to date in %s" (object-name obj)))
;;; Makefile generation functions
@@ -197,5 +195,4 @@ Argument THIS is the target that should insert stuff."
(provide 'semantic/ede-grammar)
-;; arch-tag: 37a06a8d-957a-4fa2-a931-38482d28c24a
;;; semantic/ede-grammar.el ends here
diff --git a/lisp/cedet/semantic/grammar.el b/lisp/cedet/semantic/grammar.el
index d99ae0cb0ac..513c211ee75 100644
--- a/lisp/cedet/semantic/grammar.el
+++ b/lisp/cedet/semantic/grammar.el
@@ -248,10 +248,7 @@ That is tag names plus names defined in tag attribute `:rest'."
(skip-chars-backward "\r\n\t")
;; If a grammar footer is found, skip it.
(re-search-backward "^;;;\\s-+\\S-+\\s-+ends here"
- (save-excursion
- (beginning-of-line)
- (point))
- t)
+ (point-at-bol) t)
(skip-chars-backward "\r\n\t")
(point)))
"\n"))
@@ -1897,5 +1894,4 @@ Optional argument COLOR determines if color is added to the text."
(provide 'semantic/grammar)
-;; arch-tag: 12ffc9d5-557d-49af-a5fd-a66a006ddb3e
;;; semantic/grammar.el ends here
diff --git a/lisp/cedet/semantic/idle.el b/lisp/cedet/semantic/idle.el
index 6bafdde7f08..585ad693dc8 100644
--- a/lisp/cedet/semantic/idle.el
+++ b/lisp/cedet/semantic/idle.el
@@ -129,16 +129,6 @@ unlikely the user would be ready to type again right away."
;; The minor mode portion of this code just sets up the minor mode
;; which does the initial scheduling of the idle timers.
;;
-;;;###autoload
-(defcustom global-semantic-idle-scheduler-mode nil
- "*If non-nil, enable global use of idle-scheduler mode."
- :group 'semantic
- :group 'semantic-modes
- :type 'boolean
- :require 'semantic/idle
- :initialize 'custom-initialize-default
- :set (lambda (sym val)
- (global-semantic-idle-scheduler-mode (if val 1 -1))))
(defcustom semantic-idle-scheduler-mode-hook nil
"Hook run at the end of the function `semantic-idle-scheduler-mode'."
@@ -168,24 +158,8 @@ exceeds the `semantic-idle-scheduler-max-buffer-size' threshold."
(or (<= semantic-idle-scheduler-max-buffer-size 0)
(< (buffer-size) semantic-idle-scheduler-max-buffer-size))))
-(defun semantic-idle-scheduler-mode-setup ()
- "Setup option `semantic-idle-scheduler-mode'.
-The minor mode can be turned on only if semantic feature is available
-and the current buffer was set up for parsing. When minor mode is
-enabled parse the current buffer if needed. Return non-nil if the
-minor mode is enabled."
- (if semantic-idle-scheduler-mode
- (if (not (and (featurep 'semantic) (semantic-active-p)))
- (progn
- ;; Disable minor mode if semantic stuff not available
- (setq semantic-idle-scheduler-mode nil)
- (error "Buffer %s was not set up idle time scheduling"
- (buffer-name)))
- (semantic-idle-scheduler-setup-timers)))
- semantic-idle-scheduler-mode)
-
;;;###autoload
-(defun semantic-idle-scheduler-mode (&optional arg)
+(define-minor-mode semantic-idle-scheduler-mode
"Minor mode to auto parse buffer following a change.
When this mode is off, a buffer is only rescanned for tokens when
some command requests the list of available tokens. When idle-scheduler
@@ -196,26 +170,18 @@ With prefix argument ARG, turn on if positive, otherwise off. The
minor mode can be turned on only if semantic feature is available and
the current buffer was set up for parsing. Return non-nil if the
minor mode is enabled."
- (interactive
- (list (or current-prefix-arg
- (if semantic-idle-scheduler-mode 0 1))))
- (setq semantic-idle-scheduler-mode
- (if arg
- (>
- (prefix-numeric-value arg)
- 0)
- (not semantic-idle-scheduler-mode)))
- (semantic-idle-scheduler-mode-setup)
- (run-hooks 'semantic-idle-scheduler-mode-hook)
- (if (called-interactively-p 'interactive)
- (message "idle-scheduler minor mode %sabled"
- (if semantic-idle-scheduler-mode "en" "dis")))
- (semantic-mode-line-update)
- semantic-idle-scheduler-mode)
+ nil nil nil
+ (if semantic-idle-scheduler-mode
+ (if (not (and (featurep 'semantic) (semantic-active-p)))
+ (progn
+ ;; Disable minor mode if semantic stuff not available
+ (setq semantic-idle-scheduler-mode nil)
+ (error "Buffer %s was not set up idle time scheduling"
+ (buffer-name)))
+ (semantic-idle-scheduler-setup-timers))))
(semantic-add-minor-mode 'semantic-idle-scheduler-mode
- "ARP"
- nil)
+ "ARP")
;;; SERVICES services
;;
@@ -592,31 +558,23 @@ This routine creates the following functions and variables:"
(mode (intern (concat (symbol-name name) "-mode")))
(hook (intern (concat (symbol-name name) "-mode-hook")))
(map (intern (concat (symbol-name name) "-mode-map")))
- (setup (intern (concat (symbol-name name) "-mode-setup")))
(func (intern (concat (symbol-name name) "-idle-function"))))
`(eval-and-compile
- (defun ,global (&optional arg)
+ (define-minor-mode ,global
,(concat "Toggle " (symbol-name global) ".
With ARG, turn the minor mode on if ARG is positive, off otherwise.
When this minor mode is enabled, `" (symbol-name mode) "' is
turned on in every Semantic-supported buffer.")
- (interactive "P")
- (setq ,global
- (semantic-toggle-minor-mode-globally
- ',mode arg)))
-
- (defcustom ,global nil
- ,(concat "Non-nil if `" (symbol-name mode) "' is enabled.")
+ :global t
:group 'semantic
:group 'semantic-modes
- :type 'boolean
:require 'semantic/idle
- :initialize 'custom-initialize-default
- :set (lambda (sym val)
- (,global (if val 1 -1))))
+ (semantic-toggle-minor-mode-globally
+ ',mode (if ,global 1 -1)))
+ ;; FIXME: Get rid of this when define-minor-mode does it for us.
(defcustom ,hook nil
,(concat "Hook run at the end of function `" (symbol-name mode) "'.")
:group 'semantic
@@ -627,14 +585,9 @@ turned on in every Semantic-supported buffer.")
km)
,(concat "Keymap for `" (symbol-name mode) "'."))
- (defvar ,mode nil
- ,(concat "Non-nil if the minor mode `" (symbol-name mode) "' is enabled.
-Use the command `" (symbol-name mode) "' to change this variable."))
- (make-variable-buffer-local ',mode)
-
- (defun ,setup ()
- ,(concat "Set up `" (symbol-name mode) "'.
-Return non-nil if the minor mode is enabled.")
+ (define-minor-mode ,mode
+ ,doc
+ :keymap ,map
(if ,mode
(if (not (and (featurep 'semantic) (semantic-active-p)))
(progn
@@ -643,36 +596,12 @@ Return non-nil if the minor mode is enabled.")
(error "Buffer %s was not set up for parsing"
(buffer-name)))
;; Enable the mode mode
- (semantic-idle-scheduler-add #',func)
- )
+ (semantic-idle-scheduler-add #',func))
;; Disable the mode mode
- (semantic-idle-scheduler-remove #',func)
- )
- ,mode)
-
- (defun ,mode (&optional arg)
- ,doc
- (interactive
- (list (or current-prefix-arg
- (if ,mode 0 1))))
- (setq ,mode
- (if arg
- (>
- (prefix-numeric-value arg)
- 0)
- (not ,mode)))
- (,setup)
- (run-hooks ,hook)
- (if (called-interactively-p 'interactive)
- (message "%s %sabled"
- (symbol-name ',mode)
- (if ,mode "en" "dis")))
- (semantic-mode-line-update)
- ,mode)
+ (semantic-idle-scheduler-remove #',func)))
(semantic-add-minor-mode ',mode
- "" ; idle schedulers are quiet?
- ,map)
+ "") ; idle schedulers are quiet?
(defun ,func ()
,(concat "Perform idle activity for the minor mode `"
@@ -832,21 +761,6 @@ When this minor mode is enabled, the echo area displays a summary
of the lexical token at point whenever Emacs is idle."
:group 'semantic
:group 'semantic-modes
- (semantic-idle-summary-mode-setup)
- (semantic-mode-line-update))
-
-(defun semantic-idle-summary-refresh-echo-area ()
- (and semantic-idle-summary-mode
- eldoc-last-message
- (if (and (not executing-kbd-macro)
- (not (and (boundp 'edebug-active) edebug-active))
- (not cursor-in-echo-area)
- (not (eq (selected-window) (minibuffer-window))))
- (eldoc-message eldoc-last-message)
- (setq eldoc-last-message nil))))
-
-(defun semantic-idle-summary-mode-setup ()
- "Set up `semantic-idle-summary-mode'."
(if semantic-idle-summary-mode
;; Enable the mode
(progn
@@ -860,8 +774,17 @@ of the lexical token at point whenever Emacs is idle."
(add-hook 'pre-command-hook 'semantic-idle-summary-refresh-echo-area t))
;; Disable the mode
(semantic-idle-scheduler-remove 'semantic-idle-summary-idle-function)
- (remove-hook 'pre-command-hook 'semantic-idle-summary-refresh-echo-area t))
- semantic-idle-summary-mode)
+ (remove-hook 'pre-command-hook 'semantic-idle-summary-refresh-echo-area t)))
+
+(defun semantic-idle-summary-refresh-echo-area ()
+ (and semantic-idle-summary-mode
+ eldoc-last-message
+ (if (and (not executing-kbd-macro)
+ (not (and (boundp 'edebug-active) edebug-active))
+ (not cursor-in-echo-area)
+ (not (eq (selected-window) (minibuffer-window))))
+ (eldoc-message eldoc-last-message)
+ (setq eldoc-last-message nil))))
(semantic-add-minor-mode 'semantic-idle-summary-mode "")
@@ -977,22 +900,22 @@ Call `semantic-symref-hits-in-region' to identify local references."
;;;###autoload
-(defun global-semantic-idle-scheduler-mode (&optional arg)
+(define-minor-mode global-semantic-idle-scheduler-mode
"Toggle global use of option `semantic-idle-scheduler-mode'.
The idle scheduler will automatically reparse buffers in idle time,
and then schedule other jobs setup with `semantic-idle-scheduler-add'.
-If ARG is positive, enable, if it is negative, disable.
-If ARG is nil, then toggle."
- (interactive "P")
+If ARG is positive or nil, enable, if it is negative, disable."
+ :global t
+ :group 'semantic
+ :group 'semantic-modes
;; When turning off, disable other idle modes.
- (when (or (and (numberp arg) (< arg 0))
- (and (null arg) global-semantic-idle-scheduler-mode))
+ (when (null global-semantic-idle-scheduler-mode)
(global-semantic-idle-summary-mode -1)
(global-semantic-idle-local-symbol-highlight-mode -1)
(global-semantic-idle-completions-mode -1))
- (setq global-semantic-idle-scheduler-mode
- (semantic-toggle-minor-mode-globally
- 'semantic-idle-scheduler-mode arg)))
+ (semantic-toggle-minor-mode-globally
+ 'semantic-idle-scheduler-mode
+ (if global-semantic-idle-scheduler-mode 1 -1)))
;;; Completion Popup Mode
diff --git a/lisp/cedet/semantic/lex.el b/lisp/cedet/semantic/lex.el
index af312494a81..34663727a0b 100644
--- a/lisp/cedet/semantic/lex.el
+++ b/lisp/cedet/semantic/lex.el
@@ -1427,10 +1427,7 @@ Return either a paren token or a semantic list token depending on
;; to work properly. Lets try and move over
;; whatever white space we matched to begin
;; with.
- (skip-syntax-forward "-.'"
- (save-excursion
- (end-of-line)
- (point)))
+ (skip-syntax-forward "-.'" (point-at-eol))
;; We may need to back up so newlines or whitespace is generated.
(if (bolp)
(backward-char 1)))
@@ -1810,8 +1807,8 @@ what syntax class CHAR has.")
(defvar semantic-ignore-comments t
"Default comment handling.
-t means to strip comments when flexing. Nil means to keep comments
-as part of the token stream.")
+The value t means to strip comments when flexing; nil means
+to keep comments as part of the token stream.")
(make-variable-buffer-local 'semantic-ignore-comments)
(defvar semantic-flex-enable-newlines nil
@@ -1997,10 +1994,7 @@ return LENGTH tokens."
;; to work properly. Lets try and move over
;; whatever white space we matched to begin
;; with.
- (skip-syntax-forward "-.'"
- (save-excursion
- (end-of-line)
- (point)))
+ (skip-syntax-forward "-.'" (point-at-eol))
;;(forward-comment 1)
;; Generate newline token if enabled
(if (and semantic-flex-enable-newlines
@@ -2049,5 +2043,4 @@ return LENGTH tokens."
;; generated-autoload-load-name: "semantic/lex"
;; End:
-;; arch-tag: a47664fc-48d9-4b36-921f-cab0ea8cdf92
;;; semantic/lex.el ends here
diff --git a/lisp/cedet/semantic/mru-bookmark.el b/lisp/cedet/semantic/mru-bookmark.el
index 2a6ac8f9b10..b723a848c10 100644
--- a/lisp/cedet/semantic/mru-bookmark.el
+++ b/lisp/cedet/semantic/mru-bookmark.el
@@ -252,14 +252,14 @@ been edited, and you can re-visit them with \\[semantic-mrub-switch-tags]."
(global-semantic-mru-bookmark-mode (if val 1 -1))))
;;;###autoload
-(defun global-semantic-mru-bookmark-mode (&optional arg)
+(define-minor-mode global-semantic-mru-bookmark-mode
"Toggle global use of option `semantic-mru-bookmark-mode'.
-If ARG is positive, enable, if it is negative, disable.
-If ARG is nil, then toggle."
- (interactive "P")
- (setq global-semantic-mru-bookmark-mode
- (semantic-toggle-minor-mode-globally
- 'semantic-mru-bookmark-mode arg)))
+If ARG is positive or nil, enable, if it is negative, disable."
+ :global t :group 'semantic :group 'semantic-modes
+ ;; Not needed because it's autoloaded instead.
+ ;; :require 'semantic-util-modes
+ (semantic-toggle-minor-mode-globally
+ 'semantic-mru-bookmark-mode (if global-semantic-mru-bookmark-mode 1 -1)))
(defcustom semantic-mru-bookmark-mode-hook nil
"*Hook run at the end of function `semantic-mru-bookmark-mode'."
@@ -272,17 +272,18 @@ If ARG is nil, then toggle."
km)
"Keymap for mru-bookmark minor mode.")
-(defvar semantic-mru-bookmark-mode nil
- "Non-nil if mru-bookmark minor mode is enabled.
-Use the command `semantic-mru-bookmark-mode' to change this variable.")
-(make-variable-buffer-local 'semantic-mru-bookmark-mode)
+(define-minor-mode semantic-mru-bookmark-mode
+ "Minor mode for tracking tag-based bookmarks automatically.
+When this mode is enabled, Emacs keeps track of which tags have
+been edited, and you can re-visit them with \\[semantic-mrub-switch-tags].
-(defun semantic-mru-bookmark-mode-setup ()
- "Setup option `semantic-mru-bookmark-mode'.
-The minor mode can be turned on only if semantic feature is available
-and the current buffer was set up for parsing. When minor mode is
-enabled parse the current buffer if needed. Return non-nil if the
+\\{semantic-mru-bookmark-mode-map}
+
+With prefix argument ARG, turn on if positive, otherwise off. The
+minor mode can be turned on only if semantic feature is available and
+the current buffer was set up for parsing. Return non-nil if the
minor mode is enabled."
+ :keymap semantic-mru-bookmark-mode-map
(if semantic-mru-bookmark-mode
(if (not (and (featurep 'semantic) (semantic-active-p)))
(progn
@@ -294,47 +295,15 @@ minor mode is enabled."
(add-hook 'semantic-edits-new-change-hooks
'semantic-mru-bookmark-change-hook-fcn nil t)
(add-hook 'semantic-edits-move-change-hooks
- 'semantic-mru-bookmark-change-hook-fcn nil t)
- )
+ 'semantic-mru-bookmark-change-hook-fcn nil t))
;; Remove hooks
(remove-hook 'semantic-edits-new-change-hooks
'semantic-mru-bookmark-change-hook-fcn t)
(remove-hook 'semantic-edits-move-change-hooks
- 'semantic-mru-bookmark-change-hook-fcn t)
- )
- semantic-mru-bookmark-mode)
-
-(defun semantic-mru-bookmark-mode (&optional arg)
- "Minor mode for tracking tag-based bookmarks automatically.
-When this mode is enabled, Emacs keeps track of which tags have
-been edited, and you can re-visit them with \\[semantic-mrub-switch-tags].
-
-\\{semantic-mru-bookmark-mode-map}
-
-With prefix argument ARG, turn on if positive, otherwise off. The
-minor mode can be turned on only if semantic feature is available and
-the current buffer was set up for parsing. Return non-nil if the
-minor mode is enabled."
- (interactive
- (list (or current-prefix-arg
- (if semantic-mru-bookmark-mode 0 1))))
- (setq semantic-mru-bookmark-mode
- (if arg
- (>
- (prefix-numeric-value arg)
- 0)
- (not semantic-mru-bookmark-mode)))
- (semantic-mru-bookmark-mode-setup)
- (run-hooks 'semantic-mru-bookmark-mode-hook)
- (if (called-interactively-p 'interactive)
- (message "mru-bookmark minor mode %sabled"
- (if semantic-mru-bookmark-mode "en" "dis")))
- (semantic-mode-line-update)
- semantic-mru-bookmark-mode)
+ 'semantic-mru-bookmark-change-hook-fcn t)))
(semantic-add-minor-mode 'semantic-mru-bookmark-mode
- "k"
- semantic-mru-bookmark-mode-map)
+ "k")
;;; COMPLETING READ
;;
diff --git a/lisp/cedet/semantic/symref.el b/lisp/cedet/semantic/symref.el
index d36beffc95f..667efede9ad 100644
--- a/lisp/cedet/semantic/symref.el
+++ b/lisp/cedet/semantic/symref.el
@@ -69,7 +69,7 @@
(defvar ede-minor-mode)
(declare-function data-debug-new-buffer "data-debug")
(declare-function data-debug-insert-object-slots "eieio-datadebug")
-(declare-function ede-toplevel "ede/files")
+(declare-function ede-toplevel "ede/base")
(declare-function ede-project-root-directory "ede/files")
(declare-function ede-up-directory "ede/files")
@@ -508,5 +508,4 @@ over until it returns nil."
;; generated-autoload-load-name: "semantic/symref"
;; End:
-;; arch-tag: 928394b7-19ef-4f76-8cb3-37e9a9891984
;;; semantic/symref.el ends here
diff --git a/lisp/cedet/semantic/symref/cscope.el b/lisp/cedet/semantic/symref/cscope.el
index 5847c786147..606570961bf 100644
--- a/lisp/cedet/semantic/symref/cscope.el
+++ b/lisp/cedet/semantic/symref/cscope.el
@@ -27,7 +27,7 @@
(require 'semantic/symref)
(defvar ede-minor-mode)
-(declare-function ede-toplevel "ede/files")
+(declare-function ede-toplevel "ede/base")
(declare-function ede-project-root-directory "ede/files")
;;; Code:
@@ -91,5 +91,4 @@ Moves cursor to end of the match."
;; generated-autoload-load-name: "semantic/symref/cscope"
;; End:
-;; arch-tag: 7c0a4e02-ade4-407a-9df7-4f948bd61a19
;;; semantic/symref/cscope.el ends here
diff --git a/lisp/cedet/semantic/tag-file.el b/lisp/cedet/semantic/tag-file.el
index 56b3a490118..ab08ea52dd6 100644
--- a/lisp/cedet/semantic/tag-file.el
+++ b/lisp/cedet/semantic/tag-file.el
@@ -32,7 +32,7 @@
(declare-function semanticdb-table-child-p "semantic/db" t t)
(declare-function semanticdb-get-buffer "semantic/db")
(declare-function semantic-dependency-find-file-on-path "semantic/dep")
-(declare-function ede-toplevel "ede/files")
+(declare-function ede-toplevel "ede/base")
;;; Code:
@@ -214,5 +214,4 @@ file prototypes belong in."
;; generated-autoload-load-name: "semantic/tag-file"
;; End:
-;; arch-tag: 71d4cf18-c1ec-414c-bb0a-c2ed914c1361
;;; semantic/tag-file.el ends here
diff --git a/lisp/cedet/semantic/util-modes.el b/lisp/cedet/semantic/util-modes.el
index aa0535d380c..ccfdc1c906e 100644
--- a/lisp/cedet/semantic/util-modes.el
+++ b/lisp/cedet/semantic/util-modes.el
@@ -28,6 +28,10 @@
;;
;;; Code:
+
+;; FIXME: compiling util-modes.el seems to require loading util-modes.el,
+;; so if the previous compilation generated a file that fails to load,
+;; recompiling fails to fix the problem.
(require 'semantic)
;;; Group for all semantic enhancing modes
@@ -49,8 +53,7 @@ line."
:set (lambda (sym val)
(set-default sym val)
;; Update status of all Semantic enabled buffers
- (semantic-map-buffers
- #'semantic-mode-line-update)))
+ (semantic-mode-line-update)))
(defcustom semantic-mode-line-prefix
(propertize "S" 'face 'bold)
@@ -60,59 +63,61 @@ line."
:require 'semantic/util-modes
:initialize 'custom-initialize-default)
-(defvar semantic-minor-modes-status nil
- "String showing Semantic minor modes which are locally enabled.
+(defvar semantic-minor-modes-format nil
+ "Mode line format showing Semantic minor modes which are locally enabled.
It is displayed in the mode line.")
-(make-variable-buffer-local 'semantic-minor-modes-status)
+(put 'semantic-minor-modes-format 'risky-local-variable t)
(defvar semantic-minor-mode-alist nil
"Alist saying how to show Semantic minor modes in the mode line.
Like variable `minor-mode-alist'.")
(defun semantic-mode-line-update ()
- "Update display of Semantic minor modes in the mode line.
+ "Update mode line format of Semantic minor modes.
Only minor modes that are locally enabled are shown in the mode line."
- (setq semantic-minor-modes-status nil)
- (if semantic-update-mode-line
- (let ((ml semantic-minor-mode-alist)
- mm ms see)
- (while ml
- (setq mm (car ml)
- ms (cadr mm)
- mm (car mm)
- ml (cdr ml))
- (when (and (symbol-value mm)
- ;; Only show local minor mode status
- (not (memq mm semantic-init-hook)))
- (and ms
- (symbolp ms)
- (setq ms (symbol-value ms)))
- (and (stringp ms)
- (not (member ms see)) ;; Don't duplicate same status
- (setq see (cons ms see)
- ms (if (string-match "^[ ]*\\(.+\\)" ms)
- (match-string 1 ms)))
- (setq semantic-minor-modes-status
- (if semantic-minor-modes-status
- (concat semantic-minor-modes-status "/" ms)
- ms)))))
- (if semantic-minor-modes-status
- (setq semantic-minor-modes-status
- (concat
- " "
- (if (string-match "^[ ]*\\(.+\\)"
- semantic-mode-line-prefix)
- (match-string 1 semantic-mode-line-prefix)
- "S")
- "/"
- semantic-minor-modes-status))))))
+ (setq semantic-minor-modes-format nil)
+ (dolist (x semantic-minor-mode-alist)
+ (setq minor-mode-alist (delq (assq (car x) minor-mode-alist)
+ minor-mode-alist)))
+ (when semantic-update-mode-line
+ (let ((locals '()))
+ ;; Select the minor modes that aren't enabled globally and who
+ ;; have a non-empty "name".
+ (dolist (x semantic-minor-mode-alist)
+ (unless (or (memq (car x) semantic-init-hook)
+ (not (string-match "^[ ]*\\(.+\\)" (cadr x))))
+ (push (list (car x) (concat "/" (match-string 1 (cadr x)))) locals)))
+ ;; Then build the format spec.
+ (when locals
+ (let ((prefix (if (string-match "^[ ]*\\(.+\\)"
+ semantic-mode-line-prefix)
+ (match-string 1 semantic-mode-line-prefix)
+ "S")))
+ (setq semantic-minor-modes-format
+ `((:eval (if (or ,@(mapcar 'car locals))
+ ,(concat " " prefix)))))
+ ;; It would be easier to just put `locals' inside
+ ;; semantic-minor-modes-format, but then things like
+ ;; mode-line-minor-mode-help can't find the right major mode
+ ;; any more. So instead, we carefully put the minor modes
+ ;; in minor-mode-alist.
+ (let* ((elem (or (assq 'semantic-minor-modes-format
+ minor-mode-alist)
+ ;; FIXME: This entry is meaningless for
+ ;; mode-line-minor-mode-help.
+ '(semantic-minor-modes-format
+ semantic-minor-modes-format)))
+ (tail (or (memq elem minor-mode-alist)
+ (setq minor-mode-alist
+ (cons elem minor-mode-alist)))))
+ (setcdr tail (nconc locals (cdr tail)))))))))
(defun semantic-desktop-ignore-this-minor-mode (buffer)
"Installed as a minor-mode initializer for Desktop mode.
BUFFER is the buffer to not initialize a Semantic minor mode in."
nil)
-(defun semantic-add-minor-mode (toggle name &optional keymap)
+(defun semantic-add-minor-mode (toggle name)
"Register a new Semantic minor mode.
TOGGLE is a symbol which is the name of a buffer-local variable that
is toggled on or off to say whether the minor mode is active or not.
@@ -120,98 +125,58 @@ It is also an interactive function to toggle the mode.
NAME specifies what will appear in the mode line when the minor mode
is active. NAME should be either a string starting with a space, or a
-symbol whose value is such a string.
-
-Optional KEYMAP is the keymap for the minor mode that will be added to
-`minor-mode-map-alist'."
- ;; Add a dymmy semantic minor mode to display the status
- (or (assq 'semantic-minor-modes-status minor-mode-alist)
- (setq minor-mode-alist (cons (list 'semantic-minor-modes-status
- 'semantic-minor-modes-status)
- minor-mode-alist)))
- (if (fboundp 'add-minor-mode)
- ;; Emacs 21 & XEmacs
- (add-minor-mode toggle "" keymap)
- ;; Emacs 20
- (or (assq toggle minor-mode-alist)
- (setq minor-mode-alist (cons (list toggle "") minor-mode-alist)))
- (or (not keymap)
- (assq toggle minor-mode-map-alist)
- (setq minor-mode-map-alist (cons (cons toggle keymap)
- minor-mode-map-alist))))
+symbol whose value is such a string."
;; Record how to display this minor mode in the mode line
(let ((mm (assq toggle semantic-minor-mode-alist)))
(if mm
(setcdr mm (list name))
(setq semantic-minor-mode-alist (cons (list toggle name)
semantic-minor-mode-alist))))
+ (semantic-mode-line-update)
;; Semantic minor modes don't work w/ Desktop restore.
;; This line will disable this minor mode from being restored
;; by Desktop.
(when (boundp 'desktop-minor-mode-handlers)
(add-to-list 'desktop-minor-mode-handlers
- (cons toggle 'semantic-desktop-ignore-this-minor-mode)))
- )
+ (cons toggle 'semantic-desktop-ignore-this-minor-mode))))
(defun semantic-toggle-minor-mode-globally (mode &optional arg)
"Toggle minor mode MODE in every Semantic enabled buffer.
Return non-nil if MODE is turned on in every Semantic enabled buffer.
-If ARG is positive, enable, if it is negative, disable. If ARG is
-nil, then toggle. Otherwise do nothing. MODE must be a valid minor
-mode defined in `minor-mode-alist' and must be too an interactive
-function used to toggle the mode."
- (or (and (fboundp mode) (assq mode minor-mode-alist))
+If ARG is positive, enable, if it is negative, disable.
+MODE must be a valid minor mode defined in `minor-mode-alist' and must be
+too an interactive function used to toggle the mode."
+ ;; FIXME: All callers should pass a -1 or +1 argument.
+ (or (and (fboundp mode) (or (assq mode minor-mode-alist) ;Needed?
+ (assq mode semantic-minor-mode-alist)))
(error "Semantic minor mode %s not found" mode))
- (if (not arg)
- (if (memq mode semantic-init-hook)
- (setq arg -1)
- (setq arg 1)))
- ;; Add or remove the MODE toggle function from
- ;; `semantic-init-hook'. Then turn MODE on or off in every
- ;; Semantic enabled buffer.
+ ;; Add or remove the MODE toggle function from `semantic-init-hook'.
(cond
;; Turn off if ARG < 0
- ((< arg 0)
- (remove-hook 'semantic-init-hook mode)
- (semantic-map-buffers #'(lambda () (funcall mode -1)))
- nil)
+ ((< arg 0) (remove-hook 'semantic-init-hook mode))
;; Turn on if ARG > 0
- ((> arg 0)
- (add-hook 'semantic-init-hook mode)
- (semantic-map-buffers #'(lambda () (funcall mode 1)))
- t)
+ ((> arg 0) (add-hook 'semantic-init-hook mode))
;; Otherwise just check MODE state
(t
- (memq mode semantic-init-hook))
- ))
+ (error "semantic-toggle-minor-mode-globally: arg should be -1 or 1")))
+ ;; Update the minor mode format.
+ (semantic-mode-line-update)
+ ;; Then turn MODE on or off in every Semantic enabled buffer.
+ (semantic-map-buffers #'(lambda () (funcall mode arg))))
;;;;
;;;; Minor mode to highlight areas that a user edits.
;;;;
;;;###autoload
-(defun global-semantic-highlight-edits-mode (&optional arg)
+(define-minor-mode global-semantic-highlight-edits-mode
"Toggle global use of option `semantic-highlight-edits-mode'.
-If ARG is positive, enable, if it is negative, disable.
-If ARG is nil, then toggle."
- (interactive "P")
- (setq global-semantic-highlight-edits-mode
- (semantic-toggle-minor-mode-globally
- 'semantic-highlight-edits-mode arg)))
-
-;;;###autoload
-(defcustom global-semantic-highlight-edits-mode nil
- "If non-nil enable global use of variable `semantic-highlight-edits-mode'.
-When this mode is enabled, changes made to a buffer are highlighted
-until the buffer is reparsed."
- :group 'semantic
- :group 'semantic-modes
- :type 'boolean
- :require 'semantic/util-modes
- :initialize 'custom-initialize-default
- :set (lambda (sym val)
- (global-semantic-highlight-edits-mode (if val 1 -1))))
+If ARG is positive or nil, enable, if it is negative, disable."
+ :global t :group 'semantic :group 'semantic-modes
+ (semantic-toggle-minor-mode-globally
+ 'semantic-highlight-edits-mode
+ (if global-semantic-highlight-edits-mode 1 -1)))
(defcustom semantic-highlight-edits-mode-hook nil
"Hook run at the end of function `semantic-highlight-edits-mode'."
@@ -238,17 +203,18 @@ This function will set the face property on this overlay."
km)
"Keymap for highlight-edits minor mode.")
-(defvar semantic-highlight-edits-mode nil
- "Non-nil if highlight-edits minor mode is enabled.
-Use the command `semantic-highlight-edits-mode' to change this variable.")
-(make-variable-buffer-local 'semantic-highlight-edits-mode)
-
-(defun semantic-highlight-edits-mode-setup ()
- "Setup option `semantic-highlight-edits-mode'.
-The minor mode can be turned on only if semantic feature is available
-and the current buffer was set up for parsing. When minor mode is
-enabled parse the current buffer if needed. Return non-nil if the
+;;;###autoload
+(define-minor-mode semantic-highlight-edits-mode
+ "Minor mode for highlighting changes made in a buffer.
+Changes are tracked by semantic so that the incremental parser can work
+properly.
+This mode will highlight those changes as they are made, and clear them
+when the incremental parser accounts for those edits.
+With prefix argument ARG, turn on if positive, otherwise off. The
+minor mode can be turned on only if semantic feature is available and
+the current buffer was set up for parsing. Return non-nil if the
minor mode is enabled."
+ :keymap semantic-highlight-edits-mode-map
(if semantic-highlight-edits-mode
(if (not (and (featurep 'semantic) (semantic-active-p)))
(progn
@@ -258,73 +224,28 @@ minor mode is enabled."
(buffer-name)))
(semantic-make-local-hook 'semantic-edits-new-change-hooks)
(add-hook 'semantic-edits-new-change-hooks
- 'semantic-highlight-edits-new-change-hook-fcn nil t)
- )
+ 'semantic-highlight-edits-new-change-hook-fcn nil t))
;; Remove hooks
(remove-hook 'semantic-edits-new-change-hooks
- 'semantic-highlight-edits-new-change-hook-fcn t)
- )
- semantic-highlight-edits-mode)
-
-;;;###autoload
-(defun semantic-highlight-edits-mode (&optional arg)
- "Minor mode for highlighting changes made in a buffer.
-Changes are tracked by semantic so that the incremental parser can work
-properly.
-This mode will highlight those changes as they are made, and clear them
-when the incremental parser accounts for those edits.
-With prefix argument ARG, turn on if positive, otherwise off. The
-minor mode can be turned on only if semantic feature is available and
-the current buffer was set up for parsing. Return non-nil if the
-minor mode is enabled."
- (interactive
- (list (or current-prefix-arg
- (if semantic-highlight-edits-mode 0 1))))
- (setq semantic-highlight-edits-mode
- (if arg
- (>
- (prefix-numeric-value arg)
- 0)
- (not semantic-highlight-edits-mode)))
- (semantic-highlight-edits-mode-setup)
- (run-hooks 'semantic-highlight-edits-mode-hook)
- (if (called-interactively-p 'interactive)
- (message "highlight-edits minor mode %sabled"
- (if semantic-highlight-edits-mode "en" "dis")))
- (semantic-mode-line-update)
- semantic-highlight-edits-mode)
+ 'semantic-highlight-edits-new-change-hook-fcn t)))
(semantic-add-minor-mode 'semantic-highlight-edits-mode
- "e"
- semantic-highlight-edits-mode-map)
-
+ "e")
;;;;
;;;; Minor mode to show unmatched-syntax elements
;;;;
;;;###autoload
-(defun global-semantic-show-unmatched-syntax-mode (&optional arg)
+(define-minor-mode global-semantic-show-unmatched-syntax-mode
"Toggle global use of option `semantic-show-unmatched-syntax-mode'.
-If ARG is positive, enable, if it is negative, disable.
-If ARG is nil, then toggle."
- (interactive "P")
- (setq global-semantic-show-unmatched-syntax-mode
- (semantic-toggle-minor-mode-globally
- 'semantic-show-unmatched-syntax-mode arg)))
-
-;;;###autoload
-(defcustom global-semantic-show-unmatched-syntax-mode nil
- "If non-nil, enable global use of `semantic-show-unmatched-syntax-mode'.
-When this mode is enabled, syntax in the current buffer which the
-semantic parser cannot match is highlighted with a red underline."
- :group 'semantic
- :group 'semantic-modes
- :type 'boolean
- :require 'semantic/util-modes
- :initialize 'custom-initialize-default
- :set (lambda (sym val)
- (global-semantic-show-unmatched-syntax-mode (if val 1 -1))))
+If ARG is positive or nil, enable, if it is negative, disable."
+ :global t :group 'semantic :group 'semantic-modes
+ ;; Not needed because it's autoloaded instead.
+ ;; :require 'semantic/util-modes
+ (semantic-toggle-minor-mode-globally
+ 'semantic-show-unmatched-syntax-mode
+ (if global-semantic-show-unmatched-syntax-mode 1 -1)))
(defcustom semantic-show-unmatched-syntax-mode-hook nil
"Hook run at the end of function `semantic-show-unmatched-syntax-mode'."
@@ -432,18 +353,21 @@ Do not search past BOUND if non-nil."
km)
"Keymap for command `semantic-show-unmatched-syntax-mode'.")
-(defvar semantic-show-unmatched-syntax-mode nil
- "Non-nil if show-unmatched-syntax minor mode is enabled.
-Use the command `semantic-show-unmatched-syntax-mode' to change this
-variable.")
-(make-variable-buffer-local 'semantic-show-unmatched-syntax-mode)
-
-(defun semantic-show-unmatched-syntax-mode-setup ()
- "Setup the `semantic-show-unmatched-syntax' minor mode.
-The minor mode can be turned on only if semantic feature is available
-and the current buffer was set up for parsing. When minor mode is
-enabled parse the current buffer if needed. Return non-nil if the
-minor mode is enabled."
+;;;###autoload
+(define-minor-mode semantic-show-unmatched-syntax-mode
+ "Minor mode to highlight unmatched lexical syntax tokens.
+When a parser executes, some elements in the buffer may not match any
+parser rules. These text characters are considered unmatched syntax.
+Often time, the display of unmatched syntax can expose coding
+problems before the compiler is run.
+
+With prefix argument ARG, turn on if positive, otherwise off. The
+minor mode can be turned on only if semantic feature is available and
+the current buffer was set up for parsing. Return non-nil if the
+minor mode is enabled.
+
+\\{semantic-show-unmatched-syntax-mode-map}"
+ :keymap semantic-show-unmatched-syntax-mode-map
(if semantic-show-unmatched-syntax-mode
(if (not (and (featurep 'semantic) (semantic-active-p)))
(progn
@@ -468,43 +392,10 @@ minor mode is enabled."
(remove-hook 'semantic-pre-clean-token-hooks
'semantic-clean-token-of-unmatched-syntax t)
;; Cleanup unmatched-syntax highlighting
- (semantic-clean-unmatched-syntax-in-buffer))
- semantic-show-unmatched-syntax-mode)
-
-;;;###autoload
-(defun semantic-show-unmatched-syntax-mode (&optional arg)
- "Minor mode to highlight unmatched lexical syntax tokens.
-When a parser executes, some elements in the buffer may not match any
-parser rules. These text characters are considered unmatched syntax.
-Often time, the display of unmatched syntax can expose coding
-problems before the compiler is run.
-
-With prefix argument ARG, turn on if positive, otherwise off. The
-minor mode can be turned on only if semantic feature is available and
-the current buffer was set up for parsing. Return non-nil if the
-minor mode is enabled.
-
-\\{semantic-show-unmatched-syntax-mode-map}"
- (interactive
- (list (or current-prefix-arg
- (if semantic-show-unmatched-syntax-mode 0 1))))
- (setq semantic-show-unmatched-syntax-mode
- (if arg
- (>
- (prefix-numeric-value arg)
- 0)
- (not semantic-show-unmatched-syntax-mode)))
- (semantic-show-unmatched-syntax-mode-setup)
- (run-hooks 'semantic-show-unmatched-syntax-mode-hook)
- (if (called-interactively-p 'interactive)
- (message "show-unmatched-syntax minor mode %sabled"
- (if semantic-show-unmatched-syntax-mode "en" "dis")))
- (semantic-mode-line-update)
- semantic-show-unmatched-syntax-mode)
+ (semantic-clean-unmatched-syntax-in-buffer)))
(semantic-add-minor-mode 'semantic-show-unmatched-syntax-mode
- "u"
- semantic-show-unmatched-syntax-mode-map)
+ "u")
(defun semantic-show-unmatched-syntax-next ()
"Move forward to the next occurrence of unmatched syntax."
@@ -519,27 +410,15 @@ minor mode is enabled.
;;;;
;;;###autoload
-(defcustom global-semantic-show-parser-state-mode nil
- "If non-nil enable global use of `semantic-show-parser-state-mode'.
-When enabled, the current parse state of the current buffer is displayed
-in the mode line. See `semantic-show-parser-state-marker' for details
-on what is displayed."
- :group 'semantic
- :type 'boolean
- :require 'semantic/util-modes
- :initialize 'custom-initialize-default
- :set (lambda (sym val)
- (global-semantic-show-parser-state-mode (if val 1 -1))))
-
-;;;###autoload
-(defun global-semantic-show-parser-state-mode (&optional arg)
+(define-minor-mode global-semantic-show-parser-state-mode
"Toggle global use of option `semantic-show-parser-state-mode'.
-If ARG is positive, enable, if it is negative, disable.
-If ARG is nil, then toggle."
- (interactive "P")
- (setq global-semantic-show-parser-state-mode
- (semantic-toggle-minor-mode-globally
- 'semantic-show-parser-state-mode arg)))
+If ARG is positive or nil, enable, if it is negative, disable."
+ :global t :group 'semantic
+ ;; Not needed because it's autoloaded instead.
+ ;; :require 'semantic/util-modes
+ (semantic-toggle-minor-mode-globally
+ 'semantic-show-parser-state-mode
+ (if global-semantic-show-parser-state-mode 1 -1)))
(defcustom semantic-show-parser-state-mode-hook nil
"Hook run at the end of function `semantic-show-parser-state-mode'."
@@ -551,17 +430,22 @@ If ARG is nil, then toggle."
km)
"Keymap for show-parser-state minor mode.")
-(defvar semantic-show-parser-state-mode nil
- "Non-nil if show-parser-state minor mode is enabled.
-Use the command `semantic-show-parser-state-mode' to change this variable.")
-(make-variable-buffer-local 'semantic-show-parser-state-mode)
-
-(defun semantic-show-parser-state-mode-setup ()
- "Setup option `semantic-show-parser-state-mode'.
-The minor mode can be turned on only if semantic feature is available
-and the current buffer was set up for parsing. When minor mode is
-enabled parse the current buffer if needed. Return non-nil if the
+;;;###autoload
+(define-minor-mode semantic-show-parser-state-mode
+ "Minor mode for displaying parser cache state in the modeline.
+The cache can be in one of three states. They are
+Up to date, Partial reparse needed, and Full reparse needed.
+The state is indicated in the modeline with the following characters:
+ `-' -> The cache is up to date.
+ `!' -> The cache requires a full update.
+ `~' -> The cache needs to be incrementally parsed.
+ `%' -> The cache is not currently parseable.
+ `@' -> Auto-parse in progress (not set here.)
+With prefix argument ARG, turn on if positive, otherwise off. The
+minor mode can be turned on only if semantic feature is available and
+the current buffer was set up for parsing. Return non-nil if the
minor mode is enabled."
+ :keymap semantic-show-parser-state-mode-map
(if semantic-show-parser-state-mode
(if (not (and (featurep 'semantic) (semantic-active-p)))
(progn
@@ -603,8 +487,7 @@ minor mode is enabled."
'semantic-show-parser-state-auto-marker nil t)
(semantic-make-local-hook 'semantic-after-idle-scheduler-reparse-hook)
(add-hook 'semantic-after-idle-scheduler-reparse-hook
- 'semantic-show-parser-state-marker nil t)
- )
+ 'semantic-show-parser-state-marker nil t))
;; Remove parts of mode line
(setq mode-line-modified
(delq 'semantic-show-parser-state-string mode-line-modified))
@@ -626,45 +509,10 @@ minor mode is enabled."
(remove-hook 'semantic-before-idle-scheduler-reparse-hook
'semantic-show-parser-state-auto-marker t)
(remove-hook 'semantic-after-idle-scheduler-reparse-hook
- 'semantic-show-parser-state-marker t)
- )
- semantic-show-parser-state-mode)
-
-;;;###autoload
-(defun semantic-show-parser-state-mode (&optional arg)
- "Minor mode for displaying parser cache state in the modeline.
-The cache can be in one of three states. They are
-Up to date, Partial reparse needed, and Full reparse needed.
-The state is indicated in the modeline with the following characters:
- `-' -> The cache is up to date.
- `!' -> The cache requires a full update.
- `~' -> The cache needs to be incrementally parsed.
- `%' -> The cache is not currently parseable.
- `@' -> Auto-parse in progress (not set here.)
-With prefix argument ARG, turn on if positive, otherwise off. The
-minor mode can be turned on only if semantic feature is available and
-the current buffer was set up for parsing. Return non-nil if the
-minor mode is enabled."
- (interactive
- (list (or current-prefix-arg
- (if semantic-show-parser-state-mode 0 1))))
- (setq semantic-show-parser-state-mode
- (if arg
- (>
- (prefix-numeric-value arg)
- 0)
- (not semantic-show-parser-state-mode)))
- (semantic-show-parser-state-mode-setup)
- (run-hooks 'semantic-show-parser-state-mode-hook)
- (if (called-interactively-p 'interactive)
- (message "show-parser-state minor mode %sabled"
- (if semantic-show-parser-state-mode "en" "dis")))
- (semantic-mode-line-update)
- semantic-show-parser-state-mode)
+ 'semantic-show-parser-state-marker t)))
(semantic-add-minor-mode 'semantic-show-parser-state-mode
- ""
- semantic-show-parser-state-mode-map)
+ "")
(defvar semantic-show-parser-state-string nil
"String showing the parser state for this buffer.
@@ -691,7 +539,7 @@ in many situations."
(t
"-")))
;;(message "Setup mode line indicator to [%s]" semantic-show-parser-state-string)
- (semantic-mode-line-update))
+ )
(defun semantic-show-parser-state-auto-marker ()
"Hook function run before an autoparse.
@@ -699,7 +547,6 @@ Set up `semantic-show-parser-state-marker' to show `@'
to indicate a parse in progress."
(unless (semantic-parse-tree-up-to-date-p)
(setq semantic-show-parser-state-string "@")
- (semantic-mode-line-update)
;; For testing.
;;(sit-for 1)
))
@@ -710,30 +557,14 @@ to indicate a parse in progress."
;;;;
;;;###autoload
-(defun global-semantic-stickyfunc-mode (&optional arg)
+(define-minor-mode global-semantic-stickyfunc-mode
"Toggle global use of option `semantic-stickyfunc-mode'.
-If ARG is positive, enable, if it is negative, disable.
-If ARG is nil, then toggle."
- (interactive "P")
- (setq global-semantic-stickyfunc-mode
- (semantic-toggle-minor-mode-globally
- 'semantic-stickyfunc-mode arg)))
-
-;;;###autoload
-(defcustom global-semantic-stickyfunc-mode nil
- "If non-nil, enable global use of `semantic-stickyfunc-mode'.
-This minor mode only works for Emacs 21 or later.
-When enabled, the header line is enabled, and the first line
-of the current function or method is displayed in it.
-This makes it appear that the first line of that tag is
-`sticky' to the top of the window."
- :group 'semantic
- :group 'semantic-modes
- :type 'boolean
- :require 'semantic/util-modes
- :initialize 'custom-initialize-default
- :set (lambda (sym val)
- (global-semantic-stickyfunc-mode (if val 1 -1))))
+If ARG is positive or nil, enable, if it is negative, disable."
+ :global t :group 'semantic :group 'semantic-modes
+ ;; Not needed because it's autoloaded instead.
+ ;; :require 'semantic/util-modes
+ (semantic-toggle-minor-mode-globally
+ 'semantic-stickyfunc-mode (if global-semantic-stickyfunc-mode 1 -1)))
(defcustom semantic-stickyfunc-mode-hook nil
"Hook run at the end of function `semantic-stickyfunc-mode'."
@@ -781,11 +612,6 @@ This makes it appear that the first line of that tag is
(describe-function 'semantic-stickyfunc-mode)) t])
)
-(defvar semantic-stickyfunc-mode nil
- "Non-nil if stickyfunc minor mode is enabled.
-Use the command `semantic-stickyfunc-mode' to change this variable.")
-(make-variable-buffer-local 'semantic-stickyfunc-mode)
-
(defcustom semantic-stickyfunc-indent-string
(if (and window-system (not (featurep 'xemacs)))
(concat
@@ -870,11 +696,21 @@ when it lands in the sticky line."
(t nil))
"The header line format used by stickyfunc mode.")
-(defun semantic-stickyfunc-mode-setup ()
- "Setup option `semantic-stickyfunc-mode'.
-For semantic enabled buffers, make the function declaration for the top most
-function \"sticky\". This is accomplished by putting the first line of
-text for that function in the header line."
+;;;###autoload
+(define-minor-mode semantic-stickyfunc-mode
+ "Minor mode to show the title of a tag in the header line.
+Enables/disables making the header line of functions sticky.
+A function (or other tag class specified by
+`semantic-stickyfunc-sticky-classes') has a header line, meaning the
+first line which describes the rest of the construct. This first
+line is what is displayed in the header line.
+
+With prefix argument ARG, turn on if positive, otherwise off. The
+minor mode can be turned on only if semantic feature is available and
+the current buffer was set up for parsing. Return non-nil if the
+minor mode is enabled."
+ ;; Don't need indicator. It's quite visible
+ :keymap semantic-stickyfunc-mode-map
(if semantic-stickyfunc-mode
(progn
(unless (and (featurep 'semantic) (semantic-active-p))
@@ -892,8 +728,7 @@ text for that function in the header line."
semantic-stickyfunc-header-line-format)))
(set (make-local-variable 'semantic-stickyfunc-old-hlf)
header-line-format))
- (setq header-line-format semantic-stickyfunc-header-line-format)
- )
+ (setq header-line-format semantic-stickyfunc-header-line-format))
;; Disable sticky func mode
;; Restore previous buffer local value of header line format if
;; the current one is the sticky func one.
@@ -901,38 +736,7 @@ text for that function in the header line."
(kill-local-variable 'header-line-format)
(when (local-variable-p 'semantic-stickyfunc-old-hlf (current-buffer))
(setq header-line-format semantic-stickyfunc-old-hlf)
- (kill-local-variable 'semantic-stickyfunc-old-hlf))))
- semantic-stickyfunc-mode)
-
-;;;###autoload
-(defun semantic-stickyfunc-mode (&optional arg)
- "Minor mode to show the title of a tag in the header line.
-Enables/disables making the header line of functions sticky.
-A function (or other tag class specified by
-`semantic-stickyfunc-sticky-classes') has a header line, meaning the
-first line which describes the rest of the construct. This first
-line is what is displayed in the header line.
-
-With prefix argument ARG, turn on if positive, otherwise off. The
-minor mode can be turned on only if semantic feature is available and
-the current buffer was set up for parsing. Return non-nil if the
-minor mode is enabled."
- (interactive
- (list (or current-prefix-arg
- (if semantic-stickyfunc-mode 0 1))))
- (setq semantic-stickyfunc-mode
- (if arg
- (>
- (prefix-numeric-value arg)
- 0)
- (not semantic-stickyfunc-mode)))
- (semantic-stickyfunc-mode-setup)
- (run-hooks 'semantic-stickyfunc-mode-hook)
- (if (called-interactively-p 'interactive)
- (message "Stickyfunc minor mode %sabled"
- (if semantic-stickyfunc-mode "en" "dis")))
- (semantic-mode-line-update)
- semantic-stickyfunc-mode)
+ (kill-local-variable 'semantic-stickyfunc-old-hlf)))))
(defvar semantic-stickyfunc-sticky-classes
'(function type)
@@ -1025,8 +829,7 @@ Argument EVENT describes the event that caused this function to be called."
(semantic-add-minor-mode 'semantic-stickyfunc-mode
- "" ;; Don't need indicator. It's quite visible
- semantic-stickyfunc-mode-map)
+ "") ;; Don't need indicator. It's quite visible
@@ -1038,26 +841,15 @@ Argument EVENT describes the event that caused this function to be called."
;; from the tag going off the top of the screen.
;;;###autoload
-(defun global-semantic-highlight-func-mode (&optional arg)
+(define-minor-mode global-semantic-highlight-func-mode
"Toggle global use of option `semantic-highlight-func-mode'.
-If ARG is positive, enable, if it is negative, disable.
-If ARG is nil, then toggle."
- (interactive "P")
- (setq global-semantic-highlight-func-mode
- (semantic-toggle-minor-mode-globally
- 'semantic-highlight-func-mode arg)))
-
-;;;###autoload
-(defcustom global-semantic-highlight-func-mode nil
- "If non-nil, enable global use of `semantic-highlight-func-mode'.
-When enabled, the first line of the current tag is highlighted."
- :group 'semantic
- :group 'semantic-modes
- :type 'boolean
- :require 'semantic/util-modes
- :initialize 'custom-initialize-default
- :set (lambda (sym val)
- (global-semantic-highlight-func-mode (if val 1 -1))))
+If ARG is positive or nil, enable, if it is negative, disable."
+ :global t :group 'semantic :group 'semantic-modes
+ ;; Not needed because it's autoloaded instead.
+ ;; :require 'semantic/util-modes
+ (semantic-toggle-minor-mode-globally
+ 'semantic-highlight-func-mode
+ (if global-semantic-highlight-func-mode 1 -1)))
(defcustom semantic-highlight-func-mode-hook nil
"Hook run at the end of function `semantic-highlight-func-mode'."
@@ -1121,11 +913,6 @@ Argument EVENT describes the event that caused this function to be called."
)
(select-window startwin)))
-(defvar semantic-highlight-func-mode nil
- "Non-nil if highlight-func minor mode is enabled.
-Use the command `semantic-highlight-func-mode' to change this variable.")
-(make-variable-buffer-local 'semantic-highlight-func-mode)
-
(defvar semantic-highlight-func-ct-overlay nil
"Overlay used to highlight the tag the cursor is in.")
(make-variable-buffer-local 'semantic-highlight-func-ct-overlay)
@@ -1139,28 +926,8 @@ Use the command `semantic-highlight-func-mode' to change this variable.")
"Face used to show the top of current function."
:group 'semantic-faces)
-
-(defun semantic-highlight-func-mode-setup ()
- "Setup option `semantic-highlight-func-mode'.
-For Semantic enabled buffers, highlight the first line of the
-current tag declaration."
- (if semantic-highlight-func-mode
- (progn
- (unless (and (featurep 'semantic) (semantic-active-p))
- ;; Disable minor mode if semantic stuff not available
- (setq semantic-highlight-func-mode nil)
- (error "Buffer %s was not set up for parsing" (buffer-name)))
- ;; Setup our hook
- (add-hook 'post-command-hook 'semantic-highlight-func-highlight-current-tag nil t)
- )
- ;; Disable highlight func mode
- (remove-hook 'post-command-hook 'semantic-highlight-func-highlight-current-tag t)
- (semantic-highlight-func-highlight-current-tag t)
- )
- semantic-highlight-func-mode)
-
;;;###autoload
-(defun semantic-highlight-func-mode (&optional arg)
+(define-minor-mode semantic-highlight-func-mode
"Minor mode to highlight the first line of the current tag.
Enables/disables making the current function's first line light up.
A function (or other tag class specified by
@@ -1175,21 +942,20 @@ With prefix argument ARG, turn on if positive, otherwise off. The
minor mode can be turned on only if semantic feature is available and
the current buffer was set up for parsing. Return non-nil if the
minor mode is enabled."
- (interactive
- (list (or current-prefix-arg
- (if semantic-highlight-func-mode 0 1))))
- (setq semantic-highlight-func-mode
- (if arg
- (>
- (prefix-numeric-value arg)
- 0)
- (not semantic-highlight-func-mode)))
- (semantic-highlight-func-mode-setup)
- (run-hooks 'semantic-highlight-func-mode-hook)
- (if (called-interactively-p 'interactive)
- (message "Highlight-Func minor mode %sabled"
- (if semantic-highlight-func-mode "en" "dis")))
- semantic-highlight-func-mode)
+ :lighter nil ;; Don't need indicator. It's quite visible.
+ (if semantic-highlight-func-mode
+ (progn
+ (unless (and (featurep 'semantic) (semantic-active-p))
+ ;; Disable minor mode if semantic stuff not available
+ (setq semantic-highlight-func-mode nil)
+ (error "Buffer %s was not set up for parsing" (buffer-name)))
+ ;; Setup our hook
+ (add-hook 'post-command-hook
+ 'semantic-highlight-func-highlight-current-tag nil t))
+ ;; Disable highlight func mode
+ (remove-hook 'post-command-hook
+ 'semantic-highlight-func-highlight-current-tag t)
+ (semantic-highlight-func-highlight-current-tag t)))
(defun semantic-highlight-func-highlight-current-tag (&optional disable)
"Highlight the current tag under point.
@@ -1236,8 +1002,7 @@ function was called, move the overlay."
nil)
(semantic-add-minor-mode 'semantic-highlight-func-mode
- "" ;; Don't need indicator. It's quite visible
- nil)
+ "") ;; Don't need indicator. It's quite visible
(provide 'semantic/util-modes)
diff --git a/lisp/cedet/semantic/wisent/comp.el b/lisp/cedet/semantic/wisent/comp.el
index 371a1947304..90585399b74 100644
--- a/lisp/cedet/semantic/wisent/comp.el
+++ b/lisp/cedet/semantic/wisent/comp.el
@@ -1,7 +1,8 @@
;;; semantic/wisent/comp.el --- GNU Bison for Emacs - Grammar compiler
;; Copyright (C) 1984, 1986, 1989, 1992, 1995, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2009, 2010 Free Software Foundation, Inc.
+;; 2004, 2005, 2006, 2007, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: David Ponce <david@dponce.com>
;; Maintainer: David Ponce <david@dponce.com>
@@ -160,12 +161,6 @@ If optional LEFT is non-nil insert spaces on left."
(not (zerop (logand (aref x (/ i wisent-BITS-PER-WORD))
(lsh 1 (% i wisent-BITS-PER-WORD))))))
-(eval-when-compile
- (or (fboundp 'noninteractive)
- ;; Silence the Emacs byte compiler
- (defun noninteractive nil))
- )
-
(defsubst wisent-noninteractive ()
"Return non-nil if running without interactive terminal."
(if (featurep 'xemacs)
@@ -205,7 +200,7 @@ Its name is defined in constant `wisent-log-buffer-name'."
`(with-current-buffer (wisent-log-buffer)
(erase-buffer)))
-(eval-when-compile (defvar byte-compile-current-file))
+(defvar byte-compile-current-file)
(defun wisent-source ()
"Return the current source file name or nil."
@@ -3536,5 +3531,4 @@ See also `wisent-compile-grammar' for more details on AUTOMATON."
(provide 'semantic/wisent/comp)
-;; arch-tag: 758ea04c-ea97-466b-9b35-aea0861033c9
;;; semantic/wisent/comp.el ends here
diff --git a/lisp/cedet/srecode.el b/lisp/cedet/srecode.el
index ac9a000ccd5..f27a2028b92 100644
--- a/lisp/cedet/srecode.el
+++ b/lisp/cedet/srecode.el
@@ -4,6 +4,7 @@
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: codegeneration
+;; Version: 1.0pre7
;; This file is part of GNU Emacs.
diff --git a/lisp/cedet/srecode/fields.el b/lisp/cedet/srecode/fields.el
index 0cfc2953792..ceb5f77f87f 100644
--- a/lisp/cedet/srecode/fields.el
+++ b/lisp/cedet/srecode/fields.el
@@ -198,7 +198,7 @@ If SET-TO is a string, then replace the text of OLAID wit SET-TO."
(oset ir fields srecode-field-archive)
(setq srecode-field-archive nil)
- ;; Initailize myself first.
+ ;; Initialize myself first.
(call-next-method)
)
diff --git a/lisp/cedet/srecode/mode.el b/lisp/cedet/srecode/mode.el
index 3f286c96117..32bf665d06c 100644
--- a/lisp/cedet/srecode/mode.el
+++ b/lisp/cedet/srecode/mode.el
@@ -37,19 +37,6 @@
;;; Code:
-(defcustom global-srecode-minor-mode nil
- "Non-nil in buffers with Semantic Recoder macro keybindings."
- :group 'srecode
- :type 'boolean
- :require 'srecode/mode
- :initialize 'custom-initialize-default
- :set (lambda (sym val)
- (global-srecode-minor-mode (if val 1 -1))))
-
-(defvar srecode-minor-mode nil
- "Non-nil in buffers with Semantic Recoder macro keybindings.")
-(make-variable-buffer-local 'srecode-minor-mode)
-
(defcustom srecode-minor-mode-hook nil
"Hook run at the end of the function `srecode-minor-mode'."
:group 'srecode
@@ -156,7 +143,7 @@
"Keymap for srecode minor mode.")
;;;###autoload
-(defun srecode-minor-mode (&optional arg)
+(define-minor-mode srecode-minor-mode
"Toggle srecode minor mode.
With prefix argument ARG, turn on if positive, otherwise off. The
minor mode can be turned on only if semantic feature is available and
@@ -164,16 +151,7 @@ the current buffer was set up for parsing. Return non-nil if the
minor mode is enabled.
\\{srecode-mode-map}"
- (interactive
- (list (or current-prefix-arg
- (if srecode-minor-mode 0 1))))
- ;; Flip the bits.
- (setq srecode-minor-mode
- (if arg
- (>
- (prefix-numeric-value arg)
- 0)
- (not srecode-minor-mode)))
+ :keymap srecode-mode-map
;; If we are turning things on, make sure we have templates for
;; this mode first.
(when srecode-minor-mode
@@ -182,25 +160,20 @@ minor mode is enabled.
(mapcar (lambda (map)
(srecode-map-entries-for-mode map major-mode))
(srecode-get-maps))))
- (setq srecode-minor-mode nil))
- )
- ;; Run hooks if we are turning this on.
- (when srecode-minor-mode
- (run-hooks 'srecode-minor-mode-hook))
- srecode-minor-mode)
+ (setq srecode-minor-mode nil))))
;;;###autoload
-(defun global-srecode-minor-mode (&optional arg)
+(define-minor-mode global-srecode-minor-mode
"Toggle global use of srecode minor mode.
-If ARG is positive, enable, if it is negative, disable.
-If ARG is nil, then toggle."
- (interactive "P")
- (setq global-srecode-minor-mode
- (semantic-toggle-minor-mode-globally
- 'srecode-minor-mode arg)))
+If ARG is positive or nil, enable, if it is negative, disable."
+ :global t :group 'srecode
+ ;; Not needed because it's autoloaded instead.
+ ;; :require 'srecode/mode
+ (semantic-toggle-minor-mode-globally
+ 'srecode-minor-mode (if global-srecode-minor-mode 1 -1)))
;; Use the semantic minor mode magic stuff.
-(semantic-add-minor-mode 'srecode-minor-mode "" srecode-mode-map)
+(semantic-add-minor-mode 'srecode-minor-mode "")
;;; Menu Filters
;;
diff --git a/lisp/comint.el b/lisp/comint.el
index aa0e1599537..2d03d1679ae 100644
--- a/lisp/comint.el
+++ b/lisp/comint.el
@@ -1,13 +1,14 @@
;;; comint.el --- general command interpreter in a window stuff
-;; Copyright (C) 1988, 1990, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1988, 1990, 1992, 1993, 1994, 1995, 1996, 1997, 1998,
+;; 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+;; 2010 Free Software Foundation, Inc.
;; Author: Olin Shivers <shivers@cs.cmu.edu>
;; Simon Marshall <simon@gnu.org>
;; Maintainer: FSF
;; Keywords: processes
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -309,7 +310,6 @@ the function `comint-truncate-buffer' is on `comint-output-filter-functions'."
:type 'integer
:group 'comint)
-;; FIXME: this should be defcustom
(defcustom comint-input-ring-size 500
"Size of the input history ring in `comint-mode'."
:type 'integer
@@ -339,15 +339,23 @@ This variable is buffer-local."
;; Ubuntu's sudo prompts like `[sudo] password for user:'
;; Some implementations of passwd use "Password (again)" as the 2nd prompt.
;; Something called "perforce" uses "Enter password:".
+;; See M-x comint-testsuite--test-comint-password-prompt-regexp.
(defcustom comint-password-prompt-regexp
- "\\(\\([Ee]nter \\(?:same \\|the \\)?\\|[Oo]ld \\|[Nn]ew \\|'s \\|login \\|\
-Kerberos \\|CVS \\|UNIX \\| SMB \\|LDAP \\|\\[sudo] \\|^\\)\
-\[Pp]assword\\( (again)\\)?\\|\
-pass phrase\\|\\(Enter \\|Repeat \\|Bad \\)?[Pp]assphrase\\)\
-\\(?:, try again\\)?\\(?: for [^:]+\\)?:\\s *\\'"
+ (concat
+ "\\(^ *\\|"
+ (regexp-opt
+ '("Enter" "enter" "Enter same" "enter same" "Enter the" "enter the"
+ "Old" "old" "New" "new" "'s" "login"
+ "Kerberos" "CVS" "UNIX" " SMB" "LDAP" "[sudo]" "Repeat" "Bad") t)
+ " +\\)"
+ (regexp-opt
+ '("password" "Password" "passphrase" "Passphrase"
+ "pass phrase" "Pass phrase"))
+ "\\(?:\\(?:, try\\)? *again\\| (empty for no passphrase)\\| (again)\\)?\
+\\(?: for [^:]+\\)?:\\s *\\'")
"Regexp matching prompts for passwords in the inferior process.
This is used by `comint-watch-for-password-prompt'."
- :version "23.3"
+ :version "24.1"
:type 'regexp
:group 'comint)
@@ -410,6 +418,9 @@ See `comint-send-input'."
:type 'boolean
:group 'comint)
+(define-obsolete-variable-alias 'comint-use-prompt-regexp-instead-of-fields
+ 'comint-use-prompt-regexp "22.1")
+
;; Note: If it is decided to purge comint-prompt-regexp from the source
;; entirely, searching for uses of this variable will help to identify
;; places that need attention.
@@ -422,11 +433,6 @@ respect field boundaries in a natural way)."
:type 'boolean
:group 'comint)
-;; Autoload is necessary for Custom to recognize old alias.
-;;;###autoload
-(define-obsolete-variable-alias 'comint-use-prompt-regexp-instead-of-fields
- 'comint-use-prompt-regexp "22.1")
-
(defcustom comint-mode-hook nil
"Hook run upon entry to `comint-mode'.
This is run before the process is cranked up."
@@ -670,6 +676,9 @@ Entry to this mode runs the hooks on `comint-mode-hook'."
(make-local-variable 'comint-process-echoes)
(make-local-variable 'comint-file-name-chars)
(make-local-variable 'comint-file-name-quote-list)
+ ;; dir tracking on remote files
+ (set (make-local-variable 'comint-file-name-prefix)
+ (or (file-remote-p default-directory) ""))
(make-local-variable 'comint-accum-marker)
(setq comint-accum-marker (make-marker))
(make-local-variable 'font-lock-defaults)
@@ -2290,8 +2299,6 @@ Does not delete the prompt."
(delete-region pmark (point))))
;; Output message and put back prompt
(comint-output-filter proc replacement)))
-(define-obsolete-function-alias 'comint-kill-output
- 'comint-delete-output "21.1")
(defun comint-write-output (filename &optional append mustbenew)
"Write output from interpreter since last input to FILENAME.
@@ -3745,5 +3752,4 @@ REGEXP-GROUP is the regular expression group in REGEXP to use."
(provide 'comint)
-;; arch-tag: 1793314c-09db-40be-9549-9aeae3e75164
;;; comint.el ends here
diff --git a/lisp/composite.el b/lisp/composite.el
index b5ef9b510c6..da7705cf9eb 100644
--- a/lisp/composite.el
+++ b/lisp/composite.el
@@ -8,6 +8,7 @@
;; Author: Kenichi HANDA <handa@etl.go.jp>
;; (according to ack.texi)
;; Keywords: mule, multilingual, character composition
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -28,6 +29,8 @@
;;; Code:
+(eval-when-compile (require 'cl))
+
(defconst reference-point-alist
'((tl . 0) (tc . 1) (tr . 2)
(Bl . 3) (Bc . 4) (Br . 5)
@@ -77,7 +80,7 @@ follows (the point `*' corresponds to both reference points):
+----+-----+ <--- new descent
A composition rule may have the form \(GLOBAL-REF-POINT
-NEW-REF-POINT XOFF YOFF), where XOFF and YOFF specifies how much
+NEW-REF-POINT XOFF YOFF), where XOFF and YOFF specify how much
to shift NEW-REF-POINT from GLOBAL-REF-POINT. In this case, XOFF
and YOFF are integers in the range -100..100 representing the
shifting percentage against the font size.")
@@ -410,27 +413,6 @@ after a sequence of character events."
;;; Automatic character composition.
-;; Copied from font-lock.el.
-(eval-when-compile
- ;; Borrowed from lazy-lock.el.
- ;; We use this to preserve or protect things when modifying text properties.
- (defmacro save-buffer-state (varlist &rest body)
- "Bind variables according to VARLIST and eval BODY restoring buffer state."
- `(let* ,(append varlist
- '((modified (buffer-modified-p)) (buffer-undo-list t)
- (inhibit-read-only t) (inhibit-point-motion-hooks t)
- (inhibit-modification-hooks t)
- deactivate-mark buffer-file-name buffer-file-truename))
- ,@body
- (unless modified
- (restore-buffer-modified-p nil))))
- ;; Fixme: This makes bootstrapping fail with this error.
- ;; Symbol's function definition is void: eval-defun
- ;;(def-edebug-spec save-buffer-state let)
- )
-
-(put 'save-buffer-state 'lisp-indent-function 1)
-
;; These macros must match with C macros LGSTRING_XXX and LGLYPH_XXX in font.h
(defsubst lgstring-header (gstring) (aref gstring 0))
(defsubst lgstring-set-header (gstring header) (aset gstring 0 header))
@@ -532,12 +514,12 @@ after a sequence of character events."
(defun compose-gstring-for-graphic (gstring)
"Compose glyph-string GSTRING for graphic display.
-Non-spacing characters are composed with the preceding base
+Combining characters are composed with the preceding base
character. If the preceding character is not a base character,
-each non-spacing character is composed as a spacing character by
+each combining character is composed as a spacing character by
a padding space before and/or after the character.
-All non-spacing characters has this function in
+All non-spacing characters have this function in
`composition-function-table' unless overwritten."
(let* ((header (lgstring-header gstring))
(nchars (lgstring-char-len gstring))
@@ -660,16 +642,16 @@ All non-spacing characters has this function in
[nil 0 compose-gstring-for-graphic])))
(map-char-table
#'(lambda (key val)
- (if (= val 0)
+ (if (memq val '(Mn Mc Me))
(set-char-table-range composition-function-table key elt)))
- char-width-table))
+ unicode-category-table))
(defun compose-gstring-for-terminal (gstring)
"Compose glyph string GSTRING for terminal display.
Non-spacing characters are composed with the preceding base
character. If the preceding character is not a base character,
each non-spacing character is composed as a spacing character by
-a prepending a space before it."
+prepending a space before it."
(let* ((header (lgstring-header gstring))
(nchars (lgstring-char-len gstring))
(nglyphs (lgstring-glyph-len gstring))
@@ -745,14 +727,13 @@ This function is the default value of `auto-composition-function' (which see)."
(setq func 'compose-gstring-for-terminal))
(funcall func gstring))))
-(make-variable-buffer-local 'auto-composition-mode)
(put 'auto-composition-mode 'permanent-local t)
(make-variable-buffer-local 'auto-composition-function)
(setq-default auto-composition-function 'auto-compose-chars)
;;;###autoload
-(defun auto-composition-mode (&optional arg)
+(define-minor-mode auto-composition-mode
"Toggle Auto Composition mode.
With ARG, turn Auto Composition mode off if and only if ARG is a non-positive
number; if ARG is nil, toggle Auto Composition mode; anything else turns Auto
@@ -763,43 +744,21 @@ by functions registered in `composition-function-table' (which see).
You can use `global-auto-composition-mode' to turn on
Auto Composition mode in all buffers (this is the default)."
- (interactive "P")
- (setq auto-composition-mode
- (if arg
- (or (not (integerp arg)) (> arg 0))
- (not auto-composition-mode))))
+ ;; It's defined in C, this stops the d-m-m macro defining it again.
+ :variable auto-composition-mode)
+;; It's not defined with DEFVAR_PER_BUFFER though.
+(make-variable-buffer-local 'auto-composition-mode)
;;;###autoload
-(defun global-auto-composition-mode (&optional arg)
+(define-minor-mode global-auto-composition-mode
"Toggle Auto-Composition mode in every possible buffer.
With prefix arg, turn Global-Auto-Composition mode on if and only if arg
is positive.
See `auto-composition-mode' for more information on Auto-Composition mode."
- (interactive "P")
- (setq-default auto-composition-mode
- (if arg
- (or (not (integerp arg)) (> arg 0))
- (not (default-value 'auto-composition-mode)))))
-(defalias 'toggle-auto-composition 'auto-composition-mode)
-
-
-;; The following codes are only for backward compatibility with Emacs
-;; 20.4 and earlier.
+ :variable (default-value 'auto-composition-mode))
-(defun decompose-composite-char (char &optional type with-composition-rule)
- "Convert CHAR to string.
-
-If optional 2nd arg TYPE is non-nil, it is `string', `list', or
-`vector'. In this case, CHAR is converted to string, list of CHAR, or
-vector of CHAR respectively.
-Optional 3rd arg WITH-COMPOSITION-RULE is ignored."
- (cond ((or (null type) (eq type 'string)) (char-to-string char))
- ((eq type 'list) (list char))
- (t (vector char))))
-
-(make-obsolete 'decompose-composite-char 'char-to-string "21.1")
+(defalias 'toggle-auto-composition 'auto-composition-mode)
-;; arch-tag: ee703d77-1723-45d4-a31f-e9f0f867aa33
;;; composite.el ends here
diff --git a/lisp/cus-dep.el b/lisp/cus-dep.el
index 249dd51acda..230410772ab 100644
--- a/lisp/cus-dep.el
+++ b/lisp/cus-dep.el
@@ -5,6 +5,7 @@
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el
index b815e31f31c..61e6881139a 100644
--- a/lisp/cus-edit.el
+++ b/lisp/cus-edit.el
@@ -6,6 +6,7 @@
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Maintainer: FSF
;; Keywords: help, faces
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -166,10 +167,27 @@
"Basic text editing facilities."
:group 'emacs)
+(defgroup convenience nil
+ "Convenience features for faster editing."
+ :group 'emacs)
+
+(defgroup files nil
+ "Support for editing files."
+ :group 'emacs)
+
+(defgroup wp nil
+ "Support for editing text files."
+ :tag "Text"
+ :group 'emacs)
+
+(defgroup data nil
+ "Support for editing binary data files."
+ :group 'emacs)
+
(defgroup abbrev nil
"Abbreviation handling, typing shortcuts, macros."
:tag "Abbreviations"
- :group 'editing)
+ :group 'convenience)
(defgroup matching nil
"Various sorts of searching and matching."
@@ -186,20 +204,20 @@
(defgroup outlines nil
"Support for hierarchical outlining."
- :group 'editing)
+ :group 'wp)
(defgroup external nil
"Interfacing to external utilities."
:group 'emacs)
+(defgroup comm nil
+ "Communications, networking, and remote access to files."
+ :tag "Communication"
+ :group 'emacs)
+
(defgroup processes nil
"Process, subshell, compilation, and job control support."
- :group 'external
- :group 'development)
-
-(defgroup convenience nil
- "Convenience features for faster editing."
- :group 'emacs)
+ :group 'external)
(defgroup programming nil
"Support for programming in other languages."
@@ -225,10 +243,6 @@
"Programming tools."
:group 'programming)
-(defgroup oop nil
- "Support for object-oriented programming."
- :group 'programming)
-
(defgroup applications nil
"Applications written in Emacs."
:group 'emacs)
@@ -275,11 +289,6 @@
"Fitting Emacs with its environment."
:group 'emacs)
-(defgroup comm nil
- "Communications, networking, remote access to files."
- :tag "Communication"
- :group 'environment)
-
(defgroup hardware nil
"Support for interfacing with miscellaneous hardware."
:group 'environment)
@@ -306,18 +315,6 @@
"Support for Emacs frames and window systems."
:group 'environment)
-(defgroup data nil
- "Support for editing files of data."
- :group 'emacs)
-
-(defgroup files nil
- "Support for editing files."
- :group 'emacs)
-
-(defgroup wp nil
- "Word processing."
- :group 'emacs)
-
(defgroup tex nil
"Code related to the TeX formatter."
:link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces)
@@ -327,10 +324,6 @@
"Support for multiple fonts."
:group 'emacs)
-(defgroup hypermedia nil
- "Support for links between text or other media types."
- :group 'emacs)
-
(defgroup help nil
"Support for on-line help systems."
:group 'emacs)
@@ -446,9 +439,6 @@
;;; Custom mode keymaps
(defvar custom-mode-map
- ;; This keymap should be dense, but a dense keymap would prevent inheriting
- ;; "\r" bindings from the parent map.
- ;; Actually, this misfeature of dense keymaps was fixed on 2001-11-26.
(let ((map (make-keymap)))
(set-keymap-parent map widget-keymap)
(define-key map [remap self-insert-command] 'Custom-no-edit)
@@ -680,10 +670,11 @@ If `last', order groups after non-groups."
:group 'custom-browse)
;;;###autoload
-(defcustom custom-buffer-sort-alphabetically nil
- "If non-nil, sort each customization group alphabetically in Custom buffer."
+(defcustom custom-buffer-sort-alphabetically t
+ "Whether to sort customization groups alphabetically in Custom buffer."
:type 'boolean
- :group 'custom-buffer)
+ :group 'custom-buffer
+ :version "24.1")
(defcustom custom-buffer-order-groups 'last
"If non-nil, order group members within each customization group.
@@ -744,27 +735,33 @@ groups after non-groups, if nil do not order groups at all."
;; `custom-buffer-create-internal' if `custom-buffer-verbose-help' is non-nil.
(defvar custom-commands
- '(("Set for current session" Custom-set t
+ '((" Set for current session " Custom-set t
"Apply all settings in this buffer to the current session"
- "index")
- ("Save for future sessions" Custom-save
+ "index"
+ "Apply")
+ (" Save for future sessions " Custom-save
(or custom-file user-init-file)
"Apply all settings in this buffer and save them for future Emacs sessions."
- "save")
- ("Undo edits" Custom-reset-current t
+ "save"
+ "Save")
+ (" Undo edits " Custom-reset-current t
"Restore all settings in this buffer to reflect their current values."
- "refresh")
- ("Reset to saved" Custom-reset-saved t
+ "refresh"
+ "Undo")
+ (" Reset to saved " Custom-reset-saved t
"Restore all settings in this buffer to their saved values (if any)."
- "undo")
- ("Erase customizations" Custom-reset-standard
+ "undo"
+ "Reset")
+ (" Erase customizations " Custom-reset-standard
(or custom-file user-init-file)
"Un-customize all settings in this buffer and save them with standard values."
- "delete")
- ("Help for Customize" Custom-help t
+ "delete"
+ "Uncustomize")
+ (" Help for Customize " Custom-help t
"Get help for using Customize."
- "help")
- ("Exit" Custom-buffer-done t "Exit Customize." "exit")))
+ "help"
+ "Help")
+ (" Exit " Custom-buffer-done t "Exit Customize." "exit" "Exit")))
(defun Custom-help ()
"Read the node on Easy Customization in the Emacs manual."
@@ -1136,7 +1133,7 @@ Show the buffer in another window, but don't select it."
(unless (eq symbol basevar)
(message "`%s' is an alias for `%s'" symbol basevar))))
-(defvar customize-changed-options-previous-release "22.1"
+(defvar customize-changed-options-previous-release "23.1"
"Version for `customize-changed-options' to refer back to by default.")
;; Packages will update this variable, so make it available.
@@ -1382,42 +1379,52 @@ suggest to customize that face, if it's customizable."
(custom-buffer-create (custom-sort-items found t nil)
"*Customize Saved*"))))
+(declare-function apropos-parse-pattern "apropos" (pattern))
+
;;;###autoload
-(defun customize-apropos (regexp &optional all)
- "Customize all loaded options, faces and groups matching REGEXP.
-If ALL is `options', include only options.
-If ALL is `faces', include only faces.
-If ALL is `groups', include only groups.
-If ALL is t (interactively, with prefix arg), include variables
+(defun customize-apropos (pattern &optional type)
+ "Customize all loaded options, faces and groups matching PATTERN.
+PATTERN can be a word, a list of words (separated by spaces),
+or a regexp (using some regexp special characters). If it is a word,
+search for matches for that word as a substring. If it is a list of words,
+search for matches for any two (or more) of those words.
+
+If TYPE is `options', include only options.
+If TYPE is `faces', include only faces.
+If TYPE is `groups', include only groups.
+If TYPE is t (interactively, with prefix arg), include variables
that are not customizable options, as well as faces and groups
\(but we recommend using `apropos-variable' instead)."
- (interactive "sCustomize (regexp): \nP")
- (let ((found nil))
- (mapatoms (lambda (symbol)
- (when (string-match regexp (symbol-name symbol))
- (when (and (not (memq all '(faces options)))
- (get symbol 'custom-group))
- (push (list symbol 'custom-group) found))
- (when (and (not (memq all '(options groups)))
- (custom-facep symbol))
- (push (list symbol 'custom-face) found))
- (when (and (not (memq all '(groups faces)))
- (boundp symbol)
- (eq (indirect-variable symbol) symbol)
- (or (get symbol 'saved-value)
- (custom-variable-p symbol)
- (and (not (memq all '(nil options)))
- (get symbol 'variable-documentation))))
- (push (list symbol 'custom-variable) found)))))
+ (interactive (list (apropos-read-pattern "symbol") current-prefix-arg))
+ (require 'apropos)
+ (apropos-parse-pattern pattern)
+ (let (found tests)
+ (mapatoms
+ `(lambda (symbol)
+ (when (string-match apropos-regexp (symbol-name symbol))
+ ,(if (not (memq type '(faces options)))
+ '(if (get symbol 'custom-group)
+ (push (list symbol 'custom-group) found)))
+ ,(if (not (memq type '(options groups)))
+ '(if (custom-facep symbol)
+ (push (list symbol 'custom-face) found)))
+ ,(if (not (memq type '(groups faces)))
+ `(if (and (boundp symbol)
+ (eq (indirect-variable symbol) symbol)
+ (or (get symbol 'saved-value)
+ (custom-variable-p symbol)
+ ,(if (not (memq type '(nil options)))
+ '(get symbol 'variable-documentation))))
+ (push (list symbol 'custom-variable) found))))))
(if (not found)
(error "No %s matching %s"
- (if (eq all t)
- "items"
- (format "customizable %s"
- (if (memq all '(options faces groups))
- (symbol-name all)
- "items")))
- regexp)
+ (if (eq type t)
+ "items"
+ (format "customizable %s"
+ (if (memq type '(options faces groups))
+ (symbol-name type)
+ "items")))
+ pattern)
(custom-buffer-create
(custom-sort-items found t custom-buffer-order-groups)
"*Customize Apropos*"))))
@@ -1540,6 +1547,12 @@ This button will have a menu with all three reset operations."
(defvar custom-button-pressed nil
"Face used for pressed buttons in customization buffers.")
+(defcustom custom-search-field t
+ "If non-nil, show a search field in Custom buffers."
+ :type 'boolean
+ :version "24.1"
+ :group 'custom-buffer)
+
(defcustom custom-raised-buttons (not (equal (face-valid-attribute-values :box)
'(("unspecified" . unspecified))))
"If non-nil, indicate active buttons in a `raised-button' style.
@@ -1563,14 +1576,9 @@ Otherwise use brackets."
(let ((init-file (or custom-file user-init-file)))
;; Insert verbose help at the top of the custom buffer.
(when custom-buffer-verbose-help
- (widget-insert "Editing a setting changes only the text in this buffer."
- (if init-file
- "
-To apply your changes, use the Save or Set buttons.
-Saving a change normally works by editing your init file."
- "
-Currently, these settings cannot be saved for future Emacs sessions,
-possibly because you started Emacs with `-q'.")
+ (widget-insert (if init-file
+ "To apply changes, use the Save or Set buttons."
+ "Custom settings cannot be saved; maybe you started Emacs with `-q'.")
"\nFor details, see ")
(widget-create 'custom-manual
:tag "Saving Customizations"
@@ -1582,6 +1590,26 @@ possibly because you started Emacs with `-q'.")
"(emacs)Top")
(widget-insert "."))
(widget-insert "\n")
+
+ ;; Insert the search field.
+ (when custom-search-field
+ (widget-insert "\n")
+ (let* ((echo "Search for custom items")
+ (search-widget
+ (widget-create
+ 'editable-field
+ :size 40 :help-echo echo
+ :action `(lambda (widget &optional event)
+ (customize-apropos (widget-value widget))))))
+ (widget-insert " ")
+ (widget-create-child-and-convert
+ search-widget 'push-button
+ :tag " Search "
+ :help-echo echo :action
+ (lambda (widget &optional event)
+ (customize-apropos (widget-value (widget-get widget :parent)))))
+ (widget-insert "\n")))
+
;; The custom command buttons are also in the toolbar, so for a
;; time they were not inserted in the buffer if the toolbar was in use.
;; But it can be a little confusing for the buffer layout to
@@ -1589,11 +1617,10 @@ possibly because you started Emacs with `-q'.")
;; mention that a custom buffer can in theory be created in a
;; frame with a toolbar, then later viewed in one without.
;; So now the buttons are always inserted in the buffer. (Bug#1326)
-;;; (when (not (and (bound-and-true-p tool-bar-mode) (display-graphic-p)))
(if custom-buffer-verbose-help
- (widget-insert "\n
- Operate on all settings in this buffer that are not marked HIDDEN:\n"))
- (let ((button (lambda (tag action active help icon)
+ (widget-insert "
+ Operate on all settings in this buffer:\n"))
+ (let ((button (lambda (tag action active help icon label)
(widget-insert " ")
(if (eval active)
(widget-create 'push-button :tag tag
@@ -1884,7 +1911,7 @@ something in this group has been edited but not set.")
SET for current session only." "\
something in this group has been set but not saved.")
(changed ":" custom-changed "\
-CHANGED outside Customize; operating on it here may be unreliable." "\
+CHANGED outside Customize." "\
something in this group has been changed outside customize.")
(saved "!" custom-saved "\
SAVED and set." "\
@@ -1988,68 +2015,70 @@ and `face'."
(nth 3 entry)))
(form (widget-get parent :custom-form))
children)
- (while (string-match "\\`\\(.*\\)%c\\(.*\\)\\'" text)
- (setq text (concat (match-string 1 text)
- (symbol-name category)
- (match-string 2 text))))
- (when (and custom-magic-show
- (or (not hidden)
- (memq category custom-magic-show-hidden)))
- (insert " ")
+ (unless (eq state 'hidden)
+ (while (string-match "\\`\\(.*\\)%c\\(.*\\)\\'" text)
+ (setq text (concat (match-string 1 text)
+ (symbol-name category)
+ (match-string 2 text))))
+ (when (and custom-magic-show
+ (or (not hidden)
+ (memq category custom-magic-show-hidden)))
+ (insert " ")
+ (when (and (eq category 'group)
+ (not (and (eq custom-buffer-style 'links)
+ (> (widget-get parent :custom-level) 1))))
+ (insert-char ?\ (* custom-buffer-indent
+ (widget-get parent :custom-level))))
+ (push (widget-create-child-and-convert
+ widget 'choice-item
+ :help-echo "Change the state of this item."
+ :format (if hidden "%t" "%[%t%]")
+ :button-prefix 'widget-push-button-prefix
+ :button-suffix 'widget-push-button-suffix
+ :mouse-down-action 'widget-magic-mouse-down-action
+ :tag " State ")
+ children)
+ (insert ": ")
+ (let ((start (point)))
+ (if (eq custom-magic-show 'long)
+ (insert text)
+ (insert (symbol-name state)))
+ (cond ((eq form 'lisp)
+ (insert " (lisp)"))
+ ((eq form 'mismatch)
+ (insert " (mismatch)")))
+ (put-text-property start (point) 'face 'custom-state))
+ (insert "\n"))
(when (and (eq category 'group)
(not (and (eq custom-buffer-style 'links)
(> (widget-get parent :custom-level) 1))))
(insert-char ?\ (* custom-buffer-indent
(widget-get parent :custom-level))))
- (push (widget-create-child-and-convert
- widget 'choice-item
- :help-echo "Change the state of this item."
- :format (if hidden "%t" "%[%t%]")
- :button-prefix 'widget-push-button-prefix
- :button-suffix 'widget-push-button-suffix
- :mouse-down-action 'widget-magic-mouse-down-action
- :tag "State")
- children)
- (insert ": ")
- (let ((start (point)))
- (if (eq custom-magic-show 'long)
- (insert text)
- (insert (symbol-name state)))
- (cond ((eq form 'lisp)
- (insert " (lisp)"))
- ((eq form 'mismatch)
- (insert " (mismatch)")))
- (put-text-property start (point) 'face 'custom-state))
- (insert "\n"))
- (when (and (eq category 'group)
- (not (and (eq custom-buffer-style 'links)
- (> (widget-get parent :custom-level) 1))))
- (insert-char ?\ (* custom-buffer-indent
- (widget-get parent :custom-level))))
- (when custom-magic-show-button
- (when custom-magic-show
- (let ((indent (widget-get parent :indent)))
- (when indent
- (insert-char ? indent))))
- (push (widget-create-child-and-convert
- widget 'choice-item
- :mouse-down-action 'widget-magic-mouse-down-action
- :button-face face
- :button-prefix ""
- :button-suffix ""
- :help-echo "Change the state."
- :format (if hidden "%t" "%[%t%]")
- :tag (if (memq form '(lisp mismatch))
- (concat "(" magic ")")
- (concat "[" magic "]")))
- children)
- (insert " "))
- (widget-put widget :children children)))
+ (when custom-magic-show-button
+ (when custom-magic-show
+ (let ((indent (widget-get parent :indent)))
+ (when indent
+ (insert-char ? indent))))
+ (push (widget-create-child-and-convert
+ widget 'choice-item
+ :mouse-down-action 'widget-magic-mouse-down-action
+ :button-face face
+ :button-prefix ""
+ :button-suffix ""
+ :help-echo "Change the state."
+ :format (if hidden "%t" "%[%t%]")
+ :tag (if (memq form '(lisp mismatch))
+ (concat "(" magic ")")
+ (concat "[" magic "]")))
+ children)
+ (insert " "))
+ (widget-put widget :children children))))
(defun custom-magic-reset (widget)
"Redraw the :custom-magic property of WIDGET."
(let ((magic (widget-get widget :custom-magic)))
- (widget-value-set magic (widget-value magic))))
+ (when magic
+ (widget-value-set magic (widget-value magic)))))
;;; The `custom' Widget.
@@ -2206,12 +2235,9 @@ and `face'."
(defun custom-show (widget value)
"Non-nil if WIDGET should be shown with VALUE by default."
(let ((show (widget-get widget :custom-show)))
- (cond ((null show)
- nil)
- ((eq t show)
- t)
- (t
- (funcall show widget value)))))
+ (if (functionp show)
+ (funcall show widget value)
+ show)))
(defun custom-load-widget (widget)
"Load all dependencies for WIDGET."
@@ -2289,8 +2315,7 @@ Insert PREFIX first if non-nil."
(insert ", "))))
(widget-put widget :buttons buttons))))
-(defun custom-add-parent-links (widget &optional initial-string
- doc-initial-string)
+(defun custom-add-parent-links (widget &optional initial-string doc-initial-string)
"Add \"Parent groups: ...\" to WIDGET if the group has parents.
The value is non-nil if any parents were found.
If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"."
@@ -2309,36 +2334,6 @@ If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"."
symbol)
buttons)
(setq parents (cons symbol parents)))))
- (and (null (get name 'custom-links)) ;No links of its own.
- (= (length parents) 1) ;A single parent.
- (let* ((links (delq nil (mapcar (lambda (w)
- (unless (eq (widget-type w)
- 'custom-group-link)
- w))
- (get (car parents) 'custom-links))))
- (many (> (length links) 2)))
- (when links
- (let ((pt (point))
- (left-margin (+ left-margin 2)))
- (insert "\n" (or doc-initial-string "Group documentation:") " ")
- (while links
- (push (widget-create-child-and-convert
- widget (car links)
- :button-face 'custom-link
- :mouse-face 'highlight
- :pressed-face 'highlight)
- buttons)
- (setq links (cdr links))
- (cond ((null links)
- (insert ".\n"))
- ((null (cdr links))
- (if many
- (insert ", and ")
- (insert " and ")))
- (t
- (insert ", "))))
- (fill-region-as-paragraph pt (point))
- (delete-to-left-margin (1+ pt) (+ pt 2))))))
(if parents
(insert "\n")
(delete-region start (point)))
@@ -2413,8 +2408,6 @@ If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"."
;;; The `custom-variable' Widget.
-;; When this was underlined blue, users confused it with a
-;; Mosaic-style hyperlink...
(defface custom-variable-tag
`((((class color)
(background dark))
@@ -2459,16 +2452,33 @@ However, setting it through Custom sets the default value.")
(documentation-property variable 'variable-documentation)))
(define-widget 'custom-variable 'custom
- "Customize variable."
+ "A widget for displaying a Custom variable.
+The following properties have special meanings for this widget:
+
+:hidden-states should be a list of widget states for which the
+ widget's initial contents are to be hidden.
+
+:custom-form should be a symbol describing how to display and
+ edit the variable---either `edit' (using edit widgets),
+ `lisp' (as a Lisp sexp), or `mismatch' (should not happen);
+ if nil, use the return value of `custom-variable-default-form'.
+
+:shown-value, if non-nil, should be a list whose `car' is the
+ variable value to display in place of the current value.
+
+:custom-style describes the widget interface style; nil is the
+ default style, while `simple' means a simpler interface that
+ inhibits the magic custom-state widget."
:format "%v"
:help-echo "Set or reset this variable."
:documentation-property #'custom-variable-documentation
:custom-category 'option
:custom-state nil
:custom-menu 'custom-variable-menu-create
- :custom-form nil ; defaults to value of `custom-variable-default-form'
+ :custom-form nil
:value-create 'custom-variable-value-create
:action 'custom-variable-action
+ :hidden-states '(standard)
:custom-set 'custom-variable-set
:custom-mark-to-save 'custom-variable-mark-to-save
:custom-reset-current 'custom-redraw
@@ -2503,7 +2513,6 @@ try matching its doc string against `custom-guess-doc-alist'."
(let* ((buttons (widget-get widget :buttons))
(children (widget-get widget :children))
(form (widget-get widget :custom-form))
- (state (widget-get widget :custom-state))
(symbol (widget-get widget :value))
(tag (widget-get widget :tag))
(type (custom-variable-type symbol))
@@ -2511,19 +2520,23 @@ try matching its doc string against `custom-guess-doc-alist'."
(get (or (get symbol 'custom-get) 'default-value))
(prefix (widget-get widget :custom-prefix))
(last (widget-get widget :custom-last))
- (value (if (default-boundp symbol)
- (funcall get symbol)
- (widget-get conv :value))))
- ;; If the widget is new, the child determines whether it is hidden.
- (cond (state)
- ((custom-show type value)
- (setq state 'unknown))
- (t
- (setq state 'hidden)))
+ (style (widget-get widget :custom-style))
+ (value (let ((shown-value (widget-get widget :shown-value)))
+ (cond (shown-value
+ (car shown-value))
+ ((default-boundp symbol)
+ (funcall get symbol))
+ (t (widget-get conv :value)))))
+ (state (or (widget-get widget :custom-state)
+ (if (memq (custom-variable-state symbol value)
+ (widget-get widget :hidden-states))
+ 'hidden))))
+
;; If we don't know the state, see if we need to edit it in lisp form.
+ (unless state
+ (setq state (if (custom-show type value) 'unknown 'hidden)))
(when (eq state 'unknown)
(unless (widget-apply conv :match value)
- ;; (widget-apply (widget-convert type) :match value)
(setq form 'mismatch)))
;; Now we can create the child widget.
(cond ((eq custom-buffer-style 'tree)
@@ -2536,21 +2549,36 @@ try matching its doc string against `custom-guess-doc-alist'."
((eq state 'hidden)
;; Indicate hidden value.
(push (widget-create-child-and-convert
+ widget 'custom-visibility
+ :help-echo "Show the value of this option."
+ :on-image "down"
+ :on "Hide"
+ :off-image "right"
+ :off "Show Value"
+ :action 'custom-toggle-hide-variable
+ nil)
+ buttons)
+ (insert " ")
+ (push (widget-create-child-and-convert
widget 'item
- :format "%{%t%}: "
+ :format "%{%t%} "
:sample-face 'custom-variable-tag
:tag tag
:parent widget)
- buttons)
- (push (widget-create-child-and-convert
- widget 'visibility
- :help-echo "Show the value of this option."
- :off "Show Value"
- :action 'custom-toggle-parent
- nil)
buttons))
((memq form '(lisp mismatch))
;; In lisp mode edit the saved value when possible.
+ (push (widget-create-child-and-convert
+ widget 'custom-visibility
+ :help-echo "Hide the value of this option."
+ :on "Hide"
+ :off "Show"
+ :on-image "down"
+ :off-image "right"
+ :action 'custom-toggle-hide-variable
+ t)
+ buttons)
+ (insert " ")
(let* ((value (cond ((get symbol 'saved-value)
(car (get symbol 'saved-value)))
((get symbol 'standard-value)
@@ -2561,15 +2589,6 @@ try matching its doc string against `custom-guess-doc-alist'."
(custom-quote (widget-get conv :value))))))
(insert (symbol-name symbol) ": ")
(push (widget-create-child-and-convert
- widget 'visibility
- :help-echo "Hide the value of this option."
- :on "Hide Value"
- :off "Show Value"
- :action 'custom-toggle-parent
- t)
- buttons)
- (insert " ")
- (push (widget-create-child-and-convert
widget 'sexp
:button-face 'custom-variable-button-face
:format "%v"
@@ -2579,6 +2598,17 @@ try matching its doc string against `custom-guess-doc-alist'."
children)))
(t
;; Edit mode.
+ (push (widget-create-child-and-convert
+ widget 'custom-visibility
+ :help-echo "Hide or show this option."
+ :on "Hide"
+ :off "Show"
+ :on-image "down"
+ :off-image "right"
+ :action 'custom-toggle-hide-variable
+ t)
+ buttons)
+ (insert " ")
(let* ((format (widget-get type :format))
tag-format value-format)
(unless (string-match ":" format)
@@ -2595,15 +2625,6 @@ try matching its doc string against `custom-guess-doc-alist'."
:sample-face 'custom-variable-tag
tag)
buttons)
- (insert " ")
- (push (widget-create-child-and-convert
- widget 'visibility
- :help-echo "Hide the value of this option."
- :on "Hide Value"
- :off "Show Value"
- :action 'custom-toggle-parent
- t)
- buttons)
(push (widget-create-child-and-convert
widget type
:format value-format
@@ -2613,15 +2634,18 @@ try matching its doc string against `custom-guess-doc-alist'."
(unless (eq (preceding-char) ?\n)
(widget-insert "\n"))
;; Create the magic button.
- (let ((magic (widget-create-child-and-convert
- widget 'custom-magic nil)))
- (widget-put widget :custom-magic magic)
- (push magic buttons))
+ (unless (eq style 'simple)
+ (let ((magic (widget-create-child-and-convert
+ widget 'custom-magic nil)))
+ (widget-put widget :custom-magic magic)
+ (push magic buttons)))
(widget-put widget :buttons buttons)
;; Insert documentation.
(widget-put widget :documentation-indent 3)
- (widget-add-documentation-string-button
- widget :visibility-widget 'custom-visibility)
+ (unless (and (eq style 'simple)
+ (eq state 'hidden))
+ (widget-add-documentation-string-button
+ widget :visibility-widget 'custom-visibility))
;; The comment field
(unless (eq state 'hidden)
@@ -2635,7 +2659,7 @@ try matching its doc string against `custom-guess-doc-alist'."
;; Don't push it !!! Custom assumes that the first child is the
;; value one.
(setq children (append children (list comment-widget)))))
- ;; Update the rest of the properties properties.
+ ;; Update the rest of the properties.
(widget-put widget :custom-form form)
(widget-put widget :children children)
;; Now update the state.
@@ -2648,6 +2672,31 @@ try matching its doc string against `custom-guess-doc-alist'."
(custom-add-parent-links widget))
(custom-add-see-also widget)))))
+(defun custom-toggle-hide-variable (visibility-widget &rest ignore)
+ "Toggle the visibility of a `custom-variable' parent widget.
+By default, this signals an error if the parent has unsaved
+changes. If the parent has a `simple' :custom-style property,
+the present value is saved to its :shown-value property instead."
+ (let ((widget (widget-get visibility-widget :parent)))
+ (unless (eq (widget-type widget) 'custom-variable)
+ (error "Invalid widget type"))
+ (custom-load-widget widget)
+ (let ((state (widget-get widget :custom-state)))
+ (if (eq state 'hidden)
+ (widget-put widget :custom-state 'unknown)
+ ;; In normal interface, widget can't be hidden if modified.
+ (when (memq state '(invalid modified set))
+ (if (eq (widget-get widget :custom-style) 'simple)
+ (widget-put widget :shown-value
+ (list (widget-value
+ (car-safe
+ (widget-get widget :children)))))
+ (error "There are unsaved changes")))
+ (widget-put widget :documentation-shown nil)
+ (widget-put widget :custom-state 'hidden))
+ (custom-redraw widget)
+ (widget-setup))))
+
(defun custom-tag-action (widget &rest args)
"Pass :action to first child of WIDGET's parent."
(apply 'widget-apply (car (widget-get (widget-get widget :parent) :children))
@@ -2658,61 +2707,69 @@ try matching its doc string against `custom-guess-doc-alist'."
(apply 'widget-apply (car (widget-get (widget-get widget :parent) :children))
:mouse-down-action args))
-(defun custom-variable-state-set (widget)
- "Set the state of WIDGET."
- (let* ((symbol (widget-value widget))
- (get (or (get symbol 'custom-get) 'default-value))
+(defun custom-variable-state (symbol val)
+ "Return the state of SYMBOL if its value is VAL.
+If SYMBOL has a non-nil `custom-get' property, it overrides VAL.
+Possible return values are `standard', `saved', `set', `themed',
+`changed', and `rogue'."
+ (let* ((get (or (get symbol 'custom-get) 'default-value))
(value (if (default-boundp symbol)
(funcall get symbol)
- (widget-get widget :value)))
+ val))
(comment (get symbol 'variable-comment))
tmp
- temp
- (state (cond ((progn (setq tmp (get symbol 'customized-value))
- (setq temp
- (get symbol 'customized-variable-comment))
- (or tmp temp))
- (if (condition-case nil
- (and (equal value (eval (car tmp)))
- (equal comment temp))
- (error nil))
- 'set
- 'changed))
- ((progn (setq tmp (get symbol 'theme-value))
- (setq temp (get symbol 'saved-variable-comment))
- (or tmp temp))
- (if (condition-case nil
- (and (equal comment temp)
- (equal value
- (eval
- (car (custom-variable-theme-value
- symbol)))))
- (error nil))
- (cond
- ((eq (caar tmp) 'user) 'saved)
- ((eq (caar tmp) 'changed)
- (if (condition-case nil
- (and (null comment)
- (equal value
- (eval
- (car (get symbol 'standard-value)))))
- (error nil))
- ;; The value was originally set outside
- ;; custom, but it was set to the standard
- ;; value (probably an autoloaded defcustom).
- 'standard
- 'changed))
- (t 'themed))
- 'changed))
- ((setq tmp (get symbol 'standard-value))
- (if (condition-case nil
- (and (equal value (eval (car tmp)))
- (equal comment nil))
- (error nil))
- 'standard
- 'changed))
- (t 'rogue))))
- (widget-put widget :custom-state state)))
+ temp)
+ (cond ((progn (setq tmp (get symbol 'customized-value))
+ (setq temp
+ (get symbol 'customized-variable-comment))
+ (or tmp temp))
+ (if (condition-case nil
+ (and (equal value (eval (car tmp)))
+ (equal comment temp))
+ (error nil))
+ 'set
+ 'changed))
+ ((progn (setq tmp (get symbol 'theme-value))
+ (setq temp (get symbol 'saved-variable-comment))
+ (or tmp temp))
+ (if (condition-case nil
+ (and (equal comment temp)
+ (equal value
+ (eval
+ (car (custom-variable-theme-value
+ symbol)))))
+ (error nil))
+ (cond
+ ((eq (caar tmp) 'user) 'saved)
+ ((eq (caar tmp) 'changed)
+ (if (condition-case nil
+ (and (null comment)
+ (equal value
+ (eval
+ (car (get symbol 'standard-value)))))
+ (error nil))
+ ;; The value was originally set outside
+ ;; custom, but it was set to the standard
+ ;; value (probably an autoloaded defcustom).
+ 'standard
+ 'changed))
+ (t 'themed))
+ 'changed))
+ ((setq tmp (get symbol 'standard-value))
+ (if (condition-case nil
+ (and (equal value (eval (car tmp)))
+ (equal comment nil))
+ (error nil))
+ 'standard
+ 'changed))
+ (t 'rogue))))
+
+(defun custom-variable-state-set (widget &optional state)
+ "Set the state of WIDGET to STATE.
+If STATE is nil, the value is computed by `custom-variable-state'."
+ (widget-put widget :custom-state
+ (or state (custom-variable-state (widget-value widget)
+ (widget-get widget :value)))))
(defun custom-variable-standard-value (widget)
(get (widget-value widget) 'standard-value))
@@ -2998,7 +3055,9 @@ to switch between two values."
:button-face 'custom-visibility
:pressed-face 'custom-visibility
:mouse-face 'highlight
- :pressed-face 'highlight)
+ :pressed-face 'highlight
+ :on-image nil
+ :off-image nil)
(defface custom-visibility
'((t :height 0.8 :inherit link))
@@ -3009,48 +3068,78 @@ to switch between two values."
;;; The `custom-face-edit' Widget.
(define-widget 'custom-face-edit 'checklist
- "Edit face attributes."
- :format "%t: %v"
- :tag "Attributes"
- :extra-offset 13
+ "Widget for editing face attributes.
+The following properties have special meanings for this widget:
+
+:value is a plist of face attributes.
+
+:default-face-attributes, if non-nil, is a plist of defaults for
+face attributes (as specified by a `default' defface entry)."
+ :format "%v"
+ :extra-offset 3
:button-args '(:help-echo "Control whether this attribute has any effect.")
:value-to-internal 'custom-face-edit-fix-value
:match (lambda (widget value)
(widget-checklist-match widget
(custom-face-edit-fix-value widget value)))
+ :value-create 'custom-face-edit-value-create
:convert-widget 'custom-face-edit-convert-widget
:args (mapcar (lambda (att)
- (list 'group
- :inline t
+ (list 'group :inline t
:sibling-args (widget-get (nth 1 att) :sibling-args)
(list 'const :format "" :value (nth 0 att))
(nth 1 att)))
custom-face-attributes))
+(defun custom-face-edit-value-create (widget)
+ (let* ((alist (widget-checklist-match-find
+ widget (widget-get widget :value)))
+ (args (widget-get widget :args))
+ (show-all (widget-get widget :show-all-attributes))
+ (buttons (widget-get widget :buttons))
+ (defaults (widget-checklist-match-find
+ widget
+ (widget-get widget :default-face-attributes)))
+ entry)
+ (unless (looking-back "^ *")
+ (insert ?\n))
+ (insert-char ?\s (widget-get widget :extra-offset))
+ (if (or alist defaults show-all)
+ (dolist (prop args)
+ (setq entry (or (assq prop alist)
+ (assq prop defaults)))
+ (if (or entry show-all)
+ (widget-checklist-add-item widget prop entry)))
+ (insert (propertize "-- Empty face --" 'face 'shadow) ?\n))
+ (let ((indent (widget-get widget :indent)))
+ (if indent (insert-char ?\s (widget-get widget :indent))))
+ (push (widget-create-child-and-convert
+ widget 'visibility
+ :help-echo "Show or hide all face attributes."
+ :button-face 'custom-visibility
+ :pressed-face 'custom-visibility
+ :mouse-face 'highlight
+ :on "Hide Unused Attributes" :off "Show All Attributes"
+ :on-image nil :off-image nil
+ :always-active t
+ :action 'custom-face-edit-value-visibility-action
+ show-all)
+ buttons)
+ (insert ?\n)
+ (widget-put widget :buttons buttons)
+ (widget-put widget :children (nreverse (widget-get widget :children)))))
+
+(defun custom-face-edit-value-visibility-action (widget &rest ignore)
+ ;; Toggle hiding of face attributes.
+ (let ((parent (widget-get widget :parent)))
+ (widget-put parent :show-all-attributes
+ (not (widget-get parent :show-all-attributes)))
+ (custom-redraw parent)))
+
(defun custom-face-edit-fix-value (widget value)
"Ignoring WIDGET, convert :bold and :italic in VALUE to new form.
Also change :reverse-video to :inverse-video."
- (if (listp value)
- (let (result)
- (while value
- (let ((key (car value))
- (val (car (cdr value))))
- (cond ((eq key :italic)
- (push :slant result)
- (push (if val 'italic 'normal) result))
- ((eq key :bold)
- (push :weight result)
- (push (if val 'bold 'normal) result))
- ((eq key :reverse-video)
- (push :inverse-video result)
- (push val result))
- (t
- (push key result)
- (push val result))))
- (setq value (cdr (cdr value))))
- (setq result (nreverse result))
- result)
- value))
+ (custom-fix-face-spec value))
(defun custom-face-edit-convert-widget (widget)
"Convert :args as widget types in WIDGET."
@@ -3064,6 +3153,9 @@ Also change :reverse-video to :inverse-video."
(widget-get widget :args)))
widget)
+(defconst custom-face-edit (widget-convert 'custom-face-edit)
+ "Converted version of the `custom-face-edit' widget.")
+
(defun custom-face-edit-deactivate (widget)
"Make face widget WIDGET inactive for user modifications."
(unless (widget-get widget :inactive)
@@ -3075,7 +3167,7 @@ Also change :reverse-video to :inverse-video."
(save-excursion
(goto-char from)
(widget-default-delete widget)
- (insert tag ": *\n")
+ (insert tag ": " (propertize "--" 'face 'shadow) "\n")
(widget-put widget :inactive
(cons value (cons from (- (point) from))))))))
@@ -3218,14 +3310,33 @@ Only match frames that support the specified face attributes.")
:version "20.3")
(define-widget 'custom-face 'custom
- "Customize face."
+ "Widget for customizing a face.
+The following properties have special meanings for this widget:
+
+:value is the face name (a symbol).
+
+:custom-form should be a symbol describing how to display and
+ edit the face attributes---either `selected' (attributes for
+ selected display only), `all' (all attributes), `lisp' (as a
+ Lisp sexp), or `mismatch' (should not happen); if nil, use
+ the return value of `custom-face-default-form'.
+
+:custom-style describes the widget interface style; nil is the
+ default style, while `simple' means a simpler interface that
+ inhibits the magic custom-state widget.
+
+:sample-indent, if non-nil, is the number of columns to which to
+ indent the face sample (an integer).
+
+:shown-value, if non-nil, is the face spec to display as the value
+ of the widget, instead of the current face spec."
:sample-face 'custom-face-tag
:help-echo "Set or reset this face."
:documentation-property #'face-doc-string
:value-create 'custom-face-value-create
:action 'custom-face-action
:custom-category 'face
- :custom-form nil ; defaults to value of `custom-face-default-form'
+ :custom-form nil
:custom-set 'custom-face-set
:custom-mark-to-save 'custom-face-mark-to-save
:custom-reset-current 'custom-redraw
@@ -3247,43 +3358,6 @@ Only match frames that support the specified face attributes.")
(defconst custom-face-all (widget-convert 'custom-face-all)
"Converted version of the `custom-face-all' widget.")
-(define-widget 'custom-display-unselected 'item
- "A display specification that doesn't match the selected display."
- :match 'custom-display-unselected-match)
-
-(defun custom-display-unselected-match (widget value)
- "Non-nil if VALUE is an unselected display specification."
- (not (face-spec-set-match-display value (selected-frame))))
-
-(define-widget 'custom-face-selected 'group
- "Edit the attributes of the selected display in a face specification."
- :args '((choice :inline t
- (group :tag "With Defaults" :inline t
- (group (const :tag "" default)
- (custom-face-edit :tag " Default\n Attributes"))
- (repeat :format ""
- :inline t
- (group custom-display-unselected sexp))
- (group (sexp :format "")
- (custom-face-edit :tag " Overriding\n Attributes"))
- (repeat :format ""
- :inline t
- sexp))
- (group :tag "No Defaults" :inline t
- (repeat :format ""
- :inline t
- (group custom-display-unselected sexp))
- (group (sexp :format "")
- (custom-face-edit :tag "\n Attributes"))
- (repeat :format ""
- :inline t
- sexp)))))
-
-
-
-(defconst custom-face-selected (widget-convert 'custom-face-selected)
- "Converted version of the `custom-face-selected' widget.")
-
(defun custom-filter-face-spec (spec filter-index &optional default-filter)
"Return a canonicalized version of SPEC using.
FILTER-INDEX is the index in the entry for each attribute in
@@ -3325,120 +3399,186 @@ SPEC must be a full face spec."
"Return the customized SPEC in a form suitable for setting the face."
(custom-filter-face-spec spec 3))
+(defun custom-face-widget-to-spec (widget)
+ "Return a face spec corresponding to WIDGET.
+WIDGET should be a `custom-face' widget."
+ (unless (eq (widget-type widget) 'custom-face)
+ (error "Invalid widget"))
+ (let ((child (car (widget-get widget :children))))
+ (custom-post-filter-face-spec
+ (if (eq (widget-type child) 'custom-face-edit)
+ `((t ,(widget-value child)))
+ (widget-value child)))))
+
+(defun custom-face-get-current-spec (face)
+ (let ((spec (or (get face 'customized-face)
+ (get face 'saved-face)
+ (get face 'face-defface-spec)
+ ;; Attempt to construct it.
+ `((t ,(custom-face-attributes-get
+ face (selected-frame)))))))
+ ;; If the user has changed this face in some other way,
+ ;; edit it as the user has specified it.
+ (if (not (face-spec-match-p face spec (selected-frame)))
+ (setq spec `((t ,(face-attr-construct face (selected-frame))))))
+ (custom-pre-filter-face-spec spec)))
+
+(defun custom-toggle-hide-face (visibility-widget &rest ignore)
+ "Toggle the visibility of a `custom-face' parent widget.
+By default, this signals an error if the parent has unsaved
+changes. If the parent has a `simple' :custom-style property,
+the present value is saved to its :shown-value property instead."
+ (let ((widget (widget-get visibility-widget :parent)))
+ (unless (eq (widget-type widget) 'custom-face)
+ (error "Invalid widget type"))
+ (custom-load-widget widget)
+ (let ((state (widget-get widget :custom-state)))
+ (if (eq state 'hidden)
+ (widget-put widget :custom-state 'unknown)
+ ;; In normal interface, widget can't be hidden if modified.
+ (when (memq state '(invalid modified set))
+ (if (eq (widget-get widget :custom-style) 'simple)
+ (widget-put widget :shown-value
+ (custom-face-widget-to-spec widget))
+ (error "There are unsaved changes")))
+ (widget-put widget :documentation-shown nil)
+ (widget-put widget :custom-state 'hidden))
+ (custom-redraw widget)
+ (widget-setup))))
+
(defun custom-face-value-create (widget)
"Create a list of the display specifications for WIDGET."
- (let ((buttons (widget-get widget :buttons))
- children
- (symbol (widget-get widget :value))
- (tag (widget-get widget :tag))
- (state (widget-get widget :custom-state))
- (begin (point))
- (is-last (widget-get widget :custom-last))
- (prefix (widget-get widget :custom-prefix)))
- (unless tag
- (setq tag (prin1-to-string symbol)))
- (cond ((eq custom-buffer-style 'tree)
- (insert prefix (if is-last " `--- " " |--- "))
- (push (widget-create-child-and-convert
- widget 'custom-browse-face-tag)
- buttons)
- (insert " " tag "\n")
- (widget-put widget :buttons buttons))
- (t
- ;; Create tag.
- (insert tag)
- (widget-specify-sample widget begin (point))
- (if (eq custom-buffer-style 'face)
- (insert " ")
- (if (string-match "face\\'" tag)
- (insert ":")
- (insert " face: ")))
- ;; Sample.
- (push (widget-create-child-and-convert widget 'item
- :format "(%{%t%})"
- :sample-face symbol
- :tag "sample")
- buttons)
- ;; Visibility.
- (insert " ")
- (push (widget-create-child-and-convert
- widget 'visibility
- :help-echo "Hide or show this face."
- :on "Hide Face"
- :off "Show Face"
- :action 'custom-toggle-parent
- (not (eq state 'hidden)))
- buttons)
- ;; Magic.
- (insert "\n")
- (let ((magic (widget-create-child-and-convert
- widget 'custom-magic nil)))
- (widget-put widget :custom-magic magic)
- (push magic buttons))
- ;; Update buttons.
- (widget-put widget :buttons buttons)
- ;; Insert documentation.
- (widget-put widget :documentation-indent 3)
- (widget-add-documentation-string-button
- widget :visibility-widget 'custom-visibility)
-
- ;; The comment field
- (unless (eq state 'hidden)
- (let* ((comment (get symbol 'face-comment))
- (comment-widget
- (widget-create-child-and-convert
- widget 'custom-comment
- :parent widget
- :value (or comment ""))))
- (widget-put widget :comment-widget comment-widget)
- (push comment-widget children)))
- ;; See also.
- (unless (eq state 'hidden)
- (when (eq (widget-get widget :custom-level) 1)
- (custom-add-parent-links widget))
- (custom-add-see-also widget))
- ;; Editor.
- (unless (eq (preceding-char) ?\n)
- (insert "\n"))
- (unless (eq state 'hidden)
- (message "Creating face editor...")
- (custom-load-widget widget)
- (unless (widget-get widget :custom-form)
- (widget-put widget :custom-form custom-face-default-form))
- (let* ((symbol (widget-value widget))
- (spec (or (get symbol 'customized-face)
- (get symbol 'saved-face)
- (get symbol 'face-defface-spec)
- ;; Attempt to construct it.
- (list (list t (custom-face-attributes-get
- symbol (selected-frame))))))
- (form (widget-get widget :custom-form))
- (indent (widget-get widget :indent))
- edit)
- ;; If the user has changed this face in some other way,
- ;; edit it as the user has specified it.
- (if (not (face-spec-match-p symbol spec (selected-frame)))
- (setq spec (list (list t (face-attr-construct symbol (selected-frame))))))
- (setq spec (custom-pre-filter-face-spec spec))
- (setq edit (widget-create-child-and-convert
- widget
- (cond ((and (eq form 'selected)
- (widget-apply custom-face-selected
- :match spec))
- (when indent (insert-char ?\ indent))
- 'custom-face-selected)
- ((and (not (eq form 'lisp))
- (widget-apply custom-face-all
- :match spec))
- 'custom-face-all)
- (t
- (when indent (insert-char ?\ indent))
- 'sexp))
- :value spec))
- (custom-face-state-set widget)
- (push edit children)
- (widget-put widget :children children))
- (message "Creating face editor...done"))))))
+ (let* ((buttons (widget-get widget :buttons))
+ (symbol (widget-get widget :value))
+ (tag (or (widget-get widget :tag)
+ (prin1-to-string symbol)))
+ (hiddenp (eq (widget-get widget :custom-state) 'hidden))
+ (style (widget-get widget :custom-style))
+ children)
+
+ (if (eq custom-buffer-style 'tree)
+
+ ;; Draw a tree-style `custom-face' widget
+ (progn
+ (insert (widget-get widget :custom-prefix)
+ (if (widget-get widget :custom-last) " `--- " " |--- "))
+ (push (widget-create-child-and-convert
+ widget 'custom-browse-face-tag)
+ buttons)
+ (insert " " tag "\n")
+ (widget-put widget :buttons buttons))
+
+ ;; Draw an ordinary `custom-face' widget
+ (let ((opoint (point)))
+ ;; Visibility indicator.
+ (push (widget-create-child-and-convert
+ widget 'custom-visibility
+ :help-echo "Hide or show this face."
+ :on "Hide" :off "Show"
+ :on-image "down" :off-image "right"
+ :action 'custom-toggle-hide-face
+ (not hiddenp))
+ buttons)
+ ;; Face name (tag).
+ (insert " " tag)
+ (widget-specify-sample widget opoint (point)))
+ (insert
+ (cond ((eq custom-buffer-style 'face) " ")
+ ((string-match "face\\'" tag) ":")
+ (t " face: ")))
+
+ ;; Face sample.
+ (let ((sample-indent (widget-get widget :sample-indent))
+ (indent-tabs-mode nil))
+ (and sample-indent
+ (<= (current-column) sample-indent)
+ (indent-to-column sample-indent)))
+ (push (widget-create-child-and-convert
+ widget 'item
+ :format "[%{%t%}]"
+ :sample-face (let ((spec (widget-get widget :shown-value)))
+ (if spec (face-spec-choose spec) symbol))
+ :tag "sample")
+ buttons)
+ (insert "\n")
+
+ ;; Magic.
+ (unless (eq (widget-get widget :custom-style) 'simple)
+ (let ((magic (widget-create-child-and-convert
+ widget 'custom-magic nil)))
+ (widget-put widget :custom-magic magic)
+ (push magic buttons)))
+
+ ;; Update buttons.
+ (widget-put widget :buttons buttons)
+
+ ;; Insert documentation.
+ (unless (and hiddenp (eq style 'simple))
+ (widget-put widget :documentation-indent 3)
+ (widget-add-documentation-string-button
+ widget :visibility-widget 'custom-visibility)
+ ;; The comment field
+ (unless hiddenp
+ (let* ((comment (get symbol 'face-comment))
+ (comment-widget
+ (widget-create-child-and-convert
+ widget 'custom-comment
+ :parent widget
+ :value (or comment ""))))
+ (widget-put widget :comment-widget comment-widget)
+ (push comment-widget children))))
+
+ ;; Editor.
+ (unless (eq (preceding-char) ?\n)
+ (insert "\n"))
+ (unless hiddenp
+ (custom-load-widget widget)
+ (unless (widget-get widget :custom-form)
+ (widget-put widget :custom-form custom-face-default-form))
+
+ (let* ((spec (or (widget-get widget :shown-value)
+ (custom-face-get-current-spec symbol)))
+ (form (widget-get widget :custom-form))
+ (indent (widget-get widget :indent))
+ face-alist face-entry spec-default spec-match editor)
+
+ ;; Find a display in SPEC matching the selected display.
+ ;; This will use the usual face customization interface.
+ (setq face-alist spec)
+ (when (eq (car-safe (car-safe face-alist)) 'default)
+ (setq spec-default (pop face-alist)))
+
+ (while (and face-alist (listp face-alist) (null spec-match))
+ (setq face-entry (car face-alist))
+ (and (listp face-entry)
+ (face-spec-set-match-display (car face-entry)
+ (selected-frame))
+ (widget-apply custom-face-edit :match (cadr face-entry))
+ (setq spec-match face-entry))
+ (setq face-alist (cdr face-alist)))
+
+ ;; Insert the appropriate editing widget.
+ (setq editor
+ (cond
+ ((and (eq form 'selected)
+ (or spec-match spec-default))
+ (when indent (insert-char ?\s indent))
+ (widget-create-child-and-convert
+ widget 'custom-face-edit
+ :value (cadr spec-match)
+ :default-face-attributes (cadr spec-default)))
+ ((and (not (eq form 'lisp))
+ (widget-apply custom-face-all :match spec))
+ (widget-create-child-and-convert
+ widget 'custom-face-all :value spec))
+ (t
+ (when indent
+ (insert-char ?\s indent))
+ (widget-create-child-and-convert
+ widget 'sexp :value spec))))
+ (custom-face-state-set widget)
+ (push editor children)
+ (widget-put widget :children children))))))
(defvar custom-face-menu
`(("Set for Current Session" custom-face-set)
@@ -3492,43 +3632,43 @@ widget. If FILTER is nil, ACTION is always valid.")
(widget-put widget :custom-form 'lisp)
(custom-redraw widget))
-(defun custom-face-state-set (widget)
- "Set the state of WIDGET."
- (let* ((symbol (widget-value widget))
- (comment (get symbol 'face-comment))
- tmp temp
+(defun custom-face-state (face)
+ "Return the current state of the face FACE.
+This is one of `set', `saved', `changed', `themed', or `rogue'."
+ (let* ((comment (get face 'face-comment))
(state
- (cond ((progn
- (setq tmp (get symbol 'customized-face))
- (setq temp (get symbol 'customized-face-comment))
- (or tmp temp))
- (if (equal temp comment)
- 'set
- 'changed))
- ((progn
- (setq tmp (get symbol 'saved-face))
- (setq temp (get symbol 'saved-face-comment))
- (or tmp temp))
- (if (equal temp comment)
- (cond
- ((eq 'user (caar (get symbol 'theme-face)))
- 'saved)
- ((eq 'changed (caar (get symbol 'theme-face)))
- 'changed)
- (t 'themed))
- 'changed))
- ((get symbol 'face-defface-spec)
- (if (equal comment nil)
- 'standard
- 'changed))
- (t
- 'rogue))))
- ;; If the user called set-face-attribute to change the default
- ;; for new frames, this face is "set outside of Customize".
+ (cond
+ ((or (get face 'customized-face)
+ (get face 'customized-face-comment))
+ (if (equal (get face 'customized-face-comment) comment)
+ 'set
+ 'changed))
+ ((or (get face 'saved-face)
+ (get face 'saved-face-comment))
+ (if (equal (get face 'saved-face-comment) comment)
+ (cond
+ ((eq 'user (caar (get face 'theme-face)))
+ 'saved)
+ ((eq 'changed (caar (get face 'theme-face)))
+ 'changed)
+ (t 'themed))
+ 'changed))
+ ((get face 'face-defface-spec)
+ (if (equal comment nil)
+ 'standard
+ 'changed))
+ (t 'rogue))))
+ ;; If the user called set-face-attribute to change the default for
+ ;; new frames, this face is "set outside of Customize".
(if (and (not (eq state 'rogue))
- (get symbol 'face-modified))
- (setq state 'changed))
- (widget-put widget :custom-state state)))
+ (get face 'face-modified))
+ 'changed
+ state)))
+
+(defun custom-face-state-set (widget)
+ "Set the state of WIDGET."
+ (widget-put widget :custom-state
+ (custom-face-state (widget-value widget))))
(defun custom-face-action (widget &optional event)
"Show the menu for `custom-face' WIDGET.
@@ -3548,8 +3688,7 @@ Optional EVENT is the location for the menu."
(defun custom-face-set (widget)
"Make the face attributes in WIDGET take effect."
(let* ((symbol (widget-value widget))
- (child (car (widget-get widget :children)))
- (value (custom-post-filter-face-spec (widget-value child)))
+ (value (custom-face-widget-to-spec widget))
(comment-widget (widget-get widget :comment-widget))
(comment (widget-value comment-widget)))
(when (equal comment "")
@@ -3571,8 +3710,7 @@ Optional EVENT is the location for the menu."
(defun custom-face-mark-to-save (widget)
"Mark for saving the face edited by WIDGET."
(let* ((symbol (widget-value widget))
- (child (car (widget-get widget :children)))
- (value (custom-post-filter-face-spec (widget-value child)))
+ (value (custom-face-widget-to-spec widget))
(comment-widget (widget-get widget :comment-widget))
(comment (widget-value comment-widget)))
(when (equal comment "")
@@ -3920,8 +4058,11 @@ If GROUPS-ONLY non-nil, return only those members that are groups."
(insert " " tag "\n")
(widget-put widget :buttons buttons)
(message "Creating group...")
- (let* ((members (custom-sort-items members
- custom-browse-sort-alphabetically
+ (let* ((members (custom-sort-items
+ members
+ ;; Never sort the top-level custom group.
+ (unless (eq symbol 'emacs)
+ custom-browse-sort-alphabetically)
custom-browse-order-groups))
(prefixes (widget-get widget :custom-prefixes))
(custom-prefix-list (custom-prefix-add symbol prefixes))
@@ -3979,17 +4120,21 @@ If GROUPS-ONLY non-nil, return only those members that are groups."
;; Nested style.
(t ;Visible.
+ ;; Draw a horizontal line (this works for both graphical
+ ;; and text displays):
+ (let ((p (point)))
+ (insert "\n")
+ (put-text-property p (1+ p) 'face '(:underline t))
+ (overlay-put (make-overlay p (1+ p))
+ 'before-string
+ (propertize "\n" 'face '(:underline t)
+ 'display '(space :align-to 999))))
+
;; Add parent groups references above the group.
- (if t ;;; This should test that the buffer
- ;;; was made to display a group.
- (when (eq level 1)
- (if (custom-add-parent-links widget
- "Parent groups:"
- "Parent group documentation:")
- (insert "\n"))))
- ;; Create level indicator.
+ (when (eq level 1)
+ (if (custom-add-parent-links widget "Parent groups:")
+ (insert "\n")))
(insert-char ?\ (* custom-buffer-indent (1- level)))
- (insert "/- ")
;; Create tag.
(let ((start (point)))
(insert tag " group: ")
@@ -4009,12 +4154,7 @@ If GROUPS-ONLY non-nil, return only those members that are groups."
(not (eq state 'hidden)))
buttons)
(insert " "))
- ;; Create more dashes.
- ;; Use 76 instead of 75 to compensate for the temporary "<"
- ;; added by `widget-insert'.
- (insert-char ?- (- 76 (current-column)
- (* custom-buffer-indent level)))
- (insert "\\\n")
+ (insert "\n")
;; Create magic button.
(let ((magic (widget-create-child-and-convert
widget 'custom-magic
@@ -4040,43 +4180,50 @@ If GROUPS-ONLY non-nil, return only those members that are groups."
?\ ))
;; Members.
(message "Creating group...")
- (let* ((members (custom-sort-items members
- custom-buffer-sort-alphabetically
- custom-buffer-order-groups))
+ (let* ((members (custom-sort-items
+ members
+ ;; Never sort the top-level custom group.
+ (unless (eq symbol 'emacs)
+ custom-buffer-sort-alphabetically)
+ custom-buffer-order-groups))
(prefixes (widget-get widget :custom-prefixes))
(custom-prefix-list (custom-prefix-add symbol prefixes))
- (length (length members))
+ (len (length members))
(count 0)
- (children (mapcar (lambda (entry)
- (widget-insert "\n")
- (message "\
-Creating group members... %2d%%"
- (/ (* 100.0 count) length))
- (setq count (1+ count))
- (prog1
- (widget-create-child-and-convert
- widget (nth 1 entry)
- :group widget
- :tag (custom-unlispify-tag-name
- (nth 0 entry))
- :custom-prefixes custom-prefix-list
- :custom-level (1+ level)
- :value (nth 0 entry))
- (unless (eq (preceding-char) ?\n)
- (widget-insert "\n"))))
- members)))
- (message "Creating group magic...")
+ (reporter (make-progress-reporter
+ "Creating group entries..." 0 len))
+ children)
+ (setq children
+ (mapcar
+ (lambda (entry)
+ (widget-insert "\n")
+ (progress-reporter-update reporter (setq count (1+ count)))
+ (let ((sym (nth 0 entry))
+ (type (nth 1 entry))
+ hidden-p)
+ (prog1
+ (widget-create-child-and-convert
+ widget type
+ :group widget
+ :tag (custom-unlispify-tag-name sym)
+ :custom-prefixes custom-prefix-list
+ :custom-level (1+ level)
+ :value sym)
+ (unless (eq (preceding-char) ?\n)
+ (widget-insert "\n")))))
+ members))
(mapc 'custom-magic-reset children)
- (message "Creating group state...")
(widget-put widget :children children)
(custom-group-state-update widget)
- (message "Creating group... done"))
+ (progress-reporter-done reporter))
;; End line
- (insert "\n")
- (insert-char ?\ (* custom-buffer-indent (1- level)))
- (insert "\\- " (widget-get widget :tag) " group end ")
- (insert-char ?- (- 75 (current-column) (* custom-buffer-indent level)))
- (insert "/\n")))))
+ (let ((p (1+ (point))))
+ (insert "\n\n")
+ (put-text-property p (1+ p) 'face '(:underline t))
+ (overlay-put (make-overlay p (1+ p))
+ 'before-string
+ (propertize "\n" 'face '(:underline t)
+ 'display '(space :align-to 999))))))))
(defvar custom-group-menu
`(("Set for Current Session" custom-group-set
@@ -4377,10 +4524,10 @@ This function does not save the buffer."
(unless (bolp)
(princ "\n"))
(princ "(custom-set-variables
- ;; custom-set-variables was added by Custom.
- ;; If you edit it by hand, you could mess it up, so be careful.
- ;; Your init file should contain only one such instance.
- ;; If there is more than one, they won't work right.\n")
+ ;; custom-set-variables was added by Custom.
+ ;; If you edit it by hand, you could mess it up, so be careful.
+ ;; Your init file should contain only one such instance.
+ ;; If there is more than one, they won't work right.\n")
(dolist (symbol saved-list)
(let ((spec (car-safe (get symbol 'theme-value)))
(value (get symbol 'saved-value))
@@ -4453,10 +4600,10 @@ This function does not save the buffer."
(unless (bolp)
(princ "\n"))
(princ "(custom-set-faces
- ;; custom-set-faces was added by Custom.
- ;; If you edit it by hand, you could mess it up, so be careful.
- ;; Your init file should contain only one such instance.
- ;; If there is more than one, they won't work right.\n")
+ ;; custom-set-faces was added by Custom.
+ ;; If you edit it by hand, you could mess it up, so be careful.
+ ;; Your init file should contain only one such instance.
+ ;; If there is more than one, they won't work right.\n")
(dolist (symbol saved-list)
(let ((spec (car-safe (get symbol 'theme-face)))
(value (get symbol 'saved-face))
@@ -4628,6 +4775,25 @@ If several parents are listed, go to the first of them."
(if (eq (widget-get (widget-get widget :parent) :custom-state) 'modified)
(message "To install your edits, invoke [State] and choose the Set operation")))
+(defun custom--initialize-widget-variables ()
+ (set (make-local-variable 'widget-documentation-face) 'custom-documentation)
+ (set (make-local-variable 'widget-button-face) custom-button)
+ (set (make-local-variable 'widget-button-pressed-face) custom-button-pressed)
+ (set (make-local-variable 'widget-mouse-face) custom-button-mouse)
+ ;; We need this because of the "More" button on docstrings.
+ ;; Otherwise clicking on "More" can push point offscreen, which
+ ;; causes the window to recenter on point, which pushes the
+ ;; newly-revealed docstring offscreen; which is annoying. -- cyd.
+ (set (make-local-variable 'widget-button-click-moves-point) t)
+ ;; When possible, use relief for buttons, not bracketing. This test
+ ;; may not be optimal.
+ (when custom-raised-buttons
+ (set (make-local-variable 'widget-push-button-prefix) "")
+ (set (make-local-variable 'widget-push-button-suffix) "")
+ (set (make-local-variable 'widget-link-prefix) "")
+ (set (make-local-variable 'widget-link-suffix) ""))
+ (setq show-trailing-whitespace nil))
+
(define-derived-mode Custom-mode nil "Custom"
"Major mode for editing customization buffers.
@@ -4659,33 +4825,13 @@ if that value is non-nil."
(mapc
(lambda (arg)
(tool-bar-local-item-from-menu
- (nth 1 arg) (nth 4 arg) map custom-mode-map))
+ (nth 1 arg) (nth 4 arg) map custom-mode-map
+ :label (nth 5 arg)))
custom-commands)
(setq custom-tool-bar-map map))))
(make-local-variable 'custom-options)
(make-local-variable 'custom-local-buffer)
- (make-local-variable 'widget-documentation-face)
- (setq widget-documentation-face 'custom-documentation)
- (make-local-variable 'widget-button-face)
- (setq widget-button-face custom-button)
- (setq show-trailing-whitespace nil)
-
- ;; We need this because of the "More" button on docstrings.
- ;; Otherwise clicking on "More" can push point offscreen, which
- ;; causes the window to recenter on point, which pushes the
- ;; newly-revealed docstring offscreen; which is annoying. -- cyd.
- (set (make-local-variable 'widget-button-click-moves-point) t)
-
- (set (make-local-variable 'widget-button-pressed-face) custom-button-pressed)
- (set (make-local-variable 'widget-mouse-face) custom-button-mouse)
-
- ;; When possible, use relief for buttons, not bracketing. This test
- ;; may not be optimal.
- (when custom-raised-buttons
- (set (make-local-variable 'widget-push-button-prefix) "")
- (set (make-local-variable 'widget-push-button-suffix) "")
- (set (make-local-variable 'widget-link-prefix) "")
- (set (make-local-variable 'widget-link-suffix) ""))
+ (custom--initialize-widget-variables)
(add-hook 'widget-edit-functions 'custom-state-buffer-message nil t))
(put 'Custom-mode 'mode-class 'special)
diff --git a/lisp/cus-face.el b/lisp/cus-face.el
index 5cb808c2e38..ebb20012afa 100644
--- a/lisp/cus-face.el
+++ b/lisp/cus-face.el
@@ -5,6 +5,7 @@
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, faces
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -318,42 +319,35 @@ SPEC itself is saved in FACE property `saved-face' and it is stored in
FACE's list property `theme-face' \(using `custom-push-theme')."
(custom-check-theme theme)
(let ((immediate (get theme 'theme-immediate)))
- (while args
- (let ((entry (car args)))
- (if (listp entry)
- (let ((face (nth 0 entry))
- (spec (nth 1 entry))
- (now (nth 2 entry))
- (comment (nth 3 entry))
- oldspec)
- ;; If FACE is actually an alias, customize the face it
- ;; is aliased to.
- (if (get face 'face-alias)
- (setq face (get face 'face-alias)))
-
- (setq oldspec (get face 'theme-face))
- (when (not (and oldspec (eq 'user (caar oldspec))))
- (put face 'saved-face spec)
- (put face 'saved-face-comment comment))
-
- (custom-push-theme 'theme-face face theme 'set spec)
- (when (or now immediate)
- (put face 'force-face (if now 'rogue 'immediate)))
- (when (or now immediate (facep face))
- (unless (facep face)
- (make-empty-face face))
- (put face 'face-comment comment)
- (put face 'face-override-spec nil)
- (face-spec-set face spec t))
- (setq args (cdr args)))
- ;; Old format, a plist of FACE SPEC pairs.
- (let ((face (nth 0 args))
- (spec (nth 1 args)))
- (if (get face 'face-alias)
- (setq face (get face 'face-alias)))
- (put face 'saved-face spec)
- (custom-push-theme 'theme-face face theme 'set spec))
- (setq args (cdr (cdr args))))))))
+ (dolist (entry args)
+ (unless (listp entry)
+ (error "Incompatible Custom theme spec"))
+ (let ((face (car entry))
+ (spec (nth 1 entry)))
+ ;; If FACE is actually an alias, customize the face it
+ ;; is aliased to.
+ (if (get face 'face-alias)
+ (setq face (get face 'face-alias)))
+ (if custom--inhibit-theme-enable
+ ;; Just update theme settings.
+ (custom-push-theme 'theme-face face theme 'set spec)
+ ;; Update theme settings and set the face spec.
+ (let ((now (nth 2 entry))
+ (comment (nth 3 entry))
+ (oldspec (get face 'theme-face)))
+ (when (not (and oldspec (eq 'user (caar oldspec))))
+ (put face 'saved-face spec)
+ (put face 'saved-face-comment comment))
+ ;; Do this AFTER checking the `theme-face' property.
+ (custom-push-theme 'theme-face face theme 'set spec)
+ (when (or now immediate)
+ (put face 'force-face (if now 'rogue 'immediate)))
+ (when (or now immediate (facep face))
+ (unless (facep face)
+ (make-empty-face face))
+ (put face 'face-comment comment)
+ (put face 'face-override-spec nil)
+ (face-spec-set face spec t))))))))
;; XEmacs compability function. In XEmacs, when you reset a Custom
;; Theme, you have to specify the theme to reset it to. We just apply
diff --git a/lisp/cus-start.el b/lisp/cus-start.el
index 0f686a434e0..91aa3edf384 100644
--- a/lisp/cus-start.el
+++ b/lisp/cus-start.el
@@ -1,10 +1,11 @@
;;; cus-start.el --- define customization properties of builtins
;;
-;; Copyright (C) 1997, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -33,6 +34,19 @@
;;; Code:
+;; Elements of this list have the form:
+;; SYMBOL GROUP TYPE VERSION REST...
+;; SYMBOL is the name of the variable.
+;; GROUP is the custom group to which it belongs (may also be a list
+;; of groups)
+;; TYPE is the defcustom :type.
+;; VERSION is the defcustom :version (or nil).
+;; REST is a set of :KEYWORD VALUE pairs. Accepted :KEYWORDs are:
+;; :standard - standard value for SYMBOL (else use current value)
+;; :set - custom-set property
+;; :risky - risky-local-variable property
+;; :safe - safe-local-variable property
+;; :tag - custom-tag property
(let ((all '(;; alloc.c
(gc-cons-threshold alloc integer)
(garbage-collection-messages alloc boolean)
@@ -95,6 +109,16 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of
"21.1")
(line-spacing display (choice (const :tag "none" nil) integer)
"22.1")
+ (cursor-in-non-selected-windows
+ cursor boolean nil
+ :tag "Cursor In Non-selected Windows"
+ :set #'(lambda (symbol value)
+ (set-default symbol value)
+ (force-mode-line-update t)))
+ (transient-mark-mode editing-basics boolean nil
+ :standard (not noninteractive)
+ :initialize custom-initialize-delay
+ :set custom-set-minor-mode)
;; callint.c
(mark-even-if-inactive editing-basics boolean)
;; callproc.c
@@ -165,6 +189,36 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of
;; fileio.c
(delete-by-moving-to-trash auto-save boolean "23.1")
(auto-save-visited-file-name auto-save boolean)
+ ;; filelock.c
+ (temporary-file-directory
+ ;; Darwin section added 24.1, does not seem worth :version bump.
+ files directory nil
+ :standard
+ (file-name-as-directory
+ ;; FIXME ? Should there be Ftemporary_file_directory to do this
+ ;; more robustly (cf set_local_socket in emacsclient.c).
+ ;; It could be used elsewhere, eg Fcall_process_region,
+ ;; server-socket-dir. See bug#7135.
+ (cond ((memq system-type '(ms-dos windows-nt))
+ (or (getenv "TEMP") (getenv "TMPDIR") (getenv "TMP")
+ "c:/temp"))
+ ((eq system-type 'darwin)
+ (or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP")
+ ;; See bug#7135.
+ (let ((tmp (ignore-errors
+ (shell-command-to-string
+ "getconf DARWIN_USER_TEMP_DIR"))))
+ (and (stringp tmp)
+ (setq tmp (replace-regexp-in-string
+ "\n\\'" "" tmp))
+ ;; Handles "getconf: Unrecognized variable..."
+ (file-directory-p tmp)
+ tmp))
+ "/tmp"))
+ (t
+ (or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP")
+ "/tmp"))))
+ :initialize custom-initialize-delay)
;; fns.c
(use-dialog-box menu boolean "21.1")
(use-file-dialog menu boolean "22.1")
@@ -179,6 +233,13 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of
(other :tag "hidden by keypress" 1))
"22.1")
(make-pointer-invisible mouse boolean "23.2")
+ (menu-bar-mode frames boolean nil
+ ;; FIXME?
+; :initialize custom-initialize-default
+ :set custom-set-minor-mode)
+ (tool-bar-mode (frames mouse) boolean nil
+; :initialize custom-initialize-default
+ :set custom-set-minor-mode)
;; fringe.c
(overflow-newline-into-fringe fringe boolean)
;; indent.c
@@ -197,6 +258,11 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of
(help-char keyboard character)
(help-event-list keyboard (repeat (sexp :format "%v")))
(menu-prompting menu boolean)
+ (select-active-regions killing
+ (choice (const :tag "always" t)
+ (const :tag "only shift-selection or mouse-drag" only)
+ (const :tag "off" nil))
+ "24.1")
(suggest-key-bindings keyboard (choice (const :tag "off" nil)
(integer :tag "time" 2)
(other :tag "on")))
@@ -254,12 +320,28 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of
(const control) (const meta)
(const alt) (const hyper)
(const super)) "23.1")
+ (ns-right-control-modifier
+ ns
+ (choice (const :tag "No modifier (work as control)" none)
+ (const :tag "Use the value of ns-control-modifier"
+ left)
+ (const control) (const meta)
+ (const alt) (const hyper)
+ (const super)) "24.0")
(ns-command-modifier
ns
(choice (const :tag "No modifier" nil)
(const control) (const meta)
(const alt) (const hyper)
(const super)) "23.1")
+ (ns-right-command-modifier
+ ns
+ (choice (const :tag "No modifier (work as command)" none)
+ (const :tag "Use the value of ns-command-modifier"
+ left)
+ (const control) (const meta)
+ (const alt) (const hyper)
+ (const super)) "24.0")
(ns-alternate-modifier
ns
(choice (const :tag "No modifier (work as alternate/option)" none)
@@ -321,6 +403,8 @@ since it could result in memory overflow and make Emacs crash."
(other :tag "Always" t))
"23.1")
;; xdisp.c
+ (show-trailing-whitespace whitespace-faces boolean nil
+ :safe booleanp)
(scroll-step windows integer)
(scroll-conservatively windows integer)
(scroll-margin windows integer)
@@ -347,6 +431,19 @@ since it could result in memory overflow and make Emacs crash."
(const :tag "Off (nil)" :value nil)
(const :tag "Immediate" :value t)
(number :tag "Delay by secs" :value 0.5)) "22.1")
+ (tool-bar-style
+ frames (choice
+ (const :tag "Images" :value image)
+ (const :tag "Text" :value text)
+ (const :tag "Both" :value both)
+ (const :tag "Both-horiz" :value both-horiz)
+ (const :tag "Text-image-horiz" :value text-image-horiz)
+ (const :tag "System default" :value nil)) "23.3")
+ (tool-bar-max-label-size frames integer "23.3")
+ (auto-hscroll-mode scrolling boolean "21.1")
+ (display-hourglass cursor boolean)
+ (hourglass-delay cursor number)
+
;; xfaces.c
(scalable-fonts-allowed display boolean "22.1")
;; xfns.c
@@ -356,13 +453,14 @@ since it could result in memory overflow and make Emacs crash."
(x-gtk-show-hidden-files menu boolean "22.1")
(x-gtk-file-dialog-help-text menu boolean "22.1")
(x-gtk-whole-detached-tool-bar x boolean "22.1")
+ (x-gtk-use-system-tooltips tooltip boolean "23.3")
;; xterm.c
(x-use-underline-position-properties display boolean "22.1")
(x-underline-at-descent-line display boolean "22.1")
(x-stretch-cursor display boolean "21.1")
;; xsettings.c
(font-use-system-font font-selection boolean "23.2")))
- this symbol group type standard version native-p
+ this symbol group type standard version native-p rest prop propval
;; This function turns a value
;; into an expression which produces that value.
(quoter (lambda (sexp)
@@ -381,12 +479,13 @@ since it could result in memory overflow and make Emacs crash."
group (nth 1 this)
type (nth 2 this)
version (nth 3 this)
+ rest (nthcdr 4 this)
;; If we did not specify any standard value expression above,
;; use the current value as the standard value.
- standard (if (nthcdr 4 this)
- (nth 4 this)
- (when (default-boundp symbol)
- (funcall quoter (default-value symbol))))
+ standard (if (setq prop (memq :standard rest))
+ (cadr prop)
+ (if (default-boundp symbol)
+ (funcall quoter (default-value symbol))))
;; Don't complain about missing variables which are
;; irrelevant to this platform.
native-p (save-match-data
@@ -407,6 +506,10 @@ since it could result in memory overflow and make Emacs crash."
(fboundp 'define-fringe-bitmap))
((equal "font-use-system-font" (symbol-name symbol))
(featurep 'system-font-setting))
+ ;; Conditioned on x-create-frame, because that's
+ ;; the condition for loadup.el to preload tool-bar.el.
+ ((string-match "tool-bar-" (symbol-name symbol))
+ (fboundp 'x-create-frame))
(t t))))
(if (not (boundp symbol))
;; If variables are removed from C code, give an error here!
@@ -415,25 +518,44 @@ since it could result in memory overflow and make Emacs crash."
;; Save the standard value, unless we already did.
(or (get symbol 'standard-value)
(put symbol 'standard-value (list standard)))
- ;; If this is NOT while dumping Emacs,
- ;; set up the rest of the customization info.
+ ;; We need these properties independent of whether cus-start is loaded.
+ (if (setq prop (memq :safe rest))
+ (put symbol 'safe-local-variable (cadr prop)))
+ (if (setq prop (memq :risky rest))
+ (put symbol 'risky-local-variable (cadr prop)))
+ (if (setq prop (memq :set rest))
+ (put symbol 'custom-set (cadr prop)))
+ ;; Note this is the _only_ initialize property we handle.
+ (if (eq (cadr (memq :initialize rest)) 'custom-initialize-delay)
+ (push symbol custom-delayed-init-variables))
+ ;; If this is NOT while dumping Emacs, set up the rest of the
+ ;; customization info. This is the stuff that is not needed
+ ;; until someone does M-x customize etc.
(unless purify-flag
- ;; Add it to the right group.
- (custom-add-to-group group symbol 'custom-variable)
+ ;; Add it to the right group(s).
+ (if (listp group)
+ (dolist (g group)
+ (custom-add-to-group g symbol 'custom-variable))
+ (custom-add-to-group group symbol 'custom-variable))
;; Set the type.
(put symbol 'custom-type type)
- (put symbol 'custom-version version)))))
+ (if version (put symbol 'custom-version version))
+ (while rest
+ (setq prop (car rest)
+ propval (cadr rest)
+ rest (nthcdr 2 rest))
+ (cond ((memq prop '(:standard :risky :safe :set))) ; handled above
+ ((eq prop :tag)
+ (put symbol 'custom-tag propval))))))))
(custom-add-to-group 'iswitchb 'read-buffer-function 'custom-variable)
(custom-add-to-group 'font-lock 'open-paren-in-column-0-is-defun-start
'custom-variable)
-;; Record cus-start as loaded
-;; if we have set up all the info that we can set up.
-;; Don't record cus-start as loaded
-;; if we have set up only the standard values.
+;; Record cus-start as loaded if we have set up all the info that we can.
+;; Don't record it as loaded if we have only set up the standard values
+;; and safe/risky properties.
(unless purify-flag
(provide 'cus-start))
-;; arch-tag: 4502730d-bcb3-4f5e-99a3-a86f2d54af60
;;; cus-start.el ends here
diff --git a/lisp/cus-theme.el b/lisp/cus-theme.el
index 0fb6e485de1..e6e286f00fa 100644
--- a/lisp/cus-theme.el
+++ b/lisp/cus-theme.el
@@ -6,6 +6,7 @@
;; Author: Alex Schroeder <alex@gnu.org>
;; Maintainer: FSF
;; Keywords: help, faces
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -34,318 +35,353 @@
(let ((map (make-keymap)))
(set-keymap-parent map widget-keymap)
(suppress-keymap map)
+ (define-key map "\C-x\C-s" 'custom-theme-write)
(define-key map "n" 'widget-forward)
(define-key map "p" 'widget-backward)
map)
"Keymap for `custom-new-theme-mode'.")
-(define-derived-mode custom-new-theme-mode nil "New-Theme"
- "Major mode for the buffer created by `customize-create-theme'.
-Do not call this mode function yourself. It is only meant for internal
-use by `customize-create-theme'."
+(define-derived-mode custom-new-theme-mode nil "Custom-Theme"
+ "Major mode for editing Custom themes.
+Do not call this mode function yourself. It is meant for internal use."
(use-local-map custom-new-theme-mode-map)
- (define-key custom-new-theme-mode-map [mouse-1] 'widget-move-and-invoke)
- (set (make-local-variable 'widget-documentation-face) 'custom-documentation)
- (set (make-local-variable 'widget-button-face) custom-button)
- (set (make-local-variable 'widget-button-pressed-face) custom-button-pressed)
- (set (make-local-variable 'widget-mouse-face) custom-button-mouse)
- (when custom-raised-buttons
- (set (make-local-variable 'widget-push-button-prefix) "")
- (set (make-local-variable 'widget-push-button-suffix) "")
- (set (make-local-variable 'widget-link-prefix) "")
- (set (make-local-variable 'widget-link-suffix) "")))
+ (custom--initialize-widget-variables)
+ (set (make-local-variable 'revert-buffer-function) 'custom-theme-revert))
(put 'custom-new-theme-mode 'mode-class 'special)
(defvar custom-theme-name nil)
+;; Each element has the form (VAR CHECKBOX-WIDGET VAR-WIDGET)
(defvar custom-theme-variables nil)
+;; Each element has the form (FACE CHECKBOX-WIDGET FACE-WIDGET)
(defvar custom-theme-faces nil)
-(defvar custom-theme-description)
-(defvar custom-theme-insert-variable-marker)
-(defvar custom-theme-insert-face-marker)
+(defvar custom-theme-description nil)
+(defvar custom-theme--migrate-settings nil)
+(defvar custom-theme-insert-variable-marker nil)
+(defvar custom-theme-insert-face-marker nil)
+
+(defvar custom-theme--listed-faces '(default cursor fixed-pitch
+ variable-pitch escape-glyph minibuffer-prompt highlight region
+ shadow secondary-selection trailing-whitespace
+ font-lock-builtin-face font-lock-comment-delimiter-face
+ font-lock-comment-face font-lock-constant-face
+ font-lock-doc-face font-lock-function-name-face
+ font-lock-keyword-face font-lock-negation-char-face
+ font-lock-preprocessor-face font-lock-regexp-grouping-backslash
+ font-lock-regexp-grouping-construct font-lock-string-face
+ font-lock-type-face font-lock-variable-name-face
+ font-lock-warning-face button link link-visited fringe
+ header-line tooltip mode-line mode-line-buffer-id
+ mode-line-emphasis mode-line-highlight mode-line-inactive
+ isearch isearch-fail lazy-highlight match next-error
+ query-replace)
+ "Faces listed by default in the *Custom Theme* buffer.")
+
+(defvar custom-theme--save-name)
;;;###autoload
-(defun customize-create-theme ()
- "Create a custom theme."
+(defun customize-create-theme (&optional theme buffer)
+ "Create or edit a custom theme.
+THEME, if non-nil, should be an existing theme to edit. If THEME
+is `user', provide an option to remove these as custom settings.
+BUFFER, if non-nil, should be a buffer to use; the default is
+named *Custom Theme*."
(interactive)
- (switch-to-buffer (generate-new-buffer "*New Custom Theme*"))
+ (switch-to-buffer (get-buffer-create (or buffer "*Custom Theme*")))
(let ((inhibit-read-only t))
- (erase-buffer))
+ (erase-buffer)
+ (dolist (ov (overlays-in (point-min) (point-max)))
+ (delete-overlay ov)))
(custom-new-theme-mode)
(make-local-variable 'custom-theme-name)
- (make-local-variable 'custom-theme-variables)
- (make-local-variable 'custom-theme-faces)
- (make-local-variable 'custom-theme-description)
- (make-local-variable 'custom-theme-insert-variable-marker)
+ (set (make-local-variable 'custom-theme--save-name) theme)
+ (set (make-local-variable 'custom-theme-faces) nil)
+ (set (make-local-variable 'custom-theme-variables) nil)
+ (set (make-local-variable 'custom-theme-description) "")
+ (set (make-local-variable 'custom-theme--migrate-settings) nil)
(make-local-variable 'custom-theme-insert-face-marker)
- (widget-insert "This buffer helps you write a custom theme elisp file.
-This will help you share your customizations with other people.
+ (make-local-variable 'custom-theme-insert-variable-marker)
+ (make-local-variable 'custom-theme--listed-faces)
+
+ (if (eq theme 'user)
+ (widget-insert "This buffer contains all the Custom settings you have made.
+You can convert them into a new custom theme, and optionally
+remove them from your saved Custom file.\n\n"))
-Insert the names of all variables and faces you want the theme to include.
-Invoke \"Save Theme\" to save the theme. The theme file will be saved to
-the directory " custom-theme-directory "\n\n")
(widget-create 'push-button
- :tag "Visit Theme"
+ :tag " Visit Theme "
:help-echo "Insert the settings of a pre-defined theme."
:action (lambda (widget &optional event)
(call-interactively 'custom-theme-visit-theme)))
(widget-insert " ")
(widget-create 'push-button
- :tag "Merge Theme"
+ :tag " Merge Theme "
:help-echo "Merge in the settings of a pre-defined theme."
:action (lambda (widget &optional event)
(call-interactively 'custom-theme-merge-theme)))
(widget-insert " ")
(widget-create 'push-button
- :notify (lambda (&rest ignore)
- (when (y-or-n-p "Discard current changes? ")
- (kill-buffer (current-buffer))
- (customize-create-theme)))
- "Reset Buffer")
- (widget-insert " ")
- (widget-create 'push-button
- :notify (function custom-theme-write)
- "Save Theme")
- (widget-insert "\n")
+ :tag " Revert "
+ :help-echo "Revert this buffer to its original state."
+ :action (lambda (&rest ignored) (revert-buffer)))
- (widget-insert "\n\nTheme name: ")
+ (widget-insert "\n\nTheme name : ")
(setq custom-theme-name
(widget-create 'editable-field
- :size 10
- user-login-name))
- (widget-insert "\n\nDocumentation:\n")
+ :value (if (and theme (not (eq theme 'user)))
+ (symbol-name theme)
+ "")))
+ (widget-insert "Description: ")
(setq custom-theme-description
(widget-create 'text
:value (format-time-string "Created %Y-%m-%d.")))
- (widget-insert "\n")
- (widget-create 'push-button
- :tag "Insert Variable"
- :help-echo "Add another variable to this theme."
- :action (lambda (widget &optional event)
- (call-interactively 'custom-theme-add-variable)))
- (widget-insert "\n")
- (setq custom-theme-insert-variable-marker (point-marker))
- (widget-insert "\n")
- (widget-create 'push-button
- :tag "Insert Face"
- :help-echo "Add another face to this theme."
- :action (lambda (widget &optional event)
- (call-interactively 'custom-theme-add-face)))
- (widget-insert "\n")
- (setq custom-theme-insert-face-marker (point-marker))
- (widget-insert "\n")
- (widget-create 'push-button
- :notify (lambda (&rest ignore)
- (when (y-or-n-p "Discard current changes? ")
- (kill-buffer (current-buffer))
- (customize-create-theme)))
- "Reset Buffer")
- (widget-insert " ")
(widget-create 'push-button
:notify (function custom-theme-write)
- "Save Theme")
- (widget-insert "\n")
- (widget-setup)
- (goto-char (point-min))
- (message ""))
+ " Save Theme ")
+ (when (eq theme 'user)
+ (setq custom-theme--migrate-settings t)
+ (widget-insert " ")
+ (widget-create 'checkbox
+ :value custom-theme--migrate-settings
+ :action (lambda (widget &optional event)
+ (when (widget-value widget)
+ (widget-toggle-action widget event)
+ (setq custom-theme--migrate-settings
+ (widget-value widget)))))
+ (widget-insert (propertize " Remove saved theme settings from Custom save file."
+ 'face '(variable-pitch (:height 0.9)))))
+
+ (let (vars values faces face-specs)
+
+ ;; Load the theme settings.
+ (when theme
+ (unless (eq theme 'user)
+ (load-theme theme t))
+ (dolist (setting (get theme 'theme-settings))
+ (if (eq (car setting) 'theme-value)
+ (progn (push (nth 1 setting) vars)
+ (push (nth 3 setting) values))
+ (push (nth 1 setting) faces)
+ (push (nth 3 setting) face-specs))))
+
+ ;; If THEME is non-nil, insert all of that theme's faces.
+ ;; Otherwise, insert those in `custom-theme--listed-faces'.
+ (widget-insert "\n\n Theme faces:\n ")
+ (if theme
+ (while faces
+ (custom-theme-add-face-1 (pop faces) (pop face-specs)))
+ (dolist (face custom-theme--listed-faces)
+ (custom-theme-add-face-1 face nil)))
+ (setq custom-theme-insert-face-marker (point-marker))
+ (widget-insert " ")
+ (widget-create 'push-button
+ :tag "Insert Additional Face"
+ :help-echo "Add another face to this theme."
+ :follow-link 'mouse-face
+ :button-face 'custom-link
+ :mouse-face 'highlight
+ :pressed-face 'highlight
+ :action (lambda (widget &optional event)
+ (call-interactively 'custom-theme-add-face)))
+
+ ;; If THEME is non-nil, insert all of that theme's variables.
+ (widget-insert "\n\n Theme variables:\n ")
+ (if theme
+ (while vars
+ (if (eq (car vars) 'custom-enabled-themes)
+ (progn (pop vars) (pop values))
+ (custom-theme-add-var-1 (pop vars) (pop values)))))
+ (setq custom-theme-insert-variable-marker (point-marker))
+ (widget-insert " ")
+ (widget-create 'push-button
+ :tag "Insert Variable"
+ :help-echo "Add another variable to this theme."
+ :follow-link 'mouse-face
+ :button-face 'custom-link
+ :mouse-face 'highlight
+ :pressed-face 'highlight
+ :action (lambda (widget &optional event)
+ (call-interactively 'custom-theme-add-variable)))
+ (widget-insert ?\n)
+ (widget-setup)
+ (goto-char (point-min))
+ (message "")))
+
+(defun custom-theme-revert (ignore-auto noconfirm)
+ (when (or noconfirm (y-or-n-p "Discard current changes? "))
+ (customize-create-theme custom-theme--save-name (current-buffer))))
;;; Theme variables
-(defun custom-theme-add-variable (symbol)
- (interactive "vVariable name: ")
- (cond ((assq symbol custom-theme-variables)
- (message "%s is already in the theme" (symbol-name symbol)))
- ((not (boundp symbol))
- (message "%s is not defined as a variable" (symbol-name symbol)))
- ((eq symbol 'custom-enabled-themes)
- (message "Custom theme cannot contain `custom-enabled-themes'"))
- (t
- (save-excursion
- (goto-char custom-theme-insert-variable-marker)
- (widget-insert "\n")
- (let ((widget (widget-create 'custom-variable
- :tag (custom-unlispify-tag-name symbol)
- :custom-level 0
- :action 'custom-theme-variable-action
- :custom-state 'unknown
- :value symbol)))
- (push (cons symbol widget) custom-theme-variables)
- (custom-magic-reset widget))
- (widget-setup)))))
-
-(defvar custom-theme-variable-menu
- `(("Reset to Current" custom-redraw
- (lambda (widget)
- (and (boundp (widget-value widget))
- (memq (widget-get widget :custom-state)
- '(themed modified changed)))))
- ("Reset to Theme Value" custom-variable-reset-theme
- (lambda (widget)
- (let ((theme (intern (widget-value custom-theme-name)))
- (symbol (widget-value widget))
- found)
- (and (custom-theme-p theme)
- (dolist (setting (get theme 'theme-settings) found)
- (if (and (eq (cadr setting) symbol)
- (eq (car setting) 'theme-value))
- (setq found t)))))))
- ("---" ignore ignore)
- ("Delete" custom-theme-delete-variable nil))
- "Alist of actions for the `custom-variable' widget in Custom Theme Mode.
-See the documentation for `custom-variable'.")
-
-(defun custom-theme-variable-action (widget &optional event)
- "Show the Custom Theme Mode menu for a `custom-variable' widget.
-Optional EVENT is the location for the menu."
- (let ((custom-variable-menu custom-theme-variable-menu))
- (custom-variable-action widget event)))
-
-(defun custom-variable-reset-theme (widget)
- "Reset WIDGET to its value for the currently edited theme."
- (let ((theme (intern (widget-value custom-theme-name)))
- (symbol (widget-value widget))
- found)
- (dolist (setting (get theme 'theme-settings))
- (if (and (eq (cadr setting) symbol)
- (eq (car setting) 'theme-value))
- (setq found setting)))
- (widget-value-set (car (widget-get widget :children))
- (nth 3 found)))
- (widget-put widget :custom-state 'themed)
- (custom-redraw-magic widget)
- (widget-setup))
-
-(defun custom-theme-delete-variable (widget)
- (setq custom-theme-variables
- (assq-delete-all (widget-value widget) custom-theme-variables))
- (widget-delete widget))
+(defun custom-theme-add-variable (var value)
+ "Add a widget for VAR (a symbol) to the *New Custom Theme* buffer.
+VALUE should be a value to which to set the widget; when called
+interactively, this defaults to the current value of VAR."
+ (interactive
+ (let ((v (read-variable "Variable name: ")))
+ (list v (symbol-value v))))
+ (let ((entry (assq var custom-theme-variables)))
+ (cond ((null entry)
+ ;; If VAR is not yet in the buffer, add it.
+ (save-excursion
+ (goto-char custom-theme-insert-variable-marker)
+ (custom-theme-add-var-1 var value)
+ (move-marker custom-theme-insert-variable-marker (point))
+ (widget-setup)))
+ ;; Otherwise, alter that var widget.
+ (t
+ (widget-value-set (nth 1 entry) t)
+ (let ((widget (nth 2 entry)))
+ (widget-put widget :shown-value (list value))
+ (custom-redraw widget))))))
+
+(defun custom-theme-add-var-1 (symbol val)
+ (widget-insert " ")
+ (push (list symbol
+ (prog1 (widget-create 'checkbox
+ :value t
+ :help-echo "Enable/disable this variable.")
+ (widget-insert " "))
+ (widget-create 'custom-variable
+ :tag (custom-unlispify-tag-name symbol)
+ :value symbol
+ :shown-value (list val)
+ :notify 'ignore
+ :custom-level 0
+ :custom-state 'hidden
+ :custom-style 'simple))
+ custom-theme-variables)
+ (widget-insert " "))
;;; Theme faces
-(defun custom-theme-add-face (symbol)
- (interactive (list (read-face-name "Face name" nil nil)))
- (cond ((assq symbol custom-theme-faces)
- (message "%s is already in the theme" (symbol-name symbol)))
- ((not (facep symbol))
- (message "%s is not defined as a face" (symbol-name symbol)))
- (t
- (save-excursion
- (goto-char custom-theme-insert-face-marker)
- (widget-insert "\n")
- (let ((widget (widget-create 'custom-face
- :tag (custom-unlispify-tag-name symbol)
- :custom-level 0
- :action 'custom-theme-face-action
- :custom-state 'unknown
- :value symbol)))
- (push (cons symbol widget) custom-theme-faces)
- (custom-magic-reset widget)
- (widget-setup))))))
-
-(defvar custom-theme-face-menu
- `(("Reset to Theme Value" custom-face-reset-theme
- (lambda (widget)
- (let ((theme (intern (widget-value custom-theme-name)))
- (symbol (widget-value widget))
- found)
- (and (custom-theme-p theme)
- (dolist (setting (get theme 'theme-settings) found)
- (if (and (eq (cadr setting) symbol)
- (eq (car setting) 'theme-face))
- (setq found t)))))))
- ("---" ignore ignore)
- ("Delete" custom-theme-delete-face nil))
- "Alist of actions for the `custom-variable' widget in Custom Theme Mode.
-See the documentation for `custom-variable'.")
-
-(defun custom-theme-face-action (widget &optional event)
- "Show the Custom Theme Mode menu for a `custom-face' widget.
-Optional EVENT is the location for the menu."
- (let ((custom-face-menu custom-theme-face-menu))
- (custom-face-action widget event)))
-
-(defun custom-face-reset-theme (widget)
- "Reset WIDGET to its value for the currently edited theme."
- (let ((theme (intern (widget-value custom-theme-name)))
- (symbol (widget-value widget))
- found)
- (dolist (setting (get theme 'theme-settings))
- (if (and (eq (cadr setting) symbol)
- (eq (car setting) 'theme-face))
- (setq found setting)))
- (widget-value-set (car (widget-get widget :children))
- (nth 3 found)))
- (widget-put widget :custom-state 'themed)
- (custom-redraw-magic widget)
- (widget-setup))
-
-(defun custom-theme-delete-face (widget)
- (setq custom-theme-faces
- (assq-delete-all (widget-value widget) custom-theme-faces))
- (widget-delete widget))
+(defun custom-theme-add-face (face &optional spec)
+ "Add a widget for FACE (a symbol) to the *New Custom Theme* buffer.
+SPEC, if non-nil, should be a face spec to which to set the widget."
+ (interactive (list (read-face-name "Face name" nil nil) nil))
+ (unless (or (facep face) spec)
+ (error "`%s' has no face definition" face))
+ (let ((entry (assq face custom-theme-faces)))
+ (cond ((null entry)
+ ;; If FACE is not yet in the buffer, add it.
+ (save-excursion
+ (goto-char custom-theme-insert-face-marker)
+ (custom-theme-add-face-1 face spec)
+ (move-marker custom-theme-insert-face-marker (point))
+ (widget-setup)))
+ ;; Otherwise, if SPEC is supplied, alter that face widget.
+ (spec
+ (widget-value-set (nth 1 entry) t)
+ (let ((widget (nth 2 entry)))
+ (widget-put widget :shown-value spec)
+ (custom-redraw widget)))
+ ((called-interactively-p 'interactive)
+ (error "`%s' is already present" face)))))
+
+(defun custom-theme-add-face-1 (symbol spec)
+ (widget-insert " ")
+ (push (list symbol
+ (prog1
+ (widget-create 'checkbox
+ :value t
+ :help-echo "Enable/disable this face.")
+ (widget-insert " "))
+ (widget-create 'custom-face
+ :tag (custom-unlispify-tag-name symbol)
+ :documentation-shown t
+ :value symbol
+ :custom-state 'hidden
+ :custom-style 'simple
+ :shown-value spec
+ :sample-indent 34))
+ custom-theme-faces)
+ (widget-insert " "))
;;; Reading and writing
-(defun custom-theme-visit-theme ()
- (interactive)
- (when (or (null custom-theme-variables)
- (if (y-or-n-p "Discard current changes? ")
- (progn (customize-create-theme) t)))
- (let ((theme (call-interactively 'custom-theme-merge-theme)))
- (unless (eq theme 'user)
- (widget-value-set custom-theme-name (symbol-name theme)))
- (widget-value-set custom-theme-description
- (or (get theme 'theme-documentation)
- (format-time-string "Created %Y-%m-%d.")))
- (widget-setup))))
+(defun custom-theme-visit-theme (theme)
+ "Load the custom theme THEME's settings into the current buffer."
+ (interactive
+ (list
+ (intern (completing-read "Find custom theme: "
+ (mapcar 'symbol-name
+ (custom-available-themes))))))
+ (unless (custom-theme-name-valid-p theme)
+ (error "No valid theme named `%s'" theme))
+ (cond ((not (eq major-mode 'custom-new-theme-mode))
+ (customize-create-theme theme))
+ ((y-or-n-p "Discard current changes? ")
+ (setq custom-theme--save-name theme)
+ (custom-theme-revert nil t))))
(defun custom-theme-merge-theme (theme)
- (interactive "SCustom theme name: ")
+ "Merge the custom theme THEME's settings into the current buffer."
+ (interactive
+ (list
+ (intern (completing-read "Merge custom theme: "
+ (mapcar 'symbol-name
+ (custom-available-themes))))))
(unless (eq theme 'user)
- (load-theme theme))
- (let ((settings (get theme 'theme-settings)))
+ (unless (custom-theme-name-valid-p theme)
+ (error "Invalid theme name `%s'" theme))
+ (load-theme theme t))
+ (let ((settings (reverse (get theme 'theme-settings))))
(dolist (setting settings)
- (if (eq (car setting) 'theme-value)
- (custom-theme-add-variable (cadr setting))
- (custom-theme-add-face (cadr setting)))))
- (disable-theme theme)
+ (funcall (if (eq (car setting) 'theme-value)
+ 'custom-theme-add-variable
+ 'custom-theme-add-face)
+ (nth 1 setting)
+ (nth 3 setting))))
theme)
(defun custom-theme-write (&rest ignore)
+ "Write the current custom theme to its theme file."
+ (interactive)
(let* ((name (widget-value custom-theme-name))
- (filename (expand-file-name (concat name "-theme.el")
- custom-theme-directory))
- (doc (widget-value custom-theme-description))
+ (doc (widget-value custom-theme-description))
(vars custom-theme-variables)
- (faces custom-theme-faces))
- (cond ((or (string-equal name "")
- (string-equal name "user")
- (string-equal name "changed"))
- (error "Custom themes cannot be named `%s'" name))
- ((string-match " " name)
- (error "Custom theme names should not contain spaces"))
- ((if (file-exists-p filename)
- (not (y-or-n-p
- (format "File %s exists. Overwrite? " filename))))
- (error "Aborted")))
+ (faces custom-theme-faces)
+ filename)
+ (when (string-equal name "")
+ (setq name (read-from-minibuffer "Theme name: " (user-login-name)))
+ (widget-value-set custom-theme-name name))
+ (unless (custom-theme-name-valid-p (intern name))
+ (error "Custom themes cannot be named `%s'" name))
+
+ (setq filename (expand-file-name (concat name "-theme.el")
+ custom-theme-directory))
+ (and (file-exists-p filename)
+ (not (y-or-n-p (format "File %s exists. Overwrite? " filename)))
+ (error "Aborted"))
+
(with-temp-buffer
(emacs-lisp-mode)
- (unless (file-exists-p custom-theme-directory)
+ (unless (file-directory-p custom-theme-directory)
(make-directory (file-name-as-directory custom-theme-directory) t))
(setq buffer-file-name filename)
(erase-buffer)
(insert "(deftheme " name)
(if doc (insert "\n \"" doc "\""))
(insert ")\n")
- (custom-theme-write-variables name vars)
- (custom-theme-write-faces name faces)
+ (custom-theme-write-variables name (reverse vars))
+ (custom-theme-write-faces name (reverse faces))
(insert "\n(provide-theme '" name ")\n")
(save-buffer))
- (dolist (var vars)
- (widget-put (cdr var) :custom-state 'saved)
- (custom-redraw-magic (cdr var)))
- (dolist (face faces)
- (widget-put (cdr face) :custom-state 'saved)
- (custom-redraw-magic (cdr face)))))
+ (message "Theme written to %s" filename)
+
+ (when custom-theme--migrate-settings
+ ;; Remove these settings from the Custom file.
+ (let ((custom-reset-standard-variables-list '(t))
+ (custom-reset-standard-faces-list '(t)))
+ (dolist (var vars)
+ (when (and (not (eq (car var) 'custom-enabled-themes))
+ (widget-get (nth 1 var) :value))
+ (widget-apply (nth 2 var) :custom-mark-to-reset-standard)))
+ (dolist (face faces)
+ (when (widget-get (nth 1 face) :value)
+ (widget-apply (nth 2 face) :custom-mark-to-reset-standard)))
+ (custom-save-all))
+ (let ((custom-theme-load-path (list 'custom-theme-directory)))
+ (load-theme (intern name))))))
(defun custom-theme-write-variables (theme vars)
"Write a `custom-theme-set-variables' command for THEME.
@@ -356,22 +392,23 @@ It includes all variables in list VARS."
(princ " '")
(princ theme)
(princ "\n")
- (mapc (lambda (spec)
- (let* ((symbol (car spec))
- (child (car-safe (widget-get (cdr spec) :children)))
- (value (if child
- (widget-value child)
- ;; For hidden widgets, use the standard value
- (get symbol 'standard-value))))
- (when (boundp symbol)
- (unless (bolp)
- (princ "\n"))
- (princ " '(")
- (prin1 symbol)
- (princ " ")
- (prin1 (custom-quote value))
- (princ ")"))))
- vars)
+ (dolist (spec vars)
+ (when (widget-get (nth 1 spec) :value)
+ (let* ((symbol (nth 0 spec))
+ (widget (nth 2 spec))
+ (child (car-safe (widget-get widget :children)))
+ (value (if child
+ (widget-value child)
+ ;; Child is null if the widget is closed (hidden).
+ (car (widget-get widget :shown-value)))))
+ (when (boundp symbol)
+ (unless (bolp)
+ (princ "\n"))
+ (princ " '(")
+ (prin1 symbol)
+ (princ " ")
+ (prin1 (custom-quote value))
+ (princ ")")))))
(if (bolp)
(princ " "))
(princ ")")
@@ -387,24 +424,244 @@ It includes all faces in list FACES."
(princ " '")
(princ theme)
(princ "\n")
- (mapc (lambda (spec)
- (let* ((symbol (car spec))
- (child (car-safe (widget-get (cdr spec) :children)))
- (value (if child (widget-value child))))
- (when (and (facep symbol) child)
- (unless (bolp)
- (princ "\n"))
- (princ " '(")
- (prin1 symbol)
- (princ " ")
- (prin1 value)
- (princ ")"))))
- faces)
- (if (bolp)
- (princ " "))
+ (dolist (spec faces)
+ (when (widget-get (nth 1 spec) :value)
+ (let* ((symbol (nth 0 spec))
+ (widget (nth 2 spec))
+ (value
+ (if (car-safe (widget-get widget :children))
+ (custom-face-widget-to-spec widget)
+ ;; Child is null if the widget is closed (hidden).
+ (widget-get widget :shown-value))))
+ (when (and (facep symbol) value)
+ (princ (if (bolp) " '(" "\n '("))
+ (prin1 symbol)
+ (princ " ")
+ (prin1 value)
+ (princ ")")))))
+ (if (bolp) (princ " "))
(princ ")")
(unless (looking-at "\n")
(princ "\n")))))
+
+;;; Describing Custom themes.
+
+;;;###autoload
+(defun describe-theme (theme)
+ "Display a description of the Custom theme THEME (a symbol)."
+ (interactive
+ (list
+ (intern (completing-read "Describe custom theme: "
+ (mapcar 'symbol-name
+ (custom-available-themes))))))
+ (unless (custom-theme-name-valid-p theme)
+ (error "Invalid theme name `%s'" theme))
+ (help-setup-xref (list 'describe-theme theme)
+ (called-interactively-p 'interactive))
+ (with-help-window (help-buffer)
+ (with-current-buffer standard-output
+ (describe-theme-1 theme))))
+
+(defun describe-theme-1 (theme)
+ (prin1 theme)
+ (princ " is a custom theme")
+ (let ((fn (locate-file (concat (symbol-name theme) "-theme.el")
+ (custom-theme--load-path)
+ '("" "c")))
+ doc)
+ (when fn
+ (princ " in `")
+ (help-insert-xref-button (file-name-nondirectory fn)
+ 'help-theme-def fn)
+ (princ "'"))
+ (princ ".\n")
+ (if (not (memq theme custom-known-themes))
+ (progn
+ (princ "It is not loaded.")
+ ;; Attempt to grab the theme documentation
+ (when fn
+ (with-temp-buffer
+ (insert-file-contents fn)
+ (let ((sexp (let ((read-circle nil))
+ (condition-case nil
+ (read (current-buffer))
+ (end-of-file nil)))))
+ (and sexp (listp sexp)
+ (eq (car sexp) 'deftheme)
+ (setq doc (nth 2 sexp)))))))
+ (if (custom-theme-enabled-p theme)
+ (princ "It is loaded and enabled.")
+ (princ "It is loaded but disabled."))
+ (setq doc (get theme 'theme-documentation)))
+
+ (princ "\n\nDocumentation:\n")
+ (princ (if (stringp doc)
+ doc
+ "No documentation available.")))
+ (princ "\n\nYou can ")
+ (help-insert-xref-button "customize" 'help-theme-edit theme)
+ (princ " this theme."))
+
+
+;;; Theme chooser
+
+(defvar custom--listed-themes)
+
+(defcustom custom-theme-allow-multiple-selections nil
+ "Whether to allow multi-selections in the *Custom Themes* buffer."
+ :type 'boolean
+ :group 'custom-buffer)
+
+(defvar custom-theme-choose-mode-map
+ (let ((map (make-keymap)))
+ (set-keymap-parent map widget-keymap)
+ (suppress-keymap map)
+ (define-key map "\C-x\C-s" 'custom-theme-save)
+ (define-key map "n" 'widget-forward)
+ (define-key map "p" 'widget-backward)
+ (define-key map "?" 'custom-describe-theme)
+ map)
+ "Keymap for `custom-theme-choose-mode'.")
+
+(define-derived-mode custom-theme-choose-mode nil "Themes"
+ "Major mode for selecting Custom themes.
+Do not call this mode function yourself. It is meant for internal use."
+ (use-local-map custom-theme-choose-mode-map)
+ (custom--initialize-widget-variables)
+ (set (make-local-variable 'revert-buffer-function)
+ (lambda (ignore-auto noconfirm)
+ (when (or noconfirm (y-or-n-p "Discard current choices? "))
+ (customize-themes (current-buffer))))))
+(put 'custom-theme-choose-mode 'mode-class 'special)
+
+;;;###autoload
+(defun customize-themes (&optional buffer)
+ "Display a selectable list of Custom themes.
+When called from Lisp, BUFFER should be the buffer to use; if
+omitted, a buffer named *Custom Themes* is used."
+ (interactive)
+ (pop-to-buffer (get-buffer-create (or buffer "*Custom Themes*")))
+ (let ((inhibit-read-only t))
+ (erase-buffer))
+ (custom-theme-choose-mode)
+ (set (make-local-variable 'custom--listed-themes) nil)
+ (make-local-variable 'custom-theme-allow-multiple-selections)
+ (and (null custom-theme-allow-multiple-selections)
+ (> (length custom-enabled-themes) 1)
+ (setq custom-theme-allow-multiple-selections t))
+
+ (widget-insert
+ (substitute-command-keys
+ "Type RET or click to enable/disable listed custom themes.
+Type \\[custom-describe-theme] to describe the theme at point.
+Theme files are named *-theme.el in `"))
+ (widget-create 'link :value "custom-theme-load-path"
+ :button-face 'custom-link
+ :mouse-face 'highlight
+ :pressed-face 'highlight
+ :help-echo "Describe `custom-theme-load-path'."
+ :keymap custom-mode-link-map
+ :follow-link 'mouse-face
+ :action (lambda (widget &rest ignore)
+ (describe-variable 'custom-theme-load-path)))
+ (widget-insert "'.\n\n")
+
+ ;; If the user has made customizations, display a warning and
+ ;; provide buttons to disable or convert them.
+ (let ((user-settings (get 'user 'theme-settings)))
+ (unless (or (null user-settings)
+ (and (null (cdr user-settings))
+ (eq (caar user-settings) 'theme-value)
+ (eq (cadr (car user-settings)) 'custom-enabled-themes)))
+ (widget-insert
+ (propertize
+ " Note: Your custom settings take precedence over theme settings.
+ To migrate your settings into a theme, click "
+ 'face 'font-lock-warning-face))
+ (widget-create 'link :value "here"
+ :button-face 'custom-link
+ :mouse-face 'highlight
+ :pressed-face 'highlight
+ :help-echo "Migrate."
+ :keymap custom-mode-link-map
+ :follow-link 'mouse-face
+ :action (lambda (widget &rest ignore)
+ (customize-create-theme 'user)))
+ (widget-insert ".\n\n")))
+
+ (widget-create 'push-button
+ :tag " Save Theme Settings "
+ :help-echo "Save the selected themes for future sessions."
+ :action 'custom-theme-save)
+ (widget-insert ?\n)
+ (widget-create 'checkbox
+ :value custom-theme-allow-multiple-selections
+ :action 'custom-theme-selections-toggle)
+ (widget-insert (propertize " Allow more than one theme at a time"
+ 'face '(variable-pitch (:height 0.9))))
+
+ (widget-insert "\n\nAvailable Custom Themes:\n")
+ (let (widget)
+ (dolist (theme (custom-available-themes))
+ (setq widget (widget-create 'checkbox
+ :value (custom-theme-enabled-p theme)
+ :theme-name theme
+ :action 'custom-theme-checkbox-toggle))
+ (push (cons theme widget) custom--listed-themes)
+ (widget-create-child-and-convert widget 'push-button
+ :button-face-get 'ignore
+ :mouse-face-get 'ignore
+ :value (format " %s" theme)
+ :action 'widget-parent-action)
+ (widget-insert ?\n)))
+ (goto-char (point-min))
+ (widget-setup))
+
+(defun custom-theme-checkbox-toggle (widget &optional event)
+ (let ((this-theme (widget-get widget :theme-name)))
+ (if (widget-value widget)
+ ;; Disable the theme.
+ (disable-theme this-theme)
+ ;; Enable the theme.
+ (unless custom-theme-allow-multiple-selections
+ ;; If only one theme is allowed, disable all other themes and
+ ;; uncheck their boxes.
+ (dolist (theme custom-enabled-themes)
+ (and (not (eq theme this-theme))
+ (assq theme custom--listed-themes)
+ (disable-theme theme)))
+ (dolist (theme custom--listed-themes)
+ (unless (eq (car theme) this-theme)
+ (widget-value-set (cdr theme) nil)
+ (widget-apply (cdr theme) :notify (cdr theme) event))))
+ (load-theme this-theme)))
+ ;; Mark `custom-enabled-themes' as "set for current session".
+ (put 'custom-enabled-themes 'customized-value
+ (list (custom-quote custom-enabled-themes)))
+ ;; Check/uncheck the widget.
+ (widget-toggle-action widget event))
+
+(defun custom-describe-theme ()
+ "Describe the Custom theme on the current line."
+ (interactive)
+ (let ((widget (widget-at (line-beginning-position))))
+ (and widget
+ (describe-theme (widget-get widget :theme-name)))))
+
+(defun custom-theme-save (&rest ignore)
+ (interactive)
+ (customize-save-variable 'custom-enabled-themes custom-enabled-themes)
+ (message "Custom themes saved for future sessions."))
+
+(defun custom-theme-selections-toggle (widget &optional event)
+ (when (widget-value widget)
+ ;; Deactivate multiple-selections.
+ (if (< 1 (length (delq nil (mapcar (lambda (x) (widget-value (cdr x)))
+ custom--listed-themes))))
+ (error "More than one theme is currently selected")))
+ (widget-toggle-action widget event)
+ (setq custom-theme-allow-multiple-selections (widget-value widget)))
+
;; arch-tag: cd6919bc-63af-410e-bae2-b6702e762344
;;; cus-theme.el ends here
diff --git a/lisp/custom.el b/lisp/custom.el
index 2484ee26f21..bcb78e46a3c 100644
--- a/lisp/custom.el
+++ b/lisp/custom.el
@@ -6,6 +6,7 @@
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Maintainer: FSF
;; Keywords: help, faces
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -143,7 +144,9 @@ set to nil, as the value is no longer rogue."
(when (get symbol 'force-value)
(put symbol 'force-value nil))
(when doc
- (put symbol 'variable-documentation doc))
+ (if (keywordp doc)
+ (error "Doc string is missing")
+ (put symbol 'variable-documentation doc)))
(let ((initialize 'custom-initialize-reset)
(requests nil))
(unless (memq :group args)
@@ -304,7 +307,7 @@ _outside_ any bindings for these variables. \(`defvar' and
See Info node `(elisp) Customization' in the Emacs Lisp manual
for more information."
- (declare (doc-string 3))
+ (declare (doc-string 3) (debug (name body)))
;; It is better not to use backquote in this file,
;; because that makes a bootstrapping problem
;; if you need to recompile all the Lisp files using interpreted code.
@@ -816,48 +819,80 @@ See `custom-known-themes' for a list of known themes."
(setting (assq theme old)) ; '(theme value)
(theme-settings ; '(prop symbol theme value)
(get theme 'theme-settings)))
- (if (eq mode 'reset)
- ;; Remove a setting.
- (when setting
- (let (res)
- (dolist (theme-setting theme-settings)
- (if (and (eq (car theme-setting) prop)
- (eq (cadr theme-setting) symbol))
- (setq res theme-setting)))
- (put theme 'theme-settings (delq res theme-settings)))
- (put symbol prop (delq setting old)))
- (if setting
- ;; Alter an existing setting.
- (let (res)
- (dolist (theme-setting theme-settings)
- (if (and (eq (car theme-setting) prop)
- (eq (cadr theme-setting) symbol))
- (setq res theme-setting)))
- (put theme 'theme-settings
- (cons (list prop symbol theme value)
- (delq res theme-settings)))
- (setcar (cdr setting) value))
- ;; Add a new setting.
+ (cond
+ ;; Remove a setting:
+ ((eq mode 'reset)
+ (when setting
+ (let (res)
+ (dolist (theme-setting theme-settings)
+ (if (and (eq (car theme-setting) prop)
+ (eq (cadr theme-setting) symbol))
+ (setq res theme-setting)))
+ (put theme 'theme-settings (delq res theme-settings)))
+ (put symbol prop (delq setting old))))
+ ;; Alter an existing setting:
+ (setting
+ (let (res)
+ (dolist (theme-setting theme-settings)
+ (if (and (eq (car theme-setting) prop)
+ (eq (cadr theme-setting) symbol))
+ (setq res theme-setting)))
+ (put theme 'theme-settings
+ (cons (list prop symbol theme value)
+ (delq res theme-settings)))
+ (setcar (cdr setting) value)))
+ ;; Add a new setting:
+ (t
+ (unless old
;; If the user changed the value outside of Customize, we
;; first save the current value to a fake theme, `changed'.
;; This ensures that the user-set value comes back if the
;; theme is later disabled.
- (if (null old)
- (if (and (eq prop 'theme-value)
- (boundp symbol))
- (let ((sv (get symbol 'standard-value)))
- (unless (and sv
- (equal (eval (car sv)) (symbol-value symbol)))
- (setq old (list (list 'changed (symbol-value symbol))))))
- (if (and (facep symbol)
- (not (face-spec-match-p symbol (get symbol 'face-defface-spec))))
- (setq old (list (list 'changed (list
- (append '(t) (custom-face-attributes-get symbol nil)))))))))
- (put symbol prop (cons (list theme value) old))
- (put theme 'theme-settings
- (cons (list prop symbol theme value)
- theme-settings))))))
-
+ (cond ((and (eq prop 'theme-value)
+ (boundp symbol))
+ (let ((sv (get symbol 'standard-value)))
+ (unless (and sv
+ (equal (eval (car sv)) (symbol-value symbol)))
+ (setq old (list (list 'changed (symbol-value symbol)))))))
+ ((and (facep symbol)
+ (not (face-attr-match-p
+ symbol
+ (custom-fix-face-spec
+ (face-spec-choose
+ (get symbol 'face-defface-spec))))))
+ (setq old `((changed
+ (,(append '(t) (custom-face-attributes-get
+ symbol nil)))))))))
+ (put symbol prop (cons (list theme value) old))
+ (put theme 'theme-settings
+ (cons (list prop symbol theme value) theme-settings))))))
+
+(defun custom-fix-face-spec (spec)
+ "Convert face SPEC, replacing obsolete :bold and :italic attributes.
+Also change :reverse-video to :inverse-video."
+ (when (listp spec)
+ (if (or (memq :bold spec)
+ (memq :italic spec)
+ (memq :inverse-video spec))
+ (let (result)
+ (while spec
+ (let ((key (car spec))
+ (val (car (cdr spec))))
+ (cond ((eq key :italic)
+ (push :slant result)
+ (push (if val 'italic 'normal) result))
+ ((eq key :bold)
+ (push :weight result)
+ (push (if val 'bold 'normal) result))
+ ((eq key :reverse-video)
+ (push :inverse-video result)
+ (push val result))
+ (t
+ (push key result)
+ (push val result))))
+ (setq spec (cddr spec)))
+ (nreverse result))
+ spec)))
(defun custom-set-variables (&rest args)
"Install user customizations of variable values specified in ARGS.
@@ -892,7 +927,7 @@ COMMENT is a comment string about SYMBOL.
EXP itself is saved unevaluated as SYMBOL property `saved-value' and
in SYMBOL's list property `theme-value' \(using `custom-push-theme')."
(custom-check-theme theme)
-
+
;; Process all the needed autoloads before anything else, so that the
;; subsequent code has all the info it needs (e.g. which var corresponds
;; to a minor mode), regardless of the ordering of the variables.
@@ -924,55 +959,45 @@ in SYMBOL's list property `theme-value' \(using `custom-push-theme')."
(t (or (nth 3 a2)
(eq (get sym2 'custom-set)
'custom-set-minor-mode))))))))
- (while args
- (let ((entry (car args)))
- (if (listp entry)
- (let* ((symbol (indirect-variable (nth 0 entry)))
- (value (nth 1 entry))
- (now (nth 2 entry))
- (requests (nth 3 entry))
- (comment (nth 4 entry))
- set)
- (when requests
- (put symbol 'custom-requests requests)
- (mapc 'require requests))
- (setq set (or (get symbol 'custom-set) 'custom-set-default))
- (put symbol 'saved-value (list value))
- (put symbol 'saved-variable-comment comment)
- (custom-push-theme 'theme-value symbol theme 'set value)
- ;; Allow for errors in the case where the setter has
- ;; changed between versions, say, but let the user know.
- (condition-case data
- (cond (now
- ;; Rogue variable, set it now.
- (put symbol 'force-value t)
- (funcall set symbol (eval value)))
- ((default-boundp symbol)
- ;; Something already set this, overwrite it.
- (funcall set symbol (eval value))))
- (error
- (message "Error setting %s: %s" symbol data)))
- (setq args (cdr args))
- (and (or now (default-boundp symbol))
- (put symbol 'variable-comment comment)))
- ;; I believe this is dead-code, because the `sort' code above would
- ;; have burped before we could get here. --Stef
- ;; Old format, a plist of SYMBOL VALUE pairs.
- (message "Warning: old format `custom-set-variables'")
- (ding)
- (sit-for 2)
- (let ((symbol (indirect-variable (nth 0 args)))
- (value (nth 1 args)))
+
+ (dolist (entry args)
+ (unless (listp entry)
+ (error "Incompatible Custom theme spec"))
+ (let* ((symbol (indirect-variable (nth 0 entry)))
+ (value (nth 1 entry)))
+ (custom-push-theme 'theme-value symbol theme 'set value)
+ (unless custom--inhibit-theme-enable
+ ;; Now set the variable.
+ (let* ((now (nth 2 entry))
+ (requests (nth 3 entry))
+ (comment (nth 4 entry))
+ set)
+ (when requests
+ (put symbol 'custom-requests requests)
+ (mapc 'require requests))
+ (setq set (or (get symbol 'custom-set) 'custom-set-default))
(put symbol 'saved-value (list value))
- (custom-push-theme 'theme-value symbol theme 'set value))
- (setq args (cdr (cdr args)))))))
+ (put symbol 'saved-variable-comment comment)
+ ;; Allow for errors in the case where the setter has
+ ;; changed between versions, say, but let the user know.
+ (condition-case data
+ (cond (now
+ ;; Rogue variable, set it now.
+ (put symbol 'force-value t)
+ (funcall set symbol (eval value)))
+ ((default-boundp symbol)
+ ;; Something already set this, overwrite it.
+ (funcall set symbol (eval value))))
+ (error
+ (message "Error setting %s: %s" symbol data)))
+ (and (or now (default-boundp symbol))
+ (put symbol 'variable-comment comment)))))))
;;; Defining themes.
-;; A theme file should be named `THEME-theme.el' (where THEME is the theme
-;; name), and found in either `custom-theme-directory' or the load path.
-;; It has the following format:
+;; A theme file is named `THEME-theme.el' (where THEME is the theme
+;; name) found in `custom-theme-load-path'. It has this format:
;;
;; (deftheme THEME
;; DOCSTRING)
@@ -1008,8 +1033,8 @@ see `custom-make-theme-feature' for more information."
"Like `deftheme', but THEME is evaluated as a normal argument.
FEATURE is the feature this theme provides. Normally, this is a symbol
created from THEME by `custom-make-theme-feature'."
- (if (memq theme '(user changed))
- (error "Custom theme cannot be named %S" theme))
+ (unless (custom-theme-name-valid-p theme)
+ (error "Custom theme cannot be named %S" theme))
(add-to-list 'custom-known-themes theme)
(put theme 'theme-feature feature)
(when doc (put theme 'theme-documentation doc)))
@@ -1027,49 +1052,150 @@ Every theme X has a property `provide-theme' whose value is \"X-theme\".
;;; Loading themes.
-(defcustom custom-theme-directory
- user-emacs-directory
- "Directory in which Custom theme files should be written.
-`load-theme' searches this directory in addition to load-path.
-The command `customize-create-theme' writes the files it produces
-into this directory."
+(defcustom custom-theme-directory user-emacs-directory
+ "Default user directory for storing custom theme files.
+The command `customize-create-theme' writes theme files into this
+directory. By default, Emacs searches for custom themes in this
+directory first---see `custom-theme-load-path'."
:type 'string
:group 'customize
:version "22.1")
+(defcustom custom-theme-load-path (list 'custom-theme-directory t)
+ "List of directories to search for custom theme files.
+When loading custom themes (e.g. in `customize-themes' and
+`load-theme'), Emacs searches for theme files in the specified
+order. Each element in the list should be one of the following:
+- the symbol `custom-theme-directory', meaning the value of
+ `custom-theme-directory'.
+- the symbol t, meaning the built-in theme directory (a directory
+ named \"themes\" in `data-directory').
+- a directory name (a string).
+
+Each theme file is named NAME-theme.el, where THEME is the theme
+name."
+ :type '(repeat (choice (const :tag "custom-theme-directory"
+ custom-theme-directory)
+ (const :tag "Built-in theme directory" t)
+ directory))
+ :group 'customize
+ :version "24.1")
+
+(defvar custom--inhibit-theme-enable nil
+ "If non-nil, loading a theme does not enable it.
+This internal variable is set by `load-theme' when its NO-ENABLE
+argument is non-nil, and it affects `custom-theme-set-variables',
+`custom-theme-set-faces', and `provide-theme'." )
+
(defun provide-theme (theme)
"Indicate that this file provides THEME.
This calls `provide' to provide the feature name stored in THEME's
property `theme-feature' (which is usually a symbol created by
`custom-make-theme-feature')."
- (if (memq theme '(user changed))
- (error "Custom theme cannot be named %S" theme))
+ (unless (custom-theme-name-valid-p theme)
+ (error "Custom theme cannot be named %S" theme))
(custom-check-theme theme)
(provide (get theme 'theme-feature))
- ;; Loading a theme also enables it.
- (push theme custom-enabled-themes)
- ;; `user' must always be the highest-precedence enabled theme.
- ;; Make that remain true. (This has the effect of making user settings
- ;; override the ones just loaded, too.)
- (let ((custom-enabling-themes t))
- (enable-theme 'user)))
-
-(defun load-theme (theme)
+ (unless custom--inhibit-theme-enable
+ ;; By default, loading a theme also enables it.
+ (push theme custom-enabled-themes)
+ ;; `user' must always be the highest-precedence enabled theme.
+ ;; Make that remain true. (This has the effect of making user
+ ;; settings override the ones just loaded, too.)
+ (let ((custom-enabling-themes t))
+ (enable-theme 'user))))
+
+(defvar safe-functions) ; From unsafep.el
+
+(defun load-theme (theme &optional no-enable)
"Load a theme's settings from its file.
-This also enables the theme; use `disable-theme' to disable it."
+Normally, this also enables the theme; use `disable-theme' to
+disable it. If optional arg NO-ENABLE is non-nil, don't enable
+the theme."
;; Note we do no check for validity of the theme here.
;; This allows to pull in themes by a file-name convention
- (interactive "SCustom theme name: ")
+ (interactive
+ (list
+ (intern (completing-read "Load custom theme: "
+ (mapcar 'symbol-name
+ (custom-available-themes))))))
+ (unless (custom-theme-name-valid-p theme)
+ (error "Invalid theme name `%s'" theme))
;; If reloading, clear out the old theme settings.
(when (custom-theme-p theme)
(disable-theme theme)
(put theme 'theme-settings nil)
(put theme 'theme-feature nil)
(put theme 'theme-documentation nil))
- (let ((load-path (if (file-directory-p custom-theme-directory)
- (cons custom-theme-directory load-path)
- load-path)))
- (load (symbol-name (custom-make-theme-feature theme)))))
+ (let ((fn (locate-file (concat (symbol-name theme) "-theme.el")
+ (custom-theme--load-path)
+ '("" "c"))))
+ (unless fn
+ (error "Unable to find theme file for `%s'." theme))
+ ;; Instead of simply loading the theme file, read it manually.
+ (with-temp-buffer
+ (insert-file-contents fn)
+ (require 'unsafep)
+ (let ((custom--inhibit-theme-enable no-enable)
+ (safe-functions (append '(custom-theme-set-variables
+ custom-theme-set-faces)
+ safe-functions))
+ form scar)
+ (while (setq form (let ((read-circle nil))
+ (condition-case nil
+ (read (current-buffer))
+ (end-of-file nil))))
+ (cond
+ ;; Check `deftheme' expressions.
+ ((eq (setq scar (car form)) 'deftheme)
+ (unless (eq (cadr form) theme)
+ (error "Incorrect theme name in `deftheme'"))
+ (and (symbolp (nth 1 form))
+ (stringp (nth 2 form))
+ (eval (list scar (nth 1 form) (nth 2 form)))))
+ ;; Check `provide-theme' expressions.
+ ((and (eq scar 'provide-theme)
+ (equal (cadr form) `(quote ,theme))
+ (= (length form) 2))
+ (eval form))
+ ;; All other expressions need to be safe.
+ ((not (unsafep form))
+ (eval form))))))))
+
+(defun custom-theme-name-valid-p (name)
+ "Return t if NAME is a valid name for a Custom theme, nil otherwise.
+NAME should be a symbol."
+ (and (symbolp name)
+ name
+ (not (or (zerop (length (symbol-name name)))
+ (eq name 'user)
+ (eq name 'changed)))))
+
+(defun custom-available-themes ()
+ "Return a list of available Custom themes (symbols)."
+ (let* (sym themes)
+ (dolist (dir (custom-theme--load-path))
+ (when (file-directory-p dir)
+ (dolist (file (file-expand-wildcards
+ (expand-file-name "*-theme.el" dir) t))
+ (setq file (file-name-nondirectory file))
+ (and (string-match "\\`\\(.+\\)-theme.el\\'" file)
+ (setq sym (intern (match-string 1 file)))
+ (custom-theme-name-valid-p sym)
+ (push sym themes)))))
+ (delete-dups themes)))
+
+(defun custom-theme--load-path ()
+ (let (lpath)
+ (dolist (f custom-theme-load-path)
+ (cond ((eq f 'custom-theme-directory)
+ (setq f custom-theme-directory))
+ ((eq f t)
+ (setq f (expand-file-name "themes" data-directory))))
+ (if (file-directory-p f)
+ (push f lpath)))
+ (nreverse lpath)))
+
;;; Enabling and disabling loaded themes.
@@ -1082,7 +1208,10 @@ If it is already enabled, just give it highest precedence (after `user').
If THEME does not specify any theme settings, this tries to load
the theme from its theme file, by calling `load-theme'."
- (interactive "SEnable Custom theme: ")
+ (interactive (list (intern
+ (completing-read
+ "Enable custom theme: "
+ obarray (lambda (sym) (get sym 'theme-settings))))))
(if (not (custom-theme-p theme))
(load-theme theme)
;; This could use a bit of optimization -- cyd
@@ -1108,7 +1237,8 @@ This does not include the `user' theme, which is set by Customize,
and always takes precedence over other Custom Themes."
:group 'customize
:type '(repeat symbol)
- :set-after '(custom-theme-directory) ; so we can find the themes
+ :set-after '(custom-theme-directory custom-theme-load-path)
+ :risky t
:set (lambda (symbol themes)
;; Avoid an infinite loop when custom-enabled-themes is
;; defined in a theme (e.g. `user'). Enabling the theme sets
@@ -1140,21 +1270,27 @@ and always takes precedence over other Custom Themes."
See `custom-enabled-themes' for a list of enabled themes."
(interactive (list (intern
(completing-read
- "Disable Custom theme: "
+ "Disable custom theme: "
(mapcar 'symbol-name custom-enabled-themes)
nil t))))
(when (custom-theme-enabled-p theme)
(let ((settings (get theme 'theme-settings)))
(dolist (s settings)
- (let* ((prop (car s))
+ (let* ((prop (car s))
(symbol (cadr s))
- (spec-list (get symbol prop)))
- (put symbol prop (assq-delete-all theme spec-list))
- (if (eq prop 'theme-value)
- (custom-theme-recalc-variable symbol)
+ (val (assq-delete-all theme (get symbol prop))))
+ (put symbol prop val)
+ (cond
+ ((eq prop 'theme-value)
+ (custom-theme-recalc-variable symbol))
+ ((eq prop 'theme-face)
+ ;; If the face spec specified by this theme is in the
+ ;; saved-face property, reset that property.
+ (when (equal (nth 3 s) (get symbol 'saved-face))
+ (put symbol 'saved-face (and val (cadr (car val)))))
(custom-theme-recalc-face symbol)))))
- (setq custom-enabled-themes
- (delq theme custom-enabled-themes))))
+ (setq custom-enabled-themes
+ (delq theme custom-enabled-themes)))))
(defun custom-variable-theme-value (variable)
"Return (list VALUE) indicating the custom theme value of VARIABLE.
@@ -1180,10 +1316,12 @@ This function returns nil if no custom theme specifies a value for VARIABLE."
(defun custom-theme-recalc-face (face)
"Set FACE according to currently enabled custom themes."
- (if (facep face)
- (face-spec-set face
- (get (or (get face 'face-alias) face)
- 'face-override-spec))))
+ (if (get face 'face-alias)
+ (setq face (get face 'face-alias)))
+ ;; Reset the faces for each frame.
+ (dolist (frame (frame-list))
+ (face-spec-recalc face frame)))
+
;;; XEmacs compability functions
diff --git a/lisp/descr-text.el b/lisp/descr-text.el
index 250d87a6ae6..93c69e0eea5 100644
--- a/lisp/descr-text.el
+++ b/lisp/descr-text.el
@@ -618,7 +618,7 @@ as well as widgets, buttons, overlays, and text properties."
,@(if (not eight-bit-p)
(let ((unicodedata (describe-char-unicode-data char)))
(if unicodedata
- (cons (list "Unicode data" " ") unicodedata))))))
+ (cons (list "Unicode data" "") unicodedata))))))
(setq max-width (apply 'max (mapcar (lambda (x)
(if (cadr x) (length (car x)) 0))
item-list)))
@@ -642,7 +642,8 @@ as well as widgets, buttons, overlays, and text properties."
(window-width))
(insert "\n")
(indent-to (1+ max-width)))
- (insert " " clm)))
+ (unless (zerop (length clm))
+ (insert " " clm))))
(insert "\n"))))
(when overlays
diff --git a/lisp/desktop.el b/lisp/desktop.el
index c247565af20..b4d3dfd55c8 100644
--- a/lisp/desktop.el
+++ b/lisp/desktop.el
@@ -622,7 +622,10 @@ is nil, ask the user where to save the desktop."
(when (and desktop-save-mode
(let ((exists (file-exists-p (desktop-full-file-name))))
(or (eq desktop-save t)
- (and exists (memq desktop-save '(ask-if-new if-exists)))
+ (and exists (eq desktop-save 'if-exists))
+ ;; If it exists, but we aren't using it, we are going
+ ;; to ask for a new directory below.
+ (and exists desktop-dirname (eq desktop-save 'ask-if-new))
(and
(or (memq desktop-save '(ask ask-if-new))
(and exists (eq desktop-save 'ask-if-exists)))
diff --git a/lisp/dframe.el b/lisp/dframe.el
index bfa672cdec5..9ca0a260f6d 100644
--- a/lisp/dframe.el
+++ b/lisp/dframe.el
@@ -1,7 +1,8 @@
;;; dframe --- dedicate frame support modes
-;;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+;; 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: file, tags, tools
@@ -430,7 +431,8 @@ a cons cell indicating a position of the form (LEFT . TOP)."
(unless (or (not window-system) (eq window-system 'pc))
(let* ((pfx (dframe-frame-parameter parent-frame 'left))
(pfy (dframe-frame-parameter parent-frame 'top))
- (pfw (frame-pixel-width parent-frame))
+ (pfw (+ (tool-bar-pixel-width parent-frame)
+ (frame-pixel-width parent-frame)))
(pfh (frame-pixel-height parent-frame))
(nfw (frame-pixel-width new-frame))
(nfh (frame-pixel-height new-frame))
@@ -459,7 +461,7 @@ a cons cell indicating a position of the form (LEFT . TOP)."
(- (x-display-pixel-height) (car (cdr pfy)) pfh)
(car (cdr pfy)))))
(cond ((eq location 'right)
- (setq newleft (+ pfx pfw 5)
+ (setq newleft (+ pfx pfw 10)
newtop pfy))
((eq location 'left)
(setq newleft (- pfx 10 nfw)
@@ -471,7 +473,7 @@ a cons cell indicating a position of the form (LEFT . TOP)."
;; extra 10 is just dressings for window
;; decorations.
(let* ((left-guess (- pfx 10 nfw))
- (right-guess (+ pfx pfw 5))
+ (right-guess (+ pfx pfw 10))
(left-margin left-guess)
(right-margin (- (x-display-pixel-width)
right-guess 5 nfw)))
@@ -783,8 +785,8 @@ Must be bound to EVENT."
(popup-mode-menu event)
(goto-char (event-closest-point event))
(beginning-of-line)
- (forward-char (min 5 (- (save-excursion (end-of-line) (point))
- (save-excursion (beginning-of-line) (point)))))
+ (forward-char (min 5 (- (line-end-position)
+ (line-beginning-position))))
(popup-mode-menu))
;; Wait for menu to bail out. `popup-mode-menu' (and other popup
;; menu functions) return immediately.
@@ -990,5 +992,4 @@ mode-line. This is only useful for non-XEmacs."
(provide 'dframe)
-;; arch-tag: df9b91b6-e85e-4a76-a02e-b3cb5b686bd4
;;; dframe.el ends here
diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el
index 62d6928c024..764d13f5a9c 100644
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -1,11 +1,13 @@
;;; dired-aux.el --- less commonly used parts of dired
;; Copyright (C) 1985, 1986, 1992, 1994, 1998, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Sebastian Kremer <sk@thp.uni-koeln.de>.
;; Maintainer: FSF
;; Keywords: files
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -699,7 +701,7 @@ can be produced by `dired-get-marked-files', for example."
(save-excursion (and file
(dired-goto-subdir file)
(dired-kill-subdir)))
- (delete-region (progn (beginning-of-line) (point))
+ (delete-region (line-beginning-position)
(progn (forward-line 1) (point)))
(if (> arg 0)
(setq arg (1- arg))
@@ -733,7 +735,7 @@ command with a prefix argument (the value does not matter)."
(while (and (not (eobp))
(re-search-forward regexp nil t))
(setq count (1+ count))
- (delete-region (progn (beginning-of-line) (point))
+ (delete-region (line-beginning-position)
(progn (forward-line 1) (point))))
(or (equal "" fmt)
(message (or fmt "Killed %d line%s.") count (dired-plural-s count)))
@@ -1036,10 +1038,10 @@ See Info node `(emacs)Subdir switches' for more details."
;; Keeps any marks that may be present in column one (doing this
;; here is faster than with dired-add-entry's optional arg).
;; Does not update other dired buffers. Use dired-relist-entry for that.
- (beginning-of-line)
- (let ((char (following-char)) (opoint (point))
+ (let ((char (following-char))
+ (opoint (line-beginning-position))
(buffer-read-only))
- (delete-region (point) (progn (forward-line 1) (point)))
+ (delete-region opoint (progn (forward-line 1) (point)))
(if file
(progn
(dired-add-entry file nil t)
@@ -1132,8 +1134,7 @@ See Info node `(emacs)Subdir switches' for more details."
(save-excursion ;; ...so we can run it right now:
(save-restriction
(beginning-of-line)
- (narrow-to-region (point) (save-excursion
- (forward-line 1) (point)))
+ (narrow-to-region (point) (line-beginning-position 2))
(run-hooks 'dired-after-readin-hook))))
(dired-move-to-filename))
;; return nil if all went well
@@ -1166,7 +1167,7 @@ See Info node `(emacs)Subdir switches' for more details."
(and (dired-goto-file file)
(let (buffer-read-only)
(delete-region (progn (beginning-of-line) (point))
- (save-excursion (forward-line 1) (point)))))))
+ (line-beginning-position 2))))))
;;;###autoload
(defun dired-relist-file (file)
@@ -1187,7 +1188,7 @@ See Info node `(emacs)Subdir switches' for more details."
(delete-region (progn (beginning-of-line)
(setq marker (following-char))
(point))
- (save-excursion (forward-line 1) (point))))
+ (line-beginning-position 2)))
(setq file (directory-file-name file))
(dired-add-entry file (if (eq ?\040 marker) nil marker)))))
@@ -2481,5 +2482,4 @@ true then the type of the file linked to by FILE is printed instead."
;; generated-autoload-file: "dired.el"
;; End:
-;; arch-tag: 4b508de9-a153-423d-8d3f-a1bbd86f4f60
;;; dired-aux.el ends here
diff --git a/lisp/dired-x.el b/lisp/dired-x.el
index f919840e65d..45fdda71356 100644
--- a/lisp/dired-x.el
+++ b/lisp/dired-x.el
@@ -7,6 +7,7 @@
;; Lawrence R. Dodd <dodd@roebling.poly.edu>
;; Maintainer: Romain Francoise <rfrancoise@gnu.org>
;; Keywords: dired extensions files
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -163,7 +164,13 @@ 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'."
+plus those ending with extensions in `dired-omit-extensions'.
+
+To enable omitting in every Dired buffer, you can put in your ~/.emacs
+
+ (add-hook 'dired-mode-hook (lambda () (dired-omit-mode 1)))
+
+See Info node `(dired-x) Omitting Variables' for more information."
:group 'dired-x
(if dired-omit-mode
;; This will mention how many lines were omitted:
@@ -500,16 +507,21 @@ See variables `dired-texinfo-unclean-extensions',
;;; JUMP.
;;;###autoload
-(defun dired-jump (&optional other-window)
+(defun dired-jump (&optional other-window file-name)
"Jump to dired buffer corresponding to current buffer.
If in a file, dired the current directory and move to file's line.
If in Dired already, pop up a level and goto old directory's line.
In case the proper dired file line cannot be found, refresh the dired
-buffer and try again."
- (interactive "P")
- (let* ((file buffer-file-name)
+buffer and try again.
+When OTHER-WINDOW is non-nil, jump to dired buffer in other window.
+Interactively with prefix argument, read FILE-NAME and
+move to its line in dired."
+ (interactive
+ (list nil (and current-prefix-arg
+ (read-file-name "Jump to dired file: "))))
+ (let* ((file (or file-name buffer-file-name))
(dir (if file (file-name-directory file) default-directory)))
- (if (eq major-mode 'dired-mode)
+ (if (and (eq major-mode 'dired-mode) (null file-name))
(progn
(setq dir (dired-current-directory))
(dired-up-directory other-window)
@@ -533,10 +545,12 @@ buffer and try again."
(dired-omit-mode)
(dired-goto-file file))))))))
-(defun dired-jump-other-window ()
+(defun dired-jump-other-window (&optional file-name)
"Like \\[dired-jump] (`dired-jump') but in other window."
- (interactive)
- (dired-jump t))
+ (interactive
+ (list (and current-prefix-arg
+ (read-file-name "Jump to dired file: "))))
+ (dired-jump t file-name))
;;; OMITTING.
diff --git a/lisp/dired.el b/lisp/dired.el
index b2bd082b1a6..104cf4970ad 100644
--- a/lisp/dired.el
+++ b/lisp/dired.el
@@ -7,6 +7,7 @@
;; Author: Sebastian Kremer <sk@thp.uni-koeln.de>
;; Maintainer: FSF
;; Keywords: files
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -72,7 +73,7 @@ If nil, `dired-listing-switches' is used.")
;;;###autoload
(defvar dired-chown-program
(purecopy
- (if (memq system-type '(hpux usg-unix-v irix linux gnu/linux cygwin))
+ (if (memq system-type '(hpux usg-unix-v irix gnu/linux cygwin))
"chown"
(if (file-exists-p "/usr/sbin/chown")
"/usr/sbin/chown"
@@ -1380,10 +1381,8 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST."
(define-key map ">" 'dired-next-dirline)
(define-key map "^" 'dired-up-directory)
(define-key map " " 'dired-next-line)
- (define-key map "\C-n" 'dired-next-line)
- (define-key map "\C-p" 'dired-previous-line)
- (define-key map [down] 'dired-next-line)
- (define-key map [up] 'dired-previous-line)
+ (define-key map [remap next-line] 'dired-next-line)
+ (define-key map [remap previous-line] 'dired-previous-line)
;; hiding
(define-key map "$" 'dired-hide-subdir)
(define-key map "\M-$" 'dired-hide-all)
@@ -1393,7 +1392,7 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST."
(define-key map (kbd "M-s f C-s") 'dired-isearch-filenames)
(define-key map (kbd "M-s f M-C-s") 'dired-isearch-filenames-regexp)
;; misc
- (define-key map "\C-x\C-q" 'dired-toggle-read-only)
+ (define-key map [remap toggle-read-only] 'dired-toggle-read-only)
(define-key map "?" 'dired-summary)
(define-key map "\177" 'dired-unmark-backward)
(define-key map [remap undo] 'dired-undo)
@@ -1409,7 +1408,7 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST."
(define-key map "\C-t." 'image-dired-display-thumb)
(define-key map "\C-tc" 'image-dired-dired-comment-files)
(define-key map "\C-tf" 'image-dired-mark-tagged-files)
- (define-key map "\C-t\C-t" 'image-dired-dired-insert-marked-thumbs)
+ (define-key map "\C-t\C-t" 'image-dired-dired-toggle-marked-thumbs)
(define-key map "\C-te" 'image-dired-dired-edit-comment-and-tags)
;; encryption and decryption (epa-dired)
(define-key map ":d" 'epa-dired-do-decrypt)
@@ -2147,7 +2146,7 @@ Return the position of the beginning of the filename, or nil if none found."
;; case-fold-search is nil now, so we can test for capital F:
(setq used-F (string-match "F" dired-actual-switches)
opoint (point)
- eol (save-excursion (end-of-line) (point))
+ eol (line-end-position)
hidden (and selective-display
(save-excursion (search-forward "\r" eol t))))
(if hidden
@@ -2589,7 +2588,7 @@ Anything else means ask for each directory."
;; Delete file, possibly delete a directory and all its files.
;; This function is usefull outside of dired. One could change it's name
;; to e.g. recursive-delete-file and put it somewhere else.
-(defun dired-delete-file (file &optional recursive) "\
+(defun dired-delete-file (file &optional recursive trash) "\
Delete FILE or directory (possibly recursively if optional RECURSIVE is true.)
RECURSIVE determines what to do with a non-empty directory. If RECURSIVE is:
nil, do not delete.
@@ -2600,15 +2599,19 @@ Anything else, ask for each sub-directory."
;; (and (file-directory-p fn) (not (file-symlink-p fn)))
;; but more efficient
(if (not (eq t (car (file-attributes file))))
- (delete-file file)
+ (delete-file file trash)
(if (and recursive
(directory-files file t dired-re-no-dot) ; Not empty.
(or (eq recursive 'always)
- (yes-or-no-p (format "Recursive delete of %s? "
+ (yes-or-no-p (format "Recursively %s %s? "
+ (if (and trash
+ delete-by-moving-to-trash)
+ "trash"
+ "delete")
(dired-make-relative file)))))
(if (eq recursive 'top) (setq recursive 'always)) ; Don't ask again.
(setq recursive nil))
- (delete-directory file recursive)))
+ (delete-directory file recursive trash)))
(defun dired-do-flagged-delete (&optional nomessage)
"In Dired, delete the files flagged for deletion.
@@ -2626,7 +2629,7 @@ non-empty directories is allowed."
;; this can't move point since ARG is nil
(dired-map-over-marks (cons (dired-get-filename) (point))
nil)
- nil)
+ nil t)
(or nomessage
(message "(No deletions requested)")))))
@@ -2641,11 +2644,11 @@ non-empty directories is allowed."
;; this may move point if ARG is an integer
(dired-map-over-marks (cons (dired-get-filename) (point))
arg)
- arg))
+ arg t))
(defvar dired-deletion-confirmer 'yes-or-no-p) ; or y-or-n-p?
-(defun dired-internal-do-deletions (l arg)
+(defun dired-internal-do-deletions (l arg &optional trash)
;; L is an alist of files to delete, with their buffer positions.
;; ARG is the prefix arg.
;; Filenames are absolute.
@@ -2654,14 +2657,21 @@ non-empty directories is allowed."
;; lines still to be changed, so the (point) values in L stay valid.
;; Also, for subdirs in natural order, a subdir's files are deleted
;; before the subdir itself - the other way around would not work.
- (let ((files (mapcar (function car) l))
- (count (length l))
- (succ 0))
+ (let* ((files (mapcar (function car) l))
+ (count (length l))
+ (succ 0)
+ (trashing (and trash delete-by-moving-to-trash))
+ (progress-reporter
+ (make-progress-reporter
+ (if trashing "Trashing..." "Deleting...")
+ succ count)))
;; canonicalize file list for pop up
(setq files (nreverse (mapcar (function dired-make-relative) files)))
(if (dired-mark-pop-up
" *Deletions*" 'delete files dired-deletion-confirmer
- (format "Delete %s " (dired-mark-prompt arg files)))
+ (format "%s %s "
+ (if trashing "Trash" "Delete")
+ (dired-mark-prompt arg files)))
(save-excursion
(let (failures);; files better be in reverse order for this loop!
(while l
@@ -2669,10 +2679,10 @@ non-empty directories is allowed."
(let ((inhibit-read-only t))
(condition-case err
(let ((fn (car (car l))))
- (dired-delete-file fn dired-recursive-deletes)
+ (dired-delete-file fn dired-recursive-deletes trash)
;; if we get here, removing worked
(setq succ (1+ succ))
- (message "%s of %s deletions" succ count)
+ (progress-reporter-update progress-reporter succ)
(dired-fun-in-all-buffers
(file-name-directory fn) (file-name-nondirectory fn)
(function dired-delete-entry) fn))
@@ -2681,7 +2691,7 @@ non-empty directories is allowed."
(setq failures (cons (car (car l)) failures)))))
(setq l (cdr l)))
(if (not failures)
- (message "%d deletion%s done" count (dired-plural-s count))
+ (progress-reporter-done progress-reporter)
(dired-log-summary
(format "%d of %d deletion%s failed"
(length failures) count
@@ -2764,17 +2774,19 @@ name, or the marker and a count of marked files."
(fit-window-to-buffer (get-buffer-window buf) nil 1)))
(defcustom dired-no-confirm nil
- "A list of symbols for commands Dired should not confirm.
+ "A list of symbols for commands Dired should not confirm, or t.
Command symbols are `byte-compile', `chgrp', `chmod', `chown', `compress',
`copy', `delete', `hardlink', `load', `move', `print', `shell', `symlink',
-`touch' and `uncompress'."
+`touch' and `uncompress'.
+If t, confirmation is never needed."
:group 'dired
- :type '(set (const byte-compile) (const chgrp)
- (const chmod) (const chown) (const compress)
- (const copy) (const delete) (const hardlink)
- (const load) (const move) (const print)
- (const shell) (const symlink) (const touch)
- (const uncompress)))
+ :type '(choice (const :tag "Confirmation never needed" t)
+ (set (const byte-compile) (const chgrp)
+ (const chmod) (const chown) (const compress)
+ (const copy) (const delete) (const hardlink)
+ (const load) (const move) (const print)
+ (const shell) (const symlink) (const touch)
+ (const uncompress))))
(defun dired-mark-pop-up (bufname op-symbol files function &rest args)
"Return FUNCTION's result on ARGS after showing which files are marked.
@@ -3245,12 +3257,16 @@ variable `dired-listing-switches'. To temporarily override the listing
format, use `\\[universal-argument] \\[dired]'.")
(defvar dired-sort-by-date-regexp
- (concat "^-[^" dired-ls-sorting-switches
- "]*t[^" dired-ls-sorting-switches "]*$")
+ (concat "\\(\\`\\| \\)-[^- ]*t"
+ ;; `dired-ls-sorting-switches' after -t overrides -t.
+ "[^ " dired-ls-sorting-switches "]*"
+ "\\(\\(\\`\\| +\\)\\(--[^ ]+\\|-[^- t"
+ dired-ls-sorting-switches "]+\\)\\)* *$")
"Regexp recognized by Dired to set `by date' mode.")
(defvar dired-sort-by-name-regexp
- (concat "^-[^t" dired-ls-sorting-switches "]+$")
+ (concat "\\`\\(\\(\\`\\| +\\)\\(--[^ ]+\\|"
+ "-[^- t" dired-ls-sorting-switches "]+\\)\\)* *$")
"Regexp recognized by Dired to set `by name' mode.")
(defvar dired-sort-inhibit nil
@@ -3276,8 +3292,8 @@ The idea is to set this buffer-locally in special dired buffers.")
(force-mode-line-update)))
(defun dired-sort-toggle-or-edit (&optional arg)
- "Toggle between sort by date/name and refresh the dired buffer.
-With a prefix argument you can edit the current listing switches instead."
+ "Toggle sorting by date, and refresh the Dired buffer.
+With a prefix argument, edit the current listing switches instead."
(interactive "P")
(when dired-sort-inhibit
(error "Cannot sort this dired buffer"))
@@ -3288,24 +3304,24 @@ With a prefix argument you can edit the current listing switches instead."
(defun dired-sort-toggle ()
;; Toggle between sort by date/name. Reverts the buffer.
- (setq dired-actual-switches
- (let (case-fold-search)
- (if (string-match " " dired-actual-switches)
- ;; New toggle scheme: add/remove a trailing " -t"
- (if (string-match " -t\\'" dired-actual-switches)
- (substring dired-actual-switches 0 (match-beginning 0))
- (concat dired-actual-switches " -t"))
- ;; old toggle scheme: look for some 't' switch and add/remove it
- (concat
- "-l"
- (dired-replace-in-string (concat "[-lt"
- dired-ls-sorting-switches "]")
- ""
- dired-actual-switches)
- (if (string-match (concat "[t" dired-ls-sorting-switches "]")
- dired-actual-switches)
- ""
- "t")))))
+ (let ((sorting-by-date (string-match dired-sort-by-date-regexp
+ dired-actual-switches))
+ ;; Regexp for finding (possibly embedded) -t switches.
+ (switch-regexp "\\(\\`\\| \\)-\\([a-su-zA-Z]*\\)\\(t\\)\\([^ ]*\\)")
+ case-fold-search)
+ ;; Remove the -t switch.
+ (while (string-match switch-regexp dired-actual-switches)
+ (if (and (equal (match-string 2 dired-actual-switches) "")
+ (equal (match-string 4 dired-actual-switches) ""))
+ ;; Remove a stand-alone -t switch.
+ (setq dired-actual-switches
+ (replace-match "" t t dired-actual-switches))
+ ;; Remove a switch of the form -XtY for some X and Y.
+ (setq dired-actual-switches
+ (replace-match "" t t dired-actual-switches 3))))
+ ;; Now, if we weren't sorting by date before, add the -t switch.
+ (unless sorting-by-date
+ (setq dired-actual-switches (concat dired-actual-switches " -t"))))
(dired-sort-set-modeline)
(revert-buffer))
@@ -3531,7 +3547,7 @@ Ask means pop up a menu for the user to select one of copy, move or link."
;;;;;; dired-run-shell-command dired-do-shell-command dired-do-async-shell-command
;;;;;; dired-clean-directory dired-do-print dired-do-touch dired-do-chown
;;;;;; dired-do-chgrp dired-do-chmod dired-compare-directories dired-backup-diff
-;;;;;; dired-diff) "dired-aux" "dired-aux.el" "07676ea25af17f5d50cc5db4f53bddc0")
+;;;;;; dired-diff) "dired-aux" "dired-aux.el" "1628b7a7d379fb4da8ae4bf29faad4b5")
;;; Generated autoloads from dired-aux.el
(autoload 'dired-diff "dired-aux" "\
@@ -3984,7 +4000,7 @@ true then the type of the file linked to by FILE is printed instead.
;;;***
;;;### (autoloads (dired-do-relsymlink dired-jump) "dired-x" "dired-x.el"
-;;;;;; "bb37ec379c0a523368794491b691fd8d")
+;;;;;; "27c312d6d5d40d8cb4ef8d62e30d5f4a")
;;; Generated autoloads from dired-x.el
(autoload 'dired-jump "dired-x" "\
@@ -3993,8 +4009,11 @@ If in a file, dired the current directory and move to file's line.
If in Dired already, pop up a level and goto old directory's line.
In case the proper dired file line cannot be found, refresh the dired
buffer and try again.
+When OTHER-WINDOW is non-nil, jump to dired buffer in other window.
+Interactively with prefix argument, read FILE-NAME and
+move to its line in dired.
-\(fn &optional OTHER-WINDOW)" t nil)
+\(fn &optional OTHER-WINDOW FILE-NAME)" t nil)
(autoload 'dired-do-relsymlink "dired-x" "\
Relative symlink all marked (or next ARG) files into a directory.
@@ -4019,5 +4038,4 @@ For absolute symlinks, use \\[dired-do-symlink].
(run-hooks 'dired-load-hook) ; for your customizations
-;; arch-tag: e1af7a8f-691c-41a0-aac1-ddd4d3c87517
;;; dired.el ends here
diff --git a/lisp/dirtrack.el b/lisp/dirtrack.el
index c209a2a6eb9..7a43459f536 100644
--- a/lisp/dirtrack.el
+++ b/lisp/dirtrack.el
@@ -143,15 +143,8 @@ be on a single line."
:group 'dirtrack
:type 'string)
-(defcustom dirtrackp t
- "If non-nil, directory tracking via `dirtrack' is enabled."
- :group 'dirtrack
- :type 'boolean)
-
-(make-variable-buffer-local 'dirtrackp)
-
(defcustom dirtrack-directory-function
- (if (memq system-type (list 'ms-dos 'windows-nt 'cygwin))
+ (if (memq system-type '(ms-dos windows-nt cygwin))
'dirtrack-windows-directory-function
'file-name-as-directory)
"Function to apply to the prompt directory for comparison purposes."
@@ -159,7 +152,7 @@ be on a single line."
:type 'function)
(defcustom dirtrack-canonicalize-function
- (if (memq system-type (list 'ms-dos 'windows-nt 'cygwin))
+ (if (memq system-type '(ms-dos windows-nt cygwin))
'downcase 'identity)
"Function to apply to the default directory for comparison purposes."
:group 'dirtrack
@@ -276,5 +269,4 @@ function `dirtrack-debug-mode' to turn on debugging output."
(provide 'dirtrack)
-;; arch-tag: 168de071-be88-4937-aff6-2aba9f328d5a
;;; dirtrack.el ends here
diff --git a/lisp/disp-table.el b/lisp/disp-table.el
index 86aed277765..e9bdd3d9be3 100644
--- a/lisp/disp-table.el
+++ b/lisp/disp-table.el
@@ -7,6 +7,7 @@
;; Based on a previous version by Howard Gayle
;; Maintainer: FSF
;; Keywords: i18n
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/dnd.el b/lisp/dnd.el
index aadfad6d7ac..cbbef384436 100644
--- a/lisp/dnd.el
+++ b/lisp/dnd.el
@@ -6,6 +6,7 @@
;; Author: Jan Djärv <jan.h.d@swipnet.se>
;; Maintainer: FSF
;; Keywords: window, drag, drop
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/doc-view.el b/lisp/doc-view.el
index 528d5979ce1..4f183f4b9dc 100644
--- a/lisp/doc-view.el
+++ b/lisp/doc-view.el
@@ -1349,8 +1349,8 @@ See the command `doc-view-mode' for more information on this mode."
;;;; Bookmark integration
-(declare-function bookmark-make-record-default "bookmark"
- (&optional point-only))
+(declare-function bookmark-make-record-default
+ "bookmark" (&optional no-file no-context posn))
(declare-function bookmark-prop-get "bookmark" (bookmark prop))
(declare-function bookmark-default-handler "bookmark" (bmk))
diff --git a/lisp/dos-fns.el b/lisp/dos-fns.el
index c1c2517bc22..b840319113d 100644
--- a/lisp/dos-fns.el
+++ b/lisp/dos-fns.el
@@ -5,6 +5,7 @@
;; Maintainer: Morten Welinder <terra@diku.dk>
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -30,16 +31,16 @@
(declare-function int86 "dosfns.c")
(declare-function msdos-long-file-names "msdos.c")
-;; This overrides a trivial definition in files.el.
-(defun convert-standard-filename (filename)
- "Convert a standard file's name to something suitable for the current OS.
+;; See convert-standard-filename in files.el.
+(defun dos-convert-standard-filename (filename)
+ "Convert a standard file's name to something suitable for MS-DOS.
This means to guarantee valid names and perhaps to canonicalize
certain patterns.
+This function is called by `convert-standard-filename'.
+
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')."
+sure to obey the 8.3 limitations."
(if (or (not (stringp filename))
;; This catches the case where FILENAME is "x:" or "x:/" or
;; "/", thus preventing infinite recursion.
@@ -48,7 +49,7 @@ shell requires it (see `w32-shell-dos-semantics')."
(let ((flen (length filename)))
;; If FILENAME has a trailing slash, remove it and recurse.
(if (memq (aref filename (1- flen)) '(?/ ?\\))
- (concat (convert-standard-filename
+ (concat (dos-convert-standard-filename
(substring filename 0 (1- flen)))
"/")
(let* (;; ange-ftp gets in the way for names like "/foo:bar".
@@ -122,10 +123,10 @@ shell requires it (see `w32-shell-dos-semantics')."
(aset string (1- (length string)) lastchar))))
(concat (if (and (stringp dir)
(memq (aref dir dlen-m-1) '(?/ ?\\)))
- (concat (convert-standard-filename
+ (concat (dos-convert-standard-filename
(substring dir 0 dlen-m-1))
"/")
- (convert-standard-filename dir))
+ (dos-convert-standard-filename dir))
string))))))
(defun dos-8+3-filename (filename)
@@ -188,12 +189,12 @@ shell requires it (see `w32-shell-dos-semantics')."
;; This is for the sake of standard file names elsewhere in Emacs that
;; are defined as constant strings or via defconst, and whose
-;; conversion via `convert-standard-filename' does not give good
+;; conversion via `dos-convert-standard-filename' does not give good
;; enough results.
(defun dosified-file-name (file-name)
"Return a variant of FILE-NAME that is valid on MS-DOS filesystems.
-This function is for those rare cases where `convert-standard-filename'
+This function is for those rare cases where `dos-convert-standard-filename'
does not do a job that is good enough, e.g. if you need to preserve the
file-name extension. It recognizes only certain specific file names
that are used in Emacs Lisp sources; any other file name will be
@@ -209,13 +210,13 @@ returned unaltered."
(defvar msdos-shells)
;; Override settings chosen at startup.
-(defun set-default-process-coding-system ()
+(defun dos-set-default-process-coding-system ()
(setq default-process-coding-system
(if (default-value 'enable-multibyte-characters)
'(undecided-dos . undecided-dos)
'(raw-text-dos . raw-text-dos))))
-(add-hook 'before-init-hook 'set-default-process-coding-system)
+(add-hook 'before-init-hook 'dos-set-default-process-coding-system)
;; File names defined in preloaded packages can be incorrect or
;; invalid if long file names were available during dumping, but not
@@ -232,17 +233,22 @@ returned unaltered."
(add-hook 'before-init-hook 'dos-reevaluate-defcustoms)
-(defvar register-name-alist
+(defvar dos-register-name-alist
'((ax . 0) (bx . 1) (cx . 2) (dx . 3) (si . 4) (di . 5)
(cflag . 6) (flags . 7)
(al . (0 . 0)) (bl . (1 . 0)) (cl . (2 . 0)) (dl . (3 . 0))
(ah . (0 . 1)) (bh . (1 . 1)) (ch . (2 . 1)) (dh . (3 . 1))))
-(defun make-register ()
+(define-obsolete-variable-alias
+ 'register-name-alist 'dos-register-name-alist "24.1")
+
+(defun dos-make-register ()
(make-vector 8 0))
-(defun register-value (regs name)
- (let ((where (cdr (assoc name register-name-alist))))
+(define-obsolete-function-alias 'make-register 'dos-make-register "24.1")
+
+(defun dos-register-value (regs name)
+ (let ((where (cdr (assoc name dos-register-name-alist))))
(cond ((consp where)
(let ((tem (aref regs (car where))))
(if (zerop (cdr where))
@@ -252,10 +258,12 @@ returned unaltered."
(aref regs where))
(t nil))))
-(defun set-register-value (regs name value)
+(define-obsolete-function-alias 'register-value 'dos-register-value "24.1")
+
+(defun dos-set-register-value (regs name value)
(and (numberp value)
(>= value 0)
- (let ((where (cdr (assoc name register-name-alist))))
+ (let ((where (cdr (assoc name dos-register-name-alist))))
(cond ((consp where)
(let ((tem (aref regs (car where)))
(value (logand value 255)))
@@ -268,18 +276,29 @@ returned unaltered."
(aset regs where (logand value 65535))))))
regs)
-(defsubst intdos (regs)
+(define-obsolete-function-alias
+ 'set-register-value 'dos-set-register-value "24.1")
+
+(defsubst dos-intdos (regs)
+ "Issue the DOS Int 21h with registers REGS.
+
+REGS should be a vector produced by `dos-make-register'
+and `dos-set-register-value', which see."
(int86 33 regs))
+(define-obsolete-function-alias 'intdos 'dos-intdos "24.1")
+
;; Backward compatibility for obsolescent functions which
;; set screen size.
-(defun mode25 ()
+(defun dos-mode25 ()
"Changes the number of screen rows to 25."
(interactive)
(set-frame-size (selected-frame) 80 25))
-(defun mode4350 ()
+(define-obsolete-function-alias 'mode25 'dos-mode25 "24.1")
+
+(defun dos-mode4350 ()
"Changes the number of rows to 43 or 50.
Emacs always tries to set the screen height to 50 rows first.
If this fails, it will try to set it to 43 rows, on the assumption
@@ -290,6 +309,8 @@ that your video hardware might not support 50-line mode."
nil ; the original built-in function returned nil
(set-frame-size (selected-frame) 80 43)))
+(define-obsolete-function-alias 'mode4350 'dos-mode4350 "24.1")
+
(provide 'dos-fns)
;; arch-tag: 00b03579-8ebb-4a02-8762-5c5a929774ad
diff --git a/lisp/dos-vars.el b/lisp/dos-vars.el
index 8af147e78f6..e153df3e743 100644
--- a/lisp/dos-vars.el
+++ b/lisp/dos-vars.el
@@ -5,6 +5,7 @@
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/dos-w32.el b/lisp/dos-w32.el
index 424ea0a701d..0962ae5f13a 100644
--- a/lisp/dos-w32.el
+++ b/lisp/dos-w32.el
@@ -5,6 +5,7 @@
;; Maintainer: Geoff Voelker <voelker@cs.washington.edu>
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/font-setting.el b/lisp/dynamic-setting.el
index 3de0b81621c..cfa1053c44d 100644
--- a/lisp/font-setting.el
+++ b/lisp/dynamic-setting.el
@@ -1,10 +1,11 @@
-;;; font-setting.el --- Support dynamic font changes -*- coding: utf-8 -*-
+;;; dynamic-setting.el --- Support dynamic changes
;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;; Author: Jan Djärv <jan.h.d@swipnet.se>
;; Maintainer: FSF
-;; Keywords: font, system-font
+;; Keywords: font, system-font, tool-bar-style
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -65,7 +66,6 @@ current form for the frame (i.e. hinting or somesuch changed)."
frame-font)))
(if font-to-set
(progn
- (message "setting %s" font-to-set)
(set-frame-parameter f 'font-parameter font-to-set)
(set-face-attribute 'default f
:width 'normal
@@ -81,21 +81,30 @@ current form for the frame (i.e. hinting or somesuch changed)."
(custom-push-theme 'theme-face 'default 'user 'set spec)
(put 'default 'face-modified nil))))))
-(defun font-setting-handle-config-changed-event (event)
- "Handle config-changed-event to change fonts on the display in EVENT.
-If `font-use-system-font' is nil, the font is not changed."
+(defun dynamic-setting-handle-config-changed-event (event)
+ "Handle config-changed-event on the display in EVENT.
+Changes can be
+ The monospace font. If `font-use-system-font' is nil, the font
+ is not changed.
+ Xft parameters, like DPI and hinting.
+ The tool bar style."
(interactive "e")
- (let ((type (nth 1 event)) ;; font-name or font-render
+ (let ((type (nth 1 event))
(display-name (nth 2 event)))
- (if (or (not (eq type 'font-name))
- font-use-system-font)
- (font-setting-change-default-font display-name
- (eq type 'font-name)))))
+ (cond ((and (eq type 'monospace-font-name) font-use-system-font)
+ (font-setting-change-default-font display-name t))
-(if (or (featurep 'system-font-setting) (featurep 'font-render-setting))
- (define-key special-event-map [config-changed-event]
- 'font-setting-handle-config-changed-event))
+ ((eq type 'font-render)
+ (font-setting-change-default-font display-name nil))
-(provide 'font-setting)
+ ;; This is a bit heavy, ideally we would just clear faces
+ ;; on the affected display, and perhaps only the relevant
+ ;; faces. Oh well.
+ ((eq type 'theme-name) (clear-face-cache))
+
+ ((eq type 'tool-bar-style) (force-mode-line-update t)))))
+
+(define-key special-event-map [config-changed-event]
+ 'dynamic-setting-handle-config-changed-event)
;; arch-tag: 3a57e78f-1cd6-48b6-ab75-98f160dcc017
diff --git a/lisp/ebuff-menu.el b/lisp/ebuff-menu.el
index 99704e02b35..6b462a22d1f 100644
--- a/lisp/ebuff-menu.el
+++ b/lisp/ebuff-menu.el
@@ -1,7 +1,7 @@
;;; ebuff-menu.el --- electric-buffer-list mode
-;; Copyright (C) 1985, 1986, 1994, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1986, 1994, 2001, 2002, 2003, 2004, 2005, 2006,
+;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Richard Mlynarik <mly@ai.mit.edu>
;; Maintainer: FSF
@@ -95,7 +95,7 @@ Run hooks in `electric-buffer-menu-mode-hook' on entry.
(cons first last))))))
(set-buffer buffer)
(Buffer-menu-mode)
- (bury-buffer buffer)
+ (bury-buffer) ;Get rid of window, if dedicated.
(message "")))
(if select
(progn (set-buffer buffer)
@@ -282,11 +282,10 @@ Return to Electric Buffer Menu when done."
(make-local-variable 'electric-buffer-overlay)
(setq electric-buffer-overlay (make-overlay (point) (point)))))
(move-overlay electric-buffer-overlay
- (save-excursion (beginning-of-line) (point))
- (save-excursion (end-of-line) (point)))
+ (line-beginning-position)
+ (line-end-position))
(overlay-put electric-buffer-overlay 'face 'highlight)))
(provide 'ebuff-menu)
-;; arch-tag: 1d4509b3-eece-4d4f-95ea-77c83eaf0275
;;; ebuff-menu.el ends here
diff --git a/lisp/edmacro.el b/lisp/edmacro.el
index 123d8c1aacb..f98d901ddec 100644
--- a/lisp/edmacro.el
+++ b/lisp/edmacro.el
@@ -81,11 +81,11 @@
"*Non-nil if `edit-kbd-macro' should leave 8-bit characters intact.
Default nil means to write characters above \\177 in octal notation.")
-(defvar edmacro-mode-map nil)
-(unless edmacro-mode-map
- (setq edmacro-mode-map (make-sparse-keymap))
- (define-key edmacro-mode-map "\C-c\C-c" 'edmacro-finish-edit)
- (define-key edmacro-mode-map "\C-c\C-q" 'edmacro-insert-key))
+(defvar edmacro-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\C-c\C-c" 'edmacro-finish-edit)
+ (define-key map "\C-c\C-q" 'edmacro-insert-key)
+ map))
(defvar edmacro-store-hook)
(defvar edmacro-finish-hook)
diff --git a/lisp/ehelp.el b/lisp/ehelp.el
index 7de4fd0ba63..63ec3838d32 100644
--- a/lisp/ehelp.el
+++ b/lisp/ehelp.el
@@ -94,10 +94,14 @@
map)
"Keymap defining commands available in `electric-help-mode'.")
+(defvar electric-help-orig-major-mode nil)
+(make-variable-buffer-local 'electric-help-orig-major-mode)
+
(defun electric-help-mode ()
"`with-electric-help' temporarily places its buffer in this mode.
-\(On exit from `with-electric-help', the buffer is put in default `major-mode'.)"
+\(On exit from `with-electric-help', the original `major-mode' is restored.)"
(setq buffer-read-only t)
+ (setq electric-help-orig-major-mode major-mode)
(setq mode-name "Help")
(setq major-mode 'help)
(setq mode-line-buffer-identification '(" Help: %b"))
@@ -131,7 +135,7 @@ If THUNK returns non-nil, we don't do those things.
When the user exits (with `electric-help-exit', or otherwise), the help
buffer's window disappears (i.e., we use `save-window-excursion'), and
-BUFFER is put into default `major-mode' (or `fundamental-mode')."
+BUFFER is put back into its original major mode."
(setq buffer (get-buffer-create (or buffer "*Help*")))
(let ((one (one-window-p t))
(config (current-window-configuration))
@@ -170,13 +174,17 @@ BUFFER is put into default `major-mode' (or `fundamental-mode')."
(set-buffer buffer)
(setq buffer-read-only nil)
+ ;; Restore the original major mode saved by `electric-help-mode'.
;; We should really get a usable *Help* buffer when retaining
;; the electric one with `r'. The problem is that a simple
- ;; call to help-mode won't cut it; at least RET is bound wrong
- ;; afterwards. It's also not clear that `help-mode' is always
- ;; the right thing, maybe we should add an optional parameter.
+ ;; call to `help-mode' won't cut it; e.g. RET is bound wrong
+ ;; afterwards (`View-scroll-line-forward' instead of `help-follow').
+ ;; That's because Help mode should be set with `with-help-window'
+ ;; instead of the direct call to `help-mode'. But at least
+ ;; RET works correctly on links after using `help-mode'.
+ ;; This is satisfactory enough.
(condition-case ()
- (funcall (or (default-value 'major-mode) 'fundamental-mode))
+ (funcall (or electric-help-orig-major-mode 'fundamental-mode))
(error nil))
(set-window-configuration config)
diff --git a/lisp/electric.el b/lisp/electric.el
index db53b5fa84e..0ea8cb30010 100644
--- a/lisp/electric.el
+++ b/lisp/electric.el
@@ -24,10 +24,23 @@
;;; Commentary:
-; zaaaaaaap
+;; "Electric" has been used in Emacs to refer to different things.
+;; Among them:
+;;
+;; - electric modes and buffers: modes that typically pop-up in a modal kind of
+;; way a transient buffer that automatically disappears as soon as the user
+;; is done with it.
+;;
+;; - electric keys: self inserting keys which additionally perform some side
+;; operation which happens to be often convenient at that time. Examples of
+;; such side operations are: reindenting code, inserting a newline,
+;; ... auto-fill-mode and abbrev-mode can be considered as built-in forms of
+;; electric key behavior.
;;; Code:
+(eval-when-compile (require 'cl))
+
;; This loop is the guts for non-standard modes which retain control
;; until some event occurs. It is a `do-forever', the only way out is
;; to throw. It assumes that you have set up the keymap, window, and
@@ -58,12 +71,10 @@
(err nil)
(prompt-string prompt))
(while t
- (if (not (or (stringp prompt) (eq prompt nil) (eq prompt 'noprompt)))
+ (if (functionp prompt)
(setq prompt-string (funcall prompt)))
(if (not (stringp prompt-string))
- (if (eq prompt-string 'noprompt)
- (setq prompt-string nil)
- (setq prompt-string "->")))
+ (setq prompt-string (unless (eq prompt-string 'noprompt) "->")))
(setq cmd (read-key-sequence prompt-string))
(setq last-command-event (aref cmd (1- (length cmd)))
this-command (key-binding cmd t)
@@ -159,6 +170,217 @@
(fit-window-to-buffer win max-height))
win)))
+;;; Electric keys.
+
+(defgroup electricity ()
+ "Electric behavior for self inserting keys."
+ :group 'editing)
+
+(defun electric--after-char-pos ()
+ "Return the position after the char we just inserted.
+Returns nil when we can't find this char."
+ (let ((pos (point)))
+ (when (or (eq (char-before) last-command-event) ;; Sanity check.
+ (save-excursion
+ (or (progn (skip-chars-backward " \t")
+ (setq pos (point))
+ (eq (char-before) last-command-event))
+ (progn (skip-chars-backward " \n\t")
+ (setq pos (point))
+ (eq (char-before) last-command-event)))))
+ pos)))
+
+;; Electric indentation.
+
+;; Autoloading variables is generally undesirable, but major modes
+;; should usually set this variable by adding elements to the default
+;; value, which only works well if the variable is preloaded.
+;;;###autoload
+(defvar electric-indent-chars '(?\n)
+ "Characters that should cause automatic reindentation.")
+
+(defun electric-indent-post-self-insert-function ()
+ ;; FIXME: This reindents the current line, but what we really want instead is
+ ;; to reindent the whole affected text. That's the current line for simple
+ ;; cases, but not all cases. We do take care of the newline case in an
+ ;; ad-hoc fashion, but there are still missing cases such as the case of
+ ;; electric-pair-mode wrapping a region with a pair of parens.
+ ;; There might be a way to get it working by analyzing buffer-undo-list, but
+ ;; it looks challenging.
+ (let (pos)
+ (when (and (memq last-command-event electric-indent-chars)
+ ;; Don't reindent while inserting spaces at beginning of line.
+ (or (not (memq last-command-event '(?\s ?\t)))
+ (save-excursion (skip-chars-backward " \t") (not (bolp))))
+ (setq pos (electric--after-char-pos))
+ ;; Not in a string or comment.
+ (not (nth 8 (save-excursion (syntax-ppss pos)))))
+ ;; For newline, we want to reindent both lines and basically behave like
+ ;; reindent-then-newline-and-indent (whose code we hence copied).
+ (when (and (< (1- pos) (line-beginning-position))
+ ;; Don't reindent the previous line if the indentation
+ ;; function is not a real one.
+ (not (memq indent-line-function
+ '(indent-relative indent-relative-maybe))))
+ (let ((before (copy-marker (1- pos) t)))
+ (save-excursion
+ (goto-char before)
+ (indent-according-to-mode)
+ ;; We are at EOL before the call to indent-according-to-mode, and
+ ;; after it we usually are as well, but not always. We tried to
+ ;; address it with `save-excursion' but that uses a normal marker
+ ;; whereas we need `move after insertion', so we do the
+ ;; save/restore by hand.
+ (goto-char before)
+ ;; Remove the trailing whitespace after indentation because
+ ;; indentation may (re)introduce the whitespace.
+ (delete-horizontal-space t))))
+ (indent-according-to-mode))))
+
+;;;###autoload
+(define-minor-mode electric-indent-mode
+ "Automatically reindent lines of code when inserting particular chars.
+`electric-indent-chars' specifies the set of chars that should cause reindentation."
+ :global t
+ :group 'electricity
+ (if electric-indent-mode
+ (add-hook 'post-self-insert-hook
+ #'electric-indent-post-self-insert-function)
+ (remove-hook 'post-self-insert-hook
+ #'electric-indent-post-self-insert-function))
+ ;; FIXME: electric-indent-mode and electric-layout-mode interact
+ ;; in non-trivial ways. It turns out that electric-indent-mode works
+ ;; better if it is run *after* electric-layout-mode's hook.
+ (when (memq #'electric-layout-post-self-insert-function
+ (memq #'electric-indent-post-self-insert-function
+ (default-value 'post-self-insert-hook)))
+ (remove-hook 'post-self-insert-hook
+ #'electric-layout-post-self-insert-function)
+ (add-hook 'post-self-insert-hook
+ #'electric-layout-post-self-insert-function)))
+
+;; Electric pairing.
+
+(defcustom electric-pair-pairs
+ '((?\" . ?\"))
+ "Alist of pairs that should be used regardless of major mode."
+ :type '(repeat (cons character character)))
+
+(defcustom electric-pair-skip-self t
+ "If non-nil, skip char instead of inserting a second closing paren.
+When inserting a closing paren character right before the same character,
+just skip that character instead, so that hitting ( followed by ) results
+in \"()\" rather than \"())\".
+This can be convenient for people who find it easier to hit ) than C-f."
+ :type 'boolean)
+
+(defun electric-pair-post-self-insert-function ()
+ (let* ((syntax (and (eq (char-before) last-command-event) ; Sanity check.
+ (let ((x (assq last-command-event electric-pair-pairs)))
+ (cond
+ (x (if (eq (car x) (cdr x)) ?\" ?\())
+ ((rassq last-command-event electric-pair-pairs) ?\))
+ (t (char-syntax last-command-event))))))
+ ;; FIXME: when inserting the closer, we should maybe use
+ ;; self-insert-command, although it may prove tricky running
+ ;; post-self-insert-hook recursively, and we wouldn't want to trigger
+ ;; blink-matching-open.
+ (closer (if (eq syntax ?\()
+ (cdr (or (assq last-command-event electric-pair-pairs)
+ (aref (syntax-table) last-command-event)))
+ last-command-event)))
+ (cond
+ ;; Wrap a pair around the active region.
+ ((and (memq syntax '(?\( ?\" ?\$)) (use-region-p))
+ (if (> (mark) (point))
+ (goto-char (mark))
+ ;; We already inserted the open-paren but at the end of the region,
+ ;; so we have to remove it and start over.
+ (delete-char -1)
+ (save-excursion
+ (goto-char (mark))
+ (insert last-command-event)))
+ (insert closer))
+ ;; Backslash-escaped: no pairing, no skipping.
+ ((save-excursion
+ (goto-char (1- (point)))
+ (not (zerop (% (skip-syntax-backward "\\") 2))))
+ nil)
+ ;; Skip self.
+ ((and (memq syntax '(?\) ?\" ?\$))
+ electric-pair-skip-self
+ (eq (char-after) last-command-event))
+ ;; This is too late: rather than insert&delete we'd want to only skip (or
+ ;; insert in overwrite mode). The difference is in what goes in the
+ ;; undo-log and in the intermediate state which might be visible to other
+ ;; post-self-insert-hook. We'll just have to live with it for now.
+ (delete-char 1))
+ ;; Insert matching pair.
+ ((not (or (not (memq syntax `(?\( ?\" ?\$)))
+ overwrite-mode
+ ;; I find it more often preferable not to pair when the
+ ;; same char is next.
+ (eq last-command-event (char-after))
+ (eq last-command-event (char-before (1- (point))))
+ ;; I also find it often preferable not to pair next to a word.
+ (eq (char-syntax (following-char)) ?w)))
+ (save-excursion (insert closer))))))
+
+;;;###autoload
+(define-minor-mode electric-pair-mode
+ "Automatically pair-up parens when inserting an open paren."
+ :global t
+ :group 'electricity
+ (if electric-pair-mode
+ (add-hook 'post-self-insert-hook
+ #'electric-pair-post-self-insert-function)
+ (remove-hook 'post-self-insert-hook
+ #'electric-pair-post-self-insert-function)))
+
+;; Automatically add newlines after/before/around some chars.
+
+(defvar electric-layout-rules '()
+ "List of rules saying where to automatically insert newlines.
+Each rule has the form (CHAR . WHERE) where CHAR is the char
+that was just inserted and WHERE specifies where to insert newlines
+and can be: nil, `before', `after', `around', or a function that returns
+one of those symbols.")
+
+(defun electric-layout-post-self-insert-function ()
+ (let* ((rule (cdr (assq last-command-event electric-layout-rules)))
+ pos)
+ (when (and rule
+ (setq pos (electric--after-char-pos))
+ ;; Not in a string or comment.
+ (not (nth 8 (save-excursion (syntax-ppss pos)))))
+ (let ((end (copy-marker (point) t)))
+ (goto-char pos)
+ (case (if (functionp rule) (funcall rule) rule)
+ ;; FIXME: we used `newline' down here which called
+ ;; self-insert-command and ran post-self-insert-hook recursively.
+ ;; It happened to make electric-indent-mode work automatically with
+ ;; electric-layout-mode (at the cost of re-indenting lines
+ ;; multiple times), but I'm not sure it's what we want.
+ (before (goto-char (1- pos)) (skip-chars-backward " \t")
+ (unless (bolp) (insert "\n")))
+ (after (insert "\n")) ; FIXME: check eolp before inserting \n?
+ (around (save-excursion
+ (goto-char (1- pos)) (skip-chars-backward " \t")
+ (unless (bolp) (insert "\n")))
+ (insert "\n"))) ; FIXME: check eolp before inserting \n?
+ (goto-char end)))))
+
+;;;###autoload
+(define-minor-mode electric-layout-mode
+ "Automatically insert newlines around some chars."
+ :global t
+ :group 'electricity
+ (if electric-layout-mode
+ (add-hook 'post-self-insert-hook
+ #'electric-layout-post-self-insert-function)
+ (remove-hook 'post-self-insert-hook
+ #'electric-layout-post-self-insert-function)))
+
(provide 'electric)
;; arch-tag: dae045eb-dc2d-4fb7-9f27-9cc2ce277be8
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el
index 9267bc8ac91..578e0877d30 100644
--- a/lisp/emacs-lisp/advice.el
+++ b/lisp/emacs-lisp/advice.el
@@ -7,6 +7,7 @@
;; Maintainer: FSF
;; Created: 12 Dec 1992
;; Keywords: extensions, lisp, tools
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/emacs-lisp/authors.el b/lisp/emacs-lisp/authors.el
index 7728215bb91..ae490550021 100644
--- a/lisp/emacs-lisp/authors.el
+++ b/lisp/emacs-lisp/authors.el
@@ -6,6 +6,7 @@
;; Author: Gerd Moellmann <gerd@gnu.org>
;; Maintainer: Kim F. Storm <storm@cua.dk>
;; Keywords: maint
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -220,6 +221,9 @@ If REALNAME is nil, ignore that author.")
'("vc-\\*\\.el$"
"spec.txt$"
".*loaddefs.el$" ; not obsolete, but auto-generated
+ "\\.\\(cvs\\|git\\)ignore$" ; obsolete or uninteresting
+ "\\.arch-inventory$"
+ "preferences\\.\\(nib\\|gorm\\)"
"vc-\\(rcs\\|cvs\\|sccs\\)-hooks\\.el$")
"List of regexps matching obsolete files.
Changes to files matching one of the regexps in this list are not
@@ -244,6 +248,14 @@ listed.")
"Imakefile" "icons/sink.ico" "aixcc.lex"
"nxml/char-name/unicode"
"js2-mode.el" ; only installed very briefly, replaced by js.el
+ "cedet/tests/testtemplates.cpp"
+ "cedet/tests/testusing.cpp"
+ "cedet/tests/scopetest.cpp"
+ "cedet/tests/scopetest.java"
+ "cedet/tests/test.cpp"
+ "cedet/tests/test.py"
+ "cedet/tests/teststruct.cpp"
+ "*.el"
;; Autogen:
"cus-load.el" "finder-inf.el" "ldefs-boot.el"
;; Never had any meaningful changes logged, now deleted:
@@ -255,7 +267,8 @@ listed.")
"3B-MAXMEM" "AIX.DUMP" "SUN-SUPPORT" "XENIX"
"CODINGS" "CHARSETS"
"calc/INSTALL" "calc/Makefile"
- "vms-pp.trans" "_emacs" "batcomp.com"
+ "vms-pp.trans" "_emacs" "batcomp.com" "notes/cpp" ; admin/
+ "emacsver.texi.in"
;; MH-E stuff not in Emacs:
"import-emacs" "release-utils"
;; Erc stuff not in Emacs:
@@ -286,6 +299,42 @@ listed.")
"List of files and directories to ignore.
Changes to files in this list are not listed.")
+;; List via: find . -name '*.el' | sed 's/.*\///g' | sort | uniq -d
+;; FIXME It would be better to discover these dynamically.
+;; Note that traditionally "Makefile.in" etc have not been in this list.
+;; Ditto for "abbrev.texi" etc.
+(defconst authors-ambiguous-files
+ '("chart.el"
+ "compile.el"
+ "complete.el"
+ "cpp.el"
+ "ctxt.el"
+ "debug.el"
+ "dired.el"
+ "el.el"
+ "files.el"
+ "find.el"
+ "format.el"
+ "grep.el"
+ "imenu.el"
+ "java.el"
+ "linux.el"
+ "locate.el"
+ "make.el"
+ "mode.el"
+ "python.el"
+ "semantic.el"
+ "shell.el"
+ "simple.el"
+ "sort.el"
+ "speedbar.el"
+ "srecode.el"
+ "table.el"
+ "texi.el"
+ "util.el"
+ "wisent.el")
+ "List of basenames occurring more than once in the source.")
+
;; FIXME :cowrote entries here can be overwritten by :wrote entries
;; derived from a file's Author: header (eg mh-e). This really means
;; the Author: header is erroneous.
@@ -307,7 +356,7 @@ Changes to files in this list are not listed.")
;; No longer distributed.
;;; ("Viktor Dukhovni" :wrote "unexsunos4.c")
("Paul Eggert" :wrote "rcs2log" "vcdiff")
- ("Fred Fish" :changed "unexec.c")
+ ("Fred Fish" :changed "unexcoff.c")
;; No longer distributed.
;;; ("Tim Fleehart" :wrote "makefile.nt")
("Keith Gabryelski" :wrote "hexl.c")
@@ -330,13 +379,13 @@ Changes to files in this list are not listed.")
"indent.c" "search.c" "xdisp.c" "region-cache.c" "region-cache.h")
;; ibmrt.h, ibmrt-aix.h no longer distributed.
("International Business Machines" :changed "emacs.c" "fileio.c"
- "process.c" "sysdep.c" "unexec.c")
+ "process.c" "sysdep.c" "unexcoff.c")
;; No longer distributed.
;;; ("Ishikawa Chiaki" :changed "aviion.h" "dgux.h")
;; ymakefile no longer distributed.
("Michael K. Johnson" :changed "configure.in" "emacs.c" "intel386.h"
"mem-limits.h" "process.c" "template.h" "sysdep.c" "syssignal.h"
- "systty.h" "unexec.c" "linux.h")
+ "systty.h" "unexcoff.c" "linux.h")
;; No longer distributed.
;;; ("Kyle Jones" :wrote "mldrag.el")
("Henry Kautz" :wrote "bib-mode.el")
@@ -361,7 +410,7 @@ Changes to files in this list are not listed.")
"rmail.el" "rmailedit.el" "rmailkwd.el"
"rmailmsc.el" "rmailout.el" "rmailsum.el" "scribe.el"
;; It was :wrote for xmenu.c, but it has been rewritten since.
- "server.el" "lisp.h" "sysdep.c" "unexec.c" "xmenu.c")
+ "server.el" "lisp.h" "sysdep.c" "unexcoff.c" "xmenu.c")
("Niall Mansfield" :changed "etags.c")
("Brian Marick" :cowrote "hideif.el")
("Marko Kohtala" :changed "info.el")
@@ -416,9 +465,9 @@ Changes to files in this list are not listed.")
("Kayvan Sylvan" :changed "supercite.el")
;; No longer distributed: emacsserver.c, tcp.c.
("Spencer Thomas" :changed "emacsclient.c" "server.el"
- "dabbrev.el" "unexec.c" "gnus.texi")
+ "dabbrev.el" "unexcoff.c" "gnus.texi")
("Jonathan Vail" :changed "vc.el")
- ("James Van Artsdalen" :changed "usg5-4.h" "unexec.c")
+ ("James Van Artsdalen" :changed "usg5-4.h" "unexcoff.c")
;; No longer distributed: src/makefile.nt, lisp/makefile.nt
;; winnt.el renamed to w32-fns.el; nt.[ch] to w32.[ch];
;; ntheap.[ch] to w32heap.[ch]; ntinevt.c to w32inevt.c;
@@ -427,6 +476,7 @@ Changes to files in this list are not listed.")
("Geoff Voelker" :wrote "w32-fns.el" "w32.c" "w32.h" "w32heap.c"
"w32heap.h" "w32inevt.c" "w32proc.c" "w32term.c" "ms-w32.h")
("Morten Welinder" :wrote "dosfns.c" "[many MS-DOS files]" "msdos.h")
+ ("Eli Zaretskii" :wrote "bidi.c" "[bidirectional display in xdisp.c]")
;; Not using this version any more.
;;; ("Pace Willisson" :wrote "ispell.el")
;; FIXME overwritten by Author:.
@@ -457,17 +507,23 @@ Changes to files in this list are not listed.")
"getdate.y"
"ymakefile"
"permute-index" "index.perm"
+ "ibmrs6000.inp"
+ "b2m.c" "b2m.1" "b2m.pl"
+ "emacs.bash" "emacs.csh" "ms-kermit"
"emacs.ico"
"emacs21.ico"
- "LPF" "LEDIT" "OTHER.EMACSES"
+ "BABYL" "LPF" "LEDIT" "OTHER.EMACSES"
"emacs16_mac.png" "emacs24_mac.png"
"emacs256_mac.png" "emacs32_mac.png"
"emacs48_mac.png" "emacs512_mac.png"
+ "revdiff" ; admin/
+ "mainmake" "sed1.inp" "sed2.inp" "sed3.inp" ; msdos/
+ "mac-fix-env.m"
;; Deleted vms stuff:
"temacs.opt" "descrip.mms" "compile.com" "link.com"
)
- "File names which are valid, but no longer exist (or cannot be
-found) in the repository.")
+ "File names which are valid, but no longer exist (or cannot be found)
+in the repository.")
(defconst authors-renamed-files-alist
'(("nt.c" . "w32.c") ("nt.h" . "w32.h")
@@ -504,6 +560,7 @@ found) in the repository.")
;; index and pick merged into search.
("mh-index.el" . "mh-search.el")
("mh-pick.el" . "mh-search.el")
+ ("font-setting.el" . "dynamic-setting.el")
;; INSTALL-CVS -> .CVS -> .BZR
("INSTALL-CVS" . "INSTALL.BZR")
("INSTALL.CVS" . "INSTALL.BZR")
@@ -529,12 +586,16 @@ found) in the repository.")
("schema/docbook-dyntbl.rnc" . "schema/docbk-dyntbl.rnc")
("schema/docbook-soextbl.rnc" . "schema/docbk-soextbl.rn" )
("texi/url.txi" . "url.texi")
+ ("edt-user.doc" . "edt.texi")
+ ("DEV-NOTES" . "nextstep")
;; Moved to different directories.
("ctags.1" . "ctags.1")
("etags.1" . "etags.1")
("emacs.1" . "emacs.1")
("emacsclient.1" . "emacsclient.1")
("icons/emacs21.ico" . "emacs21.ico")
+ ;; Moved from admin/nt/ to nt/.
+ ("nt/README.W32" . "README.W32")
)
"Alist of files which have been renamed during their lifetime.
Elements are (OLDNAME . NEWNAME).")
@@ -573,10 +634,25 @@ Otherwise, the file name is accepted as is.")
(defvar authors-checked-files-alist)
(defvar authors-invalid-file-names)
+(defun authors-disambiguate-file-name (fullname)
+ "Convert FULLNAME to an unambiguous relative-name."
+ (let ((relname (file-name-nondirectory fullname))
+ parent)
+ (if (member relname authors-ambiguous-files)
+ ;; In case of ambiguity, just prepend the parent directory.
+ ;; FIXME obviously this is not a perfect solution.
+ (if (string-equal "lisp"
+ (setq parent (file-name-nondirectory
+ (directory-file-name
+ (file-name-directory fullname)))))
+ relname
+ (format "%s/%s" parent relname))
+ relname)))
+
(defun authors-canonical-file-name (file log-file pos author)
"Return canonical file name for FILE found in LOG-FILE.
Checks whether FILE is a valid (existing) file name, has been renamed,
-or is on the list of removed files. Returns the non-diretory part of
+or is on the list of removed files. Returns the non-directory part of
the file name. Only uses the LOG-FILE position POS and associated AUTHOR
to print a message if FILE is not found."
;; FILE should be re-checked in every different directory associated
@@ -593,7 +669,7 @@ to print a message if FILE is not found."
(file-exists-p file)
(file-exists-p relname)
(file-exists-p (concat "etc/" relname)))
- (setq valid relname)
+ (setq valid (authors-disambiguate-file-name fullname))
(setq valid (assoc file authors-renamed-files-alist))
(if valid
(setq valid (cdr valid))
@@ -610,6 +686,7 @@ to print a message if FILE is not found."
(cons (cons fullname valid) authors-checked-files-alist))
(unless (or valid
(member file authors-ignored-files)
+ (authors-obsolete-file-p file)
(string-match "[*]" file)
(string-match "^[0-9.]+$" file))
(setq authors-invalid-file-names
@@ -758,7 +835,7 @@ TABLE is a hash table to add author information to."
(enable-local-variables :safe) ; for find-file, hence let*
(enable-local-eval nil)
(buffer (find-file-noselect file)))
- (setq file (file-name-nondirectory file))
+ (setq file (authors-disambiguate-file-name (expand-file-name file)))
(with-current-buffer buffer
(save-restriction
(widen)
@@ -956,5 +1033,4 @@ the Emacs source tree, from which to build the file."
(provide 'authors)
-;; arch-tag: 659d5900-5ff2-43b0-954c-a315cc1e4dc1
;;; authors.el ends here
diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el
index 5ae984ffdb0..4dd1a118ebd 100644
--- a/lisp/emacs-lisp/autoload.el
+++ b/lisp/emacs-lisp/autoload.el
@@ -1,11 +1,12 @@
;; autoload.el --- maintain autoloads in loaddefs.el
-;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 2001, 2002, 2003,
+;; 2004, 2005, 2006, 2007, 2008, 2009, 2010
;; Free Software Foundation, Inc.
;; Author: Roland McGrath <roland@gnu.org>
;; Keywords: maint
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -109,29 +110,48 @@ or macro definition or a defcustom)."
(let* ((macrop (memq car '(defmacro defmacro*)))
(name (nth 1 form))
(args (case car
- ((defun defmacro defun* defmacro*
- define-overloadable-function) (nth 2 form))
- ((define-skeleton) '(&optional str arg))
- ((define-generic-mode define-derived-mode
- define-compilation-mode) nil)
- (t)))
+ ((defun defmacro defun* defmacro*
+ define-overloadable-function) (nth 2 form))
+ ((define-skeleton) '(&optional str arg))
+ ((define-generic-mode define-derived-mode
+ define-compilation-mode) nil)
+ (t)))
(body (nthcdr (get car 'doc-string-elt) form))
(doc (if (stringp (car body)) (pop body))))
(when (listp args)
;; Add the usage form at the end where describe-function-1
;; can recover it.
(setq doc (help-add-fundoc-usage doc args)))
- ;; `define-generic-mode' quotes the name, so take care of that
- (list 'autoload (if (listp name) name (list 'quote name)) file doc
- (or (and (memq car '(define-skeleton define-derived-mode
- define-generic-mode
- easy-mmode-define-global-mode
- define-global-minor-mode
- define-globalized-minor-mode
- easy-mmode-define-minor-mode
- define-minor-mode)) t)
- (eq (car-safe (car body)) 'interactive))
- (if macrop (list 'quote 'macro) nil))))
+ (let ((exp
+ ;; `define-generic-mode' quotes the name, so take care of that
+ (list 'autoload (if (listp name) name (list 'quote name))
+ file doc
+ (or (and (memq car '(define-skeleton define-derived-mode
+ define-generic-mode
+ easy-mmode-define-global-mode
+ define-global-minor-mode
+ define-globalized-minor-mode
+ easy-mmode-define-minor-mode
+ define-minor-mode)) t)
+ (eq (car-safe (car body)) 'interactive))
+ (if macrop (list 'quote 'macro) nil))))
+ (when macrop
+ ;; Special case to autoload some of the macro's declarations.
+ (let ((decls (nth (if (stringp (nth 3 form)) 4 3) form))
+ (exps '()))
+ (when (eq (car decls) 'declare)
+ ;; FIXME: We'd like to reuse macro-declaration-function,
+ ;; but we can't since it doesn't return anything.
+ (dolist (decl decls)
+ (case (car-safe decl)
+ (indent
+ (push `(put ',name 'lisp-indent-function ',(cadr decl))
+ exps))
+ (doc-string
+ (push `(put ',name 'doc-string-elt ',(cadr decl)) exps))))
+ (when exps
+ (setq exp `(progn ,exp ,@exps))))))
+ exp)))
;; For defclass forms, use `eieio-defclass-autoload'.
((eq car 'defclass)
@@ -259,14 +279,17 @@ put the output in."
TYPE (default \"autoloads\") is a string stating the type of
information contained in FILE. If FEATURE is non-nil, FILE
will provide a feature. FEATURE may be a string naming the
-feature, otherwise it will be based on FILE's name."
+feature, otherwise it will be based on FILE's name.
+
+At present, a feature is in fact always provided, but this should
+not be relied upon."
(let ((basename (file-name-nondirectory file)))
(concat ";;; " basename
" --- automatically extracted " (or type "autoloads") "\n"
";;\n"
";;; Code:\n\n"
" \n"
- ;; This is used outside of autoload.el.
+ ;; This is used outside of autoload.el, eg cus-dep, finder.
"(provide '"
(if (stringp feature)
feature
@@ -325,7 +348,29 @@ which lists the file name and which functions are in it, etc."
"File local variable to prevent scanning this file for autoload cookies.")
(defun autoload-file-load-name (file)
- (let ((name (file-name-nondirectory file)))
+ "Compute the name that will be used to load FILE."
+ ;; OUTFILE should be the name of the global loaddefs.el file, which
+ ;; is expected to be at the root directory of the files we're
+ ;; scanning for autoloads and will be in the `load-path'.
+ (let* ((outfile (default-value 'generated-autoload-file))
+ (name (file-relative-name file (file-name-directory outfile)))
+ (names '())
+ (dir (file-name-directory outfile)))
+ ;; If `name' has directory components, only keep the
+ ;; last few that are really needed.
+ (while name
+ (setq name (directory-file-name name))
+ (push (file-name-nondirectory name) names)
+ (setq name (file-name-directory name)))
+ (while (not name)
+ (cond
+ ((null (cdr names)) (setq name (car names)))
+ ((file-exists-p (expand-file-name "subdirs.el" dir))
+ ;; FIXME: here we only check the existence of subdirs.el,
+ ;; without checking its content. This makes it generate wrong load
+ ;; names for cases like lisp/term which is not added to load-path.
+ (setq dir (expand-file-name (pop names) dir)))
+ (t (setq name (mapconcat 'identity names "/")))))
(if (string-match "\\.elc?\\(\\.\\|\\'\\)" name)
(substring name 0 (match-beginning 0))
name)))
@@ -340,6 +385,8 @@ Return non-nil in the case where no autoloads were added at point."
(interactive "fGenerate autoloads for file: ")
(autoload-generate-file-autoloads file (current-buffer)))
+(defvar print-readably)
+
;; When called from `generate-file-autoloads' we should ignore
;; `generated-autoload-file' altogether. When called from
;; `update-file-autoloads' we don't know `outbuf'. And when called from
@@ -370,9 +417,8 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE
(visited (get-file-buffer file))
(otherbuf nil)
(absfile (expand-file-name file))
- relfile
;; nil until we found a cookie.
- output-start)
+ output-start ostart)
(with-current-buffer (or visited
;; It is faster to avoid visiting the file.
(autoload-find-file file))
@@ -382,7 +428,10 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE
(setq load-name
(if (stringp generated-autoload-load-name)
generated-autoload-load-name
- (autoload-file-load-name file)))
+ (autoload-file-load-name absfile)))
+ (when (and outfile
+ (not (equal outfile (autoload-generated-file))))
+ (setq otherbuf t))
(save-excursion
(save-restriction
(widen)
@@ -393,26 +442,22 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE
((looking-at (regexp-quote generate-autoload-cookie))
;; If not done yet, figure out where to insert this text.
(unless output-start
- (when (and outfile
- (not (equal outfile (autoload-generated-file))))
- ;; A file-local setting of autoload-generated-file says
- ;; we should ignore OUTBUF.
- (setq outbuf nil)
- (setq otherbuf t))
- (unless outbuf
- (setq outbuf (autoload-find-destination absfile))
- (unless outbuf
- ;; The file has autoload cookies, but they're
- ;; already up-to-date. If OUTFILE is nil, the
- ;; entries are in the expected OUTBUF, otherwise
- ;; they're elsewhere.
- (throw 'done outfile)))
- (with-current-buffer outbuf
- (setq relfile (file-relative-name absfile))
- (setq output-start (point)))
- ;; (message "file=%S, relfile=%S, dest=%S"
- ;; file relfile (autoload-generated-file))
- )
+ (let ((outbuf
+ (or (if otherbuf
+ ;; A file-local setting of
+ ;; autoload-generated-file says we
+ ;; should ignore OUTBUF.
+ nil
+ outbuf)
+ (autoload-find-destination absfile load-name)
+ ;; The file has autoload cookies, but they're
+ ;; already up-to-date. If OUTFILE is nil, the
+ ;; entries are in the expected OUTBUF,
+ ;; otherwise they're elsewhere.
+ (throw 'done otherbuf))))
+ (with-current-buffer outbuf
+ (setq output-start (point-marker)
+ ostart (point)))))
(search-forward generate-autoload-cookie)
(skip-chars-forward " \t")
(if (eolp)
@@ -424,7 +469,8 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE
(if autoload
(push (nth 1 form) autoloads-done)
(setq autoload form))
- (let ((autoload-print-form-outbuf outbuf))
+ (let ((autoload-print-form-outbuf
+ (marker-buffer output-start)))
(autoload-print-form autoload)))
(error
(message "Error in %s: %S" file err)))
@@ -439,7 +485,7 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE
(forward-char 1))
(point))
(progn (forward-line 1) (point)))
- outbuf)))
+ (marker-buffer output-start))))
((looking-at ";")
;; Don't read the comment.
(forward-line 1))
@@ -451,40 +497,44 @@ Return non-nil if and only if FILE adds no autoloads to OUTFILE
(let ((secondary-autoloads-file-buf
(if (local-variable-p 'generated-autoload-file)
(current-buffer))))
- (with-current-buffer outbuf
+ (with-current-buffer (marker-buffer output-start)
(save-excursion
;; Insert the section-header line which lists the file name
;; and which functions are in it, etc.
+ (assert (= ostart output-start))
(goto-char output-start)
- (autoload-insert-section-header
- outbuf autoloads-done load-name relfile
- (if secondary-autoloads-file-buf
- ;; MD5 checksums are much better because they do not
- ;; change unless the file changes (so they'll be
- ;; equal on two different systems and will change
- ;; less often than time-stamps, thus leading to fewer
- ;; unneeded changes causing spurious conflicts), but
- ;; using time-stamps is a very useful optimization,
- ;; so we use time-stamps for the main autoloads file
- ;; (loaddefs.el) where we have special ways to
- ;; circumvent the "random change problem", and MD5
- ;; checksum in secondary autoload files where we do
- ;; not need the time-stamp optimization because it is
- ;; already provided by the primary autoloads file.
- (md5 secondary-autoloads-file-buf
- ;; We'd really want to just use
- ;; `emacs-internal' instead.
- nil nil 'emacs-mule-unix)
- (nth 5 (file-attributes relfile))))
- (insert ";;; Generated autoloads from " relfile "\n"))
+ (let ((relfile (file-relative-name absfile)))
+ (autoload-insert-section-header
+ (marker-buffer output-start)
+ autoloads-done load-name relfile
+ (if secondary-autoloads-file-buf
+ ;; MD5 checksums are much better because they do not
+ ;; change unless the file changes (so they'll be
+ ;; equal on two different systems and will change
+ ;; less often than time-stamps, thus leading to fewer
+ ;; unneeded changes causing spurious conflicts), but
+ ;; using time-stamps is a very useful optimization,
+ ;; so we use time-stamps for the main autoloads file
+ ;; (loaddefs.el) where we have special ways to
+ ;; circumvent the "random change problem", and MD5
+ ;; checksum in secondary autoload files where we do
+ ;; not need the time-stamp optimization because it is
+ ;; already provided by the primary autoloads file.
+ (md5 secondary-autoloads-file-buf
+ ;; We'd really want to just use
+ ;; `emacs-internal' instead.
+ nil nil 'emacs-mule-unix)
+ (nth 5 (file-attributes relfile))))
+ (insert ";;; Generated autoloads from " relfile "\n")))
(insert generate-autoload-section-trailer))))
(message "Generating autoloads for %s...done" file))
(or visited
;; We created this buffer, so we should kill it.
(kill-buffer (current-buffer))))
- ;; If the entries were added to some other buffer, then the file
- ;; doesn't add entries to OUTFILE.
- (or (not output-start) otherbuf))))
+ (or (not output-start)
+ ;; If the entries were added to some other buffer, then the file
+ ;; doesn't add entries to OUTFILE.
+ otherbuf))))
(defun autoload-save-buffers ()
(while autoload-modified-buffers
@@ -508,15 +558,14 @@ Return FILE if there was no autoload cookie in it, else nil."
(message "Autoload section for %s is up to date." file)))
(if no-autoloads file)))
-(defun autoload-find-destination (file)
+(defun autoload-find-destination (file load-name)
"Find the destination point of the current buffer's autoloads.
FILE is the file name of the current buffer.
Returns a buffer whose point is placed at the requested location.
Returns nil if the file's autoloads are uptodate, otherwise
removes any prior now out-of-date autoload entries."
(catch 'up-to-date
- (let* ((load-name (autoload-file-load-name file))
- (buf (current-buffer))
+ (let* ((buf (current-buffer))
(existing-buffer (if buffer-file-name buf))
(found nil))
(with-current-buffer
@@ -529,7 +578,7 @@ removes any prior now out-of-date autoload entries."
(or (eq 0 (coding-system-eol-type buffer-file-coding-system))
(set-buffer-file-coding-system 'unix))
(or (> (buffer-size) 0)
- (error "Autoloads file %s does not exist" buffer-file-name))
+ (error "Autoloads file %s lacks boilerplate" buffer-file-name))
(or (file-writable-p buffer-file-name)
(error "Autoloads file %s is not writable" buffer-file-name))
(widen)
@@ -649,6 +698,7 @@ directory or directories specified."
(t
(autoload-remove-section (match-beginning 0))
(if (autoload-generate-file-autoloads
+ ;; Passing `current-buffer' makes it insert at point.
file (current-buffer) buffer-file-name)
(push file no-autoloads))))
(push file done)
@@ -657,6 +707,9 @@ directory or directories specified."
(dolist (file files)
(cond
((member (expand-file-name file) autoload-excludes) nil)
+ ;; Passing nil as second argument forces
+ ;; autoload-generate-file-autoloads to look for the right
+ ;; spot where to insert each autoloads section.
((autoload-generate-file-autoloads file nil buffer-file-name)
(push file no-autoloads))))
@@ -725,11 +778,13 @@ Calls `update-directory-autoloads' on the command line arguments."
(with-temp-buffer
(insert-file-contents mfile)
(when (re-search-forward "^shortlisp= " nil t)
- (setq lim (line-end-position))
- (while (re-search-forward "\\.\\./lisp/\\([^ ]+\\.el\\)c?\\>"
- lim t)
+ (while (and (not lim)
+ (re-search-forward "\\.\\./lisp/\\([^ ]+\\.el\\)c?\\>"
+ nil t))
(push (expand-file-name (match-string 1) ldir)
- autoload-excludes))))))))
+ autoload-excludes)
+ (skip-chars-forward " \t")
+ (if (eolp) (setq lim t)))))))))
(let ((args command-line-args-left))
(setq command-line-args-left nil)
(apply 'update-directory-autoloads args)))
diff --git a/lisp/emacs-lisp/backquote.el b/lisp/emacs-lisp/backquote.el
index 998cee15342..96e2fb41e89 100644
--- a/lisp/emacs-lisp/backquote.el
+++ b/lisp/emacs-lisp/backquote.el
@@ -6,6 +6,7 @@
;; Author: Rick Sladkey <jrs@world.std.com>
;; Maintainer: FSF
;; Keywords: extensions, internal
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 7605f457316..2666fc5b9b7 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -7,6 +7,7 @@
;; Hallvard Furuseth <hbf@ulrik.uio.no>
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -1315,35 +1316,38 @@
"Don't call this!"
;; fetch and return the offset for the current opcode.
;; return nil if this opcode has no offset
- ;; OP, PTR and BYTES are used and set dynamically
- (defvar op)
- (defvar ptr)
- (defvar bytes)
- (cond ((< op byte-nth)
- (let ((tem (logand op 7)))
- (setq op (logand op 248))
+ ;; Used and set dynamically in byte-decompile-bytecode-1.
+ (defvar bytedecomp-op)
+ (defvar bytedecomp-ptr)
+ (defvar bytedecomp-bytes)
+ (cond ((< bytedecomp-op byte-nth)
+ (let ((tem (logand bytedecomp-op 7)))
+ (setq bytedecomp-op (logand bytedecomp-op 248))
(cond ((eq tem 6)
- (setq ptr (1+ ptr)) ;offset in next byte
- (aref bytes ptr))
+ ;; Offset in next byte.
+ (setq bytedecomp-ptr (1+ bytedecomp-ptr))
+ (aref bytedecomp-bytes bytedecomp-ptr))
((eq tem 7)
- (setq ptr (1+ ptr)) ;offset in next 2 bytes
- (+ (aref bytes ptr)
- (progn (setq ptr (1+ ptr))
- (lsh (aref bytes ptr) 8))))
+ ;; Offset in next 2 bytes.
+ (setq bytedecomp-ptr (1+ bytedecomp-ptr))
+ (+ (aref bytedecomp-bytes bytedecomp-ptr)
+ (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr))
+ (lsh (aref bytedecomp-bytes bytedecomp-ptr) 8))))
(t tem)))) ;offset was in opcode
- ((>= op byte-constant)
- (prog1 (- op byte-constant) ;offset in opcode
- (setq op byte-constant)))
- ((and (>= op byte-constant2)
- (<= op byte-goto-if-not-nil-else-pop))
- (setq ptr (1+ ptr)) ;offset in next 2 bytes
- (+ (aref bytes ptr)
- (progn (setq ptr (1+ ptr))
- (lsh (aref bytes ptr) 8))))
- ((and (>= op byte-listN)
- (<= op byte-insertN))
- (setq ptr (1+ ptr)) ;offset in next byte
- (aref bytes ptr))))
+ ((>= bytedecomp-op byte-constant)
+ (prog1 (- bytedecomp-op byte-constant) ;offset in opcode
+ (setq bytedecomp-op byte-constant)))
+ ((and (>= bytedecomp-op byte-constant2)
+ (<= bytedecomp-op byte-goto-if-not-nil-else-pop))
+ ;; Offset in next 2 bytes.
+ (setq bytedecomp-ptr (1+ bytedecomp-ptr))
+ (+ (aref bytedecomp-bytes bytedecomp-ptr)
+ (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr))
+ (lsh (aref bytedecomp-bytes bytedecomp-ptr) 8))))
+ ((and (>= bytedecomp-op byte-listN)
+ (<= bytedecomp-op byte-insertN))
+ (setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;offset in next byte
+ (aref bytedecomp-bytes bytedecomp-ptr))))
;; This de-compiler is used for inline expansion of compiled functions,
@@ -1366,19 +1370,20 @@
;; If MAKE-SPLICEABLE is nil, we are being called for the disassembler.
;; In that case, we put a pc value into the list
;; before each insn (or its label).
-(defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable)
- (let ((length (length bytes))
- (ptr 0) optr tags op offset
+(defun byte-decompile-bytecode-1 (bytedecomp-bytes constvec
+ &optional make-spliceable)
+ (let ((length (length bytedecomp-bytes))
+ (bytedecomp-ptr 0) optr tags bytedecomp-op offset
lap tmp
endtag)
- (while (not (= ptr length))
+ (while (not (= bytedecomp-ptr length))
(or make-spliceable
- (setq lap (cons ptr lap)))
- (setq op (aref bytes ptr)
- optr ptr
+ (setq lap (cons bytedecomp-ptr lap)))
+ (setq bytedecomp-op (aref bytedecomp-bytes bytedecomp-ptr)
+ optr bytedecomp-ptr
offset (disassemble-offset)) ; this does dynamic-scope magic
- (setq op (aref byte-code-vector op))
- (cond ((memq op byte-goto-ops)
+ (setq bytedecomp-op (aref byte-code-vector bytedecomp-op))
+ (cond ((memq bytedecomp-op byte-goto-ops)
;; it's a pc
(setq offset
(cdr (or (assq offset tags)
@@ -1386,27 +1391,28 @@
(cons (cons offset
(byte-compile-make-tag))
tags)))))))
- ((cond ((eq op 'byte-constant2) (setq op 'byte-constant) t)
- ((memq op byte-constref-ops)))
+ ((cond ((eq bytedecomp-op 'byte-constant2)
+ (setq bytedecomp-op 'byte-constant) t)
+ ((memq bytedecomp-op byte-constref-ops)))
(setq tmp (if (>= offset (length constvec))
(list 'out-of-range offset)
(aref constvec offset))
- offset (if (eq op 'byte-constant)
+ offset (if (eq bytedecomp-op 'byte-constant)
(byte-compile-get-constant tmp)
(or (assq tmp byte-compile-variables)
(car (setq byte-compile-variables
(cons (list tmp)
byte-compile-variables)))))))
((and make-spliceable
- (eq op 'byte-return))
- (if (= ptr (1- length))
- (setq op nil)
+ (eq bytedecomp-op 'byte-return))
+ (if (= bytedecomp-ptr (1- length))
+ (setq bytedecomp-op nil)
(setq offset (or endtag (setq endtag (byte-compile-make-tag)))
- op 'byte-goto))))
+ bytedecomp-op 'byte-goto))))
;; lap = ( [ (pc . (op . arg)) ]* )
- (setq lap (cons (cons optr (cons op (or offset 0)))
+ (setq lap (cons (cons optr (cons bytedecomp-op (or offset 0)))
lap))
- (setq ptr (1+ ptr)))
+ (setq bytedecomp-ptr (1+ bytedecomp-ptr)))
;; take off the dummy nil op that we replaced a trailing "return" with.
(let ((rest lap))
(while rest
@@ -2035,5 +2041,4 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
byte-optimize-lapcode))))
nil)
-;; arch-tag: 0f14076b-737e-4bef-aae6-908826ec1ff1
;;; byte-opt.el ends here
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index e6810fc8b72..0388435dbc2 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -7,6 +7,7 @@
;; Hallvard Furuseth <hbf@ulrik.uio.no>
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -65,7 +66,6 @@ The return value of this function is not used."
;; Redefined in byte-optimize.el.
;; This is not documented--it's not clear that we should promote it.
(fset 'inline 'progn)
-(put 'inline 'lisp-indent-function 0)
;;; Interface to inline functions.
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index cdfac80ca78..f04aad994f3 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -1,12 +1,14 @@
;;; bytecomp.el --- compilation of Lisp code into byte code
;; Copyright (C) 1985, 1986, 1987, 1992, 1994, 1998, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Jamie Zawinski <jwz@lucid.com>
;; Hallvard Furuseth <hbf@ulrik.uio.no>
;; Maintainer: FSF
;; Keywords: lisp
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -35,6 +37,7 @@
;; ========================================================================
;; Entry points:
;; byte-recompile-directory, byte-compile-file,
+;; byte-recompile-file,
;; batch-byte-compile, batch-byte-recompile-directory,
;; byte-compile, compile-defun,
;; display-call-tree
@@ -245,10 +248,14 @@ This option is enabled by default because it reduces Emacs memory usage."
:type 'boolean)
;;;###autoload(put 'byte-compile-dynamic-docstrings 'safe-local-variable 'booleanp)
+(defconst byte-compile-log-buffer "*Compile-Log*"
+ "Name of the byte-compiler's log buffer.")
+
(defcustom byte-optimize-log nil
- "If true, the byte-compiler will log its optimizations into *Compile-Log*.
+ "If non-nil, the byte-compiler will log its optimizations.
If this is 'source, then only source-level optimizations will be logged.
-If it is 'byte, then only byte-level optimizations will be logged."
+If it is 'byte, then only byte-level optimizations will be logged.
+The information is logged to `byte-compile-log-buffer'."
:group 'bytecomp
:type '(choice (const :tag "none" nil)
(const :tag "all" t)
@@ -263,7 +270,7 @@ If it is 'byte, then only byte-level optimizations will be logged."
(defconst byte-compile-warning-types
'(redefine callargs free-vars unresolved
obsolete noruntime cl-functions interactive-only
- make-local mapcar constants suspicious)
+ make-local mapcar constants suspicious lexical)
"The list of warning types used when `byte-compile-warnings' is t.")
(defcustom byte-compile-warnings t
"List of warnings that the byte-compiler should issue (t for all).
@@ -873,7 +880,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
;; Log something that isn't a warning.
(defun byte-compile-log-1 (string)
- (with-current-buffer "*Compile-Log*"
+ (with-current-buffer byte-compile-log-buffer
(let ((inhibit-read-only t))
(goto-char (point-max))
(byte-compile-warning-prefix nil nil)
@@ -981,13 +988,13 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
;; (compile-mode) will cause this to be loaded.
(declare-function compilation-forget-errors "compile" ())
-;; Log the start of a file in *Compile-Log*, and mark it as done.
+;; Log the start of a file in `byte-compile-log-buffer', and mark it as done.
;; Return the position of the start of the page in the log buffer.
;; But do nothing in batch mode.
(defun byte-compile-log-file ()
(and (not (equal byte-compile-current-file byte-compile-last-logged-file))
(not noninteractive)
- (with-current-buffer (get-buffer-create "*Compile-Log*")
+ (with-current-buffer (get-buffer-create byte-compile-log-buffer)
(goto-char (point-max))
(let* ((inhibit-read-only t)
(dir (and byte-compile-current-file
@@ -1018,14 +1025,14 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(compilation-forget-errors)
pt))))
-;; Log a message STRING in *Compile-Log*.
+;; Log a message STRING in `byte-compile-log-buffer'.
;; Also log the current function and file if not already done.
(defun byte-compile-log-warning (string &optional fill level)
(let ((warning-prefix-function 'byte-compile-warning-prefix)
(warning-type-format "")
(warning-fill-prefix (if fill " "))
(inhibit-read-only t))
- (display-warning 'bytecomp string level "*Compile-Log*")))
+ (display-warning 'bytecomp string level byte-compile-log-buffer)))
(defun byte-compile-warn (format &rest args)
"Issue a byte compiler warning; use (format FORMAT ARGS...) for message."
@@ -1332,7 +1339,7 @@ extra args."
(not (and (eq (get func 'byte-compile)
'cl-byte-compile-compiler-macro)
(string-match "\\`c[ad]+r\\'" (symbol-name func)))))
- (byte-compile-warn "Function `%s' from cl package called at runtime"
+ (byte-compile-warn "function `%s' from cl package called at runtime"
func)))
form)
@@ -1441,7 +1448,7 @@ symbol itself."
(warning-series-started
(and (markerp warning-series)
(eq (marker-buffer warning-series)
- (get-buffer "*Compile-Log*")))))
+ (get-buffer byte-compile-log-buffer)))))
(byte-compile-find-cl-functions)
(if (or (eq warning-series 'byte-compile-warning-series)
warning-series-started)
@@ -1503,7 +1510,7 @@ that already has a `.elc' file."
nil
(save-some-buffers)
(force-mode-line-update))
- (with-current-buffer (get-buffer-create "*Compile-Log*")
+ (with-current-buffer (get-buffer-create byte-compile-log-buffer)
(setq default-directory (expand-file-name bytecomp-directory))
;; compilation-mode copies value of default-directory.
(unless (eq major-mode 'compilation-mode)
@@ -1538,22 +1545,12 @@ that already has a `.elc' file."
(if (and (string-match emacs-lisp-file-regexp bytecomp-source)
(file-readable-p bytecomp-source)
(not (auto-save-file-name-p bytecomp-source))
- (setq bytecomp-dest
- (byte-compile-dest-file bytecomp-source))
- (if (file-exists-p bytecomp-dest)
- ;; File was already compiled.
- (or bytecomp-force
- (file-newer-than-file-p bytecomp-source
- bytecomp-dest))
- ;; No compiled file exists yet.
- (and bytecomp-arg
- (or (eq 0 bytecomp-arg)
- (y-or-n-p (concat "Compile "
- bytecomp-source "? "))))))
- (progn (if (and noninteractive (not byte-compile-verbose))
- (message "Compiling %s..." bytecomp-source))
- (let ((bytecomp-res (byte-compile-file
- bytecomp-source)))
+ (not (string-equal dir-locals-file
+ (file-name-nondirectory
+ bytecomp-source))))
+ (progn (let ((bytecomp-res (byte-recompile-file
+ bytecomp-source
+ bytecomp-force bytecomp-arg)))
(cond ((eq bytecomp-res 'no-byte-compile)
(setq skip-count (1+ skip-count)))
((eq bytecomp-res t)
@@ -1581,6 +1578,60 @@ This is normally set in local file variables at the end of the elisp file:
;; Local Variables:\n;; no-byte-compile: t\n;; End: ")
;;;###autoload(put 'no-byte-compile 'safe-local-variable 'booleanp)
+(defun byte-recompile-file (bytecomp-filename &optional bytecomp-force bytecomp-arg load)
+ "Recompile BYTECOMP-FILENAME file if it needs recompilation.
+This happens when its `.elc' file is older than itself.
+
+If the `.elc' file exists and is up-to-date, normally this
+function *does not* compile BYTECOMP-FILENAME. However, if the
+prefix argument BYTECOMP-FORCE is set, that means do compile
+BYTECOMP-FILENAME even if the destination already exists and is
+up-to-date.
+
+If the `.elc' file does not exist, normally this function *does
+not* compile BYTECOMP-FILENAME. If BYTECOMP-ARG is 0, that means
+compile the file even if it has never been compiled before.
+A nonzero BYTECOMP-ARG means ask the user.
+
+If LOAD is set, `load' the file after compiling.
+
+The value returned is the value returned by `byte-compile-file',
+or 'no-byte-compile if the file did not need recompilation."
+ (interactive
+ (let ((bytecomp-file buffer-file-name)
+ (bytecomp-file-name nil)
+ (bytecomp-file-dir nil))
+ (and bytecomp-file
+ (eq (cdr (assq 'major-mode (buffer-local-variables)))
+ 'emacs-lisp-mode)
+ (setq bytecomp-file-name (file-name-nondirectory bytecomp-file)
+ bytecomp-file-dir (file-name-directory bytecomp-file)))
+ (list (read-file-name (if current-prefix-arg
+ "Byte compile file: "
+ "Byte recompile file: ")
+ bytecomp-file-dir bytecomp-file-name nil)
+ current-prefix-arg)))
+ (let ((bytecomp-dest
+ (byte-compile-dest-file bytecomp-filename))
+ ;; Expand now so we get the current buffer's defaults
+ (bytecomp-filename (expand-file-name bytecomp-filename)))
+ (if (if (file-exists-p bytecomp-dest)
+ ;; File was already compiled
+ ;; Compile if forced to, or filename newer
+ (or bytecomp-force
+ (file-newer-than-file-p bytecomp-filename
+ bytecomp-dest))
+ (and bytecomp-arg
+ (or (eq 0 bytecomp-arg)
+ (y-or-n-p (concat "Compile "
+ bytecomp-filename "? ")))))
+ (progn
+ (if (and noninteractive (not byte-compile-verbose))
+ (message "Compiling %s..." bytecomp-filename))
+ (byte-compile-file bytecomp-filename load))
+ (when load (load bytecomp-filename))
+ 'no-byte-compile)))
+
;;;###autoload
(defun byte-compile-file (bytecomp-filename &optional load)
"Compile a file of Lisp code named BYTECOMP-FILENAME into a file of byte code.
@@ -1684,17 +1735,28 @@ The value is non-nil if there were no errors, nil if errors."
(insert "\n") ; aaah, unix.
(if (file-writable-p target-file)
;; We must disable any code conversion here.
- (let ((coding-system-for-write 'no-conversion))
+ (let* ((coding-system-for-write 'no-conversion)
+ ;; Write to a tempfile so that if another Emacs
+ ;; process is trying to load target-file (eg in a
+ ;; parallel bootstrap), it does not risk getting a
+ ;; half-finished file. (Bug#4196)
+ (tempfile (make-temp-name target-file))
+ (kill-emacs-hook
+ (cons (lambda () (ignore-errors (delete-file tempfile)))
+ kill-emacs-hook)))
(if (memq system-type '(ms-dos 'windows-nt))
(setq buffer-file-type t))
- (when (file-exists-p target-file)
- ;; Remove the target before writing it, so that any
- ;; hard-links continue to point to the old file (this makes
- ;; it possible for installed files to share disk space with
- ;; the build tree, without causing problems when emacs-lisp
- ;; files in the build tree are recompiled).
- (delete-file target-file))
- (write-region (point-min) (point-max) target-file))
+ (write-region (point-min) (point-max) tempfile nil 1)
+ ;; This has the intentional side effect that any
+ ;; hard-links to target-file continue to
+ ;; point to the old file (this makes it possible
+ ;; for installed files to share disk space with
+ ;; the build tree, without causing problems when
+ ;; emacs-lisp files in the build tree are
+ ;; recompiled). Previously this was accomplished by
+ ;; deleting target-file before writing it.
+ (rename-file tempfile target-file t)
+ (message "Wrote %s" target-file))
;; This is just to give a better error message than write-region
(signal 'file-error
(list "Opening output file"
@@ -1775,14 +1837,7 @@ With argument ARG, insert value in current buffer after the form."
(set-buffer-multibyte t)
(erase-buffer)
;; (emacs-lisp-mode)
- (setq case-fold-search nil)
- ;; This is a kludge. Some operating systems (OS/2, DOS) need to
- ;; write files containing binary information specially.
- ;; Under most circumstances, such files will be in binary
- ;; overwrite mode, so those OS's use that flag to guess how
- ;; they should write their data. Advise them that .elc files
- ;; need to be written carefully.
- (setq overwrite-mode 'overwrite-mode-binary))
+ (setq case-fold-search nil))
(displaying-byte-compile-warnings
(with-current-buffer bytecomp-inbuffer
(and bytecomp-filename
@@ -2131,6 +2186,11 @@ list that represents a doc string reference.
;; Since there is no doc string, we can compile this as a normal form,
;; and not do a file-boundary.
(byte-compile-keep-pending form)
+ (when (and (symbolp (nth 1 form))
+ (not (string-match "[-*/:$]" (symbol-name (nth 1 form))))
+ (byte-compile-warning-enabled-p 'lexical))
+ (byte-compile-warn "global/dynamic var `%s' lacks a prefix"
+ (nth 1 form)))
(push (nth 1 form) byte-compile-bound-variables)
(if (eq (car form) 'defconst)
(push (nth 1 form) byte-compile-const-variables))
@@ -3324,21 +3384,31 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
(setq for-effect nil)))
(defun byte-compile-setq-default (form)
- (let ((bytecomp-args (cdr form))
- setters)
- (while bytecomp-args
- (let ((var (car bytecomp-args)))
- (and (or (not (symbolp var))
- (byte-compile-const-symbol-p var t))
- (byte-compile-warning-enabled-p 'constants)
- (byte-compile-warn
- "variable assignment to %s `%s'"
- (if (symbolp var) "constant" "nonvariable")
- (prin1-to-string var)))
- (push (list 'set-default (list 'quote var) (car (cdr bytecomp-args)))
- setters))
- (setq bytecomp-args (cdr (cdr bytecomp-args))))
- (byte-compile-form (cons 'progn (nreverse setters)))))
+ (setq form (cdr form))
+ (if (> (length form) 2)
+ (let ((setters ()))
+ (while (consp form)
+ (push `(setq-default ,(pop form) ,(pop form)) setters))
+ (byte-compile-form (cons 'progn (nreverse setters))))
+ (let ((var (car form)))
+ (and (or (not (symbolp var))
+ (byte-compile-const-symbol-p var t))
+ (byte-compile-warning-enabled-p 'constants)
+ (byte-compile-warn
+ "variable assignment to %s `%s'"
+ (if (symbolp var) "constant" "nonvariable")
+ (prin1-to-string var)))
+ (byte-compile-normal-call `(set-default ',var ,@(cdr form))))))
+
+(byte-defop-compiler-1 set-default)
+(defun byte-compile-set-default (form)
+ (let ((varexp (car-safe (cdr-safe form))))
+ (if (eq (car-safe varexp) 'quote)
+ ;; If the varexp is constant, compile it as a setq-default
+ ;; so we get more warnings.
+ (byte-compile-setq-default `(setq-default ,(car-safe (cdr varexp))
+ ,@(cddr form)))
+ (byte-compile-normal-call form))))
(defun byte-compile-quote (form)
(byte-compile-constant (car (cdr form))))
@@ -3772,6 +3842,11 @@ that suppresses all warnings during execution of BODY."
(defun byte-compile-defvar (form)
;; This is not used for file-level defvar/consts with doc strings.
+ (when (and (symbolp (nth 1 form))
+ (not (string-match "[-*/:$]" (symbol-name (nth 1 form))))
+ (byte-compile-warning-enabled-p 'lexical))
+ (byte-compile-warn "global/dynamic var `%s' lacks a prefix"
+ (nth 1 form)))
(let ((fun (nth 0 form))
(var (nth 1 form))
(value (nth 2 form))
@@ -4220,6 +4295,8 @@ and corresponding effects."
(defvar byte-code-meter)
(defun byte-compile-report-ops ()
+ (or (boundp 'byte-metering-on)
+ (error "You must build Emacs with -DBYTE_CODE_METER to use this"))
(with-output-to-temp-buffer "*Meter*"
(set-buffer "*Meter*")
(let ((i 0) n op off)
@@ -4268,5 +4345,4 @@ and corresponding effects."
(run-hooks 'bytecomp-load-hook)
-;; arch-tag: 9c97b0f0-8745-4571-bfc3-8dceb677292a
;;; bytecomp.el ends here
diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el
index d2abdcffe0d..84bfd706afc 100644
--- a/lisp/emacs-lisp/chart.el
+++ b/lisp/emacs-lisp/chart.el
@@ -1,7 +1,7 @@
;;; chart.el --- Draw charts (bar charts, etc)
-;; Copyright (C) 1996, 1998, 1999, 2001, 2004, 2005, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1998, 1999, 2001, 2004, 2005, 2007, 2008, 2009,
+;; 2010 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 0.2
@@ -62,11 +62,7 @@
(require 'eieio)
;;; Code:
-(defvar chart-map nil "Keymap used in chart mode.")
-(if chart-map
- ()
- (setq chart-map (make-sparse-keymap))
- )
+(defvar chart-map (make-sparse-keymap) "Keymap used in chart mode.")
(defvar chart-local-object nil
"Local variable containing the locally displayed chart object.")
@@ -529,9 +525,9 @@ cons cells of the form (NAME . NUM). See `sort' for more details."
(defun chart-zap-chars (n)
"Zap up to N chars without deleting EOLs."
(if (not (eobp))
- (if (< n (- (save-excursion (end-of-line) (point)) (point)))
+ (if (< n (- (point-at-eol) (point)))
(delete-char n)
- (delete-region (point) (save-excursion (end-of-line) (point))))))
+ (delete-region (point) (point-at-eol)))))
(defun chart-display-label (label dir zone start end &optional face)
"Display LABEL in direction DIR in column/row ZONE between START and END.
@@ -750,5 +746,4 @@ SORT-PRED if desired."
(provide 'chart)
-;; arch-tag: 43847e44-5b45-465e-adc9-e505490a6b59
;;; chart.el ends here
diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el
index e7455b3fbb7..0a3b3c94ff6 100644
--- a/lisp/emacs-lisp/checkdoc.el
+++ b/lisp/emacs-lisp/checkdoc.el
@@ -1,7 +1,7 @@
;;; checkdoc.el --- check documentation strings for style requirements
-;; Copyright (C) 1997, 1998, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 1998, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 0.6.2
@@ -201,9 +201,9 @@ without asking, and complex changes are made by asking the user first.
The value `never' is the same as nil, never ask or change anything."
:group 'checkdoc
:type '(choice (const automatic)
- (const query)
- (const never)
- (other :tag "semiautomatic" semiautomatic)))
+ (const query)
+ (const never)
+ (other :tag "semiautomatic" semiautomatic)))
(defcustom checkdoc-bouncy-flag t
"Non-nil means to \"bounce\" to auto-fix locations.
@@ -250,10 +250,10 @@ system. Possible values are:
t - Always spell-check"
:group 'checkdoc
:type '(choice (const nil)
- (const defun)
- (const buffer)
- (const interactive)
- (const t)))
+ (const defun)
+ (const buffer)
+ (const interactive)
+ (const t)))
(defvar checkdoc-ispell-lisp-words
'("alist" "emacs" "etags" "keymap" "paren" "regexp" "sexp" "xemacs")
@@ -429,19 +429,15 @@ and experimental check. Do not modify this list without setting
the value of `checkdoc-common-verbs-regexp' to nil which cause it to
be re-created.")
-(defvar checkdoc-syntax-table nil
+(defvar checkdoc-syntax-table
+ (let ((st (make-syntax-table emacs-lisp-mode-syntax-table)))
+ ;; When dealing with syntax in doc strings, make sure that - are
+ ;; encompassed in words so we can use cheap \\> to get the end of a symbol,
+ ;; not the end of a word in a conglomerate.
+ (modify-syntax-entry ?- "w" st)
+ st)
"Syntax table used by checkdoc in document strings.")
-(if checkdoc-syntax-table
- nil
- (setq checkdoc-syntax-table (copy-syntax-table emacs-lisp-mode-syntax-table))
- ;; When dealing with syntax in doc strings, make sure that - are encompassed
- ;; in words so we can use cheap \\> to get the end of a symbol, not the
- ;; end of a word in a conglomerate.
- (modify-syntax-entry ?- "w" checkdoc-syntax-table)
- )
-
-
;;; Compatibility
;;
(defalias 'checkdoc-make-overlay
@@ -515,12 +511,11 @@ CHECK is a list of four strings stating the current status of each
test; the nth string describes the status of the nth test."
(let (temp-buffer-setup-hook)
(with-output-to-temp-buffer "*Checkdoc Status*"
- (princ-list
- "Buffer comments and tags: " (nth 0 check) "\n"
- "Documentation style: " (nth 1 check) "\n"
- "Message/Query text style: " (nth 2 check) "\n"
- "Unwanted Spaces: " (nth 3 check)
- )))
+ (mapc #'princ
+ (list "Buffer comments and tags: " (nth 0 check)
+ "\nDocumentation style: " (nth 1 check)
+ "\nMessage/Query text style: " (nth 2 check)
+ "\nUnwanted Spaces: " (nth 3 check)))))
(shrink-window-if-larger-than-buffer
(get-buffer-window "*Checkdoc Status*"))
(message nil)
@@ -623,7 +618,7 @@ style."
(recenter (/ (- (window-height) l) 2))))
(recenter))
(message "%s (C-h,%se,n,p,q)" (checkdoc-error-text
- (car (car err-list)))
+ (car (car err-list)))
(if (checkdoc-error-unfixable (car (car err-list)))
"" "f,"))
(save-excursion
@@ -713,20 +708,21 @@ style."
(delete-window (get-buffer-window "*Checkdoc Help*"))
(kill-buffer "*Checkdoc Help*"))
(with-output-to-temp-buffer "*Checkdoc Help*"
- (princ-list
- "Checkdoc Keyboard Summary:\n"
- (if (checkdoc-error-unfixable (car (car err-list)))
- ""
- (concat
- "f, y - auto Fix this warning without asking (if\
+ (with-current-buffer standard-output
+ (insert
+ "Checkdoc Keyboard Summary:\n"
+ (if (checkdoc-error-unfixable (car (car err-list)))
+ ""
+ (concat
+ "f, y - auto Fix this warning without asking (if\
available.)\n"
- " Very complex operations will still query.\n")
- )
- "e - Enter recursive Edit. Press C-M-c to exit.\n"
- "SPC, n - skip to the Next error.\n"
- "DEL, p - skip to the Previous error.\n"
- "q - Quit checkdoc.\n"
- "C-h - Toggle this help buffer."))
+ " Very complex operations will still query.\n")
+ )
+ "e - Enter recursive Edit. Press C-M-c to exit.\n"
+ "SPC, n - skip to the Next error.\n"
+ "DEL, p - skip to the Previous error.\n"
+ "q - Quit checkdoc.\n"
+ "C-h - Toggle this help buffer.")))
(shrink-window-if-larger-than-buffer
(get-buffer-window "*Checkdoc Help*"))))))
(if cdo (checkdoc-delete-overlay cdo)))))
@@ -826,9 +822,9 @@ assumes that the cursor is already positioned to perform the fix."
"Enter recursive edit to permit a user to fix some error checkdoc has found.
MSG is the error that was found, which is displayed in a help buffer."
(with-output-to-temp-buffer "*Checkdoc Help*"
- (princ-list
- "Error message:\n " msg
- "\n\nEdit to fix this problem, and press C-M-c to continue."))
+ (mapc #'princ
+ (list "Error message:\n " msg
+ "\n\nEdit to fix this problem, and press C-M-c to continue.")))
(shrink-window-if-larger-than-buffer
(get-buffer-window "*Checkdoc Help*"))
(message "When you're done editing press C-M-c to continue.")
@@ -947,14 +943,14 @@ if there is one."
(interactive "P")
(if take-notes (checkdoc-start-section "checkdoc-comments"))
(if (not buffer-file-name)
- (error "Can only check comments for a file buffer"))
+ (error "Can only check comments for a file buffer"))
(let* ((checkdoc-spellcheck-documentation-flag
(car (memq checkdoc-spellcheck-documentation-flag
'(buffer t))))
(checkdoc-autofix-flag (if take-notes 'never checkdoc-autofix-flag))
(e (checkdoc-file-comments-engine))
- (checkdoc-generate-compile-warnings-flag
- (or take-notes checkdoc-generate-compile-warnings-flag)))
+ (checkdoc-generate-compile-warnings-flag
+ (or take-notes checkdoc-generate-compile-warnings-flag)))
(if e (error "%s" (checkdoc-error-text e)))
(checkdoc-show-diagnostics)
e))
@@ -970,8 +966,8 @@ Optional argument INTERACT permits more interactive fixing."
(if take-notes (checkdoc-start-section "checkdoc-rogue-spaces"))
(let* ((checkdoc-autofix-flag (if take-notes 'never checkdoc-autofix-flag))
(e (checkdoc-rogue-space-check-engine nil nil interact))
- (checkdoc-generate-compile-warnings-flag
- (or take-notes checkdoc-generate-compile-warnings-flag)))
+ (checkdoc-generate-compile-warnings-flag
+ (or take-notes checkdoc-generate-compile-warnings-flag)))
(if (not (called-interactively-p 'interactive))
e
(if e
@@ -1207,40 +1203,37 @@ generating a buffered list of errors."
map)
"Keymap used to override evaluation key-bindings for documentation checking.")
-(define-obsolete-variable-alias 'checkdoc-minor-keymap
- 'checkdoc-minor-mode-map "21.1")
-
;; Add in a menubar with easy-menu
(easy-menu-define
- nil checkdoc-minor-mode-map "Checkdoc Minor Mode Menu"
- '("CheckDoc"
- ["Interactive Buffer Style Check" checkdoc t]
- ["Interactive Buffer Style and Spelling Check" checkdoc-ispell t]
- ["Check Buffer" checkdoc-current-buffer t]
- ["Check and Spell Buffer" checkdoc-ispell-current-buffer t]
- "---"
- ["Interactive Style Check" checkdoc-interactive t]
- ["Interactive Style and Spelling Check" checkdoc-ispell-interactive t]
- ["Find First Style Error" checkdoc-start t]
- ["Find First Style or Spelling Error" checkdoc-ispell-start t]
- ["Next Style Error" checkdoc-continue t]
- ["Next Style or Spelling Error" checkdoc-ispell-continue t]
- ["Interactive Message Text Style Check" checkdoc-message-interactive t]
- ["Interactive Message Text Style and Spelling Check"
- checkdoc-ispell-message-interactive t]
- ["Check Message Text" checkdoc-message-text t]
- ["Check and Spell Message Text" checkdoc-ispell-message-text t]
- ["Check Comment Style" checkdoc-comments buffer-file-name]
- ["Check Comment Style and Spelling" checkdoc-ispell-comments
- buffer-file-name]
- ["Check for Rogue Spaces" checkdoc-rogue-spaces t]
- "---"
- ["Check Defun" checkdoc-defun t]
- ["Check and Spell Defun" checkdoc-ispell-defun t]
- ["Check and Evaluate Defun" checkdoc-eval-defun t]
- ["Check and Evaluate Buffer" checkdoc-eval-current-buffer t]
- ))
+ nil checkdoc-minor-mode-map "Checkdoc Minor Mode Menu"
+ '("CheckDoc"
+ ["Interactive Buffer Style Check" checkdoc t]
+ ["Interactive Buffer Style and Spelling Check" checkdoc-ispell t]
+ ["Check Buffer" checkdoc-current-buffer t]
+ ["Check and Spell Buffer" checkdoc-ispell-current-buffer t]
+ "---"
+ ["Interactive Style Check" checkdoc-interactive t]
+ ["Interactive Style and Spelling Check" checkdoc-ispell-interactive t]
+ ["Find First Style Error" checkdoc-start t]
+ ["Find First Style or Spelling Error" checkdoc-ispell-start t]
+ ["Next Style Error" checkdoc-continue t]
+ ["Next Style or Spelling Error" checkdoc-ispell-continue t]
+ ["Interactive Message Text Style Check" checkdoc-message-interactive t]
+ ["Interactive Message Text Style and Spelling Check"
+ checkdoc-ispell-message-interactive t]
+ ["Check Message Text" checkdoc-message-text t]
+ ["Check and Spell Message Text" checkdoc-ispell-message-text t]
+ ["Check Comment Style" checkdoc-comments buffer-file-name]
+ ["Check Comment Style and Spelling" checkdoc-ispell-comments
+ buffer-file-name]
+ ["Check for Rogue Spaces" checkdoc-rogue-spaces t]
+ "---"
+ ["Check Defun" checkdoc-defun t]
+ ["Check and Spell Defun" checkdoc-ispell-defun t]
+ ["Check and Evaluate Defun" checkdoc-eval-defun t]
+ ["Check and Evaluate Buffer" checkdoc-eval-current-buffer t]
+ ))
;; XEmacs requires some weird stuff to add this menu in a minor mode.
;; What is it?
@@ -1369,7 +1362,7 @@ See the style guide in the Emacs Lisp manual for more details."
(setq checkdoc-autofix-flag 'never))))
(checkdoc-create-error
"You should convert this comment to documentation"
- (point) (save-excursion (end-of-line) (point))))
+ (point) (line-end-position)))
(checkdoc-create-error
(if (nth 2 fp)
"All interactive functions should have documentation"
@@ -1377,12 +1370,8 @@ See the style guide in the Emacs Lisp manual for more details."
documentation string")
(point) (+ (point) 1) t)))))
(if (and (not err) (looking-at "\""))
- (let ((old-syntax-table (syntax-table)))
- (unwind-protect
- (progn
- (set-syntax-table checkdoc-syntax-table)
- (checkdoc-this-string-valid-engine fp))
- (set-syntax-table old-syntax-table)))
+ (with-syntax-table checkdoc-syntax-table
+ (checkdoc-this-string-valid-engine fp))
err)))
(defun checkdoc-this-string-valid-engine (fp)
@@ -1391,7 +1380,7 @@ Depends on `checkdoc-this-string-valid' to reset the syntax table so that
regexp short cuts work. FP is the function defun information."
(let ((case-fold-search nil)
;; Use a marker so if an early check modifies the text,
- ;; we won't accidentally loose our place. This could cause
+ ;; we won't accidentally lose our place. This could cause
;; end-of doc string whitespace to also delete the " char.
(s (point))
(e (if (looking-at "\"")
@@ -1489,12 +1478,10 @@ regexp short cuts work. FP is the function defun information."
"First line not a complete sentence. Add RET here? "
"\n" t)
(let (l1 l2)
- (forward-line 1)
- (end-of-line)
+ (end-of-line 2)
(setq l1 (current-column)
l2 (save-excursion
- (forward-line 1)
- (end-of-line)
+ (end-of-line 2)
(current-column)))
(if (> (+ l1 l2 1) 80)
(setq msg "Incomplete auto-fix; doc string \
@@ -1511,10 +1498,7 @@ may require more formatting")
(forward-line 1)
(beginning-of-line)
(if (and (re-search-forward "[.!?:\"]\\([ \t\n]+\\|\"\\)"
- (save-excursion
- (end-of-line)
- (point))
- t)
+ (line-end-position) t)
(< (current-column) numc))
(if (checkdoc-autofix-ask-replace
p (1+ p)
@@ -1529,9 +1513,7 @@ may require more formatting")
(if msg
(checkdoc-create-error msg s (save-excursion
(goto-char s)
- (end-of-line)
- (point)))
- nil) ))))
+ (line-end-position))))))))
;; Continuation of above. Make sure our sentence is capitalized.
(save-excursion
(skip-chars-forward "\"\\*")
@@ -1631,7 +1613,7 @@ function,command,variable,option or symbol." ms1))))))
(if (and (< (point) e) (> (current-column) 80))
(checkdoc-create-error
"Some lines are over 80 columns wide"
- s (save-excursion (goto-char s) (end-of-line) (point)) ))))
+ s (save-excursion (goto-char s) (line-end-position))))))
;; Here we deviate to tests based on a variable or function.
;; We must do this before checking for symbols in quotes because there
;; is a chance that just such a symbol might really be an argument.
@@ -1776,9 +1758,8 @@ function,command,variable,option or symbol." ms1))))))
(end-of-line)
;; check string-continuation
(if (checkdoc-char= (preceding-char) ?\\)
- (progn (forward-line 1)
- (end-of-line)))
- (point)))
+ (line-end-position 2)
+ (point))))
(rs nil) replace original (case-fold-search t))
(while (and (not rs)
(re-search-forward
@@ -2002,49 +1983,45 @@ internally skip over no answers.
If the offending word is in a piece of quoted text, then it is skipped."
(save-excursion
(let ((case-fold-search nil)
- (errtxt nil) bb be
- (old-syntax-table (syntax-table)))
- (unwind-protect
- (progn
- (set-syntax-table checkdoc-syntax-table)
- (goto-char begin)
- (while (re-search-forward checkdoc-proper-noun-regexp end t)
- (let ((text (match-string 1))
- (b (match-beginning 1))
- (e (match-end 1)))
- (if (and (not (save-excursion
- (goto-char b)
- (forward-char -1)
- (looking-at "`\\|\"\\|\\.\\|\\\\")))
- ;; surrounded by /, as in a URL or filename: /emacs/
- (not (and (= ?/ (char-after e))
- (= ?/ (char-before b))))
- (not (checkdoc-in-example-string-p begin end))
- ;; info or url links left alone
- (not (thing-at-point-looking-at
- help-xref-info-regexp))
- (not (thing-at-point-looking-at
- help-xref-url-regexp)))
- (if (checkdoc-autofix-ask-replace
- b e (format "Text %s should be capitalized. Fix? "
- text)
- (capitalize text) t)
- nil
- (if errtxt
- ;; If there is already an error, then generate
- ;; the warning output if applicable
- (if checkdoc-generate-compile-warnings-flag
- (checkdoc-create-error
- (format
- "Name %s should appear capitalized as %s"
- text (capitalize text))
- b e))
- (setq errtxt
- (format
- "Name %s should appear capitalized as %s"
- text (capitalize text))
- bb b be e)))))))
- (set-syntax-table old-syntax-table))
+ (errtxt nil) bb be)
+ (with-syntax-table checkdoc-syntax-table
+ (goto-char begin)
+ (while (re-search-forward checkdoc-proper-noun-regexp end t)
+ (let ((text (match-string 1))
+ (b (match-beginning 1))
+ (e (match-end 1)))
+ (if (and (not (save-excursion
+ (goto-char b)
+ (forward-char -1)
+ (looking-at "`\\|\"\\|\\.\\|\\\\")))
+ ;; surrounded by /, as in a URL or filename: /emacs/
+ (not (and (= ?/ (char-after e))
+ (= ?/ (char-before b))))
+ (not (checkdoc-in-example-string-p begin end))
+ ;; info or url links left alone
+ (not (thing-at-point-looking-at
+ help-xref-info-regexp))
+ (not (thing-at-point-looking-at
+ help-xref-url-regexp)))
+ (if (checkdoc-autofix-ask-replace
+ b e (format "Text %s should be capitalized. Fix? "
+ text)
+ (capitalize text) t)
+ nil
+ (if errtxt
+ ;; If there is already an error, then generate
+ ;; the warning output if applicable
+ (if checkdoc-generate-compile-warnings-flag
+ (checkdoc-create-error
+ (format
+ "Name %s should appear capitalized as %s"
+ text (capitalize text))
+ b e))
+ (setq errtxt
+ (format
+ "Name %s should appear capitalized as %s"
+ text (capitalize text))
+ bb b be e)))))))
(if errtxt (checkdoc-create-error errtxt bb be)))))
(defun checkdoc-sentencespace-region-engine (begin end)
@@ -2052,43 +2029,39 @@ If the offending word is in a piece of quoted text, then it is skipped."
(if sentence-end-double-space
(save-excursion
(let ((case-fold-search nil)
- (errtxt nil) bb be
- (old-syntax-table (syntax-table)))
- (unwind-protect
- (progn
- (set-syntax-table checkdoc-syntax-table)
- (goto-char begin)
- (while (re-search-forward "[^ .0-9]\\(\\. \\)[^ \n]" end t)
- (let ((b (match-beginning 1))
- (e (match-end 1)))
- (unless (or (checkdoc-in-sample-code-p begin end)
- (checkdoc-in-example-string-p begin end)
- (save-excursion
- (goto-char b)
- (condition-case nil
- (progn
- (forward-sexp -1)
- ;; piece of an abbreviation
- ;; FIXME etc
- (looking-at
- "\\([a-z]\\|[iI]\\.?e\\|[eE]\\.?g\\)\\."))
- (error t))))
- (if (checkdoc-autofix-ask-replace
- b e
- "There should be two spaces after a period. Fix? "
- ". ")
- nil
- (if errtxt
- ;; If there is already an error, then generate
- ;; the warning output if applicable
- (if checkdoc-generate-compile-warnings-flag
- (checkdoc-create-error
- "There should be two spaces after a period"
- b e))
- (setq errtxt
- "There should be two spaces after a period"
- bb b be e)))))))
- (set-syntax-table old-syntax-table))
+ (errtxt nil) bb be)
+ (with-syntax-table checkdoc-syntax-table
+ (goto-char begin)
+ (while (re-search-forward "[^ .0-9]\\(\\. \\)[^ \n]" end t)
+ (let ((b (match-beginning 1))
+ (e (match-end 1)))
+ (unless (or (checkdoc-in-sample-code-p begin end)
+ (checkdoc-in-example-string-p begin end)
+ (save-excursion
+ (goto-char b)
+ (condition-case nil
+ (progn
+ (forward-sexp -1)
+ ;; piece of an abbreviation
+ ;; FIXME etc
+ (looking-at
+ "\\([a-z]\\|[iI]\\.?e\\|[eE]\\.?g\\)\\."))
+ (error t))))
+ (if (checkdoc-autofix-ask-replace
+ b e
+ "There should be two spaces after a period. Fix? "
+ ". ")
+ nil
+ (if errtxt
+ ;; If there is already an error, then generate
+ ;; the warning output if applicable
+ (if checkdoc-generate-compile-warnings-flag
+ (checkdoc-create-error
+ "There should be two spaces after a period"
+ b e))
+ (setq errtxt
+ "There should be two spaces after a period"
+ bb b be e)))))))
(if errtxt (checkdoc-create-error errtxt bb be))))))
;;; Ispell engine
@@ -2256,8 +2229,8 @@ Code:, and others referenced in the style guide."
(insert ";;; " fn fe " --- " (read-string "Summary: ") "\n"))
(checkdoc-create-error
"The first line should be of the form: \";;; package --- Summary\""
- (point-min) (save-excursion (goto-char (point-min)) (end-of-line)
- (point))))
+ (point-min) (save-excursion (goto-char (point-min))
+ (line-end-position))))
nil))
(setq
err
@@ -2668,8 +2641,7 @@ function called to create the messages."
(setq checkdoc-pending-errors nil)
nil)))
-(custom-add-option 'emacs-lisp-mode-hook
- (lambda () (checkdoc-minor-mode 1)))
+(custom-add-option 'emacs-lisp-mode-hook 'checkdoc-minor-mode)
(add-to-list 'debug-ignored-errors
"Argument `.*' should appear (as .*) in the doc string")
@@ -2679,5 +2651,4 @@ function called to create the messages."
(provide 'checkdoc)
-;; arch-tag: c49a7ec8-3bb7-46f2-bfbc-d5f26e033b26
;;; checkdoc.el ends here
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index 3211f79c9e9..b7c908882ed 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -5,6 +5,7 @@
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Keywords: extensions
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -685,7 +686,7 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
(setq last (point))
(goto-char (1+ pt))
(while (search-forward "(quote " last t)
- (delete-backward-char 7)
+ (delete-char -7)
(insert "'")
(forward-sexp)
(delete-char 1))
diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el
index e4f605d4fd0..4e7ada8851f 100644
--- a/lisp/emacs-lisp/cl-indent.el
+++ b/lisp/emacs-lisp/cl-indent.el
@@ -7,6 +7,7 @@
;; Created: July 1987
;; Maintainer: FSF
;; Keywords: lisp, tools
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el
index 7640a0b1575..b1d934f08e0 100644
--- a/lisp/emacs-lisp/cl-loaddefs.el
+++ b/lisp/emacs-lisp/cl-loaddefs.el
@@ -10,7 +10,7 @@
;;;;;; ceiling* floor* isqrt lcm gcd cl-progv-before cl-set-frame-visible-p
;;;;;; cl-map-overlays cl-map-intervals cl-map-keymap-recursively
;;;;;; notevery notany every some mapcon mapcan mapl maplist map
-;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "d93072a26c59f663a92b10df8bc28187")
+;;;;;; cl-mapcar-many equalp coerce) "cl-extra" "cl-extra.el" "20c8c875ff1d11dd819e15a1f25afd73")
;;; Generated autoloads from cl-extra.el
(autoload 'coerce "cl-extra" "\
@@ -277,12 +277,12 @@ Not documented
;;;;;; assert check-type typep deftype cl-struct-setf-expander defstruct
;;;;;; define-modify-macro callf2 callf letf* letf rotatef shiftf
;;;;;; remf cl-do-pop psetf setf get-setf-method defsetf define-setf-method
-;;;;;; declare the locally multiple-value-setq multiple-value-bind
-;;;;;; lexical-let* lexical-let symbol-macrolet macrolet labels
-;;;;;; flet progv psetq do-all-symbols do-symbols dotimes dolist
-;;;;;; do* do loop return-from return block etypecase typecase ecase
-;;;;;; case load-time-value eval-when destructuring-bind function*
-;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "49b7d96626dd8ba5d39551909edbd4c7")
+;;;;;; declare locally multiple-value-setq multiple-value-bind lexical-let*
+;;;;;; lexical-let symbol-macrolet macrolet labels flet progv psetq
+;;;;;; do-all-symbols do-symbols dotimes dolist do* do loop return-from
+;;;;;; return block etypecase typecase ecase case load-time-value
+;;;;;; eval-when destructuring-bind function* defmacro* defun* gentemp
+;;;;;; gensym) "cl-macs" "cl-macs.el" "979862b54946a5fcbbccdd90fa3f84d8")
;;; Generated autoloads from cl-macs.el
(autoload 'gensym "cl-macs" "\
@@ -535,11 +535,6 @@ Not documented
\(fn &rest BODY)" nil (quote macro))
-(autoload 'the "cl-macs" "\
-Not documented
-
-\(fn TYPE FORM)" nil (quote macro))
-
(autoload 'declare "cl-macs" "\
Not documented
@@ -759,7 +754,7 @@ surrounded by (block NAME ...).
;;;;;; find nsubstitute-if-not nsubstitute-if nsubstitute substitute-if-not
;;;;;; substitute-if substitute delete-duplicates remove-duplicates
;;;;;; delete-if-not delete-if delete* remove-if-not remove-if remove*
-;;;;;; replace fill reduce) "cl-seq" "cl-seq.el" "ec3ea1c77742734db8496272fe5721be")
+;;;;;; replace fill reduce) "cl-seq" "cl-seq.el" "7b7531276ddf8457abecdd487d3cf0b7")
;;; Generated autoloads from cl-seq.el
(autoload 'reduce "cl-seq" "\
@@ -1242,7 +1237,6 @@ Keywords supported: :test :test-not :key
;; version-control: never
;; no-byte-compile: t
;; no-update-autoloads: t
+;; coding: utf-8
;; End:
-
-;; arch-tag: 08cc5aab-e992-47f6-992e-12a7428c1a0e
;;; cl-loaddefs.el ends here
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 3e800c53008..76f677c6198 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -6,6 +6,7 @@
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Version: 2.02
;; Keywords: extensions
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -128,6 +129,12 @@
(and (eq (cl-const-expr-p x) t) (if (consp x) (nth 1 x) x)))
(defun cl-expr-access-order (x v)
+ ;; This apparently tries to return nil iff the expression X evaluates
+ ;; the variables V in the same order as they appear in V (so as to
+ ;; be able to replace those vars with the expressions they're bound
+ ;; to).
+ ;; FIXME: This is very naive, it doesn't even check to see if those
+ ;; variables appear more than once.
(if (cl-const-expr-p x) v
(if (consp x)
(progn
@@ -632,7 +639,7 @@ This is compatible with Common Lisp, but note that `defun' and
;;; The "loop" macro.
-(defvar args) (defvar loop-accum-var) (defvar loop-accum-vars)
+(defvar loop-args) (defvar loop-accum-var) (defvar loop-accum-vars)
(defvar loop-bindings) (defvar loop-body) (defvar loop-destr-temps)
(defvar loop-finally) (defvar loop-finish-flag) (defvar loop-first-flag)
(defvar loop-initially) (defvar loop-map-form) (defvar loop-name)
@@ -640,7 +647,7 @@ This is compatible with Common Lisp, but note that `defun' and
(defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs)
;;;###autoload
-(defmacro loop (&rest args)
+(defmacro loop (&rest loop-args)
"The Common Lisp `loop' macro.
Valid clauses are:
for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM,
@@ -655,8 +662,8 @@ Valid clauses are:
finally return EXPR, named NAME.
\(fn CLAUSE...)"
- (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list args))))))
- (list 'block nil (list* 'while t args))
+ (if (not (memq t (mapcar 'symbolp (delq nil (delq t (copy-list loop-args))))))
+ (list 'block nil (list* 'while t loop-args))
(let ((loop-name nil) (loop-bindings nil)
(loop-body nil) (loop-steps nil)
(loop-result nil) (loop-result-explicit nil)
@@ -665,8 +672,8 @@ Valid clauses are:
(loop-initially nil) (loop-finally nil)
(loop-map-form nil) (loop-first-flag nil)
(loop-destr-temps nil) (loop-symbol-macs nil))
- (setq args (append args '(cl-end-loop)))
- (while (not (eq (car args) 'cl-end-loop)) (cl-parse-loop-clause))
+ (setq loop-args (append loop-args '(cl-end-loop)))
+ (while (not (eq (car loop-args) 'cl-end-loop)) (cl-parse-loop-clause))
(if loop-finish-flag
(push `((,loop-finish-flag t)) loop-bindings))
(if loop-first-flag
@@ -706,34 +713,34 @@ Valid clauses are:
(setq body (list (list* 'symbol-macrolet loop-symbol-macs body))))
(list* 'block loop-name body)))))
-(defun cl-parse-loop-clause () ; uses args, loop-*
- (let ((word (pop args))
+(defun cl-parse-loop-clause () ; uses loop-*
+ (let ((word (pop loop-args))
(hash-types '(hash-key hash-keys hash-value hash-values))
(key-types '(key-code key-codes key-seq key-seqs
key-binding key-bindings)))
(cond
- ((null args)
+ ((null loop-args)
(error "Malformed `loop' macro"))
((eq word 'named)
- (setq loop-name (pop args)))
+ (setq loop-name (pop loop-args)))
((eq word 'initially)
- (if (memq (car args) '(do doing)) (pop args))
- (or (consp (car args)) (error "Syntax error on `initially' clause"))
- (while (consp (car args))
- (push (pop args) loop-initially)))
+ (if (memq (car loop-args) '(do doing)) (pop loop-args))
+ (or (consp (car loop-args)) (error "Syntax error on `initially' clause"))
+ (while (consp (car loop-args))
+ (push (pop loop-args) loop-initially)))
((eq word 'finally)
- (if (eq (car args) 'return)
- (setq loop-result-explicit (or (cl-pop2 args) '(quote nil)))
- (if (memq (car args) '(do doing)) (pop args))
- (or (consp (car args)) (error "Syntax error on `finally' clause"))
- (if (and (eq (caar args) 'return) (null loop-name))
- (setq loop-result-explicit (or (nth 1 (pop args)) '(quote nil)))
- (while (consp (car args))
- (push (pop args) loop-finally)))))
+ (if (eq (car loop-args) 'return)
+ (setq loop-result-explicit (or (cl-pop2 loop-args) '(quote nil)))
+ (if (memq (car loop-args) '(do doing)) (pop loop-args))
+ (or (consp (car loop-args)) (error "Syntax error on `finally' clause"))
+ (if (and (eq (caar loop-args) 'return) (null loop-name))
+ (setq loop-result-explicit (or (nth 1 (pop loop-args)) '(quote nil)))
+ (while (consp (car loop-args))
+ (push (pop loop-args) loop-finally)))))
((memq word '(for as))
(let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil)
@@ -742,29 +749,29 @@ Valid clauses are:
;; Use `gensym' rather than `make-symbol'. It's important that
;; (not (eq (symbol-name var1) (symbol-name var2))) because
;; these vars get added to the cl-macro-environment.
- (let ((var (or (pop args) (gensym "--cl-var--"))))
- (setq word (pop args))
- (if (eq word 'being) (setq word (pop args)))
- (if (memq word '(the each)) (setq word (pop args)))
+ (let ((var (or (pop loop-args) (gensym "--cl-var--"))))
+ (setq word (pop loop-args))
+ (if (eq word 'being) (setq word (pop loop-args)))
+ (if (memq word '(the each)) (setq word (pop loop-args)))
(if (memq word '(buffer buffers))
- (setq word 'in args (cons '(buffer-list) args)))
+ (setq word 'in loop-args (cons '(buffer-list) loop-args)))
(cond
((memq word '(from downfrom upfrom to downto upto
above below by))
- (push word args)
- (if (memq (car args) '(downto above))
+ (push word loop-args)
+ (if (memq (car loop-args) '(downto above))
(error "Must specify `from' value for downward loop"))
- (let* ((down (or (eq (car args) 'downfrom)
- (memq (caddr args) '(downto above))))
- (excl (or (memq (car args) '(above below))
- (memq (caddr args) '(above below))))
- (start (and (memq (car args) '(from upfrom downfrom))
- (cl-pop2 args)))
- (end (and (memq (car args)
+ (let* ((down (or (eq (car loop-args) 'downfrom)
+ (memq (caddr loop-args) '(downto above))))
+ (excl (or (memq (car loop-args) '(above below))
+ (memq (caddr loop-args) '(above below))))
+ (start (and (memq (car loop-args) '(from upfrom downfrom))
+ (cl-pop2 loop-args)))
+ (end (and (memq (car loop-args)
'(to upto downto above below))
- (cl-pop2 args)))
- (step (and (eq (car args) 'by) (cl-pop2 args)))
+ (cl-pop2 loop-args)))
+ (step (and (eq (car loop-args) 'by) (cl-pop2 loop-args)))
(end-var (and (not (cl-const-expr-p end))
(make-symbol "--cl-var--")))
(step-var (and (not (cl-const-expr-p step))
@@ -787,7 +794,7 @@ Valid clauses are:
(let* ((on (eq word 'on))
(temp (if (and on (symbolp var))
var (make-symbol "--cl-var--"))))
- (push (list temp (pop args)) loop-for-bindings)
+ (push (list temp (pop loop-args)) loop-for-bindings)
(push (list 'consp temp) loop-body)
(if (eq word 'in-ref)
(push (list var (list 'car temp)) loop-symbol-macs)
@@ -797,8 +804,8 @@ Valid clauses are:
(push (list var (if on temp (list 'car temp)))
loop-for-sets))))
(push (list temp
- (if (eq (car args) 'by)
- (let ((step (cl-pop2 args)))
+ (if (eq (car loop-args) 'by)
+ (let ((step (cl-pop2 loop-args)))
(if (and (memq (car-safe step)
'(quote function
function*))
@@ -809,10 +816,10 @@ Valid clauses are:
loop-for-steps)))
((eq word '=)
- (let* ((start (pop args))
- (then (if (eq (car args) 'then) (cl-pop2 args) start)))
+ (let* ((start (pop loop-args))
+ (then (if (eq (car loop-args) 'then) (cl-pop2 loop-args) start)))
(push (list var nil) loop-for-bindings)
- (if (or ands (eq (car args) 'and))
+ (if (or ands (eq (car loop-args) 'and))
(progn
(push `(,var
(if ,(or loop-first-flag
@@ -832,7 +839,7 @@ Valid clauses are:
((memq word '(across across-ref))
(let ((temp-vec (make-symbol "--cl-vec--"))
(temp-idx (make-symbol "--cl-idx--")))
- (push (list temp-vec (pop args)) loop-for-bindings)
+ (push (list temp-vec (pop loop-args)) loop-for-bindings)
(push (list temp-idx -1) loop-for-bindings)
(push (list '< (list 'setq temp-idx (list '1+ temp-idx))
(list 'length temp-vec)) loop-body)
@@ -844,15 +851,15 @@ Valid clauses are:
loop-for-sets))))
((memq word '(element elements))
- (let ((ref (or (memq (car args) '(in-ref of-ref))
- (and (not (memq (car args) '(in of)))
+ (let ((ref (or (memq (car loop-args) '(in-ref of-ref))
+ (and (not (memq (car loop-args) '(in of)))
(error "Expected `of'"))))
- (seq (cl-pop2 args))
+ (seq (cl-pop2 loop-args))
(temp-seq (make-symbol "--cl-seq--"))
- (temp-idx (if (eq (car args) 'using)
- (if (and (= (length (cadr args)) 2)
- (eq (caadr args) 'index))
- (cadr (cl-pop2 args))
+ (temp-idx (if (eq (car loop-args) 'using)
+ (if (and (= (length (cadr loop-args)) 2)
+ (eq (caadr loop-args) 'index))
+ (cadr (cl-pop2 loop-args))
(error "Bad `using' clause"))
(make-symbol "--cl-idx--"))))
(push (list temp-seq seq) loop-for-bindings)
@@ -878,13 +885,13 @@ Valid clauses are:
loop-for-steps)))
((memq word hash-types)
- (or (memq (car args) '(in of)) (error "Expected `of'"))
- (let* ((table (cl-pop2 args))
- (other (if (eq (car args) 'using)
- (if (and (= (length (cadr args)) 2)
- (memq (caadr args) hash-types)
- (not (eq (caadr args) word)))
- (cadr (cl-pop2 args))
+ (or (memq (car loop-args) '(in of)) (error "Expected `of'"))
+ (let* ((table (cl-pop2 loop-args))
+ (other (if (eq (car loop-args) 'using)
+ (if (and (= (length (cadr loop-args)) 2)
+ (memq (caadr loop-args) hash-types)
+ (not (eq (caadr loop-args) word)))
+ (cadr (cl-pop2 loop-args))
(error "Bad `using' clause"))
(make-symbol "--cl-var--"))))
(if (memq word '(hash-value hash-values))
@@ -894,16 +901,16 @@ Valid clauses are:
((memq word '(symbol present-symbol external-symbol
symbols present-symbols external-symbols))
- (let ((ob (and (memq (car args) '(in of)) (cl-pop2 args))))
+ (let ((ob (and (memq (car loop-args) '(in of)) (cl-pop2 loop-args))))
(setq loop-map-form
`(mapatoms (lambda (,var) . --cl-map) ,ob))))
((memq word '(overlay overlays extent extents))
(let ((buf nil) (from nil) (to nil))
- (while (memq (car args) '(in of from to))
- (cond ((eq (car args) 'from) (setq from (cl-pop2 args)))
- ((eq (car args) 'to) (setq to (cl-pop2 args)))
- (t (setq buf (cl-pop2 args)))))
+ (while (memq (car loop-args) '(in of from to))
+ (cond ((eq (car loop-args) 'from) (setq from (cl-pop2 loop-args)))
+ ((eq (car loop-args) 'to) (setq to (cl-pop2 loop-args)))
+ (t (setq buf (cl-pop2 loop-args)))))
(setq loop-map-form
`(cl-map-extents
(lambda (,var ,(make-symbol "--cl-var--"))
@@ -914,12 +921,12 @@ Valid clauses are:
(let ((buf nil) (prop nil) (from nil) (to nil)
(var1 (make-symbol "--cl-var1--"))
(var2 (make-symbol "--cl-var2--")))
- (while (memq (car args) '(in of property from to))
- (cond ((eq (car args) 'from) (setq from (cl-pop2 args)))
- ((eq (car args) 'to) (setq to (cl-pop2 args)))
- ((eq (car args) 'property)
- (setq prop (cl-pop2 args)))
- (t (setq buf (cl-pop2 args)))))
+ (while (memq (car loop-args) '(in of property from to))
+ (cond ((eq (car loop-args) 'from) (setq from (cl-pop2 loop-args)))
+ ((eq (car loop-args) 'to) (setq to (cl-pop2 loop-args)))
+ ((eq (car loop-args) 'property)
+ (setq prop (cl-pop2 loop-args)))
+ (t (setq buf (cl-pop2 loop-args)))))
(if (and (consp var) (symbolp (car var)) (symbolp (cdr var)))
(setq var1 (car var) var2 (cdr var))
(push (list var (list 'cons var1 var2)) loop-for-sets))
@@ -929,13 +936,13 @@ Valid clauses are:
,buf ,prop ,from ,to))))
((memq word key-types)
- (or (memq (car args) '(in of)) (error "Expected `of'"))
- (let ((map (cl-pop2 args))
- (other (if (eq (car args) 'using)
- (if (and (= (length (cadr args)) 2)
- (memq (caadr args) key-types)
- (not (eq (caadr args) word)))
- (cadr (cl-pop2 args))
+ (or (memq (car loop-args) '(in of)) (error "Expected `of'"))
+ (let ((map (cl-pop2 loop-args))
+ (other (if (eq (car loop-args) 'using)
+ (if (and (= (length (cadr loop-args)) 2)
+ (memq (caadr loop-args) key-types)
+ (not (eq (caadr loop-args) word)))
+ (cadr (cl-pop2 loop-args))
(error "Bad `using' clause"))
(make-symbol "--cl-var--"))))
(if (memq word '(key-binding key-bindings))
@@ -957,7 +964,7 @@ Valid clauses are:
loop-for-steps)))
((memq word '(window windows))
- (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args)))
+ (let ((scr (and (memq (car loop-args) '(in of)) (cl-pop2 loop-args)))
(temp (make-symbol "--cl-var--")))
(push (list var (if scr
(list 'frame-selected-window scr)
@@ -975,9 +982,9 @@ Valid clauses are:
(if handler
(funcall handler var)
(error "Expected a `for' preposition, found %s" word)))))
- (eq (car args) 'and))
+ (eq (car loop-args) 'and))
(setq ands t)
- (pop args))
+ (pop loop-args))
(if (and ands loop-for-bindings)
(push (nreverse loop-for-bindings) loop-bindings)
(setq loop-bindings (nconc (mapcar 'list loop-for-bindings)
@@ -993,11 +1000,11 @@ Valid clauses are:
((eq word 'repeat)
(let ((temp (make-symbol "--cl-var--")))
- (push (list (list temp (pop args))) loop-bindings)
+ (push (list (list temp (pop loop-args))) loop-bindings)
(push (list '>= (list 'setq temp (list '1- temp)) 0) loop-body)))
((memq word '(collect collecting))
- (let ((what (pop args))
+ (let ((what (pop loop-args))
(var (cl-loop-handle-accum nil 'nreverse)))
(if (eq var loop-accum-var)
(push (list 'progn (list 'push what var) t) loop-body)
@@ -1006,7 +1013,7 @@ Valid clauses are:
t) loop-body))))
((memq word '(nconc nconcing append appending))
- (let ((what (pop args))
+ (let ((what (pop loop-args))
(var (cl-loop-handle-accum nil 'nreverse)))
(push (list 'progn
(list 'setq var
@@ -1021,27 +1028,27 @@ Valid clauses are:
var what))) t) loop-body)))
((memq word '(concat concating))
- (let ((what (pop args))
+ (let ((what (pop loop-args))
(var (cl-loop-handle-accum "")))
(push (list 'progn (list 'callf 'concat var what) t) loop-body)))
((memq word '(vconcat vconcating))
- (let ((what (pop args))
+ (let ((what (pop loop-args))
(var (cl-loop-handle-accum [])))
(push (list 'progn (list 'callf 'vconcat var what) t) loop-body)))
((memq word '(sum summing))
- (let ((what (pop args))
+ (let ((what (pop loop-args))
(var (cl-loop-handle-accum 0)))
(push (list 'progn (list 'incf var what) t) loop-body)))
((memq word '(count counting))
- (let ((what (pop args))
+ (let ((what (pop loop-args))
(var (cl-loop-handle-accum 0)))
(push (list 'progn (list 'if what (list 'incf var)) t) loop-body)))
((memq word '(minimize minimizing maximize maximizing))
- (let* ((what (pop args))
+ (let* ((what (pop loop-args))
(temp (if (cl-simple-expr-p what) what (make-symbol "--cl-var--")))
(var (cl-loop-handle-accum nil))
(func (intern (substring (symbol-name word) 0 3)))
@@ -1052,27 +1059,27 @@ Valid clauses are:
((eq word 'with)
(let ((bindings nil))
- (while (progn (push (list (pop args)
- (and (eq (car args) '=) (cl-pop2 args)))
+ (while (progn (push (list (pop loop-args)
+ (and (eq (car loop-args) '=) (cl-pop2 loop-args)))
bindings)
- (eq (car args) 'and))
- (pop args))
+ (eq (car loop-args) 'and))
+ (pop loop-args))
(push (nreverse bindings) loop-bindings)))
((eq word 'while)
- (push (pop args) loop-body))
+ (push (pop loop-args) loop-body))
((eq word 'until)
- (push (list 'not (pop args)) loop-body))
+ (push (list 'not (pop loop-args)) loop-body))
((eq word 'always)
(or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
- (push (list 'setq loop-finish-flag (pop args)) loop-body)
+ (push (list 'setq loop-finish-flag (pop loop-args)) loop-body)
(setq loop-result t))
((eq word 'never)
(or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
- (push (list 'setq loop-finish-flag (list 'not (pop args)))
+ (push (list 'setq loop-finish-flag (list 'not (pop loop-args)))
loop-body)
(setq loop-result t))
@@ -1080,20 +1087,20 @@ Valid clauses are:
(or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-flag--")))
(or loop-result-var (setq loop-result-var (make-symbol "--cl-var--")))
(push (list 'setq loop-finish-flag
- (list 'not (list 'setq loop-result-var (pop args))))
+ (list 'not (list 'setq loop-result-var (pop loop-args))))
loop-body))
((memq word '(if when unless))
- (let* ((cond (pop args))
+ (let* ((cond (pop loop-args))
(then (let ((loop-body nil))
(cl-parse-loop-clause)
(cl-loop-build-ands (nreverse loop-body))))
(else (let ((loop-body nil))
- (if (eq (car args) 'else)
- (progn (pop args) (cl-parse-loop-clause)))
+ (if (eq (car loop-args) 'else)
+ (progn (pop loop-args) (cl-parse-loop-clause)))
(cl-loop-build-ands (nreverse loop-body))))
(simple (and (eq (car then) t) (eq (car else) t))))
- (if (eq (car args) 'end) (pop args))
+ (if (eq (car loop-args) 'end) (pop loop-args))
(if (eq word 'unless) (setq then (prog1 else (setq else then))))
(let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then))
(if simple (nth 1 else) (list (nth 2 else))))))
@@ -1107,22 +1114,22 @@ Valid clauses are:
((memq word '(do doing))
(let ((body nil))
- (or (consp (car args)) (error "Syntax error on `do' clause"))
- (while (consp (car args)) (push (pop args) body))
+ (or (consp (car loop-args)) (error "Syntax error on `do' clause"))
+ (while (consp (car loop-args)) (push (pop loop-args) body))
(push (cons 'progn (nreverse (cons t body))) loop-body)))
((eq word 'return)
(or loop-finish-flag (setq loop-finish-flag (make-symbol "--cl-var--")))
(or loop-result-var (setq loop-result-var (make-symbol "--cl-var--")))
- (push (list 'setq loop-result-var (pop args)
+ (push (list 'setq loop-result-var (pop loop-args)
loop-finish-flag nil) loop-body))
(t
(let ((handler (and (symbolp word) (get word 'cl-loop-handler))))
(or handler (error "Expected a loop keyword, found %s" word))
(funcall handler))))
- (if (eq (car args) 'and)
- (progn (pop args) (cl-parse-loop-clause)))))
+ (if (eq (car loop-args) 'and)
+ (progn (pop loop-args) (cl-parse-loop-clause)))))
(defun cl-loop-let (specs body par) ; uses loop-*
(let ((p specs) (temps nil) (new nil))
@@ -1158,9 +1165,9 @@ Valid clauses are:
(list* (if par 'let 'let*)
(nconc (nreverse temps) (nreverse new)) body))))
-(defun cl-loop-handle-accum (def &optional func) ; uses args, loop-*
- (if (eq (car args) 'into)
- (let ((var (cl-pop2 args)))
+(defun cl-loop-handle-accum (def &optional func) ; uses loop-*
+ (if (eq (car loop-args) 'into)
+ (let ((var (cl-pop2 loop-args)))
(or (memq var loop-accum-vars)
(progn (push (list (list var def)) loop-bindings)
(push var loop-accum-vars)))
@@ -1741,15 +1748,6 @@ Example:
(defsetf default-file-modes set-default-file-modes t)
(defsetf default-value set-default)
(defsetf documentation-property put)
-(defsetf extent-data set-extent-data)
-(defsetf extent-face set-extent-face)
-(defsetf extent-priority set-extent-priority)
-(defsetf extent-end-position (ext) (store)
- (list 'progn (list 'set-extent-endpoints (list 'extent-start-position ext)
- store) store))
-(defsetf extent-start-position (ext) (store)
- (list 'progn (list 'set-extent-endpoints store
- (list 'extent-end-position ext)) store))
(defsetf face-background (f &optional s) (x) (list 'set-face-background f x s))
(defsetf face-background-pixmap (f &optional s) (x)
(list 'set-face-background-pixmap f x s))
@@ -1763,6 +1761,7 @@ Example:
(defsetf frame-visible-p cl-set-frame-visible-p)
(defsetf frame-width set-screen-width t)
(defsetf frame-parameter set-frame-parameter t)
+(defsetf terminal-parameter set-terminal-parameter)
(defsetf getenv setenv t)
(defsetf get-register set-register)
(defsetf global-key-binding global-set-key)
@@ -1806,19 +1805,34 @@ Example:
(defsetf window-height () (store)
(list 'progn (list 'enlarge-window (list '- store '(window-height))) store))
(defsetf window-hscroll set-window-hscroll)
+(defsetf window-parameter set-window-parameter)
(defsetf window-point set-window-point)
(defsetf window-start set-window-start)
(defsetf window-width () (store)
(list 'progn (list 'enlarge-window (list '- store '(window-width)) t) store))
-(defsetf x-get-cutbuffer x-store-cutbuffer t)
-(defsetf x-get-cut-buffer x-store-cut-buffer t) ; groan.
(defsetf x-get-secondary-selection x-own-secondary-selection t)
(defsetf x-get-selection x-own-selection t)
+;; This is a hack that allows (setf (eq a 7) B) to mean either
+;; (setq a 7) or (setq a nil) depending on whether B is nil or not.
+;; This is useful when you have control over the PLACE but not over
+;; the VALUE, as is the case in define-minor-mode's :variable.
+(define-setf-method eq (place val)
+ (let ((method (get-setf-method place cl-macro-environment))
+ (val-temp (make-symbol "--eq-val--"))
+ (store-temp (make-symbol "--eq-store--")))
+ (list (append (nth 0 method) (list val-temp))
+ (append (nth 1 method) (list val))
+ (list store-temp)
+ `(let ((,(car (nth 2 method))
+ (if ,store-temp ,val-temp (not ,val-temp))))
+ ,(nth 3 method) ,store-temp)
+ `(eq ,(nth 4 method) ,val-temp))))
+
;;; More complex setf-methods.
-;;; These should take &environment arguments, but since full arglists aren't
-;;; available while compiling cl-macs, we fake it by referring to the global
-;;; variable cl-macro-environment directly.
+;; These should take &environment arguments, but since full arglists aren't
+;; available while compiling cl-macs, we fake it by referring to the global
+;; variable cl-macro-environment directly.
(define-setf-method apply (func arg1 &rest rest)
(or (and (memq (car-safe func) '(quote function function*))
@@ -2616,21 +2630,36 @@ surrounded by (block NAME ...).
(cons '&cl-quote args))
(list* 'cl-defsubst-expand (list 'quote argns)
(list 'quote (list* 'block name body))
- (not (or unsafe (cl-expr-access-order pbody argns)))
+ ;; We used to pass `simple' as
+ ;; (not (or unsafe (cl-expr-access-order pbody argns)))
+ ;; But this is much too simplistic since it
+ ;; does not pay attention to the argvs (and
+ ;; cl-expr-access-order itself is also too naive).
+ nil
(and (memq '&key args) 'cl-whole) unsafe argns)))
(list* 'defun* name args body))))
(defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs)
(if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole
(if (cl-simple-exprs-p argvs) (setq simple t))
- (let ((lets (delq nil
- (mapcar* (function
- (lambda (argn argv)
- (if (or simple (cl-const-expr-p argv))
- (progn (setq body (subst argv argn body))
- (and unsafe (list argn argv)))
- (list argn argv))))
- argns argvs))))
+ (let* ((substs ())
+ (lets (delq nil
+ (mapcar* (function
+ (lambda (argn argv)
+ (if (or simple (cl-const-expr-p argv))
+ (progn (push (cons argn argv) substs)
+ (and unsafe (list argn argv)))
+ (list argn argv))))
+ argns argvs))))
+ ;; FIXME: `sublis/subst' will happily substitute the symbol
+ ;; `argn' in places where it's not used as a reference
+ ;; to a variable.
+ ;; FIXME: `sublis/subst' will happily copy `argv' to a different
+ ;; scope, leading to name capture.
+ (setq body (cond ((null substs) body)
+ ((null (cdr substs))
+ (subst (cdar substs) (caar substs) body))
+ (t (sublis substs body))))
(if lets (list 'let lets body) body))))
@@ -2753,5 +2782,4 @@ surrounded by (block NAME ...).
;; generated-autoload-file: "cl-loaddefs.el"
;; End:
-;; arch-tag: afd947a6-b553-4df1-bba5-000be6388f46
;;; cl-macs.el ends here
diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el
index a823e9015db..a5070e4acea 100644
--- a/lisp/emacs-lisp/cl-seq.el
+++ b/lisp/emacs-lisp/cl-seq.el
@@ -6,6 +6,7 @@
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Version: 2.02
;; Keywords: extensions
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -47,6 +48,7 @@
;;; this file independent from cl-macs.
(defmacro cl-parsing-keywords (kwords other-keys &rest body)
+ (declare (indent 2) (debug (sexp sexp &rest form)))
(cons
'let*
(cons (mapcar
@@ -83,13 +85,13 @@
(car cl-keys-temp)))
'(setq cl-keys-temp (cdr (cdr cl-keys-temp)))))))
body))))
-(put 'cl-parsing-keywords 'lisp-indent-function 2)
-(put 'cl-parsing-keywords 'edebug-form-spec '(sexp sexp &rest form))
(defmacro cl-check-key (x)
+ (declare (debug edebug-forms))
(list 'if 'cl-key (list 'funcall 'cl-key x) x))
(defmacro cl-check-test-nokey (item x)
+ (declare (debug edebug-forms))
(list 'cond
(list 'cl-test
(list 'eq (list 'not (list 'funcall 'cl-test item x))
@@ -100,20 +102,17 @@
(list 'equal item x) (list 'eq item x)))))
(defmacro cl-check-test (item x)
+ (declare (debug edebug-forms))
(list 'cl-check-test-nokey item (list 'cl-check-key x)))
(defmacro cl-check-match (x y)
+ (declare (debug edebug-forms))
(setq x (list 'cl-check-key x) y (list 'cl-check-key y))
(list 'if 'cl-test
(list 'eq (list 'not (list 'funcall 'cl-test x y)) 'cl-test-not)
(list 'if (list 'numberp x)
(list 'equal x y) (list 'eq x y))))
-(put 'cl-check-key 'edebug-form-spec 'edebug-forms)
-(put 'cl-check-test 'edebug-form-spec 'edebug-forms)
-(put 'cl-check-test-nokey 'edebug-form-spec 'edebug-forms)
-(put 'cl-check-match 'edebug-form-spec 'edebug-forms)
-
(defvar cl-test) (defvar cl-test-not)
(defvar cl-if) (defvar cl-if-not)
(defvar cl-key)
diff --git a/lisp/emacs-lisp/cl-specs.el b/lisp/emacs-lisp/cl-specs.el
index acfd3504ec7..776ce5e9ca1 100644
--- a/lisp/emacs-lisp/cl-specs.el
+++ b/lisp/emacs-lisp/cl-specs.el
@@ -4,6 +4,7 @@
;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Daniel LaLiberte <liberte@holonexus.org>
;; Keywords: lisp, tools, maint
+;; Package: emacs
;; LCD Archive Entry:
;; cl-specs.el|Daniel LaLiberte|liberte@holonexus.org
diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el
index 38ae511db78..9b275255b27 100644
--- a/lisp/emacs-lisp/cl.el
+++ b/lisp/emacs-lisp/cl.el
@@ -645,7 +645,6 @@ If ALIST is non-nil, the new pairs are prepended to it."
(load "cl-loaddefs" nil 'quiet)
;; This goes here so that cl-macs can find it if it loads right now.
-(provide 'cl-19) ; usage: (require 'cl-19 "cl")
(provide 'cl)
;; Things to do after byte-compiler is loaded.
diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el
index 6f7a43af844..43eb61b0bee 100644
--- a/lisp/emacs-lisp/copyright.el
+++ b/lisp/emacs-lisp/copyright.el
@@ -158,13 +158,15 @@ When this is `function', only ask when called non-interactively."
(unless (string= (buffer-substring (- (match-end 3) 2) (match-end 3))
(substring copyright-current-year -2))
(if (or noquery
- ;; Fixes some point-moving oddness (bug#2209).
- (save-excursion
- (y-or-n-p (if replace
- (concat "Replace copyright year(s) by "
- copyright-current-year "? ")
- (concat "Add " copyright-current-year
- " to copyright? ")))))
+ (save-window-excursion
+ (switch-to-buffer (current-buffer))
+ ;; Fixes some point-moving oddness (bug#2209).
+ (save-excursion
+ (y-or-n-p (if replace
+ (concat "Replace copyright year(s) by "
+ copyright-current-year "? ")
+ (concat "Add " copyright-current-year
+ " to copyright? "))))))
(if replace
(replace-match copyright-current-year t t nil 3)
(let ((size (save-excursion (skip-chars-backward "0-9"))))
@@ -224,8 +226,10 @@ version \\([0-9]+\\), or (at"
(string-to-number copyright-current-gpl-version))
(or noquery
(save-match-data
- (y-or-n-p (format "Replace GPL version by %s? "
- copyright-current-gpl-version))))
+ (save-window-excursion
+ (switch-to-buffer (current-buffer))
+ (y-or-n-p (format "Replace GPL version by %s? "
+ copyright-current-gpl-version)))))
(progn
(if (match-end 2)
;; Esperanto bilingual comment in two-column.el
diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el
index b8ff3c03ee9..17fcf7ad6c5 100644
--- a/lisp/emacs-lisp/debug.el
+++ b/lisp/emacs-lisp/debug.el
@@ -514,9 +514,9 @@ Applies to the frame whose line point is on in the backtrace."
(insert ? )))
(beginning-of-line))
-(put 'debugger-env-macro 'lisp-indent-function 0)
(defmacro debugger-env-macro (&rest body)
"Run BODY in original environment."
+ (declare (indent 0))
`(save-excursion
(if (null (buffer-name debugger-old-buffer))
;; old buffer deleted
diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el
index debef5535f5..3456d1a63fb 100644
--- a/lisp/emacs-lisp/derived.el
+++ b/lisp/emacs-lisp/derived.el
@@ -7,6 +7,7 @@
;; Author: David Megginson (dmeggins@aix1.uottawa.ca)
;; Maintainer: FSF
;; Keywords: extensions
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -230,7 +231,7 @@ No problems result if this variable is not bound.
; Run the parent.
(delay-mode-hooks
- (,(or parent 'kill-all-local-variables))
+ (,(or parent 'fundamental-mode))
; Identify the child mode.
(setq major-mode (quote ,child))
(setq mode-name ,name)
diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el
index a48816f99c6..9a703c96378 100644
--- a/lisp/emacs-lisp/easy-mmode.el
+++ b/lisp/emacs-lisp/easy-mmode.el
@@ -5,6 +5,7 @@
;; Author: Georges Brun-Cottan <Georges.Brun-Cottan@inria.fr>
;; Maintainer: Stefan Monnier <monnier@gnu.org>
+;; Package: emacs
;; Keywords: extensions lisp
@@ -114,6 +115,12 @@ BODY contains code to execute each time the mode is enabled or disabled.
:lighter SPEC Same as the LIGHTER argument.
:keymap MAP Same as the KEYMAP argument.
:require SYM Same as in `defcustom'.
+:variable PLACE The location (as can be used with `setf') to use instead
+ of the variable MODE to store the state of the mode. PLACE
+ can also be of the form (GET . SET) where GET is an expression
+ that returns the current state and SET is a function that takes
+ a new state and sets it. If you specify a :variable, this
+ function assumes it is defined elsewhere.
For example, you could write
(define-minor-mode foo-mode \"If enabled, foo on you!\"
@@ -145,6 +152,9 @@ For example, you could write
(type nil)
(extra-args nil)
(extra-keywords nil)
+ (variable nil) ;The PLACE where the state is stored.
+ (setter nil) ;The function (if any) to set the mode var.
+ (modefun mode) ;The minor mode function name we're defining.
(require t)
(hook (intern (concat mode-name "-hook")))
(hook-on (intern (concat mode-name "-on-hook")))
@@ -165,6 +175,12 @@ For example, you could write
(:type (setq type (list :type (pop body))))
(:require (setq require (pop body)))
(:keymap (setq keymap (pop body)))
+ (:variable (setq variable (pop body))
+ (if (not (functionp (cdr-safe variable)))
+ ;; PLACE is not of the form (GET . SET).
+ (setq mode variable)
+ (setq mode (car variable))
+ (setq setter (cdr variable))))
(t (push keyw extra-keywords) (push (pop body) extra-keywords))))
(setq keymap-sym (if (and keymap (symbolp keymap)) keymap
@@ -181,16 +197,21 @@ For example, you could write
`(:group ',(intern (replace-regexp-in-string
"-mode\\'" "" mode-name)))))
+ ;; TODO? Mark booleans as safe if booleanp? Eg abbrev-mode.
(unless type (setq type '(:type 'boolean)))
`(progn
;; Define the variable to enable or disable the mode.
- ,(if (not globalp)
- `(progn
- (defvar ,mode ,init-value ,(format "Non-nil if %s is enabled.
+ ,(cond
+ ;; If :variable is specified, then the var will be
+ ;; declared elsewhere.
+ (variable nil)
+ ((not globalp)
+ `(progn
+ (defvar ,mode ,init-value ,(format "Non-nil if %s is enabled.
Use the command `%s' to change this variable." pretty-name mode))
- (make-variable-buffer-local ',mode))
-
+ (make-variable-buffer-local ',mode)))
+ (t
(let ((base-doc-string
(concat "Non-nil if %s is enabled.
See the command `%s' for a description of this minor mode."
@@ -205,10 +226,10 @@ or call the function `%s'."))))
,@group
,@type
,@(unless (eq require t) `(:require ,require))
- ,@(nreverse extra-keywords))))
+ ,@(nreverse extra-keywords)))))
;; The actual function.
- (defun ,mode (&optional arg ,@extra-args)
+ (defun ,modefun (&optional arg ,@extra-args)
,(or doc
(format (concat "Toggle %s on or off.
Interactively, with no prefix argument, toggle the mode.
@@ -219,22 +240,19 @@ With zero or negative ARG turn mode off.
;; repeat-command still does the toggling correctly.
(interactive (list (or current-prefix-arg 'toggle)))
(let ((,last-message (current-message)))
- (setq ,mode
- (cond
- ((eq arg 'toggle) (not ,mode))
- (arg (> (prefix-numeric-value arg) 0))
- (t
- (if (null ,mode) t
- (message
- "Toggling %s off; better pass an explicit argument."
- ',mode)
- nil))))
+ (,@(if setter (list setter)
+ (list (if (symbolp mode) 'setq 'setf) mode))
+ (if (eq arg 'toggle)
+ (not ,mode)
+ ;; A nil argument also means ON now.
+ (> (prefix-numeric-value arg) 0)))
,@body
;; The on/off hooks are here for backward compatibility only.
(run-hooks ',hook (if ,mode ',hook-on ',hook-off))
(if (called-interactively-p 'any)
(progn
- ,(if globalp `(customize-mark-as-set ',mode))
+ ,(if (and globalp (symbolp mode))
+ `(customize-mark-as-set ',mode))
;; Avoid overwriting a message shown by the body,
;; but do overwrite previous messages.
(unless (and (current-message)
@@ -259,9 +277,15 @@ With zero or negative ARG turn mode off.
(t (error "Invalid keymap %S" ,keymap))))
,(format "Keymap for `%s'." mode-name)))
- (add-minor-mode ',mode ',lighter
- ,(if keymap keymap-sym
- `(if (boundp ',keymap-sym) ,keymap-sym))))))
+ ,(if (not (symbolp mode))
+ (if (or lighter keymap)
+ (error ":lighter and :keymap unsupported with mode expression %s" mode))
+ `(with-no-warnings
+ (add-minor-mode ',mode ',lighter
+ ,(if keymap keymap-sym
+ `(if (boundp ',keymap-sym) ,keymap-sym))
+ nil
+ ,(unless (eq mode modefun) 'modefun)))))))
;;;
;;; make global minor mode
@@ -341,9 +365,11 @@ See `%s' for more information on %s."
(progn
(add-hook 'after-change-major-mode-hook
',MODE-enable-in-buffers)
+ (add-hook 'fundamental-mode-hook ',MODE-enable-in-buffers)
(add-hook 'find-file-hook ',MODE-check-buffers)
(add-hook 'change-major-mode-hook ',MODE-cmhh))
(remove-hook 'after-change-major-mode-hook ',MODE-enable-in-buffers)
+ (remove-hook 'fundamental-mode-hook ',MODE-enable-in-buffers)
(remove-hook 'find-file-hook ',MODE-check-buffers)
(remove-hook 'change-major-mode-hook ',MODE-cmhh))
@@ -364,13 +390,14 @@ See `%s' for more information on %s."
(dolist (buf ,MODE-buffers)
(when (buffer-live-p buf)
(with-current-buffer buf
- (if ,mode
- (unless (eq ,MODE-major-mode major-mode)
- (,mode -1)
- (,turn-on)
- (setq ,MODE-major-mode major-mode))
- (,turn-on)
- (setq ,MODE-major-mode major-mode))))))
+ (unless (eq ,MODE-major-mode major-mode)
+ (if ,mode
+ (progn
+ (,mode -1)
+ (,turn-on)
+ (setq ,MODE-major-mode major-mode))
+ (,turn-on)
+ (setq ,MODE-major-mode major-mode)))))))
(put ',MODE-enable-in-buffers 'definition-name ',global-mode)
(defun ,MODE-check-buffers ()
@@ -558,5 +585,4 @@ BODY is executed after moving to the destination location."
(provide 'easy-mmode)
-;; arch-tag: d48a5250-6961-4528-9cb0-3c9ea042a66a
;;; easy-mmode.el ends here
diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el
index 470f0f67779..9992861fc3c 100644
--- a/lisp/emacs-lisp/easymenu.el
+++ b/lisp/emacs-lisp/easymenu.el
@@ -5,6 +5,7 @@
;; Keywords: emulations
;; Author: Richard Stallman <rms@gnu.org>
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -43,8 +44,6 @@ menus, turn this variable off, otherwise it is probably better to keep it on.")
(if (stringp s) (intern s) s))
;;;###autoload
-(put 'easy-menu-define 'lisp-indent-function 'defun)
-;;;###autoload
(defmacro easy-menu-define (symbol maps doc menu)
"Define a menu bar submenu in maps MAPS, according to MENU.
@@ -150,6 +149,7 @@ unselectable text. A string consisting solely of hyphens is displayed
as a solid horizontal line.
A menu item can be a list with the same format as MENU. This is a submenu."
+ (declare (indent defun))
`(progn
,(if symbol `(defvar ,symbol nil ,doc))
(easy-menu-do-define (quote ,symbol) ,maps ,doc ,menu)))
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index 8bf20b0ccef..77953b37021 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -1,8 +1,8 @@
;;; edebug.el --- a source-level debugger for Emacs Lisp
-;; Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1997, 1999,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1997,
+;; 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+;; 2010 Free Software Foundation, Inc.
;; Author: Daniel LaLiberte <liberte@holonexus.org>
;; Maintainer: FSF
@@ -885,17 +885,12 @@ already is one.)"
(edebug-storing-offsets (1- (point)) 'quote)
(edebug-read-storing-offsets stream)))
-(defvar edebug-read-backquote-level 0
- "If non-zero, we're in a new-style backquote.
-It should never be negative. This controls how we read comma constructs.")
-
(defun edebug-read-backquote (stream)
;; Turn `thing into (\` thing)
(forward-char 1)
(list
(edebug-storing-offsets (1- (point)) '\`)
- (let ((edebug-read-backquote-level (1+ edebug-read-backquote-level)))
- (edebug-read-storing-offsets stream))))
+ (edebug-read-storing-offsets stream)))
(defun edebug-read-comma (stream)
;; Turn ,thing into (\, thing). Handle ,@ and ,. also.
@@ -910,12 +905,9 @@ It should never be negative. This controls how we read comma constructs.")
(forward-char 1)))
;; Generate the same structure of offsets we would have
;; if the resulting list appeared verbatim in the input text.
- (if (zerop edebug-read-backquote-level)
- (edebug-storing-offsets opoint symbol)
- (list
- (edebug-storing-offsets opoint symbol)
- (let ((edebug-read-backquote-level (1- edebug-read-backquote-level)))
- (edebug-read-storing-offsets stream)))))))
+ (list
+ (edebug-storing-offsets opoint symbol)
+ (edebug-read-storing-offsets stream)))))
(defun edebug-read-function (stream)
;; Turn #'thing into (function thing)
@@ -937,17 +929,7 @@ It should never be negative. This controls how we read comma constructs.")
(prog1
(let ((elements))
(while (not (memq (edebug-next-token-class) '(rparen dot)))
- (if (and (eq (edebug-next-token-class) 'backquote)
- (null elements)
- (zerop edebug-read-backquote-level))
- (progn
- ;; Old style backquote.
- (forward-char 1) ; Skip backquote.
- ;; Call edebug-storing-offsets here so that we
- ;; produce the same offsets we would have had
- ;; if the backquote were an ordinary symbol.
- (push (edebug-storing-offsets (1- (point)) '\`) elements))
- (push (edebug-read-storing-offsets stream) elements)))
+ (push (edebug-read-storing-offsets stream) elements))
(setq elements (nreverse elements))
(if (eq 'dot (edebug-next-token-class))
(let (dotted-form)
@@ -3009,7 +2991,7 @@ MSG is printed after `::::} '."
;; Set up the overlay arrow at beginning-of-line in current buffer.
;; The arrow string is derived from edebug-arrow-alist and
;; edebug-execution-mode.
- (let ((pos (save-excursion (beginning-of-line) (point))))
+ (let ((pos (line-beginning-position)))
(setq overlay-arrow-string
(cdr (assq edebug-execution-mode edebug-arrow-alist)))
(setq overlay-arrow-position (make-marker))
@@ -4029,18 +4011,16 @@ May only be called from within `edebug-recursive-edit'."
-(defvar edebug-eval-mode-map nil
- "Keymap for Edebug Eval mode. Superset of Lisp Interaction mode.")
-
-(unless edebug-eval-mode-map
- (setq edebug-eval-mode-map (make-sparse-keymap))
- (set-keymap-parent edebug-eval-mode-map lisp-interaction-mode-map)
-
- (define-key edebug-eval-mode-map "\C-c\C-w" 'edebug-where)
- (define-key edebug-eval-mode-map "\C-c\C-d" 'edebug-delete-eval-item)
- (define-key edebug-eval-mode-map "\C-c\C-u" 'edebug-update-eval-list)
- (define-key edebug-eval-mode-map "\C-x\C-e" 'edebug-eval-last-sexp)
- (define-key edebug-eval-mode-map "\C-j" 'edebug-eval-print-last-sexp))
+(defvar edebug-eval-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map lisp-interaction-mode-map)
+ (define-key map "\C-c\C-w" 'edebug-where)
+ (define-key map "\C-c\C-d" 'edebug-delete-eval-item)
+ (define-key map "\C-c\C-u" 'edebug-update-eval-list)
+ (define-key map "\C-x\C-e" 'edebug-eval-last-sexp)
+ (define-key map "\C-j" 'edebug-eval-print-last-sexp)
+ map)
+"Keymap for Edebug Eval mode. Superset of Lisp Interaction mode.")
(put 'edebug-eval-mode 'mode-class 'special)
@@ -4455,7 +4435,7 @@ With prefix argument, make it a temporary breakpoint."
(add-hook 'cl-load-hook
(function (lambda () (require 'cl-specs)))))
-;;; edebug-cl-read and cl-read are available from liberte@cs.uiuc.edu
+;; edebug-cl-read and cl-read are available from liberte@cs.uiuc.edu
(if (featurep 'cl-read)
(add-hook 'edebug-setup-hook
(function (lambda () (require 'edebug-cl-read))))
@@ -4466,13 +4446,12 @@ With prefix argument, make it a temporary breakpoint."
;;; Finalize Loading
-;;; Finally, hook edebug into the rest of Emacs.
-;;; There are probably some other things that could go here.
+;; Finally, hook edebug into the rest of Emacs.
+;; There are probably some other things that could go here.
;; Install edebug read and eval functions.
(edebug-install-read-eval-functions)
(provide 'edebug)
-;; arch-tag: 19c8d05c-4554-426e-ac72-e0fa1fcb0808
;;; edebug.el ends here
diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el
index b573af29ee2..91cb5642fb7 100644
--- a/lisp/emacs-lisp/eieio-base.el
+++ b/lisp/emacs-lisp/eieio-base.el
@@ -6,6 +6,7 @@
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 0.2
;; Keywords: OO, lisp
+;; Package: eieio
;; This file is part of GNU Emacs.
diff --git a/lisp/emacs-lisp/eieio-comp.el b/lisp/emacs-lisp/eieio-comp.el
index a2b955a280b..e07a7b20d14 100644
--- a/lisp/emacs-lisp/eieio-comp.el
+++ b/lisp/emacs-lisp/eieio-comp.el
@@ -5,7 +5,8 @@
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 0.2
-;; Keywords: oop, lisp, tools
+;; Keywords: lisp, tools
+;; Package: eieio
;; This file is part of GNU Emacs.
@@ -46,10 +47,6 @@
;; This teaches the byte compiler how to do this sort of thing.
(put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod)
-;; Variables used free:
-(defvar outbuffer)
-(defvar filename)
-
(defun byte-compile-file-form-defmethod (form)
"Mumble about the method we are compiling.
This function is mostly ripped from `byte-compile-file-form-defun',
@@ -82,14 +79,18 @@ that is called but rarely. Argument FORM is the body of the method."
(class (if (listp arg1) (nth 1 arg1) nil))
(my-outbuffer (if (eval-when-compile (featurep 'xemacs))
byte-compile-outbuffer
- (condition-case nil
- bytecomp-outbuffer
- (error outbuffer))))
- )
+ (cond ((boundp 'bytecomp-outbuffer)
+ bytecomp-outbuffer) ; Emacs >= 23.2
+ ((boundp 'outbuffer) outbuffer)
+ (t (error "Unable to set outbuffer"))))))
(let ((name (format "%s::%s" (or class "#<generic>") meth)))
(if byte-compile-verbose
;; #### filename used free
- (message "Compiling %s... (%s)" (or filename "") name))
+ (message "Compiling %s... (%s)"
+ (cond ((boundp 'bytecomp-filename) bytecomp-filename)
+ ((boundp 'filename) filename)
+ (t ""))
+ name))
(setq byte-compile-current-form name) ; for warnings
)
;; Flush any pending output
@@ -138,5 +139,4 @@ Argument PARAMLIST is the parameter list to convert."
(provide 'eieio-comp)
-;; arch-tag: f2aacdd3-1da2-4ee9-b3e5-e8eac0832ee3
;;; eieio-comp.el ends here
diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el
index 268d60fc196..12ff23b311f 100644
--- a/lisp/emacs-lisp/eieio-custom.el
+++ b/lisp/emacs-lisp/eieio-custom.el
@@ -6,6 +6,7 @@
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 0.2
;; Keywords: OO, lisp
+;; Package: eieio
;; This file is part of GNU Emacs.
diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el
index 5dc54f5c35e..b58fbfd3f08 100644
--- a/lisp/emacs-lisp/eieio-datadebug.el
+++ b/lisp/emacs-lisp/eieio-datadebug.el
@@ -4,6 +4,7 @@
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: OO, lisp
+;; Package: eieio
;; This file is part of GNU Emacs.
diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el
index 375ce0bc6d6..ca3850562c8 100644
--- a/lisp/emacs-lisp/eieio-opt.el
+++ b/lisp/emacs-lisp/eieio-opt.el
@@ -6,6 +6,7 @@
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 0.2
;; Keywords: OO, lisp
+;; Package: eieio
;; This file is part of GNU Emacs.
diff --git a/lisp/emacs-lisp/eieio-speedbar.el b/lisp/emacs-lisp/eieio-speedbar.el
index e4c1c50aa8f..e16c3a17438 100644
--- a/lisp/emacs-lisp/eieio-speedbar.el
+++ b/lisp/emacs-lisp/eieio-speedbar.el
@@ -6,6 +6,7 @@
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 0.2
;; Keywords: OO, tools
+;; Package: eieio
;; This file is part of GNU Emacs.
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index 97022f0acbe..048093b858d 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -1629,6 +1629,7 @@ SPEC-LIST is of a form similar to `let'. For example:
Where each VAR is the local variable given to the associated
SLOT. A slot specified without a variable name is given a
variable name of the same name as the slot."
+ (declare (indent 2))
;; Transform the spec-list into a symbol-macrolet spec-list.
(let ((mappings (mapcar (lambda (entry)
(let ((var (if (listp entry) (car entry) entry))
@@ -1637,8 +1638,6 @@ variable name of the same name as the slot."
spec-list)))
(append (list 'symbol-macrolet mappings)
body)))
-(put 'with-slots 'lisp-indent-function 2)
-
;;; Simple generators, and query functions. None of these would do
;; well embedded into an object.
diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el
index 961d576433a..b4845495c9e 100644
--- a/lisp/emacs-lisp/eldoc.el
+++ b/lisp/emacs-lisp/eldoc.el
@@ -530,13 +530,13 @@ The words \"&rest\", \"&optional\" are returned unchanged."
;; Prime the command list.
(eldoc-add-command-completions
- "backward-" "beginning-of-" "move-beginning-of-" "delete-other-windows"
- "delete-window" "handle-select-window"
- "end-of-" "move-end-of-" "exchange-point-and-mark" "forward-"
- "indent-for-tab-command" "goto-" "mark-page" "mark-paragraph"
- "mouse-set-point" "move-" "pop-global-mark" "next-" "other-window"
- "previous-" "recenter" "scroll-" "self-insert-command"
- "split-window-" "up-list" "down-list")
+ "backward-" "beginning-of-" "delete-other-windows" "delete-window"
+ "down-list" "end-of-" "exchange-point-and-mark" "forward-" "goto-"
+ "handle-select-window" "indent-for-tab-command" "left-" "mark-page"
+ "mark-paragraph" "mouse-set-point" "move-" "move-beginning-of-"
+ "move-end-of-" "next-" "other-window" "pop-global-mark" "previous-"
+ "recenter" "right-" "scroll-" "self-insert-command" "split-window-"
+ "up-list")
(provide 'eldoc)
diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el
index b9aa29decd0..39c45e82309 100644
--- a/lisp/emacs-lisp/elint.el
+++ b/lisp/emacs-lisp/elint.el
@@ -394,40 +394,41 @@ Return nil if there are no more forms, t otherwise."
(parse-partial-sexp (point) (point-max) nil t)
(not (eobp)))
-(defvar env) ; from elint-init-env
+(defvar elint-env) ; from elint-init-env
(defun elint-init-form (form)
- "Process FORM, adding to ENV if recognized."
+ "Process FORM, adding to ELINT-ENV if recognized."
(cond
;; Eg nnmaildir seems to use [] as a form of comment syntax.
((not (listp form))
(elint-warning "Skipping non-list form `%s'" form))
;; Add defined variable
((memq (car form) '(defvar defconst defcustom))
- (setq env (elint-env-add-var env (cadr form))))
+ (setq elint-env (elint-env-add-var elint-env (cadr form))))
;; Add function
((memq (car form) '(defun defsubst))
- (setq env (elint-env-add-func env (cadr form) (nth 2 form))))
+ (setq elint-env (elint-env-add-func elint-env (cadr form) (nth 2 form))))
;; FIXME needs a handler to say second arg is not a variable when we come
;; to scan the form.
((eq (car form) 'define-derived-mode)
- (setq env (elint-env-add-func env (cadr form) ())
- env (elint-env-add-var env (cadr form))
- env (elint-env-add-var env (intern (format "%s-map" (cadr form))))))
+ (setq elint-env (elint-env-add-func elint-env (cadr form) ())
+ elint-env (elint-env-add-var elint-env (cadr form))
+ elint-env (elint-env-add-var elint-env
+ (intern (format "%s-map" (cadr form))))))
((eq (car form) 'define-minor-mode)
- (setq env (elint-env-add-func env (cadr form) '(&optional arg))
+ (setq elint-env (elint-env-add-func elint-env (cadr form) '(&optional arg))
;; FIXME mode map?
- env (elint-env-add-var env (cadr form))))
+ elint-env (elint-env-add-var elint-env (cadr form))))
((and (eq (car form) 'easy-menu-define)
(cadr form))
- (setq env (elint-env-add-func env (cadr form) '(event))
- env (elint-env-add-var env (cadr form))))
+ (setq elint-env (elint-env-add-func elint-env (cadr form) '(event))
+ elint-env (elint-env-add-var elint-env (cadr form))))
;; FIXME it would be nice to check the autoloads are correct.
((eq (car form) 'autoload)
- (setq env (elint-env-add-func env (cadr (cadr form)) 'unknown)))
+ (setq elint-env (elint-env-add-func elint-env (cadr (cadr form)) 'unknown)))
((eq (car form) 'declare-function)
- (setq env (elint-env-add-func
- env (cadr form)
+ (setq elint-env (elint-env-add-func
+ elint-env (cadr form)
(if (or (< (length form) 4)
(eq (nth 3 form) t)
(unless (stringp (nth 2 form))
@@ -440,14 +441,14 @@ Return nil if there are no more forms, t otherwise."
;; If the alias points to something already in the environment,
;; add the alias to the environment with the same arguments.
;; FIXME symbol-function, eg backquote.el?
- (let ((def (elint-env-find-func env (cadr (nth 2 form)))))
- (setq env (elint-env-add-func env (cadr (cadr form))
+ (let ((def (elint-env-find-func elint-env (cadr (nth 2 form)))))
+ (setq elint-env (elint-env-add-func elint-env (cadr (cadr form))
(if def (cadr def) 'unknown)))))
;; Add macro, both as a macro and as a function
((eq (car form) 'defmacro)
- (setq env (elint-env-add-macro env (cadr form)
+ (setq elint-env (elint-env-add-macro elint-env (cadr form)
(cons 'lambda (cddr form)))
- env (elint-env-add-func env (cadr form) (nth 2 form))))
+ elint-env (elint-env-add-func elint-env (cadr form) (nth 2 form))))
((and (eq (car form) 'put)
(= 4 (length form))
(eq (car-safe (cadr form)) 'quote)
@@ -471,12 +472,12 @@ Return nil if there are no more forms, t otherwise."
(setq name 'cl-macs
file nil
elint-doing-cl t)) ; blech
- (setq env (elint-add-required-env env name file))))))
- env)
+ (setq elint-env (elint-add-required-env elint-env name file))))))
+ elint-env)
(defun elint-init-env (forms)
"Initialize the environment from FORMS."
- (let ((env (elint-make-env))
+ (let ((elint-env (elint-make-env))
form)
(while forms
(setq form (elint-top-form-form (car forms))
@@ -489,7 +490,7 @@ Return nil if there are no more forms, t otherwise."
with-no-warnings))
(mapc 'elint-init-form (cdr form))
(elint-init-form form)))
- env))
+ elint-env))
(defun elint-add-required-env (env name file)
"Augment ENV with the variables defined by feature NAME in FILE."
@@ -1171,5 +1172,4 @@ If no documentation could be found args will be `unknown'."
(provide 'elint)
-;; arch-tag: b2f061e2-af84-4ddc-8e39-f5e969ac228f
;;; elint.el ends here
diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el
index 216d91baa7b..9d59337a7c7 100644
--- a/lisp/emacs-lisp/find-func.el
+++ b/lisp/emacs-lisp/find-func.el
@@ -213,6 +213,8 @@ LIBRARY should be a string (the name of the library)."
(interactive
(let* ((dirs (or find-function-source-path load-path))
(suffixes (find-library-suffixes))
+ (table (apply-partially 'locate-file-completion-table
+ dirs suffixes))
(def (if (eq (function-called-at-point) 'require)
;; `function-called-at-point' may return 'require
;; with `point' anywhere on this line. So wrap the
@@ -226,16 +228,12 @@ LIBRARY should be a string (the name of the library)."
(thing-at-point 'symbol))
(error nil))
(thing-at-point 'symbol))))
- (when def
- (setq def (and (locate-file-completion-table
- dirs suffixes def nil 'lambda)
- def)))
+ (when (and def (not (test-completion def table)))
+ (setq def nil))
(list
(completing-read (if def (format "Library name (default %s): " def)
"Library name: ")
- (apply-partially 'locate-file-completion-table
- dirs suffixes)
- nil nil nil nil def))))
+ table nil nil nil nil def))))
(let ((buf (find-file-noselect (find-library-name library))))
(condition-case nil (switch-to-buffer buf) (error (pop-to-buffer buf)))))
diff --git a/lisp/emacs-lisp/find-gc.el b/lisp/emacs-lisp/find-gc.el
index 3ca1df466b9..49d3a7075d4 100644
--- a/lisp/emacs-lisp/find-gc.el
+++ b/lisp/emacs-lisp/find-gc.el
@@ -60,7 +60,7 @@ Each entry has the form (FUNCTION . FUNCTIONS-IT-CALLS).")
"indent.c" "search.c" "regex.c" "undo.c"
"alloc.c" "data.c" "doc.c" "editfns.c"
"callint.c" "eval.c" "fns.c" "print.c" "lread.c"
- "abbrev.c" "syntax.c" "unexec.c"
+ "abbrev.c" "syntax.c" "unexcoff.c"
"bytecode.c" "process.c" "callproc.c" "doprnt.c"
"x11term.c" "x11fns.c"))
diff --git a/lisp/emacs-lisp/float-sup.el b/lisp/emacs-lisp/float-sup.el
index f98e452e343..371fe8af3ad 100644
--- a/lisp/emacs-lisp/float-sup.el
+++ b/lisp/emacs-lisp/float-sup.el
@@ -1,10 +1,11 @@
;;; float-sup.el --- define some constants useful for floating point numbers.
-;; Copyright (C) 1985, 1986, 1987, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1986, 1987, 2001, 2002, 2003, 2004, 2005, 2006,
+;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -25,36 +26,27 @@
;;; Code:
-;; Provide a meaningful error message if we are running on
-;; bare (non-float) emacs.
-
-(if (fboundp 'atan)
- nil
- (error "Floating point was disabled at compile time"))
-
-;; provide an easy hook to tell if we are running with floats or not.
-;; define pi and e via math-lib calls. (much less prone to killer typos.)
+;; Provide an easy hook to tell if we are running with floats or not.
+;; Define pi and e via math-lib calls (much less prone to killer typos).
(defconst float-pi (* 4 (atan 1)) "The value of Pi (3.1415926...).")
(defconst pi float-pi "Obsolete since Emacs-23.3. Use `float-pi' instead.")
(defconst float-e (exp 1) "The value of e (2.7182818...).")
-(defvar e float-e "Obsolete since Emacs-23.3. Use `float-e' instead.")
(defconst degrees-to-radians (/ float-pi 180.0)
"Degrees to radian conversion constant.")
(defconst radians-to-degrees (/ 180.0 float-pi)
"Radian to degree conversion constant.")
-;; these expand to a single multiply by a float when byte compiled
+;; These expand to a single multiply by a float when byte compiled.
(defmacro degrees-to-radians (x)
- "Convert ARG from degrees to radians."
+ "Convert X from degrees to radians."
(list '* degrees-to-radians x))
(defmacro radians-to-degrees (x)
- "Convert ARG from radians to degrees."
+ "Convert X from radians to degrees."
(list '* radians-to-degrees x))
(provide 'lisp-float-type)
-;; arch-tag: e7837072-a4af-4d08-9953-8a3e755abf9d
;;; float-sup.el ends here
diff --git a/lisp/emacs-lisp/generic.el b/lisp/emacs-lisp/generic.el
index b6e8427ea1c..51b23c3f402 100644
--- a/lisp/emacs-lisp/generic.el
+++ b/lisp/emacs-lisp/generic.el
@@ -6,6 +6,7 @@
;; Author: Peter Breton <pbreton@cs.umb.edu>
;; Created: Fri Sep 27 1996
;; Keywords: generic, comment, font-lock
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/emacs-lisp/helper.el b/lisp/emacs-lisp/helper.el
index b7cb8b93c2f..6a597429328 100644
--- a/lisp/emacs-lisp/helper.el
+++ b/lisp/emacs-lisp/helper.el
@@ -6,6 +6,7 @@
;; Author: K. Shane Hartman
;; Maintainer: FSF
;; Keywords: help
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el
index 8a1c753f5f6..7df65acb283 100644
--- a/lisp/emacs-lisp/lisp-mnt.el
+++ b/lisp/emacs-lisp/lisp-mnt.el
@@ -298,6 +298,7 @@ The returned value is a list of strings, one per line."
(defmacro lm-with-file (file &rest body)
"Execute BODY in a buffer containing the contents of FILE.
If FILE is nil, execute BODY in the current buffer."
+ (declare (indent 1) (debug t))
(let ((filesym (make-symbol "file")))
`(let ((,filesym ,file))
(if ,filesym
@@ -311,9 +312,6 @@ If FILE is nil, execute BODY in the current buffer."
(with-syntax-table emacs-lisp-mode-syntax-table
,@body))))))
-(put 'lm-with-file 'lisp-indent-function 1)
-(put 'lm-with-file 'edebug-form-spec t)
-
;; Fixme: Probably this should be amalgamated with copyright.el; also
;; we need a check for ranges in copyright years.
@@ -458,7 +456,9 @@ each line."
"Return list of keywords given in file FILE."
(let ((keywords (lm-keywords file)))
(if keywords
- (split-string keywords "[, \t\n]+" t))))
+ (if (string-match-p "," keywords)
+ (split-string keywords ",[ \t\n]*" t)
+ (split-string keywords "[ \t\n]+" t)))))
(defvar finder-known-keywords)
(defun lm-keywords-finder-p (&optional file)
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el
index 4b58a4e68c2..5f17514763d 100644
--- a/lisp/emacs-lisp/lisp-mode.el
+++ b/lisp/emacs-lisp/lisp-mode.el
@@ -5,6 +5,7 @@
;; Maintainer: FSF
;; Keywords: lisp, languages
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -85,7 +86,7 @@
(let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
(modify-syntax-entry ?\[ "_ " table)
(modify-syntax-entry ?\] "_ " table)
- (modify-syntax-entry ?# "' 14b" table)
+ (modify-syntax-entry ?# "' 14" table)
(modify-syntax-entry ?| "\" 23bn" table)
table)
"Syntax table used in `lisp-mode'.")
@@ -221,8 +222,6 @@ font-lock keywords will not be case sensitive."
;;(set (make-local-variable 'adaptive-fill-mode) nil)
(make-local-variable 'indent-line-function)
(setq indent-line-function 'lisp-indent-line)
- (make-local-variable 'parse-sexp-ignore-comments)
- (setq parse-sexp-ignore-comments t)
(make-local-variable 'outline-regexp)
(setq outline-regexp ";;;\\(;* [^ \t\n]\\|###autoload\\)\\|(")
(make-local-variable 'outline-level)
@@ -408,10 +407,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
(if (and (buffer-modified-p)
(y-or-n-p (format "Save buffer %s first? " (buffer-name))))
(save-buffer))
- (let ((compiled-file-name (byte-compile-dest-file buffer-file-name)))
- (if (file-newer-than-file-p compiled-file-name buffer-file-name)
- (load-file compiled-file-name)
- (byte-compile-file buffer-file-name t))))
+ (byte-recompile-file buffer-file-name nil 0 t))
(defcustom emacs-lisp-mode-hook nil
"Hook run when entering Emacs Lisp mode."
@@ -431,7 +427,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
:type 'hook
:group 'lisp)
-(define-derived-mode emacs-lisp-mode nil "Emacs-Lisp"
+(define-derived-mode emacs-lisp-mode prog-mode "Emacs-Lisp"
"Major mode for editing Lisp code to run in Emacs.
Commands:
Delete converts tabs to spaces as it moves back.
@@ -466,7 +462,7 @@ if that value is non-nil."
"Keymap for ordinary Lisp mode.
All commands in `lisp-mode-shared-map' are inherited by this map.")
-(defun lisp-mode ()
+(define-derived-mode lisp-mode prog-mode "Lisp"
"Major mode for editing Lisp code for Lisps other than GNU Emacs Lisp.
Commands:
Delete converts tabs to spaces as it moves back.
@@ -478,19 +474,12 @@ or to switch back to an existing one.
Entry to this mode calls the value of `lisp-mode-hook'
if that value is non-nil."
- (interactive)
- (kill-all-local-variables)
- (use-local-map lisp-mode-map)
- (setq major-mode 'lisp-mode)
- (setq mode-name "Lisp")
(lisp-mode-variables nil t)
+ (set (make-local-variable 'find-tag-default-function) 'lisp-find-tag-default)
(make-local-variable 'comment-start-skip)
(setq comment-start-skip
"\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\)\\(;+\\|#|\\) *")
- (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)
+ (setq imenu-case-fold-search t))
(defun lisp-find-tag-default ()
(let ((default (find-tag-default)))
@@ -1078,7 +1067,7 @@ is the buffer position of the start of the containing expression."
(goto-char calculate-lisp-indent-last-sexp)
(or (and (looking-at ":")
(setq indent (current-column)))
- (and (< (save-excursion (beginning-of-line) (point))
+ (and (< (line-beginning-position)
(prog2 (backward-sexp) (point)))
(looking-at ":")
(setq indent (current-column))))
@@ -1218,31 +1207,17 @@ This function also returns nil meaning don't specify the indentation."
(put 'prog2 'lisp-indent-function 2)
(put 'save-excursion 'lisp-indent-function 0)
(put 'save-window-excursion 'lisp-indent-function 0)
-(put 'save-selected-window 'lisp-indent-function 0)
(put 'save-restriction 'lisp-indent-function 0)
(put 'save-match-data 'lisp-indent-function 0)
(put 'save-current-buffer 'lisp-indent-function 0)
-(put 'with-current-buffer 'lisp-indent-function 1)
-(put 'combine-after-change-calls 'lisp-indent-function 0)
-(put 'with-output-to-string 'lisp-indent-function 0)
-(put 'with-temp-file 'lisp-indent-function 1)
-(put 'with-temp-buffer 'lisp-indent-function 0)
-(put 'with-temp-message 'lisp-indent-function 1)
-(put 'with-syntax-table 'lisp-indent-function 1)
(put 'let 'lisp-indent-function 1)
(put 'let* 'lisp-indent-function 1)
(put 'while 'lisp-indent-function 1)
(put 'if 'lisp-indent-function 2)
-(put 'read-if 'lisp-indent-function 2)
(put 'catch 'lisp-indent-function 1)
(put 'condition-case 'lisp-indent-function 2)
(put 'unwind-protect 'lisp-indent-function 1)
(put 'with-output-to-temp-buffer 'lisp-indent-function 1)
-(put 'eval-after-load 'lisp-indent-function 1)
-(put 'dolist 'lisp-indent-function 1)
-(put 'dotimes 'lisp-indent-function 1)
-(put 'when 'lisp-indent-function 1)
-(put 'unless 'lisp-indent-function 1)
(defun indent-sexp (&optional endpos)
"Indent each line of the list starting just after point.
@@ -1454,5 +1429,4 @@ means don't indent that line."
(provide 'lisp-mode)
-;; arch-tag: 414c7f93-c245-4b77-8ed5-ed05ef7ff1bf
;;; lisp-mode.el ends here
diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el
index 5703f1ee190..d0d1520a677 100644
--- a/lisp/emacs-lisp/lisp.el
+++ b/lisp/emacs-lisp/lisp.el
@@ -5,6 +5,7 @@
;; Maintainer: FSF
;; Keywords: lisp, languages
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -140,9 +141,19 @@ A negative argument means move backward but still to a less deep spot.
This command assumes point is not in a string or comment."
(interactive "^p")
(or arg (setq arg 1))
- (let ((inc (if (> arg 0) 1 -1)))
+ (let ((inc (if (> arg 0) 1 -1))
+ pos)
(while (/= arg 0)
- (goto-char (or (scan-lists (point) inc 1) (buffer-end arg)))
+ (if (null forward-sexp-function)
+ (goto-char (or (scan-lists (point) inc 1) (buffer-end arg)))
+ (condition-case err
+ (while (progn (setq pos (point))
+ (forward-sexp inc)
+ (/= (point) pos)))
+ (scan-error (goto-char (nth 2 err))))
+ (if (= (point) pos)
+ (signal 'scan-error
+ (list "Unbalanced parentheses" (point) (point)))))
(setq arg (- arg inc)))))
(defun kill-sexp (&optional arg)
@@ -624,45 +635,60 @@ considered."
(interactive)
(let* ((data (lisp-completion-at-point predicate))
(plist (nthcdr 3 data)))
- (let ((completion-annotate-function (plist-get plist :annotate-function)))
+ (if (null data)
+ (minibuffer-message "Nothing to complete")
+ (let ((completion-annotate-function
+ (plist-get plist :annotate-function)))
(completion-in-region (nth 0 data) (nth 1 data) (nth 2 data)
- (plist-get plist :predicate)))))
+ (plist-get plist :predicate))))))
(defun lisp-completion-at-point (&optional predicate)
"Function used for `completion-at-point-functions' in `emacs-lisp-mode'."
;; FIXME: the `end' could be after point?
(with-syntax-table emacs-lisp-mode-syntax-table
- (let* ((end (point))
- (beg (save-excursion
- (backward-sexp 1)
- (while (= (char-syntax (following-char)) ?\')
- (forward-char 1))
- (point)))
- (predicate
- (or predicate
- (save-excursion
- (goto-char beg)
- (if (not (eq (char-before) ?\())
- (lambda (sym) ;why not just nil ? -sm
- (or (boundp sym) (fboundp sym)
- (symbol-plist sym)))
- ;; Looks like a funcall position. Let's double check.
- (if (condition-case nil
- (progn (up-list -2) (forward-char 1)
- (eq (char-after) ?\())
- (error nil))
- ;; If the first element of the parent list is an open
- ;; paren we are probably not in a funcall position.
- ;; Maybe a `let' varlist or something.
- nil
- ;; Else, we assume that a function name is expected.
- 'fboundp))))))
- (list beg end obarray
- :predicate predicate
- :annotate-function
- (unless (eq predicate 'fboundp)
- (lambda (str) (if (fboundp (intern-soft str)) " <f>")))))))
+ (let* ((pos (point))
+ (beg (condition-case nil
+ (save-excursion
+ (backward-sexp 1)
+ (skip-syntax-forward "'")
+ (point))
+ (scan-error pos)))
+ (predicate
+ (or predicate
+ (save-excursion
+ (goto-char beg)
+ (if (not (eq (char-before) ?\())
+ (lambda (sym) ;why not just nil ? -sm
+ (or (boundp sym) (fboundp sym)
+ (symbol-plist sym)))
+ ;; Looks like a funcall position. Let's double check.
+ (if (condition-case nil
+ (progn (up-list -2) (forward-char 1)
+ (eq (char-after) ?\())
+ (error nil))
+ ;; If the first element of the parent list is an open
+ ;; paren we are probably not in a funcall position.
+ ;; Maybe a `let' varlist or something.
+ nil
+ ;; Else, we assume that a function name is expected.
+ 'fboundp)))))
+ (end
+ (unless (or (eq beg (point-max))
+ (member (char-syntax (char-after beg)) '(?\" ?\( ?\))))
+ (condition-case nil
+ (save-excursion
+ (goto-char beg)
+ (forward-sexp 1)
+ (when (>= (point) pos)
+ (point)))
+ (scan-error pos)))))
+ (when end
+ (list beg end obarray
+ :predicate predicate
+ :annotate-function
+ (unless (eq predicate 'fboundp)
+ (lambda (str) (if (fboundp (intern-soft str)) " <f>"))))))))
;; arch-tag: aa7fa8a4-2e6f-4e9b-9cd9-fef06340e67e
;;; lisp.el ends here
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index 364e3540703..6dfd47b4ad1 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -52,6 +52,7 @@ possible (for instance, when BODY just returns VAR unchanged, the
result will be eq to LIST).
\(fn (VAR LIST) BODY...)"
+ (declare (indent 1))
(let ((var (car var+list))
(list (cadr var+list))
(shared (make-symbol "shared"))
@@ -72,7 +73,6 @@ result will be eq to LIST).
(push ,new-el ,unshared))
(setq ,tail (cdr ,tail)))
(nconc (nreverse ,unshared) ,shared))))
-(put 'macroexp-accumulate 'lisp-indent-function 1)
(defun macroexpand-all-forms (forms &optional skip)
"Return FORMS with macros expanded. FORMS is a list of forms.
@@ -107,80 +107,69 @@ Assumes the caller has bound `macroexpand-all-environment'."
macroexpand-all-environment)
;; Normal form; get its expansion, and then expand arguments.
(setq form (macroexpand form macroexpand-all-environment))
- (if (consp form)
- (let ((fun (car form)))
- (cond
- ((eq fun 'cond)
- (maybe-cons fun (macroexpand-all-clauses (cdr form)) form))
- ((eq fun 'condition-case)
- (maybe-cons
- fun
- (maybe-cons (cadr form)
- (maybe-cons (macroexpand-all-1 (nth 2 form))
- (macroexpand-all-clauses (nthcdr 3 form) 1)
- (cddr form))
- (cdr form))
- form))
- ((eq fun 'defmacro)
- (push (cons (cadr form) (cons 'lambda (cddr form)))
- macroexpand-all-environment)
- (macroexpand-all-forms form 3))
- ((eq fun 'defun)
- (macroexpand-all-forms form 3))
- ((memq fun '(defvar defconst))
- (macroexpand-all-forms form 2))
- ((eq fun 'function)
- (if (and (consp (cadr form)) (eq (car (cadr form)) 'lambda))
- (maybe-cons fun
- (maybe-cons (macroexpand-all-forms (cadr form) 2)
- nil
- (cadr form))
- form)
- form))
- ((memq fun '(let let*))
- (maybe-cons fun
- (maybe-cons (macroexpand-all-clauses (cadr form) 1)
- (macroexpand-all-forms (cddr form))
- (cdr form))
- form))
- ((eq fun 'quote)
- form)
- ((and (consp fun) (eq (car fun) 'lambda))
- ;; embedded lambda
- (maybe-cons (macroexpand-all-forms fun 2)
- (macroexpand-all-forms (cdr form))
- form))
- ;; The following few cases are for normal function calls that
- ;; are known to funcall one of their arguments. The byte
- ;; compiler has traditionally handled these functions specially
- ;; by treating a lambda expression quoted by `quote' as if it
- ;; were quoted by `function'. We make the same transformation
- ;; here, so that any code that cares about the difference will
- ;; see the same transformation.
- ;; First arg is a function:
- ((and (memq fun '(apply mapcar mapatoms mapconcat mapc))
- (consp (cadr form))
- (eq (car (cadr form)) 'quote))
- ;; We don't use `maybe-cons' since there's clearly a change.
- (cons fun
- (cons (macroexpand-all-1 (cons 'function (cdr (cadr form))))
- (macroexpand-all-forms (cddr form)))))
- ;; Second arg is a function:
- ((and (eq fun 'sort)
- (consp (nth 2 form))
- (eq (car (nth 2 form)) 'quote))
- ;; We don't use `maybe-cons' since there's clearly a change.
- (cons fun
- (cons (macroexpand-all-1 (cadr form))
- (cons (macroexpand-all-1
- (cons 'function (cdr (nth 2 form))))
- (macroexpand-all-forms (nthcdr 3 form))))))
- (t
- ;; For everything else, we just expand each argument (for
- ;; setq/setq-default this works alright because the variable names
- ;; are symbols).
- (macroexpand-all-forms form 1))))
- form)))
+ (pcase form
+ (`(cond . ,clauses)
+ (maybe-cons 'cond (macroexpand-all-clauses clauses) form))
+ (`(condition-case . ,(or `(,err ,body . ,handlers) dontcare))
+ (maybe-cons
+ 'condition-case
+ (maybe-cons err
+ (maybe-cons (macroexpand-all-1 body)
+ (macroexpand-all-clauses handlers 1)
+ (cddr form))
+ (cdr form))
+ form))
+ (`(defmacro ,name . ,args-and-body)
+ (push (cons name (cons 'lambda args-and-body))
+ macroexpand-all-environment)
+ (macroexpand-all-forms form 3))
+ (`(defun . ,_) (macroexpand-all-forms form 3))
+ (`(,(or `defvar `defconst) . ,_) (macroexpand-all-forms form 2))
+ (`(function ,(and f `(lambda . ,_)))
+ (maybe-cons 'function
+ (maybe-cons (macroexpand-all-forms f 2)
+ nil
+ (cdr form))
+ form))
+ (`(,(or `function `quote) . ,_) form)
+ (`(,(and fun (or `let `let*)) . ,(or `(,bindings . ,body) dontcare))
+ (maybe-cons fun
+ (maybe-cons (macroexpand-all-clauses bindings 1)
+ (macroexpand-all-forms body)
+ (cdr form))
+ form))
+ (`(,(and fun `(lambda . ,_)) . ,args)
+ ;; Embedded lambda in function position.
+ (maybe-cons (macroexpand-all-forms fun 2)
+ (macroexpand-all-forms args)
+ form))
+ ;; The following few cases are for normal function calls that
+ ;; are known to funcall one of their arguments. The byte
+ ;; compiler has traditionally handled these functions specially
+ ;; by treating a lambda expression quoted by `quote' as if it
+ ;; were quoted by `function'. We make the same transformation
+ ;; here, so that any code that cares about the difference will
+ ;; see the same transformation.
+ ;; First arg is a function:
+ (`(,(and fun (or `apply `mapcar `mapatoms `mapconcat `mapc)) ',f . ,args)
+ ;; We don't use `maybe-cons' since there's clearly a change.
+ (cons fun
+ (cons (macroexpand-all-1 (list 'function f))
+ (macroexpand-all-forms args))))
+ ;; Second arg is a function:
+ (`(,(and fun (or `sort)) ,arg1 ',f . ,args)
+ ;; We don't use `maybe-cons' since there's clearly a change.
+ (cons fun
+ (cons (macroexpand-all-1 arg1)
+ (cons (macroexpand-all-1
+ (list 'function f))
+ (macroexpand-all-forms args)))))
+ (`(,_ . ,_)
+ ;; For every other list, we just expand each argument (for
+ ;; setq/setq-default this works alright because the variable names
+ ;; are symbols).
+ (macroexpand-all-forms form 1))
+ (t form))))
;;;###autoload
(defun macroexpand-all (form &optional environment)
diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el
new file mode 100644
index 00000000000..38c4d5bbe35
--- /dev/null
+++ b/lisp/emacs-lisp/package-x.el
@@ -0,0 +1,227 @@
+;;; package-x.el --- Package extras
+
+;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Tom Tromey <tromey@redhat.com>
+;; Created: 10 Mar 2007
+;; Version: 0.9
+;; Keywords: tools
+;; Package: package
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; This file currently contains parts of the package system most
+;; people won't need, such as package uploading.
+
+;;; Code:
+
+(require 'package)
+(defvar gnus-article-buffer)
+
+;; Note that this only works if you have the password, which you
+;; probably don't :-).
+(defvar package-archive-upload-base nil
+ "Base location for uploading to package archive.")
+
+(defun package--encode (string)
+ "Encode a string by replacing some characters with XML entities."
+ ;; We need a special case for translating "&" to "&amp;".
+ (let ((index))
+ (while (setq index (string-match "[&]" string index))
+ (setq string (replace-match "&amp;" t nil string))
+ (setq index (1+ index))))
+ (while (string-match "[<]" string)
+ (setq string (replace-match "&lt;" t nil string)))
+ (while (string-match "[>]" string)
+ (setq string (replace-match "&gt;" t nil string)))
+ (while (string-match "[']" string)
+ (setq string (replace-match "&apos;" t nil string)))
+ (while (string-match "[\"]" string)
+ (setq string (replace-match "&quot;" t nil string)))
+ string)
+
+(defun package--make-rss-entry (title text archive-url)
+ (let ((date-string (format-time-string "%a, %d %B %Y %T %z")))
+ (concat "<item>\n"
+ "<title>" (package--encode title) "</title>\n"
+ ;; FIXME: should have a link in the web page.
+ "<link>" archive-url "news.html</link>\n"
+ "<description>" (package--encode text) "</description>\n"
+ "<pubDate>" date-string "</pubDate>\n"
+ "</item>\n")))
+
+(defun package--make-html-entry (title text)
+ (concat "<li> " (format-time-string "%B %e") " - "
+ title " - " (package--encode text)
+ " </li>\n"))
+
+(defun package--update-file (file location text)
+ (save-excursion
+ (let ((old-buffer (find-buffer-visiting file)))
+ (with-current-buffer (let ((find-file-visit-truename t))
+ (or old-buffer (find-file-noselect file)))
+ (goto-char (point-min))
+ (search-forward location)
+ (forward-line)
+ (insert text)
+ (let ((file-precious-flag t))
+ (save-buffer))
+ (unless old-buffer
+ (kill-buffer (current-buffer)))))))
+
+(defun package-maint-add-news-item (title description archive-url)
+ "Add a news item to the ELPA web pages.
+TITLE is the title of the news item.
+DESCRIPTION is the text of the news item.
+You need administrative access to ELPA to use this."
+ (interactive "sTitle: \nsText: ")
+ (package--update-file (concat package-archive-upload-base "elpa.rss")
+ "<description>"
+ (package--make-rss-entry title description archive-url))
+ (package--update-file (concat package-archive-upload-base "news.html")
+ "New entries go here"
+ (package--make-html-entry title description)))
+
+(defun package--update-news (package version description archive-url)
+ "Update the ELPA web pages when a package is uploaded."
+ (package-maint-add-news-item (concat package " version " version)
+ description
+ archive-url))
+
+(defun package-upload-buffer-internal (pkg-info extension &optional archive-url)
+ "Upload a package whose contents are in the current buffer.
+PKG-INFO is the package info, see `package-buffer-info'.
+EXTENSION is the file extension, a string. It can be either
+\"el\" or \"tar\".
+
+Optional arg ARCHIVE-URL is the URL of the destination archive.
+If nil, the \"gnu\" archive is used."
+ (unless archive-url
+ (or (setq archive-url (cdr (assoc "gnu" package-archives)))
+ (error "No destination URL")))
+ (save-excursion
+ (save-restriction
+ (let* ((file-type (cond
+ ((equal extension "el") 'single)
+ ((equal extension "tar") 'tar)
+ (t (error "Unknown extension `%s'" extension))))
+ (file-name (aref pkg-info 0))
+ (pkg-name (intern file-name))
+ (requires (aref pkg-info 1))
+ (desc (if (string= (aref pkg-info 2) "")
+ (read-string "Description of package: ")
+ (aref pkg-info 2)))
+ (pkg-version (aref pkg-info 3))
+ (commentary (aref pkg-info 4))
+ (split-version (version-to-list pkg-version))
+ (pkg-buffer (current-buffer))
+
+ ;; Download latest archive-contents.
+ (buffer (url-retrieve-synchronously
+ (concat archive-url "archive-contents"))))
+
+ ;; Parse archive-contents.
+ (set-buffer buffer)
+ (package-handle-response)
+ (re-search-forward "^$" nil 'move)
+ (forward-char)
+ (delete-region (point-min) (point))
+ (let ((contents (package-read-from-string
+ (buffer-substring-no-properties (point-min)
+ (point-max))))
+ (new-desc (vector split-version requires desc file-type)))
+ (if (> (car contents) package-archive-version)
+ (error "Unrecognized archive version %d" (car contents)))
+ (let ((elt (assq pkg-name (cdr contents))))
+ (if elt
+ (if (version-list-<= split-version
+ (package-desc-vers (cdr elt)))
+ (error "New package has smaller version: %s" pkg-version)
+ (setcdr elt new-desc))
+ (setq contents (cons (car contents)
+ (cons (cons pkg-name new-desc)
+ (cdr contents))))))
+
+ ;; Now CONTENTS is the updated archive contents. Upload
+ ;; this and the package itself. For now we assume ELPA is
+ ;; writable via file primitives.
+ (let ((print-level nil)
+ (print-length nil))
+ (write-region (concat (pp-to-string contents) "\n")
+ nil
+ (concat package-archive-upload-base
+ "archive-contents")))
+
+ ;; If there is a commentary section, write it.
+ (when commentary
+ (write-region commentary nil
+ (concat package-archive-upload-base
+ (symbol-name pkg-name) "-readme.txt")))
+
+ (set-buffer pkg-buffer)
+ (kill-buffer buffer)
+ (write-region (point-min) (point-max)
+ (concat package-archive-upload-base
+ file-name "-" pkg-version
+ "." extension)
+ nil nil nil 'excl)
+
+ ;; Write a news entry.
+ (package--update-news (concat file-name "." extension)
+ pkg-version desc archive-url)
+
+ ;; special-case "package": write a second copy so that the
+ ;; installer can easily find the latest version.
+ (if (string= file-name "package")
+ (write-region (point-min) (point-max)
+ (concat package-archive-upload-base
+ file-name "." extension)
+ nil nil nil 'ask)))))))
+
+(defun package-upload-buffer ()
+ "Upload a single .el file to ELPA from the current buffer."
+ (interactive)
+ (save-excursion
+ (save-restriction
+ ;; Find the package in this buffer.
+ (let ((pkg-info (package-buffer-info)))
+ (package-upload-buffer-internal pkg-info "el")))))
+
+(defun package-upload-file (file)
+ (interactive "fPackage file name: ")
+ (with-temp-buffer
+ (insert-file-contents-literally file)
+ (let ((info (cond
+ ((string-match "\\.tar$" file) (package-tar-file-info file))
+ ((string-match "\\.el$" file) (package-buffer-info))
+ (t (error "Unrecognized extension `%s'"
+ (file-name-extension file))))))
+ (package-upload-buffer-internal info (file-name-extension file)))))
+
+(defun package-gnus-summary-upload ()
+ "Upload a package contained in the current *Article* buffer.
+This should be invoked from the gnus *Summary* buffer."
+ (interactive)
+ (with-current-buffer gnus-article-buffer
+ (package-upload-buffer)))
+
+(provide 'package-x)
+
+;;; package.el ends here
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
new file mode 100644
index 00000000000..fecddcf16ed
--- /dev/null
+++ b/lisp/emacs-lisp/package.el
@@ -0,0 +1,1700 @@
+;;; package.el --- Simple package system for Emacs
+
+;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Tom Tromey <tromey@redhat.com>
+;; Created: 10 Mar 2007
+;; Version: 0.9
+;; Keywords: 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 3, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Change Log:
+
+;; 2 Apr 2007 - now using ChangeLog file
+;; 15 Mar 2007 - updated documentation
+;; 14 Mar 2007 - Changed how obsolete packages are handled
+;; 13 Mar 2007 - Wrote package-install-from-buffer
+;; 12 Mar 2007 - Wrote package-menu mode
+
+;;; Commentary:
+
+;; The idea behind package.el is to be able to download packages and
+;; install them. Packages are versioned and have versioned
+;; dependencies. Furthermore, this supports built-in packages which
+;; may or may not be newer than user-specified packages. This makes
+;; it possible to upgrade Emacs and automatically disable packages
+;; which have moved from external to core. (Note though that we don't
+;; currently register any of these, so this feature does not actually
+;; work.)
+
+;; A package is described by its name and version. The distribution
+;; format is either a tar file or a single .el file.
+
+;; A tar file should be named "NAME-VERSION.tar". The tar file must
+;; unpack into a directory named after the package and version:
+;; "NAME-VERSION". It must contain a file named "PACKAGE-pkg.el"
+;; which consists of a call to define-package. It may also contain a
+;; "dir" file and the info files it references.
+
+;; A .el file is named "NAME-VERSION.el" in the remote archive, but is
+;; installed as simply "NAME.el" in a directory named "NAME-VERSION".
+
+;; The downloader downloads all dependent packages. By default,
+;; packages come from the official GNU sources, but others may be
+;; added by customizing the `package-archives' alist. Packages get
+;; byte-compiled at install time.
+
+;; At activation time we will set up the load-path and the info path,
+;; and we will load the package's autoloads. If a package's
+;; dependencies are not available, we will not activate that package.
+
+;; Conceptually a package has multiple state transitions:
+;;
+;; * Download. Fetching the package from ELPA.
+;; * Install. Untar the package, or write the .el file, into
+;; ~/.emacs.d/elpa/ directory.
+;; * Byte compile. Currently this phase is done during install,
+;; but we may change this.
+;; * Activate. Evaluate the autoloads for the package to make it
+;; available to the user.
+;; * Load. Actually load the package and run some code from it.
+
+;; Other external functions you may want to use:
+;;
+;; M-x list-packages
+;; Enters a mode similar to buffer-menu which lets you manage
+;; packages. You can choose packages for install (mark with "i",
+;; then "x" to execute) or deletion (not implemented yet), and you
+;; can see what packages are available. This will automatically
+;; fetch the latest list of packages from ELPA.
+;;
+;; M-x package-list-packages-no-fetch
+;; Like package-list-packages, but does not automatically fetch the
+;; new list of packages.
+;;
+;; M-x package-install-from-buffer
+;; Install a package consisting of a single .el file that appears
+;; in the current buffer. This only works for packages which
+;; define a Version header properly; package.el also supports the
+;; extension headers Package-Version (in case Version is an RCS id
+;; or similar), and Package-Requires (if the package requires other
+;; packages).
+;;
+;; M-x package-install-file
+;; Install a package from the indicated file. The package can be
+;; either a tar file or a .el file. A tar file must contain an
+;; appropriately-named "-pkg.el" file; a .el file must be properly
+;; formatted as with package-install-from-buffer.
+
+;;; Thanks:
+;;; (sorted by sort-lines):
+
+;; Jim Blandy <jimb@red-bean.com>
+;; Karl Fogel <kfogel@red-bean.com>
+;; Kevin Ryde <user42@zip.com.au>
+;; Lawrence Mitchell
+;; Michael Olson <mwolson@member.fsf.org>
+;; Sebastian Tennant <sebyte@smolny.plus.com>
+;; Stefan Monnier <monnier@iro.umontreal.ca>
+;; Vinicius Jose Latorre <viniciusjl@ig.com.br>
+;; Phil Hagelberg <phil@hagelb.org>
+
+;;; ToDo:
+
+;; - putting info dirs at the start of the info path means
+;; users see a weird ordering of categories. OTOH we want to
+;; override later entries. maybe emacs needs to enforce
+;; the standard layout?
+;; - put bytecode in a separate directory tree
+;; - perhaps give users a way to recompile their bytecode
+;; or do it automatically when emacs changes
+;; - give users a way to know whether a package is installed ok
+;; - give users a way to view a package's documentation when it
+;; only appears in the .el
+;; - use/extend checkdoc so people can tell if their package will work
+;; - "installed" instead of a blank in the status column
+;; - tramp needs its files to be compiled in a certain order.
+;; how to handle this? fix tramp?
+;; - on emacs 21 we don't kill the -autoloads.el buffer. what about 22?
+;; - maybe we need separate .elc directories for various emacs versions
+;; and also emacs-vs-xemacs. That way conditional compilation can
+;; work. But would this break anything?
+;; - should store the package's keywords in archive-contents, then
+;; let the users filter the package-menu by keyword. See
+;; finder-by-keyword. (We could also let people view the
+;; Commentary, but it isn't clear how useful this is.)
+;; - William Xu suggests being able to open a package file without
+;; installing it
+;; - Interface with desktop.el so that restarting after an install
+;; works properly
+;; - Implement M-x package-upgrade, to upgrade any/all existing packages
+;; - Use hierarchical layout. PKG/etc PKG/lisp PKG/info
+;; ... except maybe lisp?
+;; - It may be nice to have a macro that expands to the package's
+;; private data dir, aka ".../etc". Or, maybe data-directory
+;; needs to be a list (though this would be less nice)
+;; a few packages want this, eg sokoban
+;; - package menu needs:
+;; ability to know which packages are built-in & thus not deletable
+;; it can sometimes print odd results, like 0.3 available but 0.4 active
+;; why is that?
+;; - Allow multiple versions on the server...?
+;; [ why bother? ]
+;; - Don't install a package which will invalidate dependencies overall
+;; - Allow something like (or (>= emacs 21.0) (>= xemacs 21.5))
+;; [ currently thinking, why bother.. KISS ]
+;; - Allow optional package dependencies
+;; then if we require 'bbdb', bbdb-specific lisp in lisp/bbdb
+;; and just don't compile to add to load path ...?
+;; - Have a list of archive URLs? [ maybe there's no point ]
+;; - David Kastrup pointed out on the xemacs list that for GPL it
+;; is friendlier to ship the source tree. We could "support" that
+;; by just having a "src" subdir in the package. This isn't ideal
+;; but it probably is not worth trying to support random source
+;; tree layouts, build schemes, etc.
+;; - Our treatment of the info path is somewhat bogus
+;; - perhaps have an "unstable" tree in ELPA as well as a stable one
+
+;;; Code:
+
+(defgroup package nil
+ "Manager for Emacs Lisp packages."
+ :group 'applications
+ :version "24.1")
+
+;;;###autoload
+(defcustom package-enable-at-startup t
+ "Whether to activate installed packages when Emacs starts.
+If non-nil, packages are activated after reading the init file
+and before `after-init-hook'. Activation is not done if
+`user-init-file' is nil (e.g. Emacs was started with \"-q\").
+
+Even if the value is nil, you can type \\[package-initialize] to
+activate the package system at any time."
+ :type 'boolean
+ :group 'package
+ :version "24.1")
+
+(defcustom package-load-list '(all)
+ "List of packages for `package-initialize' to load.
+Each element in this list should be a list (NAME VERSION), or the
+symbol `all'. The symbol `all' says to load the latest installed
+versions of all packages not specified by other elements.
+
+For an element (NAME VERSION), NAME is a package name (a symbol).
+VERSION should be t, a string, or nil.
+If VERSION is t, all versions are loaded, though obsolete ones
+ will be put in `package-obsolete-alist' and not activated.
+If VERSION is a string, only that version is ever loaded.
+ Any other version, even if newer, is silently ignored.
+ Hence, the package is \"held\" at that version.
+If VERSION is nil, the package is not loaded (it is \"disabled\")."
+ :type '(repeat symbol)
+ :risky t
+ :group 'package
+ :version "24.1")
+
+(defvar Info-directory-list)
+(declare-function info-initialize "info" ())
+(declare-function url-http-parse-response "url-http" ())
+(declare-function lm-header "lisp-mnt" (header))
+(declare-function lm-commentary "lisp-mnt" (&optional file))
+(defvar url-http-end-of-headers)
+
+(defcustom package-archives '(("gnu" . "http://elpa.gnu.org/packages/"))
+ "An alist of archives from which to fetch.
+The default value points to the GNU Emacs package repository.
+Each element has the form (ID . URL), where ID is an identifier
+string for an archive and URL is a http: URL (a string)."
+ :type '(alist :key-type (string :tag "Archive name")
+ :value-type (string :tag "Archive URL"))
+ :risky t
+ :group 'package
+ :version "24.1")
+
+(defconst package-archive-version 1
+ "Version number of the package archive understood by this file.
+Lower version numbers than this will probably be understood as well.")
+
+(defconst package-el-version "1.0"
+ "Version of package.el.")
+
+;; We don't prime the cache since it tends to get out of date.
+(defvar package-archive-contents nil
+ "Cache of the contents of the Emacs Lisp Package Archive.
+This is an alist mapping package names (symbols) to package
+descriptor vectors. These are like the vectors for `package-alist'
+but have extra entries: one which is 'tar for tar packages and
+'single for single-file packages, and one which is the name of
+the archive from which it came.")
+(put 'package-archive-contents 'risky-local-variable t)
+
+(defcustom package-user-dir (locate-user-emacs-file "elpa")
+ "Directory containing the user's Emacs Lisp packages.
+The directory name should be absolute.
+Apart from this directory, Emacs also looks for system-wide
+packages in `package-directory-list'."
+ :type 'directory
+ :risky t
+ :group 'package
+ :version "24.1")
+
+(defcustom package-directory-list
+ ;; Defaults are subdirs named "elpa" in the site-lisp dirs.
+ (let (result)
+ (dolist (f load-path)
+ (and (stringp f)
+ (equal (file-name-nondirectory f) "site-lisp")
+ (push (expand-file-name "elpa" f) result)))
+ (nreverse result))
+ "List of additional directories containing Emacs Lisp packages.
+Each directory name should be absolute.
+
+These directories contain packages intended for system-wide; in
+contrast, `package-user-dir' contains packages for personal use."
+ :type '(repeat directory)
+ :risky t
+ :group 'package
+ :version "24.1")
+
+;; The value is precomputed in finder-inf.el, but don't load that
+;; until it's needed (i.e. when `package-intialize' is called).
+(defvar package--builtins nil
+ "Alist of built-in packages.
+The actual value is initialized by loading the library
+`finder-inf'; this is not done until it is needed, e.g. by the
+function `package-built-in-p'.
+
+Each element has the form (PKG . DESC), where PKG is a package
+name (a symbol) and DESC is a vector that describes the package.
+The vector DESC has the form [VERSION REQS DOCSTRING].
+ VERSION is a version list.
+ REQS is a list of packages (symbols) required by the package.
+ DOCSTRING is a brief description of the package.")
+(put 'package--builtins 'risky-local-variable t)
+
+(defvar package-alist nil
+ "Alist of all packages available for activation.
+Each element has the form (PKG . DESC), where PKG is a package
+name (a symbol) and DESC is a vector that describes the package.
+
+The vector DESC has the form [VERSION REQS DOCSTRING].
+ VERSION is a version list.
+ REQS is a list of packages (symbols) required by the package.
+ DOCSTRING is a brief description of the package.
+
+This variable is set automatically by `package-load-descriptor',
+called via `package-initialize'. To change which packages are
+loaded and/or activated, customize `package-load-list'.")
+(put 'package-archive-contents 'risky-local-variable t)
+
+(defvar package-activated-list nil
+ "List of the names of currently activated packages.")
+(put 'package-activated-list 'risky-local-variable t)
+
+(defvar package-obsolete-alist nil
+ "Representation of obsolete packages.
+Like `package-alist', but maps package name to a second alist.
+The inner alist is keyed by version.")
+(put 'package-obsolete-alist 'risky-local-variable t)
+
+(defconst package-subdirectory-regexp
+ "^\\([^.].*\\)-\\([0-9]+\\(?:[.][0-9]+\\)*\\)$"
+ "Regular expression matching the name of a package subdirectory.
+The first subexpression is the package name.
+The second subexpression is the version string.")
+
+(defun package-version-join (l)
+ "Turn a list of version numbers into a version string."
+ (mapconcat 'int-to-string l "."))
+
+(defun package-strip-version (dirname)
+ "Strip the version from a combined package name and version.
+E.g., if given \"quux-23.0\", will return \"quux\""
+ (if (string-match package-subdirectory-regexp dirname)
+ (match-string 1 dirname)))
+
+(defun package-load-descriptor (dir package)
+ "Load the description file in directory DIR for package PACKAGE.
+Here, PACKAGE is a string of the form NAME-VER, where NAME is the
+package name and VER is its version."
+ (let* ((pkg-dir (expand-file-name package dir))
+ (pkg-file (expand-file-name
+ (concat (package-strip-version package) "-pkg")
+ pkg-dir)))
+ (when (and (file-directory-p pkg-dir)
+ (file-exists-p (concat pkg-file ".el")))
+ (load pkg-file nil t))))
+
+(defun package-load-all-descriptors ()
+ "Load descriptors for installed Emacs Lisp packages.
+This looks for package subdirectories in `package-user-dir' and
+`package-directory-list'. The variable `package-load-list'
+controls which package subdirectories may be loaded.
+
+In each valid package subdirectory, this function loads the
+description file containing a call to `define-package', which
+updates `package-alist' and `package-obsolete-alist'."
+ (let ((all (memq 'all package-load-list))
+ name version force)
+ (dolist (dir (cons package-user-dir package-directory-list))
+ (when (file-directory-p dir)
+ (dolist (subdir (directory-files dir))
+ (when (and (file-directory-p (expand-file-name subdir dir))
+ (string-match package-subdirectory-regexp subdir))
+ (setq name (intern (match-string 1 subdir))
+ version (match-string 2 subdir)
+ force (assq name package-load-list))
+ (when (cond
+ ((null force)
+ all) ; not in package-load-list
+ ((null (setq force (cadr force)))
+ nil) ; disabled
+ ((eq force t)
+ t)
+ ((stringp force) ; held
+ (version-list-= (version-to-list version)
+ (version-to-list force)))
+ (t
+ (error "Invalid element in `package-load-list'")))
+ (package-load-descriptor dir subdir))))))))
+
+(defsubst package-desc-vers (desc)
+ "Extract version from a package description vector."
+ (aref desc 0))
+
+(defsubst package-desc-reqs (desc)
+ "Extract requirements from a package description vector."
+ (aref desc 1))
+
+(defsubst package-desc-doc (desc)
+ "Extract doc string from a package description vector."
+ (aref desc 2))
+
+(defsubst package-desc-kind (desc)
+ "Extract the kind of download from an archive package description vector."
+ (aref desc 3))
+
+(defun package--dir (name version)
+ "Return the directory where a package is installed, or nil if none.
+NAME and VERSION are both strings."
+ (let* ((subdir (concat name "-" version))
+ (dir-list (cons package-user-dir package-directory-list))
+ pkg-dir)
+ (while dir-list
+ (let ((subdir-full (expand-file-name subdir (car dir-list))))
+ (if (file-directory-p subdir-full)
+ (setq pkg-dir subdir-full
+ dir-list nil)
+ (setq dir-list (cdr dir-list)))))
+ pkg-dir))
+
+(defun package-activate-1 (package pkg-vec)
+ (let* ((name (symbol-name package))
+ (version-str (package-version-join (package-desc-vers pkg-vec)))
+ (pkg-dir (package--dir name version-str)))
+ (unless pkg-dir
+ (error "Internal error: unable to find directory for `%s-%s'"
+ name version-str))
+ ;; Add info node.
+ (when (file-exists-p (expand-file-name "dir" pkg-dir))
+ ;; FIXME: not the friendliest, but simple.
+ (require 'info)
+ (info-initialize)
+ (push pkg-dir Info-directory-list))
+ ;; Add to load path, add autoloads, and activate the package.
+ (push pkg-dir load-path)
+ (load (expand-file-name (concat name "-autoloads") pkg-dir) nil t)
+ (push package package-activated-list)
+ ;; Don't return nil.
+ t))
+
+(defun package-built-in-p (package &optional version)
+ "Return true if PACKAGE, of VERSION or newer, is built-in to Emacs."
+ (require 'finder-inf nil t) ; For `package--builtins'.
+ (let ((elt (assq package package--builtins)))
+ (and elt (version-list-<= version (package-desc-vers (cdr elt))))))
+
+;; This function goes ahead and activates a newer version of a package
+;; if an older one was already activated. This is not ideal; we'd at
+;; least need to check to see if the package has actually been loaded,
+;; and not merely activated.
+(defun package-activate (package version)
+ "Activate package PACKAGE, of version VERSION or newer.
+If PACKAGE has any dependencies, recursively activate them.
+Return nil if the package could not be activated."
+ (let ((pkg-vec (cdr (assq package package-alist)))
+ available-version found)
+ ;; Check if PACKAGE is available in `package-alist'.
+ (when pkg-vec
+ (setq available-version (package-desc-vers pkg-vec)
+ found (version-list-<= version available-version)))
+ (cond
+ ;; If no such package is found, maybe it's built-in.
+ ((null found)
+ (package-built-in-p package version))
+ ;; If the package is already activated, just return t.
+ ((memq package package-activated-list)
+ t)
+ ;; Otherwise, proceed with activation.
+ (t
+ (let ((fail (catch 'dep-failure
+ ;; Activate its dependencies recursively.
+ (dolist (req (package-desc-reqs pkg-vec))
+ (unless (package-activate (car req) (cadr req))
+ (throw 'dep-failure req))))))
+ (if fail
+ (warn "Unable to activate package `%s'.
+Required package `%s-%s' is unavailable"
+ package (car fail) (package-version-join (cadr fail)))
+ ;; If all goes well, activate the package itself.
+ (package-activate-1 package pkg-vec)))))))
+
+(defun package-mark-obsolete (package pkg-vec)
+ "Put package on the obsolete list, if not already there."
+ (let ((elt (assq package package-obsolete-alist)))
+ (if elt
+ ;; If this obsolete version does not exist in the list, update
+ ;; it the list.
+ (unless (assoc (package-desc-vers pkg-vec) (cdr elt))
+ (setcdr elt (cons (cons (package-desc-vers pkg-vec) pkg-vec)
+ (cdr elt))))
+ ;; Make a new association.
+ (push (cons package (list (cons (package-desc-vers pkg-vec)
+ pkg-vec)))
+ package-obsolete-alist))))
+
+(defun define-package (name-string version-string
+ &optional docstring requirements
+ &rest extra-properties)
+ "Define a new package.
+NAME-STRING is the name of the package, as a string.
+VERSION-STRING is the version of the package, as a list of
+integers of the form produced by `version-to-list'.
+DOCSTRING is a short description of the package, a string.
+REQUIREMENTS is a list of dependencies on other packages.
+Each requirement is of the form (OTHER-PACKAGE \"VERSION\").
+
+EXTRA-PROPERTIES is currently unused."
+ (let* ((name (intern name-string))
+ (version (version-to-list version-string))
+ (new-pkg-desc
+ (cons name
+ (vector version
+ (mapcar
+ (lambda (elt)
+ (list (car elt)
+ (version-to-list (car (cdr elt)))))
+ requirements)
+ docstring)))
+ (old-pkg (assq name package-alist)))
+ (cond
+ ;; If there's no old package, just add this to `package-alist'.
+ ((null old-pkg)
+ (push new-pkg-desc package-alist))
+ ((version-list-< (package-desc-vers (cdr old-pkg)) version)
+ ;; Remove the old package and declare it obsolete.
+ (package-mark-obsolete name (cdr old-pkg))
+ (setq package-alist (cons new-pkg-desc
+ (delq old-pkg package-alist))))
+ ;; You can have two packages with the same version, e.g. one in
+ ;; the system package directory and one in your private
+ ;; directory. We just let the first one win.
+ ((not (version-list-= (package-desc-vers (cdr old-pkg)) version))
+ ;; The package is born obsolete.
+ (package-mark-obsolete name (cdr new-pkg-desc))))))
+
+;; From Emacs 22.
+(defun package-autoload-ensure-default-file (file)
+ "Make sure that the autoload file FILE exists and if not create it."
+ (unless (file-exists-p file)
+ (write-region
+ (concat ";;; " (file-name-nondirectory file)
+ " --- automatically extracted autoloads\n"
+ ";;\n"
+ ";;; Code:\n\n"
+ " \n;; Local Variables:\n"
+ ";; version-control: never\n"
+ ";; no-byte-compile: t\n"
+ ";; no-update-autoloads: t\n"
+ ";; End:\n"
+ ";;; " (file-name-nondirectory file)
+ " ends here\n")
+ nil file))
+ file)
+
+(defun package-generate-autoloads (name pkg-dir)
+ (let* ((auto-name (concat name "-autoloads.el"))
+ (ignore-name (concat name "-pkg.el"))
+ (generated-autoload-file (expand-file-name auto-name pkg-dir))
+ (version-control 'never))
+ (require 'autoload)
+ (unless (fboundp 'autoload-ensure-default-file)
+ (package-autoload-ensure-default-file generated-autoload-file))
+ (update-directory-autoloads pkg-dir)))
+
+(defun package-untar-buffer ()
+ "Untar the current buffer.
+This uses `tar-untar-buffer' if it is available.
+Otherwise it uses an external `tar' program.
+`default-directory' should be set by the caller."
+ (require 'tar-mode)
+ (if (fboundp 'tar-untar-buffer)
+ (progn
+ ;; tar-mode messes with narrowing, so we just let it have the
+ ;; whole buffer to play with.
+ (delete-region (point-min) (point))
+ (tar-mode)
+ (tar-untar-buffer))
+ ;; FIXME: check the result.
+ (call-process-region (point) (point-max) "tar" nil '(nil nil) nil
+ "xf" "-")))
+
+(defun package-unpack (name version)
+ (let ((pkg-dir (expand-file-name (concat (symbol-name name) "-" version)
+ package-user-dir)))
+ (make-directory package-user-dir t)
+ ;; FIXME: should we delete PKG-DIR if it exists?
+ (let* ((default-directory (file-name-as-directory package-user-dir)))
+ (package-untar-buffer)
+ (package-generate-autoloads (symbol-name name) pkg-dir)
+ (let ((load-path (cons pkg-dir load-path)))
+ (byte-recompile-directory pkg-dir 0 t)))))
+
+(defun package--write-file-no-coding (file-name excl)
+ (let ((buffer-file-coding-system 'no-conversion))
+ (write-region (point-min) (point-max) file-name nil nil nil excl)))
+
+(defun package-unpack-single (file-name version desc requires)
+ "Install the contents of the current buffer as a package."
+ ;; Special case "package".
+ (if (string= file-name "package")
+ (package--write-file-no-coding
+ (expand-file-name (concat file-name ".el") package-user-dir)
+ nil)
+ (let* ((pkg-dir (expand-file-name (concat file-name "-" version)
+ package-user-dir))
+ (el-file (expand-file-name (concat file-name ".el") pkg-dir))
+ (pkg-file (expand-file-name (concat file-name "-pkg.el") pkg-dir)))
+ (make-directory pkg-dir t)
+ (package--write-file-no-coding el-file 'excl)
+ (let ((print-level nil)
+ (print-length nil))
+ (write-region
+ (concat
+ (prin1-to-string
+ (list 'define-package
+ file-name
+ version
+ desc
+ (list 'quote
+ ;; Turn version lists into string form.
+ (mapcar
+ (lambda (elt)
+ (list (car elt)
+ (package-version-join (cadr elt))))
+ requires))))
+ "\n")
+ nil
+ pkg-file
+ nil nil nil 'excl))
+ (package-generate-autoloads file-name pkg-dir)
+ (let ((load-path (cons pkg-dir load-path)))
+ (byte-recompile-directory pkg-dir 0 t)))))
+
+(defun package-handle-response ()
+ "Handle the response from the server.
+Parse the HTTP response and throw if an error occurred.
+The url package seems to require extra processing for this.
+This should be called in a `save-excursion', in the download buffer.
+It will move point to somewhere in the headers."
+ ;; We assume HTTP here.
+ (require 'url-http)
+ (let ((response (url-http-parse-response)))
+ (when (or (< response 200) (>= response 300))
+ (display-buffer (current-buffer))
+ (error "Error during download request:%s"
+ (buffer-substring-no-properties (point) (progn
+ (end-of-line)
+ (point)))))))
+
+(defun package-download-single (name version desc requires)
+ "Download and install a single-file package."
+ (let ((buffer (url-retrieve-synchronously
+ (concat (package-archive-url name)
+ (symbol-name name) "-" version ".el"))))
+ (with-current-buffer buffer
+ (package-handle-response)
+ (re-search-forward "^$" nil 'move)
+ (forward-char)
+ (delete-region (point-min) (point))
+ (package-unpack-single (symbol-name name) version desc requires)
+ (kill-buffer buffer))))
+
+(defun package-download-tar (name version)
+ "Download and install a tar package."
+ (let ((tar-buffer (url-retrieve-synchronously
+ (concat (package-archive-url name)
+ (symbol-name name) "-" version ".tar"))))
+ (with-current-buffer tar-buffer
+ (package-handle-response)
+ (re-search-forward "^$" nil 'move)
+ (forward-char)
+ (package-unpack name version)
+ (kill-buffer tar-buffer))))
+
+(defun package-installed-p (package &optional min-version)
+ "Return true if PACKAGE, of VERSION or newer, is installed.
+Built-in packages also qualify."
+ (let ((pkg-desc (assq package package-alist)))
+ (if pkg-desc
+ (version-list-<= min-version
+ (package-desc-vers (cdr pkg-desc)))
+ ;; Also check built-in packages.
+ (package-built-in-p package min-version))))
+
+(defun package-compute-transaction (package-list requirements)
+ "Return a list of packages to be installed, including PACKAGE-LIST.
+PACKAGE-LIST should be a list of package names (symbols).
+
+REQUIREMENTS should be a list of additional requirements; each
+element in this list should have the form (PACKAGE VERSION),
+where PACKAGE is a package name and VERSION is the required
+version of that package (as a list).
+
+This function recursively computes the requirements of the
+packages in REQUIREMENTS, and returns a list of all the packages
+that must be installed. Packages that are already installed are
+not included in this list."
+ (dolist (elt requirements)
+ (let* ((next-pkg (car elt))
+ (next-version (cadr elt)))
+ (unless (package-installed-p next-pkg next-version)
+ ;; A package is required, but not installed. It might also be
+ ;; blocked via `package-load-list'.
+ (let ((pkg-desc (assq next-pkg package-archive-contents))
+ hold)
+ (when (setq hold (assq next-pkg package-load-list))
+ (setq hold (cadr hold))
+ (cond ((eq hold nil)
+ (error "Required package '%s' is disabled"
+ (symbol-name next-pkg)))
+ ((null (stringp hold))
+ (error "Invalid element in `package-load-list'"))
+ ((version-list-< (version-to-list hold) next-version)
+ (error "Package `%s' held at version %s, \
+but version %s required"
+ (symbol-name next-pkg) hold
+ (package-version-join next-version)))))
+ (unless pkg-desc
+ (error "Package `%s-%s' is unavailable"
+ (symbol-name next-pkg)
+ (package-version-join next-version)))
+ (unless (version-list-<= next-version
+ (package-desc-vers (cdr pkg-desc)))
+ (error
+ "Need package `%s-%s', but only %s is available"
+ (symbol-name next-pkg) (package-version-join next-version)
+ (package-version-join (package-desc-vers (cdr pkg-desc)))))
+ ;; Only add to the transaction if we don't already have it.
+ (unless (memq next-pkg package-list)
+ (push next-pkg package-list))
+ (setq package-list
+ (package-compute-transaction package-list
+ (package-desc-reqs
+ (cdr pkg-desc))))))))
+ package-list)
+
+(defun package-read-from-string (str)
+ "Read a Lisp expression from STR.
+Signal an error if the entire string was not used."
+ (let* ((read-data (read-from-string str))
+ (more-left
+ (condition-case nil
+ ;; The call to `ignore' suppresses a compiler warning.
+ (progn (ignore (read-from-string
+ (substring str (cdr read-data))))
+ t)
+ (end-of-file nil))))
+ (if more-left
+ (error "Can't read whole string")
+ (car read-data))))
+
+(defun package--read-archive-file (file)
+ "Re-read archive file FILE, if it exists.
+Will return the data from the file, or nil if the file does not exist.
+Will throw an error if the archive version is too new."
+ (let ((filename (expand-file-name file package-user-dir)))
+ (when (file-exists-p filename)
+ (with-temp-buffer
+ (insert-file-contents-literally filename)
+ (let ((contents (read (current-buffer))))
+ (if (> (car contents) package-archive-version)
+ (error "Package archive version %d is higher than %d"
+ (car contents) package-archive-version))
+ (cdr contents))))))
+
+(defun package-read-all-archive-contents ()
+ "Re-read `archive-contents', if it exists.
+If successful, set `package-archive-contents'."
+ (setq package-archive-contents nil)
+ (dolist (archive package-archives)
+ (package-read-archive-contents (car archive))))
+
+(defun package-read-archive-contents (archive)
+ "Re-read archive contents for ARCHIVE.
+If successful, set the variable `package-archive-contents'.
+If the archive version is too new, signal an error."
+ ;; Version 1 of 'archive-contents' is identical to our internal
+ ;; representation.
+ (let* ((dir (concat "archives/" archive))
+ (contents-file (concat dir "/archive-contents"))
+ contents)
+ (when (setq contents (package--read-archive-file contents-file))
+ (dolist (package contents)
+ (package--add-to-archive-contents package archive)))))
+
+(defun package--add-to-archive-contents (package archive)
+ "Add the PACKAGE from the given ARCHIVE if necessary.
+Also, add the originating archive to the end of the package vector."
+ (let* ((name (car package))
+ (version (aref (cdr package) 0))
+ (entry (cons (car package)
+ (vconcat (cdr package) (vector archive))))
+ (existing-package (cdr (assq name package-archive-contents))))
+ (when (or (not existing-package)
+ (version-list-< (aref existing-package 0) version))
+ (add-to-list 'package-archive-contents entry))))
+
+(defun package-download-transaction (package-list)
+ "Download and install all the packages in PACKAGE-LIST.
+PACKAGE-LIST should be a list of package names (symbols).
+This function assumes that all package requirements in
+PACKAGE-LIST are satisfied, i.e. that PACKAGE-LIST is computed
+using `package-compute-transaction'."
+ (dolist (elt package-list)
+ (let* ((desc (cdr (assq elt package-archive-contents)))
+ ;; As an exception, if package is "held" in
+ ;; `package-load-list', download the held version.
+ (hold (cadr (assq elt package-load-list)))
+ (v-string (or (and (stringp hold) hold)
+ (package-version-join (package-desc-vers desc))))
+ (kind (package-desc-kind desc)))
+ (cond
+ ((eq kind 'tar)
+ (package-download-tar elt v-string))
+ ((eq kind 'single)
+ (package-download-single elt v-string
+ (package-desc-doc desc)
+ (package-desc-reqs desc)))
+ (t
+ (error "Unknown package kind: %s" (symbol-name kind)))))))
+
+;;;###autoload
+(defun package-install (name)
+ "Install the package named NAME.
+Interactively, prompt for the package name.
+The package is found on one of the archives in `package-archives'."
+ (interactive
+ (list (intern (completing-read "Install package: "
+ (mapcar (lambda (elt)
+ (cons (symbol-name (car elt))
+ nil))
+ package-archive-contents)
+ nil t))))
+ (let ((pkg-desc (assq name package-archive-contents)))
+ (unless pkg-desc
+ (error "Package `%s' is not available for installation"
+ (symbol-name name)))
+ (package-download-transaction
+ (package-compute-transaction (list name)
+ (package-desc-reqs (cdr pkg-desc)))))
+ ;; Try to activate it.
+ (package-initialize))
+
+(defun package-strip-rcs-id (v-str)
+ "Strip RCS version ID from the version string.
+If the result looks like a dotted numeric version, return it.
+Otherwise return nil."
+ (if v-str
+ (if (string-match "^[ \t]*[$]Revision:[ \t]\([0-9.]+\)[ \t]*[$]$" v-str)
+ (match-string 1 v-str)
+ (if (string-match "^[0-9.]*$" v-str)
+ v-str))))
+
+(defun package-buffer-info ()
+ "Return a vector describing the package in the current buffer.
+The vector has the form
+
+ [FILENAME REQUIRES DESCRIPTION VERSION COMMENTARY]
+
+FILENAME is the file name, a string, sans the \".el\" extension.
+REQUIRES is a requires list, or nil.
+DESCRIPTION is the package description, a string.
+VERSION is the version, a string.
+COMMENTARY is the commentary section, a string, or nil if none.
+
+If the buffer does not contain a conforming package, signal an
+error. If there is a package, narrow the buffer to the file's
+boundaries."
+ (goto-char (point-min))
+ (unless (re-search-forward "^;;; \\([^ ]*\\)\\.el --- \\(.*\\)$" nil t)
+ (error "Packages lacks a file header"))
+ (let ((file-name (match-string-no-properties 1))
+ (desc (match-string-no-properties 2))
+ (start (line-beginning-position)))
+ (unless (search-forward (concat ";;; " file-name ".el ends here"))
+ (error "Package lacks a terminating comment"))
+ ;; Try to include a trailing newline.
+ (forward-line)
+ (narrow-to-region start (point))
+ (require 'lisp-mnt)
+ ;; Use some headers we've invented to drive the process.
+ (let* ((requires-str (lm-header "package-requires"))
+ (requires (if requires-str
+ (package-read-from-string requires-str)))
+ ;; Prefer Package-Version; if defined, the package author
+ ;; probably wants us to use it. Otherwise try Version.
+ (pkg-version
+ (or (package-strip-rcs-id (lm-header "package-version"))
+ (package-strip-rcs-id (lm-header "version"))))
+ (commentary (lm-commentary)))
+ (unless pkg-version
+ (error
+ "Package lacks a \"Version\" or \"Package-Version\" header"))
+ ;; Turn string version numbers into list form.
+ (setq requires
+ (mapcar
+ (lambda (elt)
+ (list (car elt)
+ (version-to-list (car (cdr elt)))))
+ requires))
+ (vector file-name requires desc pkg-version commentary))))
+
+(defun package-tar-file-info (file)
+ "Find package information for a tar file.
+FILE is the name of the tar file to examine.
+The return result is a vector like `package-buffer-info'."
+ (unless (string-match "^\\(.+\\)-\\([0-9.]+\\)\\.tar$" file)
+ (error "Invalid package name `%s'" file))
+ (let* ((pkg-name (file-name-nondirectory (match-string-no-properties 1 file)))
+ (pkg-version (match-string-no-properties 2 file))
+ ;; Extract the package descriptor.
+ (pkg-def-contents (shell-command-to-string
+ ;; Requires GNU tar.
+ (concat "tar -xOf " file " "
+ pkg-name "-" pkg-version "/"
+ pkg-name "-pkg.el")))
+ (pkg-def-parsed (package-read-from-string pkg-def-contents)))
+ (unless (eq (car pkg-def-parsed) 'define-package)
+ (error "No `define-package' sexp is present in `%s-pkg.el'" pkg-name))
+ (let ((name-str (nth 1 pkg-def-parsed))
+ (version-string (nth 2 pkg-def-parsed))
+ (docstring (nth 3 pkg-def-parsed))
+ (requires (nth 4 pkg-def-parsed))
+ (readme (shell-command-to-string
+ ;; Requires GNU tar.
+ (concat "tar -xOf " file " "
+ pkg-name "-" pkg-version "/README"))))
+ (unless (equal pkg-version version-string)
+ (error "Package has inconsistent versions"))
+ (unless (equal pkg-name name-str)
+ (error "Package has inconsistent names"))
+ ;; Kind of a hack.
+ (if (string-match ": Not found in archive" readme)
+ (setq readme nil))
+ ;; Turn string version numbers into list form.
+ (if (eq (car requires) 'quote)
+ (setq requires (car (cdr requires))))
+ (setq requires
+ (mapcar (lambda (elt)
+ (list (car elt)
+ (version-to-list (cadr elt))))
+ requires))
+ (vector pkg-name requires docstring version-string readme))))
+
+;;;###autoload
+(defun package-install-from-buffer (pkg-info type)
+ "Install a package from the current buffer.
+When called interactively, the current buffer is assumed to be a
+single .el file that follows the packaging guidelines; see info
+node `(elisp)Packaging'.
+
+When called from Lisp, PKG-INFO is a vector describing the
+information, of the type returned by `package-buffer-info'; and
+TYPE is the package type (either `single' or `tar')."
+ (interactive (list (package-buffer-info) 'single))
+ (save-excursion
+ (save-restriction
+ (let* ((file-name (aref pkg-info 0))
+ (requires (aref pkg-info 1))
+ (desc (if (string= (aref pkg-info 2) "")
+ "No description available."
+ (aref pkg-info 2)))
+ (pkg-version (aref pkg-info 3)))
+ ;; Download and install the dependencies.
+ (let ((transaction (package-compute-transaction nil requires)))
+ (package-download-transaction transaction))
+ ;; Install the package itself.
+ (cond
+ ((eq type 'single)
+ (package-unpack-single file-name pkg-version desc requires))
+ ((eq type 'tar)
+ (package-unpack (intern file-name) pkg-version))
+ (t
+ (error "Unknown type: %s" (symbol-name type))))
+ ;; Try to activate it.
+ (package-initialize)))))
+
+;;;###autoload
+(defun package-install-file (file)
+ "Install a package from a file.
+The file can either be a tar file or an Emacs Lisp file."
+ (interactive "fPackage file name: ")
+ (with-temp-buffer
+ (insert-file-contents-literally file)
+ (cond
+ ((string-match "\\.el$" file)
+ (package-install-from-buffer (package-buffer-info) 'single))
+ ((string-match "\\.tar$" file)
+ (package-install-from-buffer (package-tar-file-info file) 'tar))
+ (t (error "Unrecognized extension `%s'" (file-name-extension file))))))
+
+(defun package-delete (name version)
+ (let ((dir (package--dir name version)))
+ (if (string-equal (file-name-directory dir)
+ (file-name-as-directory
+ (expand-file-name package-user-dir)))
+ (progn
+ (delete-directory dir t t)
+ (message "Package `%s-%s' deleted." name version))
+ ;; Don't delete "system" packages
+ (error "Package `%s-%s' is a system package, not deleting"
+ name version))))
+
+(defun package-archive-url (name)
+ "Return the archive containing the package NAME."
+ (let ((desc (cdr (assq (intern-soft name) package-archive-contents))))
+ (cdr (assoc (aref desc (- (length desc) 1)) package-archives))))
+
+(defun package--download-one-archive (archive file)
+ "Download an archive file FILE from ARCHIVE, and cache it locally."
+ (let* ((archive-name (car archive))
+ (archive-url (cdr archive))
+ (dir (expand-file-name "archives" package-user-dir))
+ (dir (expand-file-name archive-name dir))
+ (buffer (url-retrieve-synchronously (concat archive-url file))))
+ (with-current-buffer buffer
+ (package-handle-response)
+ (re-search-forward "^$" nil 'move)
+ (forward-char)
+ (delete-region (point-min) (point))
+ ;; Read the retrieved buffer to make sure it is valid (e.g. it
+ ;; may fetch a URL redirect page).
+ (when (listp (read buffer))
+ (make-directory dir t)
+ (setq buffer-file-name (expand-file-name file dir))
+ (let ((version-control 'never))
+ (save-buffer))))
+ (kill-buffer buffer)))
+
+(defun package-refresh-contents ()
+ "Download the ELPA archive description if needed.
+This informs Emacs about the latest versions of all packages, and
+makes them available for download."
+ (interactive)
+ (unless (file-exists-p package-user-dir)
+ (make-directory package-user-dir t))
+ (dolist (archive package-archives)
+ (condition-case nil
+ (package--download-one-archive archive "archive-contents")
+ (error (message "Failed to download `%s' archive."
+ (car archive)))))
+ (package-read-all-archive-contents))
+
+(defvar package--initialized nil)
+
+;;;###autoload
+(defun package-initialize (&optional no-activate)
+ "Load Emacs Lisp packages, and activate them.
+The variable `package-load-list' controls which packages to load.
+If optional arg NO-ACTIVATE is non-nil, don't activate packages."
+ (interactive)
+ (setq package-alist nil
+ package-obsolete-alist nil)
+ (package-load-all-descriptors)
+ (package-read-all-archive-contents)
+ (unless no-activate
+ (dolist (elt package-alist)
+ (package-activate (car elt) (package-desc-vers (cdr elt)))))
+ (setq package--initialized t))
+
+
+;;;; Package description buffer.
+
+;;;###autoload
+(defun describe-package (package)
+ "Display the full documentation of PACKAGE (a symbol)."
+ (interactive
+ (let* ((guess (function-called-at-point))
+ packages val)
+ (require 'finder-inf nil t)
+ ;; Load the package list if necessary (but don't activate them).
+ (unless package--initialized
+ (package-initialize t))
+ (setq packages (append (mapcar 'car package-alist)
+ (mapcar 'car package-archive-contents)
+ (mapcar 'car package--builtins)))
+ (unless (memq guess packages)
+ (setq guess nil))
+ (setq packages (mapcar 'symbol-name packages))
+ (setq val
+ (completing-read (if guess
+ (format "Describe package (default %s): "
+ guess)
+ "Describe package: ")
+ packages nil t nil nil guess))
+ (list (if (equal val "") guess (intern val)))))
+ (if (or (null package) (not (symbolp package)))
+ (message "No package specified")
+ (help-setup-xref (list #'describe-package package)
+ (called-interactively-p 'interactive))
+ (with-help-window (help-buffer)
+ (with-current-buffer standard-output
+ (describe-package-1 package)))))
+
+(defun describe-package-1 (package)
+ (require 'lisp-mnt)
+ (let ((package-name (symbol-name package))
+ (built-in (assq package package--builtins))
+ desc pkg-dir reqs version installable)
+ (prin1 package)
+ (princ " is ")
+ (cond
+ ;; Loaded packages are in `package-alist'.
+ ((setq desc (cdr (assq package package-alist)))
+ (setq version (package-version-join (package-desc-vers desc)))
+ (if (setq pkg-dir (package--dir package-name version))
+ (insert "an installed package.\n\n")
+ ;; This normally does not happen.
+ (insert "a deleted package.\n\n")))
+ ;; Available packages are in `package-archive-contents'.
+ ((setq desc (cdr (assq package package-archive-contents)))
+ (setq version (package-version-join (package-desc-vers desc))
+ installable t)
+ (if built-in
+ (insert "a built-in package.\n\n")
+ (insert "an uninstalled package.\n\n")))
+ (built-in
+ (setq desc (cdr built-in)
+ version (package-version-join (package-desc-vers desc)))
+ (insert "a built-in package.\n\n"))
+ (t
+ (insert "an orphan package.\n\n")))
+
+ (insert " " (propertize "Status" 'font-lock-face 'bold) ": ")
+ (cond (pkg-dir
+ (insert (propertize "Installed"
+ 'font-lock-face 'font-lock-comment-face))
+ (insert " in `")
+ ;; Todo: Add button for uninstalling.
+ (help-insert-xref-button (file-name-as-directory pkg-dir)
+ 'help-package-def pkg-dir)
+ (if built-in
+ (insert "',\n shadowing a "
+ (propertize "built-in package"
+ 'font-lock-face 'font-lock-builtin-face)
+ ".")
+ (insert "'.")))
+ (installable
+ (if built-in
+ (insert (propertize "Built-in." 'font-lock-face 'font-lock-builtin-face)
+ " Alternate version available -- ")
+ (insert "Available -- "))
+ (let ((button-text (if (display-graphic-p) "Install" "[Install]"))
+ (button-face (if (display-graphic-p)
+ '(:box (:line-width 2 :color "dark grey")
+ :background "light grey"
+ :foreground "black")
+ 'link)))
+ (insert-text-button button-text 'face button-face 'follow-link t
+ 'package-symbol package
+ 'action 'package-install-button-action)))
+ (built-in
+ (insert (propertize "Built-in." 'font-lock-face 'font-lock-builtin-face)))
+ (t (insert "Deleted.")))
+ (insert "\n")
+ (and version (> (length version) 0)
+ (insert " "
+ (propertize "Version" 'font-lock-face 'bold) ": " version "\n"))
+
+ (setq reqs (if desc (package-desc-reqs desc)))
+ (when reqs
+ (insert " " (propertize "Requires" 'font-lock-face 'bold) ": ")
+ (let ((first t)
+ name vers text)
+ (dolist (req reqs)
+ (setq name (car req)
+ vers (cadr req)
+ text (format "%s-%s" (symbol-name name)
+ (package-version-join vers)))
+ (cond (first (setq first nil))
+ ((>= (+ 2 (current-column) (length text))
+ (window-width))
+ (insert ",\n "))
+ (t (insert ", ")))
+ (help-insert-xref-button text 'help-package name))
+ (insert "\n")))
+ (insert " " (propertize "Summary" 'font-lock-face 'bold)
+ ": " (if desc (package-desc-doc desc)) "\n\n")
+
+ (if built-in
+ ;; For built-in packages, insert the commentary.
+ (let ((fn (locate-file (concat package-name ".el") load-path
+ load-file-rep-suffixes))
+ (opoint (point)))
+ (insert (or (lm-commentary fn) ""))
+ (save-excursion
+ (goto-char opoint)
+ (when (re-search-forward "^;;; Commentary:\n" nil t)
+ (replace-match ""))
+ (while (re-search-forward "^\\(;+ ?\\)" nil t)
+ (replace-match ""))))
+ (let ((readme (expand-file-name (concat package-name "-readme.txt")
+ package-user-dir)))
+ ;; For elpa packages, try downloading the commentary. If that
+ ;; fails, try an existing readme file in `package-user-dir'.
+ (cond ((let ((buffer (ignore-errors
+ (url-retrieve-synchronously
+ (concat (package-archive-url package)
+ package-name "-readme.txt"))))
+ response)
+ (when buffer
+ (with-current-buffer buffer
+ (setq response (url-http-parse-response))
+ (if (or (< response 200) (>= response 300))
+ (setq response nil)
+ (setq buffer-file-name
+ (expand-file-name readme package-user-dir))
+ (delete-region (point-min) (1+ url-http-end-of-headers))
+ (save-buffer)))
+ (when response
+ (insert-buffer-substring buffer)
+ (kill-buffer buffer)
+ t))))
+ ((file-readable-p readme)
+ (insert-file-contents readme)
+ (goto-char (point-max))))))))
+
+(defun package-install-button-action (button)
+ (let ((package (button-get button 'package-symbol)))
+ (when (y-or-n-p (format "Install package `%s'? " package))
+ (package-install package)
+ (revert-buffer nil t)
+ (goto-char (point-min)))))
+
+
+;;;; Package menu mode.
+
+(defvar package-menu-mode-map
+ (let ((map (make-keymap))
+ (menu-map (make-sparse-keymap "Package")))
+ (set-keymap-parent map button-buffer-map)
+ (define-key map "\C-m" 'package-menu-describe-package)
+ (define-key map "q" 'quit-window)
+ (define-key map "n" 'next-line)
+ (define-key map "p" 'previous-line)
+ (define-key map "u" 'package-menu-mark-unmark)
+ (define-key map "\177" 'package-menu-backup-unmark)
+ (define-key map "d" 'package-menu-mark-delete)
+ (define-key map "i" 'package-menu-mark-install)
+ (define-key map "g" 'revert-buffer)
+ (define-key map "r" 'package-menu-refresh)
+ (define-key map "~" 'package-menu-mark-obsolete-for-deletion)
+ (define-key map "x" 'package-menu-execute)
+ (define-key map "h" 'package-menu-quick-help)
+ (define-key map "?" 'package-menu-describe-package)
+ (define-key map [follow-link] 'mouse-face)
+ (define-key map [mouse-2] 'mouse-select-window)
+ (define-key map [menu-bar package-menu] (cons "Package" menu-map))
+ (define-key menu-map [mq]
+ '(menu-item "Quit" quit-window
+ :help "Quit package selection"))
+ (define-key menu-map [s1] '("--"))
+ (define-key menu-map [mn]
+ '(menu-item "Next" next-line
+ :help "Next Line"))
+ (define-key menu-map [mp]
+ '(menu-item "Previous" previous-line
+ :help "Previous Line"))
+ (define-key menu-map [s2] '("--"))
+ (define-key menu-map [mu]
+ '(menu-item "Unmark" package-menu-mark-unmark
+ :help "Clear any marks on a package and move to the next line"))
+ (define-key menu-map [munm]
+ '(menu-item "Unmark backwards" package-menu-backup-unmark
+ :help "Back up one line and clear any marks on that package"))
+ (define-key menu-map [md]
+ '(menu-item "Mark for deletion" package-menu-mark-delete
+ :help "Mark a package for deletion and move to the next line"))
+ (define-key menu-map [mi]
+ '(menu-item "Mark for install" package-menu-mark-install
+ :help "Mark a package for installation and move to the next line"))
+ (define-key menu-map [s3] '("--"))
+ (define-key menu-map [mg]
+ '(menu-item "Update package list" revert-buffer
+ :help "Update the list of packages"))
+ (define-key menu-map [mr]
+ '(menu-item "Refresh package list" package-menu-refresh
+ :help "Download the ELPA archive"))
+ (define-key menu-map [s4] '("--"))
+ (define-key menu-map [mt]
+ '(menu-item "Mark obsolete packages" package-menu-mark-obsolete-for-deletion
+ :help "Mark all obsolete packages for deletion"))
+ (define-key menu-map [mx]
+ '(menu-item "Execute actions" package-menu-execute
+ :help "Perform all the marked actions"))
+ (define-key menu-map [s5] '("--"))
+ (define-key menu-map [mh]
+ '(menu-item "Help" package-menu-quick-help
+ :help "Show short key binding help for package-menu-mode"))
+ (define-key menu-map [mc]
+ '(menu-item "View Commentary" package-menu-view-commentary
+ :help "Display information about this package"))
+ map)
+ "Local keymap for `package-menu-mode' buffers.")
+
+(defvar package-menu-sort-button-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [header-line mouse-1] 'package-menu-sort-by-column)
+ (define-key map [header-line mouse-2] 'package-menu-sort-by-column)
+ (define-key map [follow-link] 'mouse-face)
+ map)
+ "Local keymap for package menu sort buttons.")
+
+(put 'package-menu-mode 'mode-class 'special)
+
+(defun package-menu-mode ()
+ "Major mode for browsing a list of packages.
+Letters do not insert themselves; instead, they are commands.
+\\<package-menu-mode-map>
+\\{package-menu-mode-map}"
+ (kill-all-local-variables)
+ (use-local-map package-menu-mode-map)
+ (setq major-mode 'package-menu-mode)
+ (setq mode-name "Package Menu")
+ (setq truncate-lines t)
+ (setq buffer-read-only t)
+ (set (make-local-variable 'revert-buffer-function) 'package-menu-revert)
+ (setq header-line-format
+ (mapconcat
+ (lambda (pair)
+ (let ((column (car pair))
+ (name (cdr pair)))
+ (concat
+ ;; Insert a space that aligns the button properly.
+ (propertize " " 'display (list 'space :align-to column)
+ 'face 'fixed-pitch)
+ ;; Set up the column button.
+ (propertize name
+ 'column-name name
+ 'help-echo "mouse-1: sort by column"
+ 'mouse-face 'highlight
+ 'keymap package-menu-sort-button-map))))
+ ;; We take a trick from buff-menu and have a dummy leading
+ ;; space to align the header line with the beginning of the
+ ;; text. This doesn't really work properly on Emacs 21, but
+ ;; it is close enough.
+ '((0 . "")
+ (2 . "Package")
+ (20 . "Version")
+ (32 . "Status")
+ (43 . "Description"))
+ ""))
+ (run-mode-hooks 'package-menu-mode-hook))
+
+(defun package-menu-refresh ()
+ "Download the Emacs Lisp package archive.
+This fetches the contents of each archive specified in
+`package-archives', and then refreshes the package menu."
+ (interactive)
+ (unless (eq major-mode 'package-menu-mode)
+ (error "The current buffer is not a Package Menu"))
+ (package-refresh-contents)
+ (package--generate-package-list))
+
+(defun package-menu-revert (&optional arg noconfirm)
+ "Update the list of packages.
+This function is the `revert-buffer-function' for Package Menu
+buffers. The arguments are ignored."
+ (interactive)
+ (unless (eq major-mode 'package-menu-mode)
+ (error "The current buffer is not a Package Menu"))
+ (package--generate-package-list))
+
+(defun package-menu-describe-package ()
+ "Describe the package in the current line."
+ (interactive)
+ (let ((name (package-menu-get-package)))
+ (if name
+ (describe-package (intern name))
+ (message "No package on this line"))))
+
+(defun package-menu-mark-internal (what)
+ (unless (eobp)
+ (let ((buffer-read-only nil))
+ (beginning-of-line)
+ (delete-char 1)
+ (insert what)
+ (forward-line))))
+
+;; fixme numeric argument
+(defun package-menu-mark-delete (num)
+ "Mark a package for deletion and move to the next line."
+ (interactive "p")
+ (if (string-equal (package-menu-get-status) "installed")
+ (package-menu-mark-internal "D")
+ (forward-line)))
+
+(defun package-menu-mark-install (num)
+ "Mark a package for installation and move to the next line."
+ (interactive "p")
+ (if (string-equal (package-menu-get-status) "available")
+ (package-menu-mark-internal "I")
+ (forward-line)))
+
+(defun package-menu-mark-unmark (num)
+ "Clear any marks on a package and move to the next line."
+ (interactive "p")
+ (package-menu-mark-internal " "))
+
+(defun package-menu-backup-unmark ()
+ "Back up one line and clear any marks on that package."
+ (interactive)
+ (forward-line -1)
+ (package-menu-mark-internal " ")
+ (forward-line -1))
+
+(defun package-menu-mark-obsolete-for-deletion ()
+ "Mark all obsolete packages for deletion."
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (forward-line 2)
+ (while (not (eobp))
+ (if (looking-at ".*\\s obsolete\\s ")
+ (package-menu-mark-internal "D")
+ (forward-line 1)))))
+
+(defun package-menu-quick-help ()
+ "Show short key binding help for package-menu-mode."
+ (interactive)
+ (message "n-ext, i-nstall, d-elete, u-nmark, x-ecute, r-efresh, h-elp"))
+
+(define-obsolete-function-alias
+ 'package-menu-view-commentary 'package-menu-describe-package "24.1")
+
+;; Return the name of the package on the current line.
+(defun package-menu-get-package ()
+ (save-excursion
+ (beginning-of-line)
+ (if (looking-at ". \\([^ \t]*\\)")
+ (match-string-no-properties 1))))
+
+;; Return the version of the package on the current line.
+(defun package-menu-get-version ()
+ (save-excursion
+ (beginning-of-line)
+ (if (looking-at ". [^ \t]*[ \t]*\\([0-9.]*\\)")
+ (match-string 1))))
+
+(defun package-menu-get-status ()
+ (save-excursion
+ (if (looking-at ". [^ \t]*[ \t]*[^ \t]*[ \t]*\\([^ \t]*\\)")
+ (match-string 1)
+ "")))
+
+(defun package-menu-execute ()
+ "Perform marked Package Menu actions.
+Packages marked for installation are downloaded and installed;
+packages marked for deletion are removed."
+ (interactive)
+ (let (install-list delete-list cmd)
+ (save-excursion
+ (goto-char (point-min))
+ (while (not (eobp))
+ (setq cmd (char-after))
+ (cond
+ ((eq cmd ?\s) t)
+ ((eq cmd ?D)
+ (push (cons (package-menu-get-package)
+ (package-menu-get-version))
+ delete-list))
+ ((eq cmd ?I)
+ (push (package-menu-get-package) install-list)))
+ (forward-line)))
+ ;; Delete packages, prompting if necessary.
+ (when delete-list
+ (if (yes-or-no-p
+ (if (= (length delete-list) 1)
+ (format "Delete package `%s-%s'? "
+ (caar delete-list)
+ (cdr (car delete-list)))
+ (format "Delete these %d packages (%s)? "
+ (length delete-list)
+ (mapconcat (lambda (elt)
+ (concat (car elt) "-" (cdr elt)))
+ delete-list
+ ", "))))
+ (dolist (elt delete-list)
+ (condition-case err
+ (package-delete (car elt) (cdr elt))
+ (error (message (cadr err)))))
+ (error "Aborted")))
+ (when install-list
+ (if (yes-or-no-p
+ (if (= (length install-list) 1)
+ (format "Install package `%s'? " (car install-list))
+ (format "Install these %d packages (%s)? "
+ (length install-list)
+ (mapconcat 'identity install-list ", "))))
+ (dolist (elt install-list)
+ (package-install (intern elt)))))
+ ;; If we deleted anything, regenerate `package-alist'. This is done
+ ;; automatically if we installed a package.
+ (and delete-list (null install-list)
+ (package-initialize))
+ (if (or delete-list install-list)
+ (package-menu-revert)
+ (message "No operations specified."))))
+
+(defun package-print-package (package version key desc)
+ (let ((face
+ (cond ((string= key "built-in") 'font-lock-builtin-face)
+ ((string= key "available") 'default)
+ ((string= key "held") 'font-lock-constant-face)
+ ((string= key "disabled") 'font-lock-warning-face)
+ ((string= key "installed") 'font-lock-comment-face)
+ (t ; obsolete, but also the default.
+ 'font-lock-warning-face))))
+ (insert (propertize " " 'font-lock-face face))
+ (insert-text-button (symbol-name package)
+ 'face 'link
+ 'follow-link t
+ 'package-symbol package
+ 'action (lambda (button)
+ (describe-package
+ (button-get button 'package-symbol))))
+ (indent-to 20 1)
+ (insert (propertize (package-version-join version) 'font-lock-face face))
+ (indent-to 32 1)
+ (insert (propertize key 'font-lock-face face))
+ ;; FIXME: this 'when' is bogus...
+ (when desc
+ (indent-to 43 1)
+ (let ((opoint (point)))
+ (insert (propertize desc 'font-lock-face face))
+ (upcase-region opoint (min (point) (1+ opoint)))))
+ (insert "\n")))
+
+(defun package-list-maybe-add (package version status description result)
+ (unless (assoc (cons package version) result)
+ (push (list (cons package version) status description) result))
+ result)
+
+(defvar package-menu-package-list nil
+ "List of packages to display in the Package Menu buffer.
+A value of nil means to display all packages.")
+
+(defvar package-menu-sort-key nil
+ "Sort key for the current Package Menu buffer.")
+
+(defun package--generate-package-list ()
+ "Populate the current Package Menu buffer."
+ (let ((inhibit-read-only t)
+ info-list name desc hold builtin)
+ (erase-buffer)
+ ;; List installed packages
+ (dolist (elt package-alist)
+ (setq name (car elt))
+ (when (or (null package-menu-package-list)
+ (memq name package-menu-package-list))
+ (setq desc (cdr elt)
+ hold (cadr (assq name package-load-list)))
+ (setq info-list
+ (package-list-maybe-add
+ name (package-desc-vers desc)
+ ;; FIXME: it turns out to be tricky to see if this
+ ;; package is presently activated.
+ (if (stringp hold) "held" "installed")
+ (package-desc-doc desc)
+ info-list))))
+
+ ;; List built-in packages
+ (dolist (elt package--builtins)
+ (setq name (car elt))
+ (when (and (not (eq name 'emacs)) ; Hide the `emacs' package.
+ (or (null package-menu-package-list)
+ (memq name package-menu-package-list)))
+ (setq desc (cdr elt))
+ (setq info-list
+ (package-list-maybe-add
+ name (package-desc-vers desc)
+ "built-in"
+ (package-desc-doc desc)
+ info-list))))
+
+ ;; List available and disabled packages
+ (dolist (elt package-archive-contents)
+ (setq name (car elt)
+ desc (cdr elt)
+ hold (assq name package-load-list))
+ (when (or (null package-menu-package-list)
+ (memq name package-menu-package-list))
+ (setq info-list
+ (package-list-maybe-add name
+ (package-desc-vers desc)
+ (if (and hold (null (cadr hold)))
+ "disabled"
+ "available")
+ (package-desc-doc (cdr elt))
+ info-list))))
+ ;; List obsolete packages
+ (mapc (lambda (elt)
+ (mapc (lambda (inner-elt)
+ (setq info-list
+ (package-list-maybe-add (car elt)
+ (package-desc-vers
+ (cdr inner-elt))
+ "obsolete"
+ (package-desc-doc
+ (cdr inner-elt))
+ info-list)))
+ (cdr elt)))
+ package-obsolete-alist)
+
+ (setq info-list
+ (sort info-list
+ (cond ((string= package-menu-sort-key "Package")
+ 'package-menu--name-predicate)
+ ((string= package-menu-sort-key "Version")
+ 'package-menu--version-predicate)
+ ((string= package-menu-sort-key "Description")
+ 'package-menu--description-predicate)
+ (t ; By default, sort by package status
+ 'package-menu--status-predicate))))
+
+ (dolist (elt info-list)
+ (package-print-package (car (car elt))
+ (cdr (car elt))
+ (car (cdr elt))
+ (car (cdr (cdr elt)))))
+ (goto-char (point-min))
+ (set-buffer-modified-p nil)
+ (current-buffer)))
+
+(defun package-menu--version-predicate (left right)
+ (let ((vleft (or (cdr (car left)) '(0)))
+ (vright (or (cdr (car right)) '(0))))
+ (if (version-list-= vleft vright)
+ (package-menu--name-predicate left right)
+ (version-list-< vleft vright))))
+
+(defun package-menu--status-predicate (left right)
+ (let ((sleft (cadr left))
+ (sright (cadr right)))
+ (cond ((string= sleft sright)
+ (package-menu--name-predicate left right))
+ ((string= sleft "available") t)
+ ((string= sright "available") nil)
+ ((string= sleft "installed") t)
+ ((string= sright "installed") nil)
+ ((string= sleft "held") t)
+ ((string= sright "held") nil)
+ ((string= sleft "built-in") t)
+ ((string= sright "built-in") nil)
+ ((string= sleft "obsolete") t)
+ ((string= sright "obsolete") nil)
+ (t (string< sleft sright)))))
+
+(defun package-menu--description-predicate (left right)
+ (let ((sleft (car (cddr left)))
+ (sright (car (cddr right))))
+ (if (string= sleft sright)
+ (package-menu--name-predicate left right)
+ (string< sleft sright))))
+
+(defun package-menu--name-predicate (left right)
+ (string< (symbol-name (caar left))
+ (symbol-name (caar right))))
+
+(defun package-menu-sort-by-column (&optional e)
+ "Sort the package menu by the column of the mouse click E."
+ (interactive "e")
+ (let* ((pos (event-start e))
+ (obj (posn-object pos))
+ (col (if obj
+ (get-text-property (cdr obj) 'column-name (car obj))
+ (get-text-property (posn-point pos) 'column-name)))
+ (buf (window-buffer (posn-window (event-start e)))))
+ (with-current-buffer buf
+ (when (eq major-mode 'package-menu-mode)
+ (setq package-menu-sort-key col)
+ (package--generate-package-list)))))
+
+(defun package--list-packages (&optional packages)
+ "Generate and pop to the *Packages* buffer.
+Optional PACKAGES is a list of names of packages (symbols) to
+list; the default is to display everything in `package-alist'."
+ (require 'finder-inf nil t)
+ (with-current-buffer (get-buffer-create "*Packages*")
+ (package-menu-mode)
+ (set (make-local-variable 'package-menu-package-list) packages)
+ (set (make-local-variable 'package-menu-sort-key) nil)
+ (package--generate-package-list)
+ ;; It's okay to use pop-to-buffer here. The package menu buffer
+ ;; has keybindings, and the user just typed `M-x list-packages',
+ ;; suggesting that they might want to use them.
+ (pop-to-buffer (current-buffer))))
+
+;;;###autoload
+(defun list-packages ()
+ "Display a list of packages.
+Fetches the updated list of packages before displaying.
+The list is displayed in a buffer named `*Packages*'."
+ (interactive)
+ ;; Initialize the package system if necessary.
+ (unless package--initialized
+ (package-initialize t))
+ (package-refresh-contents)
+ (package--list-packages))
+
+;;;###autoload
+(defalias 'package-list-packages 'list-packages)
+
+(defun package-list-packages-no-fetch ()
+ "Display a list of packages.
+Does not fetch the updated list of packages before displaying.
+The list is displayed in a buffer named `*Packages*'."
+ (interactive)
+ (package--list-packages))
+
+(provide 'package)
+
+;;; package.el ends here
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
new file mode 100644
index 00000000000..5ff26b3dbc0
--- /dev/null
+++ b/lisp/emacs-lisp/pcase.el
@@ -0,0 +1,553 @@
+;;; pcase.el --- ML-style pattern-matching macro for Elisp
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Keywords:
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; ML-style pattern matching.
+;; The entry points are autoloaded.
+
+;; Todo:
+
+;; - provide ways to extend the set of primitives, with some kind of
+;; define-pcase-matcher. We could easily make it so that (guard BOOLEXP)
+;; could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)).
+;; But better would be if we could define new ways to match by having the
+;; extension provide its own `pcase--split-<foo>' thingy.
+;; - ideally we'd want (pcase s ((re RE1) E1) ((re RE2) E2)) to be able to
+;; generate a lex-style DFA to decide whether to run E1 or E2.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+;; Macro-expansion of pcase is reasonably fast, so it's not a problem
+;; when byte-compiling a file, but when interpreting the code, if the pcase
+;; is in a loop, the repeated macro-expansion becomes terribly costly, so we
+;; memoize previous macro expansions to try and avoid recomputing them
+;; over and over again.
+(defconst pcase-memoize (make-hash-table :weakness t :test 'equal))
+
+(defconst pcase--dontcare-upats '(t _ dontcare))
+
+;;;###autoload
+(defmacro pcase (exp &rest cases)
+ "Perform ML-style pattern matching on EXP.
+CASES is a list of elements of the form (UPATTERN CODE...).
+
+UPatterns can take the following forms:
+ _ matches anything.
+ SYMBOL matches anything and binds it to SYMBOL.
+ (or UPAT...) matches if any of the patterns matches.
+ (and UPAT...) matches if all the patterns match.
+ `QPAT matches if the QPattern QPAT matches.
+ (pred PRED) matches if PRED applied to the object returns non-nil.
+ (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil.
+
+QPatterns can take the following forms:
+ (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr.
+ ,UPAT matches if the UPattern UPAT matches.
+ STRING matches if the object is `equal' to STRING.
+ ATOM matches if the object is `eq' to ATOM.
+QPatterns for vectors are not implemented yet.
+
+PRED can take the form
+ FUNCTION in which case it gets called with one argument.
+ (FUN ARG1 .. ARGN) in which case it gets called with N+1 arguments.
+A PRED of the form FUNCTION is equivalent to one of the form (FUNCTION).
+PRED patterns can refer to variables bound earlier in the pattern.
+E.g. you can match pairs where the cdr is larger than the car with a pattern
+like `(,a . ,(pred (< a))) or, with more checks:
+`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))"
+ (declare (indent 1) (debug case)) ;FIXME: edebug `guard' and vars.
+ (or (gethash (cons exp cases) pcase-memoize)
+ (puthash (cons exp cases)
+ (pcase--expand exp cases)
+ pcase-memoize)))
+
+;;;###autoload
+(defmacro pcase-let* (bindings &rest body)
+ "Like `let*' but where you can use `pcase' patterns for bindings.
+BODY should be an expression, and BINDINGS should be a list of bindings
+of the form (UPAT EXP)."
+ (declare (indent 1) (debug let))
+ (cond
+ ((null bindings) (if (> (length body) 1) `(progn ,@body) (car body)))
+ ((pcase--trivial-upat-p (caar bindings))
+ `(let (,(car bindings)) (pcase-let* ,(cdr bindings) ,@body)))
+ (t
+ `(pcase ,(cadr (car bindings))
+ (,(caar bindings) (pcase-let* ,(cdr bindings) ,@body))
+ ;; We can either signal an error here, or just use `dontcare' which
+ ;; generates more efficient code. In practice, if we use `dontcare' we
+ ;; will still often get an error and the few cases where we don't do not
+ ;; matter that much, so it's a better choice.
+ (dontcare nil)))))
+
+;;;###autoload
+(defmacro pcase-let (bindings &rest body)
+ "Like `let' but where you can use `pcase' patterns for bindings.
+BODY should be a list of expressions, and BINDINGS should be a list of bindings
+of the form (UPAT EXP)."
+ (declare (indent 1) (debug let))
+ (if (null (cdr bindings))
+ `(pcase-let* ,bindings ,@body)
+ (let ((matches '()))
+ (dolist (binding (prog1 bindings (setq bindings nil)))
+ (cond
+ ((memq (car binding) pcase--dontcare-upats)
+ (push (cons (make-symbol "_") (cdr binding)) bindings))
+ ((pcase--trivial-upat-p (car binding)) (push binding bindings))
+ (t
+ (let ((tmpvar (make-symbol (format "x%d" (length bindings)))))
+ (push (cons tmpvar (cdr binding)) bindings)
+ (push (list (car binding) tmpvar) matches)))))
+ `(let ,(nreverse bindings) (pcase-let* ,matches ,@body)))))
+
+(defmacro pcase-dolist (spec &rest body)
+ (if (pcase--trivial-upat-p (car spec))
+ `(dolist ,spec ,@body)
+ (let ((tmpvar (make-symbol "x")))
+ `(dolist (,tmpvar ,@(cdr spec))
+ (pcase-let* ((,(car spec) ,tmpvar))
+ ,@body)))))
+
+
+(defun pcase--trivial-upat-p (upat)
+ (and (symbolp upat) (not (memq upat pcase--dontcare-upats))))
+
+(defun pcase--expand (exp cases)
+ (let* ((defs (if (symbolp exp) '()
+ (let ((sym (make-symbol "x")))
+ (prog1 `((,sym ,exp)) (setq exp sym)))))
+ (seen '())
+ (codegen
+ (lambda (code vars)
+ (let ((prev (assq code seen)))
+ (if (not prev)
+ (let ((res (pcase-codegen code vars)))
+ (push (list code vars res) seen)
+ res)
+ ;; Since we use a tree-based pattern matching
+ ;; technique, the leaves (the places that contain the
+ ;; code to run once a pattern is matched) can get
+ ;; copied a very large number of times, so to avoid
+ ;; code explosion, we need to keep track of how many
+ ;; times we've used each leaf and move it
+ ;; to a separate function if that number is too high.
+ ;;
+ ;; We've already used this branch. So it is shared.
+ (destructuring-bind (code prevvars res) prev
+ (unless (symbolp res)
+ ;; This is the first repeat, so we have to move
+ ;; the branch to a separate function.
+ (let ((bsym
+ (make-symbol (format "pcase-%d" (length defs)))))
+ (push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code)) defs)
+ (setcar res 'funcall)
+ (setcdr res (cons bsym (mapcar #'cdr prevvars)))
+ (setcar (cddr prev) bsym)
+ (setq res bsym)))
+ (setq vars (copy-sequence vars))
+ (let ((args (mapcar (lambda (pa)
+ (let ((v (assq (car pa) vars)))
+ (setq vars (delq v vars))
+ (cdr v)))
+ prevvars)))
+ (when vars ;New additional vars.
+ (error "The vars %s are only bound in some paths"
+ (mapcar #'car vars)))
+ `(funcall ,res ,@args)))))))
+ (main
+ (pcase--u
+ (mapcar (lambda (case)
+ `((match ,exp . ,(car case))
+ ,(apply-partially
+ (if (pcase--small-branch-p (cdr case))
+ ;; Don't bother sharing multiple
+ ;; occurrences of this leaf since it's small.
+ #'pcase-codegen codegen)
+ (cdr case))))
+ cases))))
+ (if (null defs) main
+ `(let ,defs ,main))))
+
+(defun pcase-codegen (code vars)
+ `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars)
+ ,@code))
+
+(defun pcase--small-branch-p (code)
+ (and (= 1 (length code))
+ (or (not (consp (car code)))
+ (let ((small t))
+ (dolist (e (car code))
+ (if (consp e) (setq small nil)))
+ small))))
+
+;; Try to use `cond' rather than a sequence of `if's, so as to reduce
+;; the depth of the generated tree.
+(defun pcase--if (test then else)
+ (cond
+ ((eq else :pcase--dontcare) then)
+ ((eq (car-safe else) 'if)
+ (if (equal test (nth 1 else))
+ ;; Doing a test a second time: get rid of the redundancy.
+ ;; FIXME: ideally, this should never happen because the pcase--split-*
+ ;; funs should have eliminated such things, but pcase--split-member
+ ;; is imprecise, so in practice it can happen occasionally.
+ `(if ,test ,then ,@(nthcdr 3 else))
+ `(cond (,test ,then)
+ (,(nth 1 else) ,(nth 2 else))
+ (t ,@(nthcdr 3 else)))))
+ ((eq (car-safe else) 'cond)
+ `(cond (,test ,then)
+ ;; Doing a test a second time: get rid of the redundancy, as above.
+ ,@(remove (assoc test else) (cdr else))))
+ (t `(if ,test ,then ,else))))
+
+(defun pcase--upat (qpattern)
+ (cond
+ ((eq (car-safe qpattern) '\,) (cadr qpattern))
+ (t (list '\` qpattern))))
+
+;; Note about MATCH:
+;; When we have patterns like `(PAT1 . PAT2), after performing the `consp'
+;; check, we want to turn all the similar patterns into ones of the form
+;; (and (match car PAT1) (match cdr PAT2)), so you naturally need conjunction.
+;; Earlier code hence used branches of the form (MATCHES . CODE) where
+;; MATCHES was a list (implicitly a conjunction) of (SYM . PAT).
+;; But if we have a pattern of the form (or `(PAT1 . PAT2) PAT3), there is
+;; no easy way to eliminate the `consp' check in such a representation.
+;; So we replaced the MATCHES by the MATCH below which can be made up
+;; of conjunctions and disjunctions, so if we know `foo' is a cons, we can
+;; turn (match foo . (or `(PAT1 . PAT2) PAT3)) into
+;; (or (and (match car . `PAT1) (match cdr . `PAT2)) (match foo . PAT3)).
+;; The downside is that we now have `or' and `and' both in MATCH and
+;; in PAT, so there are different equivalent representations and we
+;; need to handle them all. We do not try to systematically
+;; canonicalize them to one form over another, but we do occasionally
+;; turn one into the other.
+
+(defun pcase--u (branches)
+ "Expand matcher for rules BRANCHES.
+Each BRANCH has the form (MATCH CODE . VARS) where
+CODE is the code generator for that branch.
+VARS is the set of vars already bound by earlier matches.
+MATCH is the pattern that needs to be matched, of the form:
+ (match VAR . UPAT)
+ (and MATCH ...)
+ (or MATCH ...)"
+ (when (setq branches (delq nil branches))
+ (destructuring-bind (match code &rest vars) (car branches)
+ (pcase--u1 (list match) code vars (cdr branches)))))
+
+(defun pcase--and (match matches)
+ (if matches `(and ,match ,@matches) match))
+
+(defun pcase--split-match (sym splitter match)
+ (case (car match)
+ ((match)
+ (if (not (eq sym (cadr match)))
+ (cons match match)
+ (let ((pat (cddr match)))
+ (cond
+ ;; Hoist `or' and `and' patterns to `or' and `and' matches.
+ ((memq (car-safe pat) '(or and))
+ (pcase--split-match sym splitter
+ (cons (car pat)
+ (mapcar (lambda (alt)
+ `(match ,sym . ,alt))
+ (cdr pat)))))
+ (t (let ((res (funcall splitter (cddr match))))
+ (cons (or (car res) match) (or (cdr res) match))))))))
+ ((or and)
+ (let ((then-alts '())
+ (else-alts '())
+ (neutral-elem (if (eq 'or (car match))
+ :pcase--fail :pcase--succeed))
+ (zero-elem (if (eq 'or (car match)) :pcase--succeed :pcase--fail)))
+ (dolist (alt (cdr match))
+ (let ((split (pcase--split-match sym splitter alt)))
+ (unless (eq (car split) neutral-elem)
+ (push (car split) then-alts))
+ (unless (eq (cdr split) neutral-elem)
+ (push (cdr split) else-alts))))
+ (cons (cond ((memq zero-elem then-alts) zero-elem)
+ ((null then-alts) neutral-elem)
+ ((null (cdr then-alts)) (car then-alts))
+ (t (cons (car match) (nreverse then-alts))))
+ (cond ((memq zero-elem else-alts) zero-elem)
+ ((null else-alts) neutral-elem)
+ ((null (cdr else-alts)) (car else-alts))
+ (t (cons (car match) (nreverse else-alts)))))))
+ (t (error "Uknown MATCH %s" match))))
+
+(defun pcase--split-rest (sym splitter rest)
+ (let ((then-rest '())
+ (else-rest '()))
+ (dolist (branch rest)
+ (let* ((match (car branch))
+ (code&vars (cdr branch))
+ (splitted
+ (pcase--split-match sym splitter match)))
+ (unless (eq (car splitted) :pcase--fail)
+ (push (cons (car splitted) code&vars) then-rest))
+ (unless (eq (cdr splitted) :pcase--fail)
+ (push (cons (cdr splitted) code&vars) else-rest))))
+ (cons (nreverse then-rest) (nreverse else-rest))))
+
+(defun pcase--split-consp (syma symd pat)
+ (cond
+ ;; A QPattern for a cons, can only go the `then' side.
+ ((and (eq (car-safe pat) '\`) (consp (cadr pat)))
+ (let ((qpat (cadr pat)))
+ (cons `(and (match ,syma . ,(pcase--upat (car qpat)))
+ (match ,symd . ,(pcase--upat (cdr qpat))))
+ :pcase--fail)))
+ ;; A QPattern but not for a cons, can only go the `else' side.
+ ((eq (car-safe pat) '\`) (cons :pcase--fail nil))))
+
+(defun pcase--split-equal (elem pat)
+ (cond
+ ;; The same match will give the same result.
+ ((and (eq (car-safe pat) '\`) (equal (cadr pat) elem))
+ (cons :pcase--succeed :pcase--fail))
+ ;; A different match will fail if this one succeeds.
+ ((and (eq (car-safe pat) '\`)
+ ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
+ ;; (consp (cadr pat)))
+ )
+ (cons :pcase--fail nil))))
+
+(defun pcase--split-member (elems pat)
+ ;; Based on pcase--split-equal.
+ (cond
+ ;; The same match (or a match of membership in a superset) will
+ ;; give the same result, but we don't know how to check it.
+ ;; (???
+ ;; (cons :pcase--succeed nil))
+ ;; A match for one of the elements may succeed or fail.
+ ((and (eq (car-safe pat) '\`) (member (cadr pat) elems))
+ nil)
+ ;; A different match will fail if this one succeeds.
+ ((and (eq (car-safe pat) '\`)
+ ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
+ ;; (consp (cadr pat)))
+ )
+ (cons :pcase--fail nil))))
+
+(defun pcase--split-pred (upat pat)
+ ;; FIXME: For predicates like (pred (> a)), two such predicates may
+ ;; actually refer to different variables `a'.
+ (if (equal upat pat)
+ (cons :pcase--succeed :pcase--fail)))
+
+(defun pcase--fgrep (vars sexp)
+ "Check which of the symbols VARS appear in SEXP."
+ (let ((res '()))
+ (while (consp sexp)
+ (dolist (var (pcase--fgrep vars (pop sexp)))
+ (unless (memq var res) (push var res))))
+ (and (memq sexp vars) (not (memq sexp res)) (push sexp res))
+ res))
+
+;; It's very tempting to use `pcase' below, tho obviously, it'd create
+;; bootstrapping problems.
+(defun pcase--u1 (matches code vars rest)
+ "Return code that runs CODE (with VARS) if MATCHES match.
+and otherwise defers to REST which is a list of branches of the form
+\(ELSE-MATCH ELSE-CODE . ELSE-VARS)."
+ ;; Depending on the order in which we choose to check each of the MATCHES,
+ ;; the resulting tree may be smaller or bigger. So in general, we'd want
+ ;; to be careful to chose the "optimal" order. But predicate
+ ;; patterns make this harder because they create dependencies
+ ;; between matches. So we don't bother trying to reorder anything.
+ (cond
+ ((null matches) (funcall code vars))
+ ((eq :pcase--fail (car matches)) (pcase--u rest))
+ ((eq :pcase--succeed (car matches))
+ (pcase--u1 (cdr matches) code vars rest))
+ ((eq 'and (caar matches))
+ (pcase--u1 (append (cdar matches) (cdr matches)) code vars rest))
+ ((eq 'or (caar matches))
+ (let* ((alts (cdar matches))
+ (var (if (eq (caar alts) 'match) (cadr (car alts))))
+ (simples '()) (others '()))
+ (when var
+ (dolist (alt alts)
+ (if (and (eq (car alt) 'match) (eq var (cadr alt))
+ (let ((upat (cddr alt)))
+ (and (eq (car-safe upat) '\`)
+ (or (integerp (cadr upat)) (symbolp (cadr upat))
+ (stringp (cadr upat))))))
+ (push (cddr alt) simples)
+ (push alt others))))
+ (cond
+ ((null alts) (error "Please avoid it") (pcase--u rest))
+ ((> (length simples) 1)
+ ;; De-hoist the `or' MATCH into an `or' pattern that will be
+ ;; turned into a `memq' below.
+ (pcase--u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches))
+ code vars
+ (if (null others) rest
+ (cons (list*
+ (pcase--and (if (cdr others)
+ (cons 'or (nreverse others))
+ (car others))
+ (cdr matches))
+ code vars)
+ rest))))
+ (t
+ (pcase--u1 (cons (pop alts) (cdr matches)) code vars
+ (if (null alts) (progn (error "Please avoid it") rest)
+ (cons (list*
+ (pcase--and (if (cdr alts)
+ (cons 'or alts) (car alts))
+ (cdr matches))
+ code vars)
+ rest)))))))
+ ((eq 'match (caar matches))
+ (destructuring-bind (op sym &rest upat) (pop matches)
+ (cond
+ ((memq upat '(t _)) (pcase--u1 matches code vars rest))
+ ((eq upat 'dontcare) :pcase--dontcare)
+ ((functionp upat) (error "Feature removed, use (pred %s)" upat))
+ ((memq (car-safe upat) '(guard pred))
+ (destructuring-bind (then-rest &rest else-rest)
+ (pcase--split-rest
+ sym (apply-partially #'pcase--split-pred upat) rest)
+ (pcase--if (if (and (eq (car upat) 'pred) (symbolp (cadr upat)))
+ `(,(cadr upat) ,sym)
+ (let* ((exp (cadr upat))
+ ;; `vs' is an upper bound on the vars we need.
+ (vs (pcase--fgrep (mapcar #'car vars) exp))
+ (call (cond
+ ((eq 'guard (car upat)) exp)
+ ((functionp exp) `(,exp ,sym))
+ (t `(,@exp ,sym)))))
+ (if (null vs)
+ call
+ ;; Let's not replace `vars' in `exp' since it's
+ ;; too difficult to do it right, instead just
+ ;; let-bind `vars' around `exp'.
+ `(let ,(mapcar (lambda (var)
+ (list var (cdr (assq var vars))))
+ vs)
+ ;; FIXME: `vars' can capture `sym'. E.g.
+ ;; (pcase x ((and `(,x . ,y) (pred (fun x)))))
+ ,call))))
+ (pcase--u1 matches code vars then-rest)
+ (pcase--u else-rest))))
+ ((symbolp upat)
+ (pcase--u1 matches code (cons (cons upat sym) vars) rest))
+ ((eq (car-safe upat) '\`)
+ (pcase--q1 sym (cadr upat) matches code vars rest))
+ ((eq (car-safe upat) 'or)
+ (let ((all (> (length (cdr upat)) 1))
+ (memq-fine t))
+ (when all
+ (dolist (alt (cdr upat))
+ (unless (and (eq (car-safe alt) '\`)
+ (or (symbolp (cadr alt)) (integerp (cadr alt))
+ (setq memq-fine nil)
+ (stringp (cadr alt))))
+ (setq all nil))))
+ (if all
+ ;; Use memq for (or `a `b `c `d) rather than a big tree.
+ (let ((elems (mapcar 'cadr (cdr upat))))
+ (destructuring-bind (then-rest &rest else-rest)
+ (pcase--split-rest
+ sym (apply-partially #'pcase--split-member elems) rest)
+ (pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems)
+ (pcase--u1 matches code vars then-rest)
+ (pcase--u else-rest))))
+ (pcase--u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars
+ (append (mapcar (lambda (upat)
+ `((and (match ,sym . ,upat) ,@matches)
+ ,code ,@vars))
+ (cddr upat))
+ rest)))))
+ ((eq (car-safe upat) 'and)
+ (pcase--u1 (append (mapcar (lambda (upat) `(match ,sym ,@upat))
+ (cdr upat))
+ matches)
+ code vars rest))
+ ((eq (car-safe upat) 'not)
+ ;; FIXME: The implementation below is naive and results in
+ ;; inefficient code.
+ ;; To make it work right, we would need to turn pcase--u1's
+ ;; `code' and `vars' into a single argument of the same form as
+ ;; `rest'. We would also need to split this new `then-rest' argument
+ ;; for every test (currently we don't bother to do it since
+ ;; it's only useful for odd patterns like (and `(PAT1 . PAT2)
+ ;; `(PAT3 . PAT4)) which the programmer can easily rewrite
+ ;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))).
+ (pcase--u1 `((match ,sym . ,(cadr upat)))
+ (lexical-let ((rest rest))
+ ;; FIXME: This codegen is not careful to share its
+ ;; code if used several times: code blow up is likely.
+ (lambda (vars)
+ ;; `vars' will likely contain bindings which are
+ ;; not always available in other paths to
+ ;; `rest', so there' no point trying to pass
+ ;; them down.
+ (pcase--u rest)))
+ vars
+ (list `((and . ,matches) ,code . ,vars))))
+ (t (error "Unknown upattern `%s'" upat)))))
+ (t (error "Incorrect MATCH %s" (car matches)))))
+
+(defun pcase--q1 (sym qpat matches code vars rest)
+ "Return code that runs CODE if SYM matches QPAT and if MATCHES match.
+and if not, defers to REST which is a list of branches of the form
+\(OTHER_MATCH OTHER-CODE . OTHER-VARS)."
+ (cond
+ ((eq (car-safe qpat) '\,) (error "Can't use `,UPATTERN"))
+ ((floatp qpat) (error "Floating point patterns not supported"))
+ ((vectorp qpat)
+ ;; FIXME.
+ (error "Vector QPatterns not implemented yet"))
+ ((consp qpat)
+ (let ((syma (make-symbol "xcar"))
+ (symd (make-symbol "xcdr")))
+ (destructuring-bind (then-rest &rest else-rest)
+ (pcase--split-rest sym
+ (apply-partially #'pcase--split-consp syma symd)
+ rest)
+ (pcase--if `(consp ,sym)
+ `(let ((,syma (car ,sym))
+ (,symd (cdr ,sym)))
+ ,(pcase--u1 `((match ,syma . ,(pcase--upat (car qpat)))
+ (match ,symd . ,(pcase--upat (cdr qpat)))
+ ,@matches)
+ code vars then-rest))
+ (pcase--u else-rest)))))
+ ((or (integerp qpat) (symbolp qpat) (stringp qpat))
+ (destructuring-bind (then-rest &rest else-rest)
+ (pcase--split-rest sym (apply-partially 'pcase--split-equal qpat) rest)
+ (pcase--if `(,(if (stringp qpat) #'equal #'eq) ,sym ',qpat)
+ (pcase--u1 matches code vars then-rest)
+ (pcase--u else-rest))))
+ (t (error "Unkown QPattern %s" qpat))))
+
+
+(provide 'pcase)
+;;; pcase.el ends here
diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el
index ec1a704ce0b..1845effd5bb 100644
--- a/lisp/emacs-lisp/re-builder.el
+++ b/lisp/emacs-lisp/re-builder.el
@@ -61,14 +61,12 @@
;; this limit allowing an easy way to see all matches.
;; Currently `re-builder' understands five different forms of input,
-;; namely `read', `string', `rx', `sregex' and `lisp-re' syntax. Read
+;; namely `read', `string', `rx', and `sregex' syntax. Read
;; syntax and string syntax are both delimited by `"'s and behave
;; according to their name. With the `string' syntax there's no need
;; to escape the backslashes and double quotes simplifying the editing
;; somewhat. The other three allow editing of symbolic regular
-;; expressions supported by the packages of the same name. (`lisp-re'
-;; is a package by me and its support may go away as it is nearly the
-;; same as the `sregex' package in Emacs)
+;; expressions supported by the packages of the same name.
;; Editing symbolic expressions is done through a major mode derived
;; from `emacs-lisp-mode' so you'll get all the good stuff like
@@ -128,12 +126,11 @@
(defcustom reb-re-syntax 'read
"Syntax for the REs in the RE Builder.
-Can either be `read', `string', `sregex', `lisp-re', `rx'."
+Can either be `read', `string', `sregex', or `rx'."
:group 're-builder
:type '(choice (const :tag "Read syntax" read)
(const :tag "String syntax" string)
(const :tag "`sregex' syntax" sregex)
- (const :tag "`lisp-re' syntax" lisp-re)
(const :tag "`rx' syntax" rx)))
(defcustom reb-auto-match-limit 200
@@ -281,9 +278,8 @@ Except for Lisp syntax this is the same as `reb-regexp'.")
(define-derived-mode reb-lisp-mode
emacs-lisp-mode "RE Builder Lisp"
"Major mode for interactively building symbolic Regular Expressions."
- (cond ((eq reb-re-syntax 'lisp-re) ; Pull in packages
- (require 'lisp-re)) ; as needed
- ((eq reb-re-syntax 'sregex) ; sregex is not autoloaded
+ ;; Pull in packages as needed
+ (cond ((eq reb-re-syntax 'sregex) ; sregex is not autoloaded
(require 'sregex)) ; right now..
((eq reb-re-syntax 'rx) ; rx-to-string is autoloaded
(require 'rx))) ; require rx anyway
@@ -329,7 +325,7 @@ Except for Lisp syntax this is the same as `reb-regexp'.")
(defsubst reb-lisp-syntax-p ()
"Return non-nil if RE Builder uses a Lisp syntax."
- (memq reb-re-syntax '(lisp-re sregex rx)))
+ (memq reb-re-syntax '(sregex rx)))
(defmacro reb-target-binding (symbol)
"Return binding for SYMBOL in the RE Builder target buffer."
@@ -489,10 +485,10 @@ Optional argument SYNTAX must be specified if called non-interactively."
(list (intern
(completing-read "Select syntax: "
(mapcar (lambda (el) (cons (symbol-name el) 1))
- '(read string lisp-re sregex rx))
+ '(read string sregex rx))
nil t (symbol-name reb-re-syntax)))))
- (if (memq syntax '(read string lisp-re sregex rx))
+ (if (memq syntax '(read string sregex rx))
(let ((buffer (get-buffer reb-buffer)))
(setq reb-re-syntax syntax)
(when buffer
@@ -616,10 +612,7 @@ optional fourth argument FORCE is non-nil."
(defun reb-cook-regexp (re)
"Return RE after processing it according to `reb-re-syntax'."
- (cond ((eq reb-re-syntax 'lisp-re)
- (when (fboundp 'lre-compile-string)
- (lre-compile-string (eval (car (read-from-string re))))))
- ((eq reb-re-syntax 'sregex)
+ (cond ((eq reb-re-syntax 'sregex)
(apply 'sregex (eval (car (read-from-string re)))))
((eq reb-re-syntax 'rx)
(rx-to-string (eval (car (read-from-string re)))))
diff --git a/lisp/emacs-lisp/regexp-opt.el b/lisp/emacs-lisp/regexp-opt.el
index f70ad4047a7..116d7b93d90 100644
--- a/lisp/emacs-lisp/regexp-opt.el
+++ b/lisp/emacs-lisp/regexp-opt.el
@@ -96,19 +96,24 @@ The returned regexp is typically more efficient than the equivalent regexp:
(concat open (mapconcat 'regexp-quote STRINGS \"\\\\|\") close))
If PAREN is `words', then the resulting regexp is additionally surrounded
-by \\=\\< and \\>."
+by \\=\\< and \\>.
+If PAREN is `symbols', then the resulting regexp is additionally surrounded
+by \\=\\_< and \\_>."
(save-match-data
;; Recurse on the sorted list.
(let* ((max-lisp-eval-depth 10000)
(max-specpdl-size 10000)
(completion-ignore-case nil)
(completion-regexp-list nil)
- (words (eq paren 'words))
(open (cond ((stringp paren) paren) (paren "\\(")))
(sorted-strings (delete-dups
(sort (copy-sequence strings) 'string-lessp)))
(re (regexp-opt-group sorted-strings (or open t) (not open))))
- (if words (concat "\\<" re "\\>") re))))
+ (cond ((eq paren 'words)
+ (concat "\\<" re "\\>"))
+ ((eq paren 'symbols)
+ (concat "\\_<" re "\\_>"))
+ (t re)))))
;;;###autoload
(defun regexp-opt-depth (regexp)
@@ -120,7 +125,7 @@ This means the number of non-shy regexp grouping constructs
(string-match regexp "")
;; Count the number of open parentheses in REGEXP.
(let ((count 0) start last)
- (while (string-match "\\\\(\\(\\?:\\)?" regexp start)
+ (while (string-match "\\\\(\\(\\?[0-9]*:\\)?" regexp start)
(setq start (match-end 0)) ; Start of next search.
(when (and (not (match-beginning 1))
(subregexp-context-p regexp (match-beginning 0) last))
diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el
index fe32a302045..e690cbaa1bc 100644
--- a/lisp/emacs-lisp/shadow.el
+++ b/lisp/emacs-lisp/shadow.el
@@ -157,6 +157,34 @@ See the documentation for `list-load-path-shadows' for further information."
(and (= (nth 7 (file-attributes f1))
(nth 7 (file-attributes f2)))
(eq 0 (call-process "cmp" nil nil nil "-s" f1 f2))))))))
+
+(defvar load-path-shadows-font-lock-keywords
+ `((,(format "hides \\(%s.*\\)"
+ (file-name-directory (locate-library "simple.el")))
+ . (1 font-lock-warning-face)))
+ "Keywords to highlight in `load-path-shadows-mode'.")
+
+(define-derived-mode load-path-shadows-mode fundamental-mode "LP-Shadows"
+ "Major mode for load-path shadows buffer."
+ (set (make-local-variable 'font-lock-defaults)
+ '((load-path-shadows-font-lock-keywords)))
+ (setq buffer-undo-list t
+ buffer-read-only t))
+
+;; TODO use text-properties instead, a la dired.
+(require 'button)
+(define-button-type 'load-path-shadows-find-file
+ 'follow-link t
+;; 'face 'default
+ 'action (lambda (button)
+ (let ((file (concat (button-get button 'shadow-file) ".el")))
+ (or (file-exists-p file)
+ (setq file (concat file ".gz")))
+ (if (file-readable-p file)
+ (pop-to-buffer (find-file-noselect file))
+ (error "Cannot read file"))))
+ 'help-echo "mouse-2, RET: find this file")
+
;;;###autoload
(defun list-load-path-shadows (&optional stringp)
@@ -240,14 +268,21 @@ function, `load-path-shadows-find'."
;; Create the *Shadows* buffer and display shadowings there.
(let ((string (buffer-string)))
(with-current-buffer (get-buffer-create "*Shadows*")
- (fundamental-mode) ;run after-change-major-mode-hook.
(display-buffer (current-buffer))
- (setq buffer-undo-list t
- buffer-read-only nil)
- (erase-buffer)
- (insert string)
- (insert msg "\n")
- (setq buffer-read-only t)))
+ (load-path-shadows-mode) ; run after-change-major-mode-hook
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (insert string)
+ (insert msg "\n")
+ (while (re-search-backward "\\(^.*\\) hides \\(.*$\\)"
+ nil t)
+ (dotimes (i 2)
+ (make-button (match-beginning (1+ i))
+ (match-end (1+ i))
+ 'type 'load-path-shadows-find-file
+ 'shadow-file
+ (match-string (1+ i)))))
+ (goto-char (point-max)))))
;; We are non-interactive, print shadows via message.
(unless (zerop n)
(message "This site has duplicate Lisp libraries with the same name.
@@ -265,5 +300,4 @@ version unless you know what you are doing.\n")
(provide 'shadow)
-;; arch-tag: 0480e8a7-62ed-4a12-a9f6-f44ded9b0830
;;; shadow.el ends here
diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el
index 5cc89596ef5..b85399263d0 100644
--- a/lisp/emacs-lisp/syntax.el
+++ b/lisp/emacs-lisp/syntax.el
@@ -34,7 +34,6 @@
;; - do something about the case where the syntax-table is changed.
;; This typically happens with tex-mode and its `$' operator.
-;; - move font-lock-syntactic-keywords in here. Then again, maybe not.
;; - new functions `syntax-state', ... to replace uses of parse-partial-state
;; with something higher-level (similar to syntax-ppss-context).
;; - interaction with mmm-mode.
@@ -47,6 +46,281 @@
(defvar font-lock-beginning-of-syntax-function)
+;;; Applying syntax-table properties where needed.
+
+(defvar syntax-propertize-function nil
+ ;; Rather than a -functions hook, this is a -function because it's easier
+ ;; to do a single scan than several scans: with multiple scans, one cannot
+ ;; assume that the text before point has been propertized, so syntax-ppss
+ ;; gives unreliable results (and stores them in its cache to boot, so we'd
+ ;; have to flush that cache between each function, and we couldn't use
+ ;; syntax-ppss-flush-cache since that would not only flush the cache but also
+ ;; reset syntax-propertize--done which should not be done in this case).
+ "Mode-specific function to apply the syntax-table properties.
+Called with 2 arguments: START and END.
+This function can call `syntax-ppss' on any position before END, but it
+should not call `syntax-ppss-flush-cache', which means that it should not
+call `syntax-ppss' on some position and later modify the buffer on some
+earlier position.")
+
+(defvar syntax-propertize-chunk-size 500)
+
+(defvar syntax-propertize-extend-region-functions
+ '(syntax-propertize-wholelines)
+ "Special hook run just before proceeding to propertize a region.
+This is used to allow major modes to help `syntax-propertize' find safe buffer
+positions as beginning and end of the propertized region. Its most common use
+is to solve the problem of /identification/ of multiline elements by providing
+a function that tries to find such elements and move the boundaries such that
+they do not fall in the middle of one.
+Each function is called with two arguments (START and END) and it should return
+either a cons (NEW-START . NEW-END) or nil if no adjustment should be made.
+These functions are run in turn repeatedly until they all return nil.
+Put first the functions more likely to cause a change and cheaper to compute.")
+;; Mark it as a special hook which doesn't use any global setting
+;; (i.e. doesn't obey the element t in the buffer-local value).
+(make-variable-buffer-local 'syntax-propertize-extend-region-functions)
+
+(defun syntax-propertize-wholelines (start end)
+ (goto-char start)
+ (cons (line-beginning-position)
+ (progn (goto-char end)
+ (if (bolp) (point) (line-beginning-position 2)))))
+
+(defun syntax-propertize-multiline (beg end)
+ "Let `syntax-propertize' pay attention to the syntax-multiline property."
+ (when (and (> beg (point-min))
+ (get-text-property (1- beg) 'syntax-multiline))
+ (setq beg (or (previous-single-property-change beg 'syntax-multiline)
+ (point-min))))
+ ;;
+ (when (get-text-property end 'font-lock-multiline)
+ (setq end (or (text-property-any end (point-max)
+ 'syntax-multiline nil)
+ (point-max))))
+ (cons beg end))
+
+(defvar syntax-propertize--done -1
+ "Position upto which syntax-table properties have been set.")
+(make-variable-buffer-local 'syntax-propertize--done)
+
+(defun syntax-propertize--shift-groups (re n)
+ (replace-regexp-in-string
+ "\\\\(\\?\\([0-9]+\\):"
+ (lambda (s)
+ (replace-match
+ (number-to-string (+ n (string-to-number (match-string 1 s))))
+ t t s 1))
+ re t t))
+
+(defmacro syntax-propertize-precompile-rules (&rest rules)
+ "Return a precompiled form of RULES to pass to `syntax-propertize-rules'.
+The arg RULES can be of the same form as in `syntax-propertize-rules'.
+The return value is an object that can be passed as a rule to
+`syntax-propertize-rules'.
+I.e. this is useful only when you want to share rules among several
+syntax-propertize-functions."
+ (declare (debug syntax-propertize-rules))
+ ;; Precompile? Yeah, right!
+ ;; Seriously, tho, this is a macro for 2 reasons:
+ ;; - we could indeed do some pre-compilation at some point in the future,
+ ;; e.g. fi/when we switch to a DFA-based implementation of
+ ;; syntax-propertize-rules.
+ ;; - this lets Edebug properly annotate the expressions inside RULES.
+ `',rules)
+
+(defmacro syntax-propertize-rules (&rest rules)
+ "Make a function that applies RULES for use in `syntax-propertize-function'.
+The function will scan the buffer, applying the rules where they match.
+The buffer is scanned a single time, like \"lex\" would, rather than once
+per rule.
+
+Each RULE can be a symbol, in which case that symbol's value should be,
+at macro-expansion time, a precompiled set of rules, as returned
+by `syntax-propertize-precompile-rules'.
+
+Otherwise, RULE should have the form (REGEXP HIGHLIGHT1 ... HIGHLIGHTn), where
+REGEXP is an expression (evaluated at time of macro-expansion) that returns
+a regexp, and where HIGHLIGHTs have the form (NUMBER SYNTAX) which means to
+apply the property SYNTAX to the chars matched by the subgroup NUMBER
+of the regular expression, if NUMBER did match.
+SYNTAX is an expression that returns a value to apply as `syntax-table'
+property. Some expressions are handled specially:
+- if SYNTAX is a string, then it is converted with `string-to-syntax';
+- if SYNTAX has the form (prog1 EXP . EXPS) then the value returned by EXP
+ will be applied to the buffer before running EXPS and if EXP is a string it
+ is also converted with `string-to-syntax'.
+The SYNTAX expression is responsible to save the `match-data' if needed
+for subsequent HIGHLIGHTs.
+Also SYNTAX is free to move point, in which case RULES may not be applied to
+some parts of the text or may be applied several times to other parts.
+
+Note: back-references in REGEXPs do not work."
+ (declare (debug (&rest &or symbolp ;FIXME: edebug this eval step.
+ (form &rest
+ (numberp
+ [&or stringp ;FIXME: Use &wrap
+ ("prog1" [&or stringp def-form] def-body)
+ def-form])))))
+ (let ((newrules nil))
+ (while rules
+ (if (symbolp (car rules))
+ (setq rules (append (symbol-value (pop rules)) rules))
+ (push (pop rules) newrules)))
+ (setq rules (nreverse newrules)))
+ (let* ((offset 0)
+ (branches '())
+ ;; We'd like to use a real DFA-based lexer, usually, but since Emacs
+ ;; doesn't have one yet, we fallback on building one large regexp
+ ;; and use groups to determine which branch of the regexp matched.
+ (re
+ (mapconcat
+ (lambda (rule)
+ (let* ((orig-re (eval (car rule)))
+ (re orig-re))
+ (when (and (assq 0 rule) (cdr rules))
+ ;; If there's more than 1 rule, and the rule want to apply
+ ;; highlight to match 0, create an extra group to be able to
+ ;; tell when *this* match 0 has succeeded.
+ (incf offset)
+ (setq re (concat "\\(" re "\\)")))
+ (setq re (syntax-propertize--shift-groups re offset))
+ (let ((code '())
+ (condition
+ (cond
+ ((assq 0 rule) (if (zerop offset) t
+ `(match-beginning ,offset)))
+ ((null (cddr rule))
+ `(match-beginning ,(+ offset (car (cadr rule)))))
+ (t
+ `(or ,@(mapcar
+ (lambda (case)
+ `(match-beginning ,(+ offset (car case))))
+ (cdr rule))))))
+ (nocode t)
+ (offset offset))
+ ;; If some of the subgroup rules include Elisp code, then we
+ ;; need to set the match-data so it's consistent with what the
+ ;; code expects. If not, then we can simply use shifted
+ ;; offset in our own code.
+ (unless (zerop offset)
+ (dolist (case (cdr rule))
+ (unless (stringp (cadr case))
+ (setq nocode nil)))
+ (unless nocode
+ (push `(let ((md (match-data 'ints)))
+ ;; Keep match 0 as is, but shift everything else.
+ (setcdr (cdr md) (nthcdr ,(* (1+ offset) 2) md))
+ (set-match-data md))
+ code)
+ (setq offset 0)))
+ ;; Now construct the code for each subgroup rules.
+ (dolist (case (cdr rule))
+ (assert (null (cddr case)))
+ (let* ((gn (+ offset (car case)))
+ (action (nth 1 case))
+ (thiscode
+ (cond
+ ((stringp action)
+ `((put-text-property
+ (match-beginning ,gn) (match-end ,gn)
+ 'syntax-table
+ ',(string-to-syntax action))))
+ ((eq (car-safe action) 'ignore)
+ (cdr action))
+ ((eq (car-safe action) 'prog1)
+ (if (stringp (nth 1 action))
+ `((put-text-property
+ (match-beginning ,gn) (match-end ,gn)
+ 'syntax-table
+ ',(string-to-syntax (nth 1 action)))
+ ,@(nthcdr 2 action))
+ `((let ((mb (match-beginning ,gn))
+ (me (match-end ,gn))
+ (syntax ,(nth 1 action)))
+ (if syntax
+ (put-text-property
+ mb me 'syntax-table syntax))
+ ,@(nthcdr 2 action)))))
+ (t
+ `((let ((mb (match-beginning ,gn))
+ (me (match-end ,gn))
+ (syntax ,action))
+ (if syntax
+ (put-text-property
+ mb me 'syntax-table syntax))))))))
+
+ (if (or (not (cddr rule)) (zerop gn))
+ (setq code (nconc (nreverse thiscode) code))
+ (push `(if (match-beginning ,gn)
+ ;; Try and generate clean code with no
+ ;; extraneous progn.
+ ,(if (null (cdr thiscode))
+ (car thiscode)
+ `(progn ,@thiscode)))
+ code))))
+ (push (cons condition (nreverse code))
+ branches))
+ (incf offset (regexp-opt-depth orig-re))
+ re))
+ rules
+ "\\|")))
+ `(lambda (start end)
+ (goto-char start)
+ (while (and (< (point) end)
+ (re-search-forward ,re end t))
+ (cond ,@(nreverse branches))))))
+
+(defun syntax-propertize-via-font-lock (keywords)
+ "Propertize for syntax in START..END using font-lock syntax.
+KEYWORDS obeys the format used in `font-lock-syntactic-keywords'.
+The return value is a function suitable for `syntax-propertize-function'."
+ (lexical-let ((keywords keywords))
+ (lambda (start end)
+ (with-no-warnings
+ (let ((font-lock-syntactic-keywords keywords))
+ (font-lock-fontify-syntactic-keywords-region start end)
+ ;; In case it was eval'd/compiled.
+ (setq keywords font-lock-syntactic-keywords))))))
+
+(defun syntax-propertize (pos)
+ "Ensure that syntax-table properties are set upto POS."
+ (when (and syntax-propertize-function
+ (< syntax-propertize--done pos))
+ ;; (message "Needs to syntax-propertize from %s to %s"
+ ;; syntax-propertize--done pos)
+ (set (make-local-variable 'parse-sexp-lookup-properties) t)
+ (save-excursion
+ (with-silent-modifications
+ (let* ((start (max syntax-propertize--done (point-min)))
+ (end (max pos
+ (min (point-max)
+ (+ start syntax-propertize-chunk-size))))
+ (funs syntax-propertize-extend-region-functions))
+ (while funs
+ (let ((new (funcall (pop funs) start end)))
+ (if (or (null new)
+ (and (>= (car new) start) (<= (cdr new) end)))
+ nil
+ (setq start (car new))
+ (setq end (cdr new))
+ ;; If there's been a change, we should go through the
+ ;; list again since this new position may
+ ;; warrant a different answer from one of the funs we've
+ ;; already seen.
+ (unless (eq funs
+ (cdr syntax-propertize-extend-region-functions))
+ (setq funs syntax-propertize-extend-region-functions)))))
+ ;; Move the limit before calling the function, so the function
+ ;; can use syntax-ppss.
+ (setq syntax-propertize--done end)
+ ;; (message "syntax-propertizing from %s to %s" start end)
+ (remove-text-properties start end
+ '(syntax-table nil syntax-multiline nil))
+ (funcall syntax-propertize-function start end))))))
+
+;;; Incrementally compute and memoize parser state.
+
(defsubst syntax-ppss-depth (ppss)
(nth 0 ppss))
@@ -92,6 +366,8 @@ point (where the PPSS is equivalent to nil).")
(defalias 'syntax-ppss-after-change-function 'syntax-ppss-flush-cache)
(defun syntax-ppss-flush-cache (beg &rest ignored)
"Flush the cache of `syntax-ppss' starting at position BEG."
+ ;; Set syntax-propertize to refontify anything past beg.
+ (setq syntax-propertize--done (min beg syntax-propertize--done))
;; Flush invalid cache entries.
(while (and syntax-ppss-cache (> (caar syntax-ppss-cache) beg))
(setq syntax-ppss-cache (cdr syntax-ppss-cache)))
@@ -128,6 +404,7 @@ the 2nd and 6th values of the returned state cannot be relied upon.
Point is at POS when this function returns."
;; Default values.
(unless pos (setq pos (point)))
+ (syntax-propertize pos)
;;
(let ((old-ppss (cdr syntax-ppss-last))
(old-pos (car syntax-ppss-last))
@@ -209,7 +486,8 @@ Point is at POS when this function returns."
(funcall syntax-begin-function)
;; Make sure it's better.
(> (point) pt-best))
- ;; Simple sanity check.
+ ;; Simple sanity checks.
+ (< (point) pos) ; backward-paragraph can fail here.
(not (memq (get-text-property (point) 'face)
'(font-lock-string-face font-lock-doc-face
font-lock-comment-face))))
diff --git a/lisp/emacs-lisp/tcover-ses.el b/lisp/emacs-lisp/tcover-ses.el
index cf5e79d2a26..8df70f4d979 100644
--- a/lisp/emacs-lisp/tcover-ses.el
+++ b/lisp/emacs-lisp/tcover-ses.el
@@ -6,6 +6,7 @@
;; Author: Jonathan Yavner <jyavner@engineer.com>
;; Maintainer: Jonathan Yavner <jyavner@engineer.com>
;; Keywords: spreadsheet lisp utility
+;; Package: testcover
;; 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
diff --git a/lisp/emacs-lisp/tcover-unsafep.el b/lisp/emacs-lisp/tcover-unsafep.el
index b300ee6dcef..47f931bf9d3 100644
--- a/lisp/emacs-lisp/tcover-unsafep.el
+++ b/lisp/emacs-lisp/tcover-unsafep.el
@@ -5,6 +5,7 @@
;; Author: Jonathan Yavner <jyavner@engineer.com>
;; Maintainer: Jonathan Yavner <jyavner@engineer.com>
;; Keywords: safety lisp utility
+;; Package: testcover
;; This file is part of GNU Emacs.
diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el
index f3b8ddcd123..b12d9068676 100644
--- a/lisp/emacs-lisp/timer.el
+++ b/lisp/emacs-lisp/timer.el
@@ -4,6 +4,7 @@
;; 2009, 2010 Free Software Foundation, Inc.
;; Maintainer: FSF
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -92,31 +93,20 @@ fire each time Emacs is idle for that many seconds."
More precisely, the next value, after TIME, that is an integral multiple
of SECS seconds since the epoch. SECS may be a fraction."
(let ((time-base (ash 1 16)))
- (if (fboundp 'atan)
- ;; Use floating point, taking care to not lose precision.
- (let* ((float-time-base (float time-base))
- (million 1000000.0)
- (time-usec (+ (* million
- (+ (* float-time-base (nth 0 time))
- (nth 1 time)))
- (nth 2 time)))
- (secs-usec (* million secs))
- (mod-usec (mod time-usec secs-usec))
- (next-usec (+ (- time-usec mod-usec) secs-usec))
- (time-base-million (* float-time-base million)))
- (list (floor next-usec time-base-million)
- (floor (mod next-usec time-base-million) million)
- (floor (mod next-usec million))))
- ;; Floating point is not supported.
- ;; Use integer arithmetic, avoiding overflow if possible.
- (let* ((mod-sec (mod (+ (* (mod time-base secs)
- (mod (nth 0 time) secs))
- (nth 1 time))
- secs))
- (next-1-sec (+ (- (nth 1 time) mod-sec) secs)))
- (list (+ (nth 0 time) (floor next-1-sec time-base))
- (mod next-1-sec time-base)
- 0)))))
+ ;; Use floating point, taking care to not lose precision.
+ (let* ((float-time-base (float time-base))
+ (million 1000000.0)
+ (time-usec (+ (* million
+ (+ (* float-time-base (nth 0 time))
+ (nth 1 time)))
+ (nth 2 time)))
+ (secs-usec (* million secs))
+ (mod-usec (mod time-usec secs-usec))
+ (next-usec (+ (- time-usec mod-usec) secs-usec))
+ (time-base-million (* float-time-base million)))
+ (list (floor next-usec time-base-million)
+ (floor (mod next-usec time-base-million) million)
+ (floor (mod next-usec million))))))
(defun timer-relative-time (time secs &optional usecs)
"Advance TIME by SECS seconds and optionally USECS microseconds.
@@ -321,7 +311,11 @@ This function is called, by name, directly by the C code."
;; We do this after rescheduling so that the handler function
;; can cancel its own timer successfully with cancel-timer.
(condition-case nil
- (apply (timer--function timer) (timer--args timer))
+ ;; Timer functions should not change the current buffer.
+ ;; If they do, all kinds of nasty surprises can happen,
+ ;; and it can be hellish to track down their source.
+ (save-current-buffer
+ (apply (timer--function timer) (timer--args timer)))
(error nil))
(if retrigger
(setf (timer--triggered timer) nil)))
@@ -438,8 +432,6 @@ This function returns a timer object which you can use in `cancel-timer'."
"This is the timer function used for the timer made by `with-timeout'."
(throw tag 'timeout))
-(put 'with-timeout 'lisp-indent-function 1)
-
(defvar with-timeout-timers nil
"List of all timers used by currently pending `with-timeout' calls.")
@@ -451,6 +443,7 @@ event (such as keyboard input, input from subprocesses, or a certain time);
if the program loops without waiting in any way, the timeout will not
be detected.
\n(fn (SECONDS TIMEOUT-FORMS...) BODY)"
+ (declare (indent 1))
(let ((seconds (car list))
(timeout-forms (cdr list)))
`(let ((with-timeout-tag (cons nil nil))
@@ -539,5 +532,4 @@ If the user does not answer after SECONDS seconds, return DEFAULT-VALUE."
(provide 'timer)
-;; arch-tag: b1a9237b-7787-4382-9e46-8f2c3b3273e0
;;; timer.el ends here
diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el
index 4adb93a852d..ba8c8ffc831 100644
--- a/lisp/emacs-lisp/warnings.el
+++ b/lisp/emacs-lisp/warnings.el
@@ -119,9 +119,9 @@ See also `warning-suppress-log-types'."
:type '(repeat (repeat symbol))
:version "22.1")
-;;; The autoload cookie is so that programs can bind this variable
-;;; safely, testing the existing value, before they call one of the
-;;; warnings functions.
+;; The autoload cookie is so that programs can bind this variable
+;; safely, testing the existing value, before they call one of the
+;; warnings functions.
;;;###autoload
(defvar warning-prefix-function nil
"Function to generate warning prefixes.
@@ -132,9 +132,9 @@ The warnings buffer is current when this function is called
and the function can insert text in it. This text becomes
the beginning of the warning.")
-;;; The autoload cookie is so that programs can bind this variable
-;;; safely, testing the existing value, before they call one of the
-;;; warnings functions.
+;; The autoload cookie is so that programs can bind this variable
+;; safely, testing the existing value, before they call one of the
+;; warnings functions.
;;;###autoload
(defvar warning-series nil
"Non-nil means treat multiple `display-warning' calls as a series.
@@ -146,16 +146,16 @@ A symbol with a function definition is like t, except
also call that function before the next warning.")
(put 'warning-series 'risky-local-variable t)
-;;; The autoload cookie is so that programs can bind this variable
-;;; safely, testing the existing value, before they call one of the
-;;; warnings functions.
+;; The autoload cookie is so that programs can bind this variable
+;; safely, testing the existing value, before they call one of the
+;; warnings functions.
;;;###autoload
(defvar warning-fill-prefix nil
"Non-nil means fill each warning text using this string as `fill-prefix'.")
-;;; The autoload cookie is so that programs can bind this variable
-;;; safely, testing the existing value, before they call one of the
-;;; warnings functions.
+;; The autoload cookie is so that programs can bind this variable
+;; safely, testing the existing value, before they call one of the
+;; warnings functions.
;;;###autoload
(defvar warning-type-format (purecopy " (%s)")
"Format for displaying the warning type in the warning message.
@@ -241,6 +241,8 @@ See also `warning-series', `warning-prefix-function' and
(with-current-buffer buffer
;; If we created the buffer, disable undo.
(unless old
+ (special-mode)
+ (setq buffer-read-only t)
(setq buffer-undo-list t))
(goto-char (point-max))
(when (and warning-series (symbolp warning-series))
@@ -248,6 +250,7 @@ See also `warning-series', `warning-prefix-function' and
(prog1 (point-marker)
(unless (eq warning-series t)
(funcall warning-series)))))
+ (let ((inhibit-read-only t))
(unless (bolp)
(newline))
(setq start (point))
@@ -262,7 +265,7 @@ See also `warning-series', `warning-prefix-function' and
(let ((fill-prefix warning-fill-prefix)
(fill-column 78))
(fill-region start (point))))
- (setq end (point))
+ (setq end (point)))
(when (and (markerp warning-series)
(eq (marker-buffer warning-series) buffer))
(goto-char warning-series)))
diff --git a/lisp/emulation/crisp.el b/lisp/emulation/crisp.el
index fd59ba760d8..9be200168ea 100644
--- a/lisp/emulation/crisp.el
+++ b/lisp/emulation/crisp.el
@@ -1,7 +1,7 @@
;;; crisp.el --- CRiSP/Brief Emacs emulator
-;; Copyright (C) 1997, 1998, 1999, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 1998, 1999, 2001, 2002, 2003, 2004, 2005, 2006,
+;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Gary D. Foster <Gary.Foster@Corp.Sun.COM>
;; Keywords: emulations brief crisp
@@ -175,7 +175,7 @@ All the bindings are done here instead of globally to try and be
nice to the world.")
(defcustom crisp-mode-modeline-string " *CRiSP*"
- "*String to display in the modeline when CRiSP emulation mode is enabled."
+ "String to display in the modeline when CRiSP emulation mode is enabled."
:type 'string
:group 'crisp)
@@ -195,7 +195,7 @@ use either M-x customize or the function `crisp-mode'."
:group 'crisp)
(defcustom crisp-override-meta-x t
- "*Controls overriding the normal Emacs M-x key binding in the CRiSP emulator.
+ "Controls overriding the normal Emacs M-x key binding in the CRiSP emulator.
Normally the CRiSP emulator rebinds M-x to `save-buffers-exit-emacs', and
provides the usual M-x functionality on the F10 key. If this variable
is non-nil, M-x will exit Emacs."
diff --git a/lisp/emulation/cua-base.el b/lisp/emulation/cua-base.el
index 11cee8197a4..bc64608a284 100644
--- a/lisp/emulation/cua-base.el
+++ b/lisp/emulation/cua-base.el
@@ -1,7 +1,7 @@
;;; cua-base.el --- emulate CUA key bindings
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Kim F. Storm <storm@cua.dk>
;; Keywords: keyboard emulations convenience cua
@@ -270,7 +270,7 @@
:link '(emacs-library-link :tag "Lisp File" "cua-base.el"))
(defcustom cua-enable-cua-keys t
- "*Enable using C-z, C-x, C-c, and C-v for undo, cut, copy, and paste.
+ "Enable using C-z, C-x, C-c, and C-v for undo, cut, copy, and paste.
If the value is t, these mappings are always enabled. If the value is
`shift', these keys are only enabled if the last region was marked with
a shifted movement key. If the value is nil, these keys are never
@@ -281,18 +281,18 @@ enabled."
:group 'cua)
(defcustom cua-remap-control-v t
- "*If non-nil, C-v binding is used for paste (yank).
+ "If non-nil, C-v binding is used for paste (yank).
Also, M-v is mapped to `cua-repeat-replace-region'."
:type 'boolean
:group 'cua)
(defcustom cua-remap-control-z t
- "*If non-nil, C-z binding is used for undo."
+ "If non-nil, C-z binding is used for undo."
:type 'boolean
:group 'cua)
(defcustom cua-highlight-region-shift-only nil
- "*If non-nil, only highlight region if marked with S-<move>.
+ "If non-nil, only highlight region if marked with S-<move>.
When this is non-nil, CUA toggles `transient-mark-mode' on when the region
is marked using shifted movement keys, and off when the mark is cleared.
But when the mark was set using \\[cua-set-mark], Transient Mark mode
@@ -300,9 +300,8 @@ is not turned on."
:type 'boolean
:group 'cua)
-(defcustom cua-prefix-override-inhibit-delay
- (if (featurep 'lisp-float-type) (/ (float 1) (float 5)) nil)
- "*If non-nil, time in seconds to delay before overriding prefix key.
+(defcustom cua-prefix-override-inhibit-delay 0.2
+ "If non-nil, time in seconds to delay before overriding prefix key.
If there is additional input within this time, the prefix key is
used as a normal prefix key. So typing a key sequence quickly will
inhibit overriding the prefix key.
@@ -315,7 +314,7 @@ If the value is nil, use a shifted prefix key to inhibit the override."
:group 'cua)
(defcustom cua-delete-selection t
- "*If non-nil, typed text replaces text in the active selection."
+ "If non-nil, typed text replaces text in the active selection."
:type '(choice (const :tag "Disabled" nil)
(other :tag "Enabled" t))
:group 'cua)
@@ -326,13 +325,13 @@ If the value is nil, use a shifted prefix key to inhibit the override."
:group 'cua)
(defcustom cua-toggle-set-mark t
- "*If non-nil, the `cua-set-mark' command toggles the mark."
+ "If non-nil, the `cua-set-mark' command toggles the mark."
:type '(choice (const :tag "Disabled" nil)
(other :tag "Enabled" t))
:group 'cua)
(defcustom cua-auto-mark-last-change nil
- "*If non-nil, set implicit mark at position of last buffer change.
+ "If non-nil, set implicit mark at position of last buffer change.
This means that \\[universal-argument] \\[cua-set-mark] will jump to the position
of the last buffer change before jumping to the explicit marks on the mark ring.
See `cua-set-mark' for details."
@@ -340,7 +339,7 @@ See `cua-set-mark' for details."
:group 'cua)
(defcustom cua-enable-register-prefix 'not-ctrl-u
- "*If non-nil, registers are supported via numeric prefix arg.
+ "If non-nil, registers are supported via numeric prefix arg.
If the value is t, any numeric prefix arg in the range 0 to 9 will be
interpreted as a register number.
If the value is `not-ctrl-u', using C-u to enter a numeric prefix is not
@@ -354,29 +353,29 @@ interpreted as a register number."
:group 'cua)
(defcustom cua-delete-copy-to-register-0 t
- "*If non-nil, save last deleted region or rectangle to register 0."
+ "If non-nil, save last deleted region or rectangle to register 0."
:type 'boolean
:group 'cua)
(defcustom cua-enable-region-auto-help nil
- "*If non-nil, automatically show help for active region."
+ "If non-nil, automatically show help for active region."
:type 'boolean
:group 'cua)
(defcustom cua-enable-modeline-indications nil
- "*If non-nil, use minor-mode hook to show status in mode line."
+ "If non-nil, use minor-mode hook to show status in mode line."
:type 'boolean
:group 'cua)
(defcustom cua-check-pending-input t
- "*If non-nil, don't override prefix key if input pending.
+ "If non-nil, don't override prefix key if input pending.
It is rumoured that `input-pending-p' is unreliable under some window
managers, so try setting this to nil, if prefix override doesn't work."
:type 'boolean
:group 'cua)
(defcustom cua-paste-pop-rotate-temporarily nil
- "*If non-nil, \\[cua-paste-pop] only rotates the kill-ring temporarily.
+ "If non-nil, \\[cua-paste-pop] only rotates the kill-ring temporarily.
This means that both \\[yank] and the first \\[yank-pop] in a sequence always insert
the most recently killed text. Each immediately following \\[cua-paste-pop] replaces
the previous text with the next older element on the `kill-ring'.
@@ -388,7 +387,7 @@ recent \\[yank-pop] (or \\[yank]) command."
;;; Rectangle Customization
(defcustom cua-virtual-rectangle-edges t
- "*If non-nil, rectangles have virtual straight edges.
+ "If non-nil, rectangles have virtual straight edges.
Note that although rectangles are always DISPLAYED with straight edges, the
buffer is NOT modified, until you execute a command that actually modifies it.
M-p toggles this feature when a rectangle is active."
@@ -396,7 +395,7 @@ M-p toggles this feature when a rectangle is active."
:group 'cua)
(defcustom cua-auto-tabify-rectangles 1000
- "*If non-nil, automatically tabify after rectangle commands.
+ "If non-nil, automatically tabify after rectangle commands.
This basically means that `tabify' is applied to all lines that
are modified by inserting or deleting a rectangle. If value is
an integer, CUA will look for existing tabs in a region around
@@ -428,7 +427,7 @@ and after the region marked by the rectangle to search."
:group 'cua)
(defcustom cua-rectangle-modifier-key 'meta
- "*Modifier key used for rectangle commands bindings.
+ "Modifier key used for rectangle commands bindings.
On non-window systems, always use the meta modifier.
Must be set prior to enabling CUA."
:type '(choice (const :tag "Meta key" meta)
@@ -438,27 +437,27 @@ Must be set prior to enabling CUA."
:group 'cua)
(defcustom cua-enable-rectangle-auto-help t
- "*If non-nil, automatically show help for region, rectangle and global mark."
+ "If non-nil, automatically show help for region, rectangle and global mark."
:type 'boolean
:group 'cua)
(defface cua-rectangle
'((default :inherit region)
(((class color)) :foreground "white" :background "maroon"))
- "*Font used by CUA for highlighting the rectangle."
+ "Font used by CUA for highlighting the rectangle."
:group 'cua)
(defface cua-rectangle-noselect
'((default :inherit region)
(((class color)) :foreground "white" :background "dimgray"))
- "*Font used by CUA for highlighting the non-selected rectangle lines."
+ "Font used by CUA for highlighting the non-selected rectangle lines."
:group 'cua)
;;; Global Mark Customization
(defcustom cua-global-mark-keep-visible t
- "*If non-nil, always keep global mark visible in other window."
+ "If non-nil, always keep global mark visible in other window."
:type 'boolean
:group 'cua)
@@ -466,11 +465,11 @@ Must be set prior to enabling CUA."
'((((min-colors 88)(class color)) :foreground "black" :background "yellow1")
(((class color)) :foreground "black" :background "yellow")
(t :bold t))
- "*Font used by CUA for highlighting the global mark."
+ "Font used by CUA for highlighting the global mark."
:group 'cua)
(defcustom cua-global-mark-blink-cursor-interval 0.20
- "*Blink cursor at this interval when global mark is active."
+ "Blink cursor at this interval when global mark is active."
:type '(choice (number :tag "Blink interval")
(const :tag "No blink" nil))
:group 'cua)
@@ -479,7 +478,7 @@ Must be set prior to enabling CUA."
;;; Cursor Indication Customization
(defcustom cua-enable-cursor-indications nil
- "*If non-nil, use different cursor colors for indications."
+ "If non-nil, use different cursor colors for indications."
:type 'boolean
:group 'cua)
@@ -517,7 +516,7 @@ a cons (TYPE . COLOR), then both properties are affected."
:group 'cua)
(defcustom cua-read-only-cursor-color "darkgreen"
- "*Cursor color used in read-only buffers, if non-nil.
+ "Cursor color used in read-only buffers, if non-nil.
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
@@ -541,7 +540,7 @@ a cons (TYPE . COLOR), then both properties are affected."
:group 'cua)
(defcustom cua-overwrite-cursor-color "yellow"
- "*Cursor color used when overwrite mode is set, if non-nil.
+ "Cursor color used when overwrite mode is set, if non-nil.
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
@@ -565,7 +564,7 @@ a cons (TYPE . COLOR), then both properties are affected."
:group 'cua)
(defcustom cua-global-mark-cursor-color "cyan"
- "*Indication for active global mark.
+ "Indication for active global mark.
Will change cursor color to specified color if string.
Only used when `cua-enable-cursor-indications' is non-nil.
@@ -780,6 +779,10 @@ Repeating prefix key when region is active works as a single prefix key."
(setq mark-active nil)
(run-hooks 'deactivate-mark-hook)))
+(defun cua--filter-buffer-noprops (start end)
+ (let ((str (filter-buffer-substring start end)))
+ (set-text-properties 0 (length str) nil str)
+ str))
;; The current register prefix
(defvar cua--register nil)
@@ -1039,8 +1042,7 @@ of text."
(setq s (car u))
(setq s (car u) e (cdr u)))))))
(cond ((and s e (<= s e) (= s (mark t)))
- (setq cua--repeat-replace-text
- (filter-buffer-substring s e nil t)))
+ (setq cua--repeat-replace-text (cua--filter-buffer-noprops s e)))
((and (null s) (eq u elt)) ;; nothing inserted
(setq cua--repeat-replace-text
""))
@@ -1440,6 +1442,8 @@ If ARG is the atom `-', scroll upward by nearly full screen."
;; 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-global-keymap [remap scroll-up-command] 'cua-scroll-up)
+ (define-key cua-global-keymap [remap scroll-down-command] '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)
@@ -1492,6 +1496,8 @@ If ARG is the atom `-', scroll upward by nearly full screen."
(dolist (cmd
'(forward-char backward-char
+ right-char left-char
+ right-word left-word
next-line previous-line
forward-word backward-word
end-of-line beginning-of-line
@@ -1499,6 +1505,7 @@ If ARG is the atom `-', scroll upward by nearly full screen."
move-end-of-line move-beginning-of-line
end-of-buffer beginning-of-buffer
scroll-up scroll-down
+ scroll-up-command scroll-down-command
up-list down-list backward-up-list
end-of-defun beginning-of-defun
forward-sexp backward-sexp
@@ -1629,5 +1636,4 @@ shifted movement key, set `cua-highlight-region-shift-only'."
(provide 'cua-base)
-;; arch-tag: 21fb6289-ba25-4fee-bfdc-f9fb351acf05
;;; cua-base.el ends here
diff --git a/lisp/emulation/cua-gmrk.el b/lisp/emulation/cua-gmrk.el
index 6cb8bfe6e1c..761a3d5ec24 100644
--- a/lisp/emulation/cua-gmrk.el
+++ b/lisp/emulation/cua-gmrk.el
@@ -5,6 +5,7 @@
;; Author: Kim F. Storm <storm@cua.dk>
;; Keywords: keyboard emulations convenience cua mark
+;; Package: cua-base
;; This file is part of GNU Emacs.
@@ -137,7 +138,7 @@ With prefix argument, don't jump to global mark when cancelling it."
(let ((src-buf (current-buffer)))
(save-excursion
(if (equal (marker-buffer cua--global-mark-marker) src-buf)
- (let ((text (filter-buffer-substring start end nil t)))
+ (let ((text (cua--filter-buffer-noprops start end)))
(goto-char (marker-position cua--global-mark-marker))
(insert text))
(set-buffer (marker-buffer cua--global-mark-marker))
@@ -161,7 +162,7 @@ With prefix argument, don't jump to global mark when cancelling it."
(if (and (< start (marker-position cua--global-mark-marker))
(< (marker-position cua--global-mark-marker) end))
(message "Can't move region into itself")
- (let ((text (filter-buffer-substring start end nil t))
+ (let ((text (cua--filter-buffer-noprops start end))
(p1 (copy-marker start))
(p2 (copy-marker end)))
(goto-char (marker-position cua--global-mark-marker))
diff --git a/lisp/emulation/cua-rect.el b/lisp/emulation/cua-rect.el
index a59e0f24c7f..2cbf4438869 100644
--- a/lisp/emulation/cua-rect.el
+++ b/lisp/emulation/cua-rect.el
@@ -5,6 +5,7 @@
;; Author: Kim F. Storm <storm@cua.dk>
;; Keywords: keyboard emulations convenience CUA
+;; Package: cua-base
;; This file is part of GNU Emacs.
@@ -625,7 +626,7 @@ If command is repeated at same position, delete the rectangle."
(if (not (cua--rectangle-virtual-edges))
(cua--rectangle-operation nil nil nil nil nil ; do not tabify
'(lambda (s e l r)
- (setq rect (cons (filter-buffer-substring s e nil t) rect))))
+ (setq rect (cons (cua--filter-buffer-noprops s e) rect))))
(cua--rectangle-operation nil 1 nil nil nil ; do not tabify
'(lambda (s e l r v)
(let ((copy t) (bs 0) (as 0) row)
@@ -643,7 +644,7 @@ If command is repeated at same position, delete the rectangle."
(setq as (- r (max (current-column) l))
e (point)))
(setq row (if (and copy (> e s))
- (filter-buffer-substring s e nil t)
+ (cua--filter-buffer-noprops s e)
""))
(when (> bs 0)
(setq row (concat (make-string bs ?\s) row)))
@@ -1124,12 +1125,12 @@ The length of STRING need not be the same as the rectangle width."
'(lambda (s e l r)
(cond
((re-search-forward "0x\\([0-9a-fA-F]+\\)" e t)
- (let* ((txt (filter-buffer-substring (match-beginning 1) (match-end 1) nil t))
+ (let* ((txt (cua--filter-buffer-noprops (match-beginning 1) (match-end 1)))
(n (string-to-number txt 16))
(fmt (format "0x%%0%dx" (length txt))))
(replace-match (format fmt (+ n increment)))))
((re-search-forward "\\( *-?[0-9]+\\)" e t)
- (let* ((txt (filter-buffer-substring (match-beginning 1) (match-end 1) nil t))
+ (let* ((txt (cua--filter-buffer-noprops (match-beginning 1) (match-end 1)))
(prefix (if (= (aref txt 0) ?0) "0" ""))
(n (string-to-number txt 10))
(fmt (format "%%%s%dd" prefix (length txt))))
@@ -1344,7 +1345,7 @@ With prefix arg, indent to that column."
pad)
(if (bolp)
nil
- (delete-backward-char 1)
+ (delete-char -1)
(if (cua--rectangle-right-side t)
(cua--rectangle-insert-col (current-column))
(setq indent (- l (current-column))))))
@@ -1432,6 +1433,8 @@ With prefix arg, indent to that column."
(define-key cua--rectangle-keymap [remap beginning-of-buffer] 'cua-resize-rectangle-top)
(define-key cua--rectangle-keymap [remap scroll-down] 'cua-resize-rectangle-page-up)
(define-key cua--rectangle-keymap [remap scroll-up] 'cua-resize-rectangle-page-down)
+ (define-key cua--rectangle-keymap [remap scroll-down-command] 'cua-resize-rectangle-page-up)
+ (define-key cua--rectangle-keymap [remap scroll-up-command] 'cua-resize-rectangle-page-down)
(define-key cua--rectangle-keymap [remap delete-backward-char] 'cua-delete-char-rectangle)
(define-key cua--rectangle-keymap [remap backward-delete-char] 'cua-delete-char-rectangle)
diff --git a/lisp/emulation/edt-lk201.el b/lisp/emulation/edt-lk201.el
index 6cce36e42a1..e50e064077d 100644
--- a/lisp/emulation/edt-lk201.el
+++ b/lisp/emulation/edt-lk201.el
@@ -6,6 +6,7 @@
;; Author: Kevin Gallagher <Kevin.Gallagher@boeing.com>
;; Maintainer: Kevin Gallagher <Kevin.Gallagher@boeing.com>
;; Keywords: emulations
+;; Package: edt
;; This file is part of GNU Emacs.
diff --git a/lisp/emulation/edt-mapper.el b/lisp/emulation/edt-mapper.el
index e5c0ceecf1c..6bf50db5442 100644
--- a/lisp/emulation/edt-mapper.el
+++ b/lisp/emulation/edt-mapper.el
@@ -6,6 +6,7 @@
;; Author: Kevin Gallagher <Kevin.Gallagher@boeing.com>
;; Maintainer: Kevin Gallagher <Kevin.Gallagher@boeing.com>
;; Keywords: emulations
+;; Package: edt
;; This file is part of GNU Emacs.
diff --git a/lisp/emulation/edt-pc.el b/lisp/emulation/edt-pc.el
index 0cd421620ab..04128ac00b9 100644
--- a/lisp/emulation/edt-pc.el
+++ b/lisp/emulation/edt-pc.el
@@ -6,6 +6,7 @@
;; Author: Kevin Gallagher <Kevin.Gallagher@boeing.com>
;; Maintainer: Kevin Gallagher <Kevin.Gallagher@boeing.com>
;; Keywords: emulations
+;; Package: edt
;; This file is part of GNU Emacs.
diff --git a/lisp/emulation/edt-vt100.el b/lisp/emulation/edt-vt100.el
index f14bdfc79cb..9416a9ad48a 100644
--- a/lisp/emulation/edt-vt100.el
+++ b/lisp/emulation/edt-vt100.el
@@ -6,6 +6,7 @@
;; Author: Kevin Gallagher <Kevin.Gallagher@boeing.com>
;; Maintainer: Kevin Gallagher <Kevin.Gallagher@boeing.com>
;; Keywords: emulations
+;; Package: edt
;; This file is part of GNU Emacs.
diff --git a/lisp/emulation/edt.el b/lisp/emulation/edt.el
index 2abde59af90..bfed09e0df3 100644
--- a/lisp/emulation/edt.el
+++ b/lisp/emulation/edt.el
@@ -1,7 +1,8 @@
-;;; edt.el --- enhanced EDT keypad mode emulation for GNU Emacs 19
+;;; edt.el --- enhanced EDT keypad mode emulation for GNU Emacs
;; Copyright (C) 1986, 1992, 1993, 1994, 1995, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Kevin Gallagher <Kevin.Gallagher@boeing.com>
;; Maintainer: Kevin Gallagher <Kevin.Gallagher@boeing.com>
@@ -27,7 +28,7 @@
;;; Commentary:
;;
-;; This is Version 4.0 of the EDT Emulation for Emacs 19 and above.
+;; This is Version 4.0 of the EDT Emulation for Emacs.
;; It comes with special functions which replicate nearly all of EDT's
;; keypad mode behavior. It sets up default keypad and function key
;; bindings which closely match those found in EDT. Support is
@@ -88,8 +89,8 @@
;; settings for that session.
;;
;; NOTE: Another way to set the scroll margins is to use the
-;; Emacs customization feature (not available in Emacs 19) to set
-;; the following two variables directly:
+;; Emacs customization feature to set the following two variables
+;; directly:
;;
;; edt-top-scroll-margin and edt-bottom-scroll-margin
;;
@@ -193,7 +194,7 @@
;;;
(defcustom edt-keep-current-page-delimiter nil
- "*Emacs MUST be restarted for a change in value to take effect!
+ "Emacs MUST be restarted for a change in value to take effect!
Non-nil leaves Emacs value of `page-delimiter' unchanged within EDT
Emulation. If set to nil (the default), the `page-delimiter' variable
is set to \"\\f\" when edt-emulation-on is first invoked. This
@@ -203,7 +204,7 @@ is restored when edt-emulation-off is called."
:group 'edt)
(defcustom edt-use-EDT-control-key-bindings nil
- "*Emacs MUST be restarted for a change in value to take effect!
+ "Emacs MUST be restarted for a change in value to take effect!
Non-nil causes the control key bindings to be replaced with EDT
bindings. If set to nil (the default), EDT control key bindings are
not used and the current Emacs control key bindings are retained for
@@ -212,7 +213,7 @@ use within the EDT emulation."
:group 'edt)
(defcustom edt-word-entities '(?\t)
- "*Specifies the list of EDT word entity characters.
+ "Specifies the list of EDT word entity characters.
The default list, (\?\\t), contains just the TAB character, which
emulates EDT. Characters are specified in the list using their
decimal ASCII values. A question mark, followed by the actual
@@ -237,14 +238,14 @@ will be treated as if it were a separate word."
:group 'edt)
(defcustom edt-top-scroll-margin 10
- "*Scroll margin at the top of the screen.
+ "Scroll margin at the top of the screen.
Interpreted as a percent of the current window size with a default
setting of 10%. If set to 0, top scroll margin is disabled."
:type 'integer
:group 'edt)
(defcustom edt-bottom-scroll-margin 15
- "*Scroll margin at the bottom of the screen.
+ "Scroll margin at the bottom of the screen.
Interpreted as a percent of the current window size with a default
setting of 15%. If set to 0, bottom scroll margin is disabled."
:type 'integer
@@ -666,6 +667,25 @@ Argument NUM is the number of lines to move."
(goto-char (point-max))
(edt-line-to-bottom-of-window))
+(defmacro edt-with-position (&rest body)
+ "Execute BODY with some position-related variables bound."
+ `(let* ((left nil)
+ (beg (edt-current-line))
+ (height (window-height))
+ (top-percent
+ (if (zerop edt-top-scroll-margin) 10 edt-top-scroll-margin))
+ (bottom-percent
+ (if (zerop edt-bottom-scroll-margin) 15 edt-bottom-scroll-margin))
+ (top-margin (/ (* height top-percent) 100))
+ (bottom-up-margin (1+ (/ (* height bottom-percent) 100)))
+ (bottom-margin (max beg (- height bottom-up-margin 1)))
+ (top (save-excursion (move-to-window-line top-margin) (point)))
+ (bottom (save-excursion (move-to-window-line bottom-margin) (point)))
+ (far (save-excursion
+ (goto-char bottom)
+ (point-at-bol (1- height)))))
+ ,@body))
+
;;;
;;; FIND
;;;
@@ -674,57 +694,29 @@ Argument NUM is the number of lines to move."
"Find first occurrence of a string in forward direction and save it.
Optional argument FIND is t is this function is called from `edt-find'."
(interactive)
- (if (not find)
- (set 'edt-find-last-text (read-string "Search forward: ")))
- (let* ((left nil)
- (beg (edt-current-line))
- (height (window-height))
- (top-percent
- (if (= 0 edt-top-scroll-margin) 10 edt-top-scroll-margin))
- (bottom-percent
- (if (= 0 edt-bottom-scroll-margin) 15 edt-bottom-scroll-margin))
- (top-margin (/ (* height top-percent) 100))
- (bottom-up-margin (+ 1 (/ (* height bottom-percent) 100)))
- (bottom-margin (max beg (- height bottom-up-margin 1)))
- (top (save-excursion (move-to-window-line top-margin) (point)))
- (bottom (save-excursion (move-to-window-line bottom-margin) (point)))
- (far (save-excursion
- (goto-char bottom) (forward-line (- height 2)) (point))))
- (if (search-forward edt-find-last-text)
- (progn
- (search-backward edt-find-last-text)
- (edt-set-match)
- (cond((> (point) far)
- (setq left (save-excursion (forward-line height)))
- (if (= 0 left) (recenter top-margin)
- (recenter (- left bottom-up-margin))))
- (t
- (and (> (point) bottom) (recenter bottom-margin)))))))
+ (or find
+ (setq edt-find-last-text (read-string "Search forward: ")))
+ (edt-with-position
+ (when (search-forward edt-find-last-text) ; FIXME noerror?
+ (search-backward edt-find-last-text)
+ (edt-set-match)
+ (if (> (point) far)
+ (if (zerop (setq left (save-excursion (forward-line height))))
+ (recenter top-margin)
+ (recenter (- left bottom-up-margin)))
+ (and (> (point) bottom) (recenter bottom-margin)))))
(if (featurep 'xemacs) (setq zmacs-region-stays t)))
(defun edt-find-backward (&optional find)
"Find first occurrence of a string in the backward direction and save it.
Optional argument FIND is t if this function is called from `edt-find'."
(interactive)
- (if (not find)
- (set 'edt-find-last-text (read-string "Search backward: ")))
- (let* ((left nil)
- (beg (edt-current-line))
- (height (window-height))
- (top-percent
- (if (= 0 edt-top-scroll-margin) 10 edt-top-scroll-margin))
- (bottom-percent
- (if (= 0 edt-bottom-scroll-margin) 15 edt-bottom-scroll-margin))
- (top-margin (/ (* height top-percent) 100))
- (bottom-up-margin (+ 1 (/ (* height bottom-percent) 100)))
- (bottom-margin (max beg (- height bottom-up-margin 1)))
- (top (save-excursion (move-to-window-line top-margin) (point)))
- (bottom (save-excursion (move-to-window-line bottom-margin) (point)))
- (far (save-excursion
- (goto-char bottom) (forward-line (- height 2)) (point))))
- (if (search-backward edt-find-last-text)
- (edt-set-match))
- (and (< (point) top) (recenter (min beg top-margin))))
+ (or find
+ (setq edt-find-last-text (read-string "Search backward: ")))
+ (edt-with-position
+ (if (search-backward edt-find-last-text)
+ (edt-set-match))
+ (and (< (point) top) (recenter (min beg top-margin))))
(if (featurep 'xemacs) (setq zmacs-region-stays t)))
(defun edt-find ()
@@ -743,58 +735,29 @@ Optional argument FIND is t if this function is called from `edt-find'."
(defun edt-find-next-forward ()
"Find next occurrence of a string in forward direction."
(interactive)
- (let* ((left nil)
- (beg (edt-current-line))
- (height (window-height))
- (top-percent
- (if (= 0 edt-top-scroll-margin) 10 edt-top-scroll-margin))
- (bottom-percent
- (if (= 0 edt-bottom-scroll-margin) 15 edt-bottom-scroll-margin))
- (top-margin (/ (* height top-percent) 100))
- (bottom-up-margin (+ 1 (/ (* height bottom-percent) 100)))
- (bottom-margin (max beg (- height bottom-up-margin 1)))
- (top (save-excursion (move-to-window-line top-margin) (point)))
- (bottom (save-excursion (move-to-window-line bottom-margin) (point)))
- (far (save-excursion
- (goto-char bottom) (forward-line (- height 2)) (point))))
- (forward-char 1)
- (if (search-forward edt-find-last-text nil t)
- (progn
- (search-backward edt-find-last-text)
- (edt-set-match)
- (cond((> (point) far)
- (setq left (save-excursion (forward-line height)))
- (if (= 0 left) (recenter top-margin)
- (recenter (- left bottom-up-margin))))
- (t
- (and (> (point) bottom) (recenter bottom-margin)))))
- (progn
- (backward-char 1)
- (error "Search failed: \"%s\"" edt-find-last-text))))
+ (edt-with-position
+ (forward-char 1)
+ (if (search-forward edt-find-last-text nil t)
+ (progn
+ (search-backward edt-find-last-text)
+ (edt-set-match)
+ (if (> (point) far)
+ (if (zerop (setq left (save-excursion (forward-line height))))
+ (recenter top-margin)
+ (recenter (- left bottom-up-margin)))
+ (and (> (point) bottom) (recenter bottom-margin))))
+ (backward-char 1)
+ (error "Search failed: \"%s\"" edt-find-last-text)))
(if (featurep 'xemacs) (setq zmacs-region-stays t)))
(defun edt-find-next-backward ()
"Find next occurrence of a string in backward direction."
(interactive)
- (let* ((left nil)
- (beg (edt-current-line))
- (height (window-height))
- (top-percent
- (if (= 0 edt-top-scroll-margin) 10 edt-top-scroll-margin))
- (bottom-percent
- (if (= 0 edt-bottom-scroll-margin) 15 edt-bottom-scroll-margin))
- (top-margin (/ (* height top-percent) 100))
- (bottom-up-margin (+ 1 (/ (* height bottom-percent) 100)))
- (bottom-margin (max beg (- height bottom-up-margin 1)))
- (top (save-excursion (move-to-window-line top-margin) (point)))
- (bottom (save-excursion (move-to-window-line bottom-margin) (point)))
- (far (save-excursion
- (goto-char bottom) (forward-line (- height 2)) (point))))
- (if (not (search-backward edt-find-last-text nil t))
- (error "Search failed: \"%s\"" edt-find-last-text)
- (progn
- (edt-set-match)
- (and (< (point) top) (recenter (min beg top-margin))))))
+ (edt-with-position
+ (if (not (search-backward edt-find-last-text nil t))
+ (error "Search failed: \"%s\"" edt-find-last-text)
+ (edt-set-match)
+ (and (< (point) top) (recenter (min beg top-margin)))))
(if (featurep 'xemacs) (setq zmacs-region-stays t)))
(defun edt-find-next ()
@@ -858,8 +821,7 @@ Argument NUM is the number of lines to delete."
In select mode, selected text is highlighted."
(if arg
(progn
- (make-local-variable 'edt-select-mode)
- (setq edt-select-mode 'edt-select-mode-current)
+ (set (make-local-variable 'edt-select-mode) 'edt-select-mode-current)
(setq rect-start-point (window-point)))
(progn
(kill-local-variable 'edt-select-mode)))
@@ -1318,33 +1280,17 @@ Argument BOTTOM is the bottom margin in number of lines or percent of window."
Argument NUM is the positive number of sentences to move."
(interactive "p")
(edt-check-prefix num)
- (let* ((left nil)
- (beg (edt-current-line))
- (height (window-height))
- (top-percent
- (if (= 0 edt-top-scroll-margin) 10 edt-top-scroll-margin))
- (bottom-percent
- (if (= 0 edt-bottom-scroll-margin) 15 edt-bottom-scroll-margin))
- (top-margin (/ (* height top-percent) 100))
- (bottom-up-margin (+ 1 (/ (* height bottom-percent) 100)))
- (bottom-margin (max beg (- height bottom-up-margin 1)))
- (top (save-excursion (move-to-window-line top-margin) (point)))
- (bottom (save-excursion (move-to-window-line bottom-margin) (point)))
- (far (save-excursion
- (goto-char bottom) (forward-line (- height 2)) (point))))
- (if (eobp)
- (progn
- (error "End of buffer"))
- (progn
- (forward-sentence num)
- (forward-word 1)
- (backward-sentence)))
- (cond((> (point) far)
- (setq left (save-excursion (forward-line height)))
- (if (= 0 left) (recenter top-margin)
- (recenter (- left bottom-up-margin))))
- (t
- (and (> (point) bottom) (recenter bottom-margin)))))
+ (edt-with-position
+ (if (eobp)
+ (error "End of buffer")
+ (forward-sentence num)
+ (forward-word 1)
+ (backward-sentence))
+ (if (> (point) far)
+ (if (zerop (setq left (save-excursion (forward-line height))))
+ (recenter top-margin)
+ (recenter (- left bottom-up-margin)))
+ (and (> (point) bottom) (recenter bottom-margin))))
(if (featurep 'xemacs) (setq zmacs-region-stays t)))
(defun edt-sentence-backward (num)
@@ -1352,25 +1298,11 @@ Argument NUM is the positive number of sentences to move."
Argument NUM is the positive number of sentences to move."
(interactive "p")
(edt-check-prefix num)
- (let* ((left nil)
- (beg (edt-current-line))
- (height (window-height))
- (top-percent
- (if (= 0 edt-top-scroll-margin) 10 edt-top-scroll-margin))
- (bottom-percent
- (if (= 0 edt-bottom-scroll-margin) 15 edt-bottom-scroll-margin))
- (top-margin (/ (* height top-percent) 100))
- (bottom-up-margin (+ 1 (/ (* height bottom-percent) 100)))
- (bottom-margin (max beg (- height bottom-up-margin 1)))
- (top (save-excursion (move-to-window-line top-margin) (point)))
- (bottom (save-excursion (move-to-window-line bottom-margin) (point)))
- (far (save-excursion
- (goto-char bottom) (forward-line (- height 2)) (point))))
- (if (eobp)
- (progn
- (error "End of buffer"))
- (backward-sentence num))
- (and (< (point) top) (recenter (min beg top-margin))))
+ (edt-with-position
+ (if (eobp)
+ (error "End of buffer")
+ (backward-sentence num))
+ (and (< (point) top) (recenter (min beg top-margin))))
(if (featurep 'xemacs) (setq zmacs-region-stays t)))
(defun edt-sentence (num)
@@ -1390,32 +1322,18 @@ Argument NUM is the positive number of sentences to move."
Argument NUM is the positive number of paragraphs to move."
(interactive "p")
(edt-check-prefix num)
- (let* ((left nil)
- (beg (edt-current-line))
- (height (window-height))
- (top-percent
- (if (= 0 edt-top-scroll-margin) 10 edt-top-scroll-margin))
- (bottom-percent
- (if (= 0 edt-bottom-scroll-margin) 15 edt-bottom-scroll-margin))
- (top-margin (/ (* height top-percent) 100))
- (bottom-up-margin (+ 1 (/ (* height bottom-percent) 100)))
- (bottom-margin (max beg (- height bottom-up-margin 1)))
- (top (save-excursion (move-to-window-line top-margin) (point)))
- (bottom (save-excursion (move-to-window-line bottom-margin) (point)))
- (far (save-excursion
- (goto-char bottom) (forward-line (- height 2)) (point))))
- (while (> num 0)
- (forward-paragraph (+ num 1))
- (start-of-paragraph-text)
- (if (eolp)
- (forward-line 1))
- (setq num (1- num)))
- (cond((> (point) far)
- (setq left (save-excursion (forward-line height)))
- (if (= 0 left) (recenter top-margin)
- (recenter (- left bottom-up-margin))))
- (t
- (and (> (point) bottom) (recenter bottom-margin)))))
+ (edt-with-position
+ (while (> num 0)
+ (forward-paragraph (+ num 1))
+ (start-of-paragraph-text)
+ (if (eolp)
+ (forward-line 1))
+ (setq num (1- num)))
+ (if (> (point) far)
+ (if (zerop (setq left (save-excursion (forward-line height))))
+ (recenter top-margin)
+ (recenter (- left bottom-up-margin)))
+ (and (> (point) bottom) (recenter bottom-margin))))
(if (featurep 'xemacs) (setq zmacs-region-stays t)))
(defun edt-paragraph-backward (num)
@@ -1423,24 +1341,11 @@ Argument NUM is the positive number of paragraphs to move."
Argument NUM is the positive number of paragraphs to move."
(interactive "p")
(edt-check-prefix num)
- (let* ((left nil)
- (beg (edt-current-line))
- (height (window-height))
- (top-percent
- (if (= 0 edt-top-scroll-margin) 10 edt-top-scroll-margin))
- (bottom-percent
- (if (= 0 edt-bottom-scroll-margin) 15 edt-bottom-scroll-margin))
- (top-margin (/ (* height top-percent) 100))
- (bottom-up-margin (+ 1 (/ (* height bottom-percent) 100)))
- (bottom-margin (max beg (- height bottom-up-margin 1)))
- (top (save-excursion (move-to-window-line top-margin) (point)))
- (bottom (save-excursion (move-to-window-line bottom-margin) (point)))
- (far (save-excursion
- (goto-char bottom) (forward-line (- height 2)) (point))))
- (while (> num 0)
- (start-of-paragraph-text)
- (setq num (1- num)))
- (and (< (point) top) (recenter (min beg top-margin))))
+ (edt-with-position
+ (while (> num 0)
+ (start-of-paragraph-text)
+ (setq num (1- num)))
+ (and (< (point) top) (recenter (min beg top-margin))))
(if (featurep 'xemacs) (setq zmacs-region-stays t)))
(defun edt-paragraph (num)
@@ -2057,40 +1962,32 @@ created."
Ack!! You're running the Enhanced EDT Emulation without loading an
EDT key mapping file. To create an EDT key mapping file, run the
- edt-mapper.el program. It is safest to run it from an Emacs loaded
+ edt-mapper program. It is safest to run it from an Emacs loaded
without any of your own customizations found in your .emacs file, etc.
The reason for this is that some user customizations confuse edt-mapper.
You can do this by quitting Emacs and then invoking Emacs again as
follows:
- emacs -q -l edt-mapper.el
+ emacs -q -l edt-mapper
[NOTE: If you do nothing out of the ordinary in your .emacs file, and
- the search for edt-mapper.el is successful, you can try running it now.]
+ the search for edt-mapper is successful, you can try running it now.]
- The file edt-mapper.el includes these same directions on how to
+ The library edt-mapper includes these same directions on how to
use it! Perhaps it's lying around here someplace. \n ")
- (let ((file "edt-mapper.el")
- (found nil)
- (path nil)
- (search-list (append (list (expand-file-name ".")) load-path)))
- (while (and (not found) search-list)
- (setq path (concat (car search-list)
- (if (string-match "/$" (car search-list)) "" "/")
- file))
- (if (and (file-exists-p path) (not (file-directory-p path)))
- (setq found t))
- (setq search-list (cdr search-list)))
- (cond (found
- (insert (format
- "Ah yes, there it is, in \n\n %s \n\n" path))
- (if (edt-y-or-n-p "Do you want to run it now? ")
- (load-file path)
- (error "EDT Emulation not configured")))
- (t
- (insert "Nope, I can't seem to find it. :-(\n\n")
- (sit-for 20)
- (error "EDT Emulation not configured")))))))
+ (let ((path (locate-library
+ "edt-mapper"
+ nil (append (list default-directory) load-path))))
+ (if path
+ (progn
+ (insert (format
+ "Ah yes, there it is, in \n\n %s \n\n" path))
+ (if (edt-y-or-n-p "Do you want to run it now? ")
+ (load-file path)
+ (error "EDT Emulation not configured")))
+ (insert "Nope, I can't seem to find it. :-(\n\n")
+ (sit-for 20)
+ (error "EDT Emulation not configured"))))))
;;;
;;; Turning the EDT Emulation on and off.
@@ -2571,12 +2468,12 @@ Argument GOLD-BINDING is the Emacs function to be bound to GOLD <KEY>."
;;; DEFAULT EDT KEYPAD HELP
;;;
-;;;
-;;; Upper case commands in the keypad diagram below indicate that the
-;;; emulation should look and feel very much like EDT. Lower case
-;;; commands are enhancements and/or additions to the EDT keypad
-;;; commands or are native Emacs commands.
-;;;
+;;
+;; Upper case commands in the keypad diagram below indicate that the
+;; emulation should look and feel very much like EDT. Lower case
+;; commands are enhancements and/or additions to the EDT keypad
+;; commands or are native Emacs commands.
+;;
(defun edt-keypad-help ()
"DEFAULT EDT Keypad Active.
@@ -2685,7 +2582,7 @@ G-C-\\: Split Window | FNDNXT | Yank | CUT |
;;;
;;; EDT emulation screen width commands.
-;;;
+;;
;; Some terminals require modification of terminal attributes when
;; changing the number of columns displayed, hence the fboundp tests
;; below. These functions are defined in the corresponding terminal
@@ -2709,5 +2606,4 @@ G-C-\\: Split Window | FNDNXT | Yank | CUT |
(provide 'edt)
-;; arch-tag: 18d1c54f-6900-4078-8bbc-7c2292f48941
;;; edt.el ends here
diff --git a/lisp/emulation/pc-select.el b/lisp/emulation/pc-select.el
index 22983f49694..8dcdb991ab2 100644
--- a/lisp/emulation/pc-select.el
+++ b/lisp/emulation/pc-select.el
@@ -82,11 +82,10 @@
(defgroup pc-select nil
"Emulate pc bindings."
:prefix "pc-select"
- :group 'editing-basics
- :group 'convenience)
+ :group 'emulations)
(defcustom pc-select-override-scroll-error t
- "*Non-nil means don't generate error on scrolling past edge of buffer.
+ "Non-nil means don't generate error on scrolling past edge of buffer.
This variable applies in PC Selection mode only.
The scroll commands normally generate an error if you try to scroll
past the top or bottom of the buffer. This is annoying when selecting
@@ -94,16 +93,19 @@ text with these commands. If you set this variable to non-nil, these
errors are suppressed."
:type 'boolean
:group 'pc-select)
+(define-obsolete-variable-alias 'pc-select-override-scroll-error
+ 'scroll-error-top-bottom
+ "24.1")
(defcustom pc-select-selection-keys-only nil
- "*Non-nil means only bind the basic selection keys when started.
+ "Non-nil means only bind the basic selection keys when started.
Other keys that emulate pc-behavior will be untouched.
This gives mostly Emacs-like behavior with only the selection keys enabled."
:type 'boolean
:group 'pc-select)
(defcustom pc-select-meta-moves-sexps nil
- "*Non-nil means move sexp-wise with Meta key, otherwise move word-wise."
+ "Non-nil means move sexp-wise with Meta key, otherwise move word-wise."
:type 'boolean
:group 'pc-select)
diff --git a/lisp/emulation/tpu-edt.el b/lisp/emulation/tpu-edt.el
index c5dd9b3cf32..f77cf23d81e 100644
--- a/lisp/emulation/tpu-edt.el
+++ b/lisp/emulation/tpu-edt.el
@@ -2438,7 +2438,7 @@ If FILE is nil, try to load a default file. The default file names are
;;;### (autoloads (tpu-set-cursor-bound tpu-set-cursor-free tpu-set-scroll-margins
-;;;;;; tpu-cursor-free-mode) "tpu-extras" "tpu-extras.el" "d003e4c2f1291eccc629926bb0f88e17")
+;;;;;; tpu-cursor-free-mode) "tpu-extras" "tpu-extras.el" "fe5b7795d6b6720a98b805ee47a08bdf")
;;; Generated autoloads from tpu-extras.el
(autoload 'tpu-cursor-free-mode "tpu-extras" "\
diff --git a/lisp/emulation/tpu-extras.el b/lisp/emulation/tpu-extras.el
index 2fc9ce516f5..311b8e2516d 100644
--- a/lisp/emulation/tpu-extras.el
+++ b/lisp/emulation/tpu-extras.el
@@ -6,6 +6,7 @@
;; Author: Rob Riepel <riepel@networking.stanford.edu>
;; Maintainer: Rob Riepel <riepel@networking.stanford.edu>
;; Keywords: emulations
+;; Package: tpu-edt
;; This file is part of GNU Emacs.
@@ -275,36 +276,41 @@ Prefix argument serves as repeat count."
;;; Movement by paragraph
+;; Cf edt-with-position.
+(defmacro tpu-with-position (&rest body)
+ "Execute BODY with some position-related variables bound."
+ `(let* ((left nil)
+ (beg (tpu-current-line))
+ (height (window-height))
+ (top-percent
+ (if (zerop tpu-top-scroll-margin) 10 tpu-top-scroll-margin))
+ (bottom-percent
+ (if (zerop tpu-bottom-scroll-margin) 15 tpu-bottom-scroll-margin))
+ (top-margin (/ (* height top-percent) 100))
+ (bottom-up-margin (1+ (/ (* height bottom-percent) 100)))
+ (bottom-margin (max beg (- height bottom-up-margin 1)))
+ (top (save-excursion (move-to-window-line top-margin) (point)))
+ (bottom (save-excursion (move-to-window-line bottom-margin) (point)))
+ (far (save-excursion
+ (goto-char bottom)
+ (point-at-bol (1- height)))))
+ ,@body))
+
(defun tpu-paragraph (num)
"Move to the next paragraph in the current direction.
A repeat count means move that many paragraphs."
(interactive "p")
- (let* ((left nil)
- (beg (tpu-current-line))
- (height (window-height))
- (top-percent
- (if (= 0 tpu-top-scroll-margin) 10 tpu-top-scroll-margin))
- (bottom-percent
- (if (= 0 tpu-bottom-scroll-margin) 15 tpu-bottom-scroll-margin))
- (top-margin (/ (* height top-percent) 100))
- (bottom-up-margin (+ 1 (/ (* height bottom-percent) 100)))
- (bottom-margin (max beg (- height bottom-up-margin 1)))
- (top (save-excursion (move-to-window-line top-margin) (point)))
- (bottom (save-excursion (move-to-window-line bottom-margin) (point)))
- (far (save-excursion
- (goto-char bottom) (forward-line (- height 2)) (point))))
- (cond (tpu-advance
- (tpu-next-paragraph num)
- (cond((> (point) far)
- (setq left (save-excursion (forward-line height)))
- (if (= 0 left) (recenter top-margin)
- (recenter (- left bottom-up-margin))))
- (t
- (and (> (point) bottom) (recenter bottom-margin)))))
- (t
- (tpu-previous-paragraph num)
- (and (< (point) top) (recenter (min beg top-margin)))))))
-
+ (tpu-with-position
+ (if tpu-advance
+ (progn
+ (tpu-next-paragraph num)
+ (if (> (point) far)
+ (if (zerop (setq left (save-excursion (forward-line height))))
+ (recenter top-margin)
+ (recenter (- left bottom-up-margin)))
+ (and (> (point) bottom) (recenter bottom-margin))))
+ (tpu-previous-paragraph num)
+ (and (< (point) top) (recenter (min beg top-margin))))))
;;; Movement by page
@@ -312,32 +318,17 @@ A repeat count means move that many paragraphs."
"Move to the next page in the current direction.
A repeat count means move that many pages."
(interactive "p")
- (let* ((left nil)
- (beg (tpu-current-line))
- (height (window-height))
- (top-percent
- (if (= 0 tpu-top-scroll-margin) 10 tpu-top-scroll-margin))
- (bottom-percent
- (if (= 0 tpu-bottom-scroll-margin) 15 tpu-bottom-scroll-margin))
- (top-margin (/ (* height top-percent) 100))
- (bottom-up-margin (+ 1 (/ (* height bottom-percent) 100)))
- (bottom-margin (max beg (- height bottom-up-margin 1)))
- (top (save-excursion (move-to-window-line top-margin) (point)))
- (bottom (save-excursion (move-to-window-line bottom-margin) (point)))
- (far (save-excursion
- (goto-char bottom) (forward-line (- height 2)) (point))))
- (cond (tpu-advance
- (forward-page num)
- (cond((> (point) far)
- (setq left (save-excursion (forward-line height)))
- (if (= 0 left) (recenter top-margin)
- (recenter (- left bottom-up-margin))))
- (t
- (and (> (point) bottom) (recenter bottom-margin)))))
- (t
- (backward-page num)
- (and (< (point) top) (recenter (min beg top-margin)))))))
-
+ (tpu-with-position
+ (if tpu-advance
+ (progn
+ (forward-page num)
+ (if (> (point) far)
+ (if (zerop (setq left (save-excursion (forward-line height))))
+ (recenter top-margin)
+ (recenter (- left bottom-up-margin)))
+ (and (> (point) bottom) (recenter bottom-margin))))
+ (backward-page num)
+ (and (< (point) top) (recenter (min beg top-margin))))))
;;; Scrolling
@@ -366,31 +357,16 @@ A repeat count means scroll that many sections."
(defun tpu-search-internal (pat &optional quiet)
"Search for a string or regular expression."
- (let* ((left nil)
- (beg (tpu-current-line))
- (height (window-height))
- (top-percent
- (if (= 0 tpu-top-scroll-margin) 10 tpu-top-scroll-margin))
- (bottom-percent
- (if (= 0 tpu-bottom-scroll-margin) 15 tpu-bottom-scroll-margin))
- (top-margin (/ (* height top-percent) 100))
- (bottom-up-margin (+ 1 (/ (* height bottom-percent) 100)))
- (bottom-margin (max beg (- height bottom-up-margin 1)))
- (top (save-excursion (move-to-window-line top-margin) (point)))
- (bottom (save-excursion (move-to-window-line bottom-margin) (point)))
- (far (save-excursion
- (goto-char bottom) (forward-line (- height 2)) (point))))
- (tpu-search-internal-core pat quiet)
- (if tpu-searching-forward
- (cond((> (point) far)
- (setq left (save-excursion (forward-line height)))
- (if (= 0 left) (recenter top-margin)
- (recenter (- left bottom-up-margin))))
- (t
- (and (> (point) bottom) (recenter bottom-margin))))
- (and (< (point) top) (recenter (min beg top-margin))))))
-
-
+ (tpu-with-position
+ (tpu-search-internal-core pat quiet)
+ (if tpu-searching-forward
+ (progn
+ (if (> (point) far)
+ (if (zerop (setq left (save-excursion (forward-line height))))
+ (recenter top-margin)
+ (recenter (- left bottom-up-margin)))
+ (and (> (point) bottom) (recenter bottom-margin))))
+ (and (< (point) top) (recenter (min beg top-margin))))))
;; Advise the newline, newline-and-indent, and do-auto-fill functions.
(defadvice newline (around tpu-respect-bottom-scroll-margin activate disable)
@@ -462,5 +438,4 @@ A repeat count means scroll that many sections."
;; generated-autoload-file: "tpu-edt.el"
;; End:
-;; arch-tag: 89676fa4-33ec-48cb-9135-6f3bf230ab1a
;;; tpu-extras.el ends here
diff --git a/lisp/emulation/tpu-mapper.el b/lisp/emulation/tpu-mapper.el
index ed42824a8bb..b4942564eba 100644
--- a/lisp/emulation/tpu-mapper.el
+++ b/lisp/emulation/tpu-mapper.el
@@ -6,6 +6,7 @@
;; Author: Rob Riepel <riepel@networking.stanford.edu>
;; Maintainer: Rob Riepel <riepel@networking.stanford.edu>
;; Keywords: emulations
+;; Package: tpu-edt
;; This file is part of GNU Emacs.
diff --git a/lisp/emulation/vip.el b/lisp/emulation/vip.el
index 4839e07bc1c..0474ba7c679 100644
--- a/lisp/emulation/vip.el
+++ b/lisp/emulation/vip.el
@@ -91,12 +91,12 @@
"How to reexecute last destructive command. Value is list (M-COM VAL COM).")
(defcustom vip-shift-width 8
- "*The number of columns shifted by > and < command."
+ "The number of columns shifted by > and < command."
:type 'integer
:group 'vip)
(defcustom vip-re-replace nil
- "*If t then do regexp replace, if nil then do string replace."
+ "If t then do regexp replace, if nil then do string replace."
:type 'boolean
:group 'vip)
@@ -116,12 +116,12 @@
"For use by \";\" command.")
(defcustom vip-search-wrap-around t
- "*If t, search wraps around."
+ "If t, search wraps around."
:type 'boolean
:group 'vip)
(defcustom vip-re-search nil
- "*If t, search is reg-exp search, otherwise vanilla search."
+ "If t, search is reg-exp search, otherwise vanilla search."
:type 'boolean
:group 'vip)
@@ -132,22 +132,22 @@
"If t, search is forward.")
(defcustom vip-case-fold-search nil
- "*If t, search ignores cases."
+ "If t, search ignores cases."
:type 'boolean
:group 'vip)
(defcustom vip-re-query-replace nil
- "*If t then do regexp replace, if nil then do string replace."
+ "If t then do regexp replace, if nil then do string replace."
:type 'boolean
:group 'vip)
(defcustom vip-open-with-indent nil
- "*If t, indent when open a new line."
+ "If t, indent when open a new line."
:type 'boolean
:group 'vip)
(defcustom vip-help-in-insert-mode nil
- "*If t then C-h is bound to help-command in insert mode.
+ "If t then C-h is bound to help-command in insert mode.
If nil then it is bound to `delete-backward-char'."
:type 'boolean
:group 'vip)
diff --git a/lisp/emulation/viper-cmd.el b/lisp/emulation/viper-cmd.el
index 8c216d9aca6..4e90889ddd0 100644
--- a/lisp/emulation/viper-cmd.el
+++ b/lisp/emulation/viper-cmd.el
@@ -1,9 +1,10 @@
;;; viper-cmd.el --- Vi command support for Viper
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: viper
;; This file is part of GNU Emacs.
@@ -41,7 +42,7 @@
(defvar quail-current-str)
(defvar mark-even-if-inactive)
(defvar init-message)
-(defvar initial)
+(defvar viper-initial)
(defvar undo-beg-posn)
(defvar undo-end-posn)
@@ -2064,23 +2065,22 @@ Undo previous insertion and inserts new."
(funcall hook)
))
-;; Thie is a temp hook that uses free variables init-message and initial.
+;; This is a temp hook that uses free variables init-message and viper-initial.
;; A dirty feature, but it is the simplest way to have it do the right thing.
-;; The INIT-MESSAGE and INITIAL vars come from the scope set by
+;; The INIT-MESSAGE and VIPER-INITIAL vars come from the scope set by
;; viper-read-string-with-history
(defun viper-minibuffer-standard-hook ()
(if (stringp init-message)
(viper-tmp-insert-at-eob init-message))
- (if (stringp initial)
- (progn
- ;; don't wait if we have unread events or in kbd macro
- (or unread-command-events
- executing-kbd-macro
- (sit-for 840))
- (if (fboundp 'minibuffer-prompt-end)
- (delete-region (minibuffer-prompt-end) (point-max))
- (erase-buffer))
- (insert initial))))
+ (when (stringp viper-initial)
+ ;; don't wait if we have unread events or in kbd macro
+ (or unread-command-events
+ executing-kbd-macro
+ (sit-for 840))
+ (if (fboundp 'minibuffer-prompt-end)
+ (delete-region (minibuffer-prompt-end) (point-max))
+ (erase-buffer))
+ (insert viper-initial)))
(defsubst viper-minibuffer-real-start ()
(if (fboundp 'minibuffer-prompt-end)
@@ -2179,10 +2179,10 @@ problems."
;;; Reading string with history
-(defun viper-read-string-with-history (prompt &optional initial
+(defun viper-read-string-with-history (prompt &optional viper-initial
history-var default keymap
init-message)
- ;; Read string, prompting with PROMPT and inserting the INITIAL
+ ;; Read string, prompting with PROMPT and inserting the VIPER-INITIAL
;; value. Uses HISTORY-VAR. DEFAULT is the default value to accept if the
;; input is an empty string.
;; Default value is displayed until the user types something in the
@@ -2205,14 +2205,14 @@ problems."
temp-msg)
(setq keymap (or keymap minibuffer-local-map)
- initial (or initial "")
+ viper-initial (or viper-initial "")
temp-msg (if default
(format "(default %s) " default)
""))
(setq viper-incomplete-ex-cmd nil)
(setq val (read-from-minibuffer prompt
- (concat temp-msg initial val padding)
+ (concat temp-msg viper-initial val padding)
keymap nil history-var))
(setq minibuffer-setup-hook nil
padding (viper-array-to-string (this-command-keys))
@@ -3498,11 +3498,8 @@ controlled by the sign of prefix numeric value."
(if (and (eolp) (not (bolp))) (forward-char -1))
(if (not (looking-at "[][(){}]"))
(setq anchor-point (point)))
- (save-excursion
- (beginning-of-line)
- (setq beg-lim (point))
- (end-of-line)
- (setq end-lim (point)))
+ (setq beg-lim (point-at-bol)
+ end-lim (point-at-eol))
(cond ((re-search-forward "[][(){}]" end-lim t)
(backward-char) )
((re-search-backward "[][(){}]" beg-lim t))
@@ -4247,7 +4244,7 @@ Null string will repeat previous search."
(setq viper-use-register nil)))
(if (and (bolp) viper-ex-style-editing)
(ding))
- (delete-backward-char val t)))
+ (delete-char (- val) t)))
(defun viper-del-backward-char-in-insert ()
@@ -4256,7 +4253,7 @@ Null string will repeat previous search."
(if (and viper-ex-style-editing (bolp))
(beep 1)
;; don't put on kill ring
- (delete-backward-char 1 nil)))
+ (delete-char -1 nil)))
(defun viper-del-backward-char-in-replace ()
@@ -4269,14 +4266,14 @@ cursor move past the beginning of line."
(cond (viper-delete-backwards-in-replace
(cond ((not (bolp))
;; don't put on kill ring
- (delete-backward-char 1 nil))
+ (delete-char -1 nil))
(viper-ex-style-editing
(beep 1))
((bobp)
(beep 1))
(t
;; don't put on kill ring
- (delete-backward-char 1 nil))))
+ (delete-char -1 nil))))
(viper-ex-style-editing
(if (bolp)
(beep 1)
@@ -4344,7 +4341,7 @@ cursor move past the beginning of line."
(insert-before-markers "@") ; put placeholder after the TAB
(untabify (viper-replace-start) (point))
;; del @, don't put on kill ring
- (delete-backward-char 1)
+ (delete-char -1)
(viper-set-replace-overlay-glyphs
viper-replace-region-start-delimiter
@@ -4622,12 +4619,10 @@ One can use `` and '' to temporarily jump 1 step back."
(progn
(if (eq ?^ (preceding-char))
(setq viper-preserve-indent t))
- (delete-backward-char 1)
+ (delete-char -1)
(setq p (point))
(setq indent nil)))
- (save-excursion
- (beginning-of-line)
- (setq bol (point)))
+ (setq bol (point-at-bol))
(if (re-search-backward "[^ \t]" bol 1) (forward-char))
(delete-region (point) p)
(if indent
@@ -4711,9 +4706,7 @@ One can use `` and '' to temporarily jump 1 step back."
(goto-char pos)
(beginning-of-line)
(if (re-search-backward "[^ \t]" nil t)
- (progn
- (beginning-of-line)
- (setq s (point))))
+ (setq s (point-at-bol)))
(goto-char pos)
(forward-line 1)
(if (re-search-forward "[^ \t]" nil t)
@@ -5092,5 +5085,4 @@ Mail anyway (y or n)? ")
-;; arch-tag: 739a6450-5fda-44d0-88b0-325053d888c2
;;; viper-cmd.el ends here
diff --git a/lisp/emulation/viper-ex.el b/lisp/emulation/viper-ex.el
index 5f5c7e86d63..be387d7724b 100644
--- a/lisp/emulation/viper-ex.el
+++ b/lisp/emulation/viper-ex.el
@@ -4,6 +4,7 @@
;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: viper
;; This file is part of GNU Emacs.
@@ -750,7 +751,7 @@ reversed."
(format "[^\\\\]\\(\\\\\\\\\\)*\\\\%c" c)))
(setq cont nil)
;; we are at an escaped delimiter: unescape it and continue
- (delete-backward-char 2)
+ (delete-char -2)
(insert c)
(if (eolp)
;; if at eol, exit loop and go to next line
diff --git a/lisp/emulation/viper-init.el b/lisp/emulation/viper-init.el
index 68f729e8b43..5af96922171 100644
--- a/lisp/emulation/viper-init.el
+++ b/lisp/emulation/viper-init.el
@@ -1,9 +1,10 @@
;;; viper-init.el --- some common definitions for Viper
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: viper
;; This file is part of GNU Emacs.
@@ -62,9 +63,10 @@
(defun viper-window-display-p ()
(and (viper-device-type) (not (memq (viper-device-type) '(tty stream pc)))))
-(defcustom viper-ms-style-os-p (memq system-type
- '(ms-dos windows-nt windows-95))
- "Tells if Emacs is running under an MS-style OS: ms-dos, windows-nt, W95."
+(defcustom viper-ms-style-os-p
+ (memq system-type (if (featurep 'emacs) '(ms-dos windows-nt)
+ '(ms-dos windows-nt windows-95)))
+ "Non-nil if Emacs is running under an MS-style OS: MS-DOS, or MS-Windows."
:type 'boolean
:tag "Is it Microsoft-made OS?"
:group 'viper-misc)
@@ -783,7 +785,7 @@ Related buffers can be cycled through via :R and :P commands."
;; These two vars control the interaction of jumps performed by ' and `.
;; In this new version, '' doesn't erase the marks set by ``, so one can
-;; use both kinds of jumps interchangeably and without loosing positions
+;; use both kinds of jumps interchangeably and without losing positions
;; inside the lines.
;; Remembers position of the last jump done using ``'.
@@ -995,5 +997,4 @@ on a dumb terminal."
;; eval: (put 'viper-deflocalvar 'lisp-indent-hook 'defun)
;; End:
-;; arch-tag: 4efa2416-1fcb-4690-be10-1a2a0248d250
;;; viper-init.el ends here
diff --git a/lisp/emulation/viper-keym.el b/lisp/emulation/viper-keym.el
index cfc84956dac..d75573673d7 100644
--- a/lisp/emulation/viper-keym.el
+++ b/lisp/emulation/viper-keym.el
@@ -4,6 +4,7 @@
;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: viper
;; This file is part of GNU Emacs.
diff --git a/lisp/emulation/viper-macs.el b/lisp/emulation/viper-macs.el
index ec31aeef428..71d565632eb 100644
--- a/lisp/emulation/viper-macs.el
+++ b/lisp/emulation/viper-macs.el
@@ -4,6 +4,7 @@
;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: viper
;; This file is part of GNU Emacs.
diff --git a/lisp/emulation/viper-mous.el b/lisp/emulation/viper-mous.el
index dd1cd5362ce..9bea921e167 100644
--- a/lisp/emulation/viper-mous.el
+++ b/lisp/emulation/viper-mous.el
@@ -4,6 +4,7 @@
;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: viper
;; This file is part of GNU Emacs.
diff --git a/lisp/emulation/viper-util.el b/lisp/emulation/viper-util.el
index 99dd305cb4c..6868a960087 100644
--- a/lisp/emulation/viper-util.el
+++ b/lisp/emulation/viper-util.el
@@ -1,9 +1,11 @@
;;; viper-util.el --- Utilities used by viper.el
;; Copyright (C) 1994, 1995, 1996, 1997, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: viper
;; This file is part of GNU Emacs.
@@ -76,7 +78,7 @@
(defalias 'viper-int-to-char
(if (featurep 'xemacs) 'int-to-char 'identity))
(defalias 'viper-get-face
- (if (featurep 'xemacs) 'get-face 'internal-get-face))
+ (if (featurep 'xemacs) 'get-face 'facep))
(defalias 'viper-color-defined-p
(if (featurep 'xemacs) 'valid-color-name-p 'x-color-defined-p))
(defalias 'viper-iconify
diff --git a/lisp/emulation/viper.el b/lisp/emulation/viper.el
index 302cfa82958..04833a836a6 100644
--- a/lisp/emulation/viper.el
+++ b/lisp/emulation/viper.el
@@ -8,6 +8,7 @@
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
;; Keywords: emulations
+;; Version: 3.14.1
;; Yoni Rabkin <yoni@rabkins.net> contacted the maintainer of this
;; file on 20/3/2008, and the maintainer agreed that when a bug is
diff --git a/lisp/emulation/ws-mode.el b/lisp/emulation/ws-mode.el
index ed8b5562999..35f54b71d61 100644
--- a/lisp/emulation/ws-mode.el
+++ b/lisp/emulation/ws-mode.el
@@ -27,158 +27,156 @@
;; This emulates WordStar, with a major mode.
;;; Code:
-
-(defvar wordstar-mode-map nil "")
+(defvar wordstar-C-k-map
+ (let ((map (make-keymap)))
+ (define-key map " " ())
+ (define-key map "0" 'ws-set-marker-0)
+ (define-key map "1" 'ws-set-marker-1)
+ (define-key map "2" 'ws-set-marker-2)
+ (define-key map "3" 'ws-set-marker-3)
+ (define-key map "4" 'ws-set-marker-4)
+ (define-key map "5" 'ws-set-marker-5)
+ (define-key map "6" 'ws-set-marker-6)
+ (define-key map "7" 'ws-set-marker-7)
+ (define-key map "8" 'ws-set-marker-8)
+ (define-key map "9" 'ws-set-marker-9)
+ (define-key map "b" 'ws-begin-block)
+ (define-key map "\C-b" 'ws-begin-block)
+ (define-key map "c" 'ws-copy-block)
+ (define-key map "\C-c" 'ws-copy-block)
+ (define-key map "d" 'save-buffers-kill-emacs)
+ (define-key map "\C-d" 'save-buffers-kill-emacs)
+ (define-key map "f" 'find-file)
+ (define-key map "\C-f" 'find-file)
+ (define-key map "h" 'ws-show-markers)
+ (define-key map "\C-h" 'ws-show-markers)
+ (define-key map "i" 'ws-indent-block)
+ (define-key map "\C-i" 'ws-indent-block)
+ (define-key map "k" 'ws-end-block)
+ (define-key map "\C-k" 'ws-end-block)
+ (define-key map "p" 'ws-print-block)
+ (define-key map "\C-p" 'ws-print-block)
+ (define-key map "q" 'kill-emacs)
+ (define-key map "\C-q" 'kill-emacs)
+ (define-key map "r" 'insert-file)
+ (define-key map "\C-r" 'insert-file)
+ (define-key map "s" 'save-some-buffers)
+ (define-key map "\C-s" 'save-some-buffers)
+ (define-key map "t" 'ws-mark-word)
+ (define-key map "\C-t" 'ws-mark-word)
+ (define-key map "u" 'ws-exdent-block)
+ (define-key map "\C-u" 'keyboard-quit)
+ (define-key map "v" 'ws-move-block)
+ (define-key map "\C-v" 'ws-move-block)
+ (define-key map "w" 'ws-write-block)
+ (define-key map "\C-w" 'ws-write-block)
+ (define-key map "x" 'save-buffers-kill-emacs)
+ (define-key map "\C-x" 'save-buffers-kill-emacs)
+ (define-key map "y" 'ws-delete-block)
+ (define-key map "\C-y" 'ws-delete-block)
+ map)
+ "")
+
+(defvar wordstar-C-o-map
+ (let ((map (make-keymap)))
+ (define-key map " " ())
+ (define-key map "c" 'wordstar-center-line)
+ (define-key map "\C-c" 'wordstar-center-line)
+ (define-key map "b" 'switch-to-buffer)
+ (define-key map "\C-b" 'switch-to-buffer)
+ (define-key map "j" 'justify-current-line)
+ (define-key map "\C-j" 'justify-current-line)
+ (define-key map "k" 'kill-buffer)
+ (define-key map "\C-k" 'kill-buffer)
+ (define-key map "l" 'list-buffers)
+ (define-key map "\C-l" 'list-buffers)
+ (define-key map "m" 'auto-fill-mode)
+ (define-key map "\C-m" 'auto-fill-mode)
+ (define-key map "r" 'set-fill-column)
+ (define-key map "\C-r" 'set-fill-column)
+ (define-key map "\C-u" 'keyboard-quit)
+ (define-key map "wd" 'delete-other-windows)
+ (define-key map "wh" 'split-window-horizontally)
+ (define-key map "wo" 'other-window)
+ (define-key map "wv" 'split-window-vertically)
+ map)
+ "")
+
+(defvar wordstar-C-q-map
+ (let ((map (make-keymap)))
+ (define-key map " " ())
+ (define-key map "0" 'ws-find-marker-0)
+ (define-key map "1" 'ws-find-marker-1)
+ (define-key map "2" 'ws-find-marker-2)
+ (define-key map "3" 'ws-find-marker-3)
+ (define-key map "4" 'ws-find-marker-4)
+ (define-key map "5" 'ws-find-marker-5)
+ (define-key map "6" 'ws-find-marker-6)
+ (define-key map "7" 'ws-find-marker-7)
+ (define-key map "8" 'ws-find-marker-8)
+ (define-key map "9" 'ws-find-marker-9)
+ (define-key map "a" 'ws-query-replace)
+ (define-key map "\C-a" 'ws-query-replace)
+ (define-key map "b" 'ws-goto-block-begin)
+ (define-key map "\C-b" 'ws-goto-block-begin)
+ (define-key map "c" 'end-of-buffer)
+ (define-key map "\C-c" 'end-of-buffer)
+ (define-key map "d" 'end-of-line)
+ (define-key map "\C-d" 'end-of-line)
+ (define-key map "f" 'ws-search)
+ (define-key map "\C-f" 'ws-search)
+ (define-key map "k" 'ws-goto-block-end)
+ (define-key map "\C-k" 'ws-goto-block-end)
+ (define-key map "l" 'ws-undo)
+ (define-key map "\C-l" 'ws-undo)
+ (define-key map "p" 'ws-last-cursorp)
+ (define-key map "\C-p" 'ws-last-cursorp)
+ (define-key map "r" 'beginning-of-buffer)
+ (define-key map "\C-r" 'beginning-of-buffer)
+ (define-key map "s" 'beginning-of-line)
+ (define-key map "\C-s" 'beginning-of-line)
+ (define-key map "\C-u" 'keyboard-quit)
+ (define-key map "w" 'ws-last-error)
+ (define-key map "\C-w" 'ws-last-error)
+ (define-key map "y" 'ws-kill-eol)
+ (define-key map "\C-y" 'ws-kill-eol)
+ (define-key map "\177" 'ws-kill-bol)
+ map)
+ "")
+
+(defvar wordstar-mode-map
+ (let ((map (make-keymap)))
+ (define-key map "\C-a" 'backward-word)
+ (define-key map "\C-b" 'fill-paragraph)
+ (define-key map "\C-c" 'scroll-up)
+ (define-key map "\C-d" 'forward-char)
+ (define-key map "\C-e" 'previous-line)
+ (define-key map "\C-f" 'forward-word)
+ (define-key map "\C-g" 'delete-char)
+ (define-key map "\C-h" 'backward-char)
+ (define-key map "\C-i" 'indent-for-tab-command)
+ (define-key map "\C-j" 'help-for-help)
+ (define-key map "\C-k" wordstar-C-k-map)
+ (define-key map "\C-l" 'ws-repeat-search)
+ (define-key map "\C-n" 'open-line)
+ (define-key map "\C-o" wordstar-C-o-map)
+ (define-key map "\C-p" 'quoted-insert)
+ (define-key map "\C-q" wordstar-C-q-map)
+ (define-key map "\C-r" 'scroll-down)
+ (define-key map "\C-s" 'backward-char)
+ (define-key map "\C-t" 'kill-word)
+ (define-key map "\C-u" 'keyboard-quit)
+ (define-key map "\C-v" 'overwrite-mode)
+ (define-key map "\C-w" 'scroll-down-line)
+ (define-key map "\C-x" 'next-line)
+ (define-key map "\C-y" 'kill-complete-line)
+ (define-key map "\C-z" 'scroll-up-line)
+ map)
+ "")
+
+;; wordstar-C-j-map not yet implemented
(defvar wordstar-C-j-map nil "")
-(defvar wordstar-C-k-map nil "")
-(defvar wordstar-C-o-map nil "")
-(defvar wordstar-C-q-map nil "")
-
-(if wordstar-mode-map
- ()
- (setq wordstar-mode-map (make-keymap))
- ;; (setq wordstar-C-j-map (make-keymap)) ; later, perhaps
- (setq wordstar-C-k-map (make-keymap))
- (setq wordstar-C-o-map (make-keymap))
- (setq wordstar-C-q-map (make-keymap))
-
- (define-key wordstar-mode-map "\C-a" 'backward-word)
- (define-key wordstar-mode-map "\C-b" 'fill-paragraph)
- (define-key wordstar-mode-map "\C-c" 'scroll-up)
- (define-key wordstar-mode-map "\C-d" 'forward-char)
- (define-key wordstar-mode-map "\C-e" 'previous-line)
- (define-key wordstar-mode-map "\C-f" 'forward-word)
- (define-key wordstar-mode-map "\C-g" 'delete-char)
- (define-key wordstar-mode-map "\C-h" 'backward-char)
- (define-key wordstar-mode-map "\C-i" 'indent-for-tab-command)
- (define-key wordstar-mode-map "\C-j" 'help-for-help)
- (define-key wordstar-mode-map "\C-k" wordstar-C-k-map)
- (define-key wordstar-mode-map "\C-l" 'ws-repeat-search)
- (define-key wordstar-mode-map "\C-n" 'open-line)
- (define-key wordstar-mode-map "\C-o" wordstar-C-o-map)
- (define-key wordstar-mode-map "\C-p" 'quoted-insert)
- (define-key wordstar-mode-map "\C-q" wordstar-C-q-map)
- (define-key wordstar-mode-map "\C-r" 'scroll-down)
- (define-key wordstar-mode-map "\C-s" 'backward-char)
- (define-key wordstar-mode-map "\C-t" 'kill-word)
- (define-key wordstar-mode-map "\C-u" 'keyboard-quit)
- (define-key wordstar-mode-map "\C-v" 'overwrite-mode)
- (define-key wordstar-mode-map "\C-w" 'scroll-down-line)
- (define-key wordstar-mode-map "\C-x" 'next-line)
- (define-key wordstar-mode-map "\C-y" 'kill-complete-line)
- (define-key wordstar-mode-map "\C-z" 'scroll-up-line)
-
- ;; wordstar-C-k-map
-
- (define-key wordstar-C-k-map " " ())
- (define-key wordstar-C-k-map "0" 'ws-set-marker-0)
- (define-key wordstar-C-k-map "1" 'ws-set-marker-1)
- (define-key wordstar-C-k-map "2" 'ws-set-marker-2)
- (define-key wordstar-C-k-map "3" 'ws-set-marker-3)
- (define-key wordstar-C-k-map "4" 'ws-set-marker-4)
- (define-key wordstar-C-k-map "5" 'ws-set-marker-5)
- (define-key wordstar-C-k-map "6" 'ws-set-marker-6)
- (define-key wordstar-C-k-map "7" 'ws-set-marker-7)
- (define-key wordstar-C-k-map "8" 'ws-set-marker-8)
- (define-key wordstar-C-k-map "9" 'ws-set-marker-9)
- (define-key wordstar-C-k-map "b" 'ws-begin-block)
- (define-key wordstar-C-k-map "\C-b" 'ws-begin-block)
- (define-key wordstar-C-k-map "c" 'ws-copy-block)
- (define-key wordstar-C-k-map "\C-c" 'ws-copy-block)
- (define-key wordstar-C-k-map "d" 'save-buffers-kill-emacs)
- (define-key wordstar-C-k-map "\C-d" 'save-buffers-kill-emacs)
- (define-key wordstar-C-k-map "f" 'find-file)
- (define-key wordstar-C-k-map "\C-f" 'find-file)
- (define-key wordstar-C-k-map "h" 'ws-show-markers)
- (define-key wordstar-C-k-map "\C-h" 'ws-show-markers)
- (define-key wordstar-C-k-map "i" 'ws-indent-block)
- (define-key wordstar-C-k-map "\C-i" 'ws-indent-block)
- (define-key wordstar-C-k-map "k" 'ws-end-block)
- (define-key wordstar-C-k-map "\C-k" 'ws-end-block)
- (define-key wordstar-C-k-map "p" 'ws-print-block)
- (define-key wordstar-C-k-map "\C-p" 'ws-print-block)
- (define-key wordstar-C-k-map "q" 'kill-emacs)
- (define-key wordstar-C-k-map "\C-q" 'kill-emacs)
- (define-key wordstar-C-k-map "r" 'insert-file)
- (define-key wordstar-C-k-map "\C-r" 'insert-file)
- (define-key wordstar-C-k-map "s" 'save-some-buffers)
- (define-key wordstar-C-k-map "\C-s" 'save-some-buffers)
- (define-key wordstar-C-k-map "t" 'ws-mark-word)
- (define-key wordstar-C-k-map "\C-t" 'ws-mark-word)
- (define-key wordstar-C-k-map "u" 'ws-exdent-block)
- (define-key wordstar-C-k-map "\C-u" 'keyboard-quit)
- (define-key wordstar-C-k-map "v" 'ws-move-block)
- (define-key wordstar-C-k-map "\C-v" 'ws-move-block)
- (define-key wordstar-C-k-map "w" 'ws-write-block)
- (define-key wordstar-C-k-map "\C-w" 'ws-write-block)
- (define-key wordstar-C-k-map "x" 'save-buffers-kill-emacs)
- (define-key wordstar-C-k-map "\C-x" 'save-buffers-kill-emacs)
- (define-key wordstar-C-k-map "y" 'ws-delete-block)
- (define-key wordstar-C-k-map "\C-y" 'ws-delete-block)
-
- ;; wordstar-C-j-map not yet implemented
-
- ;; wordstar-C-o-map
-
- (define-key wordstar-C-o-map " " ())
- (define-key wordstar-C-o-map "c" 'wordstar-center-line)
- (define-key wordstar-C-o-map "\C-c" 'wordstar-center-line)
- (define-key wordstar-C-o-map "b" 'switch-to-buffer)
- (define-key wordstar-C-o-map "\C-b" 'switch-to-buffer)
- (define-key wordstar-C-o-map "j" 'justify-current-line)
- (define-key wordstar-C-o-map "\C-j" 'justify-current-line)
- (define-key wordstar-C-o-map "k" 'kill-buffer)
- (define-key wordstar-C-o-map "\C-k" 'kill-buffer)
- (define-key wordstar-C-o-map "l" 'list-buffers)
- (define-key wordstar-C-o-map "\C-l" 'list-buffers)
- (define-key wordstar-C-o-map "m" 'auto-fill-mode)
- (define-key wordstar-C-o-map "\C-m" 'auto-fill-mode)
- (define-key wordstar-C-o-map "r" 'set-fill-column)
- (define-key wordstar-C-o-map "\C-r" 'set-fill-column)
- (define-key wordstar-C-o-map "\C-u" 'keyboard-quit)
- (define-key wordstar-C-o-map "wd" 'delete-other-windows)
- (define-key wordstar-C-o-map "wh" 'split-window-horizontally)
- (define-key wordstar-C-o-map "wo" 'other-window)
- (define-key wordstar-C-o-map "wv" 'split-window-vertically)
-
- ;; wordstar-C-q-map
- (define-key wordstar-C-q-map " " ())
- (define-key wordstar-C-q-map "0" 'ws-find-marker-0)
- (define-key wordstar-C-q-map "1" 'ws-find-marker-1)
- (define-key wordstar-C-q-map "2" 'ws-find-marker-2)
- (define-key wordstar-C-q-map "3" 'ws-find-marker-3)
- (define-key wordstar-C-q-map "4" 'ws-find-marker-4)
- (define-key wordstar-C-q-map "5" 'ws-find-marker-5)
- (define-key wordstar-C-q-map "6" 'ws-find-marker-6)
- (define-key wordstar-C-q-map "7" 'ws-find-marker-7)
- (define-key wordstar-C-q-map "8" 'ws-find-marker-8)
- (define-key wordstar-C-q-map "9" 'ws-find-marker-9)
- (define-key wordstar-C-q-map "a" 'ws-query-replace)
- (define-key wordstar-C-q-map "\C-a" 'ws-query-replace)
- (define-key wordstar-C-q-map "b" 'ws-goto-block-begin)
- (define-key wordstar-C-q-map "\C-b" 'ws-goto-block-begin)
- (define-key wordstar-C-q-map "c" 'end-of-buffer)
- (define-key wordstar-C-q-map "\C-c" 'end-of-buffer)
- (define-key wordstar-C-q-map "d" 'end-of-line)
- (define-key wordstar-C-q-map "\C-d" 'end-of-line)
- (define-key wordstar-C-q-map "f" 'ws-search)
- (define-key wordstar-C-q-map "\C-f" 'ws-search)
- (define-key wordstar-C-q-map "k" 'ws-goto-block-end)
- (define-key wordstar-C-q-map "\C-k" 'ws-goto-block-end)
- (define-key wordstar-C-q-map "l" 'ws-undo)
- (define-key wordstar-C-q-map "\C-l" 'ws-undo)
- (define-key wordstar-C-q-map "p" 'ws-last-cursorp)
- (define-key wordstar-C-q-map "\C-p" 'ws-last-cursorp)
- (define-key wordstar-C-q-map "r" 'beginning-of-buffer)
- (define-key wordstar-C-q-map "\C-r" 'beginning-of-buffer)
- (define-key wordstar-C-q-map "s" 'beginning-of-line)
- (define-key wordstar-C-q-map "\C-s" 'beginning-of-line)
- (define-key wordstar-C-q-map "\C-u" 'keyboard-quit)
- (define-key wordstar-C-q-map "w" 'ws-last-error)
- (define-key wordstar-C-q-map "\C-w" 'ws-last-error)
- (define-key wordstar-C-q-map "y" 'ws-kill-eol)
- (define-key wordstar-C-q-map "\C-y" 'ws-kill-eol)
- (define-key wordstar-C-q-map "\177" 'ws-kill-bol))
+
(put 'wordstar-mode 'mode-class 'special)
@@ -339,16 +337,6 @@ the distance between the end of the text and `fill-column'."
(+ left-margin
(/ (- fill-column left-margin line-length) 2))))))
-(defun scroll-down-line ()
- "Scroll one line down."
- (interactive)
- (scroll-down 1))
-
-(defun scroll-up-line ()
- "Scroll one line up."
- (interactive)
- (scroll-up 1))
-
;;;;;;;;;;;
;; wordstar special variables:
diff --git a/lisp/env.el b/lisp/env.el
index 0699e907fa8..b69f2d2b0e3 100644
--- a/lisp/env.el
+++ b/lisp/env.el
@@ -5,6 +5,7 @@
;; Maintainer: FSF
;; Keywords: processes, unix
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/epa-dired.el b/lisp/epa-dired.el
index 7ba414da2f9..80ecef6f54f 100644
--- a/lisp/epa-dired.el
+++ b/lisp/epa-dired.el
@@ -3,6 +3,7 @@
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Keywords: PGP, GnuPG
+;; Package: epa
;; This file is part of GNU Emacs.
diff --git a/lisp/epa-file.el b/lisp/epa-file.el
index 2bbb0aa6455..95d8423020b 100644
--- a/lisp/epa-file.el
+++ b/lisp/epa-file.el
@@ -3,6 +3,7 @@
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Keywords: PGP, GnuPG
+;; Package: epa
;; This file is part of GNU Emacs.
@@ -66,10 +67,11 @@ way."
(cons entry
epa-file-passphrase-alist)))
(setq passphrase (epa-passphrase-callback-function context
- key-id nil))
+ key-id
+ file))
(setcdr entry (copy-sequence passphrase))
passphrase))))
- (epa-passphrase-callback-function context key-id nil)))
+ (epa-passphrase-callback-function context key-id file)))
;;;###autoload
(defun epa-file-handler (operation &rest args)
@@ -101,6 +103,14 @@ way."
(insert (epa-file--decode-coding-string string (or coding-system-for-read
'undecided)))))
+(defvar epa-file-error nil)
+(defun epa-file--find-file-not-found-function ()
+ (let ((error epa-file-error))
+ (save-window-excursion
+ (kill-buffer))
+ (signal 'file-error
+ (cons "Opening input file" (cdr error)))))
+
(defvar last-coding-system-used)
(defun epa-file-insert-file-contents (file &optional visit beg end replace)
(barf-if-buffer-read-only)
@@ -131,6 +141,16 @@ way."
(error
(if (setq entry (assoc file epa-file-passphrase-alist))
(setcdr entry nil))
+ ;; Hack to prevent find-file from opening empty buffer
+ ;; when decryption failed (bug#6568). See the place
+ ;; where `find-file-not-found-functions' are called in
+ ;; `find-file-noselect-1'.
+ (when (file-exists-p local-file)
+ (make-local-variable 'epa-file-error)
+ (setq epa-file-error error)
+ (add-hook 'find-file-not-found-functions
+ 'epa-file--find-file-not-found-function
+ nil t))
(signal 'file-error
(cons "Opening input file" (cdr error)))))
(make-local-variable 'epa-file-encrypt-to)
@@ -139,12 +159,17 @@ way."
(if (or beg end)
(setq string (substring string (or beg 0) end)))
(save-excursion
- (save-restriction
- (narrow-to-region (point) (point))
- (epa-file-decode-and-insert string file visit beg end replace)
- (setq length (- (point-max) (point-min))))
- (if replace
- (delete-region (point) (point-max)))
+ ;; If visiting, bind off buffer-file-name so that
+ ;; file-locking will not ask whether we should
+ ;; really edit the buffer.
+ (let ((buffer-file-name
+ (if visit nil buffer-file-name)))
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (epa-file-decode-and-insert string file visit beg end replace)
+ (setq length (- (point-max) (point-min))))
+ (if replace
+ (delete-region (point) (point-max))))
(if visit
(set-visited-file-modtime))))
(if (and local-copy
diff --git a/lisp/epa-hook.el b/lisp/epa-hook.el
index 9ed2feb15bf..5fb7e2c0bf3 100644
--- a/lisp/epa-hook.el
+++ b/lisp/epa-hook.el
@@ -3,6 +3,7 @@
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Keywords: PGP, GnuPG
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/epa-mail.el b/lisp/epa-mail.el
index b3c31fe4354..ab47cbf60bc 100644
--- a/lisp/epa-mail.el
+++ b/lisp/epa-mail.el
@@ -3,6 +3,7 @@
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Keywords: PGP, GnuPG, mail, message
+;; Package: epa
;; This file is part of GNU Emacs.
@@ -32,6 +33,12 @@
(define-key keymap "\C-c\C-ee" 'epa-mail-encrypt)
(define-key keymap "\C-c\C-ei" 'epa-mail-import-keys)
(define-key keymap "\C-c\C-eo" 'epa-insert-keys)
+ (define-key keymap "\C-c\C-e\C-d" 'epa-mail-decrypt)
+ (define-key keymap "\C-c\C-e\C-v" 'epa-mail-verify)
+ (define-key keymap "\C-c\C-e\C-s" 'epa-mail-sign)
+ (define-key keymap "\C-c\C-e\C-e" 'epa-mail-encrypt)
+ (define-key keymap "\C-c\C-e\C-i" 'epa-mail-import-keys)
+ (define-key keymap "\C-c\C-e\C-o" 'epa-insert-keys)
keymap))
(defvar epa-mail-mode-hook nil)
@@ -110,23 +117,29 @@ Don't use this command in Lisp programs!"
(save-excursion
(let ((verbose current-prefix-arg)
(context (epg-make-context epa-protocol))
- recipients recipient-key)
+ recipients-string recipients recipient-key)
(goto-char (point-min))
(save-restriction
(narrow-to-region (point)
(if (search-forward mail-header-separator nil 0)
(match-beginning 0)
(point)))
+ (setq recipients-string
+ (mapconcat #'identity
+ (nconc (mail-fetch-field "to" nil nil t)
+ (mail-fetch-field "cc" nil nil t)
+ (mail-fetch-field "bcc" nil nil t))
+ ","))
(setq recipients
(mail-strip-quoted-names
- (mapconcat #'identity
- (nconc (mail-fetch-field "to" nil nil t)
- (mail-fetch-field "cc" nil nil t)
- (mail-fetch-field "bcc" nil nil t))
- ","))))
+ (with-temp-buffer
+ (insert "to: " recipients-string "\n")
+ (expand-mail-aliases (point-min) (point-max))
+ (car (mail-fetch-field "to" nil nil t))))))
(if recipients
(setq recipients (delete ""
- (split-string recipients "[ \t\n]+"))))
+ (split-string recipients
+ "[ \t\n]*,[ \t\n]*"))))
(goto-char (point-min))
(if (search-forward mail-header-separator nil t)
(forward-line))
@@ -147,7 +160,9 @@ If no one is selected, symmetric encryption will be performed. "
(epa-mail--find-usable-key
(epg-list-keys
(epg-make-context epa-protocol)
- (concat "<" recipient ">"))
+ (if (string-match "@" recipient)
+ (concat "<" recipient ">")
+ recipient))
'encrypt))
(unless (or recipient-key
(y-or-n-p
diff --git a/lisp/epa.el b/lisp/epa.el
index 8d77d6938b1..687a31a8c3a 100644
--- a/lisp/epa.el
+++ b/lisp/epa.el
@@ -1,5 +1,7 @@
;;; epa.el --- the EasyPG Assistant
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Copyright (C) 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Keywords: PGP, GnuPG
@@ -471,11 +473,9 @@ If ARG is non-nil, mark the key."
'epa-key))
(setq keys (cons key keys))))
(nreverse keys)))
- (save-excursion
- (beginning-of-line)
- (let ((key (get-text-property (point) 'epa-key)))
- (if key
- (list key))))))
+ (let ((key (get-text-property (point-at-bol) 'epa-key)))
+ (if key
+ (list key)))))
(defun epa--select-keys (prompt keys)
(unless (and epa-keys-buffer
@@ -635,8 +635,13 @@ If SECRET is non-nil, list secret keys instead of public keys."
(defun epa-passphrase-callback-function (context key-id handback)
(if (eq key-id 'SYM)
- (read-passwd "Passphrase for symmetric encryption: "
- (eq (epg-context-operation context) 'encrypt))
+ (read-passwd
+ (format "Passphrase for symmetric encryption%s: "
+ ;; Add the file name to the prompt, if any.
+ (if (stringp handback)
+ (format " for %s" handback)
+ ""))
+ (eq (epg-context-operation context) 'encrypt))
(read-passwd
(if (eq key-id 'PIN)
"Passphrase for PIN: "
@@ -1246,5 +1251,4 @@ between START and END."
(provide 'epa)
-;; arch-tag: 38d20ced-20d5-4137-b17a-f206335423d7
;;; epa.el ends here
diff --git a/lisp/epg-config.el b/lisp/epg-config.el
index 3cdf2ff3ffa..a439fa0480e 100644
--- a/lisp/epg-config.el
+++ b/lisp/epg-config.el
@@ -4,6 +4,7 @@
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Keywords: PGP, GnuPG
+;; Package: epg
;; This file is part of GNU Emacs.
@@ -34,9 +35,11 @@
(defgroup epg ()
"The EasyPG library."
:version "23.1"
- :group 'emacs)
+ :group 'data)
-(defcustom epg-gpg-program "gpg"
+(defcustom epg-gpg-program (or (executable-find "gpg")
+ (executable-find "gpg2")
+ "gpg")
"The `gpg' executable."
:group 'epg
:type 'string)
diff --git a/lisp/epg.el b/lisp/epg.el
index 9fde76d5f85..fae896c4ae0 100644
--- a/lisp/epg.el
+++ b/lisp/epg.el
@@ -4,6 +4,7 @@
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Keywords: PGP, GnuPG
+;; Version: 1.0.0
;; This file is part of GNU Emacs.
@@ -137,7 +138,8 @@
'((?e . encrypt)
(?s . sign)
(?c . certify)
- (?a . authentication)))
+ (?a . authentication)
+ (?D . disabled)))
(defvar epg-new-signature-type-alist
'((?D . detached)
diff --git a/lisp/erc/ChangeLog b/lisp/erc/ChangeLog
index 6eacc035552..210f6985dc9 100644
--- a/lisp/erc/ChangeLog
+++ b/lisp/erc/ChangeLog
@@ -1,18 +1,50 @@
-2010-10-23 Julien Danjou <julien@danjou.info>
+2010-11-11 Glenn Morris <rgm@gnu.org>
+
+ * erc-lang.el (erc-cmd-LANG): Fix what may have been a typo.
+
+2010-11-05 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * erc-backend.el (erc-coding-system-precedence): New variable.
+ (erc-decode-string-from-target): Use it.
+
+2010-10-24 Julien Danjou <julien@danjou.info>
* erc-backend.el (erc-server-JOIN): Set the correct target list on join.
* erc-backend.el (erc-process-sentinel): Check that buffer is alive
before setting it as current buffer.
-2010-10-12 Juanma Barranquero <lekktu@gmail.com>
+2010-10-14 Juanma Barranquero <lekktu@gmail.com>
* erc-xdcc.el (erc-xdcc-help-text): Fix typo in docstring.
+2010-10-10 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * erc-list.el (erc-list-menu-mode-map): Declare and define in one step.
+
+2010-08-14 Vivek Dasmohapatra <vivek@etla.org>
+
+ * erc-join.el (erc-autojoin-timing, erc-autojoin-delay): New vars.
+ (erc-autojoin-channels-delayed, erc-autojoin-after-ident): New
+ functions.
+ (erc-autojoin-channels): Allow autojoining after ident (Bug#5521).
+
+2010-08-08 Fran Litterio <flitterio@gmail.com>
+
+ * erc-backend.el (erc-server-filter-function): Call
+ erc-log-irc-protocol.
+
+ * erc.el (erc-toggle-debug-irc-protocol): Bind
+ erc-toggle-debug-irc-protocol to t.
+
2010-05-07 Chong Yidong <cyd@stupidchicken.com>
* Version 23.2 released.
+2010-03-10 Chong Yidong <cyd@stupidchicken.com>
+
+ * Branch for 23.2.
+
2010-02-07 Vivek Dasmohapatra <vivek@etla.org>
* erc-services.el (erc-nickserv-alist): Fix defcustom type (Bug#5520).
@@ -23,8 +55,8 @@
(erc-server-reconnect): Use it to reconnect via old
connector (Bug#4958).
- * erc.el (erc-determine-parameters): Save
- erc-server-connect-function to erc-session-connector.
+ * erc.el (erc-determine-parameters):
+ Save erc-server-connect-function to erc-session-connector.
2009-11-03 Stefan Monnier <monnier@iro.umontreal.ca>
diff --git a/lisp/erc/ChangeLog.03 b/lisp/erc/ChangeLog.03
index d378cf36d42..6f46837ad19 100644
--- a/lisp/erc/ChangeLog.03
+++ b/lisp/erc/ChangeLog.03
@@ -145,7 +145,7 @@
to delete-if-not.
* erc.el(erc-update-current-channel-member):
- Use erc-downcase when comparing
+ Use erc-downcase when comparing
nick entries. Cleanup indentation.
2003-11-01 Lawrence Mitchell <wence@gmx.li>
@@ -171,7 +171,7 @@
2003-10-24 Mario Lang <mlang@delysid.org>
* erc-dcc.el: From Stephan Stahl <stl@isogmbh.de>:
- * (erc-dcc-send-block): Kill buffer if transfer completed correctly.
+ (erc-dcc-send-block): Kill buffer if transfer completed correctly.
2003-10-22 Mario Lang <mlang@delysid.org>
diff --git a/lisp/erc/ChangeLog.04 b/lisp/erc/ChangeLog.04
index 16e7788a221..a1cbab740be 100644
--- a/lisp/erc/ChangeLog.04
+++ b/lisp/erc/ChangeLog.04
@@ -72,7 +72,7 @@
2004-12-24 Jorgen Schaefer <forcer@users.sourceforge.net>
* erc-goodies.el, erc.el: The Small Extraction of Stuff[tm] commit.
- Moved some functions from erc.el to erc-goodies.el, and
+ Moved some functions from erc.el to erc-goodies.el, and
transformed them to erc modules in the process.
- imenu autoload stuff moved. I don't know why it is here at all.
- Moved: scroll-to-bottom, make-read-only, distinguish-noncommands,
diff --git a/lisp/erc/ChangeLog.06 b/lisp/erc/ChangeLog.06
index 9ca4396e88a..a1a196b79aa 100644
--- a/lisp/erc/ChangeLog.06
+++ b/lisp/erc/ChangeLog.06
@@ -174,7 +174,7 @@
* erc-nicklist.el (erc-nicklist-insert-contents): Add missing
parenthesis. Thanks to Stephan Stahl for the report.
-2006-09-10 Eric Hanchrow <offby1@blarg.net> (tiny change)
+2006-09-10 Eric Hanchrow <offby1@blarg.net>
* erc.el (erc-cmd-IGNORE): Prompt user if this might be a regexp
instead of a single user.
diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el
index f9c74a7af3e..3bc56989f4f 100644
--- a/lisp/erc/erc-backend.el
+++ b/lisp/erc/erc-backend.el
@@ -324,6 +324,13 @@ Good luck."
:type 'integer
:group 'erc-server)
+(defcustom erc-coding-system-precedence '(utf-8 undecided)
+ "List of coding systems to be preferred when receiving a string from the server.
+This will only be consulted if the coding system in
+`erc-server-coding-system' is `undecided'."
+ :group 'erc-server
+ :type '(repeat coding-system))
+
(defcustom erc-server-coding-system (if (and (fboundp 'coding-system-p)
(coding-system-p 'undecided)
(coding-system-p 'utf-8))
@@ -334,7 +341,9 @@ This is either a coding system, a cons, a function, or nil.
If a cons, the encoding system for outgoing text is in the car
and the decoding system for incoming text is in the cdr. The most
-interesting use for this is to put `undecided' in the cdr.
+interesting use for this is to put `undecided' in the cdr. This
+means that `erc-coding-system-precedence' will be consulted, and the
+first match there will be used.
If a function, it is called with the argument `target' and should
return a coding system or a cons as described above.
@@ -574,6 +583,7 @@ Make sure you are in an ERC buffer when running this."
nil
(substring erc-server-filter-data
(match-end 0))))
+ (erc-log-irc-protocol line nil)
(erc-parse-server-response process line)))))))
(defsubst erc-server-reconnect-p (event)
@@ -704,6 +714,14 @@ This is indicated by `erc-encoding-coding-alist', defaulting to the value of
(let ((coding (erc-coding-system-for-target target)))
(when (consp coding)
(setq coding (cdr coding)))
+ (when (eq coding 'undecided)
+ (let ((codings (detect-coding-string str))
+ (precedence erc-coding-system-precedence))
+ (while (and precedence
+ (not (memq (car precedence) codings)))
+ (pop precedence))
+ (when precedence
+ (setq coding (car precedence)))))
(erc-decode-coding-string str coding)))
;; proposed name, not used by anything yet
diff --git a/lisp/erc/erc-join.el b/lisp/erc/erc-join.el
index 7081d97fc4b..c54c2c534f3 100644
--- a/lisp/erc/erc-join.el
+++ b/lisp/erc/erc-join.el
@@ -42,9 +42,11 @@
(define-erc-module autojoin nil
"Makes ERC autojoin on connects and reconnects."
((add-hook 'erc-after-connect 'erc-autojoin-channels)
+ (add-hook 'erc-nickserv-identified-hook 'erc-autojoin-after-ident)
(add-hook 'erc-server-JOIN-functions 'erc-autojoin-add)
(add-hook 'erc-server-PART-functions 'erc-autojoin-remove))
((remove-hook 'erc-after-connect 'erc-autojoin-channels)
+ (remove-hook 'erc-nickserv-identified-hook 'erc-autojoin-after-ident)
(remove-hook 'erc-server-JOIN-functions 'erc-autojoin-add)
(remove-hook 'erc-server-PART-functions 'erc-autojoin-remove)))
@@ -66,6 +68,24 @@ time is used again."
(repeat :tag "Channels"
(string :tag "Name")))))
+(defcustom erc-autojoin-timing 'connect
+ "When ERC should attempt to autojoin a channel.
+If the value is `connect', autojoin immediately on connecting.
+If the value is `ident', autojoin after successful NickServ
+identification, or after `erc-autojoin-delay' seconds.
+Any other value means the same as `connect'."
+ :group 'erc-autojoin
+ :type '(choice (const :tag "On Connection" 'connect)
+ (const :tag "When Identified" 'ident)))
+
+(defcustom erc-autojoin-delay 30
+ "Number of seconds to wait before attempting to autojoin channels.
+This only takes effect if `erc-autojoin-timing' is `ident'.
+If NickServ identification occurs before this delay expires, ERC
+autojoins immediately at that time."
+ :group 'erc-autojoin
+ :type 'integer)
+
(defcustom erc-autojoin-domain-only t
"Truncate host name to the domain name when joining a server.
If non-nil, and a channel on the server a.b.c is joined, then
@@ -75,12 +95,60 @@ servers, presumably in the same domain."
:group 'erc-autojoin
:type 'boolean)
+(defvar erc--autojoin-timer nil)
+(make-variable-buffer-local 'erc--autojoin-timer)
+
+(defun erc-autojoin-channels-delayed (server nick buffer)
+ "Attempt to autojoin channels.
+This is called from a timer set up by `erc-autojoin-channels'."
+ (if erc--autojoin-timer
+ (setq erc--autojoin-timer
+ (erc-cancel-timer erc--autojoin-timer)))
+ (with-current-buffer buffer
+ ;; Don't kick of another delayed autojoin or try to wait for
+ ;; another ident response:
+ (let ((erc-autojoin-delay -1)
+ (erc-autojoin-timing 'connect))
+ (erc-log "Delayed autojoin started (no ident success detected yet)")
+ (erc-autojoin-channels server nick))))
+
+(defun erc-autojoin-after-ident (network nick)
+ "Autojoin channels in `erc-autojoin-channels-alist'.
+This function is run from `erc-nickserv-identified-hook'."
+ (if erc--autojoin-timer
+ (setq erc--autojoin-timer
+ (erc-cancel-timer erc--autojoin-timer)))
+ (when (eq erc-autojoin-timing 'ident)
+ (let ((server (or erc-server-announced-name erc-session-server))
+ (joined (mapcar (lambda (buf)
+ (with-current-buffer buf (erc-default-target)))
+ (erc-channel-list erc-server-process))))
+ ;; We may already be in these channels, e.g. because the
+ ;; autojoin timer went off.
+ (dolist (l erc-autojoin-channels-alist)
+ (when (string-match (car l) server)
+ (dolist (chan (cdr l))
+ (unless (erc-member-ignore-case chan joined)
+ (erc-server-send (concat "join " chan))))))))
+ nil)
+
(defun erc-autojoin-channels (server nick)
"Autojoin channels in `erc-autojoin-channels-alist'."
- (dolist (l erc-autojoin-channels-alist)
- (when (string-match (car l) server)
- (dolist (chan (cdr l))
- (erc-server-send (concat "join " chan))))))
+ (if (eq erc-autojoin-timing 'ident)
+ ;; Prepare the delayed autojoin timer, in case ident doesn't
+ ;; happen within the allotted time limit:
+ (when (> erc-autojoin-delay 0)
+ (setq erc--autojoin-timer
+ (run-with-timer erc-autojoin-delay nil
+ 'erc-autojoin-channels-delayed
+ server nick (current-buffer))))
+ ;; `erc-autojoin-timing' is `connect':
+ (dolist (l erc-autojoin-channels-alist)
+ (when (string-match (car l) server)
+ (dolist (chan (cdr l))
+ (erc-server-send (concat "join " chan))))))
+ ;; Return nil to avoid stomping on any other hook funcs.
+ nil)
(defun erc-autojoin-add (proc parsed)
"Add the channel being joined to `erc-autojoin-channels-alist'."
diff --git a/lisp/erc/erc-lang.el b/lisp/erc/erc-lang.el
index 89e36a733e4..a7e971acc61 100644
--- a/lisp/erc/erc-lang.el
+++ b/lisp/erc/erc-lang.el
@@ -1,6 +1,7 @@
;;; erc-lang.el --- provide the LANG command to ERC
-;; Copyright (C) 2002, 2004, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2002, 2004, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Alex Schroeder <alex@gnu.org>
;; Maintainer: Alex Schroeder <alex@gnu.org>
@@ -197,17 +198,14 @@ Normungsinstitut (ON), Postfach 130, A-1021 Vienna, Austria.")
iso-638-languages)))
(message "%s" (cdr (assoc code iso-638-languages))))
-(defvar line) ; dynamically bound in erc-process-input-line
-
(defun erc-cmd-LANG (language)
"Display the language name for the language code given by LANGUAGE."
(let ((lang (cdr (assoc language iso-638-languages))))
(erc-display-message
nil 'notice 'active
- (or lang (concat line ": No such domain"))))
+ (or lang (concat language ": No such domain"))))
t)
(provide 'erc-lang)
-;; arch-tag: 8ffb1563-cc03-4517-b067-16309d4ff97b
;;; erc-lang.el ends here
diff --git a/lisp/erc/erc-list.el b/lisp/erc/erc-list.el
index 218ea96f6da..8bf0d213f8e 100644
--- a/lisp/erc/erc-list.el
+++ b/lisp/erc/erc-list.el
@@ -117,19 +117,18 @@
(sort-fields col (point-min) (point-max))
(sort-numeric-fields col (point-min) (point-max))))))
-(defvar erc-list-menu-mode-map nil
+(defvar erc-list-menu-mode-map
+ (let ((map (make-keymap)))
+ (suppress-keymap map)
+ (define-key map "k" 'erc-list-kill)
+ (define-key map "j" 'erc-list-join)
+ (define-key map "g" 'erc-list-revert)
+ (define-key map "n" 'next-line)
+ (define-key map "p" 'previous-line)
+ (define-key map "q" 'quit-window)
+ map)
"Local keymap for `erc-list-mode' buffers.")
-(unless erc-list-menu-mode-map
- (setq erc-list-menu-mode-map (make-keymap))
- (suppress-keymap erc-list-menu-mode-map)
- (define-key erc-list-menu-mode-map "k" 'erc-list-kill)
- (define-key erc-list-menu-mode-map "j" 'erc-list-join)
- (define-key erc-list-menu-mode-map "g" 'erc-list-revert)
- (define-key erc-list-menu-mode-map "n" 'next-line)
- (define-key erc-list-menu-mode-map "p" 'previous-line)
- (define-key erc-list-menu-mode-map "q" 'quit-window))
-
(defvar erc-list-menu-sort-button-map nil
"Local keymap for ERC list menu mode sorting buttons.")
diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el
index b76f486f155..54f87982f8f 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -12,6 +12,7 @@
;; David Edmondson (dme@dme.org)
;; Maintainer: Michael Olson (mwolson@gnu.org)
;; Keywords: IRC, chat, client, Internet
+;; Version: 5.3
;; This file is part of GNU Emacs.
@@ -2306,14 +2307,14 @@ If ARG is non-nil, show the *erc-protocol* buffer."
(insert (erc-make-notice "This buffer displays all IRC protocol traffic exchanged with each server.\n"))
(insert (erc-make-notice "Kill this buffer to terminate protocol logging.\n\n")))
(use-local-map (make-sparse-keymap))
- (local-set-key (kbd "RET") 'erc-toggle-debug-irc-protocol))
+ (local-set-key (kbd "t") 'erc-toggle-debug-irc-protocol))
(add-hook 'kill-buffer-hook
#'(lambda () (setq erc-debug-irc-protocol nil))
nil 'local)
(goto-char (point-max))
(let ((inhibit-read-only t))
(insert (erc-make-notice
- (format "IRC protocol logging %s at %s -- Press ENTER to toggle logging.\n"
+ (format "IRC protocol logging %s at %s -- Press `t' to toggle logging.\n"
(if erc-debug-irc-protocol "disabled" "enabled")
(current-time-string))))))
(setq erc-debug-irc-protocol (not erc-debug-irc-protocol))
diff --git a/lisp/eshell/.arch-inventory b/lisp/eshell/.arch-inventory
deleted file mode 100644
index b5d82cdd6fc..00000000000
--- a/lisp/eshell/.arch-inventory
+++ /dev/null
@@ -1,4 +0,0 @@
-# Generated files
-precious ^(esh-groups)\.el$
-
-# arch-tag: 8dc7bfaa-6ca6-4be0-915a-1e539c3dabfb
diff --git a/lisp/eshell/em-alias.el b/lisp/eshell/em-alias.el
index 6dcdadf0a5d..6b24c269b30 100644
--- a/lisp/eshell/em-alias.el
+++ b/lisp/eshell/em-alias.el
@@ -103,7 +103,7 @@
:group 'eshell-module)
(defcustom eshell-aliases-file (expand-file-name "alias" eshell-directory-name)
- "*The file in which aliases are kept.
+ "The file in which aliases are kept.
Whenever an alias is defined by the user, using the `alias' command,
it will be written to this file. Thus, alias definitions (and
deletions) are always permanent. This approach was chosen for the
@@ -113,13 +113,13 @@ gained by using this module."
:group 'eshell-alias)
(defcustom eshell-bad-command-tolerance 3
- "*The number of failed commands to ignore before creating an alias."
+ "The number of failed commands to ignore before creating an alias."
:type 'integer
;; :link '(custom-manual "(eshell)Auto-correction of bad commands")
:group 'eshell-alias)
(defcustom eshell-alias-load-hook '(eshell-alias-initialize)
- "*A hook that gets run when `eshell-alias' is loaded."
+ "A hook that gets run when `eshell-alias' is loaded."
:type 'hook
:group 'eshell-alias)
diff --git a/lisp/eshell/em-banner.el b/lisp/eshell/em-banner.el
index c13df836651..9087cae369c 100644
--- a/lisp/eshell/em-banner.el
+++ b/lisp/eshell/em-banner.el
@@ -58,7 +58,7 @@ modules may have a simple template to begin with."
;;; User Variables:
(defcustom eshell-banner-message "Welcome to the Emacs shell\n\n"
- "*The banner message to be displayed when Eshell is loaded.
+ "The banner message to be displayed when Eshell is loaded.
This can be any sexp, and should end with at least two newlines."
:type 'sexp
:group 'eshell-banner)
@@ -66,7 +66,7 @@ This can be any sexp, and should end with at least two newlines."
(put 'eshell-banner-message 'risky-local-variable t)
(defcustom eshell-banner-load-hook '(eshell-banner-initialize)
- "*A list of functions to run when `eshell-banner' is loaded."
+ "A list of functions to run when `eshell-banner' is loaded."
:type 'hook
:group 'eshell-banner)
diff --git a/lisp/eshell/em-basic.el b/lisp/eshell/em-basic.el
index a4074011f58..ce72f752d42 100644
--- a/lisp/eshell/em-basic.el
+++ b/lisp/eshell/em-basic.el
@@ -77,7 +77,7 @@ same thing."
:group 'eshell-module)
(defcustom eshell-plain-echo-behavior nil
- "*If non-nil, `echo' tries to behave like an ordinary shell echo.
+ "If non-nil, `echo' tries to behave like an ordinary shell echo.
This comes at some detriment to Lisp functionality. However, the Lisp
equivalent of `echo' can always be achieved by using `identity'."
:type 'boolean
diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el
index b0aad0f1499..554e010a1b3 100644
--- a/lisp/eshell/em-cmpl.el
+++ b/lisp/eshell/em-cmpl.el
@@ -86,26 +86,26 @@ variable names, arguments, etc."
;;; User Variables:
(defcustom eshell-cmpl-load-hook '(eshell-cmpl-initialize)
- "*A list of functions to run when `eshell-cmpl' is loaded."
+ "A list of functions to run when `eshell-cmpl' is loaded."
:type 'hook
:group 'eshell-cmpl)
(defcustom eshell-show-lisp-completions nil
- "*If non-nil, include Lisp functions in the command completion list.
+ "If non-nil, include Lisp functions in the command completion list.
If this variable is nil, Lisp completion can still be done in command
position by using M-TAB instead of TAB."
:type 'boolean
:group 'eshell-cmpl)
(defcustom eshell-show-lisp-alternatives t
- "*If non-nil, and no other completions found, show Lisp functions.
+ "If non-nil, and no other completions found, show Lisp functions.
Setting this variable means nothing if `eshell-show-lisp-completions'
is non-nil."
:type 'boolean
:group 'eshell-cmpl)
(defcustom eshell-no-completion-during-jobs t
- "*If non-nil, don't allow completion while a process is running."
+ "If non-nil, don't allow completion while a process is running."
:type 'boolean
:group 'eshell-cmpl)
@@ -126,7 +126,7 @@ is non-nil."
("dbx" . "\\`\\([^.]*\\|a\\.out\\)\\'")
("sdb" . "\\`\\([^.]*\\|a\\.out\\)\\'")
("adb" . "\\`\\([^.]*\\|a\\.out\\)\\'"))
- "*An alist that defines simple argument type correlations.
+ "An alist that defines simple argument type correlations.
This is provided for common commands, as a simplistic alternative
to writing a completion function."
:type '(repeat (cons string regexp))
diff --git a/lisp/eshell/em-dirs.el b/lisp/eshell/em-dirs.el
index 43bc3ffaa6f..f4b2575def2 100644
--- a/lisp/eshell/em-dirs.el
+++ b/lisp/eshell/em-dirs.el
@@ -60,14 +60,14 @@ they lack somewhat in feel from the typical shell equivalents."
;;; User Variables:
(defcustom eshell-dirs-load-hook '(eshell-dirs-initialize)
- "*A hook that gets run when `eshell-dirs' is loaded."
+ "A hook that gets run when `eshell-dirs' is loaded."
:type 'hook
:group 'eshell-dirs)
(defcustom eshell-pwd-convert-function (if (eshell-under-windows-p)
'expand-file-name
'identity)
- "*The function used to normalize the value of Eshell's `pwd'.
+ "The function used to normalize the value of Eshell's `pwd'.
The value returned by `pwd' is also used when recording the
last-visited directory in the last-dir-ring, so it will affect the
form of the list used by 'cd ='."
@@ -78,7 +78,7 @@ form of the list used by 'cd ='."
:group 'eshell-dirs)
(defcustom eshell-ask-to-save-last-dir 'always
- "*Determine if the last-dir-ring should be automatically saved.
+ "Determine if the last-dir-ring should be automatically saved.
The last-dir-ring is always preserved when exiting an Eshell buffer.
However, when Emacs is being shut down, this variable determines
whether to prompt the user, or just save the ring.
@@ -91,22 +91,22 @@ If set to `always', the list-dir-ring will always be saved, silently."
:group 'eshell-dirs)
(defcustom eshell-cd-shows-directory nil
- "*If non-nil, using `cd' will report the directory it changes to."
+ "If non-nil, using `cd' will report the directory it changes to."
:type 'boolean
:group 'eshell-dirs)
(defcustom eshell-cd-on-directory t
- "*If non-nil, do a cd if a directory is in command position."
+ "If non-nil, do a cd if a directory is in command position."
:type 'boolean
:group 'eshell-dirs)
(defcustom eshell-directory-change-hook nil
- "*A hook to run when the current directory changes."
+ "A hook to run when the current directory changes."
:type 'hook
:group 'eshell-dirs)
(defcustom eshell-list-files-after-cd nil
- "*If non-nil, call \"ls\" with any remaining args after doing a cd.
+ "If non-nil, call \"ls\" with any remaining args after doing a cd.
This is provided for convenience, since the same effect is easily
achieved by adding a function to `eshell-directory-change-hook' that
calls \"ls\" and references `eshell-last-arguments'."
@@ -114,39 +114,39 @@ calls \"ls\" and references `eshell-last-arguments'."
:group 'eshell-dirs)
(defcustom eshell-pushd-tohome nil
- "*If non-nil, make pushd with no arg behave as 'pushd ~' (like `cd').
+ "If non-nil, make pushd with no arg behave as 'pushd ~' (like `cd').
This mirrors the optional behavior of tcsh."
:type 'boolean
:group 'eshell-dirs)
(defcustom eshell-pushd-dextract nil
- "*If non-nil, make \"pushd +n\" pop the nth dir to the stack top.
+ "If non-nil, make \"pushd +n\" pop the nth dir to the stack top.
This mirrors the optional behavior of tcsh."
:type 'boolean
:group 'eshell-dirs)
(defcustom eshell-pushd-dunique nil
- "*If non-nil, make pushd only add unique directories to the stack.
+ "If non-nil, make pushd only add unique directories to the stack.
This mirrors the optional behavior of tcsh."
:type 'boolean
:group 'eshell-dirs)
(defcustom eshell-dirtrack-verbose t
- "*If non-nil, show the directory stack following directory change.
+ "If non-nil, show the directory stack following directory change.
This is effective only if directory tracking is enabled."
:type 'boolean
:group 'eshell-dirs)
(defcustom eshell-last-dir-ring-file-name
(expand-file-name "lastdir" eshell-directory-name)
- "*If non-nil, name of the file to read/write the last-dir-ring.
+ "If non-nil, name of the file to read/write the last-dir-ring.
See also `eshell-read-last-dir-ring' and `eshell-write-last-dir-ring'.
If it is nil, the last-dir-ring will not be written to disk."
:type 'file
:group 'eshell-dirs)
(defcustom eshell-last-dir-ring-size 32
- "*If non-nil, the size of the directory history ring.
+ "If non-nil, the size of the directory history ring.
This ring is added to every time `cd' or `pushd' is used. It simply
stores the most recent directory locations Eshell has been in. To
return to the most recent entry, use 'cd -' (equivalent to 'cd -0').
@@ -167,7 +167,7 @@ thing again."
:group 'eshell-dirs)
(defcustom eshell-last-dir-unique t
- "*If non-nil, `eshell-last-dir-ring' contains only unique entries."
+ "If non-nil, `eshell-last-dir-ring' contains only unique entries."
:type 'boolean
:group 'eshell-dirs)
diff --git a/lisp/eshell/em-glob.el b/lisp/eshell/em-glob.el
index d4ad3009f86..6996bdbb7a0 100644
--- a/lisp/eshell/em-glob.el
+++ b/lisp/eshell/em-glob.el
@@ -63,39 +63,39 @@ by zsh for filename generation."
;;; User Variables:
(defcustom eshell-glob-load-hook '(eshell-glob-initialize)
- "*A list of functions to run when `eshell-glob' is loaded."
+ "A list of functions to run when `eshell-glob' is loaded."
:type 'hook
:group 'eshell-glob)
(defcustom eshell-glob-include-dot-files nil
- "*If non-nil, glob patterns will match files beginning with a dot."
+ "If non-nil, glob patterns will match files beginning with a dot."
:type 'boolean
:group 'eshell-glob)
(defcustom eshell-glob-include-dot-dot t
- "*If non-nil, glob patterns that match dots will match . and .."
+ "If non-nil, glob patterns that match dots will match . and .."
:type 'boolean
:group 'eshell-glob)
(defcustom eshell-glob-case-insensitive (eshell-under-windows-p)
- "*If non-nil, glob pattern matching will ignore case."
+ "If non-nil, glob pattern matching will ignore case."
:type 'boolean
:group 'eshell-glob)
(defcustom eshell-glob-show-progress nil
- "*If non-nil, display progress messages during a recursive glob.
+ "If non-nil, display progress messages during a recursive glob.
This option slows down recursive glob processing by quite a bit."
:type 'boolean
:group 'eshell-glob)
(defcustom eshell-error-if-no-glob nil
- "*If non-nil, it is an error for a glob pattern not to match.
+ "If non-nil, it is an error for a glob pattern not to match.
This mimcs the behavior of zsh if non-nil, but bash if nil."
:type 'boolean
:group 'eshell-glob)
(defcustom eshell-glob-chars-list '(?\] ?\[ ?* ?? ?~ ?\( ?\) ?| ?# ?^)
- "*List of additional characters used in extended globbing."
+ "List of additional characters used in extended globbing."
:type '(repeat character)
:group 'eshell-glob)
@@ -117,7 +117,7 @@ This option slows down recursive glob processing by quite a bit."
(if (eq (aref str (1+ pos)) ?*)
"*" "+")) (+ pos 2))
(cons "*" (1+ pos))))))
- "*An alist for translation of extended globbing characters."
+ "An alist for translation of extended globbing characters."
:type '(repeat (cons character (choice regexp function)))
:group 'eshell-glob)
@@ -246,7 +246,7 @@ the form:
(INCLUDE-REGEXP EXCLUDE-REGEXP (PRED-FUNC-LIST) (MOD-FUNC-LIST))"
(let ((paths (eshell-split-path glob))
- matches message-shown ange-cache)
+ eshell-glob-matches message-shown ange-cache)
(unwind-protect
(if (and (cdr paths)
(file-name-absolute-p (car paths)))
@@ -255,15 +255,15 @@ the form:
(eshell-glob-entries (file-name-as-directory ".") paths))
(if message-shown
(message nil)))
- (or (and matches (sort matches #'string<))
+ (or (and eshell-glob-matches (sort eshell-glob-matches #'string<))
(if eshell-error-if-no-glob
(error "No matches found: %s" glob)
glob))))
-(defvar matches)
+(defvar eshell-glob-matches)
(defvar message-shown)
-;; FIXME does this really need to abuse matches, message-shown?
+;; FIXME does this really need to abuse eshell-glob-matches, message-shown?
(defun eshell-glob-entries (path globs &optional recurse-p)
"Glob the entries in PATHS, possibly recursing if RECURSE-P is non-nil."
(let* ((entries (ignore-errors
@@ -319,7 +319,7 @@ the form:
"\\`\\.")))
(when (and recurse-p eshell-glob-show-progress)
(message "Building file list...%d so far: %s"
- (length matches) path)
+ (length eshell-glob-matches) path)
(setq message-shown t))
(if (equal path "./") (setq path ""))
(while entries
@@ -332,7 +332,8 @@ the form:
(if (cdr globs)
(if isdir
(setq dirs (cons (concat path name) dirs)))
- (setq matches (cons (concat path name) matches))))
+ (setq eshell-glob-matches
+ (cons (concat path name) eshell-glob-matches))))
(if (and recurse-p isdir
(or (> len 3)
(not (or (and (= len 2) (equal name "./"))
@@ -358,5 +359,4 @@ the form:
;; generated-autoload-file: "esh-groups.el"
;; End:
-;; arch-tag: d0548f54-fb7c-4978-a88e-f7c26f7f68ca
;;; em-glob.el ends here
diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el
index 37a926f888a..1f644261337 100644
--- a/lisp/eshell/em-hist.el
+++ b/lisp/eshell/em-hist.el
@@ -72,7 +72,7 @@
;;; User Variables:
(defcustom eshell-hist-load-hook '(eshell-hist-initialize)
- "*A list of functions to call when loading `eshell-hist'."
+ "A list of functions to call when loading `eshell-hist'."
:type 'hook
:group 'eshell-hist)
@@ -81,31 +81,31 @@
(function
(lambda ()
(remove-hook 'kill-emacs-hook 'eshell-save-some-history))))
- "*A hook that gets run when `eshell-hist' is unloaded."
+ "A hook that gets run when `eshell-hist' is unloaded."
:type 'hook
:group 'eshell-hist)
(defcustom eshell-history-file-name
(expand-file-name "history" eshell-directory-name)
- "*If non-nil, name of the file to read/write input history.
+ "If non-nil, name of the file to read/write input history.
See also `eshell-read-history' and `eshell-write-history'.
If it is nil, Eshell will use the value of HISTFILE."
:type 'file
:group 'eshell-hist)
(defcustom eshell-history-size 128
- "*Size of the input history ring. If nil, use envvar HISTSIZE."
+ "Size of the input history ring. If nil, use envvar HISTSIZE."
:type 'integer
:group 'eshell-hist)
(defcustom eshell-hist-ignoredups nil
- "*If non-nil, don't add input matching the last on the input ring.
+ "If non-nil, don't add input matching the last on the input ring.
This mirrors the optional behavior of bash."
:type 'boolean
:group 'eshell-hist)
(defcustom eshell-save-history-on-exit t
- "*Determine if history should be automatically saved.
+ "Determine if history should be automatically saved.
History is always preserved after sanely exiting an Eshell buffer.
However, when Emacs is being shut down, this variable determines
whether to prompt the user.
@@ -121,7 +121,7 @@ If set to t, history will always be saved, silently."
(function
(lambda (str)
(not (string-match "\\`\\s-*\\'" str))))
- "*Predicate for filtering additions to input history.
+ "Predicate for filtering additions to input history.
Takes one argument, the input. If non-nil, the input may be saved on
the input history list. Default is to save anything that isn't all
whitespace."
@@ -131,7 +131,7 @@ whitespace."
(put 'eshell-input-filter 'risky-local-variable t)
(defcustom eshell-hist-match-partial t
- "*If non-nil, movement through history is constrained by current input.
+ "If non-nil, movement through history is constrained by current input.
Otherwise, typing <M-p> and <M-n> will always go to the next history
element, regardless of any text on the command line. In that case,
<C-c M-r> and <C-c M-s> still offer that functionality."
@@ -139,25 +139,25 @@ element, regardless of any text on the command line. In that case,
:group 'eshell-hist)
(defcustom eshell-hist-move-to-end t
- "*If non-nil, move to the end of the buffer before cycling history."
+ "If non-nil, move to the end of the buffer before cycling history."
:type 'boolean
:group 'eshell-hist)
(defcustom eshell-hist-event-designator
"^!\\(!\\|-?[0-9]+\\|\\??[^:^$%*?]+\\??\\|#\\)"
- "*The regexp used to identifier history event designators."
+ "The regexp used to identifier history event designators."
:type 'regexp
:group 'eshell-hist)
(defcustom eshell-hist-word-designator
"^:?\\([0-9]+\\|[$^%*]\\)?\\(\\*\\|-[0-9]*\\|[$^%*]\\)?"
- "*The regexp used to identify history word designators."
+ "The regexp used to identify history word designators."
:type 'regexp
:group 'eshell-hist)
(defcustom eshell-hist-modifier
"^\\(:\\([hretpqx&g]\\|s/\\([^/]*\\)/\\([^/]*\\)/\\)\\)*"
- "*The regexp used to identity history modifiers."
+ "The regexp used to identity history modifiers."
:type 'regexp
:group 'eshell-hist)
@@ -174,7 +174,7 @@ element, regardless of any text on the command line. In that case,
([(meta ?n)] . eshell-next-matching-input-from-input)
([up] . eshell-previous-matching-input-from-input)
([down] . eshell-next-matching-input-from-input))
- "*History keys to bind differently if point is in input text."
+ "History keys to bind differently if point is in input text."
:type '(repeat (cons (vector :tag "Keys to bind"
(repeat :inline t sexp))
(function :tag "Command")))
diff --git a/lisp/eshell/em-ls.el b/lisp/eshell/em-ls.el
index 860ad5c77d8..84af53efe58 100644
--- a/lisp/eshell/em-ls.el
+++ b/lisp/eshell/em-ls.el
@@ -54,24 +54,24 @@ properties to colorize its output based on the setting of
(function
(lambda ()
(fset 'insert-directory eshell-ls-orig-insert-directory))))
- "*When unloading `eshell-ls', restore the definition of `insert-directory'."
+ "When unloading `eshell-ls', restore the definition of `insert-directory'."
:type 'hook
:group 'eshell-ls)
(defcustom eshell-ls-initial-args nil
- "*If non-nil, this list of args is included before any call to `ls'.
+ "If non-nil, this list of args is included before any call to `ls'.
This is useful for enabling human-readable format (-h), for example."
:type '(repeat :tag "Arguments" string)
:group 'eshell-ls)
(defcustom eshell-ls-dired-initial-args nil
- "*If non-nil, args is included before any call to `ls' in Dired.
+ "If non-nil, args is included before any call to `ls' in Dired.
This is useful for enabling human-readable format (-h), for example."
:type '(repeat :tag "Arguments" string)
:group 'eshell-ls)
(defcustom eshell-ls-use-in-dired nil
- "*If non-nil, use `eshell-ls' to read directories in Dired."
+ "If non-nil, use `eshell-ls' to read directories in Dired."
:set (lambda (symbol value)
(if value
(unless (and (boundp 'eshell-ls-use-in-dired)
@@ -86,24 +86,24 @@ This is useful for enabling human-readable format (-h), for example."
:group 'eshell-ls)
(defcustom eshell-ls-default-blocksize 1024
- "*The default blocksize to use when display file sizes with -s."
+ "The default blocksize to use when display file sizes with -s."
:type 'integer
:group 'eshell-ls)
(defcustom eshell-ls-exclude-regexp nil
- "*Unless -a is specified, files matching this regexp will not be shown."
+ "Unless -a is specified, files matching this regexp will not be shown."
:type '(choice regexp (const nil))
:group 'eshell-ls)
(defcustom eshell-ls-exclude-hidden t
- "*Unless -a is specified, files beginning with . will not be shown.
+ "Unless -a is specified, files beginning with . will not be shown.
Using this boolean, instead of `eshell-ls-exclude-regexp', is both
faster and conserves more memory."
:type 'boolean
:group 'eshell-ls)
(defcustom eshell-ls-use-colors t
- "*If non-nil, use colors in file listings."
+ "If non-nil, use colors in file listings."
:type 'boolean
:group 'eshell-ls)
@@ -111,7 +111,7 @@ faster and conserves more memory."
'((((class color) (background light)) (:foreground "Blue" :weight bold))
(((class color) (background dark)) (:foreground "SkyBlue" :weight bold))
(t (:weight bold)))
- "*The face used for highlight directories."
+ "The face used for highlight directories."
:group 'eshell-ls)
(define-obsolete-face-alias 'eshell-ls-directory-face
'eshell-ls-directory "22.1")
@@ -119,14 +119,14 @@ faster and conserves more memory."
(defface eshell-ls-symlink
'((((class color) (background light)) (:foreground "Dark Cyan" :weight bold))
(((class color) (background dark)) (:foreground "Cyan" :weight bold)))
- "*The face used for highlight symbolic links."
+ "The face used for highlight symbolic links."
:group 'eshell-ls)
(define-obsolete-face-alias 'eshell-ls-symlink-face 'eshell-ls-symlink "22.1")
(defface eshell-ls-executable
'((((class color) (background light)) (:foreground "ForestGreen" :weight bold))
(((class color) (background dark)) (:foreground "Green" :weight bold)))
- "*The face used for highlighting executables (not directories, though)."
+ "The face used for highlighting executables (not directories, though)."
:group 'eshell-ls)
(define-obsolete-face-alias 'eshell-ls-executable-face
'eshell-ls-executable "22.1")
@@ -134,14 +134,14 @@ faster and conserves more memory."
(defface eshell-ls-readonly
'((((class color) (background light)) (:foreground "Brown"))
(((class color) (background dark)) (:foreground "Pink")))
- "*The face used for highlighting read-only files."
+ "The face used for highlighting read-only files."
:group 'eshell-ls)
(define-obsolete-face-alias 'eshell-ls-readonly-face 'eshell-ls-readonly "22.1")
(defface eshell-ls-unreadable
'((((class color) (background light)) (:foreground "Grey30"))
(((class color) (background dark)) (:foreground "DarkGrey")))
- "*The face used for highlighting unreadable files."
+ "The face used for highlighting unreadable files."
:group 'eshell-ls)
(define-obsolete-face-alias 'eshell-ls-unreadable-face
'eshell-ls-unreadable "22.1")
@@ -149,49 +149,50 @@ faster and conserves more memory."
(defface eshell-ls-special
'((((class color) (background light)) (:foreground "Magenta" :weight bold))
(((class color) (background dark)) (:foreground "Magenta" :weight bold)))
- "*The face used for highlighting non-regular files."
+ "The face used for highlighting non-regular files."
:group 'eshell-ls)
(define-obsolete-face-alias 'eshell-ls-special-face 'eshell-ls-special "22.1")
(defface eshell-ls-missing
'((((class color) (background light)) (:foreground "Red" :weight bold))
(((class color) (background dark)) (:foreground "Red" :weight bold)))
- "*The face used for highlighting non-existent file names."
+ "The face used for highlighting non-existent file names."
:group 'eshell-ls)
(define-obsolete-face-alias 'eshell-ls-missing-face 'eshell-ls-missing "22.1")
(defcustom eshell-ls-archive-regexp
(concat "\\.\\(t\\(a[rz]\\|gz\\)\\|arj\\|lzh\\|"
- "zip\\|[zZ]\\|gz\\|bz2\\|deb\\|rpm\\)\\'")
- "*A regular expression that matches names of file archives.
+ "zip\\|[zZ]\\|gz\\|bz2\\|xz\\|deb\\|rpm\\)\\'")
+ "A regular expression that matches names of file archives.
This typically includes both traditional archives and compressed
files."
+ :version "24.1" ; added xz
:type 'regexp
:group 'eshell-ls)
(defface eshell-ls-archive
'((((class color) (background light)) (:foreground "Orchid" :weight bold))
(((class color) (background dark)) (:foreground "Orchid" :weight bold)))
- "*The face used for highlighting archived and compressed file names."
+ "The face used for highlighting archived and compressed file names."
:group 'eshell-ls)
(define-obsolete-face-alias 'eshell-ls-archive-face 'eshell-ls-archive "22.1")
(defcustom eshell-ls-backup-regexp
"\\(\\`\\.?#\\|\\(\\.bak\\|~\\)\\'\\)"
- "*A regular expression that matches names of backup files."
+ "A regular expression that matches names of backup files."
:type 'regexp
:group 'eshell-ls)
(defface eshell-ls-backup
'((((class color) (background light)) (:foreground "OrangeRed"))
(((class color) (background dark)) (:foreground "LightSalmon")))
- "*The face used for highlighting backup file names."
+ "The face used for highlighting backup file names."
:group 'eshell-ls)
(define-obsolete-face-alias 'eshell-ls-backup-face 'eshell-ls-backup "22.1")
(defcustom eshell-ls-product-regexp
"\\.\\(elc\\|o\\(bj\\)?\\|a\\|lib\\|res\\)\\'"
- "*A regular expression that matches names of product files.
+ "A regular expression that matches names of product files.
Products are files that get generated from a source file, and hence
ought to be recreatable if they are deleted."
:type 'regexp
@@ -200,13 +201,13 @@ ought to be recreatable if they are deleted."
(defface eshell-ls-product
'((((class color) (background light)) (:foreground "OrangeRed"))
(((class color) (background dark)) (:foreground "LightSalmon")))
- "*The face used for highlighting files that are build products."
+ "The face used for highlighting files that are build products."
:group 'eshell-ls)
(define-obsolete-face-alias 'eshell-ls-product-face 'eshell-ls-product "22.1")
(defcustom eshell-ls-clutter-regexp
"\\(^texput\\.log\\|^core\\)\\'"
- "*A regular expression that matches names of junk files.
+ "A regular expression that matches names of junk files.
These are mainly files that get created for various reasons, but don't
really need to stick around for very long."
:type 'regexp
@@ -215,7 +216,7 @@ really need to stick around for very long."
(defface eshell-ls-clutter
'((((class color) (background light)) (:foreground "OrangeRed" :weight bold))
(((class color) (background dark)) (:foreground "OrangeRed" :weight bold)))
- "*The face used for highlighting junk file names."
+ "The face used for highlighting junk file names."
:group 'eshell-ls)
(define-obsolete-face-alias 'eshell-ls-clutter-face 'eshell-ls-clutter "22.1")
@@ -249,7 +250,7 @@ calling FUNC with FILE as an argument."
(,(eval func) ,file)))))
(defcustom eshell-ls-highlight-alist nil
- "*This alist correlates test functions to color.
+ "This alist correlates test functions to color.
The format of the members of this alist is
(TEST-SEXP . FACE)
@@ -611,11 +612,11 @@ In Eshell's implementation of ls, ENTRIES is always reversed."
(let ((result
(cond
((eq sort-method 'by-atime)
- (eshell-ls-compare-entries l r 4 'eshell-time-less-p))
+ (eshell-ls-compare-entries l r 4 'time-less-p))
((eq sort-method 'by-mtime)
- (eshell-ls-compare-entries l r 5 'eshell-time-less-p))
+ (eshell-ls-compare-entries l r 5 'time-less-p))
((eq sort-method 'by-ctime)
- (eshell-ls-compare-entries l r 6 'eshell-time-less-p))
+ (eshell-ls-compare-entries l r 6 'time-less-p))
((eq sort-method 'by-size)
(eshell-ls-compare-entries l r 7 '<))
((eq sort-method 'by-extension)
@@ -940,5 +941,4 @@ to use, and each member of which is the width of that column
;; generated-autoload-file: "esh-groups.el"
;; End:
-;; arch-tag: 9295181c-0cb2-499c-999b-89f5359842cb
;;; em-ls.el ends here
diff --git a/lisp/eshell/em-pred.el b/lisp/eshell/em-pred.el
index aee1b5437de..2b5cb1a0dc4 100644
--- a/lisp/eshell/em-pred.el
+++ b/lisp/eshell/em-pred.el
@@ -61,7 +61,7 @@ ordinary strings."
;;; User Variables:
(defcustom eshell-pred-load-hook '(eshell-pred-initialize)
- "*A list of functions to run when `eshell-pred' is loaded."
+ "A list of functions to run when `eshell-pred' is loaded."
:type 'hook
:group 'eshell-pred)
@@ -101,7 +101,7 @@ ordinary strings."
(?m . (eshell-pred-file-time ?m "modification" 5))
(?c . (eshell-pred-file-time ?c "change" 6))
(?L . (eshell-pred-file-size)))
- "*A list of predicates than can be applied to a globbing pattern.
+ "A list of predicates than can be applied to a globbing pattern.
The format of each entry is
(CHAR . PREDICATE-FUNC-SEXP)"
@@ -150,7 +150,7 @@ The format of each entry is
(eshell-pred-substitute t)
(error "`g' modifier cannot be used alone"))))
(?s . (eshell-pred-substitute)))
- "*A list of modifiers than can be applied to an argument expansion.
+ "A list of modifiers than can be applied to an argument expansion.
The format of each entry is
(CHAR ENTRYWISE-P MODIFIER-FUNC-SEXP)"
@@ -427,7 +427,7 @@ returning the resultant string."
(forward-char))
(if (looking-at "[0-9]+")
(progn
- (setq when (- (eshell-time-to-seconds (current-time))
+ (setq when (- (float-time)
(* (string-to-number (match-string 0))
quantum)))
(goto-char (match-end 0)))
@@ -444,7 +444,7 @@ returning the resultant string."
(attrs (file-attributes file)))
(unless attrs
(error "Cannot stat file `%s'" file))
- (setq when (eshell-time-to-seconds (nth attr-index attrs))))
+ (setq when (float-time (nth attr-index attrs))))
(goto-char (1+ end)))
`(lambda (file)
(let ((attrs (file-attributes file)))
@@ -453,7 +453,7 @@ returning the resultant string."
'<
(if (eq qual ?+)
'>
- '=)) ,when (eshell-time-to-seconds
+ '=)) ,when (float-time
(nth ,attr-index attrs))))))))
(defun eshell-pred-file-type (type)
@@ -605,5 +605,4 @@ that 'ls -l' will show in the first column of its display. "
;; generated-autoload-file: "esh-groups.el"
;; End:
-;; arch-tag: 8b5ce022-17f3-4c40-93c7-5faafaa63f31
;;; em-pred.el ends here
diff --git a/lisp/eshell/em-prompt.el b/lisp/eshell/em-prompt.el
index 6e8abd660d1..29e1ace26b1 100644
--- a/lisp/eshell/em-prompt.el
+++ b/lisp/eshell/em-prompt.el
@@ -39,7 +39,7 @@ as is common with most shells."
;;; User Variables:
(defcustom eshell-prompt-load-hook '(eshell-prompt-initialize)
- "*A list of functions to call when loading `eshell-prompt'."
+ "A list of functions to call when loading `eshell-prompt'."
:type 'hook
:group 'eshell-prompt)
@@ -55,7 +55,7 @@ prompt."
:group 'eshell-prompt)
(defcustom eshell-prompt-regexp "^[^#$\n]* [#$] "
- "*A regexp which fully matches your eshell prompt.
+ "A regexp which fully matches your eshell prompt.
This setting is important, since it affects how eshell will interpret
the lines that are passed to it.
If this variable is changed, all Eshell buffers must be exited and
@@ -64,7 +64,7 @@ re-entered for it to take effect."
:group 'eshell-prompt)
(defcustom eshell-highlight-prompt t
- "*If non-nil, Eshell should highlight the prompt."
+ "If non-nil, Eshell should highlight the prompt."
:type 'boolean
:group 'eshell-prompt)
@@ -72,20 +72,20 @@ re-entered for it to take effect."
'((((class color) (background light)) (:foreground "Red" :bold t))
(((class color) (background dark)) (:foreground "Pink" :bold t))
(t (:bold t)))
- "*The face used to highlight prompt strings.
+ "The face used to highlight prompt strings.
For highlighting other kinds of strings -- similar to shell mode's
behavior -- simply use an output filer which changes text properties."
:group 'eshell-prompt)
(define-obsolete-face-alias 'eshell-prompt-face 'eshell-prompt "22.1")
(defcustom eshell-before-prompt-hook nil
- "*A list of functions to call before outputting the prompt."
+ "A list of functions to call before outputting the prompt."
:type 'hook
:options '(eshell-begin-on-new-line)
:group 'eshell-prompt)
(defcustom eshell-after-prompt-hook nil
- "*A list of functions to call after outputting the prompt.
+ "A list of functions to call after outputting the prompt.
Note that if `eshell-scroll-show-maximum-output' is non-nil, then
setting `eshell-show-maximum-output' here won't do much. It depends
on whether the user wants the resizing to happen while output is
diff --git a/lisp/eshell/em-rebind.el b/lisp/eshell/em-rebind.el
index ef60cf793a0..9b208d64803 100644
--- a/lisp/eshell/em-rebind.el
+++ b/lisp/eshell/em-rebind.el
@@ -43,7 +43,7 @@ the behavior of normal shells while the user editing new input text."
;;; User Variables:
(defcustom eshell-rebind-load-hook '(eshell-rebind-initialize)
- "*A list of functions to call when loading `eshell-rebind'."
+ "A list of functions to call when loading `eshell-rebind'."
:type 'hook
:group 'eshell-rebind)
@@ -55,14 +55,14 @@ the behavior of normal shells while the user editing new input text."
([delete] . eshell-delete-backward-char)
([(control ?w)] . backward-kill-word)
([(control ?u)] . eshell-kill-input))
- "*Bind some keys differently if point is in input text."
+ "Bind some keys differently if point is in input text."
:type '(repeat (cons (vector :tag "Keys to bind"
(repeat :inline t sexp))
(function :tag "Command")))
:group 'eshell-rebind)
(defcustom eshell-confine-point-to-input t
- "*If non-nil, do not allow the point to leave the current input.
+ "If non-nil, do not allow the point to leave the current input.
This is more difficult to do nicely in Emacs than one might think.
Basically, the `point-left' attribute is added to the input text, and
a function is placed on that hook to take the point back to
@@ -77,13 +77,13 @@ people will left the point alone in the Eshell buffer. Sigh."
:group 'eshell-rebind)
(defcustom eshell-error-if-move-away t
- "*If non-nil, consider it an error to try to move outside current input.
+ "If non-nil, consider it an error to try to move outside current input.
This is default behavior of shells like bash."
:type 'boolean
:group 'eshell-rebind)
(defcustom eshell-remap-previous-input t
- "*If non-nil, remap input keybindings on previous prompts as well."
+ "If non-nil, remap input keybindings on previous prompts as well."
:type 'boolean
:group 'eshell-rebind)
@@ -132,7 +132,7 @@ This is default behavior of shells like bash."
forward-visible-line
forward-comment
forward-thing)
- "*A list of commands that cannot leave the input area."
+ "A list of commands that cannot leave the input area."
:type '(repeat function)
:group 'eshell-rebind)
diff --git a/lisp/eshell/em-script.el b/lisp/eshell/em-script.el
index 0371ee86b6d..21a5d804073 100644
--- a/lisp/eshell/em-script.el
+++ b/lisp/eshell/em-script.el
@@ -36,19 +36,19 @@ commands, as a script file."
;;; User Variables:
(defcustom eshell-script-load-hook '(eshell-script-initialize)
- "*A list of functions to call when loading `eshell-script'."
+ "A list of functions to call when loading `eshell-script'."
:type 'hook
:group 'eshell-script)
(defcustom eshell-login-script (expand-file-name "login" eshell-directory-name)
- "*If non-nil, a file to invoke when starting up Eshell interactively.
+ "If non-nil, a file to invoke when starting up Eshell interactively.
This file should be a file containing Eshell commands, where comment
lines begin with '#'."
:type 'file
:group 'eshell-script)
(defcustom eshell-rc-script (expand-file-name "profile" eshell-directory-name)
- "*If non-nil, a file to invoke whenever Eshell is started.
+ "If non-nil, a file to invoke whenever Eshell is started.
This includes when running `eshell-command'."
:type 'file
:group 'eshell-script)
@@ -90,23 +90,25 @@ Comments begin with '#'."
(interactive "f")
(let ((orig (point))
(here (point-max))
- (inhibit-point-motion-hooks t)
- after-change-functions)
+ (inhibit-point-motion-hooks t))
(goto-char (point-max))
- (insert-file-contents file)
- (goto-char (point-max))
- (throw 'eshell-replace-command
- (prog1
- (list 'let
- (list (list 'eshell-command-name (list 'quote file))
- (list 'eshell-command-arguments
- (list 'quote args)))
- (let ((cmd (eshell-parse-command (cons here (point)))))
- (if subcommand-p
- (setq cmd (list 'eshell-as-subcommand cmd)))
- cmd))
- (delete-region here (point))
- (goto-char orig)))))
+ (with-silent-modifications
+ ;; FIXME: Why not use a temporary buffer and avoid this
+ ;; "insert&delete" business? --Stef
+ (insert-file-contents file)
+ (goto-char (point-max))
+ (throw 'eshell-replace-command
+ (prog1
+ (list 'let
+ (list (list 'eshell-command-name (list 'quote file))
+ (list 'eshell-command-arguments
+ (list 'quote args)))
+ (let ((cmd (eshell-parse-command (cons here (point)))))
+ (if subcommand-p
+ (setq cmd (list 'eshell-as-subcommand cmd)))
+ cmd))
+ (delete-region here (point))
+ (goto-char orig))))))
(defun eshell/source (&rest args)
"Source a file in a subshell environment."
diff --git a/lisp/eshell/em-smart.el b/lisp/eshell/em-smart.el
index c9be839e12b..afe3cf826b1 100644
--- a/lisp/eshell/em-smart.el
+++ b/lisp/eshell/em-smart.el
@@ -86,7 +86,7 @@ it to get a real sense of how it works."
;;; User Variables:
(defcustom eshell-smart-load-hook '(eshell-smart-initialize)
- "*A list of functions to call when loading `eshell-smart'."
+ "A list of functions to call when loading `eshell-smart'."
:type 'hook
:group 'eshell-smart)
@@ -96,12 +96,12 @@ it to get a real sense of how it works."
(lambda ()
(remove-hook 'window-configuration-change-hook
'eshell-refresh-windows))))
- "*A hook that gets run when `eshell-smart' is unloaded."
+ "A hook that gets run when `eshell-smart' is unloaded."
:type 'hook
:group 'eshell-smart)
(defcustom eshell-review-quick-commands nil
- "*If t, always review commands.
+ "If t, always review commands.
Reviewing means keeping point on the text of the command that was just
invoked, to allow corrections to be made easily.
@@ -124,12 +124,12 @@ only if that output can be presented in its entirely in the Eshell window."
yank-pop
yank-rectangle
yank)
- "*A list of commands which cause Eshell to jump to the end of buffer."
+ "A list of commands which cause Eshell to jump to the end of buffer."
:type '(repeat function)
:group 'eshell-smart)
(defcustom eshell-smart-space-goes-to-end t
- "*If non-nil, space will go to end of buffer when point-max is visible.
+ "If non-nil, space will go to end of buffer when point-max is visible.
That is, if a command is running and the user presses SPACE at a time
when the end of the buffer is visible, point will go to the end of the
buffer and smart-display will be turned off (that is, subsequently
@@ -148,7 +148,7 @@ buffer using \\[end-of-buffer]."
:group 'eshell-smart)
(defcustom eshell-where-to-jump 'begin
- "*This variable indicates where point should jump to after a command.
+ "This variable indicates where point should jump to after a command.
The options are `begin', `after' or `end'."
:type '(radio (const :tag "Beginning of command" begin)
(const :tag "After command word" after)
diff --git a/lisp/eshell/em-term.el b/lisp/eshell/em-term.el
index 8662dd9fffb..bd27d9f262e 100644
--- a/lisp/eshell/em-term.el
+++ b/lisp/eshell/em-term.el
@@ -48,7 +48,7 @@ which commands are considered visual in nature."
;;; User Variables:
(defcustom eshell-term-load-hook '(eshell-term-initialize)
- "*A list of functions to call when loading `eshell-term'."
+ "A list of functions to call when loading `eshell-term'."
:type 'hook
:group 'eshell-term)
@@ -58,19 +58,19 @@ which commands are considered visual in nature."
"less" "more" ; M-x view-file
"lynx" "ncftp" ; w3.el, ange-ftp
"pine" "tin" "trn" "elm") ; GNUS!!
- "*A list of commands that present their output in a visual fashion."
+ "A list of commands that present their output in a visual fashion."
:type '(repeat string)
:group 'eshell-term)
(defcustom eshell-term-name "eterm"
- "*Name to use for the TERM variable when running visual commands.
+ "Name to use for the TERM variable when running visual commands.
See `term-term-name' in term.el for more information on how this is
used."
:type 'string
:group 'eshell-term)
(defcustom eshell-escape-control-x t
- "*If non-nil, allow <C-x> to be handled by Emacs key in visual buffers.
+ "If non-nil, allow <C-x> to be handled by Emacs key in visual buffers.
See the variable `eshell-visual-commands'. If this variable is set to
nil, <C-x> will send that control character to the invoked process."
:type 'boolean
@@ -187,8 +187,7 @@ allowed."
; (if (boundp 'xemacs-logo)
; (eshell-term-send-raw-string
; (or (condition-case () (x-get-selection) (error ()))
-; (x-get-cutbuffer)
-; (error "No selection or cut buffer available")))
+; (error "No selection available")))
; ;; Give temporary modes such as isearch a chance to turn off.
; (run-hooks 'mouse-leave-buffer-hook)
; (setq this-command 'yank)
diff --git a/lisp/eshell/em-unix.el b/lisp/eshell/em-unix.el
index 6ceb591e131..d4f62415084 100644
--- a/lisp/eshell/em-unix.el
+++ b/lisp/eshell/em-unix.el
@@ -55,84 +55,84 @@ by name)."
:group 'eshell-module)
(defcustom eshell-unix-load-hook '(eshell-unix-initialize)
- "*A list of functions to run when `eshell-unix' is loaded."
+ "A list of functions to run when `eshell-unix' is loaded."
:type 'hook
:group 'eshell-unix)
(defcustom eshell-plain-grep-behavior nil
- "*If non-nil, standalone \"grep\" commands will behave normally.
+ "If non-nil, standalone \"grep\" commands will behave normally.
Standalone in this context means not redirected, and not on the
receiving side of a command pipeline."
:type 'boolean
:group 'eshell-unix)
(defcustom eshell-no-grep-available (not (eshell-search-path "grep"))
- "*If non-nil, no grep is available on the current machine."
+ "If non-nil, no grep is available on the current machine."
:type 'boolean
:group 'eshell-unix)
(defcustom eshell-plain-diff-behavior nil
- "*If non-nil, standalone \"diff\" commands will behave normally.
+ "If non-nil, standalone \"diff\" commands will behave normally.
Standalone in this context means not redirected, and not on the
receiving side of a command pipeline."
:type 'boolean
:group 'eshell-unix)
(defcustom eshell-plain-locate-behavior (featurep 'xemacs)
- "*If non-nil, standalone \"locate\" commands will behave normally.
+ "If non-nil, standalone \"locate\" commands will behave normally.
Standalone in this context means not redirected, and not on the
receiving side of a command pipeline."
:type 'boolean
:group 'eshell-unix)
(defcustom eshell-rm-removes-directories nil
- "*If non-nil, `rm' will remove directory entries.
+ "If non-nil, `rm' will remove directory entries.
Otherwise, `rmdir' is required."
:type 'boolean
:group 'eshell-unix)
(defcustom eshell-rm-interactive-query (= (user-uid) 0)
- "*If non-nil, `rm' will query before removing anything."
+ "If non-nil, `rm' will query before removing anything."
:type 'boolean
:group 'eshell-unix)
(defcustom eshell-mv-interactive-query (= (user-uid) 0)
- "*If non-nil, `mv' will query before overwriting anything."
+ "If non-nil, `mv' will query before overwriting anything."
:type 'boolean
:group 'eshell-unix)
(defcustom eshell-mv-overwrite-files t
- "*If non-nil, `mv' will overwrite files without warning."
+ "If non-nil, `mv' will overwrite files without warning."
:type 'boolean
:group 'eshell-unix)
(defcustom eshell-cp-interactive-query (= (user-uid) 0)
- "*If non-nil, `cp' will query before overwriting anything."
+ "If non-nil, `cp' will query before overwriting anything."
:type 'boolean
:group 'eshell-unix)
(defcustom eshell-cp-overwrite-files t
- "*If non-nil, `cp' will overwrite files without warning."
+ "If non-nil, `cp' will overwrite files without warning."
:type 'boolean
:group 'eshell-unix)
(defcustom eshell-ln-interactive-query (= (user-uid) 0)
- "*If non-nil, `ln' will query before overwriting anything."
+ "If non-nil, `ln' will query before overwriting anything."
:type 'boolean
:group 'eshell-unix)
(defcustom eshell-ln-overwrite-files nil
- "*If non-nil, `ln' will overwrite files without warning."
+ "If non-nil, `ln' will overwrite files without warning."
:type 'boolean
:group 'eshell-unix)
(defcustom eshell-default-target-is-dot nil
- "*If non-nil, the default destination for cp, mv or ln is `.'."
+ "If non-nil, the default destination for cp, mv or ln is `.'."
:type 'boolean
:group 'eshell-unix)
(defcustom eshell-du-prefer-over-ange nil
- "*Use Eshell's du in ange-ftp remote directories.
+ "Use Eshell's du in ange-ftp remote directories.
Otherwise, Emacs will attempt to use rsh to invoke du on the remote machine."
:type 'boolean
:group 'eshell-unix)
@@ -154,10 +154,10 @@ Otherwise, Emacs will attempt to use rsh to invoke du on the remote machine."
(defalias 'eshell/basename 'file-name-nondirectory)
(defalias 'eshell/dirname 'file-name-directory)
-(defvar interactive)
-(defvar preview)
-(defvar recursive)
-(defvar verbose)
+(defvar em-interactive)
+(defvar em-preview)
+(defvar em-recursive)
+(defvar em-verbose)
(defun eshell/man (&rest args)
"Invoke man, flattening the arguments appropriately."
@@ -203,32 +203,26 @@ Otherwise, Emacs will attempt to use rsh to invoke du on the remote machine."
(eshell-error "rm: cannot remove `.' or `..'\n"))
(if (and (file-directory-p (car files))
(not (file-symlink-p (car files))))
- (let ((dir (file-name-as-directory (car files))))
- (eshell-remove-entries dir
- (mapcar
- (function
- (lambda (file)
- (concat dir file)))
- (directory-files dir)))
- (if verbose
+ (progn
+ (if em-verbose
(eshell-printn (format "rm: removing directory `%s'"
(car files))))
(unless
- (or preview
- (and interactive
+ (or em-preview
+ (and em-interactive
(not (y-or-n-p
(format "rm: remove directory `%s'? "
(car files))))))
- (eshell-funcalln 'delete-directory (car files))))
- (if verbose
+ (eshell-funcalln 'delete-directory (car files) t t)))
+ (if em-verbose
(eshell-printn (format "rm: removing file `%s'"
(car files))))
- (unless (or preview
- (and interactive
+ (unless (or em-preview
+ (and em-interactive
(not (y-or-n-p
(format "rm: remove `%s'? "
(car files))))))
- (eshell-funcalln 'delete-file (car files)))))
+ (eshell-funcalln 'delete-file (car files) t))))
(setq files (cdr files))))
(defun eshell/rm (&rest args)
@@ -241,21 +235,21 @@ argument."
"rm" args
'((?h "help" nil nil "show this usage screen")
(?f "force" nil force-removal "force removal")
- (?i "interactive" nil interactive "prompt before any removal")
- (?n "preview" nil preview "don't change anything on disk")
- (?r "recursive" nil recursive
+ (?i "interactive" nil em-interactive "prompt before any removal")
+ (?n "preview" nil em-preview "don't change anything on disk")
+ (?r "recursive" nil em-recursive
"remove the contents of directories recursively")
- (?R nil nil recursive "(same)")
- (?v "verbose" nil verbose "explain what is being done")
+ (?R nil nil em-recursive "(same)")
+ (?v "verbose" nil em-verbose "explain what is being done")
:preserve-args
:external "rm"
:show-usage
:usage "[OPTION]... FILE...
Remove (unlink) the FILE(s).")
- (unless interactive
- (setq interactive eshell-rm-interactive-query))
- (if (and force-removal interactive)
- (setq interactive nil))
+ (unless em-interactive
+ (setq em-interactive eshell-rm-interactive-query))
+ (if (and force-removal em-interactive)
+ (setq em-interactive nil))
(while args
(let ((entry (if (stringp (car args))
(directory-file-name (car args))
@@ -264,37 +258,37 @@ Remove (unlink) the FILE(s).")
(car args)))))
(cond
((bufferp entry)
- (if verbose
+ (if em-verbose
(eshell-printn (format "rm: removing buffer `%s'" entry)))
- (unless (or preview
- (and interactive
+ (unless (or em-preview
+ (and em-interactive
(not (y-or-n-p (format "rm: delete buffer `%s'? "
entry)))))
(eshell-funcalln 'kill-buffer entry)))
((eshell-processp entry)
- (if verbose
+ (if em-verbose
(eshell-printn (format "rm: killing process `%s'" entry)))
- (unless (or preview
- (and interactive
+ (unless (or em-preview
+ (and em-interactive
(not (y-or-n-p (format "rm: kill process `%s'? "
entry)))))
(eshell-funcalln 'kill-process entry)))
((symbolp entry)
- (if verbose
+ (if em-verbose
(eshell-printn (format "rm: uninterning symbol `%s'" entry)))
(unless
- (or preview
- (and interactive
+ (or em-preview
+ (and em-interactive
(not (y-or-n-p (format "rm: unintern symbol `%s'? "
entry)))))
(eshell-funcalln 'unintern entry)))
((stringp entry)
(if (and (file-directory-p entry)
(not (file-symlink-p entry)))
- (if (or recursive
+ (if (or em-recursive
eshell-rm-removes-directories)
- (if (or preview
- (not interactive)
+ (if (or em-preview
+ (not em-interactive)
(y-or-n-p
(format "rm: descend into directory `%s'? "
entry)))
@@ -339,8 +333,6 @@ Remove the DIRECTORY(ies), if they are empty.")
(put 'eshell/rmdir 'eshell-no-numeric-conversions t)
(defvar no-dereference)
-(defvar preview)
-(defvar verbose)
(defvar eshell-warn-dot-directories t)
@@ -348,9 +340,9 @@ Remove the DIRECTORY(ies), if they are empty.")
"Shuffle around some filesystem entries, using FUNC to do the work."
(let ((attr-target (eshell-file-attributes target))
(is-dir (or (file-directory-p target)
- (and preview (not eshell-warn-dot-directories))))
+ (and em-preview (not eshell-warn-dot-directories))))
attr)
- (if (and (not preview) (not is-dir)
+ (if (and (not em-preview) (not is-dir)
(> (length files) 1))
(error "%s: when %s multiple files, last argument must be a directory"
command action))
@@ -387,7 +379,7 @@ Remove the DIRECTORY(ies), if they are empty.")
(not (memq func '(make-symbolic-link
add-name-to-file))))
(if (and (eq func 'copy-file)
- (not recursive))
+ (not em-recursive))
(eshell-error (format "%s: %s: omitting directory\n"
command (car files)))
(let (eshell-warn-dot-directories)
@@ -405,11 +397,11 @@ Remove the DIRECTORY(ies), if they are empty.")
(expand-file-name target)))))))
(apply 'eshell-funcalln func source target args)
(unless (file-directory-p target)
- (if verbose
+ (if em-verbose
(eshell-printn
(format "%s: making directory %s"
command target)))
- (unless preview
+ (unless em-preview
(eshell-funcalln 'make-directory target)))
(apply 'eshell-shuffle-files
command action
@@ -420,16 +412,16 @@ Remove the DIRECTORY(ies), if they are empty.")
(directory-files source))
target func t args)
(when (eq func 'rename-file)
- (if verbose
+ (if em-verbose
(eshell-printn
(format "%s: deleting directory %s"
command source)))
- (unless preview
+ (unless em-preview
(eshell-funcalln 'delete-directory source))))))
- (if verbose
+ (if em-verbose
(eshell-printn (format "%s: %s -> %s" command
source target)))
- (unless preview
+ (unless em-preview
(if (and no-dereference
(setq link (file-symlink-p source)))
(progn
@@ -454,7 +446,7 @@ Remove the DIRECTORY(ies), if they are empty.")
(if (file-exists-p archive)
(setq tar-args (concat "u" tar-args))
(setq tar-args (concat "c" tar-args)))
- (if verbose
+ (if em-verbose
(setq tar-args (concat "v" tar-args)))
(if (equal command "mv")
(setq tar-args (concat "--remove-files -" tar-args)))
@@ -487,7 +479,7 @@ Remove the DIRECTORY(ies), if they are empty.")
(eshell-shuffle-files
,command ,action args target ,func nil
,@(append
- `((if (and (or interactive
+ `((if (and (or em-interactive
,query-var)
(not force))
1 (or force ,force-var)))
@@ -501,11 +493,11 @@ Remove the DIRECTORY(ies), if they are empty.")
"mv" args
'((?f "force" nil force
"remove existing destinations, never prompt")
- (?i "interactive" nil interactive
+ (?i "interactive" nil em-interactive
"request confirmation if target already exists")
- (?n "preview" nil preview
+ (?n "preview" nil em-preview
"don't change anything on disk")
- (?v "verbose" nil verbose
+ (?v "verbose" nil em-verbose
"explain what is being done")
(nil "help" nil nil "show this usage screen")
:preserve-args
@@ -532,15 +524,15 @@ Rename SOURCE to DEST, or move SOURCE(s) to DIRECTORY.
"preserve links")
(?f "force" nil force
"remove existing destinations, never prompt")
- (?i "interactive" nil interactive
+ (?i "interactive" nil em-interactive
"request confirmation if target already exists")
- (?n "preview" nil preview
+ (?n "preview" nil em-preview
"don't change anything on disk")
(?p "preserve" nil preserve
"preserve file attributes if possible")
- (?R "recursive" nil recursive
+ (?R "recursive" nil em-recursive
"copy directories recursively")
- (?v "verbose" nil verbose
+ (?v "verbose" nil em-verbose
"explain what is being done")
(nil "help" nil nil "show this usage screen")
:preserve-args
@@ -550,7 +542,7 @@ Rename SOURCE to DEST, or move SOURCE(s) to DIRECTORY.
or: cp [OPTION]... SOURCE... DIRECTORY
Copy SOURCE to DEST, or multiple SOURCE(s) to DIRECTORY.")
(if archive
- (setq preserve t no-dereference t recursive t))
+ (setq preserve t no-dereference t em-recursive t))
(eshell-mvcpln-template "cp" "copying" 'copy-file
eshell-cp-interactive-query
eshell-cp-overwrite-files preserve)))
@@ -564,12 +556,12 @@ Copy SOURCE to DEST, or multiple SOURCE(s) to DIRECTORY.")
'((?h "help" nil nil "show this usage screen")
(?s "symbolic" nil symbolic
"make symbolic links instead of hard links")
- (?i "interactive" nil interactive
+ (?i "interactive" nil em-interactive
"request confirmation if target already exists")
(?f "force" nil force "remove existing destinations, never prompt")
- (?n "preview" nil preview
+ (?n "preview" nil em-preview
"don't change anything on disk")
- (?v "verbose" nil verbose "explain what is being done")
+ (?v "verbose" nil em-verbose "explain what is being done")
:preserve-args
:external "ln"
:show-usage
@@ -920,9 +912,7 @@ Summarize disk usage of each FILE, recursively for directories.")
(defvar eshell-time-start nil)
(defun eshell-show-elapsed-time ()
- (let ((elapsed (format "%.3f secs\n"
- (- (eshell-time-to-seconds (current-time))
- eshell-time-start))))
+ (let ((elapsed (format "%.3f secs\n" (- (float-time) eshell-time-start))))
(set-text-properties 0 (length elapsed) '(face bold) elapsed)
(eshell-interactive-print elapsed))
(remove-hook 'eshell-post-command-hook 'eshell-show-elapsed-time t))
@@ -948,7 +938,7 @@ Summarize disk usage of each FILE, recursively for directories.")
:show-usage
:usage "COMMAND...
Show wall-clock time elapsed during execution of COMMAND.")
- (setq eshell-time-start (eshell-time-to-seconds (current-time)))
+ (setq eshell-time-start (float-time))
(add-hook 'eshell-post-command-hook 'eshell-show-elapsed-time nil t)
;; after setting
(throw 'eshell-replace-command
@@ -1127,5 +1117,4 @@ Execute a COMMAND as the superuser or another USER.")
;; generated-autoload-file: "esh-groups.el"
;; End:
-;; arch-tag: 2462edd2-a76a-4cf2-897d-92e9a82ac1c9
;;; em-unix.el ends here
diff --git a/lisp/eshell/esh-arg.el b/lisp/eshell/esh-arg.el
index 6395fe22d87..e6d73acd434 100644
--- a/lisp/eshell/esh-arg.el
+++ b/lisp/eshell/esh-arg.el
@@ -123,7 +123,7 @@ treated as a literal character."
:type 'hook
:group 'eshell-arg)
-(defcustom eshell-delimiter-argument-list '(?\; ?& ?\| ?\> ? ?\t ?\n)
+(defcustom eshell-delimiter-argument-list '(?\; ?& ?\| ?\> ?\s ?\t ?\n)
"List of characters to recognize as argument separators."
:type '(repeat character)
:group 'eshell-arg)
@@ -214,25 +214,24 @@ Point is left at the end of the arguments."
(narrow-to-region beg end)
(let ((inhibit-point-motion-hooks t)
(args (list t))
- after-change-functions
delim)
- (remove-text-properties (point-min) (point-max)
- '(arg-begin nil arg-end nil))
- (if (setq
- delim
- (catch 'eshell-incomplete
- (while (not (eobp))
- (let* ((here (point))
- (arg (eshell-parse-argument)))
- (if (= (point) here)
- (error "Failed to parse argument '%s'"
- (buffer-substring here (point-max))))
- (and arg (nconc args (list arg)))))))
- (if (listp delim)
- (throw 'eshell-incomplete delim)
- (throw 'eshell-incomplete
- (list delim (point) (cdr args)))))
- (cdr args)))))
+ (with-silent-modifications
+ (remove-text-properties (point-min) (point-max)
+ '(arg-begin nil arg-end nil))
+ (if (setq
+ delim
+ (catch 'eshell-incomplete
+ (while (not (eobp))
+ (let* ((here (point))
+ (arg (eshell-parse-argument)))
+ (if (= (point) here)
+ (error "Failed to parse argument '%s'"
+ (buffer-substring here (point-max))))
+ (and arg (nconc args (list arg)))))))
+ (throw 'eshell-incomplete (if (listp delim)
+ delim
+ (list delim (point) (cdr args)))))
+ (cdr args))))))
(defun eshell-parse-argument ()
"Get the next argument. Leave point after it."
diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el
index ed335ab5fd4..a12d8fb7f3b 100644
--- a/lisp/eshell/esh-cmd.el
+++ b/lisp/eshell/esh-cmd.el
@@ -122,28 +122,28 @@ however."
:group 'eshell)
(defcustom eshell-prefer-lisp-functions nil
- "*If non-nil, prefer Lisp functions to external commands."
+ "If non-nil, prefer Lisp functions to external commands."
:type 'boolean
:group 'eshell-cmd)
(defcustom eshell-lisp-regexp "\\([(`]\\|#'\\)"
- "*A regexp which, if matched at beginning of an argument, means Lisp.
+ "A regexp which, if matched at beginning of an argument, means Lisp.
Such arguments will be passed to `read', and then evaluated."
:type 'regexp
:group 'eshell-cmd)
(defcustom eshell-pre-command-hook nil
- "*A hook run before each interactive command is invoked."
+ "A hook run before each interactive command is invoked."
:type 'hook
:group 'eshell-cmd)
(defcustom eshell-post-command-hook nil
- "*A hook run after each interactive command is invoked."
+ "A hook run after each interactive command is invoked."
:type 'hook
:group 'eshell-cmd)
(defcustom eshell-prepare-command-hook nil
- "*A set of functions called to prepare a named command.
+ "A set of functions called to prepare a named command.
The command name and its argument are in `eshell-last-command-name'
and `eshell-last-arguments'. The functions on this hook can change
the value of these symbols if necessary.
@@ -154,7 +154,7 @@ To prevent a command from executing at all, set
:group 'eshell-cmd)
(defcustom eshell-named-command-hook nil
- "*A set of functions called before a named command is invoked.
+ "A set of functions called before a named command is invoked.
Each function will be passed the command name and arguments that were
passed to `eshell-named-command'.
@@ -180,7 +180,7 @@ call to `cd' using the arguments that were passed to the function."
(defcustom eshell-pre-rewrite-command-hook
'(eshell-no-command-conversion
eshell-subcommand-arg-values)
- "*A hook run before command rewriting begins.
+ "A hook run before command rewriting begins.
The terms of the command to be rewritten is passed as arguments, and
may be modified in place. Any return value is ignored."
:type 'hook
@@ -193,7 +193,7 @@ may be modified in place. Any return value is ignored."
eshell-rewrite-sexp-command
eshell-rewrite-initial-subcommand
eshell-rewrite-named-command)
- "*A set of functions used to rewrite the command argument.
+ "A set of functions used to rewrite the command argument.
Once parsing of a command line is completed, the next step is to
rewrite the initial argument into something runnable.
@@ -207,14 +207,14 @@ forms or strings)."
:group 'eshell-cmd)
(defcustom eshell-post-rewrite-command-hook nil
- "*A hook run after command rewriting is finished.
+ "A hook run after command rewriting is finished.
Each function is passed the symbol containing the rewritten command,
which may be modified directly. Any return value is ignored."
:type 'hook
:group 'eshell-cmd)
(defcustom eshell-complex-commands '("ls")
- "*A list of commands names or functions, that determine complexity.
+ "A list of commands names or functions, that determine complexity.
That is, if a command is defined by a function named eshell/NAME,
and NAME is part of this list, it is invoked as a complex command.
Complex commands are always correct, but run much slower. If a
@@ -231,12 +231,12 @@ return non-nil if the command is complex."
;;; User Variables:
(defcustom eshell-cmd-load-hook '(eshell-cmd-initialize)
- "*A hook that gets run when `eshell-cmd' is loaded."
+ "A hook that gets run when `eshell-cmd' is loaded."
:type 'hook
:group 'eshell-cmd)
(defcustom eshell-debug-command nil
- "*If non-nil, enable debugging code. SSLLOOWW.
+ "If non-nil, enable debugging code. SSLLOOWW.
This option is only useful for reporting bugs. If you enable it, you
will have to visit the file 'eshell-cmd.el' and run the command
\\[eval-buffer]."
@@ -247,7 +247,7 @@ will have to visit the file 'eshell-cmd.el' and run the command
'(eshell-named-command
eshell-lisp-command
eshell-process-identity)
- "*A list of functions which might return an ansychronous process.
+ "A list of functions which might return an ansychronous process.
If they return a process object, execution of the calling Eshell
command will wait for completion (in the background) before finishing
the command."
@@ -258,7 +258,7 @@ the command."
'((eshell-in-subcommand-p t)
(default-directory default-directory)
(process-environment (eshell-copy-environment)))
- "*A list of `let' bindings for subcommand environments."
+ "A list of `let' bindings for subcommand environments."
:type 'sexp
:group 'eshell-cmd)
@@ -355,12 +355,14 @@ hooks should be run before and after the command."
(if (consp command)
(eshell-parse-arguments (car command) (cdr command))
(let ((here (point))
- (inhibit-point-motion-hooks t)
- after-change-functions)
- (insert command)
- (prog1
- (eshell-parse-arguments here (point))
- (delete-region here (point)))))
+ (inhibit-point-motion-hooks t))
+ (with-silent-modifications
+ ;; FIXME: Why not use a temporary buffer and avoid this
+ ;; "insert&delete" business? --Stef
+ (insert command)
+ (prog1
+ (eshell-parse-arguments here (point))
+ (delete-region here (point))))))
args))
(commands
(mapcar
diff --git a/lisp/eshell/esh-ext.el b/lisp/eshell/esh-ext.el
index dba8665d9ae..8a3f86a3997 100644
--- a/lisp/eshell/esh-ext.el
+++ b/lisp/eshell/esh-ext.el
@@ -1,7 +1,7 @@
;;; esh-ext.el --- commands external to Eshell
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -48,17 +48,17 @@ loaded into memory, thus beginning a new process."
;;; User Variables:
(defcustom eshell-ext-load-hook '(eshell-ext-initialize)
- "*A hook that gets run when `eshell-ext' is loaded."
+ "A hook that gets run when `eshell-ext' is loaded."
:type 'hook
:group 'eshell-ext)
(defcustom eshell-binary-suffixes exec-suffixes
- "*A list of suffixes used when searching for executable files."
+ "A list of suffixes used when searching for executable files."
:type '(repeat string)
:group 'eshell-ext)
(defcustom eshell-force-execution nil
- "*If non-nil, try to execute binary files regardless of permissions.
+ "If non-nil, try to execute binary files regardless of permissions.
This can be useful on systems like Windows, where the operating system
doesn't happen to honor the permission bits in certain cases; or in
cases where you want to associate an interpreter with a particular
@@ -96,7 +96,7 @@ since nothing else but Eshell will be able to understand
(or (eshell-search-path "cmd.exe")
(eshell-search-path "command.com"))
shell-file-name))
- "*The name of the shell command to use for DOS/Windows batch files.
+ "The name of the shell command to use for DOS/Windows batch files.
This defaults to nil on non-Windows systems, where this variable is
wholly ignored."
:type '(choice file (const nil))
@@ -113,7 +113,7 @@ wholly ignored."
(defcustom eshell-interpreter-alist
(if (eshell-under-windows-p)
'(("\\.\\(bat\\|cmd\\)\\'" . eshell-invoke-batch-file)))
- "*An alist defining interpreter substitutions.
+ "An alist defining interpreter substitutions.
Each member is a cons cell of the form:
(MATCH . INTERPRETER)
@@ -134,7 +134,7 @@ possible return values of `eshell-external-command', which see."
:group 'eshell-ext)
(defcustom eshell-alternate-command-hook nil
- "*A hook run whenever external command lookup fails.
+ "A hook run whenever external command lookup fails.
If a functions wishes to provide an alternate command, they must throw
it using the tag `eshell-replace-command'. This is done because the
substituted command need not be external at all, and therefore must be
@@ -147,12 +147,12 @@ by the user on the command line."
:group 'eshell-ext)
(defcustom eshell-command-interpreter-max-length 256
- "*The maximum length of any command interpreter string, plus args."
+ "The maximum length of any command interpreter string, plus args."
:type 'integer
:group 'eshell-ext)
(defcustom eshell-explicit-command-char ?*
- "*If this char occurs before a command name, call it externally.
+ "If this char occurs before a command name, call it externally.
That is, although `vi' may be an alias, `\vi' will always call the
external version."
:type 'character
diff --git a/lisp/eshell/esh-io.el b/lisp/eshell/esh-io.el
index 3aa785c7c1b..53b6fd2163e 100644
--- a/lisp/eshell/esh-io.el
+++ b/lisp/eshell/esh-io.el
@@ -73,12 +73,12 @@ though they were files."
;;; User Variables:
(defcustom eshell-io-load-hook '(eshell-io-initialize)
- "*A hook that gets run when `eshell-io' is loaded."
+ "A hook that gets run when `eshell-io' is loaded."
:type 'hook
:group 'eshell-io)
(defcustom eshell-number-of-handles 3
- "*The number of file handles that eshell supports.
+ "The number of file handles that eshell supports.
Currently this is standard input, output and error. But even all of
these Emacs does not currently support with asynchronous processes
\(which is what eshell uses so that you can continue doing work in
@@ -87,17 +87,17 @@ other buffers) ."
:group 'eshell-io)
(defcustom eshell-output-handle 1
- "*The index of the standard output handle."
+ "The index of the standard output handle."
:type 'integer
:group 'eshell-io)
(defcustom eshell-error-handle 2
- "*The index of the standard error handle."
+ "The index of the standard error handle."
:type 'integer
:group 'eshell-io)
(defcustom eshell-buffer-shorthand nil
- "*If non-nil, a symbol name can be used for a buffer in redirection.
+ "If non-nil, a symbol name can be used for a buffer in redirection.
If nil, redirecting to a buffer requires buffer name syntax. If this
variable is set, redirection directly to Lisp symbols will be
impossible.
@@ -110,7 +110,7 @@ Example:
:group 'eshell-io)
(defcustom eshell-print-queue-size 5
- "*The size of the print queue, for doing buffered printing.
+ "The size of the print queue, for doing buffered printing.
This is basically a speed enhancement, to avoid blocking the Lisp code
from executing while Emacs is redisplaying."
:type 'integer
@@ -127,7 +127,7 @@ from executing while Emacs is redisplaying."
(let ((x-select-enable-clipboard t))
(kill-new "")))
'eshell-clipboard-append) t))
- "*Map virtual devices name to Emacs Lisp functions.
+ "Map virtual devices name to Emacs Lisp functions.
If the user specifies any of the filenames above as a redirection
target, the function in the second element will be called.
diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el
index cc7f0df92ca..4477f138478 100644
--- a/lisp/eshell/esh-mode.el
+++ b/lisp/eshell/esh-mode.el
@@ -75,54 +75,54 @@
;;; User Variables:
(defcustom eshell-mode-unload-hook nil
- "*A hook that gets run when `eshell-mode' is unloaded."
+ "A hook that gets run when `eshell-mode' is unloaded."
:type 'hook
:group 'eshell-mode)
(defcustom eshell-mode-hook nil
- "*A hook that gets run when `eshell-mode' is entered."
+ "A hook that gets run when `eshell-mode' is entered."
:type 'hook
:group 'eshell-mode)
(defcustom eshell-first-time-mode-hook nil
- "*A hook that gets run the first time `eshell-mode' is entered.
+ "A hook that gets run the first time `eshell-mode' is entered.
That is to say, the first time during an Emacs session."
:type 'hook
:group 'eshell-mode)
(defcustom eshell-exit-hook '(eshell-query-kill-processes)
- "*A hook that is run whenever `eshell' is exited.
+ "A hook that is run whenever `eshell' is exited.
This hook is only run if exiting actually kills the buffer."
:type 'hook
:group 'eshell-mode)
(defcustom eshell-kill-on-exit t
- "*If non-nil, kill the Eshell buffer on the `exit' command.
+ "If non-nil, kill the Eshell buffer on the `exit' command.
Otherwise, the buffer will simply be buried."
:type 'boolean
:group 'eshell-mode)
(defcustom eshell-input-filter-functions nil
- "*Functions to call before input is processed.
+ "Functions to call before input is processed.
The input is contained in the region from `eshell-last-input-start' to
`eshell-last-input-end'."
:type 'hook
:group 'eshell-mode)
(defcustom eshell-send-direct-to-subprocesses nil
- "*If t, send any input immediately to a subprocess."
+ "If t, send any input immediately to a subprocess."
:type 'boolean
:group 'eshell-mode)
(defcustom eshell-expand-input-functions nil
- "*Functions to call before input is parsed.
+ "Functions to call before input is parsed.
Each function is passed two arguments, which bounds the region of the
current input text."
:type 'hook
:group 'eshell-mode)
(defcustom eshell-scroll-to-bottom-on-input nil
- "*Controls whether input to interpreter causes window to scroll.
+ "Controls whether input to interpreter causes window to scroll.
If nil, then do not scroll. If t or `all', scroll all windows showing
buffer. If `this', scroll only the selected window.
@@ -133,7 +133,7 @@ See `eshell-preinput-scroll-to-bottom'."
:group 'eshell-mode)
(defcustom eshell-scroll-to-bottom-on-output nil
- "*Controls whether interpreter output causes window to scroll.
+ "Controls whether interpreter output causes window to scroll.
If nil, then do not scroll. If t or `all', scroll all windows showing
buffer. If `this', scroll only the selected window. If `others',
scroll only those that are not the selected window.
@@ -147,7 +147,7 @@ See variable `eshell-scroll-show-maximum-output' and function
:group 'eshell-mode)
(defcustom eshell-scroll-show-maximum-output t
- "*Controls how interpreter output causes window to scroll.
+ "Controls how interpreter output causes window to scroll.
If non-nil, then show the maximum output when the window is scrolled.
See variable `eshell-scroll-to-bottom-on-output' and function
@@ -156,7 +156,7 @@ See variable `eshell-scroll-to-bottom-on-output' and function
:group 'eshell-mode)
(defcustom eshell-buffer-maximum-lines 1024
- "*The maximum size in lines for eshell buffers.
+ "The maximum size in lines for eshell buffers.
Eshell buffers are truncated from the top to be no greater than this
number, if the function `eshell-truncate-buffer' is on
`eshell-output-filter-functions'."
@@ -168,14 +168,14 @@ number, if the function `eshell-truncate-buffer' is on
eshell-handle-control-codes
eshell-handle-ansi-color
eshell-watch-for-password-prompt)
- "*Functions to call before output is displayed.
+ "Functions to call before output is displayed.
These functions are only called for output that is displayed
interactively, and not for output which is redirected."
:type 'hook
:group 'eshell-mode)
(defcustom eshell-preoutput-filter-functions nil
- "*Functions to call before output is inserted into the buffer.
+ "Functions to call before output is inserted into the buffer.
These functions get one argument, a string containing the text to be
inserted. They return the string as it should be inserted."
:type 'hook
@@ -183,18 +183,18 @@ inserted. They return the string as it should be inserted."
(defcustom eshell-password-prompt-regexp
"[Pp]ass\\(word\\|phrase\\).*:\\s *\\'"
- "*Regexp matching prompts for passwords in the inferior process.
+ "Regexp matching prompts for passwords in the inferior process.
This is used by `eshell-watch-for-password-prompt'."
:type 'regexp
:group 'eshell-mode)
(defcustom eshell-skip-prompt-function nil
- "*A function called from beginning of line to skip the prompt."
+ "A function called from beginning of line to skip the prompt."
:type '(choice (const nil) function)
:group 'eshell-mode)
(defcustom eshell-status-in-modeline t
- "*If non-nil, let the user know a command is running in the modeline."
+ "If non-nil, let the user know a command is running in the modeline."
:type 'boolean
:group 'eshell-mode)
diff --git a/lisp/eshell/esh-opt.el b/lisp/eshell/esh-opt.el
index 91ba13be896..7662217237a 100644
--- a/lisp/eshell/esh-opt.el
+++ b/lisp/eshell/esh-opt.el
@@ -64,10 +64,9 @@ interned variable `args' (created using a `let' form)."
macro-args
(list 'eshell-stringify-list
(list 'eshell-flatten-list macro-args)))))
- (let ,(append (mapcar (function
- (lambda (opt)
- (or (and (listp opt) (nth 3 opt))
- 'eshell-option-stub)))
+ (let ,(append (mapcar (lambda (opt)
+ (or (and (listp opt) (nth 3 opt))
+ 'eshell-option-stub))
(cadr options))
'(usage-msg last-value ext-command args))
(eshell-do-opt ,name ,options (quote ,body-forms)))))
@@ -78,6 +77,7 @@ interned variable `args' (created using a `let' form)."
(defvar last-value)
(defvar usage-msg)
(defvar ext-command)
+;; Documented part of the interface; see eshell-eval-using-options.
(defvar args)
(defun eshell-do-opt (name options body-forms)
@@ -224,5 +224,4 @@ This assumes that symbols have been intern'd by `eshell-with-options'."
(setq index (1+ index)))))))))
args)
-;; arch-tag: 45c6c2d0-8091-46a1-a205-2f4bafd8230c
;;; esh-opt.el ends here
diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el
index 4fef82b46d5..ccc36ed9949 100644
--- a/lisp/eshell/esh-proc.el
+++ b/lisp/eshell/esh-proc.el
@@ -1,7 +1,7 @@
;;; esh-proc.el --- process management
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -40,27 +40,27 @@ finish."
;;; User Variables:
(defcustom eshell-proc-load-hook '(eshell-proc-initialize)
- "*A hook that gets run when `eshell-proc' is loaded."
+ "A hook that gets run when `eshell-proc' is loaded."
:type 'hook
:group 'eshell-proc)
(defcustom eshell-process-wait-seconds 0
- "*The number of seconds to delay waiting for a synchronous process."
+ "The number of seconds to delay waiting for a synchronous process."
:type 'integer
:group 'eshell-proc)
(defcustom eshell-process-wait-milliseconds 50
- "*The number of milliseconds to delay waiting for a synchronous process."
+ "The number of milliseconds to delay waiting for a synchronous process."
:type 'integer
:group 'eshell-proc)
(defcustom eshell-done-messages-in-minibuffer t
- "*If non-nil, subjob \"Done\" messages will display in minibuffer."
+ "If non-nil, subjob \"Done\" messages will display in minibuffer."
:type 'boolean
:group 'eshell-proc)
(defcustom eshell-delete-exited-processes t
- "*If nil, process entries will stick around until `jobs' is run.
+ "If nil, process entries will stick around until `jobs' is run.
This variable sets the buffer-local value of `delete-exited-processes'
in Eshell buffers.
@@ -81,12 +81,12 @@ variable's value to take effect."
(defcustom eshell-reset-signals
"^\\(interrupt\\|killed\\|quit\\|stopped\\)"
- "*If a termination signal matches this regexp, the terminal will be reset."
+ "If a termination signal matches this regexp, the terminal will be reset."
:type 'regexp
:group 'eshell-proc)
(defcustom eshell-exec-hook nil
- "*Called each time a process is exec'd by `eshell-gather-process-output'.
+ "Called each time a process is exec'd by `eshell-gather-process-output'.
It is passed one argument, which is the process that was just started.
It is useful for things that must be done each time a process is
executed in a eshell mode buffer (e.g., `process-kill-without-query').
@@ -96,7 +96,7 @@ is created."
:group 'eshell-proc)
(defcustom eshell-kill-hook '(eshell-reset-after-proc)
- "*Called when a process run by `eshell-gather-process-output' has ended.
+ "Called when a process run by `eshell-gather-process-output' has ended.
It is passed two arguments: the process that was just ended, and the
termination status (as a string). Note that the first argument may be
nil, in which case the user attempted to send a signal, but there was
@@ -418,12 +418,12 @@ If QUERY is non-nil, query the user with QUERY before calling FUNC."
result))
(defcustom eshell-kill-process-wait-time 5
- "*Seconds to wait between sending termination signals to a subprocess."
+ "Seconds to wait between sending termination signals to a subprocess."
:type 'integer
:group 'eshell-proc)
(defcustom eshell-kill-process-signals '(SIGINT SIGQUIT SIGKILL)
- "*Signals used to kill processes when an Eshell buffer exits.
+ "Signals used to kill processes when an Eshell buffer exits.
Eshell calls each of these signals in order when an Eshell buffer is
killed; if the process is still alive afterwards, Eshell waits a
number of seconds defined by `eshell-kill-process-wait-time', and
@@ -432,7 +432,7 @@ tries the next signal in the list."
:group 'eshell-proc)
(defcustom eshell-kill-processes-on-exit nil
- "*If non-nil, kill active processes when exiting an Eshell buffer.
+ "If non-nil, kill active processes when exiting an Eshell buffer.
Emacs will only kill processes owned by that Eshell buffer.
If nil, ownership of background and foreground processes reverts to
diff --git a/lisp/eshell/esh-test.el b/lisp/eshell/esh-test.el
index eb448e9704f..50d0a8e861c 100644
--- a/lisp/eshell/esh-test.el
+++ b/lisp/eshell/esh-test.el
@@ -43,7 +43,7 @@
(defface eshell-test-ok
'((((class color) (background light)) (:foreground "Green" :bold t))
(((class color) (background dark)) (:foreground "Green" :bold t)))
- "*The face used to highlight OK result strings."
+ "The face used to highlight OK result strings."
:group 'eshell-test)
(define-obsolete-face-alias 'eshell-test-ok-face 'eshell-test-ok "22.1")
@@ -51,12 +51,12 @@
'((((class color) (background light)) (:foreground "OrangeRed" :bold t))
(((class color) (background dark)) (:foreground "OrangeRed" :bold t))
(t (:bold t)))
- "*The face used to highlight FAILED result strings."
+ "The face used to highlight FAILED result strings."
:group 'eshell-test)
(define-obsolete-face-alias 'eshell-test-failed-face 'eshell-test-failed "22.1")
(defcustom eshell-show-usage-metrics nil
- "*If non-nil, display different usage metrics for each Eshell command."
+ "If non-nil, display different usage metrics for each Eshell command."
:set (lambda (symbol value)
(if value
(add-hook 'eshell-mode-hook 'eshell-show-usage-metrics)
@@ -101,7 +101,7 @@
(eshell-redisplay))
(let ((truth (eval command)))
(with-current-buffer test-buffer
- (delete-backward-char 6)
+ (delete-char -6)
(insert-before-markers
"[" (let (str)
(if truth
@@ -150,7 +150,7 @@
(defun eshell-test (&optional arg)
"Test Eshell to verify that it works as expected."
(interactive "P")
- (let* ((begin (eshell-time-to-seconds (current-time)))
+ (let* ((begin (float-time))
(test-buffer (get-buffer-create "*eshell test*")))
(set-buffer (let ((inhibit-redisplay t))
(save-window-excursion (eshell t))))
@@ -176,8 +176,7 @@
(with-current-buffer test-buffer
(insert (format "\n\n--- %s --- (completed in %d seconds)\n"
(current-time-string)
- (- (eshell-time-to-seconds (current-time))
- begin)))
+ (- (float-time) begin)))
(message "Eshell test suite completed: %s failure%s"
(if (> eshell-test-failures 0)
(number-to-string eshell-test-failures)
@@ -223,14 +222,13 @@
(if (eq eshell-show-usage-metrics t)
(- eshell-metric-after-command
eshell-metric-before-command 7)
- (- (eshell-time-to-seconds
+ (- (float-time
eshell-metric-after-command)
- (eshell-time-to-seconds
+ (float-time
eshell-metric-before-command))))
"\n"))))
nil t))
(provide 'esh-test)
-;; arch-tag: 6e32275a-8285-4a4e-b7cf-819aa7c86b8e
;;; esh-test.el ends here
diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el
index 1a4c5e1021b..0a2ebba528f 100644
--- a/lisp/eshell/esh-util.el
+++ b/lisp/eshell/esh-util.el
@@ -32,7 +32,7 @@
;;; User Variables:
(defcustom eshell-stringify-t t
- "*If non-nil, the string representation of t is 't'.
+ "If non-nil, the string representation of t is 't'.
If nil, t will be represented only in the exit code of the function,
and not printed as a string. This causes Lisp functions to behave
similarly to external commands, as far as successful result output."
@@ -40,44 +40,45 @@ similarly to external commands, as far as successful result output."
:group 'eshell-util)
(defcustom eshell-group-file "/etc/group"
- "*If non-nil, the name of the group file on your system."
+ "If non-nil, the name of the group file on your system."
:type '(choice (const :tag "No group file" nil) file)
:group 'eshell-util)
(defcustom eshell-passwd-file "/etc/passwd"
- "*If non-nil, the name of the passwd file on your system."
+ "If non-nil, the name of the passwd file on your system."
:type '(choice (const :tag "No passwd file" nil) file)
:group 'eshell-util)
(defcustom eshell-hosts-file "/etc/hosts"
- "*The name of the /etc/hosts file."
+ "The name of the /etc/hosts file."
:type '(choice (const :tag "No hosts file" nil) file)
:group 'eshell-util)
(defcustom eshell-handle-errors t
- "*If non-nil, Eshell will handle errors itself.
+ "If non-nil, Eshell will handle errors itself.
Setting this to nil is offered as an aid to debugging only."
:type 'boolean
:group 'eshell-util)
(defcustom eshell-private-file-modes 384 ; umask 177
- "*The file-modes value to use for creating \"private\" files."
+ "The file-modes value to use for creating \"private\" files."
:type 'integer
:group 'eshell-util)
(defcustom eshell-private-directory-modes 448 ; umask 077
- "*The file-modes value to use for creating \"private\" directories."
+ "The file-modes value to use for creating \"private\" directories."
:type 'integer
:group 'eshell-util)
(defcustom eshell-tar-regexp
- "\\.t\\(ar\\(\\.\\(gz\\|bz2\\|Z\\)\\)?\\|gz\\|a[zZ]\\|z2\\)\\'"
- "*Regular expression used to match tar file names."
+ "\\.t\\(ar\\(\\.\\(gz\\|bz2\\|xz\\|Z\\)\\)?\\|gz\\|a[zZ]\\|z2\\)\\'"
+ "Regular expression used to match tar file names."
+ :version "24.1" ; added xz
:type 'regexp
:group 'eshell-util)
(defcustom eshell-convert-numeric-arguments t
- "*If non-nil, converting arguments of numeric form to Lisp numbers.
+ "If non-nil, converting arguments of numeric form to Lisp numbers.
Numeric form is tested using the regular expression
`eshell-number-regexp'.
@@ -95,7 +96,7 @@ argument matches `eshell-number-regexp'."
:group 'eshell-util)
(defcustom eshell-number-regexp "-?\\([0-9]*\\.\\)?[0-9]+\\(e[-0-9.]+\\)?"
- "*Regular expression used to match numeric arguments.
+ "Regular expression used to match numeric arguments.
If `eshell-convert-numeric-arguments' is non-nil, and an argument
matches this regexp, it will be converted to a Lisp number, using the
function `string-to-number'."
@@ -103,7 +104,7 @@ function `string-to-number'."
:group 'eshell-util)
(defcustom eshell-ange-ls-uids nil
- "*List of user/host/id strings, used to determine remote ownership."
+ "List of user/host/id strings, used to determine remote ownership."
:type '(repeat (cons :tag "Host for User/UID map"
(string :tag "Hostname")
(repeat (cons :tag "User/UID List"
@@ -340,20 +341,6 @@ Prepend remote identification of `default-directory', if any."
"Flatten and stringify all of the ARGS into a single string."
(mapconcat 'eshell-stringify (eshell-flatten-list args) " "))
-;; the next two are from GNUS, and really should be made part of Emacs
-;; some day
-(defsubst eshell-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)))))
-
-(defsubst eshell-time-to-seconds (time)
- "Convert TIME to a floating point number."
- (+ (* (car time) 65536.0)
- (cadr time)
- (/ (or (car (cdr (cdr time))) 0) 1000000.0)))
-
(defsubst eshell-directory-files (regexp &optional directory)
"Return a list of files in the given DIRECTORY matching REGEXP."
(directory-files (or directory default-directory)
@@ -467,7 +454,7 @@ list."
"Read the contents of /etc/passwd for user names."
(if (or (not (symbol-value result-var))
(not (symbol-value timestamp-var))
- (eshell-time-less-p
+ (time-less-p
(symbol-value timestamp-var)
(nth 5 (file-attributes file))))
(progn
@@ -521,7 +508,7 @@ list."
"Read the contents of /etc/passwd for user names."
(if (or (not (symbol-value result-var))
(not (symbol-value timestamp-var))
- (eshell-time-less-p
+ (time-less-p
(symbol-value timestamp-var)
(nth 5 (file-attributes file))))
(progn
@@ -535,25 +522,18 @@ list."
(eshell-read-hosts eshell-hosts-file 'eshell-host-names
'eshell-host-timestamp)))
-(unless (fboundp 'line-end-position)
- (defsubst line-end-position (&optional N)
- (save-excursion (end-of-line N) (point))))
-
-(unless (fboundp 'line-beginning-position)
- (defsubst line-beginning-position (&optional N)
- (save-excursion (beginning-of-line N) (point))))
-
-(unless (fboundp 'subst-char-in-string)
- (defun subst-char-in-string (fromchar tochar string &optional inplace)
- "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
+(and (featurep 'xemacs)
+ (not (fboundp 'subst-char-in-string))
+ (defun subst-char-in-string (fromchar tochar string &optional inplace)
+ "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
Unless optional argument INPLACE is non-nil, return a new string."
- (let ((i (length string))
- (newstr (if inplace string (copy-sequence string))))
- (while (> i 0)
- (setq i (1- i))
- (if (eq (aref newstr i) fromchar)
- (aset newstr i tochar)))
- newstr)))
+ (let ((i (length string))
+ (newstr (if inplace string (copy-sequence string))))
+ (while (> i 0)
+ (setq i (1- i))
+ (if (eq (aref newstr i) fromchar)
+ (aset newstr i tochar)))
+ newstr)))
(defsubst eshell-copy-environment ()
"Return an unrelated copy of `process-environment'."
@@ -593,8 +573,9 @@ Unless optional argument INPLACE is non-nil, return a new string."
(substring string 0 sublen)
string)))
-(unless (fboundp 'directory-files-and-attributes)
- (defun directory-files-and-attributes (directory &optional full match nosort id-format)
+(and (featurep 'xemacs)
+ (not (fboundp 'directory-files-and-attributes))
+ (defun directory-files-and-attributes (directory &optional full match nosort id-format)
"Return a list of names of files and their attributes in DIRECTORY.
There are three optional arguments:
If FULL is non-nil, return absolute file names. Otherwise return names
@@ -606,7 +587,7 @@ If NOSORT is non-nil, the list is not sorted--its order is unpredictable.
(mapcar
(function
(lambda (file)
- (cons file (eshell-file-attributes (expand-file-name file directory)))))
+ (cons file (eshell-file-attributes (expand-file-name file directory)))))
(directory-files directory full match nosort)))))
(defvar ange-cache)
@@ -801,5 +782,4 @@ gid format. Valid values are 'string and 'integer, defaulting to
(provide 'esh-util)
-;; arch-tag: 70159778-5c7a-480a-bae4-3ad332fca19d
;;; esh-util.el ends here
diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el
index 1610c53d428..f76d1de3c8d 100644
--- a/lisp/eshell/esh-var.el
+++ b/lisp/eshell/esh-var.el
@@ -1,7 +1,7 @@
;;; esh-var.el --- handling of variables
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
@@ -128,27 +128,27 @@ variable value, a subcommand, or even the result of a Lisp form."
;;; User Variables:
(defcustom eshell-var-load-hook '(eshell-var-initialize)
- "*A list of functions to call when loading `eshell-var'."
+ "A list of functions to call when loading `eshell-var'."
:type 'hook
:group 'eshell-var)
(defcustom eshell-prefer-lisp-variables nil
- "*If non-nil, prefer Lisp variables to environment variables."
+ "If non-nil, prefer Lisp variables to environment variables."
:type 'boolean
:group 'eshell-var)
(defcustom eshell-complete-export-definition t
- "*If non-nil, completing names for `export' shows current definition."
+ "If non-nil, completing names for `export' shows current definition."
:type 'boolean
:group 'eshell-var)
(defcustom eshell-modify-global-environment nil
- "*If non-nil, using `export' changes Emacs's global environment."
+ "If non-nil, using `export' changes Emacs's global environment."
:type 'boolean
:group 'eshell-var)
(defcustom eshell-variable-name-regexp "[A-Za-z0-9_-]+"
- "*A regexp identifying what constitutes a variable name reference.
+ "A regexp identifying what constitutes a variable name reference.
Note that this only applies for '$NAME'. If the syntax '$<NAME>' is
used, then NAME can contain any character, including angle brackets,
if they are quoted with a backslash."
@@ -183,7 +183,7 @@ if they are quoted with a backslash."
eshell-command-arguments
(eshell-apply-indices eshell-command-arguments
indices)))))
- "*This list provides aliasing for variable references.
+ "This list provides aliasing for variable references.
It is very similar in concept to what `eshell-user-aliases-list' does
for commands. Each member of this defines defines the name of a
command, and the Lisp value to return for that variable if it is
diff --git a/lisp/eshell/eshell.el b/lisp/eshell/eshell.el
index 74f65d2fe55..89ec3ab9c60 100644
--- a/lisp/eshell/eshell.el
+++ b/lisp/eshell/eshell.el
@@ -404,7 +404,7 @@ With prefix ARG, insert output into the current buffer at point."
(assert (not (eshell-interactive-process)))
(goto-char (point-max))
(while (and (bolp) (not (bobp)))
- (delete-backward-char 1)))
+ (delete-char -1)))
(assert (and buf (buffer-live-p buf)))
(unless arg
(let ((len (if (not intr) 2
diff --git a/lisp/expand.el b/lisp/expand.el
index 23fde5f21de..14bc210232c 100644
--- a/lisp/expand.el
+++ b/lisp/expand.el
@@ -368,7 +368,7 @@ See `expand-add-abbrevs'. Value is non-nil if expansion was done."
nil))
(defun expand-do-expansion ()
- (delete-backward-char (length last-abbrev-text))
+ (delete-char (- (length last-abbrev-text)))
(let* ((vect (symbol-value last-abbrev))
(text (aref vect 0))
(position (aref vect 1))
diff --git a/lisp/face-remap.el b/lisp/face-remap.el
index 4441c9557fb..f7f469b0ccc 100644
--- a/lisp/face-remap.el
+++ b/lisp/face-remap.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc.
;;
;; Author: Miles Bader <miles@gnu.org>
-;; Keywords: faces face remapping display user commands
+;; Keywords: faces, face remapping, display, user commands
;;
;; This file is part of GNU Emacs.
;;
diff --git a/lisp/facemenu.el b/lisp/facemenu.el
index 6f9e6799763..f2a7958d93b 100644
--- a/lisp/facemenu.el
+++ b/lisp/facemenu.el
@@ -5,6 +5,7 @@
;; Author: Boris Goldowsky <boris@gnu.org>
;; Keywords: faces
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -357,7 +358,7 @@ inserted. Moving point or switching buffers before
typing a character to insert cancels the specification."
(interactive (list (progn
(barf-if-buffer-read-only)
- (facemenu-read-color "Foreground color: "))
+ (read-color "Foreground color: "))
(if (and mark-active (not current-prefix-arg))
(region-beginning))
(if (and mark-active (not current-prefix-arg))
@@ -379,7 +380,7 @@ inserted. Moving point or switching buffers before
typing a character to insert cancels the specification."
(interactive (list (progn
(barf-if-buffer-read-only)
- (facemenu-read-color "Background color: "))
+ (read-color "Background color: "))
(if (and mark-active (not current-prefix-arg))
(region-beginning))
(if (and mark-active (not current-prefix-arg))
@@ -461,81 +462,197 @@ These special properties include `invisible', `intangible' and `read-only'."
(remove-text-properties
start end '(invisible nil intangible nil read-only nil))))
-(defun facemenu-read-color (&optional prompt)
- "Read a color using the minibuffer."
- (let* ((completion-ignore-case t)
- (color-list (or facemenu-color-alist (defined-colors)))
- (completer
- (lambda (string pred all-completions)
- (if all-completions
- (or (all-completions string color-list pred)
- (if (color-defined-p string)
- (list string)))
- (or (try-completion string color-list pred)
- (if (color-defined-p string)
- string)))))
- (col (completing-read (or prompt "Color: ") completer nil t)))
- (if (equal "" col)
- nil
- col)))
-
-(defun list-colors-display (&optional list buffer-name)
+(defalias 'facemenu-read-color 'read-color)
+
+(defun color-rgb-to-hsv (r g b)
+ "For R, G, B color components return a list of hue, saturation, value.
+R, G, B input values should be in [0..65535] range.
+Output values for hue are integers in [0..360] range.
+Output values for saturation and value are integers in [0..100] range."
+ (let* ((r (/ r 65535.0))
+ (g (/ g 65535.0))
+ (b (/ b 65535.0))
+ (max (max r g b))
+ (min (min r g b))
+ (h (cond ((= max min) 0)
+ ((= max r) (mod (+ (* 60 (/ (- g b) (- max min))) 360) 360))
+ ((= max g) (+ (* 60 (/ (- b r) (- max min))) 120))
+ ((= max b) (+ (* 60 (/ (- r g) (- max min))) 240))))
+ (s (cond ((= max 0) 0)
+ (t (- 1 (/ min max)))))
+ (v max))
+ (list (round h) (round s 0.01) (round v 0.01))))
+
+(defcustom list-colors-sort nil
+ "Color sort order for `list-colors-display'.
+`nil' means default implementation-dependent order (defined in `x-colors').
+`name' sorts by color name.
+`rgb' sorts by red, green, blue components.
+`(rgb-dist . COLOR)' sorts by the RGB distance to the specified color.
+`hsv' sorts by hue, saturation, value.
+`(hsv-dist . COLOR)' sorts by the HSV distance to the specified color
+and excludes grayscale colors."
+ :type '(choice (const :tag "Unsorted" nil)
+ (const :tag "Color Name" name)
+ (const :tag "Red-Green-Blue" rgb)
+ (cons :tag "Distance on RGB cube"
+ (const :tag "Distance from Color" rgb-dist)
+ (color :tag "Source Color Name"))
+ (const :tag "Hue-Saturation-Value" hsv)
+ (cons :tag "Distance on HSV cylinder"
+ (const :tag "Distance from Color" hsv-dist)
+ (color :tag "Source Color Name")))
+ :group 'facemenu
+ :version "24.1")
+
+(defun list-colors-sort-key (color)
+ "Return a list of keys for sorting colors depending on `list-colors-sort'.
+COLOR is the name of the color. When return value is nil,
+filter out the color from the output."
+ (cond
+ ((null list-colors-sort) color)
+ ((eq list-colors-sort 'name)
+ (downcase color))
+ ((eq list-colors-sort 'rgb)
+ (color-values color))
+ ((eq (car-safe list-colors-sort) 'rgb-dist)
+ (color-distance color (cdr list-colors-sort)))
+ ((eq list-colors-sort 'hsv)
+ (apply 'color-rgb-to-hsv (color-values color)))
+ ((eq (car-safe list-colors-sort) 'hsv-dist)
+ (let* ((c-rgb (color-values color))
+ (c-hsv (apply 'color-rgb-to-hsv c-rgb))
+ (o-hsv (apply 'color-rgb-to-hsv
+ (color-values (cdr list-colors-sort)))))
+ (unless (and (eq (nth 0 c-rgb) (nth 1 c-rgb)) ; exclude grayscale
+ (eq (nth 1 c-rgb) (nth 2 c-rgb)))
+ ;; 3D Euclidean distance (sqrt is not needed for sorting)
+ (+ (expt (- 180 (abs (- 180 (abs (- (nth 0 c-hsv) ; wrap hue
+ (nth 0 o-hsv)))))) 2)
+ (expt (- (nth 1 c-hsv) (nth 1 o-hsv)) 2)
+ (expt (- (nth 2 c-hsv) (nth 2 o-hsv)) 2)))))))
+
+(defun list-colors-display (&optional list buffer-name callback)
"Display names of defined colors, and show what they look like.
If the optional argument LIST is non-nil, it should be a list of
colors to display. Otherwise, this command computes a list of
-colors that the current display can handle. If the optional
-argument BUFFER-NAME is nil, it defaults to *Colors*."
+colors that the current display can handle.
+
+If the optional argument BUFFER-NAME is nil, it defaults to
+*Colors*.
+
+If the optional argument CALLBACK is non-nil, it should be a
+function to call each time the user types RET or clicks on a
+color. The function should accept a single argument, the color
+name.
+
+You can change the color sort order by customizing `list-colors-sort'."
(interactive)
(when (and (null list) (> (display-color-cells) 0))
(setq list (list-colors-duplicates (defined-colors)))
+ (when list-colors-sort
+ ;; Schwartzian transform with `(color key1 key2 key3 ...)'.
+ (setq list (mapcar
+ 'car
+ (sort (delq nil (mapcar
+ (lambda (c)
+ (let ((key (list-colors-sort-key
+ (car c))))
+ (when key
+ (cons c (if (consp key) key
+ (list key))))))
+ list))
+ (lambda (a b)
+ (let* ((a-keys (cdr a))
+ (b-keys (cdr b))
+ (a-key (car a-keys))
+ (b-key (car b-keys)))
+ ;; Skip common keys at the beginning of key lists.
+ (while (and a-key b-key (equal a-key b-key))
+ (setq a-keys (cdr a-keys) a-key (car a-keys)
+ b-keys (cdr b-keys) b-key (car b-keys)))
+ (cond
+ ((and (numberp a-key) (numberp b-key))
+ (< a-key b-key))
+ ((and (stringp a-key) (stringp b-key))
+ (string< a-key b-key)))))))))
(when (memq (display-visual-class) '(gray-scale pseudo-color direct-color))
;; Don't show more than what the display can handle.
(let ((lc (nthcdr (1- (display-color-cells)) list)))
(if lc
(setcdr lc nil)))))
- (with-help-window (or buffer-name "*Colors*")
- (with-current-buffer standard-output
+ (let ((buf (get-buffer-create "*Colors*")))
+ (with-current-buffer buf
+ (erase-buffer)
(setq truncate-lines t)
- (if temp-buffer-show-function
- (list-colors-print list)
- ;; Call list-colors-print from temp-buffer-show-hook
- ;; to get the right value of window-width in list-colors-print
- ;; after the buffer is displayed.
- (add-hook 'temp-buffer-show-hook
- (lambda ()
- (set-buffer-modified-p
- (prog1 (buffer-modified-p)
- (list-colors-print list))))
- nil t)))))
-
-(defun list-colors-print (list)
- (dolist (color list)
- (if (consp color)
- (if (cdr color)
- (setq color (sort color (lambda (a b)
- (string< (downcase a)
- (downcase b))))))
- (setq color (list color)))
- (put-text-property
- (prog1 (point)
- (insert (car color))
- (indent-to 22))
- (point)
- 'face (list ':background (car color)))
- (put-text-property
- (prog1 (point)
- (insert " " (if (cdr color)
- (mapconcat 'identity (cdr color) ", ")
- (car color))))
- (point)
- 'face (list ':foreground (car color)))
- (indent-to (max (- (window-width) 8) 44))
- (insert (apply 'format "#%02x%02x%02x"
- (mapcar (lambda (c) (lsh c -8))
- (color-values (car color)))))
-
- (insert "\n"))
- (goto-char (point-min)))
+ ;; Display buffer before generating content to allow
+ ;; `list-colors-print' to get the right window-width.
+ (pop-to-buffer buf)
+ (list-colors-print list callback)
+ (set-buffer-modified-p nil)))
+ (if callback
+ (message "Click on a color to select it.")))
+
+(defun list-colors-print (list &optional callback)
+ (let ((callback-fn
+ (if callback
+ `(lambda (button)
+ (funcall ,callback (button-get button 'color-name))))))
+ (dolist (color list)
+ (if (consp color)
+ (if (cdr color)
+ (setq color (sort color (lambda (a b)
+ (string< (downcase a)
+ (downcase b))))))
+ (setq color (list color)))
+ (let* ((opoint (point))
+ (color-values (color-values (car color)))
+ (light-p (>= (apply 'max color-values)
+ (* (car (color-values "white")) .5)))
+ (max-len (max (- (window-width) 33) 20)))
+ (insert (car color))
+ (indent-to 22)
+ (put-text-property opoint (point) 'face `(:background ,(car color)))
+ (put-text-property
+ (prog1 (point)
+ (insert " ")
+ (if (cdr color)
+ ;; Insert as many color names as possible, fitting max-len.
+ (let ((names (list (car color)))
+ (others (cdr color))
+ (len (length (car color)))
+ newlen)
+ (while (and others
+ (< (setq newlen (+ len 2 (length (car others))))
+ max-len))
+ (setq len newlen)
+ (push (pop others) names))
+ (insert (mapconcat 'identity (nreverse names) ", ")))
+ (insert (car color))))
+ (point)
+ 'face (list :foreground (car color)))
+ (indent-to (max (- (window-width) 8) 44))
+ (insert (propertize
+ (apply 'format "#%02x%02x%02x"
+ (mapcar (lambda (c) (lsh c -8))
+ color-values))
+ 'mouse-face 'highlight
+ 'help-echo
+ (let ((hsv (apply 'color-rgb-to-hsv
+ (color-values (car color)))))
+ (format "H:%d S:%d V:%d"
+ (nth 0 hsv) (nth 1 hsv) (nth 2 hsv)))))
+ (when callback
+ (make-text-button
+ opoint (point)
+ 'follow-link t
+ 'mouse-face (list :background (car color)
+ :foreground (if light-p "black" "white"))
+ 'color-name (car color)
+ 'action callback-fn)))
+ (insert "\n"))
+ (goto-char (point-min))))
+
(defun list-colors-duplicates (&optional list)
"Return a list of colors with grouped duplicate colors.
@@ -567,6 +684,22 @@ determine the correct answer."
(cond ((equal a b) t)
((equal (color-values a) (color-values b)))))
+
+(defvar facemenu-self-insert-data nil)
+
+(defun facemenu-post-self-insert-function ()
+ (when (and (car facemenu-self-insert-data)
+ (eq last-command (cdr facemenu-self-insert-data)))
+ (put-text-property (1- (point)) (point)
+ 'face (car facemenu-self-insert-data))
+ (setq facemenu-self-insert-data nil))
+ (remove-hook 'post-self-insert-hook 'facemenu-post-self-insert-function))
+
+(defun facemenu-set-self-insert-face (face)
+ "Arrange for the next self-inserted char to have face `face'."
+ (setq facemenu-self-insert-data (cons face this-command))
+ (add-hook 'post-self-insert-hook 'facemenu-post-self-insert-function))
+
(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
@@ -580,51 +713,52 @@ As a special case, if FACE is `default', then the region is left with NO face
text property. Otherwise, selecting the default face would not have any
effect. See `facemenu-remove-face-function'."
(interactive "*xFace: \nr")
- (if (and (eq face 'default)
- (not (eq facemenu-remove-face-function t)))
- (if facemenu-remove-face-function
- (funcall facemenu-remove-face-function start end)
- (if (and start (< start end))
- (remove-text-properties start end '(face default))
- (setq self-insert-face 'default
- self-insert-face-command this-command)))
- (if facemenu-add-face-function
- (save-excursion
- (if end (goto-char end))
- (save-excursion
- (if start (goto-char start))
- (insert-before-markers
- (funcall facemenu-add-face-function face end)))
- (if facemenu-end-add-face
- (insert (if (stringp facemenu-end-add-face)
- facemenu-end-add-face
- (funcall facemenu-end-add-face face)))))
+ (cond
+ ((and (eq face 'default)
+ (not (eq facemenu-remove-face-function t)))
+ (if facemenu-remove-face-function
+ (funcall facemenu-remove-face-function start end)
(if (and start (< start end))
- (let ((part-start start) part-end)
- (while (not (= part-start end))
- (setq part-end (next-single-property-change part-start 'face
- nil end))
- (let ((prev (get-text-property part-start 'face)))
- (put-text-property part-start part-end 'face
- (if (null prev)
- face
- (facemenu-active-faces
- (cons face
- (if (listp prev)
- prev
- (list prev)))
- ;; Specify the selected frame
- ;; because nil would mean to use
- ;; the new-frame default settings,
- ;; and those are usually nil.
- (selected-frame)))))
- (setq part-start part-end)))
- (setq self-insert-face (if (eq last-command self-insert-face-command)
- (cons face (if (listp self-insert-face)
- self-insert-face
- (list self-insert-face)))
- face)
- self-insert-face-command this-command))))
+ (remove-text-properties start end '(face default))
+ (facemenu-set-self-insert-face 'default))))
+ (facemenu-add-face-function
+ (save-excursion
+ (if end (goto-char end))
+ (save-excursion
+ (if start (goto-char start))
+ (insert-before-markers
+ (funcall facemenu-add-face-function face end)))
+ (if facemenu-end-add-face
+ (insert (if (stringp facemenu-end-add-face)
+ facemenu-end-add-face
+ (funcall facemenu-end-add-face face))))))
+ ((and start (< start end))
+ (let ((part-start start) part-end)
+ (while (not (= part-start end))
+ (setq part-end (next-single-property-change part-start 'face
+ nil end))
+ (let ((prev (get-text-property part-start 'face)))
+ (put-text-property part-start part-end 'face
+ (if (null prev)
+ face
+ (facemenu-active-faces
+ (cons face
+ (if (listp prev)
+ prev
+ (list prev)))
+ ;; Specify the selected frame
+ ;; because nil would mean to use
+ ;; the new-frame default settings,
+ ;; and those are usually nil.
+ (selected-frame)))))
+ (setq part-start part-end))))
+ (t
+ (facemenu-set-self-insert-face
+ (if (eq last-command (cdr facemenu-self-insert-data))
+ (cons face (if (listp (car facemenu-self-insert-data))
+ (car facemenu-self-insert-data)
+ (list (car facemenu-self-insert-data))))
+ face))))
(unless (facemenu-enable-faces-p)
(message "Font-lock mode will override any faces you set in this buffer")))
diff --git a/lisp/faces.el b/lisp/faces.el
index 900e96ed048..ba8535aac4f 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -6,6 +6,7 @@
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -29,7 +30,7 @@
(eval-when-compile
(require 'cl))
-(declare-function xw-defined-colors "term/x-win" (&optional frame))
+(declare-function xw-defined-colors "term/common-win" (&optional frame))
(defvar help-xref-stack-item)
@@ -185,33 +186,6 @@ to NEW-FACE on frame NEW-FRAME. In this case, FRAME may not be nil."
(internal-copy-lisp-face old-face new-face frame new-frame))
new-face))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Obsolete functions
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; The functions in this section are defined because Lisp packages use
-;; them, despite the prefix `internal-' suggesting that they are
-;; private to the face implementation.
-
-(defun internal-find-face (name &optional frame)
- "Retrieve the face named NAME.
-Return nil if there is no such face.
-If NAME is already a face, it is simply returned.
-The optional argument FRAME is ignored."
- (facep name))
-(make-obsolete 'internal-find-face 'facep "21.1")
-
-
-(defun internal-get-face (name &optional frame)
- "Retrieve the face named NAME; error if there is none.
-If NAME is already a face, it is simply returned.
-The optional argument FRAME is ignored."
- (or (facep name)
- (check-face name)))
-(make-obsolete 'internal-get-face "see `facep' and `check-face'." "21.1")
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Predicates, type checks.
@@ -376,7 +350,7 @@ FRAME nil or not specified means do it for all frames."
(defun face-all-attributes (face &optional frame)
"Return an alist stating the attributes of FACE.
Each element of the result has the form (ATTR-NAME . ATTR-VALUE).
-Normally the value describes the default attributes,
+If FRAME is omitted or nil the value describes the default attributes,
but if you specify FRAME, the value describes the attributes
of FACE on FRAME."
(mapcar (lambda (pair)
@@ -915,13 +889,14 @@ of the default face. Value is FACE."
;;; Interactively modifying faces.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun read-face-name (prompt &optional string-describing-default multiple)
+(defun read-face-name (prompt &optional default multiple)
"Read a face, defaulting to the face or faces on the char after point.
If it has the property `read-face-name', that overrides the `face' property.
PROMPT should be a string that describes what the caller will do with the face;
it should not end in a space.
-STRING-DESCRIBING-DEFAULT should describe what default the caller will use if
-the user just types RET; you can omit it.
+The optional argument DEFAULT provides the value to display in the
+minibuffer prompt that is returned if the user just types RET
+unless DEFAULT is a string (in which case nil is returned).
If MULTIPLE is non-nil, return a list of faces (possibly only one).
Otherwise, return a single face."
(let ((faceprop (or (get-char-property (point) 'read-face-name)
@@ -960,10 +935,10 @@ Otherwise, return a single face."
(let* ((input
;; Read the input.
(completing-read-multiple
- (if (or faces string-describing-default)
- (format "%s (default %s): " prompt
+ (if (or faces default)
+ (format "%s (default `%s'): " prompt
(if faces (mapconcat 'symbol-name faces ",")
- string-describing-default))
+ default))
(format "%s: " prompt))
(completion-table-in-turn nonaliasfaces aliasfaces)
nil t nil 'face-name-history
@@ -971,7 +946,7 @@ Otherwise, return a single face."
;; Canonicalize the output.
(output
(cond ((or (equal input "") (equal input '("")))
- faces)
+ (or faces (unless (stringp default) default)))
((stringp input)
(mapcar 'intern (split-string input ", *" t)))
((listp input)
@@ -1334,7 +1309,7 @@ and FRAME defaults to the selected frame.
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."
- (interactive (list (read-face-name "Describe face" "= `default' face" t)))
+ (interactive (list (read-face-name "Describe face" 'default t)))
(let* ((attrs '((:family . "Family")
(:foundry . "Foundry")
(:width . "Width")
@@ -1532,12 +1507,11 @@ If SPEC is nil, return nil."
(defun face-spec-reset-face (face &optional frame)
"Reset all attributes of FACE on FRAME to unspecified."
- (let ((attrs face-attribute-name-alist))
- (while attrs
- (let ((attr-and-name (car attrs)))
- (set-face-attribute face frame (car attr-and-name) 'unspecified))
- (setq attrs (cdr attrs)))))
-
+ (let (reset-args)
+ (dolist (attr-and-name face-attribute-name-alist)
+ (push 'unspecified reset-args)
+ (push (car attr-and-name) reset-args))
+ (apply 'set-face-attribute face frame reset-args)))
(defun face-spec-set (face spec &optional for-defface)
"Set FACE's face spec, which controls its appearance, to SPEC.
@@ -1603,8 +1577,8 @@ is used. If nil or omitted, use the selected frame."
(setq frame (selected-frame)))
(let ((list face-attribute-name-alist)
(match t))
- (while (and match (not (null list)))
- (let* ((attr (car (car list)))
+ (while (and match list)
+ (let* ((attr (caar list))
(specified-value
(if (plist-member attrs attr)
(plist-get attrs attr)
@@ -1614,7 +1588,7 @@ is used. If nil or omitted, use the selected frame."
(setq list (cdr list))))
match))
-(defun face-spec-match-p (face spec &optional frame)
+(defsubst face-spec-match-p (face spec &optional frame)
"Return t if FACE, on FRAME, matches what SPEC says it should look like."
(face-attr-match-p face (face-spec-choose spec frame) frame))
@@ -1702,89 +1676,76 @@ If omitted or nil, that stands for the selected frame's display."
(t
(> (tty-color-gray-shades display) 2)))))
-(defun read-color (&optional prompt convert-to-RGB-p allow-empty-name-p msg-p)
- "Read a color name or RGB hex value: #RRRRGGGGBBBB.
-Completion is available for color names, but not for RGB hex strings.
-If the user inputs an RGB hex string, it must have the form
-#XXXXXXXXXXXX or XXXXXXXXXXXX, where each X is a hex digit. The
-number of Xs must be a multiple of 3, with the same number of Xs for
-each of red, green, and blue. The order is red, green, blue.
+(defun read-color (&optional prompt convert-to-RGB allow-empty-name msg)
+ "Read a color name or RGB triplet of the form \"#RRRRGGGGBBBB\".
+Completion is available for color names, but not for RGB triplets.
-In addition to standard color names and RGB hex values, the following
-are available as color candidates. In each case, the corresponding
-color is used.
+RGB triplets have the form #XXXXXXXXXXXX, where each X is a hex
+digit. The number of Xs must be a multiple of 3, with the same
+number of Xs for each of red, green, and blue. The order is red,
+green, blue.
+
+In addition to standard color names and RGB hex values, the
+following are available as color candidates. In each case, the
+corresponding color is used.
* `foreground at point' - foreground under the cursor
* `background at point' - background under the cursor
-Checks input to be sure it represents a valid color. If not, raises
-an error (but see exception for empty input with non-nil
-ALLOW-EMPTY-NAME-P).
-
-Optional arg PROMPT is the prompt; if nil, uses a default prompt.
+Optional arg PROMPT is the prompt; if nil, use a default prompt.
-Interactively, or with optional arg CONVERT-TO-RGB-P non-nil, converts
-an input color name to an RGB hex string. Returns the RGB hex string.
+Interactively, or with optional arg CONVERT-TO-RGB-P non-nil,
+convert an input color name to an RGB hex string. Return the RGB
+hex string.
-Optional arg ALLOW-EMPTY-NAME-P controls what happens if the user
-enters an empty color name (that is, just hits `RET'). If non-nil,
-then returns an empty color name, \"\". If nil, then raises an error.
-Programs must test for \"\" if ALLOW-EMPTY-NAME-P is non-nil. They
-can then perform an appropriate action in case of empty input.
+If optional arg ALLOW-EMPTY-NAME is non-nil, the user is allowed
+to enter an empty color name (the empty string).
-Interactively, or with optional arg MSG-P non-nil, echoes the color in
-a message."
+Interactively, or with optional arg MSG non-nil, print the
+resulting color name in the echo area."
(interactive "i\np\ni\np") ; Always convert to RGB interactively.
(let* ((completion-ignore-case t)
- (colors (append '("foreground at point" "background at point")
- (defined-colors)))
- (color (completing-read (or prompt "Color (name or #R+G+B+): ")
- colors))
- hex-string)
- (cond ((string= "foreground at point" color)
- (setq color (foreground-color-at-point)))
- ((string= "background at point" color)
- (setq color (background-color-at-point))))
- (unless color
- (setq color ""))
- (setq hex-string
- (string-match "^#?\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color))
- (if (and allow-empty-name-p (string= "" color))
- ""
- (when (and hex-string (not (eq (aref color 0) ?#)))
- (setq color (concat "#" color))) ; No #; add it.
- (unless hex-string
- (when (or (string= "" color) (not (test-completion color colors)))
- (error "No such color: %S" color))
- (when convert-to-RGB-p
- (let ((components (x-color-values color)))
- (unless components (error "No such color: %S" color))
- (unless (string-match "^#\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color)
- (setq color (format "#%04X%04X%04X"
- (logand 65535 (nth 0 components))
- (logand 65535 (nth 1 components))
- (logand 65535 (nth 2 components))))))))
- (when msg-p (message "Color: `%s'" color))
- color)))
-
-;; Commented out because I decided it is better to include the
-;; duplicates in read-color's completion list.
-
-;; (defun defined-colors-without-duplicates ()
-;; "Return the list of defined colors, without the no-space versions.
-;; For each color name, we keep the variant that DOES have spaces."
-;; (let ((result (copy-sequence (defined-colors)))
-;; to-be-rejected)
-;; (save-match-data
-;; (dolist (this result)
-;; (if (string-match " " this)
-;; (push (replace-regexp-in-string " " ""
-;; this)
-;; to-be-rejected)))
-;; (dolist (elt to-be-rejected)
-;; (let ((as-found (car (member-ignore-case elt result))))
-;; (setq result (delete as-found result)))))
-;; result))
+ (colors (or facemenu-color-alist
+ (append '("foreground at point" "background at point")
+ (if allow-empty-name '(""))
+ (defined-colors))))
+ (color (completing-read
+ (or prompt "Color (name or #RGB triplet): ")
+ ;; Completing function for reading colors, accepting
+ ;; both color names and RGB triplets.
+ (lambda (string pred flag)
+ (cond
+ ((null flag) ; Try completion.
+ (or (try-completion string colors pred)
+ (if (color-defined-p string)
+ string)))
+ ((eq flag t) ; List all completions.
+ (or (all-completions string colors pred)
+ (if (color-defined-p string)
+ (list string))))
+ ((eq flag 'lambda) ; Test completion.
+ (or (memq string colors)
+ (color-defined-p string)))))
+ nil t))
+ hex-string)
+
+ ;; Process named colors.
+ (when (member color colors)
+ (cond ((string-equal color "foreground at point")
+ (setq color (foreground-color-at-point)))
+ ((string-equal color "background at point")
+ (setq color (background-color-at-point))))
+ (when (and convert-to-RGB
+ (not (string-equal color "")))
+ (let ((components (x-color-values color)))
+ (unless (string-match "^#\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color)
+ (setq color (format "#%04X%04X%04X"
+ (logand 65535 (nth 0 components))
+ (logand 65535 (nth 1 components))
+ (logand 65535 (nth 2 components))))))))
+ (when msg (message "Color: `%s'" color))
+ color))
+
(defun face-at-point ()
"Return the face of the character after point.
@@ -1862,10 +1823,13 @@ variable with `setq'; this won't have the expected effect."
(defvar inhibit-frame-set-background-mode nil)
-(defun frame-set-background-mode (frame)
+(defun frame-set-background-mode (frame &optional keep-face-specs)
"Set up display-dependent faces on FRAME.
Display-dependent faces are those which have different definitions
-according to the `background-mode' and `display-type' frame parameters."
+according to the `background-mode' and `display-type' frame parameters.
+
+If optional arg KEEP-FACE-SPECS is non-nil, don't recalculate
+face specs for the new background mode."
(unless inhibit-frame-set-background-mode
(let* ((bg-resource
(and (window-system frame)
@@ -1913,29 +1877,29 @@ according to the `background-mode' and `display-type' frame parameters."
(let ((locally-modified-faces nil)
;; Prevent face-spec-recalc from calling this function
;; again, resulting in a loop (bug#911).
- (inhibit-frame-set-background-mode t))
- ;; Before modifying the frame parameters, collect a list of
- ;; faces that don't match what their face-spec says they
- ;; should look like. We then avoid changing these faces
- ;; below. These are the faces whose attributes were
- ;; modified on FRAME. We use a negative list on the
- ;; assumption that most faces will be unmodified, so we can
- ;; avoid consing in the common case.
- (dolist (face (face-list))
- (and (not (get face 'face-override-spec))
- (not (face-spec-match-p face
- (face-user-default-spec face)
- (selected-frame)))
- (push face locally-modified-faces)))
- ;; Now change to the new frame parameters
- (modify-frame-parameters frame
- (list (cons 'background-mode bg-mode)
- (cons 'display-type display-type)))
- ;; For all named faces, choose face specs matching the new frame
- ;; parameters, unless they have been locally modified.
- (dolist (face (face-list))
- (unless (memq face locally-modified-faces)
- (face-spec-recalc face frame))))))))
+ (inhibit-frame-set-background-mode t)
+ (params (list (cons 'background-mode bg-mode)
+ (cons 'display-type display-type))))
+ (if keep-face-specs
+ (modify-frame-parameters frame params)
+ ;; If we are recomputing face specs, first collect a list
+ ;; of faces that don't match their face-specs. These are
+ ;; the faces modified on FRAME, and we avoid changing them
+ ;; below. Use a negative list to avoid consing (we assume
+ ;; most faces are unmodified).
+ (dolist (face (face-list))
+ (and (not (get face 'face-override-spec))
+ (not (face-spec-match-p face
+ (face-user-default-spec face)
+ (selected-frame)))
+ (push face locally-modified-faces)))
+ ;; Now change to the new frame parameters
+ (modify-frame-parameters frame params)
+ ;; For all unmodified named faces, choose face specs
+ ;; matching the new frame parameters.
+ (dolist (face (face-list))
+ (unless (memq face locally-modified-faces)
+ (face-spec-recalc face frame)))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -1948,8 +1912,7 @@ according to the `background-mode' and `display-type' frame parameters."
"Add geometry parameters for a named frame to parameter list PARAMETERS.
Value is the new parameter list."
;; Note that `x-resource-name' has a global meaning.
- (let ((x-resource-name (or (cdr (assq 'name parameters))
- (cdr (assq 'name default-frame-alist)))))
+ (let ((x-resource-name (cdr (assq 'name parameters))))
(when x-resource-name
;; Before checking X resources, we must have an X connection.
(or (window-system)
@@ -1960,7 +1923,7 @@ Value is the new parameter list."
(and (setq res-geometry (x-get-resource "geometry" "Geometry"))
(setq parsed (x-parse-geometry res-geometry))
(setq parameters
- (append parameters default-frame-alist parsed
+ (append parameters parsed
;; If the resource specifies a position,
;; take note of that.
(if (or (assq 'top parsed) (assq 'left parsed))
@@ -1972,7 +1935,6 @@ Value is the new parameter list."
"Handle the reverse-video frame parameter and X resource.
`x-create-frame' does not handle this one."
(when (cdr (or (assq 'reverse parameters)
- (assq 'reverse default-frame-alist)
(let ((resource (x-get-resource "reverseVideo"
"ReverseVideo")))
(if resource
@@ -1995,16 +1957,13 @@ Value is the new parameter list."
(list (cons 'cursor-color fg)))))))
(declare-function x-create-frame "xfns.c" (parms))
-(declare-function x-setup-function-keys "term/x-win" (frame))
+(declare-function x-setup-function-keys "term/common-win" (frame))
(defun x-create-frame-with-faces (&optional parameters)
- "Create a frame from optional frame parameters PARAMETERS.
-Parameters not specified by PARAMETERS are taken from
-`default-frame-alist'. If PARAMETERS specify a frame name,
-handle X geometry resources for that name. If either PARAMETERS
-or `default-frame-alist' contains a `reverse' parameter, or
-the X resource ``reverseVideo'' is present, handle that.
-Value is the new frame created."
+ "Create and return a frame with frame parameters PARAMETERS.
+If PARAMETERS specify a frame name, handle X geometry resources
+for that name. If PARAMETERS includes a `reverse' parameter, or
+the X resource ``reverseVideo'' is present, handle that."
(setq parameters (x-handle-named-frame-geometry parameters))
(let* ((params (copy-tree parameters))
(visibility-spec (assq 'visibility parameters))
@@ -2020,7 +1979,7 @@ Value is the new frame created."
(progn
(x-setup-function-keys frame)
(x-handle-reverse-video frame parameters)
- (frame-set-background-mode frame)
+ (frame-set-background-mode frame t)
(face-set-after-frame-default frame parameters)
(if (null visibility-spec)
(make-frame-visible frame)
@@ -2035,21 +1994,22 @@ Value is the new frame created."
Calculate the face definitions using the face specs, custom theme
settings, X resources, and `face-new-frame-defaults'.
Finally, apply any relevant face attributes found amongst the
-frame parameters in PARAMETERS and `default-frame-alist'."
- (dolist (face (nreverse (face-list))) ;Why reverse? --Stef
- (condition-case ()
- (progn
- ;; Initialize faces from face spec and custom theme.
- (face-spec-recalc face frame)
- ;; X resouces for the default face are applied during
- ;; x-create-frame.
- (and (not (eq face 'default))
- (memq (window-system frame) '(x w32))
- (make-face-x-resource-internal face frame))
- ;; Apply attributes specified by face-new-frame-defaults
- (internal-merge-in-global-face face frame))
- ;; Don't let invalid specs prevent frame creation.
- (error nil)))
+frame parameters in PARAMETERS."
+ (let ((window-system-p (memq (window-system frame) '(x w32))))
+ (dolist (face (nreverse (face-list))) ;Why reverse? --Stef
+ (condition-case ()
+ (progn
+ ;; Initialize faces from face spec and custom theme.
+ (face-spec-recalc face frame)
+ ;; X resouces for the default face are applied during
+ ;; `x-create-frame'.
+ (and (not (eq face 'default)) window-system-p
+ (make-face-x-resource-internal face frame))
+ ;; Apply attributes specified by face-new-frame-defaults
+ (internal-merge-in-global-face face frame))
+ ;; Don't let invalid specs prevent frame creation.
+ (error nil))))
+
;; Apply attributes specified by frame parameters.
(let ((face-params '((foreground-color default :foreground)
(background-color default :background)
@@ -2061,16 +2021,14 @@ frame parameters in PARAMETERS and `default-frame-alist'."
(mouse-color mouse :background))))
(dolist (param face-params)
(let* ((param-name (nth 0 param))
- (value (cdr (or (assq param-name parameters)
- (assq param-name default-frame-alist)))))
+ (value (cdr (assq param-name parameters))))
(if value
(set-face-attribute (nth 1 param) frame
(nth 2 param) value))))))
(defun tty-handle-reverse-video (frame parameters)
"Handle the reverse-video frame parameter for terminal frames."
- (when (cdr (or (assq 'reverse parameters)
- (assq 'reverse default-frame-alist)))
+ (when (cdr (assq 'reverse parameters))
(let* ((params (frame-parameters frame))
(bg (cdr (assq 'foreground-color params)))
(fg (cdr (assq 'background-color params))))
@@ -2086,11 +2044,8 @@ frame parameters in PARAMETERS and `default-frame-alist'."
(defun tty-create-frame-with-faces (&optional parameters)
- "Create a frame from optional frame parameters PARAMETERS.
-Parameters not specified by PARAMETERS are taken from
-`default-frame-alist'. If either PARAMETERS or `default-frame-alist'
-contains a `reverse' parameter, handle that. Value is the new frame
-created."
+ "Create and return a frame from optional frame parameters PARAMETERS.
+If PARAMETERS contains a `reverse' parameter, handle that."
(let ((frame (make-terminal-frame parameters))
success)
(unwind-protect
@@ -2101,7 +2056,7 @@ created."
(set-terminal-parameter frame 'terminal-initted t)
(set-locale-environment nil frame)
(tty-run-terminal-initialization frame))
- (frame-set-background-mode frame)
+ (frame-set-background-mode frame t)
(face-set-after-frame-default frame parameters)
(setq success t))
(unless success
@@ -2157,27 +2112,10 @@ terminal type to a different value."
(defun tty-set-up-initial-frame-faces ()
(let ((frame (selected-frame)))
- (frame-set-background-mode frame)
+ (frame-set-background-mode frame t)
(face-set-after-frame-default frame)))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Compatibility with 20.2
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; Update a frame's faces when we change its default font.
-
-(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
-;; changed.
-
-(define-obsolete-function-alias 'frame-update-face-colors
- 'frame-set-background-mode "21.1")
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Standard faces.
@@ -2290,6 +2228,9 @@ terminal type to a different value."
(defface region
'((((class color) (min-colors 88) (background dark))
:background "blue3")
+ (((class color) (min-colors 88) (background light) (type gtk))
+ :foreground "gtk_selection_fg_color"
+ :background "gtk_selection_bg_color")
(((class color) (min-colors 88) (background light) (type ns))
:background "ns_selection_color")
(((class color) (min-colors 88) (background light))
@@ -2497,7 +2438,9 @@ used to display the prompt text."
:group 'frames
:group 'basic-faces)
-(defface cursor '((t nil))
+(defface cursor
+ '((((background light)) :background "black")
+ (((background dark)) :background "white"))
"Basic face for the cursor color under X.
Note: Other faces cannot inherit from the cursor face."
:version "21.1"
@@ -2539,6 +2482,15 @@ Note: Other faces cannot inherit from the cursor face."
(defface help-argument-name '((((supports :slant italic)) :inherit italic))
"Face to highlight argument names in *Help* buffers."
:group 'help)
+
+(defface glyphless-char
+ '((((type tty)) :inherit underline)
+ (((type pc)) :inherit escape-glyph)
+ (t :height 0.6))
+ "Face for displaying non-graphic characters (e.g. U+202A (LRE)).
+It is used for characters of no fonts too."
+ :version "24.1"
+ :group 'basic-faces)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Manipulating font names.
@@ -2625,98 +2577,6 @@ also the same size as FACE on FRAME, or fail."
(car fonts))
(cdr (assq 'font (frame-parameters (selected-frame))))))
-
-(defun x-frob-font-weight (font which)
- (let ((case-fold-search t))
- (cond ((string-match x-font-regexp font)
- (concat (substring font 0
- (match-beginning x-font-regexp-weight-subnum))
- which
- (substring font (match-end x-font-regexp-weight-subnum)
- (match-beginning x-font-regexp-adstyle-subnum))
- ;; Replace the ADD_STYLE_NAME field with *
- ;; because the info in it may not be the same
- ;; for related fonts.
- "*"
- (substring font (match-end x-font-regexp-adstyle-subnum))))
- ((string-match x-font-regexp-head font)
- (concat (substring font 0 (match-beginning 1)) which
- (substring font (match-end 1))))
- ((string-match x-font-regexp-weight font)
- (concat (substring font 0 (match-beginning 1)) which
- (substring font (match-end 1)))))))
-(make-obsolete 'x-frob-font-weight 'make-face-... "21.1")
-
-(defun x-frob-font-slant (font which)
- (let ((case-fold-search t))
- (cond ((string-match x-font-regexp font)
- (concat (substring font 0
- (match-beginning x-font-regexp-slant-subnum))
- which
- (substring font (match-end x-font-regexp-slant-subnum)
- (match-beginning x-font-regexp-adstyle-subnum))
- ;; Replace the ADD_STYLE_NAME field with *
- ;; because the info in it may not be the same
- ;; for related fonts.
- "*"
- (substring font (match-end x-font-regexp-adstyle-subnum))))
- ((string-match x-font-regexp-head font)
- (concat (substring font 0 (match-beginning 2)) which
- (substring font (match-end 2))))
- ((string-match x-font-regexp-slant font)
- (concat (substring font 0 (match-beginning 1)) which
- (substring font (match-end 1)))))))
-(make-obsolete 'x-frob-font-slant 'make-face-... "21.1")
-
-;; These aliases are here so that we don't get warnings about obsolete
-;; functions from the byte compiler.
-(defalias 'internal-frob-font-weight 'x-frob-font-weight)
-(defalias 'internal-frob-font-slant 'x-frob-font-slant)
-
-(defun x-make-font-bold (font)
- "Given an X font specification, make a bold version of it.
-If that can't be done, return nil."
- (internal-frob-font-weight font "bold"))
-(make-obsolete 'x-make-font-bold 'make-face-bold "21.1")
-
-(defun x-make-font-demibold (font)
- "Given an X font specification, make a demibold version of it.
-If that can't be done, return nil."
- (internal-frob-font-weight font "demibold"))
-(make-obsolete 'x-make-font-demibold 'make-face-bold "21.1")
-
-(defun x-make-font-unbold (font)
- "Given an X font specification, make a non-bold version of it.
-If that can't be done, return nil."
- (internal-frob-font-weight font "medium"))
-(make-obsolete 'x-make-font-unbold 'make-face-unbold "21.1")
-
-(defun x-make-font-italic (font)
- "Given an X font specification, make an italic version of it.
-If that can't be done, return nil."
- (internal-frob-font-slant font "i"))
-(make-obsolete 'x-make-font-italic 'make-face-italic "21.1")
-
-(defun x-make-font-oblique (font) ; you say tomayto...
- "Given an X font specification, make an oblique version of it.
-If that can't be done, return nil."
- (internal-frob-font-slant font "o"))
-(make-obsolete 'x-make-font-oblique 'make-face-italic "21.1")
-
-(defun x-make-font-unitalic (font)
- "Given an X font specification, make a non-italic version of it.
-If that can't be done, return nil."
- (internal-frob-font-slant font "r"))
-(make-obsolete 'x-make-font-unitalic 'make-face-unitalic "21.1")
-
-(defun x-make-font-bold-italic (font)
- "Given an X font specification, make a bold and italic version of it.
-If that can't be done, return nil."
- (and (setq font (internal-frob-font-weight font "bold"))
- (internal-frob-font-slant font "i")))
-(make-obsolete 'x-make-font-bold-italic 'make-face-bold-italic "21.1")
-
(provide 'faces)
-;; arch-tag: 19a4759f-2963-445f-b004-425b9aadd7d6
;;; faces.el ends here
diff --git a/lisp/filecache.el b/lisp/filecache.el
index b4b1e8bd954..51b7ce59b1e 100644
--- a/lisp/filecache.el
+++ b/lisp/filecache.el
@@ -207,7 +207,7 @@ should be t."
:group 'file-cache)
(defcustom file-cache-completion-ignore-case
- (if (memq system-type (list 'ms-dos 'windows-nt 'cygwin))
+ (if (memq system-type '(ms-dos windows-nt cygwin))
t
completion-ignore-case)
"If non-nil, file-cache completion should ignore case.
@@ -216,7 +216,7 @@ Defaults to the value of `completion-ignore-case'."
:group 'file-cache)
(defcustom file-cache-case-fold-search
- (if (memq system-type (list 'ms-dos 'windows-nt 'cygwin))
+ (if (memq system-type '(ms-dos windows-nt cygwin))
t
case-fold-search)
"If non-nil, file-cache completion should ignore case.
@@ -225,7 +225,7 @@ Defaults to the value of `case-fold-search'."
:group 'file-cache)
(defcustom file-cache-ignore-case
- (memq system-type (list 'ms-dos 'windows-nt 'cygwin))
+ (memq system-type '(ms-dos windows-nt cygwin))
"Non-nil means ignore case when checking completions in the file cache.
Defaults to nil on DOS and Windows, and t on other systems."
:type 'boolean
@@ -687,5 +687,4 @@ match REGEXP."
(provide 'filecache)
-;; arch-tag: 433d3ca4-4af2-47ce-b2cf-1f727460f538
;;; filecache.el ends here
diff --git a/lisp/files-x.el b/lisp/files-x.el
index 096f302820a..222141bd357 100644
--- a/lisp/files-x.el
+++ b/lisp/files-x.el
@@ -5,6 +5,7 @@
;; Author: Juri Linkov <juri@jurta.org>
;; Maintainer: FSF
;; Keywords: files
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/files.el b/lisp/files.el
index 4901c3872cd..2e2d4eeb1fb 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -1,10 +1,11 @@
;;; files.el --- file input and output commands for Emacs
;; Copyright (C) 1985, 1986, 1987, 1992, 1993, 1994, 1995, 1996,
-;; 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Maintainer: FSF
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -114,13 +115,14 @@ This variable is relevant only if `backup-by-copying' is nil."
:type 'boolean
:group 'backup)
-(defcustom backup-by-copying-when-mismatch nil
+(defcustom backup-by-copying-when-mismatch t
"Non-nil means create backups by copying if this preserves owner or group.
Renaming may still be used (subject to control of other variables)
when it would not result in changing the owner or group of the file;
that is, for files which are owned by you and whose group matches
the default for a new file created there by you.
This variable is relevant only if `backup-by-copying' is nil."
+ :version "24.1"
:type 'boolean
:group 'backup)
(put 'backup-by-copying-when-mismatch 'permanent-local t)
@@ -188,17 +190,6 @@ If the buffer is visiting a new file, the value is nil.")
"Non-nil if visited file was read-only when visited.")
(make-variable-buffer-local 'buffer-file-read-only)
-(defcustom temporary-file-directory
- (file-name-as-directory
- (cond ((memq system-type '(ms-dos windows-nt))
- (or (getenv "TEMP") (getenv "TMPDIR") (getenv "TMP") "c:/temp"))
- (t
- (or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP") "/tmp"))))
- "The directory for writing temporary files."
- :group 'files
- :initialize 'custom-initialize-delay
- :type 'directory)
-
(defcustom small-temporary-file-directory
(if (eq system-type 'ms-dos) (getenv "TMPDIR"))
"The directory for writing small temporary files.
@@ -575,6 +566,9 @@ Runs the usual ange-ftp hook, but only for completion operations."
(inhibit-file-name-operation op))
(apply op args))))
+(declare-function dos-convert-standard-filename "dos-fns.el" (filename))
+(declare-function w32-convert-standard-filename "w32-fns.el" (filename))
+
(defun convert-standard-filename (filename)
"Convert a standard file's name to something suitable for the OS.
This means to guarantee valid names and perhaps to canonicalize
@@ -592,15 +586,20 @@ and also turn slashes into backslashes if the shell requires it (see
`w32-shell-dos-semantics').
See Info node `(elisp)Standard File Names' for more details."
- (if (eq system-type 'cygwin)
- (let ((name (copy-sequence filename))
- (start 0))
- ;; Replace invalid filename characters with !
- (while (string-match "[?*:<>|\"\000-\037]" name start)
- (aset name (match-beginning 0) ?!)
- (setq start (match-end 0)))
- name)
- filename))
+ (cond
+ ((eq system-type 'cygwin)
+ (let ((name (copy-sequence filename))
+ (start 0))
+ ;; Replace invalid filename characters with !
+ (while (string-match "[?*:<>|\"\000-\037]" name start)
+ (aset name (match-beginning 0) ?!)
+ (setq start (match-end 0)))
+ name))
+ ((eq system-type 'windows-nt)
+ (w32-convert-standard-filename filename))
+ ((eq system-type 'ms-dos)
+ (dos-convert-standard-filename filename))
+ (t filename)))
(defun read-directory-name (prompt &optional dir default-dirname mustmatch initial)
"Read directory name, prompting with PROMPT and completing in directory DIR.
@@ -750,21 +749,45 @@ one or more of those symbols."
(let ((x (file-name-directory suffix)))
(if x (1- (length x)) (length suffix))))))
(t
- (let ((names nil)
+ (let ((names '())
+ ;; If we have files like "foo.el" and "foo.elc", we could load one of
+ ;; them with "foo.el", "foo.elc", or "foo", where just "foo" is the
+ ;; preferred way. So if we list all 3, that gives a lot of redundant
+ ;; entries for the poor soul looking just for "foo". OTOH, sometimes
+ ;; the user does want to pay attention to the extension. We try to
+ ;; diffuse this tension by stripping the suffix, except when the
+ ;; result is a single element (i.e. usually we only list "foo" unless
+ ;; it's the only remaining element in the list, in which case we do
+ ;; list "foo", "foo.elc" and "foo.el").
+ (fullnames '())
(suffix (concat (regexp-opt suffixes t) "\\'"))
(string-dir (file-name-directory string))
(string-file (file-name-nondirectory string)))
(dolist (dir dirs)
- (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
- string-file dir))
- (push file names)
- (when (string-match suffix file)
- (setq file (substring file 0 (match-beginning 0)))
- (push file names)))))
+ (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
+ string-file dir))
+ (if (not (string-match suffix file))
+ (push file names)
+ (push file fullnames)
+ (push (substring file 0 (match-beginning 0)) names)))))
+ ;; Switching from names to names+fullnames creates a non-monotonicity
+ ;; which can cause problems with things like partial-completion.
+ ;; To minimize the problem, filter out completion-regexp-list, so that
+ ;; M-x load-library RET t/x.e TAB finds some files. Also remove elements
+ ;; from `names' which only matched `string' when they still had
+ ;; their suffix.
+ (setq names (all-completions string names))
+ ;; Remove duplicates of the first element, so that we can easily check
+ ;; if `names' really only contains a single element.
+ (when (cdr names) (setcdr names (delete (car names) (cdr names))))
+ (unless (cdr names)
+ ;; There's no more than one matching non-suffixed element, so expand
+ ;; the list by adding the suffixed elements as well.
+ (setq names (nconc names fullnames)))
(completion-table-with-context
string-dir names string-file pred action)))))
@@ -903,6 +926,36 @@ to that remote system.
(funcall handler 'file-remote-p file identification connected)
nil)))
+(defcustom remote-file-name-inhibit-cache 10
+ "Whether to use the remote file-name cache for read access.
+
+When `nil', always use the cached values.
+When `t', never use them.
+A number means use them for that amount of seconds since they were
+cached.
+
+File attributes of remote files are cached for better performance.
+If they are changed out of Emacs' control, the cached values
+become invalid, and must be invalidated.
+
+In case a remote file is checked regularly, it might be
+reasonable to let-bind this variable to a value less then the
+time period between two checks.
+Example:
+
+ \(defun display-time-file-nonempty-p \(file)
+ \(let \(\(remote-file-name-inhibit-cache \(- display-time-interval 5)))
+ \(and \(file-exists-p file)
+ \(< 0 \(nth 7 \(file-attributes \(file-chase-links file)))))))"
+ :group 'files
+ :version "24.1"
+ :type `(choice
+ (const :tag "Do not inhibit file name cache" nil)
+ (const :tag "Do not use file name cache" t)
+ (integer :tag "Do not use file name cache"
+ :format "Do not use file name cache older then %v seconds"
+ :value 10)))
+
(defun file-local-copy (file)
"Copy the file FILE into a temporary file on this machine.
Returns the name of the local copy, or nil, if FILE is directly
@@ -2160,7 +2213,7 @@ in that case, this function acts as if `enable-local-variables' were t."
(if (fboundp 'ucs-set-table-for-input) ; don't lose when building
(ucs-set-table-for-input)))
-(defcustom auto-mode-case-fold nil
+(defcustom auto-mode-case-fold t
"Non-nil means to try second pass through `auto-mode-alist'.
This means that if the first case-sensitive search through the alist fails
to find a matching major mode, a second case-insensitive search is made.
@@ -2180,6 +2233,15 @@ since only a single case-insensitive search through the alist is made."
(cons (purecopy (car elt)) (cdr elt)))
`(;; do this first, so that .html.pl is Polish html, not Perl
("\\.s?html?\\(\\.[a-zA-Z_]+\\)?\\'" . html-mode)
+ ("\\.svgz?\\'" . image-mode)
+ ("\\.svgz?\\'" . xml-mode)
+ ("\\.x[bp]m\\'" . image-mode)
+ ("\\.x[bp]m\\'" . c-mode)
+ ("\\.p[bpgn]m\\'" . image-mode)
+ ("\\.tiff?\\'" . image-mode)
+ ("\\.gif\\'" . image-mode)
+ ("\\.png\\'" . image-mode)
+ ("\\.jpe?g\\'" . image-mode)
("\\.te?xt\\'" . text-mode)
("\\.[tT]e[xX]\\'" . tex-mode)
("\\.ins\\'" . tex-mode) ;Installation files for TeX packages.
@@ -2215,6 +2277,14 @@ since only a single case-insensitive search through the alist is made."
("\\.te?xi\\'" . texinfo-mode)
("\\.[sS]\\'" . asm-mode)
("\\.asm\\'" . asm-mode)
+ ("\\.css\\'" . css-mode)
+ ("\\.mixal\\'" . mixal-mode)
+ ("\\.gcov\\'" . compilation-mode)
+ ;; Besides .gdbinit, gdb documents other names to be usable for init
+ ;; files, cross-debuggers can use something like
+ ;; .PROCESSORNAME-gdbinit so that the host and target gdbinit files
+ ;; don't interfere with each other.
+ ("/\\.[a-z0-9-]*gdbinit" . gdb-script-mode)
("[cC]hange\\.?[lL]og?\\'" . change-log-mode)
("[cC]hange[lL]og[-.][0-9]+\\'" . change-log-mode)
("\\$CHANGE_LOG\\$\\.TXT" . change-log-mode)
@@ -2231,6 +2301,7 @@ since only a single case-insensitive search through the alist is made."
("\\.cl[so]\\'" . latex-mode) ;LaTeX 2e class option
("\\.bbl\\'" . latex-mode)
("\\.bib\\'" . bibtex-mode)
+ ("\\.bst\\'" . bibtex-style-mode)
("\\.sql\\'" . sql-mode)
("\\.m[4c]\\'" . m4-mode)
("\\.mf\\'" . metafont-mode)
@@ -2253,15 +2324,14 @@ since only a single case-insensitive search through the alist is made."
;; The list of archive file extensions should be in sync with
;; `auto-coding-alist' with `no-conversion' coding system.
("\\.\\(\
-arc\\|zip\\|lzh\\|lha\\|zoo\\|[jew]ar\\|xpi\\|rar\\|\
-ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|RAR\\)\\'" . archive-mode)
+arc\\|zip\\|lzh\\|lha\\|zoo\\|[jew]ar\\|xpi\\|rar\\|7z\\|\
+ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|RAR\\|7Z\\)\\'" . archive-mode)
("\\.\\(sx[dmicw]\\|od[fgpst]\\|oxt\\)\\'" . archive-mode) ;OpenOffice.org
("\\.\\(deb\\|[oi]pk\\)\\'" . archive-mode) ; Debian/Opkg packages.
;; Mailer puts message to be edited in
;; /tmp/Re.... or Message
("\\`/tmp/Re" . text-mode)
("/Message[0-9]*\\'" . text-mode)
- ("\\.zone\\'" . zone-mode)
;; some news reader is reported to use this
("\\`/tmp/fol/" . text-mode)
("\\.oak\\'" . scheme-mode)
@@ -2280,6 +2350,20 @@ ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|RAR\\)\\'" . archive-mode)
("[:/]_emacs\\'" . emacs-lisp-mode)
("/crontab\\.X*[0-9]+\\'" . shell-script-mode)
("\\.ml\\'" . lisp-mode)
+ ;; Linux-2.6.9 uses some different suffix for linker scripts:
+ ;; "ld", "lds", "lds.S", "lds.in", "ld.script", and "ld.script.balo".
+ ;; eCos uses "ld" and "ldi". Netbsd uses "ldscript.*".
+ ("\\.ld[si]?\\'" . ld-script-mode)
+ ("ld\\.?script\\'" . ld-script-mode)
+ ;; .xs is also used for ld scripts, but seems to be more commonly
+ ;; associated with Perl .xs files (C with Perl bindings). (Bug#7071)
+ ("\\.xs\\'" . c-mode)
+ ;; Explained in binutils ld/genscripts.sh. Eg:
+ ;; A .x script file is the default script.
+ ;; A .xr script is for linking without relocation (-r flag). Etc.
+ ("\\.x[abdsru]?[cnw]?\\'" . ld-script-mode)
+ ("\\.zone\\'" . dns-mode)
+ ("\\.soa\\'" . dns-mode)
;; Common Lisp ASDF package system.
("\\.asd\\'" . lisp-mode)
("\\.\\(asn\\|mib\\|smi\\)\\'" . snmp-mode)
@@ -2295,7 +2379,6 @@ ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|RAR\\)\\'" . archive-mode)
("#\\*mail\\*" . mail-mode)
("\\.g\\'" . antlr-mode)
("\\.ses\\'" . ses-mode)
- ("\\.\\(soa\\|zone\\)\\'" . dns-mode)
("\\.docbook\\'" . sgml-mode)
("\\.com\\'" . dcl-mode)
("/config\\.\\(?:bat\\|log\\)\\'" . fundamental-mode)
@@ -2405,7 +2488,8 @@ and `magic-mode-alist', which determines modes based on file contents.")
("pg" . text-mode)
("make" . makefile-gmake-mode) ; Debian uses this
("guile" . scheme-mode)
- ("clisp" . lisp-mode)))
+ ("clisp" . lisp-mode)
+ ("emacs" . emacs-lisp-mode)))
"Alist mapping interpreter names to major modes.
This is used for files whose first lines match `auto-mode-interpreter-regexp'.
Each element looks like (INTERPRETER . MODE).
@@ -2768,15 +2852,19 @@ asking you for confirmation."
(mapc (lambda (pair)
(put (car pair) 'safe-local-variable (cdr pair)))
- '((buffer-read-only . booleanp) ;; C source code
- (default-directory . stringp) ;; C source code
- (fill-column . integerp) ;; C source code
- (indent-tabs-mode . booleanp) ;; C source code
- (left-margin . integerp) ;; C source code
- (no-update-autoloads . booleanp)
- (tab-width . integerp) ;; C source code
- (truncate-lines . booleanp) ;; C source code
- (word-wrap . booleanp))) ;; C source code
+ '((buffer-read-only . booleanp) ;; C source code
+ (default-directory . stringp) ;; C source code
+ (fill-column . integerp) ;; C source code
+ (indent-tabs-mode . booleanp) ;; C source code
+ (left-margin . integerp) ;; C source code
+ (no-update-autoloads . booleanp)
+ (tab-width . integerp) ;; C source code
+ (truncate-lines . booleanp) ;; C source code
+ (word-wrap . booleanp) ;; C source code
+ (bidi-display-reordering . booleanp))) ;; C source code
+
+(put 'bidi-paragraph-direction 'safe-local-variable
+ (lambda (v) (memq v '(nil right-to-left left-to-right))))
(put 'c-set-style 'safe-local-eval-function t)
@@ -3114,14 +3202,17 @@ is specified, returning t if it is specified."
;; Otherwise, set the variables.
(enable-local-variables
(hack-local-variables-filter result nil)
- (when file-local-variables-alist
- ;; Any 'evals must run in the Right sequence.
- (setq file-local-variables-alist
- (nreverse file-local-variables-alist))
- (run-hooks 'before-hack-local-variables-hook)
- (dolist (elt file-local-variables-alist)
- (hack-one-local-variable (car elt) (cdr elt))))
- (run-hooks 'hack-local-variables-hook)))))
+ (hack-local-variables-apply)))))
+
+(defun hack-local-variables-apply ()
+ (when file-local-variables-alist
+ ;; Any 'evals must run in the Right sequence.
+ (setq file-local-variables-alist
+ (nreverse file-local-variables-alist))
+ (run-hooks 'before-hack-local-variables-hook)
+ (dolist (elt file-local-variables-alist)
+ (hack-one-local-variable (car elt) (cdr elt))))
+ (run-hooks 'hack-local-variables-hook))
(defun safe-local-variable-p (sym val)
"Non-nil if SYM is safe as a file-local variable with value VAL.
@@ -3418,15 +3509,14 @@ is found. Returns the new class name."
Store the directory-local variables in `dir-local-variables-alist'
and `file-local-variables-alist', without applying them."
(when (and enable-local-variables
- (buffer-file-name)
- (not (file-remote-p (buffer-file-name))))
+ (not (file-remote-p (or (buffer-file-name) default-directory))))
;; Find the variables file.
- (let ((variables-file (dir-locals-find-file (buffer-file-name)))
+ (let ((variables-file (dir-locals-find-file (or (buffer-file-name) default-directory)))
(class nil)
(dir-name nil))
(cond
((stringp variables-file)
- (setq dir-name (file-name-directory (buffer-file-name)))
+ (setq dir-name (if (buffer-file-name) (file-name-directory (buffer-file-name)) default-directory))
(setq class (dir-locals-read-from-file variables-file)))
((consp variables-file)
(setq dir-name (nth 0 variables-file))
@@ -3443,6 +3533,10 @@ and `file-local-variables-alist', without applying them."
(push elt dir-local-variables-alist))
(hack-local-variables-filter variables dir-name)))))))
+(defun hack-dir-local-variables-non-file-buffer ()
+ (hack-dir-local-variables)
+ (hack-local-variables-apply))
+
(defcustom change-major-mode-with-file-name t
"Non-nil means \\[write-file] should set the major mode from the file name.
@@ -3622,10 +3716,13 @@ variable `make-backup-files'. If it's done by renaming, then the file is
no longer accessible under its old name.
The value is non-nil after a backup was made by renaming.
-It has the form (MODES . BACKUPNAME).
+It has the form (MODES SELINUXCONTEXT BACKUPNAME).
MODES is the result of `file-modes' on the original
file; this means that the caller, after saving the buffer, should change
the modes of the new file to agree with the old modes.
+SELINUXCONTEXT is the result of `file-selinux-context' on the original
+file; this means that the caller, after saving the buffer, should change
+the SELinux context of the new file to agree with the old context.
BACKUPNAME is the backup file name, which is the old file renamed."
(if (and make-backup-files (not backup-inhibited)
(not buffer-backed-up)
@@ -3653,7 +3750,8 @@ BACKUPNAME is the backup file name, which is the old file renamed."
(or delete-old-versions
(y-or-n-p (format "Delete excess backup versions of %s? "
real-file-name)))))
- (modes (file-modes buffer-file-name)))
+ (modes (file-modes buffer-file-name))
+ (context (file-selinux-context buffer-file-name)))
;; Actually write the back up file.
(condition-case ()
(if (or file-precious-flag
@@ -3673,10 +3771,10 @@ BACKUPNAME is the backup file name, which is the old file renamed."
(<= (nth 2 attr) backup-by-copying-when-privileged-mismatch)))
(or (nth 9 attr)
(not (file-ownership-preserved-p real-file-name)))))))
- (backup-buffer-copy real-file-name backupname modes)
+ (backup-buffer-copy real-file-name backupname modes context)
;; rename-file should delete old backup.
(rename-file real-file-name backupname t)
- (setq setmodes (cons modes backupname)))
+ (setq setmodes (list modes context backupname)))
(file-error
;; If trouble writing the backup, write it in ~.
(setq backupname (expand-file-name
@@ -3685,7 +3783,7 @@ BACKUPNAME is the backup file name, which is the old file renamed."
(message "Cannot write backup file; backing up in %s"
backupname)
(sleep-for 1)
- (backup-buffer-copy real-file-name backupname modes)))
+ (backup-buffer-copy real-file-name backupname modes context)))
(setq buffer-backed-up t)
;; Now delete the old versions, if desired.
(if delete-old-versions
@@ -3697,7 +3795,7 @@ BACKUPNAME is the backup file name, which is the old file renamed."
setmodes)
(file-error nil))))))
-(defun backup-buffer-copy (from-name to-name modes)
+(defun backup-buffer-copy (from-name to-name modes context)
(let ((umask (default-file-modes)))
(unwind-protect
(progn
@@ -3724,7 +3822,9 @@ BACKUPNAME is the backup file name, which is the old file renamed."
;; Reset the umask.
(set-default-file-modes umask)))
(and modes
- (set-file-modes to-name (logand modes #o1777))))
+ (set-file-modes to-name (logand modes #o1777)))
+ (and context
+ (set-file-selinux-context to-name context)))
(defun file-name-sans-versions (name &optional keep-backup-version)
"Return file NAME sans backup versions or strings.
@@ -4254,7 +4354,9 @@ Before and after saving the buffer, this function runs
(nthcdr 10 (file-attributes buffer-file-name)))
(if setmodes
(condition-case ()
- (set-file-modes buffer-file-name (car setmodes))
+ (progn
+ (set-file-modes buffer-file-name (car setmodes))
+ (set-file-selinux-context buffer-file-name (nth 1 setmodes)))
(error nil))))
;; If the auto-save file was recent before this command,
;; delete it now.
@@ -4267,7 +4369,7 @@ Before and after saving the buffer, this function runs
;; This does the "real job" of writing a buffer into its visited file
;; and making a backup file. This is what is normally done
;; but inhibited if one of write-file-functions returns non-nil.
-;; It returns a value (MODES . BACKUPNAME), like backup-buffer.
+;; It returns a value (MODES SELINUXCONTEXT BACKUPNAME), like backup-buffer.
(defun basic-save-buffer-1 ()
(prog1
(if save-buffer-coding-system
@@ -4279,7 +4381,7 @@ Before and after saving the buffer, this function runs
(setq buffer-file-coding-system-explicit
(cons last-coding-system-used nil)))))
-;; This returns a value (MODES . BACKUPNAME), like backup-buffer.
+;; This returns a value (MODES SELINUXCONTEXT BACKUPNAME), like backup-buffer.
(defun basic-save-buffer-2 ()
(let (tempsetmodes setmodes)
(if (not (file-writable-p buffer-file-name))
@@ -4350,8 +4452,9 @@ Before and after saving the buffer, this function runs
;; Since we have created an entirely new file,
;; make sure it gets the right permission bits set.
(setq setmodes (or setmodes
- (cons (or (file-modes buffer-file-name)
+ (list (or (file-modes buffer-file-name)
(logand ?\666 umask))
+ (file-selinux-context buffer-file-name)
buffer-file-name)))
;; We succeeded in writing the temp file,
;; so rename it.
@@ -4362,8 +4465,11 @@ Before and after saving the buffer, this function runs
;; (setmodes is set) because that says we're superseding.
(cond ((and tempsetmodes (not setmodes))
;; Change the mode back, after writing.
- (setq setmodes (cons (file-modes buffer-file-name) buffer-file-name))
- (set-file-modes buffer-file-name (logior (car setmodes) 128))))
+ (setq setmodes (list (file-modes buffer-file-name)
+ (file-selinux-context buffer-file-name)
+ buffer-file-name))
+ (set-file-modes buffer-file-name (logior (car setmodes) 128))
+ (set-file-selinux-context buffer-file-name (nth 1 setmodes)))))
(let (success)
(unwind-protect
(progn
@@ -4377,33 +4483,10 @@ Before and after saving the buffer, this function runs
;; the backup by renaming, undo the backing-up.
(and setmodes (not success)
(progn
- (rename-file (cdr setmodes) buffer-file-name t)
- (setq buffer-backed-up nil)))))))
+ (rename-file (nth 2 setmodes) buffer-file-name t)
+ (setq buffer-backed-up nil))))))
setmodes))
-(defun diff-buffer-with-file (&optional buffer)
- "View the differences between BUFFER and its associated file.
-This requires the external program `diff' to be in your `exec-path'."
- (interactive "bBuffer: ")
- (with-current-buffer (get-buffer (or buffer (current-buffer)))
- (if (and buffer-file-name
- (file-exists-p buffer-file-name))
- (let ((tempfile (make-temp-file "buffer-content-")))
- (unwind-protect
- (progn
- (write-region nil nil tempfile nil 'nomessage)
- (diff buffer-file-name tempfile nil t)
- (sit-for 0))
- (when (file-exists-p tempfile)
- (delete-file tempfile))))
- (message "Buffer %s has no associated file on disc" (buffer-name))
- ;; Display that message for 1 second so that user can read it
- ;; in the minibuffer.
- (sit-for 1)))
- ;; return always nil, so that save-buffers-kill-emacs will not move
- ;; over to the next unsaved buffer when calling `d'.
- nil)
-
(defvar save-some-buffers-action-alist
`((?\C-r
,(lambda (buf)
@@ -4418,13 +4501,14 @@ This requires the external program `diff' to be in your `exec-path'."
(?d ,(lambda (buf)
(if (null (buffer-file-name buf))
(message "Not applicable: no file")
- (save-window-excursion (diff-buffer-with-file buf))
- (if (not enable-recursive-minibuffers)
- (progn (display-buffer (get-buffer-create "*Diff*"))
- (setq other-window-scroll-buffer "*Diff*"))
- (view-buffer (get-buffer-create "*Diff*")
- (lambda (_) (exit-recursive-edit)))
- (recursive-edit)))
+ (require 'diff) ;for diff-no-select.
+ (let ((diffbuf (diff-no-select (buffer-file-name buf) buf
+ nil 'noasync)))
+ (if (not enable-recursive-minibuffers)
+ (progn (display-buffer diffbuf)
+ (setq other-window-scroll-buffer diffbuf))
+ (view-buffer diffbuf (lambda (_) (exit-recursive-edit)))
+ (recursive-edit))))
;; Return nil to ask about BUF again.
nil)
,(purecopy "view changes in this buffer")))
@@ -4614,16 +4698,17 @@ or multiple mail buffers, etc."
(force-mode-line-update))))
(defun make-directory (dir &optional parents)
- "Create the directory DIR and any nonexistent parent dirs.
-If DIR already exists as a directory, signal an error, unless PARENTS is set.
+ "Create the directory DIR and optionally any nonexistent parent dirs.
+If DIR already exists as a directory, signal an error, unless
+PARENTS is non-nil.
-Interactively, the default choice of directory to create
-is the current default directory for file names.
-That is useful when you have visited a file in a nonexistent directory.
+Interactively, the default choice of directory to create is the
+current buffer's default directory. That is useful when you have
+visited a file in a nonexistent directory.
-Noninteractively, the second (optional) argument PARENTS says whether
-to create parent directories if they don't exist. Interactively,
-this happens by default."
+Noninteractively, the second (optional) argument PARENTS, if
+non-nil, says whether to create parent directories that don't
+exist. Interactively, this happens by default."
(interactive
(list (read-file-name "Make directory: " default-directory default-directory
nil nil)
@@ -4654,19 +4739,30 @@ this happens by default."
"^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*"
"Regexp matching any file name except \".\" and \"..\".")
-(defun delete-directory (directory &optional recursive)
+(defun delete-directory (directory &optional recursive trash)
"Delete the directory named DIRECTORY. Does not follow symlinks.
-If RECURSIVE is non-nil, all files in DIRECTORY are deleted as well."
+If RECURSIVE is non-nil, all files in DIRECTORY are deleted as well.
+TRASH non-nil means to trash the directory instead, provided
+`delete-by-moving-to-trash' is non-nil.
+
+When called interactively, TRASH is t if no prefix argument is
+given. With a prefix argument, TRASH is nil."
(interactive
- (let ((dir (expand-file-name
- (read-file-name
- "Delete directory: "
- default-directory default-directory nil nil))))
+ (let* ((trashing (and delete-by-moving-to-trash
+ (null current-prefix-arg)))
+ (dir (expand-file-name
+ (read-file-name
+ (if trashing
+ "Move directory to trash: "
+ "Delete directory: ")
+ default-directory default-directory nil nil))))
(list dir
(if (directory-files dir nil directory-files-no-dot-files-regexp)
(y-or-n-p
- (format "Directory `%s' is not empty, really delete? " dir))
- nil))))
+ (format "Directory `%s' is not empty, really %s? "
+ dir (if trashing "trash" "delete")))
+ nil)
+ (null current-prefix-arg))))
;; If default-directory is a remote directory, make sure we find its
;; delete-directory handler.
(setq directory (directory-file-name (expand-file-name directory)))
@@ -4674,7 +4770,7 @@ If RECURSIVE is non-nil, all files in DIRECTORY are deleted as well."
(cond
(handler
(funcall handler 'delete-directory directory recursive))
- (delete-by-moving-to-trash
+ ((and delete-by-moving-to-trash trash)
;; Only move non-empty dir to trash if recursive deletion was
;; requested. This mimics the non-`delete-by-moving-to-trash'
;; case, where the operation fails in delete-directory-internal.
@@ -4694,8 +4790,8 @@ If RECURSIVE is non-nil, all files in DIRECTORY are deleted as well."
;; (and (file-directory-p fn) (not (file-symlink-p fn)))
;; but more efficient
(if (eq t (car (file-attributes file)))
- (delete-directory file recursive)
- (delete-file file)))
+ (delete-directory file recursive nil)
+ (delete-file file nil)))
;; We do not want to delete "." and "..".
(directory-files
directory 'full directory-files-no-dot-files-regexp)))
@@ -5139,30 +5235,6 @@ The optional second argument indicates whether to kill internal buffers too."
(kill-buffer-ask buffer)))))
-(defun auto-save-mode (arg)
- "Toggle auto-saving of contents of current buffer.
-With prefix argument ARG, turn auto-saving on if positive, else off."
- (interactive "P")
- (setq buffer-auto-save-file-name
- (and (if (null arg)
- (or (not buffer-auto-save-file-name)
- ;; If auto-save is off because buffer has shrunk,
- ;; then toggling should turn it on.
- (< buffer-saved-size 0))
- (or (eq arg t) (listp arg) (and (integerp arg) (> arg 0))))
- (if (and buffer-file-name auto-save-visited-file-name
- (not buffer-read-only))
- buffer-file-name
- (make-auto-save-file-name))))
- ;; If -1 was stored here, to temporarily turn off saving,
- ;; turn it back on.
- (and (< buffer-saved-size 0)
- (setq buffer-saved-size 0))
- (if (called-interactively-p 'interactive)
- (message "Auto-save %s (in this buffer)"
- (if buffer-auto-save-file-name "on" "off")))
- buffer-auto-save-file-name)
-
(defun rename-auto-save-file ()
"Adjust current buffer's auto save file name for current conditions.
Also rename any existing auto save file, if it was made in this session."
@@ -5526,12 +5598,14 @@ preference to the program given by this variable."
(defun get-free-disk-space (dir)
"Return the amount of free space on directory DIR's file system.
-The result is a string that gives the number of free 1KB blocks,
-or nil if the system call or the program which retrieve the information
-fail. It returns also nil when DIR is a remote directory.
-
-This function calls `file-system-info' if it is available, or invokes the
-program specified by `directory-free-space-program' if that is non-nil."
+The return value is a string describing the amount of free
+space (normally, the number of free 1KB blocks).
+
+This function calls `file-system-info' if it is available, or
+invokes the program specified by `directory-free-space-program'
+and `directory-free-space-args'. If the system call or program
+is unsuccessful, or if DIR is a remote directory, this function
+returns nil."
(unless (file-remote-p dir)
;; Try to find the number of free blocks. Non-Posix systems don't
;; always have df, but might have an equivalent system call.
@@ -5551,19 +5625,17 @@ program specified by `directory-free-space-program' if that is non-nil."
directory-free-space-args
dir)
0)))
- ;; Usual format is a header line followed by a line of
- ;; numbers.
+ ;; Assume that the "available" column is before the
+ ;; "capacity" column. Find the "%" and scan backward.
(goto-char (point-min))
(forward-line 1)
- (if (not (eobp))
- (progn
- ;; Move to the end of the "available blocks" number.
- (skip-chars-forward "^ \t")
- (forward-word 3)
- ;; Copy it into AVAILABLE.
- (let ((end (point)))
- (forward-word -1)
- (buffer-substring (point) end))))))))))
+ (when (re-search-forward
+ "[[:space:]]+[^[:space:]]+%[^%]*$"
+ (line-end-position) t)
+ (goto-char (match-beginning 0))
+ (let ((endpt (point)))
+ (skip-chars-backward "^[:space:]")
+ (buffer-substring-no-properties (point) endpt)))))))))
;; The following expression replaces `dired-move-to-filename-regexp'.
(defvar directory-listing-before-filename-regexp
@@ -6355,5 +6427,4 @@ Otherwise, trash FILENAME using the freedesktop.org conventions,
(define-key ctl-x-5-map "r" 'find-file-read-only-other-frame)
(define-key ctl-x-5-map "\C-o" 'display-buffer-other-frame)
-;; arch-tag: bc68d3ea-19ca-468b-aac6-3a4a7766101f
;;; files.el ends here
diff --git a/lisp/filesets.el b/lisp/filesets.el
index b7e37a8ca33..d530269bae3 100644
--- a/lisp/filesets.el
+++ b/lisp/filesets.el
@@ -348,7 +348,7 @@ See `add-submenu' for documentation."
:group 'filesets)
;;(defcustom filesets-menu-cnvfp-flag nil
-;; "*Non-nil means show \"Convert :pattern to :files\" entry for :pattern menus."
+;; "Non-nil means show \"Convert :pattern to :files\" entry for :pattern menus."
;; :set (function filesets-set-default!)
;; :type 'boolean
;; :group 'filesets)
diff --git a/lisp/find-dired.el b/lisp/find-dired.el
index 9458fdfec43..0c8229c8f7a 100644
--- a/lisp/find-dired.el
+++ b/lisp/find-dired.el
@@ -99,7 +99,7 @@ The command run (after changing into DIR) is
except that the variable `find-ls-option' specifies what to use
as the final argument."
- (interactive (list (read-file-name "Run find in directory: " nil "" t)
+ (interactive (list (read-directory-name "Run find in directory: " nil "" t)
(read-string "Run find (with args): " find-args
'(find-args-history . 1))))
(let ((dired-buffers dired-buffers))
diff --git a/lisp/finder.el b/lisp/finder.el
index 682fc1d4ae2..655ad5383b0 100644
--- a/lisp/finder.el
+++ b/lisp/finder.el
@@ -27,64 +27,53 @@
;; This mode uses the Keywords library header to provide code-finding
;; services by keyword.
-;;
-;; Things to do:
-;; 1. Support multiple keywords per search. This could be extremely hairy;
-;; there doesn't seem to be any way to get completing-read to exit on
-;; an EOL with no substring pending, which is what we'd want to end the loop.
-;; 2. Search by string in synopsis line?
-;; 3. Function to check finder-package-info for unknown keywords.
;;; Code:
+(require 'package)
(require 'lisp-mnt)
-(require 'find-func) ;for find-library(-suffixes)
-;; Use `load' rather than `require' so that it doesn't get loaded
-;; during byte-compilation (at which point it might be missing).
-(load "finder-inf" t t)
+(require 'find-func) ;for find-library(-suffixes)
+(require 'finder-inf nil t)
;; These are supposed to correspond to top-level customization groups,
;; says rms.
(defvar finder-known-keywords
- '(
- (abbrev . "abbreviation handling, typing shortcuts, macros")
- ;; Too specific:
- (bib . "code related to the `bib' bibliography processor")
- (c . "support for the C language and related languages")
- (calendar . "calendar and time management support")
- (comm . "communications, networking, remote access to files")
+ '((abbrev . "abbreviation handling, typing shortcuts, and macros")
+ (bib . "bibliography processors")
+ (c . "C and related programming languages")
+ (calendar . "calendar and time management tools")
+ (comm . "communications, networking, and remote file access")
(convenience . "convenience features for faster editing")
- (data . "support for editing files of data")
- (docs . "support for Emacs documentation")
+ (data . "editing data (non-text) files")
+ (docs . "Emacs documentation facilities")
(emulations . "emulations of other editors")
(extensions . "Emacs Lisp language extensions")
- (faces . "support for multiple fonts")
- (files . "support for editing and manipulating files")
- (frames . "support for Emacs frames and window systems")
+ (faces . "fonts and colors for text")
+ (files . "file editing and manipulation")
+ (frames . "Emacs frames and window systems")
(games . "games, jokes and amusements")
- (hardware . "support for interfacing with exotic hardware")
- (help . "support for on-line help systems")
- (hypermedia . "support for links between text or other media types")
- (i18n . "internationalization and alternate character-set support")
+ (hardware . "interfacing with system hardware")
+ (help . "on-line help systems")
+ (hypermedia . "links between text or other media types")
+ (i18n . "internationalization and character-set support")
(internal . "code for Emacs internals, build process, defaults")
(languages . "specialized modes for editing programming languages")
(lisp . "Lisp support, including Emacs Lisp")
(local . "code local to your site")
- (maint . "maintenance aids for the Emacs development group")
- (mail . "modes for electronic-mail handling")
- (matching . "various sorts of searching and matching")
+ (maint . "Emacs development tools and aids")
+ (mail . "email reading and posting")
+ (matching . "searching, matching, and sorting")
(mouse . "mouse support")
- (multimedia . "images and sound support")
- (news . "support for netnews reading and posting")
- (oop . "support for object-oriented programming")
- (outlines . "support for hierarchical outlining")
- (processes . "process, subshell, compilation, and job control support")
- (terminals . "support for terminal types")
- (tex . "supporting code for the TeX formatter")
+ (multimedia . "images and sound")
+ (news . "USENET news reading and posting")
+ (outlines . "hierarchical outlining and note taking")
+ (processes . "processes, subshells, and compilation")
+ (terminals . "text terminals (ttys)")
+ (tex . "the TeX document formatter")
(tools . "programming tools")
- (unix . "front-ends/assistants for, or emulators of, UNIX-like features")
- (wp . "word processing")
- ))
+ (unix . "UNIX feature interfaces and emulators")
+ (vc . "version control")
+ (wp . "word processing")))
(defvar finder-mode-map
(let ((map (make-sparse-keymap))
@@ -131,8 +120,9 @@
;;; Code for regenerating the keyword list.
-(defvar finder-package-info nil
- "Assoc list mapping file names to description & keyword lists.")
+(defvar finder-keywords-hash nil
+ "Hash table mapping keywords to lists of package names.
+Keywords and package names both should be symbols.")
(defvar generated-finder-keywords-file "finder-inf.el"
"The function `finder-compile-keywords' writes keywords into this file.")
@@ -148,10 +138,92 @@ cus-load\\|finder-inf\\|esh-groups\\|subdirs\\)\\.el$\\)"
(autoload 'autoload-rubric "autoload")
+(defvar finder--builtins-alist
+ '(("calc" . calc)
+ ("ede" . ede)
+ ("erc" . erc)
+ ("eshell" . eshell)
+ ("gnus" . gnus)
+ ("international" . emacs)
+ ("language" . emacs)
+ ("mh-e" . mh-e)
+ ("semantic" . semantic)
+ ("analyze" . semantic)
+ ("bovine" . semantic)
+ ("decorate" . semantic)
+ ("symref" . semantic)
+ ("wisent" . semantic)
+ ("nxml" . nxml)
+ ("org" . org)
+ ("srecode" . srecode)
+ ("term" . emacs)
+ ("url" . url))
+ "Alist of built-in package directories.
+Each element should have the form (DIR . PACKAGE), where DIR is a
+directory name and PACKAGE is the name of a package (a symbol).
+When generating `package--builtins', Emacs assumes any file in
+DIR is part of the package PACKAGE.")
+
(defun finder-compile-keywords (&rest dirs)
- "Regenerate the keywords association list into `generated-finder-keywords-file'.
-Optional arguments DIRS are a list of Emacs Lisp directories to compile from;
-no arguments compiles from `load-path'."
+ "Regenerate list of built-in Emacs packages.
+This recomputes `package--builtins' and `finder-keywords-hash',
+and prints them into the file `generated-finder-keywords-file'.
+
+Optional DIRS is a list of Emacs Lisp directories to compile
+from; the default is `load-path'."
+ ;; Allow compressed files also.
+ (setq package--builtins nil)
+ (setq finder-keywords-hash (make-hash-table :test 'eq))
+ (let ((el-file-regexp "^\\([^=].*\\)\\.el\\(\\.\\(gz\\|Z\\)\\)?$")
+ package-override files base-name processed
+ summary keywords package version entry desc)
+ (dolist (d (or dirs load-path))
+ (when (file-exists-p (directory-file-name d))
+ (message "Directory %s" d)
+ (setq package-override
+ (intern-soft
+ (cdr-safe
+ (assoc (file-name-nondirectory (directory-file-name d))
+ finder--builtins-alist))))
+ (setq files (directory-files d nil el-file-regexp))
+ (dolist (f files)
+ (unless (or (string-match finder-no-scan-regexp f)
+ (null (setq base-name
+ (and (string-match el-file-regexp f)
+ (intern (match-string 1 f)))))
+ (memq base-name processed))
+ (push base-name processed)
+ (with-temp-buffer
+ (insert-file-contents (expand-file-name f d))
+ (setq summary (lm-synopsis)
+ keywords (mapcar 'intern (lm-keywords-list))
+ package (or package-override
+ (let ((str (lm-header "package")))
+ (if str (intern str)))
+ base-name)
+ version (lm-header "version")))
+ (when summary
+ (setq version (ignore-errors (version-to-list version)))
+ (setq entry (assq package package--builtins))
+ (cond ((null entry)
+ (push (cons package (vector version nil summary))
+ package--builtins))
+ ((eq base-name package)
+ (setq desc (cdr entry))
+ (aset desc 0 version)
+ (aset desc 2 summary)))
+ (dolist (kw keywords)
+ (puthash kw
+ (cons package
+ (delq package
+ (gethash kw finder-keywords-hash)))
+ finder-keywords-hash))))))))
+
+ (setq package--builtins
+ (sort package--builtins
+ (lambda (a b) (string< (symbol-name (car a))
+ (symbol-name (car b))))))
+
(save-excursion
(find-file generated-finder-keywords-file)
(setq buffer-undo-list t)
@@ -159,40 +231,16 @@ no arguments compiles from `load-path'."
(insert (autoload-rubric generated-finder-keywords-file
"keyword-to-package mapping" t))
(search-backward " ")
- (insert "(setq finder-package-info '(\n")
- (let (processed summary keywords)
- (mapc
- (lambda (d)
- (when (file-exists-p (directory-file-name d))
- (message "Directory %s" d)
- (mapc
- (lambda (f)
- ;; FIXME should this not be using (expand-file-name f d)?
- (unless (or (member f processed)
- (string-match finder-no-scan-regexp f))
- (setq processed (cons f processed))
- (with-temp-buffer
- (insert-file-contents (expand-file-name f d))
- (setq summary (lm-synopsis)
- keywords (lm-keywords-list)))
- (insert
- (format " (\"%s\"\n "
- (if (string-match "\\.\\(gz\\|Z\\)$" f)
- (file-name-sans-extension f)
- f)))
- (prin1 summary (current-buffer))
- (insert "\n ")
- (princ keywords (current-buffer))
- (insert ")\n")))
- (directory-files d nil
- ;; Allow compressed files also. FIXME:
- ;; generalize this, especially for
- ;; MS-DOG-type filenames.
- "^[^=].*\\.el\\(\\.\\(gz\\|Z\\)\\)?$"
- ))))
- (or dirs load-path)))
- (insert " ))\n")
- (eval-buffer) ; so we get the new keyword list immediately
+ (insert "(setq package--builtins '(\n")
+ (dolist (package package--builtins)
+ (insert " ")
+ (prin1 package (current-buffer))
+ (insert "\n"))
+ (insert "))\n\n")
+ ;; Insert hash table.
+ (insert "(setq finder-keywords-hash\n ")
+ (prin1 finder-keywords-hash (current-buffer))
+ (insert ")\n")
(basic-save-buffer)))
(defun finder-compile-keywords-make-dist ()
@@ -230,6 +278,17 @@ no arguments compiles from `load-path'."
'(mouse-face highlight
help-echo finder-help-echo))))
+(defun finder-unknown-keywords ()
+ "Return an alist of unknown keywords and number of their occurrences.
+Unknown keywords are those present in `finder-keywords-hash' but
+not `finder-known-keywords'."
+ (let (alist)
+ (maphash (lambda (kw packages)
+ (unless (assq kw finder-known-keywords)
+ (push (cons kw (length packages)) alist)))
+ finder-keywords-hash)
+ (sort alist (lambda (a b) (string< (car a) (car b))))))
+
;;;###autoload
(defun finder-list-keywords ()
"Display descriptions of the keywords in the Finder buffer."
@@ -238,46 +297,27 @@ no arguments compiles from `load-path'."
(pop-to-buffer "*Finder*")
(pop-to-buffer (get-buffer-create "*Finder*"))
(finder-mode)
- (setq buffer-read-only nil
- buffer-undo-list t)
- (erase-buffer)
- (mapc
- (lambda (assoc)
- (let ((keyword (car assoc)))
- (insert (symbol-name keyword))
- (finder-insert-at-column 14 (concat (cdr assoc) "\n"))
- (finder-mouse-face-on-line)))
- finder-known-keywords)
- (goto-char (point-min))
- (setq finder-headmark (point)
- buffer-read-only t)
- (set-buffer-modified-p nil)
- (balance-windows)
- (finder-summary)))
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (dolist (assoc finder-known-keywords)
+ (let ((keyword (car assoc)))
+ (insert (propertize (symbol-name keyword)
+ 'font-lock-face 'font-lock-constant-face))
+ (finder-insert-at-column 14 (concat (cdr assoc) "\n"))
+ (finder-mouse-face-on-line)))
+ (goto-char (point-min))
+ (setq finder-headmark (point)
+ buffer-read-only t)
+ (set-buffer-modified-p nil)
+ (balance-windows)
+ (finder-summary))))
(defun finder-list-matches (key)
- (pop-to-buffer (set-buffer (get-buffer-create "*Finder Category*")))
- (finder-mode)
- (setq buffer-read-only nil
- buffer-undo-list t)
- (erase-buffer)
- (let ((id (intern key)))
- (insert
- "The following packages match the keyword `" key "':\n\n")
- (setq finder-headmark (point))
- (mapc
- (lambda (x)
- (when (memq id (cadr (cdr x)))
- (insert (car x))
- (finder-insert-at-column 16 (concat (cadr x) "\n"))
- (finder-mouse-face-on-line)))
- finder-package-info)
- (goto-char (point-min))
- (forward-line)
- (setq buffer-read-only t)
- (set-buffer-modified-p nil)
- (shrink-window-if-larger-than-buffer)
- (finder-summary)))
+ (let* ((id (intern key))
+ (packages (gethash id finder-keywords-hash)))
+ (unless packages
+ (error "No packages matching key `%s'" key))
+ (package--list-packages packages)))
(define-button-type 'finder-xref 'action #'finder-goto-xref)
@@ -364,8 +404,8 @@ FILE should be in a form suitable for passing to `locate-library'."
\\[finder-select] more help for the item on the current line
\\[finder-exit] exit Finder mode and kill the Finder buffer."
:syntax-table finder-mode-syntax-table
- (setq font-lock-defaults '(finder-font-lock-keywords nil nil
- (("+-*/.<>=!?$%_&~^:@" . "w")) nil))
+ (setq buffer-read-only t
+ buffer-undo-list t)
(set (make-local-variable 'finder-headmark) nil))
(defun finder-summary ()
@@ -382,8 +422,8 @@ finder directory, \\[finder-exit] = quit, \\[finder-summary] = help")))
Delete the window and kill all Finder-related buffers."
(interactive)
(ignore-errors (delete-window))
- (dolist (buff '("*Finder*" "*Finder-package*" "*Finder Category*"))
- (and (get-buffer buff) (kill-buffer buff))))
+ (let ((buf "*Finder*"))
+ (and (get-buffer buf) (kill-buffer buf))))
(provide 'finder)
diff --git a/lisp/foldout.el b/lisp/foldout.el
index bee9227639c..4c7ef29a072 100644
--- a/lisp/foldout.el
+++ b/lisp/foldout.el
@@ -6,7 +6,7 @@
;; Author: Kevin Broadey <KevinB@bartley.demon.co.uk>
;; Maintainer: FSF
;; Created: 27 Jan 1994
-;; Version: foldout.el 1.10 dated 94/05/19 at 17:09:12
+;; Version: 1.10
;; Keywords: folding, outlines
;; This file is part of GNU Emacs.
diff --git a/lisp/font-core.el b/lisp/font-core.el
index d33295b3c34..5f8af5a5215 100644
--- a/lisp/font-core.el
+++ b/lisp/font-core.el
@@ -6,6 +6,7 @@
;; Maintainer: FSF
;; Keywords: languages, faces
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -80,17 +81,6 @@ functions, `font-lock-fontify-buffer-function',
(put 'font-lock-defaults 'risky-local-variable t)
(make-variable-buffer-local 'font-lock-defaults)
-(defvar font-lock-defaults-alist nil
- "Alist of fall-back Font Lock defaults for major modes.
-
-Each item should be a list of the form:
-
- (MAJOR-MODE . FONT-LOCK-DEFAULTS)
-
-where MAJOR-MODE is a symbol and FONT-LOCK-DEFAULTS is a list of default
-settings. See the variable `font-lock-defaults', which takes precedence.")
-(make-obsolete-variable 'font-lock-defaults-alist 'font-lock-defaults "21.1")
-
(defvar font-lock-function 'font-lock-default-function
"A function which is called when `font-lock-mode' is toggled.
It will be passed one argument, which is the current value of
@@ -143,8 +133,7 @@ To fontify a block (the function or paragraph containing point, or a number of
lines around point), perhaps because modification on the current line caused
syntactic change on other lines, you can use \\[font-lock-fontify-block].
-See the variable `font-lock-defaults-alist' for the Font Lock mode default
-settings. You can set your own default settings for some mode, by setting a
+You can set your own default settings for some mode, by setting a
buffer local value for `font-lock-defaults', via its mode hook.
The above is the default behavior of `font-lock-mode'; you may specify
@@ -206,8 +195,6 @@ this function onto `change-major-mode-hook'."
;; `font-lock-defaults'.
(when (or font-lock-defaults
(if (boundp 'font-lock-keywords) font-lock-keywords)
- (with-no-warnings
- (cdr (assq major-mode font-lock-defaults-alist)))
(and mode
(boundp 'font-lock-set-defaults)
font-lock-set-defaults
@@ -309,5 +296,4 @@ means that Font Lock mode is turned on for buffers in C and C++ modes only."
(provide 'font-core)
-;; arch-tag: f8c286e1-02f7-41d9-b89b-1b67780aed71
;;; font-core.el ends here
diff --git a/lisp/font-lock.el b/lisp/font-lock.el
index 85a7ff1b371..fe873297dc2 100644
--- a/lisp/font-lock.el
+++ b/lisp/font-lock.el
@@ -1,14 +1,15 @@
;;; font-lock.el --- Electric font lock mode
;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+;; 2010 Free Software Foundation, Inc.
;; Author: Jamie Zawinski
;; Richard Stallman
;; Stefan Monnier
;; Maintainer: FSF
;; Keywords: languages, faces
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -101,11 +102,10 @@
;; Modes that support Font Lock mode do so by defining one or more variables
;; whose values specify the fontification. Font Lock mode knows of these
-;; variable names from (a) the buffer local variable `font-lock-defaults', if
-;; non-nil, or (b) the global variable `font-lock-defaults-alist', if the major
-;; mode has an entry. (Font Lock mode is set up via (a) where a mode's
-;; patterns are distributed with the mode's package library, and (b) where a
-;; mode's patterns are distributed with font-lock.el itself. An example of (a)
+;; variable names from the buffer local variable `font-lock-defaults'.
+;; (Font Lock mode is set up via (a) where a mode's patterns are
+;; distributed with the mode's package library, and (b) where a mode's
+;; patterns are distributed with font-lock.el itself. An example of (a)
;; is Pascal mode, an example of (b) is Lisp mode. Normally, the mechanism is
;; (a); (b) is used where it is not clear which package library should contain
;; the pattern definitions.) Font Lock mode chooses which variable to use for
@@ -209,6 +209,7 @@
;;; Code:
(require 'syntax)
+(eval-when-compile (require 'cl))
;; Define core `font-lock' group.
(defgroup font-lock '((jit-lock custom-group))
@@ -542,6 +543,8 @@ and what they do:
contexts will not be affected.
This is normally set via `font-lock-defaults'.")
+(make-obsolete-variable 'font-lock-syntactic-keywords
+ 'syntax-propertize-function "24.1")
(defvar font-lock-syntax-table nil
"Non-nil means use this syntax table for fontifying.
@@ -612,24 +615,12 @@ Major/minor modes can set this variable if they know which option applies.")
;;
;; Borrowed from lazy-lock.el.
;; We use this to preserve or protect things when modifying text properties.
- (defmacro save-buffer-state (varlist &rest body)
+ (defmacro save-buffer-state (&rest body)
"Bind variables according to VARLIST and eval BODY restoring buffer state."
- (declare (indent 1) (debug let))
- (let ((modified (make-symbol "modified")))
- `(let* ,(append varlist
- `((,modified (buffer-modified-p))
- (buffer-undo-list t)
- (inhibit-read-only t)
- (inhibit-point-motion-hooks t)
- (inhibit-modification-hooks t)
- deactivate-mark
- buffer-file-name
- buffer-file-truename))
- (unwind-protect
- (progn
- ,@body)
- (unless ,modified
- (restore-buffer-modified-p nil))))))
+ (declare (indent 0) (debug t))
+ `(let ((inhibit-point-motion-hooks t))
+ (with-silent-modifications
+ ,@body)))
;;
;; Shut up the byte compiler.
(defvar font-lock-face-attributes)) ; Obsolete but respected if set.
@@ -904,26 +895,24 @@ The value of this variable is used when Font Lock mode is turned on."
(declare-function lazy-lock-mode "lazy-lock")
(defun font-lock-turn-on-thing-lock ()
- (let ((thing-mode (font-lock-value-in-major-mode font-lock-support-mode)))
- (cond ((eq thing-mode 'fast-lock-mode)
- (fast-lock-mode t))
- ((eq thing-mode 'lazy-lock-mode)
- (lazy-lock-mode t))
- ((eq thing-mode 'jit-lock-mode)
- ;; Prepare for jit-lock
- (remove-hook 'after-change-functions
- 'font-lock-after-change-function t)
- (set (make-local-variable 'font-lock-fontify-buffer-function)
- 'jit-lock-refontify)
- ;; Don't fontify eagerly (and don't abort if the buffer is large).
- (set (make-local-variable 'font-lock-fontified) t)
- ;; Use jit-lock.
- (jit-lock-register 'font-lock-fontify-region
- (not font-lock-keywords-only))
- ;; Tell jit-lock how we extend the region to refontify.
- (add-hook 'jit-lock-after-change-extend-region-functions
- 'font-lock-extend-jit-lock-region-after-change
- nil t)))))
+ (case (font-lock-value-in-major-mode font-lock-support-mode)
+ (fast-lock-mode (fast-lock-mode t))
+ (lazy-lock-mode (lazy-lock-mode t))
+ (jit-lock-mode
+ ;; Prepare for jit-lock
+ (remove-hook 'after-change-functions
+ 'font-lock-after-change-function t)
+ (set (make-local-variable 'font-lock-fontify-buffer-function)
+ 'jit-lock-refontify)
+ ;; Don't fontify eagerly (and don't abort if the buffer is large).
+ (set (make-local-variable 'font-lock-fontified) t)
+ ;; Use jit-lock.
+ (jit-lock-register 'font-lock-fontify-region
+ (not font-lock-keywords-only))
+ ;; Tell jit-lock how we extend the region to refontify.
+ (add-hook 'jit-lock-after-change-extend-region-functions
+ 'font-lock-extend-jit-lock-region-after-change
+ nil t))))
(defun font-lock-turn-off-thing-lock ()
(cond ((bound-and-true-p fast-lock-mode)
@@ -1033,7 +1022,7 @@ The region it returns may start or end in the middle of a line.")
(funcall font-lock-fontify-region-function beg end loudly))
(defun font-lock-unfontify-region (beg end)
- (save-buffer-state nil
+ (save-buffer-state
(funcall font-lock-unfontify-region-function beg end)))
(defun font-lock-default-fontify-buffer ()
@@ -1126,39 +1115,38 @@ Put first the functions more likely to cause a change and cheaper to compute.")
(defun font-lock-default-fontify-region (beg end loudly)
(save-buffer-state
- ((parse-sexp-lookup-properties
- (or parse-sexp-lookup-properties font-lock-syntactic-keywords))
- (old-syntax-table (syntax-table)))
- (unwind-protect
- (save-restriction
- (unless font-lock-dont-widen (widen))
- ;; Use the fontification syntax table, if any.
- (when font-lock-syntax-table
- (set-syntax-table font-lock-syntax-table))
- ;; Extend the region to fontify so that it starts and ends at
- ;; safe places.
- (let ((funs font-lock-extend-region-functions)
- (font-lock-beg beg)
- (font-lock-end end))
- (while funs
- (setq funs (if (or (not (funcall (car funs)))
- (eq funs font-lock-extend-region-functions))
- (cdr funs)
- ;; If there's been a change, we should go through
- ;; the list again since this new position may
- ;; warrant a different answer from one of the fun
- ;; we've already seen.
- font-lock-extend-region-functions)))
- (setq beg font-lock-beg end font-lock-end))
- ;; Now do the fontification.
- (font-lock-unfontify-region beg end)
- (when font-lock-syntactic-keywords
- (font-lock-fontify-syntactic-keywords-region beg end))
- (unless font-lock-keywords-only
- (font-lock-fontify-syntactically-region beg end loudly))
- (font-lock-fontify-keywords-region beg end loudly))
- ;; Clean up.
- (set-syntax-table old-syntax-table))))
+ ;; Use the fontification syntax table, if any.
+ (with-syntax-table (or font-lock-syntax-table (syntax-table))
+ (save-restriction
+ (unless font-lock-dont-widen (widen))
+ ;; Extend the region to fontify so that it starts and ends at
+ ;; safe places.
+ (let ((funs font-lock-extend-region-functions)
+ (font-lock-beg beg)
+ (font-lock-end end))
+ (while funs
+ (setq funs (if (or (not (funcall (car funs)))
+ (eq funs font-lock-extend-region-functions))
+ (cdr funs)
+ ;; If there's been a change, we should go through
+ ;; the list again since this new position may
+ ;; warrant a different answer from one of the fun
+ ;; we've already seen.
+ font-lock-extend-region-functions)))
+ (setq beg font-lock-beg end font-lock-end))
+ ;; Now do the fontification.
+ (font-lock-unfontify-region beg end)
+ (when (and font-lock-syntactic-keywords
+ (null syntax-propertize-function))
+ ;; Ensure the beginning of the file is properly syntactic-fontified.
+ (let ((start beg))
+ (when (< font-lock-syntactically-fontified start)
+ (setq start (max font-lock-syntactically-fontified (point-min)))
+ (setq font-lock-syntactically-fontified end))
+ (font-lock-fontify-syntactic-keywords-region start end)))
+ (unless font-lock-keywords-only
+ (font-lock-fontify-syntactically-region beg end loudly))
+ (font-lock-fontify-keywords-region beg end loudly)))))
;; The following must be rethought, since keywords can override fontification.
;; ;; Now scan for keywords, but not if we are inside a comment now.
@@ -1454,11 +1442,10 @@ LIMIT can be modified by the value of its PRE-MATCH-FORM."
(defun font-lock-fontify-syntactic-keywords-region (start end)
"Fontify according to `font-lock-syntactic-keywords' between START and END.
START should be at the beginning of a line."
- ;; Ensure the beginning of the file is properly syntactic-fontified.
- (when (and font-lock-syntactically-fontified
- (< font-lock-syntactically-fontified start))
- (setq start (max font-lock-syntactically-fontified (point-min)))
- (setq font-lock-syntactically-fontified end))
+ (unless parse-sexp-lookup-properties
+ ;; We wouldn't go through so much trouble if we didn't intend to use those
+ ;; properties, would we?
+ (set (make-local-variable 'parse-sexp-lookup-properties) t))
;; If `font-lock-syntactic-keywords' is a symbol, get the real keywords.
(when (symbolp font-lock-syntactic-keywords)
(setq font-lock-syntactic-keywords (font-lock-eval-keywords
@@ -1501,19 +1488,18 @@ START should be at the beginning of a line."
(defvar font-lock-comment-end-skip nil
"If non-nil, Font Lock mode uses this instead of `comment-end'.")
-(defun font-lock-fontify-syntactically-region (start end &optional loudly ppss)
+(defun font-lock-fontify-syntactically-region (start end &optional loudly)
"Put proper face on each string and comment between START and END.
START should be at the beginning of a line."
+ (syntax-propertize end) ; Apply any needed syntax-table properties.
(let ((comment-end-regexp
(or font-lock-comment-end-skip
(regexp-quote
(replace-regexp-in-string "^ *" "" comment-end))))
- state face beg)
+ ;; Find the `start' state.
+ (state (syntax-ppss start))
+ face beg)
(if loudly (message "Fontifying %s... (syntactically...)" (buffer-name)))
- (goto-char start)
- ;;
- ;; Find the `start' state.
- (setq state (or ppss (syntax-ppss start)))
;;
;; Find each interesting place between here and `end'.
(while
@@ -1771,8 +1757,7 @@ A LEVEL of nil is equal to a LEVEL of 0, a LEVEL of t is equal to
(defun font-lock-refresh-defaults ()
"Restart fontification in current buffer after recomputing from defaults.
-Recompute fontification variables using `font-lock-defaults' (or,
-if nil, using `font-lock-defaults-alist') and
+Recompute fontification variables using `font-lock-defaults' and
`font-lock-maximum-decoration'. Then restart fontification.
Use this function when you have changed any of the above
@@ -1792,8 +1777,8 @@ preserve `hi-lock-mode' highlighting patterns."
(defun font-lock-set-defaults ()
"Set fontification defaults appropriately for this mode.
-Sets various variables using `font-lock-defaults' (or, if nil, using
-`font-lock-defaults-alist') and `font-lock-maximum-decoration'."
+Sets various variables using `font-lock-defaults' and
+`font-lock-maximum-decoration'."
;; Set fontification defaults if not previously set for correct major mode.
(unless (and font-lock-set-defaults
(eq font-lock-major-mode major-mode))
@@ -1801,10 +1786,7 @@ Sets various variables using `font-lock-defaults' (or, if nil, using
(set (make-local-variable 'font-lock-set-defaults) t)
(make-local-variable 'font-lock-fontified)
(make-local-variable 'font-lock-multiline)
- (let* ((defaults (or font-lock-defaults
- (cdr (assq major-mode
- (with-no-warnings
- font-lock-defaults-alist)))))
+ (let* ((defaults font-lock-defaults)
(keywords
(font-lock-choose-keywords (nth 0 defaults)
(font-lock-value-in-major-mode font-lock-maximum-decoration)))
@@ -2095,8 +2077,7 @@ Sets various variables using `font-lock-defaults' (or, if nil, using
;; ;; Activate less/more fontification entries if there are multiple levels for
;; ;; the current buffer. Sets `font-lock-fontify-level' to be of the form
;; ;; (CURRENT-LEVEL IS-LOWER-LEVEL-P IS-HIGHER-LEVEL-P) for menu activation.
-;; (let ((keywords (or (nth 0 font-lock-defaults)
-;; (nth 1 (assq major-mode font-lock-defaults-alist))))
+;; (let ((keywords (nth 0 font-lock-defaults))
;; (level (font-lock-value-in-major-mode font-lock-maximum-decoration)))
;; (make-local-variable 'font-lock-fontify-level)
;; (if (or (symbolp keywords) (= (length keywords) 1))
@@ -2286,14 +2267,17 @@ in which C preprocessor directives are used. e.g. `asm-mode' and
"inline" "lambda" "save-restriction" "save-excursion"
"save-selected-window" "save-window-excursion"
"save-match-data" "save-current-buffer"
- "unwind-protect" "condition-case" "track-mouse"
- "eval-after-load" "eval-and-compile" "eval-when-compile"
- "eval-when" "eval-next-after-load"
+ "combine-after-change-calls" "unwind-protect"
+ "condition-case" "condition-case-no-debug"
+ "track-mouse" "eval-after-load" "eval-and-compile"
+ "eval-when-compile" "eval-when" "eval-next-after-load"
"with-case-table" "with-category-table"
- "with-current-buffer" "with-electric-help"
+ "with-current-buffer" "with-demoted-errors"
+ "with-electric-help"
"with-local-quit" "with-no-warnings"
"with-output-to-string" "with-output-to-temp-buffer"
- "with-selected-window" "with-selected-frame" "with-syntax-table"
+ "with-selected-window" "with-selected-frame"
+ "with-silent-modifications" "with-syntax-table"
"with-temp-buffer" "with-temp-file" "with-temp-message"
"with-timeout" "with-timeout-handler") t)
"\\>")
@@ -2363,5 +2347,4 @@ in which C preprocessor directives are used. e.g. `asm-mode' and
(provide 'font-lock)
-;; arch-tag: 682327e4-64d8-4057-b20b-1fbb9f1fc54c
;;; font-lock.el ends here
diff --git a/lisp/format-spec.el b/lisp/format-spec.el
index f5bc3e51b40..d177a43cc1f 100644
--- a/lisp/format-spec.el
+++ b/lisp/format-spec.el
@@ -76,5 +76,4 @@ starting with a character."
(provide 'format-spec)
-;; arch-tag: c22d49cf-d167-445d-b7f1-2504d4173f53
;;; format-spec.el ends here
diff --git a/lisp/format.el b/lisp/format.el
index d4262e2d0e6..0436187d984 100644
--- a/lisp/format.el
+++ b/lisp/format.el
@@ -4,6 +4,7 @@
;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Boris Goldowsky <boris@gnu.org>
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/forms.el b/lisp/forms.el
index acb86dcc194..50f7ac9f506 100644
--- a/lisp/forms.el
+++ b/lisp/forms.el
@@ -1407,7 +1407,9 @@ Commands: Equivalent keys in read-only mode:
(if forms-forms-scroll
(progn
(local-set-key [remap scroll-up] 'forms-next-record)
- (local-set-key [remap scroll-down] 'forms-prev-record)))
+ (local-set-key [remap scroll-down] 'forms-prev-record)
+ (local-set-key [remap scroll-up-command] 'forms-next-record)
+ (local-set-key [remap scroll-down-command] 'forms-prev-record)))
;;
;; beginning-of-buffer -> forms-first-record
;; end-of-buffer -> forms-end-record
diff --git a/lisp/frame.el b/lisp/frame.el
index 0628db7ee38..b133851b440 100644
--- a/lisp/frame.el
+++ b/lisp/frame.el
@@ -1,10 +1,12 @@
;;; frame.el --- multi-frame management independent of window systems
;; Copyright (C) 1993, 1994, 1996, 1997, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -24,6 +26,7 @@
;;; Commentary:
;;; Code:
+(eval-when-compile (require 'cl))
(defvar frame-creation-function-alist
(list (cons nil
@@ -38,13 +41,6 @@ as its argument.")
(defvar window-system-default-frame-alist nil
"Alist of window-system dependent default frame parameters.
-You can set this in your init file; for example,
-
- ;; Disable menubar and toolbar on the console, but enable them under X.
- (setq window-system-default-frame-alist
- '((x (menu-bar-lines . 1) (tool-bar-lines . 1))
- (nil (menu-bar-lines . 0) (tool-bar-lines . 0))))
-
Parameters specified here supersede the values given in
`default-frame-alist'.")
@@ -286,36 +282,6 @@ and (cdr ARGS) as second."
React to settings of `initial-frame-alist',
`window-system-default-frame-alist' and `default-frame-alist'
there (in decreasing order of priority)."
- ;; Make menu-bar-mode and default-frame-alist consistent.
- (when (boundp 'menu-bar-mode)
- (let ((default (assq 'menu-bar-lines default-frame-alist)))
- (if default
- (setq menu-bar-mode (not (eq (cdr default) 0)))
- (setq default-frame-alist
- (cons (cons 'menu-bar-lines (if menu-bar-mode 1 0))
- default-frame-alist)))))
-
- ;; Make tool-bar-mode and default-frame-alist consistent. Don't do
- ;; it in batch mode since that would leave a tool-bar-lines
- ;; parameter in default-frame-alist in a dumped Emacs, which is not
- ;; what we want.
- (when (and (boundp 'tool-bar-mode)
- (not noninteractive))
- (let ((default (assq 'tool-bar-lines default-frame-alist)))
- (if default
- (setq tool-bar-mode (not (eq (cdr default) 0)))
- ;; If Emacs was started on a tty, changing default-frame-alist
- ;; would disable the toolbar on X frames created later. We
- ;; want to keep the default of showing a toolbar under X even
- ;; in this case.
- ;;
- ;; If the user explicitly called `tool-bar-mode' in .emacs,
- ;; then default-frame-alist is already changed anyway.
- (when initial-window-system
- (setq default-frame-alist
- (cons (cons 'tool-bar-lines (if tool-bar-mode 1 0))
- default-frame-alist))))))
-
;; Creating and deleting frames may shift the selected frame around,
;; and thus the current buffer. Protect against that. We don't
;; want to use save-excursion here, because that may also try to set
@@ -330,22 +296,19 @@ there (in decreasing order of priority)."
(null frame-initial-frame))
;; This case happens when we don't have a window system, and
;; also for MS-DOS frames.
- (let ((parms (frame-parameters frame-initial-frame)))
+ (let ((parms (frame-parameters)))
;; Don't change the frame names.
(setq parms (delq (assq 'name parms) parms))
;; Can't modify the minibuffer parameter, so don't try.
(setq parms (delq (assq 'minibuffer parms) parms))
- (modify-frame-parameters nil
- (if (null initial-window-system)
- (append initial-frame-alist
- window-system-frame-alist
- default-frame-alist
- parms
- nil)
- ;; initial-frame-alist and
- ;; default-frame-alist were already
- ;; applied in pc-win.el.
- parms))
+ (modify-frame-parameters
+ nil
+ (if initial-window-system
+ parms
+ ;; initial-frame-alist and default-frame-alist were already
+ ;; applied in pc-win.el.
+ (append initial-frame-alist window-system-frame-alist
+ default-frame-alist parms nil)))
(if (null initial-window-system) ;; MS-DOS does this differently in pc-win.el
(let ((newparms (frame-parameters))
(frame (selected-frame)))
@@ -546,25 +509,28 @@ there (in decreasing order of priority)."
;; it is undesirable to specify the parm again
;; once the user has seen the frame and been able to alter it
;; manually.
- (while tail
- (let (newval oldval)
- (setq oldval (assq (car (car tail))
- frame-initial-frame-alist))
- (setq newval (cdr (assq (car (car tail)) allparms)))
+ (let (newval oldval)
+ (dolist (entry tail)
+ (setq oldval (assq (car entry) frame-initial-frame-alist))
+ (setq newval (cdr (assq (car entry) allparms)))
(or (and oldval (eq (cdr oldval) newval))
(setq newparms
- (cons (cons (car (car tail)) newval) newparms))))
- (setq tail (cdr tail)))
+ (cons (cons (car entry) newval) newparms)))))
(setq newparms (nreverse newparms))
- (modify-frame-parameters frame-initial-frame
- newparms)
- ;; If we changed the background color,
- ;; we need to update the background-mode parameter
- ;; and maybe some faces too.
- (when (assq 'background-color newparms)
- (unless (assq 'background-mode newparms)
- (frame-set-background-mode frame-initial-frame))
- (face-set-after-frame-default frame-initial-frame)))))
+
+ (let ((new-bg (assq 'background-color newparms)))
+ ;; If the `background-color' parameter is changed, apply
+ ;; it first, then make sure that the `background-mode'
+ ;; parameter and other faces are updated, before applying
+ ;; the other parameters.
+ (when new-bg
+ (modify-frame-parameters frame-initial-frame
+ (list new-bg))
+ (unless (assq 'background-mode newparms)
+ (frame-set-background-mode frame-initial-frame))
+ (face-set-after-frame-default frame-initial-frame)
+ (setq newparms (delq new-bg newparms)))
+ (modify-frame-parameters frame-initial-frame newparms)))))
;; Restore the original buffer.
(set-buffer old-buffer)
@@ -719,15 +685,17 @@ The functions are run with one arg, the newly created frame.")
(defun make-frame (&optional parameters)
"Return a newly created frame displaying the current buffer.
-Optional argument PARAMETERS is an alist of parameters for the new frame.
-Each element of PARAMETERS should have the form (NAME . VALUE), for example:
+Optional argument PARAMETERS is an alist of frame parameters for
+the new frame. Each element of PARAMETERS should have the
+form (NAME . VALUE), for example:
(name . STRING) The frame should be named STRING.
(width . NUMBER) The frame should be NUMBER characters in width.
(height . NUMBER) The frame should be NUMBER text lines high.
-You cannot specify either `width' or `height', you must use neither or both.
+You cannot specify either `width' or `height', you must specify
+neither or both.
(minibuffer . t) The frame should have a minibuffer.
(minibuffer . nil) The frame should have no minibuffer.
@@ -739,15 +707,17 @@ You cannot specify either `width' or `height', you must use neither or both.
(terminal . TERMINAL) The frame should use the terminal object TERMINAL.
-Before the frame is created (via `frame-creation-function-alist'), functions on the
-hook `before-make-frame-hook' are run. After the frame is created, functions
-on `after-make-frame-functions' are run with one arg, the newly created frame.
+In addition, any parameter specified in `default-frame-alist',
+but not present in PARAMETERS, is applied.
-This function itself does not make the new frame the selected frame.
-The previously selected frame remains selected. However, the
-window system may select the new frame for its own reasons, for
-instance if the frame appears under the mouse pointer and your
-setup is for focus to follow the pointer."
+Before creating the frame (via `frame-creation-function-alist'),
+this function runs the hook `before-make-frame-hook'. After
+creating the frame, it runs the hook `after-make-frame-functions'
+with one arg, the newly created frame.
+
+On graphical displays, this function does not itself make the new
+frame the selected frame. However, the window system may select
+the new frame according to its own rules."
(interactive)
(let* ((w (cond
((assq 'terminal parameters)
@@ -762,14 +732,21 @@ setup is for focus to follow the pointer."
(t window-system)))
(frame-creation-function (cdr (assq w frame-creation-function-alist)))
(oldframe (selected-frame))
+ (params parameters)
frame)
(unless frame-creation-function
(error "Don't know how to create a frame on window system %s" w))
+ ;; Add parameters from `window-system-default-frame-alist'.
+ (dolist (p (cdr (assq w window-system-default-frame-alist)))
+ (unless (assq (car p) params)
+ (push p params)))
+ ;; Add parameters from `default-frame-alist'.
+ (dolist (p default-frame-alist)
+ (unless (assq (car p) params)
+ (push p params)))
+ ;; Now make the frame.
(run-hooks 'before-make-frame-hook)
- (setq frame
- (funcall frame-creation-function
- (append parameters
- (cdr (assq w window-system-default-frame-alist)))))
+ (setq frame (funcall frame-creation-function params))
(normal-erase-is-backspace-setup-frame frame)
;; Inherit the original frame's parameters.
(dolist (param frame-inherited-parameters)
@@ -931,15 +908,16 @@ Calls `suspend-emacs' if invoked from the controlling tty device,
(t (suspend-emacs)))))
(defun make-frame-names-alist ()
+ ;; Only consider the frames on the same display.
(let* ((current-frame (selected-frame))
(falist
(cons
(cons (frame-parameter current-frame 'name) current-frame) nil))
- (frame (next-frame nil t)))
+ (frame (next-frame nil 0)))
(while (not (eq frame current-frame))
(progn
- (setq falist (cons (cons (frame-parameter frame 'name) frame) falist))
- (setq frame (next-frame frame t))))
+ (push (cons (frame-parameter frame 'name) frame) falist)
+ (setq frame (next-frame frame 0))))
falist))
(defvar frame-name-history nil)
@@ -1089,7 +1067,7 @@ See `modify-frame-parameters'."
"Set the background color of the selected frame to COLOR-NAME.
When called interactively, prompt for the name of the color to use.
To get the frame's current background color, use `frame-parameters'."
- (interactive (list (facemenu-read-color "Background color: ")))
+ (interactive (list (read-color "Background color: ")))
(modify-frame-parameters (selected-frame)
(list (cons 'background-color color-name)))
(or window-system
@@ -1099,7 +1077,7 @@ To get the frame's current background color, use `frame-parameters'."
"Set the foreground color of the selected frame to COLOR-NAME.
When called interactively, prompt for the name of the color to use.
To get the frame's current foreground color, use `frame-parameters'."
- (interactive (list (facemenu-read-color "Foreground color: ")))
+ (interactive (list (read-color "Foreground color: ")))
(modify-frame-parameters (selected-frame)
(list (cons 'foreground-color color-name)))
(or window-system
@@ -1109,7 +1087,7 @@ To get the frame's current foreground color, use `frame-parameters'."
"Set the text cursor color of the selected frame to COLOR-NAME.
When called interactively, prompt for the name of the color to use.
To get the frame's current cursor color, use `frame-parameters'."
- (interactive (list (facemenu-read-color "Cursor color: ")))
+ (interactive (list (read-color "Cursor color: ")))
(modify-frame-parameters (selected-frame)
(list (cons 'cursor-color color-name))))
@@ -1117,7 +1095,7 @@ To get the frame's current cursor color, use `frame-parameters'."
"Set the color of the mouse pointer of the selected frame to COLOR-NAME.
When called interactively, prompt for the name of the color to use.
To get the frame's current mouse color, use `frame-parameters'."
- (interactive (list (facemenu-read-color "Mouse color: ")))
+ (interactive (list (read-color "Mouse color: ")))
(modify-frame-parameters (selected-frame)
(list (cons 'mouse-color
(or color-name
@@ -1128,41 +1106,30 @@ To get the frame's current mouse color, use `frame-parameters'."
"Set the color of the border of the selected frame to COLOR-NAME.
When called interactively, prompt for the name of the color to use.
To get the frame's current border color, use `frame-parameters'."
- (interactive (list (facemenu-read-color "Border color: ")))
+ (interactive (list (read-color "Border color: ")))
(modify-frame-parameters (selected-frame)
(list (cons 'border-color color-name))))
-(defun auto-raise-mode (arg)
+(define-minor-mode auto-raise-mode
"Toggle whether or not the selected frame should auto-raise.
With ARG, turn auto-raise mode on if and only if ARG is positive.
Note that this controls Emacs's own auto-raise feature.
Some window managers allow you to enable auto-raise for certain windows.
You can use that for Emacs windows if you wish, but if you do,
that is beyond the control of Emacs and this command has no effect on it."
- (interactive "P")
- (if (null arg)
- (setq arg
- (if (cdr (assq 'auto-raise (frame-parameters (selected-frame))))
- -1 1)))
- (if (> arg 0)
- (raise-frame (selected-frame)))
- (modify-frame-parameters (selected-frame)
- (list (cons 'auto-raise (> arg 0)))))
+ :variable (frame-parameter nil 'auto-raise)
+ (if (frame-parameter nil 'auto-raise)
+ (raise-frame)))
-(defun auto-lower-mode (arg)
+(define-minor-mode auto-lower-mode
"Toggle whether or not the selected frame should auto-lower.
With ARG, turn auto-lower mode on if and only if ARG is positive.
Note that this controls Emacs's own auto-lower feature.
Some window managers allow you to enable auto-lower for certain windows.
You can use that for Emacs windows if you wish, but if you do,
that is beyond the control of Emacs and this command has no effect on it."
- (interactive "P")
- (if (null arg)
- (setq arg
- (if (cdr (assq 'auto-lower (frame-parameters (selected-frame))))
- -1 1)))
- (modify-frame-parameters (selected-frame)
- (list (cons 'auto-lower (> arg 0)))))
+ :variable (frame-parameter nil 'auto-lower))
+
(defun set-frame-name (name)
"Set the name of the selected frame to NAME.
When called interactively, prompt for the name of the frame.
@@ -1245,8 +1212,7 @@ frame's display)."
(defun display-selections-p (&optional display)
"Return non-nil if DISPLAY supports selections.
A selection is a way to transfer text or other data between programs
-via special system buffers called `selection' or `cut buffer' or
-`clipboard'.
+via special system buffers called `selection' or `clipboard'.
DISPLAY can be a display name, a frame, or nil (meaning the selected
frame's display)."
(let ((frame-type (framep-on-display display)))
@@ -1467,23 +1433,6 @@ In the 3rd, 4th, and 6th examples, the returned value is relative to
the opposite frame edge from the edge indicated in the input spec."
(cons (car spec) (frame-geom-value-cons (car spec) (cdr spec))))
-;;;; Aliases for backward compatibility with Emacs 18.
-(define-obsolete-function-alias 'screen-height 'frame-height "19.7")
-(define-obsolete-function-alias 'screen-width 'frame-width "19.7")
-
-(defun set-screen-width (cols &optional pretend)
- "Change the size of the screen to COLS columns.
-Optional second arg non-nil means that redisplay should use COLS columns
-but that the idea of the actual width of the frame should not be changed.
-This function is provided only for compatibility with Emacs 18."
- (set-frame-width (selected-frame) cols pretend))
-
-(defun set-screen-height (lines &optional pretend)
- "Change the height of the screen to LINES lines.
-Optional second arg non-nil means that redisplay should use LINES lines
-but that the idea of the actual height of the screen should not be changed.
-This function is provided only for compatibility with Emacs 18."
- (set-frame-height (selected-frame) lines pretend))
(defun delete-other-frames (&optional frame)
"Delete all frames except FRAME.
@@ -1509,9 +1458,6 @@ left untouched. FRAME nil or omitted means use the selected frame."
(when (eq (frame-parameter frame 'minibuffer) 'only)
(delete-frame frame)))))
-(make-obsolete 'set-screen-width 'set-frame-width "19.7")
-(make-obsolete 'set-screen-height 'set-frame-height "19.7")
-
;; miscellaneous obsolescence declarations
(define-obsolete-variable-alias 'delete-frame-hook
'delete-frame-functions "22.1")
@@ -1521,14 +1467,6 @@ 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.
-This is done in the face `trailing-whitespace'."
- :type 'boolean
- :safe 'booleanp
- :group 'whitespace-faces)
-
-
;; Scrolling
@@ -1537,13 +1475,6 @@ This is done in the face `trailing-whitespace'."
:version "21.1"
:group 'frames)
-(defcustom auto-hscroll-mode t
- "Allow or disallow automatic scrolling windows horizontally.
-If non-nil, windows are automatically scrolled horizontally to make
-point visible."
- :version "21.1"
- :type 'boolean
- :group 'scrolling)
(defvaralias 'automatic-hscrolling 'auto-hscroll-mode)
@@ -1630,35 +1561,6 @@ cursor display. On a text-only terminal, this is not implemented."
'blink-cursor-start))))
(define-obsolete-variable-alias 'blink-cursor 'blink-cursor-mode "22.1")
-
-;; Hourglass pointer
-
-(defcustom display-hourglass t
- "Non-nil means show an hourglass pointer, when Emacs is busy.
-This feature only works when on a window system that can change
-cursor shapes."
- :type 'boolean
- :group 'cursor)
-
-(defcustom hourglass-delay 1
- "Seconds to wait before displaying an hourglass pointer when Emacs is busy."
- :type 'number
- :group 'cursor)
-
-
-(defcustom cursor-in-non-selected-windows t
- "Non-nil means show a hollow box cursor in non-selected windows.
-If nil, don't show a cursor except in the selected window.
-If t, display a cursor related to the usual cursor type
- \(a solid box becomes hollow, a bar becomes a narrower bar).
-You can also specify the cursor type as in the `cursor-type' variable.
-Use Custom to set this variable to get the display updated."
- :tag "Cursor In Non-selected Windows"
- :type 'boolean
- :group 'cursor
- :set #'(lambda (symbol value)
- (set-default symbol value)
- (force-mode-line-update t)))
;;;; Key bindings
@@ -1670,5 +1572,4 @@ Use Custom to set this variable to get the display updated."
(provide 'frame)
-;; arch-tag: 82979c70-b8f2-4306-b2ad-ddbd6b328b56
;;; frame.el ends here
diff --git a/lisp/fringe.el b/lisp/fringe.el
index 18a89cddd7d..6f5f496e907 100644
--- a/lisp/fringe.el
+++ b/lisp/fringe.el
@@ -6,6 +6,7 @@
;; Author: Simon Josefsson <simon@josefsson.org>
;; Maintainer: FSF
;; Keywords: frames
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -135,6 +136,14 @@ See `fringe-mode' for possible values and their effect."
;; Otherwise impose the user-specified value of fringe-mode.
(custom-initialize-reset symbol value))))
+(defconst fringe-styles
+ '(("default" . nil)
+ ("no-fringes" . 0)
+ ("right-only" . (0 . nil))
+ ("left-only" . (nil . 0))
+ ("half-width" . (4 . 4))
+ ("minimal" . (1 . 1))))
+
(defcustom fringe-mode nil
"Specify appearance of fringes on all frames.
This variable can be nil (the default) meaning the fringes should have
@@ -143,21 +152,27 @@ the width of both left and right fringe (where 0 means no fringe), or
a cons cell where car indicates width of left fringe and cdr indicates
width of right fringe (where again 0 can be used to indicate no
fringe).
+Note that the actual width may be rounded up to ensure that the sum of
+the width of the left and right fringes is a multiple of the frame's
+character width. However, a fringe width of 0 is never rounded.
To set this variable in a Lisp program, use `set-fringe-mode' to make
it take real effect.
Setting the variable with a customization buffer also takes effect.
If you only want to modify the appearance of the fringe in one frame,
you can use the interactive function `set-fringe-style'."
- :type '(choice (const :tag "Default width" nil)
- (const :tag "No fringes" 0)
- (const :tag "Only right" (0 . nil))
- (const :tag "Only left" (nil . 0))
- (const :tag "Half width" (5 . 5))
- (const :tag "Minimal" (1 . 1))
- (integer :tag "Specific width")
- (cons :tag "Different left/right sizes"
- (integer :tag "Left width")
- (integer :tag "Right width")))
+ :type `(choice
+ ,@ (mapcar (lambda (style)
+ (let ((name
+ (replace-regexp-in-string "-" " " (car style))))
+ `(const :tag
+ ,(concat (capitalize (substring name 0 1))
+ (substring name 1))
+ ,(cdr style))))
+ fringe-styles)
+ (integer :tag "Specific width")
+ (cons :tag "Different left/right sizes"
+ (integer :tag "Left width")
+ (integer :tag "Right width")))
:group 'fringe
:require 'fringe
:initialize 'fringe-mode-initialize
@@ -174,27 +189,20 @@ If ALL-FRAMES, the negation of the fringe values in
`default-frame-alist' is used when user enters the empty string.
Otherwise the negation of the fringe value in the currently selected
frame parameter is used."
- (let ((mode (intern (completing-read
- (concat
- "Select fringe mode for "
- (if all-frames "all frames" "selected frame")
- " (type ? for list): ")
- '(("none") ("default") ("left-only")
- ("right-only") ("half") ("minimal"))
- nil t))))
- (cond ((eq mode 'none) 0)
- ((eq mode 'default) nil)
- ((eq mode 'left-only) '(nil . 0))
- ((eq mode 'right-only) '(0 . nil))
- ((eq mode 'half) '(5 . 5))
- ((eq mode 'minimal) '(1 . 1))
- ((eq mode (intern ""))
- (if (eq 0 (cdr (assq 'left-fringe
- (if all-frames
- default-frame-alist
- (frame-parameters (selected-frame))))))
- nil
- 0)))))
+ (let* ((mode (completing-read
+ (concat
+ "Select fringe mode for "
+ (if all-frames "all frames" "selected frame")
+ " (type ? for list): ")
+ fringe-styles nil t))
+ (style (assoc (downcase mode) fringe-styles)))
+ (if style (cdr style)
+ (if (eq 0 (cdr (assq 'left-fringe
+ (if all-frames
+ default-frame-alist
+ (frame-parameters (selected-frame))))))
+ nil
+ 0))))
(defun fringe-mode (&optional mode)
"Set the default appearance of fringes on all frames.
diff --git a/lisp/generic-x.el b/lisp/generic-x.el
index 0083989c75a..8c2e8b4bc99 100644
--- a/lisp/generic-x.el
+++ b/lisp/generic-x.el
@@ -6,6 +6,7 @@
;; Author: Peter Breton <pbreton@cs.umb.edu>
;; Created: Tue Oct 08 1996
;; Keywords: generic, comment, font-lock
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/gnus/.dir-locals.el b/lisp/gnus/.dir-locals.el
new file mode 100644
index 00000000000..fb968e13a36
--- /dev/null
+++ b/lisp/gnus/.dir-locals.el
@@ -0,0 +1,4 @@
+((emacs-lisp-mode . ((show-trailing-whitespace . t))))
+;; Local Variables:
+;; no-byte-compile: t
+;; End:
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index 7350cf97f50..651cfef7f00 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,17 +1,4189 @@
-2010-11-19 Yuri Karaban <tech@askold.net> (tiny change)
+2010-11-27 Yuri Karaban <tech@askold.net> (tiny change)
* pop3.el (pop3-open-server): Read server greeting before starting TLS
negotiation.
-2010-10-12 Juanma Barranquero <lekktu@gmail.com>
+2010-11-26 Julien Danjou <julien@danjou.info>
+
+ * color.el: Rename various rgb functions to srgb.
+
+2010-11-26 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-get-groups): Allow non-quoted strings as mailbox
+ names.
+
+2010-11-26 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * shr.el (shr-insert): Revert last change.
+ (shr-find-fill-point): Never leave point being at bol;
+ relax the kinsoku limitation when rendering tables.
+
+2010-11-26 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnmail.el (nnmail-expiry-target-group): Protect against degenerate
+ results from -accept-article.
+
+ * shr-color.el: Require cl when compiling.
+
+ * nnheader.el (nnheader-update-marks-actions): Fix typo in last
+ checkin.
+
+ * gnus-art.el (gnus-url-mailto): Unfold URLs before using them.
+
+ * nnimap.el (nnimap-request-set-mark): Add is "+", not "-".
+
+ * gnus-sum.el (gnus-summary-push-marks-to-backend): Use 'set instead of
+ 'add and 'delete to set backend marks.
+
+ * nnmaildir.el (nnmaildir-request-set-mark): Be explicit about 'set.
+
+ * nnheader.el (nnheader-update-marks-actions): Refactor out.
+
+ * nntp.el (nntp-request-set-mark): Use it.
+
+ * nnfolder.el (nnfolder-request-set-mark): Ditto.
+
+ * nnml.el (nnml-request-set-mark): Ditto.
+
+ * nnimap.el (nnimap-last-response-string): Remove the unfolding -- it
+ introduces regressions in article selection.
+ (nnimap-find-uid-response): New function.
+ (nnimap-request-accept-article): Use the UID returned, if any.
+ (nnimap-request-move-article): Use the UID returned, if any.
+ (nnimap-get-groups): Reimplement to work with folded lines.
+ (nnimap-find-uid-response): The UID is the last element in the list.
+ (nnimap-request-set-mark): Extend syntax with 'set.
+
+ * nnml.el (nnml-request-set-mark): Ditto.
+
+ * nnfolder.el (nnfolder-request-set-mark): Ditto.
+
+ * nntp.el (nntp-request-set-mark): Ditto.
+
+2010-11-25 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * message.el (message-called-interactively-p): A temporary macro.
+ (message-goto-body): Use it temporarily.
+
+2010-11-25 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-unfold-quoted-lines): Refactor out.
+ (nnimap-last-response-string): Unfold quoted lines, if they exist.
+ (nnimap-last-response-string): Fix last unfolding fix.
+
+2010-11-25 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * shr.el (shr-insert): Fix the way to fold lines.
+
+2010-11-25 Julien Danjou <julien@danjou.info>
+
+ * shr-color.el (shr-color->hexadecimal): Use color-rgb->hex
+
+ * color.el: Rename from color-lab.el
+ (color-rgb->hex): Add.
+ (color-complement): Add.
+ (color-complement-hex): Add.
+
+ * gnus-sum.el (gnus-summary-widget-forward): Add, and bind to [tab].
+
+2010-11-25 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr-color.el (shr-color-visible): Don't bug out if the colour names
+ don't exist.
+
+2010-11-25 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * mml.el (mml-preview): Make sure to bind gnus-displaying-mime to nil,
+ assuming that article displaying or another mml-preview may be
+ interrupted for an error or for the like.
+
+ * shr.el (shr-get-background): Fix argument name.
+
+2010-11-24 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-cache.el (gnus-summary-insert-cached-articles): Use it.
+
+ * gnus-sum.el (gnus-summary-include-articles): New function.
+
+ * message.el (message-goto-body): called-interactively-p needs a
+ parameter, so use `any'.
+
+ * nnimap.el (nnimap-request-move-article): It's no longer necessary to
+ clear marks before moving, since they're synced from the Gnus side
+ first.
+
+ * gnus-sum.el (gnus-summary-push-marks-to-backend): New function.
+ (gnus-summary-move-article): Copy over all marks before moving, so that
+ IMAP doesn't think a new article has arrived.
+
+2010-11-24 Julien Danjou <julien@danjou.info>
+
+ * shr.el (shr-insert-background-overlay): Fix typo.
+ (shr-render-td): Copy the background before rendering.
+
+ * shr-color.el (shr-color-visible): Fix docstring.
+
+ * shr.el (shr-tag-table): Add bgcolor support.
+ (shr-render-td): Add bgcolor support.
+ (shr-get-background): Add.
+ (shr-insert-foreground-overlay): Use shr-get-background.
+
+ * message.el (message-goto-body): Use called-interactively-p.
+ (message-in-body-p): message-goto-body returns point.
+
+2010-11-24 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * mm-util.el (mm-enable-multibyte): Use `to' instead of t. This fixes
+ Fixes something or other in Emacs 23, and is backwards compatible.
+
+ * message.el (message-goto-body): Remove the <#secure special-casing,
+ which is too special.
+
+ * shr.el (shr-parse-style): Drop !important from styles.
+
+2010-11-24 Daniel Schoepe <daniel.schoepe@googlemail.com> (tiny change)
+
+ * gnus-sum.el (gnus-summary-articles-in-thread): Fix a bug that causes
+ this function to return incorrect results when calling it with an
+ explicit article argument different from
+ (gnus-summary-article-number).
+
+2010-11-24 Julien Danjou <julien@danjou.info>
+
+ * shr.el (shr-insert-color-overlay): Replace deprecated syntax.
+ (shr-tag-body): Add background support.
+ (shr-descend): Add background support.
+ (shr-tag-title): Add.
+
+ * shr-color.el (shr-color-visible): Really return original background
+ if fixed.
+
+2010-11-24 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-color-check): Protect against non-existant colour names.
+
+2010-11-24 Julien Danjou <julien@danjou.info>
+
+ * color-lab.el: Require 'cl when compiling.
+
+ * shr.el (shr-insert-color-overlay): Remove specific rgb() check.
+
+ * shr-color.el (shr-color->hexadecimal): Only return the hexadecimal
+ matched part.
+
+ * color-lab.el: Fix all expt calls to use float type.
+
+2010-11-24 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * shr.el (shr-insert-color-overlay): Pass rgb(rrr, ggg, bbb) type color
+ expression to shr-color-check as is.
+
+ * shr-color.el (shr-color->hexadecimal): Ignore case of color names.
+
+ * color-lab.el: Add coding cookie.
+ (float-pi): Use eval-and-compile.
+
+2010-11-23 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-insert-color-overlay): Split stuff like
+ "#444444 !important" to find the real colour.
+ (shr-tag-font): Resurrect shr-tag-font again, since it's needed to
+ parse <font color="red"> entries.
+
+2010-11-23 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnheader.el (nnheader-parse-head): Bug fix. Properly position
+ point when parsing headers.
+
+ * nnspool.el (nnspool-insert-nov-head): Bug fix. Make sure point
+ is positioned properly when parsing headers.
+
+2010-11-23 Julien Danjou <julien@danjou.info>
+
+ * color-lab.el (boundp): Bind float-pi for Emacs < 23.3.
+
+ * shr-color.el (shr-color->hexadecimal): Add support for color names.
+
+ * shr.el (shr-parse-style): Replace \n with space in style parsing.
+
+ * shr-color.el (shr-color-hsl-to-rgb-fractions): Use
+ shr-color-hue-to-rgb.
+ (shr-color->hexadecimal): Call shr-color-hsl-to-rgb-fractions.
+
+2010-11-23 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-color->hexadecimal): Autoload.
+ (shr-descend): Add color to all tags.
+
+2010-11-22 Julien Danjou <julien@danjou.info>
+
+ * shr.el (shr-tag-color-check): Convert colors to hexadecimal with
+ shr-color->hexadecimal.
+
+ * shr-color.el (shr-color->hexadecimal): Add converting functions for
+ RGB() or HSL() color representation.
+
+ * shr.el (shr-tag-font): Add.
+ (shr-tag-color-check): New function to get better colors.
+ (shr-tag-insert-color-overlay): Factorize code between tag-font and
+ tag-span.
+
+ * shr-color.el: New file.
+
+ * color-lab.el: New file.
+
+ * gnus-art.el (gnus-url-mailto): Do not downcase args.
+
+2010-11-21 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el: Fix typo in comments.
+ (nnir-run-imap): Simplify code. No need to reverse artlist.
+ (nnir-run-gmane): Use nnir-tmp-buffer for web results.
+
+2010-11-21 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-srvr.el (gnus-server-show-server): New command and keystroke.
+
+ * nnimap.el (nnimap-get-capabilities): Refactor out.
+ (nnimap-open-connection): Re-request capabilities after STARTTLS.
+
+2010-11-21 Ralf Angeli <angeli@caeruleus.net>
+
+ * mm-uu.el (mm-uu-type-alist): Prevent spurious empty line from
+ appearing when `mm-uu-hide-markers' is nil.
+
+2010-11-21 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-unselect-group): Make into its own function.
+ (nnimap-request-rename-group): Unselect group before renaming.
+ This had gotten lost somewhere.
+ (nnimap-request-accept-article): Keep track of examined groups, and
+ unselect the group before APPENDing to read-only groups.
+ (nnimap-request-move-article): Clear flags before moving so that they
+ can be re-set later.
+
+2010-11-20 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-gravatar.el (gnus-gravatar-transform-address): Decode name again.
+ (gnus-gravatar-insert): Put avatar always in the beginning of the field.
+
+2010-11-19 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-art.el (gnus-mime-display-single)
+ * gnus-html.el (gnus-html-wash-images, gnus-html-prefetch-images)
+ * mm-decode.el (mm-shr): Assume that gnus-inhibit-images may be a group
+ parameter.
+
+2010-11-18 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-table-horizontal-line): Rename from shr-table-line.
+ (shr-table-vertical-line): New variable.
+ (shr-insert-table): Use it.
+
+2010-11-18 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-html.el (gnus-html-wash-images): Don't display images if
+ gnus-inhibit-images is non-nil; register displayer for cid images.
+ (gnus-html-display-image): Work for cid image.
+ (gnus-html-insert-image): Allow arguments.
+ (gnus-html-put-image): Inhibit read-only.
+ (gnus-html-prefetch-images): Don't prefetch images if
+ gnus-inhibit-images is non-nil.
+
+2010-11-17 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-put-image): Break lines when inserting big pictures.
+
+2010-11-17 Daniel Dehennin <daniel.dehennin@baby-gnu.org>
+
+ * mml2015.el (mml2015-epg-encrypt): Fix two cons with missing
+ sender, thanks Katsumi Yamaoka.
+
+2010-11-17 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el (nnir-run-imap): Reverse the article list for each group
+ rather than the whole list.
+
+2010-11-17 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * shr.el (shr-image-displayer): Protect function against non-existent
+ image source.
+
+ * gnus-art.el (gnus-inhibit-images): New user option.
+ (gnus-mime-display-single): Don't display image if it is non-nil.
+
+ * mm-decode.el (mm-shr): Bind shr-inhibit-images to the value of
+ gnus-inhibit-images.
+
+ * shr.el (shr-image-displayer): New function.
+ (shr-tag-img): Use it.
+
+2010-11-16 Daniel Dehennin <daniel.dehennin@baby-gnu.org>
+
+ * mml2015.el (mml2015-epg-sign): Use From header.
+
+2010-11-15 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-html.el (gnus-html-wash-images): Register a displayer.
+
+ * gnus-util.el (gnus-find-text-property-region): Return markers.
+
+ * shr.el (shr-tag-img): Put a displayer in the text property.
+
+ * gnus-util.el (gnus-find-text-property-region): New utility function.
+
+ * gnus-html.el (gnus-html-display-image): Make the alt optional.
+ (gnus-html-show-images): Remove.
+
+ * gnus-art.el (gnus-article-show-images): New, more general function.
+
+ * gnus-html.el: Use image-url instead of gnus-image-url to unify the
+ image url text properties.
+
+ * shr.el: Ditto.
+
+ * gnus-agent.el (gnus-agentize): Only do the auto-agentizing if
+ gnus-agent-auto-agentize-methods is set. Which it isn't.
+
+2010-11-15 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-sum.el (gnus-summary-move-article): Fix `while' loop to make it
+ work for two or more articles.
+
+2010-11-12 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-art.el (article-treat-non-ascii): Keep text properties not to
+ divide an image that's in an html article to two or more when washing
+ non-ASCII characters in alt text of it.
+
+2010-11-11 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * mm-decode.el (mm-dissect-buffer): Pass sender's mail address to
+ smime-decrypt-region using function argument.
+ (mm-possibly-verify-or-decrypt, mm-dissect-multipart): Relay it.
+
+ * mm-view.el (mm-view-pkcs7, mm-view-pkcs7-decrypt): Relay it.
+
+ * smime.el (smime-decrypt-region): Catch it.
+
+2010-11-11 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * smime.el (smime-mode-map): Move initialization into declaration.
+ (gnus-run-mode-hooks): Don't autoload.
+ (smime-mode): Use define-derived-mode.
+
+2010-11-11 Glenn Morris <rgm@gnu.org>
+
+ * smime.el (from): Restrict declaration to XEmacs.
+
+ * nnir.el (gnus-group-topic-name): Autoload.
+
+2010-11-11 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * shr.el (shr-insert): Don't break long line if it is because of
+ kinsoku-bol characters in the line end.
+
+2010-11-11 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el (nnir-request-move-article): Fix to provide original group
+ and subject.
+ (nnir-warp-to-article): Don't fail on articles whose headers haven't
+ been retrieved.
+
+ * gnus-sum.el (gnus-summary-move-article): Use original group and
+ subject for virtual articles such as those in an nnir summary buffer.
+
+2010-11-11 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-art.el (article-treat-non-ascii): Make it work for XEmacs (at
+ least 21.5).
+
+ * smime.el (from): Declare it again for XEmacs.
+
+2010-11-10 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * message.el (message-resend): Don't disable encoding unless it's
+ already encoded.
+
+ * nnimap.el (nnimap-update-info): Fix problem with `g' chopping of
+ low-numbered articles.
+
+2010-11-10 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * rfc2047.el (rfc2047-syntax-table): Simplify.
+
+ * gnus-art.el (article-treat-non-ascii): Use put-char-table instead of
+ set-char-table-range for XEmacs.
+
+2010-11-10 Glenn Morris <rgm@gnu.org>
+
+ * smime.el (from): Remove unused declaration.
+
+ * gnus-util.el (with-no-warnings): Remove compat stub, now unused.
+ (gnus-float-time): On Emacs, always an alias.
+
+ * ecomplete.el (with-no-warnings): Remove compat stub, now unused.
+ (ecomplete-add-item): Use float-time on Emacs, else gnus-float-time.
+
+2010-11-10 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-art.el (org-entities): Declare it to silence the byte compiler.
+
+2010-11-09 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (browse-url-mailto): Autoload.
+
+ * gnus-art.el (article-treat-non-ascii): New command and keystroke.
+
+ * message.el (message-subject-trailing-was-ask-regexp): A ] in a []
+ regexp doesn't need quoting.
+
+2010-11-09 Sven Joachim <svenjoac@gmx.de>
+
+ * message.el (message-subject-trailing-was-ask-regexp)
+ (message-subject-trailing-was-regexp): Match was: in addition to was.
+
+2010-11-09 Glenn Morris <rgm@gnu.org>
+
+ * nnbabyl.el (nnbabyl-request-move-article, nnbabyl-delete-mail)
+ (nnbabyl-check-mbox): Use point-at-bol.
+
+2010-11-08 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-browse-url): Call browse-url-mailto for mailto: links.
+
+ * message.el (message-mailto): New function.
+ (message-mailto): Should accept other parameters.
+ (message-mailto): Remove since it duplicates browse-url-mailto
+ functionality.
+
+2010-11-07 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-start.el (gnus-get-unread-articles): Ignore totally non-existent
+ methods.
+ (gnus-read-active-file): Ditto.
+
+ * gnus-group.el (gnus-group-read-ephemeral-group): Remove superfluous
+ ": " from the prompt.
+ (gnus-group-make-group): Ditto.
+
+2010-11-07 Glenn Morris <rgm@gnu.org>
+
+ * gnus-bookmark.el (gnus-bookmark-bmenu-show-infos)
+ (gnus-bookmark-kill-line): Use point-at-eol.
+
+2010-11-07 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-gravatar.el (gnus-gravatar-transform-address): No need to skip
+ asterisks in From header.
+
+2010-11-06 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-ems.el (gnus-put-image): Use a blank text as the insertion
+ string to avoid making the From headers syntactically invalid.
+
+ * message.el (message-send-mail): Don't insert courtesy messages if the
+ message already has List-Post and List-ID messages.
+
+2010-11-06 Glenn Morris <rgm@gnu.org>
+
+ * gnus-art.el (gnus-treat-article): Give dynamic local variables
+ `condition', `type', `length' a prefix.
+ (gnus-treat-predicate): Update for above name changes.
+
+2010-11-06 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el (gnus-summary-nnir-goto-thread): Remove function and
+ binding. Handled by `gnus-summary-refer-thread' instead.
+ (nnir-warp-to-article): New backend function.
+
+ * nnimap.el (nnimap-request-thread): Force dependency updating.
+
+ * gnus-sum.el (gnus-fetch-headers): Allow more arguments.
+ (gnus-summary-refer-thread): Rework to improve thread-referral.
+
+ * gnus-int.el (gnus-warp-to-article): New function.
+
+ * gnus-sum.el (gnus-summary-article-map): Bind it.
+
+2010-11-04 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el (gnus-summary-nnir-goto-thread): Limit work done by
+ gnus-summary-refer-thread.
+
+ * gnus-sum.el (gnus-build-all-threads): Force updating of dependency
+ headers.
+ (gnus-summary-limit-include-thread): Prevent articles in thread from
+ being cut in gnus-cut-threads.
+ (gnus-summary-refer-thread): Limit retrieved headers to those in
+ thread.
+
+2010-11-04 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * message.el (message-send-mail): Use the value of
+ message-courtesy-message from the message buffer.
+
+ * gnus-html.el (gnus-html-browse-url): Implement mailto: URLs.
+
+ * shr.el (shr-browse-url): Implement mailto: URLs.
+
+ * gnus-sum.el (gnus-summary-show-article): Take `t' as the arg to mean
+ "raw".
+
+ * nnimap.el (nnimap-find-article-by-message-id): Don't EXAMINE a group
+ if it's already selected.
+
+ * mm-decode.el (mm-save-part): Put the entire path in the `M-n' slot.
+
+2010-11-04 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * shr.el (shr-tag-img): Use string-width and truncate-string-to-width
+ to measure the length and truncate alt text.
+
+2010-11-03 Glenn Morris <rgm@gnu.org>
+
+ * nndiary.el (nndiary-generate-nov-databases-1)
+ (nndiary-generate-active-info): Rename dynamic variable `files' to
+ something less generic.
+
+2010-11-03 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el (nnir-request-move-article): Call the underlying backend to
+ move articles from nnir.
+
+2010-11-02 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-cite.el (gnus-article-natural-long-line-p): Remove.
+
+2010-11-02 Julien Danjou <julien@danjou.info>
+
+ * nnir.el: Remove wais support.
+
+2010-11-02 Glenn Morris <rgm@gnu.org>
+
+ * gnus-html.el: Reorder requirements to quieten compiler.
+
+2010-11-02 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-cite.el (gnus-article-fill-cited-article): Make fill work
+ properly for XEmacs as well.
+ (gnus-article-fill-cited-article, gnus-article-foldable-buffer)
+ (gnus-article-natural-long-line-p): Use window-width rather than
+ frame-width.
+
+2010-11-01 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el (nnir-run-gmane): Inhibit demon. Return nil if no messages.
+ (nnir-read-parms): Don't modify query.
+ (nnir-run-query): Add ability to search topic on current line.
+ (nnir-get-active): Clean up.
+
+2010-11-01 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-cite.el (gnus-article-foldable-buffer): Protect against
+ degenerate articles.
+
+ * gnus-sum.el (gnus-print-buffer): Rewrite to use with-temp-buffer.
+ (gnus-print-buffer): Just print the buffer as is, without any copying
+ to a buffer and then re-highlighting.
+
+ * nnimap.el (nnimap-request-group): Store the new updated info.
+ (nnimap-request-group): Select the group when we don't know whether it
+ exists or not.
+
+ * gnus-start.el (gnus-ask-server-for-new-groups): Return the new
+ groups.
+
+ * gnus-group.el (gnus-group-find-new-groups): Display all the new
+ groups.
+
+ * gnus-start.el (gnus-find-new-newsgroups): Return the list of new
+ groups.
+
+ * gnus-cite.el (gnus-article-fill-cited-article): Minimize the
+ long-lines case by only filling the long lines.
+
+ * nnimap.el (nnimap-parse-line): Don't bug out oddly formed replies
+ (bug #7311).
+
+2010-11-01 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * shr.el: No need to declare `declare-function' since shr.el is for
+ only Emacsen that provide `libxml-parse-html-region'.
+
+2010-11-01 Glenn Morris <rgm@gnu.org>
+
+ * mm-util.el (gnus-completing-read): Autoload.
+ (mm-read-coding-system): Simplify Emacs definition.
+
+ * nnmail.el (gnus-activate-group):
+ * nnimap.el (gnutls-negotiate):
+ * nntp.el (netrc-parse): Fix declarations.
+
+2010-11-01 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-util.el (gnus-string-match-p): New function, that is an alias to
+ string-match-p in Emacs >=23.
+
+ * gnus-msg.el (gnus-configure-posting-styles)
+ * nnir.el (nnir-run-gmane): Use gnus-string-match-p.
+
+2010-11-01 Glenn Morris <rgm@gnu.org>
+
+ * nnir.el (declare-function): Add compat stub.
+ (mm-url-insert, mm-url-encode-www-form-urlencoded): Declare.
+ (nnir-run-gmane): Require 'mm-url.
+
+ * mm-util.el (mm-string-to-multibyte): Simplify.
+
+ * shr.el (declare-function): Add compat stub.
+ (url-cache-create-filename): Declare.
+ (mm-disable-multibyte, widget-convert-button): Autoload.
+
+ * smime.el (ldap-search): Declare.
+ (smime-cert-by-ldap-1): Require ldap on Emacs.
+
+ * nnimap.el: Require nnmail, and gnus-sum when compiling.
+ (nnimap-keepalive): Use gnus-float-time.
+
+ * mail-source.el (nnheader-message, gnus-float-time): Autoload.
+ (mail-source-delete-crash-box): Use gnus-float-time.
+
+ * gnus-dired.el (gnus-completing-read): Autoload.
+
+ * mm-view.el (gnus-rescale-image): Autoload.
+
+ * mm-decode.el (gnus-completing-read, gnus-blocked-images): Autoload.
+
+ * gnus.el (gnus-sloppily-equal-method-parameters): Move defn before use.
+
+ * sieve-manage.el: Require 'cl when compiling.
+
+ * gnus-util.el (iswitchb-read-buffer): Declare rather than autoload.
+ (gnus-iswitchb-completing-read): Require iswitchb.
+ (gnus-select-frame-set-input-focus): Silence compiler.
+
+2010-10-31 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * message.el (message-subject-trailing-was-query): Change default to t,
+ since I think that's what most people want.
+
+ * nnimap.el (nnimap-request-accept-article): Erase buffer before
+ appending for easier debugging.
+ (nnimap-wait-for-connection): Take a regexp.
+ (nnimap-request-accept-article): Wait for the continuation line before
+ sending anything unless we're streaming.
+
+ * gnus-art.el (gnus-treat-article): Only inhibit body washing, and
+ leave the header washing to take place.
+
+2010-10-31 Daniel Dehennin <daniel.dehennin@baby-gnu.org>
+
+ * gnus-msg.el (gnus-configure-posting-styles): Permit the use of
+ regular expression match and replace in posting styles.
+
+2010-10-31 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el (gnus-group-make-nnir-group,nnir-run-query): Allow searching
+ an entire server.
+ (nnir-get-active): New function.
+ (nnir-run-imap): Use it.
+ (nnir-run-gmane): Who knew, gmane search returns an article score!
+
+ * gnus-srvr.el (gnus-server-mode-map): Add binding "G" to search the
+ server on the current line with nnir.
+
+2010-10-31 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-cite.el (gnus-article-foldable-buffer): Refactor out.
+ (gnus-article-foldable-buffer): Don't fold regions that have a ragged
+ left edge.
+ (gnus-article-foldable-buffer): Skip past the prefix when determining
+ raggedness.
+
+ * gnus-sum.el (gnus-summary-show-article): Add `C-u C-u g' for showing
+ the raw article, and change `C-u g' to show the article without doing
+ treatments.
+
+ * gnus-art.el (gnus-mime-display-alternative): Actually pass the type
+ on to `gnus-treat-article'.
+ (gnus-inhibit-article-treatments): New variable.
+
+ * gnus.el: Autoload gnus-article-fill-cited-long-lines.
+
+ * gnus-art.el (gnus-treatment-function-alist): Have
+ gnus-treat-fill-long-lines point to gnus-article-fill-cited-long-lines.
+ (gnus-treat-fill-long-lines): Change default to fill all text/plain
+ sections.
+
+ * gnus-cite.el (gnus-article-fill-cited-article): Remove unused `force'
+ parameter.
+ (gnus-article-fill-cited-long-lines): New function.
+ (gnus-article-fill-cited-article): Allow filling only long sections.
+
+ * shr.el (shr-find-fill-point): Don't break lines between punctuation
+ and non-punctuation (like after the apostrophe in "'We").
+
+ * gnus-sum.el (gnus-summary-select-article): Make sure
+ gnus-original-article-buffer is alive.
+
+ * nndoc.el (nndoc-dissect-buffer): Reverse the order of the articles to
+ reflect the order they're in in the digest.
+
+ * gnus.el (gnus-group-startup-message): Move point to the start of the
+ buffer.
+
+ * nnimap.el (nnimap-capability): New function.
+ (nnimap-open-connection): Only send AUTHENTICATE PLAIN if LOGINDISABLED
+ is set.
+
+2010-10-31 David Engster <dengste@eml.cc>
+
+ * nnmairix.el (nnmairix-get-valid-servers): Return list of strings to
+ conform with changes to gnus-completing-read.
+
+2010-10-30 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-tag-img): Output "*" instead of "[img]".
+
+2010-10-30 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el: Move defvar, defcustom around to keep file organized
+ and keep byte-compiler quiet.
+ (nnir-read-parms): Accept search-engine as arg.
+ (nnir-run-query): Pass search-engine as arg.
+ (nnir-search-engine): Remove.
+
+2010-10-30 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-generic): The text nodes should be text, not :text.
+
+ * nnir.el (nnir-search-engine): Ressurect variable, since it's used
+ later in the file.
+
+2010-10-30 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el: General clean up. Allow searching with multiple engines.
+ Allow separate extra-parameters for each engine.
+ Batch queries when possible.
+ (nnir-imap-default-search-key,nnir-method-default-engines):
+ Add customize interface.
+ (nnir-run-gmane): New engine.
+ (nnir-engines): Use it. Qualify all prompts with engine name.
+ (nnir-search-engine): Remove global variable.
+ (nnir-run-hyrex): Restore for now.
+ (nnir-extra-parms,nnir-search-history): New variables.
+ (gnus-group-make-nnir-group): Use them.
+ (nnir-group-server): Remove in favor of gnus-group-server.
+ (nnir-request-group): Avoid searching twice.
+ (nnir-sort-groups-by-server): New function.
+
+2010-10-30 Julien Danjou <julien@danjou.info>
+
+ * gnus-group.el: Remove gnus-group-fetch-control.
+
+ * gnus-start.el (gnus-find-new-newsgroups):
+ Remove gnus-check-first-time-used.
+
+ * gnus.el: Remove gnus-backup-default-subscribed-newsgroups.
+
+2010-10-30 Knut Anders Hatlen <kahatlen@gmail.com> (tiny change)
+
+ * nnimap.el (nnimap-update-info): Allow 'ticked and other flags to be
+ set on groups that don't have \* permanentflags.
+
+2010-10-30 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-tag-span): Drop colorisation of regions since we don't
+ control the background color.
+ (shr-tag-img): Ignore very small web bug type images.
+ (shr-put-image): Add help-echo alt texts to the images.
+ (shr-tag-video): Show the video poster image.
+
+2010-10-29 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-table-depth): New variable.
+ (shr-tag-table-1): Only insert the images after the top-level table.
+
+ * nnimap.el (nnimap-split-incoming-mail): Fix typo.
+
+ * gnus-util.el (gnus-list-memq-of-list): New function.
+
+ * nnimap.el (nnimap-split-incoming-mail): Note that the INBOX has been
+ selected.
+ (nnimap-unsplittable-articles): New slot.
+ (nnimap-new-articles): Use it.
+
+2010-10-29 Stephen Berman <stephen.berman@gmx.net> (tiny change)
+
+ * gnus-group.el (gnus-group-get-new-news-this-group): Don't have point
+ move to the previous line on `M-g'.
+
+2010-10-29 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-msg.el (gnus-inews-do-gcc): Don't have the backends do the slow
+ *-request-group, which seems unnecessary.
+
+ * nnimap.el (nnimap-quote-specials): Function copied over from
+ imap.el.
+ (nnimap-open-connection): Use AUTHENTICATE PLAIN on servers that say
+ they support that. Suggested by Tom Regner.
+
+2010-10-29 Julien Danjou <julien@danjou.info>
+
+ * gnus-sum.el (gnus-summary-delete-marked-as-read): Remove obsolete
+ defalias.
+ (gnus-summary-delete-marked-with): Remove obsolete defalias.
+
+ * gnus.el: Remove `gnus-nntp-service' variable.
+ (gnus-secondary-servers): Make obsolete.
+ (gnus-nntp-server): Make obsolete.
+
+ * gnus-start.el (gnus-1): Remove x-splash calls.
+
+ * gnus-ems.el (gnus-x-splash): Remove.
+
+ * gnus.el (gnus-group-startup-message): Simplify/update code.
+
+ * gnus-group.el (gnus-group-make-tool-bar): Check for display graphic
+ capability before doing anything.
+ (gnus-group-insert-group-line): Remove useless
+ gnus-group-remove-excess-properties.
+
+2010-10-29 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-art.el (gnus-article-goto-part): Work for article narrowed by ^L.
+
+2010-10-28 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-sum.el (gnus-summary-rescan-group): Try to restore the window
+ config after reselecting.
+
+2010-10-28 Julien Danjou <julien@danjou.info>
+
+ * shr.el (shr-put-image): Use point even if only inserting text.
+ (shr-put-image): Save excursion when inserting alt text on non-graphic
+ display, so the behaviour is the same when we are on a graphic display.
+
+ * nnir.el (nnir-run-swish-e): Remove hyrex support.
+
+2010-10-28 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-art.el (gnus-article-jump-to-part): Error on no part; fix prompt.
+ (gnus-mime-copy-part): Check coding system, not charset.
+ (gnus-mime-view-part-externally): Never remove part.
+ (gnus-mime-view-part-internally): Don't remove part here.
+ (gnus-article-part-wrapper): Make sure MIME tag is visible.
+ (gnus-article-goto-part): Go to displayed or preferred subpart if it is
+ multipart/alternative.
+
+ * mm-decode.el (mm-display-part): Take optional arg `force'.
+
+2010-10-26 Julien Danjou <julien@danjou.info>
+
+ * gnus-group.el (gnus-group-default-list-level): Add this function to
+ compute the default list level.
+ (gnus-group-default-list-level): Add possibility to use a function.
+
+2010-10-27 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * mm-decode.el (mm-shr): Add undisplayer to MIME handle.
+
+ * gnus-group.el (gnus-group-completing-read)
+ (gnus-read-ephemeral-bug-group): Replace replace-regexp-in-string with
+ gnus-replace-in-string.
+
+2010-10-26 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * shr.el (shr-tag-div): Add.
+
+2010-10-25 Julien Danjou <julien@danjou.info>
+
+ * gnus-util.el: Remove `gnus-with-local-quit'.
+
+ * gnus-demon.el (gnus-demon-init): Use run-with-idle-timer function.
+
+2010-10-25 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-sum.el (gnus-summary-select-article): Fix type error in checking
+ the original article buffer.
+
+2010-10-24 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-request-head): New function.
+ (nnimap-request-move-article): Try to be slighly faster by not
+ requesting the entire message when moving.
+ (nnimap-transform-headers): Don't bug out on bodiless articles.
+ (nnimap-send-command): Have no outstanding messages if the IMAP server
+ doesn't support streaming.
+ (nnimap-transform-headers): Fold {quoted} strings more sloppily.
+
+2010-10-24 Julien Danjou <julien@danjou.info>
+
+ * message.el (message-default-headers): Fix type.
+
+2010-10-24 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-html.el (gnus-html-prefetch-images): Decode entities before
+ prefetching images.
+
+ * gnus-sum.el (gnus-group-make-articles-read): Propagate marks to the
+ backend for unknown groups. This is mainly useful for nnimap groups.
+
+ * gnus-agent.el (gnus-agent-fetch-group): Don't download stuff if the
+ group isn't covered by the agent.
+
+2010-10-22 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el (nnir-method-default-engines): New variable.
+ (nnir-run-query): Use it.
+ (nnir-group-mode-hook): Remove key binding and move to gnus-group.el.
+ (gnus-summary-nnir-goto-thread): Change group if needed.
+
+ * gnus-group.el (gnus-group-group-map): Add key binding for
+ gnus-group-make-nnir-group.
+
+2010-10-24 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-tag-object): Add.
+
+ * gnus-sum.el (gnus-summary-select-article): Make sure we have the
+ original article buffer live.
+ (gnus-summary-select-article-buffer):
+ Mention gnus-widen-article-buffer.
+
+2010-10-23 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-tag-strong): Add.
+
+2010-10-22 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-group.el (gnus-group-completing-read): Remove all newlines from
+ group names. They mess up the group buffer badly.
+
+ * shr.el (shr-tag-img): Don't bug out on images that don't have a SRC.
+
+ * gnus-group.el (gnus-group-mark-group): Use gnus-group-position-point
+ instead of the summary one.
+
+2010-10-22 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * mml.el (mml-preview): Work properly when editing article.
+
+ * gnus-start.el (gnus-read-active-file-1): Don't add method to
+ gnus-have-read-active-file if it's already been in.
+
+2010-10-22 Tom Tromey <tromey@redhat.com>
+
+ * gnus-group.el (gnus-group-unsubscribe-group): Fix args passed to
+ gnus-group-completing-read.
+
+2010-10-21 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * message.el (message-mode-map): Don't bind M-; to comment region, to
+ allow the global comment-dwim to work.
+
+2010-10-21 Julien Danjou <julien@danjou.info>
+
+ * message.el (message-setup-1): Allow message-default-headers to be a
+ function.
+
+2010-10-21 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * shr.el (shr-tag-table): Simplify.
+
+2010-10-21 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-html.el (gnus-html-prefetch-images): Only prefetch http images
+ to avoid trying to snarf invalid stuff.
+
+ * gnus-sum.el (gnus-summary-edit-article-done): Bind free variable.
+
+ * gnus.el (gnus-message-archive-group): Quote value.
+ (gnus-message-archive-group): Mark as changed.
+
+ * shr.el (shr-add-font): Don't put the font properties on the newline
+ or the indentation.
+
+ * message.el (message-fix-before-sending): Change options when sending
+ non-printable characters.
+
+ * gnus.el (gnus-message-archive-method): Change the default to
+ monthly outgoing groups.
+
+ * gnus-sum.el (gnus-summary-edit-article-done): Try to replace articles
+ that have gotten new numbers.
+
+ * nnimap.el (nnimap-request-replace-article): New function.
+
+2010-10-21 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * nnrss.el (nnrss-wash-html-in-text-plain-parts): Remove.
+ (nnrss-request-article): Don't use special html washing code.
+
+2010-10-20 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * shr.el (shr-tag-table): Remove useless nconc.
+
+2010-10-20 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-art.el (article-wash-html): Simplify and remove the charset
+ stuff. Use the normal html rendering code instead of the special html
+ washing code.
+
+ * mm-view.el (mm-text-html-renderer-alist): Add the `shr' and
+ `gnus-w3m' symbols.
+ (mm-text-html-washer-alist): Remove.
+
+ * mm-decode.el (mm-inline-text-html-renderer): Remove.
+ (mm-inline-media-tests): Remove use.
+ (mm-text-html-renderer): Change default to the `shr' symbol.
+
+ * mm-view.el (mm-inline-text-html): Remove use.
+
+ * gnus-art.el (gnus-blocked-images): New function. Allow the
+ `gnus-blocked-images' to be a function.
+ (gnus-article-wash-function): Remove.
+
+2010-10-20 Julien Danjou <julien@danjou.info>
+
+ * spam.el (spam-list-of-processors): Mark as obsolete.
+
+ * nnimap.el (nnimap-request-article): Fix BODYSTRUCTURE retrieval.
+ (nnimap-insert-partial-structure): Fix boundary detection.
+
+2010-10-20 Andreas Seltenreich <seltenreich@gmx.de>
+
+ * gnus-draft.el (gnus-draft-check-draft-articles): Don't unnecessarily
+ run file-truename on remote files. This can be expensive and even
+ prevent one from editing drafts if some unrelated buffer has a stale
+ connection.
+
+2010-10-20 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * shr.el (shr-find-fill-point): Shorten line if the preceding char is
+ kinsoku-eol regardless of shr-kinsoku-shorten.
+ (shr-tag-table-1): Rename from shr-tag-table; make it a subroutine.
+ (shr-tag-table): Support caption, thead, and tfoot.
+
+2010-10-19 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-find-fill-point): Don't leave blanks at the start of some
+ lines.
+ (shr-save-contents): New command and keystroke.
+
+ * nndoc.el (nndoc-type-alist): Add git support.
+ (nndoc-git-type-p): New function.
+ (nndoc-transform-git-article): Ditto.
+ (nndoc-transform-git-headers): Ditto.
+ (nndoc-transform-git-headers): Generate Subject headers.
+
+ * shr.el (shr-parse-style): New function.
+ (shr-tag-span): Ditto.
+
+ * nnmairix.el (nnmairix-summary-mode-hook): Move nnmairix's `$' command
+ to `G G' to avoid collisions.
+
+2010-10-19 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * shr.el: Load kinsoku if necessary.
+ (shr-kinsoku-shorten): New internal variable.
+ (shr-find-fill-point): Make kinsoku shorten text line if
+ shr-kinsoku-shorten is bound to non-nil.
+ (shr-tag-table): Bild shr-kinsoku-shorten to t; refer to
+ shr-indentation too when testing if table is wider than frame width.
+ (shr-insert-table): Use `string-width' instead of `length' to measure
+ text width.
+ (shr-insert-table-ruler): Make sure indentation is done at bol.
+
+2010-10-19 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * nnimap.el (nnimap-request-move-article, nnimap-parse-line)
+ (nnimap-process-expiry-targets): Use unibyte for buffers that hold
+ undecoded network data.
+
+2010-10-18 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-agent.el (gnus-agent-toggle-plugged): Use the right minor mode
+ name in the mode line spec so that the mode line menu works
+ (bug #2431).
+
+ * message.el (message-get-reply-headers): If we're fed `to-address',
+ then always use that.
+
+ * gnus-art.el (gnus-article-make-menu-bar): The article/group menus
+ aren't so wide as to need to switch off the edit menu.
+
+ * gnus-delay.el (gnus-delay-article): Remove superfluous `group'
+ binding. Suggested by Leo <sdl.web@gmail.com> (bug #6613).
+
+ * nnimap.el (nnimap-request-group): Don't SELECT the group twice on
+ `M-g'.
+ (nnimap-update-info): Update flags/read marks even if \* isn't part of
+ the permanent marks.
+
+2010-10-18 Andrew Cohen <cohen@andy.bu.edu>
+
+ * gnus-registry.el (gnus-registry-split-fancy-with-parent):
+ Splitting according to references/in-reply-to obeys the ignore-groups
+ variable, while splitting by sender and subject do not.
+
+2010-10-18 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-art.el (gnus-article-dumbquotes-map): Make into a char/string
+ alist, so that we can look for non-Unicode chars.
+ (article-translate-strings): Allow both character and string maps.
+
+2010-10-18 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * shr.el (shr-insert): Don't insert space behind a wide character
+ categorized as kinsoku-bol, or between characters both categorized as
+ nospace.
+
+2010-10-16 Andrew Cohen <cohen@andy.bu.edu>
+
+ * gnus-sum.el (gnus-summary-refer-thread): Bug fix. Add the thread
+ headers to gnus-newsgroup-headers.
+
+2010-10-16 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-tag-img): Don't align images -- since we're not
+ rescaling, this often leads to ugly displays.
+
+2010-10-15 Andrew Cohen <cohen@andy.bu.edu>
+
+ * gnus-sum.el (gnus-summary-refer-thread): Unconditionally ignore
+ duplicates.
+
+2010-10-15 Kan-Ru Chen <kanru@kanru.info> (tiny change)
+
+ * gnus-diary.el (gnus-diary-check-message): Fix gnus-completing-read
+ call.
+
+2010-10-15 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus.el: Autoload gnus-html-show-images.
+
+ * nnimap.el: Use nnheader-message throughout.
+
+ * shr.el (shr-tag-img): Ignore images with no data.
+
+2010-10-15 Julien Danjou <julien@danjou.info>
+
+ * mml.el (mml-generate-mime-1): Add `mml-enable-flowed' variable to add
+ a possibility to disable format=flow encoding when using hard newlines.
+
+2010-10-15 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * shr.el (shr-insert): Remove space inserted before or after a
+ breakable character or at the beginning or the end of a line.
+ (shr-find-fill-point): Do kinsoku; find the second best point or give
+ it up if there's no breakable point.
+
+2010-10-14 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-open-connection): Message when opening connection
+ for debugging purposes.
+
+ * gnus-art.el (gnus-article-setup-buffer): Set article mode truncation
+ on every setup buffer call to allow this to change from article to
+ article.
+
+ * shr.el (shr-tag-table): Experimental feature: Truncate lines in
+ buffers where we have a wide table.
+
+2010-10-14 Andrew Cohen <cohen@andy.bu.edu>
+
+ * gnus-sum.el (gnus-summary-refer-thread): Implement a version that
+ uses *-request-thread.
+
+2010-10-14 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-open-connection): Remove %s from openssl
+ incantation, which is no longer valid.
+
+2010-10-14 Julien Danjou <julien@danjou.info>
+
+ * shr.el: Fix defcustom type (char -> character).
+
+2010-10-14 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-open-connection): tls-program should be a list of
+ programs.
+
+2010-10-14 Julien Danjou <julien@danjou.info>
+
+ * shr.el (shr-tag-a): Use url-link as widget type.
+
+ * gnus-group.el (gnus-group-insert-group-line): Fix group argument to
+ `gnus-group-get-icon'.
+
+2010-10-13 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-close-server): Forget the nnimap data on close.
+ This should make server editing work better.
+
+ * shr.el (shr-find-fill-point): Don't inloop on indented text.
+
+ * nnimap.el (nnimap-open-connection): Fix open-tls-stream call.
+ (nnimap-parse-flags): Fix regexp.
+
+ * shr.el (shr-find-fill-point): Use a filling algorithm that should
+ probably work for CJVK text, too.
+
+ * nnimap.el (nnimap-extend-tls-programs): Remove.
+ (nnimap-open-connection): Bind STARTTLS to openssl explicitly.
+
+2010-10-13 Julien Danjou <julien@danjou.info>
+
+ * nnimap.el (nnimap-parse-flags): Be more strict when looking for FETCH
+ responses.
+
+2010-10-13 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * mm-decode.el (mm-shr): Allow use from non-Gnus users.
+
+ * gnus-spec.el (gnus-parse-simple-format): princ doesn't really insert
+ anything in Emacs.
+
+ * shr.el (shr-current-column): Remove buggy and unnecessary function.
+
+2010-10-13 Julien Danjou <julien@danjou.info>
+
+ * shr.el (shr-width): Make shr-width a defcustom with default to
+ fill-column.
+ (shr-tag-img): Use shr-width rather than fill-column.
+
+2010-10-13 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-dired.el (gnus-dired-attach): Silence XEmacs 21.5 when compiling.
+
+ * gnus-gravatar.el (gnus-gravatar-transform-address): Adjust avatars'
+ position when (X-)Faces exist.
+ (gnus-treat-from-gravatar, gnus-treat-mail-gravatar): Force displaying
+ avatars when called interactively.
+
+2010-10-12 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-gravatar.el (gnus-gravatar-too-ugly): Don't test if
+ gnus-article-x-face-too-ugly is bound.
+
+2010-10-12 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * rfc2231.el (rfc2231-parse-string): Ignore repeated parts.
+
+ * nnimap.el (nnimap-request-rename-group): Unselect by selecting a
+ mailbox that doesn't exist.
+
+2010-10-12 Julien Danjou <julien@danjou.info>
+
+ * shr.el (shr-tag-img): Encode URL properly when retrieving.
+ (shr-get-image-data): Encode URL properly when fetching from cache.
+ (shr-tag-img): Use aligned-to spaces to align correctly images.
+
+ * gnus-gravatar.el (gnus-gravatar-insert): Check if buffer is alive
+ before inserting the Gravatar.
+
+ * shr.el (shr-tag-img): Add align attribute support for <img>.
+
+2010-10-12 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-gravatar.el (gnus-art): Require.
+
+ * gnus-sum.el (gnus-summary-mark-as-unread-forward)
+ (gnus-summary-mark-as-unread-backward, gnus-summary-mark-as-unread):
+ Remove long obsoleted functions.
+
+2010-10-11 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * nnimap.el (gnutls-negotiate): Silence the byte compiler.
+
+ * gnus-art.el, gnus-cache.el, gnus-fun.el, gnus-group.el:
+ * gnus-picon.el, gnus-spec.el, gnus-sum.el, gnus-util.el, gnus.el:
+ * mail-source.el, message.el, mm-bodies.el, mm-decode.el, mm-extern.el:
+ * mm-util.el, mm-view.el, mml-smime.el, mml.el, mml1991.el, mml2015.el:
+ * nnfolder.el, nnheader.el, nnmail.el, nnmaildir.el, nnrss.el, nntp.el:
+ * rfc1843.el, sieve-manage.el, smime.el, spam.el:
+ Fix comment for declare-function.
+
+2010-10-11 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-request-rename-group): Select group read-only
+ before renaming it.
+
+ * shr.el (shr-insert): Fix up the white space only regexp.
+
+ * nnimap.el (nnimap-transform-split-mail): Not all articles have
+ bodies. Protect against this. Reported by Michael Welsh Duggan.
+
+ * shr.el (shr-current-column): New function.
+ (shr-find-fill-point): New function.
+
+2010-10-11 Michael Welsh Duggan <md5i@md5i.com> (tiny change)
+
+ * sieve-manage.el (sieve-manage-open): Allow port names as well as port
+ numbers.
+
+2010-10-11 Julien Danjou <julien@danjou.info>
+
+ * shr.el (shr-hr-line): Add.
+ (shr-tag-hr): Use shr-hr-line to specify which character to use to
+ display hr lines.
+ (shr-max-columns): Do not change state to nil if we just inserting
+ spaces.
+
+2010-10-11 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-topic.el (gnus-topic-read-group): If after the last group,
+ select the last group.
+
+2010-10-11 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * gnus-int.el (gnus-run-hook-with-args): Autoload from gnus-util.el.
+
+2010-10-10 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-update-qresync-info): \Flagged messages are read
+ for Gnus.
+ (nnimap-retrieve-group-data-early): utf7-encode the group parameters.
+ (nnimap-update-qresync-info): Mark \Seen articles as read.
+
+ * gnus-sum.el (gnus-summary-set-local-parameters): Ignore the `active'
+ non-variable, too.
+
+ * nnimap.el (nnimap-open-connection): Use gnutls STARTTLS, if
+ available.
+ (nnimap-update-info): Rely more on the current active than the param
+ active to avoid marking articles as read too much.
+
+ * auth-source.el (auth-source-create): Use (user-login-name) for the
+ user name default.
+
+ * nnimap.el (nnimap-update-info): If the server doesn't return any
+ useful info, just use the previous info.
+ (nnimap-update-info): Prefer old info over start-article.
+ (nnimap-update-qresync-info): Finish implementing QRESYNC.
+
+2010-10-10 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el (autoload): Clean up autoloads.
+ (nnir-imap-default-search-key): Rename from nnir-imap-search-field.
+ Use key rather than value.
+ (nnir-imap-search-other): New variable.
+ (nnir-read-parm): Use it.
+ (nnir-imap-expr-to-imap): Use %S rather than imap-quote-specials.
+ (gnus-summary-nnir-goto-thread): Modify to work with imap.
+
+2010-10-10 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * nnimap.el (nnimap-wait-for-response): If the user hits `C-g', kill
+ the process, too.
+
+2010-10-09 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * spam.el (gnus-summary-mode-map): Bind to "$".
+ Suggested by Russ Allbery.
+
+ * shr.el: Rework the way things are indented by <li> slightly.
+
+ * gnus.el (gnus-group-set-parameter): Fix typo.
+
+ * nnimap.el: Start implementing QRESYNC support.
+
+2010-10-09 Julien Danjou <julien@danjou.info>
+
+ * nnir.el (nnir-engines): Fix too many arguments.
+
+2010-10-09 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnmail.el (nnmail-expiry-target-group): Say that every expiry target
+ group is the "last", so that the backends like nnfolder actually save
+ their folders.
+
+ * nnimap.el (nnimap-open-connection): If we have gnutls loaded, then
+ try to use that for the tls stream.
+ (nnimap-retrieve-group-data-early): Rework the marks code to heed
+ UIDVALIDITY and find out which groups are read-only and not.
+ (nnimap-get-flags): Use the same marks parsing code as the rest of
+ nnimap.
+
+2010-10-09 Julien Danjou <julien@danjou.info>
+
+ * nnir.el (nnir-read-parm): Fix call to gnus-completing-read.
+
+ * gnus-gravatar.el (gnus-gravatar-transform-address): Error errors when
+ retrieving gravatars.
+
+ * shr.el (shr-table-corner): Add.
+ (shr-table-line): Add.
+ (shr-insert-table-ruler): Use the above defcustoms to insert tables.
+
+2010-10-08 Julien Danjou <julien@danjou.info>
+
+ * mm-decode.el (mm-text-html-renderer): Add mm-shr in choice list.
+
+2010-10-08 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * gnus-util.el (gnus-alist-pull): Rename `gnus-pull'.
+
+ * gnus-sum.el (gnus-mark-article-as-unread)
+ (gnus-summary-mark-article-as-unread, gnus-summary-remove-bookmark)
+ (gnus-summary-set-bookmark): Use it.
+
+ * gnus-msg.el (gnus-setup-message): Use it.
+
+ * gnus-demon.el (gnus-demon-remove-handler): Use it.
+
+ * gnus.el (gnus-group-remove-parameter): Use it.
+
+ * gnus-group.el (gnus-group-make-web-group): Use it.
+
+ * gnus-demon.el (gnus-demon-remove-handler): Use it.
+
+ * nnregistry.el: Update docs to mention manual.
+
+ * gnus-registry.el: Update docs to mention nnregistry.el.
+ (gnus-registry-initialize): Don't install nnregistry refer method
+ automatically.
+ (gnus-registry-install-nnregistry): Remove it.
+
+2010-10-08 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-insert): Don't insert double spaces.
+
+2010-10-08 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-gravatar.el (gnus-treat-from-gravatar)
+ (gnus-treat-mail-gravatar): Bind gnus-gravatar-too-ugly to nil when
+ called interactively.
+
+ * gnus-art.el (gnus-mime-view-part-externally)
+ (gnus-mime-view-part-internally): Make predicate function passed to
+ gnus-mime-view-part-as-type assume argument is a mime type, not a list
+ of a mime type.
+
+ * shr.el (shr-table-widths): Don't use cl function `reduce'.
+
+2010-10-07 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (require): Require cl when compiling.
+ (shr-tag-hr): New function.
+
+ * nnimap.el (nnimap-update-info): Remove double setting of high.
+ (nnimap-update-info): Don't ignore groups that have no UIDNEXT.
+ This makes nnimap work properly on Courier again.
+
+ * gnus.el (gnus-carpal): The carpal mode has been removed, but define
+ the variable for backwards compatability.
+
+ * mm-decode.el (mm-save-part): If given a non-directory result, expand
+ the file name before using to avoid setting mm-default-directory to
+ nil.
+
+ * gnus-start.el (gnus-get-unread-articles): Require gnus-agent before
+ bidning gnus-agent variables.
+
+ * shr.el (shr-render-td): Use a cache for the table rendering function
+ to avoid getting an exponential rendering behaviour in nested tables.
+ (shr-insert): Rework the line-breaking algorithm.
+ (shr-insert): Don't leave trailing spaces.
+ (shr-insert-table): Also insert empty TDs.
+ (shr-tag-blockquote): Ensure paragraphs after </ul>.
+
+2010-10-07 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * gnus-sum.el (gnus-number): Rename from `number'.
+ (gnus-article-marked-p, gnus-summary-limit-to-display-predicate)
+ (gnus-summary-limit-children): Update uses correspondingly.
+
+2010-10-07 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-gravatar.el (gnus-gravatar-too-ugly): New user option.
+ (gnus-gravatar-transform-address): Don't show avatars of people of
+ which mail addresses match gnus-gravatar-too-ugly.
+
+2010-10-07 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-table-widths): Expand TD elements to fill available
+ space.
+
+2010-10-07 Julien Danjou <julien@danjou.info>
+
+ * nnimap.el (nnimap-request-rename-group): Add this method.
+
+2010-10-07 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-html.el (gnus-html-schedule-image-fetching): Remove function
+ name from XEmacs' function-arglist.
+
+ * gnus-gravatar.el (gnus-gravatar-insert): Don't add properties to
+ gravatar under XEmacs.
+
+2010-10-07 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * auth-source.el: Update docs with TODO items.
+
+ * gnus-sync.el: Update docs to explain state and plans.
+
+ * gnus-int.el (gnus-after-set-mark-hook, gnus-before-update-mark-hook):
+ Hooks for mark updates.
+ (gnus-request-set-mark, gnus-request-update-mark): Use them.
+
+ * gnus-util.el (gnus-run-hooks-with-args): Convenience function to run
+ hooks with arguments, which is needed for mark update hooks.
+
+2010-10-06 Julien Danjou <julien@danjou.info>
+
+ * gnus.el (gnus-expand-group-parameter): Only return and act on what
+ was matched.
+
+ * sieve-manage.el: Update example in `Commentary'.
+
+ * sieve.el (sieve-open-server): Use sieve-manage-authenticate.
+
+ * sieve-manage.el (sieve-manage-open): Use sieve-manage-default-port,
+ not 2000.
+ (sieve-manage-authenticate): Re-add function.
+
+2010-10-06 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-insert): Get 'space transition right.
+ (shr-render-td): Only delete space at the end of the TD.
+
+ * nnimap.el (nnimap-open-connection): Prepare to support
+ open-gnutls-stream.
+
+ * shr.el: Rearrange function order to be more logical.
+
+2010-10-06 Julien Danjou <julien@danjou.info>
+
+ * nnrss.el (nnrss-check-group): Remove 404 URL in comment.
+ (nnrss-discover-feed): Remove 404 URL in docstring.
+
+ * nnir.el: Fix Swish-E URL.
+ Fix Namazu URL.
+
+ * message.el (message-change-subject): Remove 404 URL in a comment.
+
+2010-10-06 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-art.el (gnus-mime-view-part-as-type): Make it work when being
+ called interactively.
+
+ * gnus-util.el (gnus-remove-if): Allow hash table.
+ (gnus-remove-if-not): New function.
+
+ * gnus-art.el (gnus-mime-view-part-as-type)
+ * gnus-score.el (gnus-summary-score-effect)
+ * gnus-sum.el (gnus-read-move-group-name):
+ Replace remove-if-not with gnus-remove-if-not.
+
+ * gnus-group.el (gnus-group-completing-read):
+ Regard collection as a hash table if it is not a list.
+
+2010-10-05 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-render-td): Allow blank/missing <TD>s.
+
+ * shr.el: Document the table-rendering algorithm.
+
+ * gnus-html.el (gnus-html-schedule-image-fetching): Protect against
+ invalid URLs.
+
+ * shr.el (shr-tag-img): Shorten ALT texts and allow them to be
+ line-broken.
+ (shr-tag-img): Ignore image fetching errors.
+ (shr-overlays-in-region): Compute overlay positions correctly.
+
+ * mm-decode.el (mm-shr): Require shr.
+
+ * gnus-art.el (gnus-blocked-images): Move variable here.
+
+ * shr.el (shr-insert-table): Bind free variable.
+
+ * mm-decode.el (mm-shr): Bind shr-content-function.
+
+ * shr.el (shr-content-function): New variable.
+
+ * gnus-sum.el (gnus-article-sort-by-most-recent-date): New function,
+ added for symmetry.
+
+ * nnir.el (nnir-retrieve-headers): Don't bug out on invalid data.
+
+ * gnus-group.el (gnus-group-make-group): Doc fix.
+
+ * nnimap.el (nnimap-request-newgroups): Return success.
+
+ * shr.el (shr-find-elements): New function.
+ (shr-tag-table): Put all the images after the table.
+ (shr-tag-table): Really inhibit images inside the table.
+ (shr-collect-overlays): Copy over overlays from the TD elements to the
+ main document.
+
+ * mm-decode.el (mm-shr): Bind shr-blocked-images to
+ gnus-blocked-images.
+
+2010-10-05 Julien Danjou <julien@danjou.info>
+
+ * sieve-manage.el (sieve-sasl-auth): Use auth-source to authenticate.
+
+ * gnus-html.el (gnus-html-wash-images): Rescale image from cid too.
+ (gnus-html-maximum-image-size): Add this function.
+ (gnus-html-put-image): Use gnus-html-maximum-image-size.
+
+ * sieve-manage.el (sieve-manage-capability): Do not bug out when the
+ server-value of the capability is nil.
+
+2010-10-05 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-tag-em): Add <EM> tag.
+
+2010-10-05 Florian Ragwitz <rafl@debian.org> (tiny change)
+
+ * sieve-manage.el (sieve-manage-default-stream): Make default stream
+ customizable.
+
+ * gnus-html.el (gnus-html-wash-tags): Decode URL entities to avoid
+ handing broken links to browse-url.
+
+2010-10-05 Julien Danjou <julien@danjou.info>
+
+ * gnus-util.el (gnus-emacs-completing-read)
+ (gnus-iswitchb-completing-read): Use autoload rather than require.
+
+2010-10-05 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-util.el (gnus-completing-read-function): Exclude
+ gnus-icompleting-read and gnus-ido-completing-read from candidates for
+ XEmacs since iswitchb.el is very old and ido.el is unavailable in
+ XEmacs.
+
+ * gnus-registry.el (gnus-registry-install-nnregistry): Rewrite so as
+ not to use `delete-dups' that is unavailable in XEmacs 21.4.
+
+ * gnus-html.el: Don't require help-fns under XEmacs.
+ (gnus-html-schedule-image-fetching): Work for XEmacs.
+
+ * mm-decode.el (mm-shr): Decode contents by charset.
+
+2010-10-04 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-open-connection): Give an error if nnimap-stream is
+ unknown.
+
+ * shr.el (shr-tag-blockquote): Ensure paragraph after quote, too.
+ (shr-get-image-data): Ensure against the cache file missing.
+
+ * nnimap.el (nnimap-finish-retrieve-group-infos): Message while waiting
+ for data.
+
+ * spam-report.el (spam-report-url-ping-plain): Don't query about
+ killing the process.
+
+ * shr.el (shr-render-td): Protect against too-wide text.
+
+2010-10-04 Julien Danjou <julien@danjou.info>
+
+ * mml-smime.el (mml-smime-openssl-encrypt-query): Fix choices.
+ (mml-smime-openssl-sign-query): Fix gnus-completing-read call.
+
+ * gravatar.el (gravatar-retrieved): Kill buffer when gravatar has been
+ retrieved.
+
+2010-10-04 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (browse-url): Require.
+ (shr-ensure-paragraph): Don't insert a new newline after empty-ish
+ lines.
+ (shr-show-alt-text, shr-browse-image): New commands.
+ (shr-browse-url, shr-copy-url): New commands.
+
+ * gnus-sum.el (gnus-widen-article-window): New variable.
+ (gnus-summary-select-article-buffer): Use it.
+
+ * message.el (message-idna-to-ascii-rhs-1): Don't bug out on addresses
+ without @ signs.
+
+2010-10-04 Michael Welsh Duggan <md5i@md5i.com> (tiny change)
+
+ * nnir.el (nnir-run-imap): Remove spurious space in search string.
+
+2010-10-04 Julien Danjou <julien@danjou.info>
+
+ * gnus-util.el (gnus-emacs-completing-read): Mapcar collection to list,
+ for XEmacs.
+
+2010-10-04 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-salt.el: Remove all gnus-carpal stuff -- it's not useful.
+
+ * nnimap.el (nnimap-open-connection): Allow tls as a synonym for ssl.
+ (nnimap-close-server): Implement.
+
+ * shr.el (shr-ensure-paragraph): Fix the non-empty line case.
+ (shr-insert): Tweak line breaking.
+ (shr-insert): Handle <pre> better.
+ (shr-tag-li): Get <li> indentation right.
+ (shr-tag-li): Get <li> indentation even righter.
+ (shr-tag-blockquote): Ensure paragraph start.
+ (shr-make-table): Tweak table generation.
+ (shr-make-table): Fix typo.
+
+ * shr.el: Implement table rendering.
+
+2010-10-04 Julien Danjou <julien@danjou.info>
+
+ * gnus-html.el (gnus-html-put-image): Fix resize image code.
+
+2010-10-04 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-insert): Use string anchors instead of line anchors.
+
+2010-10-03 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el: Add headings.
+ (shr-ensure-paragraph): Actually work.
+ (shr-tag-li): Make <ul> prettier.
+ (shr-insert): Get white space at the beginning/end of elements right.
+ (shr-tag-p): Collapse subsequent <p>s.
+ (shr-ensure-paragraph): Don't insert double line feeds after blank
+ lines.
+ (shr-insert): \t is also space.
+ (shr-tag-s): Fix "s" tag name function.
+ (shr-tag-s): Fix face prop name.
+
+2010-10-03 Julien Danjou <julien@danjou.info>
+
+ * gnus-html.el (gnus-html-put-image): Use gnus-rescale-image.
+
+ * mm-view.el (gnus-window-inside-pixel-edges): Add autoload for
+ gnus-window-inside-pixel-edges.
+
+ * gnus-ems.el (gnus-window-inside-pixel-edges): Move from gnus-html to
+ gnus-ems.
+
+ * mm-view.el (mm-inline-image-emacs): Support image resizing.
+
+ * gnus-util.el (gnus-rescale-image): Add generic gnus-rescale-image
+ function.
+
+ * mm-decode.el (mm-inline-large-images): Enhance defcustom and add
+ resize choice.
+
+2010-10-03 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-tag-p): Don't insert newlines on empty tags at the
+ beginning of the buffer.
+
+ * gnus-sum.el (gnus-summary-select-article-buffer): Really select the
+ article buffer again.
+
+ * shr.el (shr-tag-p): Don't insert newlines at the start of the buffer.
+
+ * mm-decode.el (mm-shr): Narrow before inserting, so that shr can know
+ when it's at the start of the buffer.
+
+ * shr.el (shr-tag-blockquote): Convert name.
+ (shr-rescale-image): Use the right image-size variant.
+
+ * gnus-sum.el (gnus-summary-select-article-buffer): If the article
+ buffer isn't shown, then select the current article first instead of
+ bugging out.
+ (gnus-summary-select-article-buffer): Show both the article and summary
+ buffers again.
+
+ * shr.el (shr-fontize-cont): Protect against regions with no text.
+ Rename tag functions to shr-tag-* for enhanced security.
+ (shr-tag-ul, shr-tag-ol, shr-tag-li, shr-tag-br): New functions.
+
+2010-10-03 Chong Yidong <cyd@stupidchicken.com>
+
+ * shr.el (shr-insert):
+ * pop3.el (pop3-movemail):
+ * gnus-html.el (gnus-html-wash-tags): Don't use plusp, as cl may not be
+ loaded.
+
+2010-10-03 Glenn Morris <rgm@gnu.org>
+
+ * nnmairix.el (nnmairix-replace-illegal-chars): Drop Emacs 20 code.
+
+ * smime.el (smime-cert-by-ldap-1): Drop Emacs 21 code.
+
+ * gnus-art.el (gnus-next-page-map): Drop Emacs 20 compat cruft.
+
+ * gmm-utils.el (gmm-write-region): Drop Emacs 20 compat cruft.
+
+ * gnus-util.el (gnus-make-local-hook): Simplify.
+
+2010-10-02 Julien Danjou <julien@danjou.info>
+
+ * gnus-util.el (gnus-iswitchb-completing-read): New function.
+ (gnus-ido-completing-read): New function.
+ (gnus-emacs-completing-read): New function.
+ (gnus-completing-read): Use gnus-completing-read-function.
+ Add gnus-completing-read-function.
+
+2010-10-02 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el (shr-insert-document): Autoload.
+ (shr-img): Be silent.
+ (shr-insert): Add a newline after every picture before text.
+ (shr-add-font): Use overlays for combining faces.
+ (shr-insert): Pass upwards the text start point.
+
+ * mm-decode.el (mm-text-html-renderer): Default to shr.el rendering, if
+ possible.
+ (mm-shr): New function.
+
+2010-10-02 Julien Danjou <julien@danjou.info>
+
+ * gnus-gravatar.el (gnus-gravatar-insert): Adjust character where we
+ should go backward.
+
+2010-10-02 Juanma Barranquero <lekktu@gmail.com>
+
+ * shr.el (shr): Fix typo in provide call.
+
+2010-10-02 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * shr.el: New file.
+
+ * gnus-html.el (gnus-html-schedule-image-fetching): Be silent.
+
+ * gnus-topic.el (gnus-topic-move-group): Fix the syntax of the
+ completing read.
+
+2010-10-01 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-start.el (gnus-check-bogus-newsgroups): Say how many groups
+ we're being queried about. Suggested by Dan Jacobson.
+
+ * nndoc.el (nndoc-type-alist): Do babyl before mime-parts.
+ Suggested by Jason Eisner.
+
+ * gnus-async.el (gnus-async-delete-prefetched-entry): Remove from hash
+ table, too. Suggested by Stefan Wiens.
+ (gnus-async-prefetched-article-entry): Use intern-soft to avoid growing
+ the table unnecessary. Suggested by Stefan Wiens.
+
+ * gnus-sum.el (gnus-summary-clear-local-variables): This is probably no
+ longer needed, and probably doesn't work either, as pointed out by
+ Stefan Wiens.
+ (gnus-summary-exit): Remove call to the clearing function.
+ (gnus-summary-exit-no-update): Ditto.
+
+ * gnus-art.el (gnus-summary-save-in-file): Use with-current-buffer
+ instead of gnus-eval-in-buffer-window to avoid popping up frames.
+ Reported by Stefan Monnier.
+ (gnus-summary-save-in-rmail): Ditto.
+
+ * gnus-sum.el (gnus-summary-select-article-buffer): Show only the
+ article buffer, instead of both the article buffer and the summary
+ buffer. Sort of suggested by Dan Jacobson.
+
+ * gnus-win.el (gnus-buffer-configuration): Add an only-article spec.
+
+ * nnmbox.el (nnmbox-read-mbox): Mark buffer for deletion on Gnus exit.
+ Suggested by Dan Jacobson.
+
+ * mm-encode.el (mm-content-transfer-encoding-defaults): Try to make the
+ documentation clearer.
+
+ * message.el (message-shorten-references): Comment on the number "21".
+ Suggested by Stefan Monnier.
+
+ * gnus-sum.el (gnus-summary-scroll-up): Add more documentation.
+ Suggested by Dan Jacobson.
+
+ * gnus.el (gnus-large-newsgroup):
+ Mention gnus-large-ephemeral-newsgroup. Suggested by Dan Jacobson.
+
+ * gnus-msg.el (gnus-summary-resend-message): When resending, don't
+ externalize attachments. Bug reported by Steve Wen.
+
+ * gnus.el (gnus-continuum-version): Make inactive, since it doesn't
+ really message anything to the user.
+
+ * nnmail.el (nnmail-article-group): Allow using the fancy split method
+ directly.
+
+ * nnimap.el (nnimap-request-group): Low higher than high to signal no
+ messages in empty groups.
+
+2010-10-01 Ted Zlatanov <tzz@lifelogs.com>
+
+ * nnimap.el (nnimap-request-group): Don't bug out when there's an empty
+ non-UIDNEXT group.
+
+2010-10-01 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-group.el (gnus-group-completing-read): Return the symbol name,
+ not the value from the collection.
+
+ * nnimap.el (nnimap-update-info): Ignore groups that have no UIDNEXT
+ values. This sometimes happens on some groups that have no info.
+ (nnimap-request-newgroups): New function.
+
+2010-10-01 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * gnus-registry.el (gnus-registry-install-nnregistry): Move the feature
+ check into `gnus-registry-initialize'.
+ (gnus-registry-initialize): Ditto.
+ Fix and extend header docs.
+
+2010-10-01 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-html.el (gnus-html-prefetch-images): Adjust regexp to avoid
+ regexp backtrace overflows.
+
+ * nnimap.el (nnimap-extend-tls-programs): Only extend those programs
+ for starttls that tls.el implements; i.e. openssl.
+
+2010-10-01 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gravatar.el: Don't load image.el that XEmacs doesn't provide.
+ (gravatar-create-image): New function that's an alias to
+ gnus-xmas-create-image, gnus-create-image, or create-image.
+ (gravatar-data->image): Use it.
+
+2010-09-30 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * gnus-registry.el (gnus-registry-install-nnregistry): New function to
+ install the nnregistry refer method.
+ (gnus-registry-install-hooks): Use it.
+ (gnus-registry-unfollowed-groups): Add nnmairix to the default
+ unfollowed groups.
+
+2010-09-30 Jose A. Ortega Ruiz <jao@gnu.org> (tiny change)
+
+ * gnus-sum.el (gnus-summary-show-thread): Skip past invisible text when
+ expanding threads.
+
+2010-09-30 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnir.el: Use the server names without suffixes (bug #7009).
+
+ * nnimap.el (nnimap-open-connection): Reinstate the auto-upgrade from
+ unencrypted to STARTTLS, if possible.
+
+2010-09-30 Teemu Likonen <tlikonen@iki.fi> (tiny change)
+
+ * message.el (message-ignored-supersedes-headers): Strip Injection-*
+ headers before superseding.
+
+2010-09-30 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnrss.el (nnrss-use-local): Add documentation.
+
+ * nnimap.el (nnimap-extend-tls-programs): New function.
+ (nnimap-open-connection): Use tls.el exclusively, and not starttls.el.
+ (nnimap-wait-for-connection): Accept the greeting from the stupid
+ output from openssl s_client -starttls, too.
+
+ * nnimap.el (nnimap-find-article-by-message-id): Really return the
+ article number.
+ (nnimap-split-fancy): New variable.
+ (nnimap-split-incoming-mail): Use it.
+
+ * nntp.el (nntp-server-list-active-group): Document.
+
+ * nnimap.el (nnimap-find-article-by-message-id): Use EXAMINE instead of
+ SELECT to get the message-id.
+
+ * mail-source.el (mail-sources): Remove webmail support.
+ (defvar): Ditto.
+ (mail-source-fetcher-alist): Ditto.
+ (mail-source-fetch-webmail): Remove.
+
+ * webmail.el: Remove -- doesn't seem relevant any more.
+
+ * gnus.el: Fix up make-obsolete-variable declarations throughout.
+
+ * nnimap.el (nnimap-request-accept-article): Get the Message-ID without
+ the \r.
+
+2010-09-30 Julien Danjou <julien@danjou.info>
+
+ * gnus-agent.el (gnus-agent-add-group): Fix call to
+ gnus-completing-read.
+
+2010-09-29 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nndoc.el (nndoc-retrieve-groups): New function.
+
+ * nnimap.el (nnimap-split-incoming-mail): If nnimap-split-methods is
+ `default', use nnmail-split-methods.
+ (nnimap-request-article): Downcase the NILs so that they are nil.
+
+ * gnus-sum.el (gnus-valid-move-group-p): Make sure that `group' is a
+ symbol.
+
+ * nnimap.el (nnimap-open-connection): Revert the auto-network->starttls
+ code, since if the user has requested network, that's what they ought
+ to get.
+ (nnimap-request-set-mark): Erase the buffer before issuing commands.
+ (nnimap-split-rule): Mark as obsolete.
+
+ * pop3.el (pop3-send-streaming-command, pop3-stream-length):
+ New variable.
+
+ * nnimap.el (nnimap-insert-partial-structure): Get the type from the
+ correct slot, too.
+
+2010-09-29 Julien Danjou <julien@danjou.info>
+
+ * gnus.el (gnus-local-domain): Declare variable obsolete.
+
+ * gnus-util.el (gnus-icompleting-read): Require iswitchb.
+ Fix history computing.
+ (gnus-ido-completing-read): Require ido.
+
+2010-09-29 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-registry.el: Don't prompt on load, which makes it impossible to
+ build Gnus.
+
+ * nnimap.el (nnimap-insert-partial-structure): Be way more permissive
+ when interpreting the structures.
+ (nnimap-request-accept-article): Add \r\n to the lines to make this
+ work with Cyrus.
+
+ * nndraft.el (nndraft-request-expire-articles): Use the group name
+ instead if "nndraft". Fix found by Nils Ackermann.
+
+2010-09-29 Ludovic Courtes <ludo@gnu.org>
+
+ * nnregistry.el: Add.
+
+2010-09-29 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * nnmail.el (group, group-art-list, group-art):
+ Remove unneeded directives.
+
+2010-09-29 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * mm-util.el (mm-codepage-iso-8859-list, mm-charset-eval-alist)
+ (mm-mime-charset)
+ * rfc2047.el (rfc2047-syntax-table)
+ * utf7.el (utf7-utf-16-coding-system): Comment fix.
+
+ * nnrss.el (nnrss-read-server-data, nnrss-read-group-data): Use `load'
+ rather than `insert-file-contents' and `eval-region'.
+
+2010-09-29 Julien Danjou <julien@danjou.info>
+
+ * gnus-gravatar.el (gnus-gravatar-properties): Add this properties in
+ replacement of `gnus-gravatar-relief' to mimic
+ `gnus-faces-properties-alist'.
+ Add :version property.
+
+2010-09-28 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * mail-source.el (mail-source-report-new-mail)
+ * message.el (message-default-mail-headers)
+ * mm-decode.el (mm-valid-image-format-p): Comment fix.
+
+ * mml2015.el (mml2015-use): Don't bind recursive-load-depth-limit.
+
+2010-09-28 Julien Danjou <julien@danjou.info>
+
+ * gnus-gravatar.el (gnus-gravatar-insert): Fix search in case
+ mail-address contains the same string as real-name.
+
+ * gnus-ems.el (gnus-put-image): Revert Lars, change and insert
+ non-blank in header, otherwise it'll get stripped.
+
+ * gnus-gravatar.el (gnus-gravatar-insert): Search backward for
+ real-name, and then for mail address rather than doing : or , search.
+
+2010-09-27 Julien Danjou <julien@danjou.info>
+
+ * gnus-util.el (gnus-completing-read): Use gnus-use-ido to apply the
+ right completing-read function.
+ (gnus-use-ido): New variable
+ (gnus-completing-read-with-default): Remove.
+ * gnus-agent.el (gnus-agent-read-group): Remove prompt computing.
+ (gnus-agent-add-group):
+ * gnus-srvr.el (gnus-server-add-server, gnus-server-goto-server):
+ * mm-view.el (mm-view-pkcs7-decrypt):
+ * mm-util.el (mm-codepage-setup):
+ * smime.el (smime-sign-buffer, smime-decrypt-buffer):
+ * mml-smime.el (mml-smime-openssl-sign-query):
+ * mml.el (mml-minibuffer-read-type, mml-minibuffer-read-disposition)
+ (mml-insert-multipart):
+ * gnus-msg.el (gnus-summary-yank-message):
+ * gnus-int.el (gnus-start-news-server):
+ * mm-decode.el (mm-interactively-view-part):
+ * gnus-dired.el (gnus-dired-attach):
+ * gnus.el (gnus-read-method):
+ * gnus-bookmark.el (gnus-bookmark-jump):
+ * gnus-art.el (gnus-mime-view-part-as-type)
+ (gnus-mime-action-on-part, gnus-article-encrypt-body):
+ * gnus-topic.el (gnus-topic-jump-to-topic, gnus-topic-move-matching)
+ (gnus-topic-copy-matching, gnus-topic-sort-topics, gnus-topic-move):
+ * nnmairix.el (nnmairix-create-server-and-default-group)
+ (nnmairix-update-groups, nnmairix-get-server)
+ (nnmairix-backend-to-server, nnmairix-goto-original-article)
+ (nnmairix-get-group-from-file-path):
+ * nnrss.el (nnrss-find-rss-via-syndic8):
+ * gnus-group.el (gnus-group-completing-read, gnus-group-make-web-group)
+ (gnus-group-make-useful-group, gnus-group-add-to-virtual)
+ (gnus-group-browse-foreign-server):
+ * gnus-sum.el (gnus-summary-goto-article, gnus-summary-limit-to-extra)
+ (gnus-summary-execute-command, gnus-summary-respool-article)
+ (gnus-read-move-group-name):
+ * gnus-score.el (gnus-summary-increase-score)
+ (gnus-summary-score-effect):
+ * gnus-registry.el (gnus-registry-read-mark): Use gnus-completing-read.
+
+2010-09-28 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * nnimap.el (auth-source-forget-user-or-password)
+ (auth-source-user-or-password): Autoload.
+
+ * message.el (message-from-style, message-interactive)
+ (message-signature): Remove comment.
+ (message-cite-prefix-regexp): Default to mail-citation-prefix-regexp
+ always.
+ (message-sendmail-envelope-from): Comment fix.
+ (message-yank-prefix): Default to mail-yank-prefix always.
+ (message-indentation-spaces):
+ Default to mail-indentation-spaces always.
+ (message-signature-file): Default to mail-signature-file always.
+
+2010-09-27 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-sum.el (gnus-summary-read-group-1): Set gnus-newsgroup-highest.
+ (gnus-summary-insert-new-articles): Use gnus-newsgroup-highest to get
+ new articles.
+
+ * nnimap.el (nnimap-request-article): Don't partial-fetch single-part
+ parts.
+ (nnimap-request-article): Work with the t setting, too.
+
+ * gnus-sum.el (gnus-summary-exit): Kill the article buffer later, so
+ that you don't get flashes of other buffers.
+ (gnus-summary-show-complete-article): Intern before setting.
+
+2010-09-27 David Engster <dengste@eml.cc>
+
+ * nnmairix.el (nnmairix-replace-group-and-numbers): Deal with NOV as
+ well as HEADERS.
+ (nnmairix-retrieve-headers): Provide new argument for the above.
+
+2010-09-27 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-sum.el (gnus-summary-move-article): Don't alter
+ gnus-newsgroup-active. This makes `/ N' work after copying to the same
+ group.
+
+ * nnimap.el (nnimap-update-info): Don't destructively alter active.
+
+ * message.el (message-cite-prefix-regexp): Revert my last edit.
+
+ * gnus-sum.el (gnus-summary-show-complete-article): Bind the server
+ variable instead of the Gnus variable.
+
+ * nnimap.el (nnimap-find-wanted-parts-1): Use it.
+
+ * gnus-art.el (gnus-fetch-partial-articles): Move back to nnimap again.
+
+ * nnimap.el (nnimap-request-accept-article): Remove the "." at the end,
+ since some servers don't like it.
+ (nnimap-open-connection): Forget credentials if the server says the
+ password was wrong.
+ (nnimap-parse-line): Protect against invalid data.
+
+ * gnus-sum.el (gnus-summary-move-article): Add comment.
+ (gnus-summary-insert-new-articles): Copy the old-high watermark so that
+ nothing alters it while scanning for new messages.
+
+ * nnimap.el (nnimap-request-accept-article): Send a "." at the end,
+ which may or may not help.
+ (nnimap-open-connection): If we're doing a stream connection, and then
+ discover we're on a STARTTLS-capable server, then open a STARTTLS
+ connection instead.
+
+2010-09-27 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (utf7): Require.
+
+ * message.el (message-cite-prefix-regexp): Remove "}" from citation
+ prefix.
+
+2010-09-27 Juanma Barranquero <lekktu@gmail.com>
* nnmail.el (nnmail-fancy-expiry-targets): Fix typo in docstring.
-2010-09-21 Glenn Morris <rgm@gnu.org>
+2010-09-27 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-request-accept-article): Message the error on
+ error.
+
+2010-09-27 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-art.el (gnus-mime-delete-part): Fix Lisp type of byte(s).
+
+2010-09-26 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nndoc.el (nndoc-request-list): Return success always.
+
+ * gnus-agent.el (gnus-agent-retrieve-headers): Don't propagate
+ `fetch-old' -- we only want to fetch the articles we've requested.
+ The rest are in the agent, probably.
+ (gnus-agent-read-servers-validate): Change the level for the "Ignoring
+ disappeared server" to something low. It's not important.
+
+ * nnimap.el (nnimap-get-whole-article): Remove the data that may have
+ arrived before the FETCH data.
+
+ * nnmh.el (nnmh-request-expire-articles): Don't try to fetch the expiry
+ target here, because we don't know the Gnus name of the group.
+
+ * nndraft.el (nndraft-request-expire-articles): Fetch the expiry target
+ for the correct group.
+
+ * gnus-ems.el (gnus-create-image): Ignore all image-creation errors.
+
+ * gnus.el (gnus): Give a final warning after startup.
+
+ * gnus-util.el (gnus-action-message-log): New variable.
+ (gnus-message): Use it.
+ (gnus-final-warning): New function.
+
+ * nnimap.el (nnimap-open-connection): Record the greeting.
+ (nnimap): Add greeting.
+
+2010-09-26 Julien Danjou <julien@danjou.info>
+
+ * gnus-html.el (gnus-html-show-images): Fix gnus-html-display-image
+ arguments.
+ (gnus-html-wash-images): Fix spec computing to include start/end.
+
+ * gnus-art.el (gnus-article-treat-body-boundary): Fix length computing.
+
+2010-09-26 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-request-expire-articles): Compress ranges before
+ deletion.
+ (nnimap-retrieve-headers): Don't select the group, because that's
+ already done by nnimap-possibly-change-group.
+
+ * gnus-picon.el (gnus-picon-inhibit-top-level-domains): New variable.
+ (gnus-picon-transform-address): Use it.
+
+ * mail-source.el (mail-source-value): Revert previous patch.
+
+ * nnimap.el (nnimap-credentials): Allow inhibiting the password query
+ on failure.
+ (nnimap-open-connection): Look up both virtual and physical server name
+ credentials.
+
+ * gnus-win.el: Revert previous patch, since it made Gnus backtrace.
+
+2009-02-08 Dave Love <fx@gnu.org>
+
+ * gnus-win.el (gnus-window-to-buffer-helper)
+ (gnus-all-windows-visible-p): Function needn't be a symbol.
+
+ * mail-source.el (mail-source-value): Function needn't be a symbol.
+
+2010-09-26 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * message.el (message-cite-prefix-regexp): Remove } from the cite
+ prefix.
+
+ * gnus-art.el (gnus-treatment-function-alist): Do picons before
+ highlight again, so that the highlight is correct.
+
+ * gnus-picon.el (gnus-picon): Remove again.
+ (gnus-picon-create-glyph): Set the background XPM colour explicitly.
+
+ * gnus-art.el (gnus-treatment-function-alist): Insert picons after
+ doing the header highlightling, so that the background colour of the
+ picon is correct.
+
+ * gnus-picon.el (gnus-picon-xbm): Remove obsolete face.
+ (gnus-picon): Ditto.
+ (gnus-picon): Reinstate. The background colour for picons is white.
+ (gnus-picon-insert-glyph): Make the background white.
+
+ * nnml.el (nnml-open-nov): Don't return dead buffers.
+
+ * auth-source.el (auth-source-create): Query the user for whether to
+ store the credentials.
+
+ * auth-source.el (auth-source-user-or-password): Use the existing auth
+ sources, if any, for creation.
+
+ * gnus.el (gnus-group-fast-parameter): Return the last matching
+ parameter instead of the first matching parameter.
+
+2010-09-26 Julien Danjou <julien@danjou.info>
+
+ * gnus-sum.el (gnus-auto-center-group): Transform into a defcustom.
+
+2010-09-26 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * mml2015.el (mml2015-use): Remove gpg support.
+
+ * mml1991.el (mml1991-function-alist): Remove gpg function.
+ (mml1991-gpg-sign): Remove.
+
+2010-09-26 Andreas Seltenreich <seltenreich@gmx.de>
+
+ * gnus-srvr.el (gnus-browse-subscribe-newsgroup-method): New variable.
+ (gnus-browse-unsubscribe-current-group): Document it.
+ (gnus-browse-unsubscribe-group): Use it.
+
+2010-09-26 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-group.el (gnus-read-ephemeral-bug-group): Add the bug email
+ address to the To list for easier response.
+
+ * gnus.el (gnus-play-startup-jingle): Remove.
+ (gnus-splash): Don't play jingle.
+ (gnus): Silence gnus-load message.
+
+ * gnus-art.el (gnus-treat-play-sounds): Remove.
+
+ * gnus.el (gnus-play-jingle): Remove audio support.
+
+ * gnus-cus.el (gnus-score-customize): Remove audio reference.
+
+ * earcon.el: Remove -- no users.
+
+ * gnus-audio.el: Remove -- no users of this package.
+
+ * gnus-sum.el (gnus-summary-limit-children): Remove nocem support.
+
+ * gnus-start.el (gnus-setup-news): Remove nocem support.
+
+ * gnus-group.el (gnus-group-get-new-news): Remove nocem call.
+
+ * gnus.el (gnus-use-nocem): Remove.
+
+ * gnus-demon.el (gnus-demon-add-nocem, gnus-demon-scan-nocem):
+ Remove.
+
+ * gnus-nocem.el (gnus-nocem-issuers): Remove file. Apparently nobody
+ uses NoCeM any more.
+
+ * gnus-art.el (gnus-ctan-url): Seems not very useful -- removed.
+ (gnus-button-ctan-handler): Ditto.
+ (gnus-button-handle-ctan-bogus-regexp): Ditto.
+ (gnus-button-ctan-directory-regexp): Ditto.
+ (gnus-button-handle-ctan): Ditto.
+ (gnus-button-tex-level): Ditto.
+ (gnus-button-alist): Remove CTAN stuff.
+
+2010-09-25 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-wait-for-response): Reverse logic in the
+ nnimap-streaming test.
+
+ * gnus-start.el (gnus-get-unread-articles): Don't try to open failed
+ servers twice.
+
+ * nnimap.el (nnimap-open-connection): Add more error reporting when
+ nnimap fails early.
+
+ * nnheader.el (nnheader-get-report-string): New function.
+ (nnheader-get-report): Use it.
+
+ * gnus-int.el (gnus-check-server): Say what the error was when opening
+ failed.
+
+ * nnimap.el (nnimap-wait-for-response): Search further when we're not
+ using streaming.
+
+2010-09-25 Julien Danjou <julien@danjou.info>
+
+ * gnus-html.el (gnus-html-rescale-image): Use our defalias
+ gnus-window-inside-pixel-edges.
+
+2010-09-25 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-srvr.el (gnus-server-copy-server): Add documentation.
+
+ * mm-decode.el (mm-save-part): Allow saving to other directories the
+ normal Emacs way.
+
+ * nndoc.el (nndoc-type-alist): Move mime-parts after mbox.
+ Suggested by Jay Berkenbilt.
+
+ * gnus-art.el (gnus-mime-delete-part): Fix plural for "byte" when
+ there isn't a single byte.
+
+ * gnus-int.el (gnus-open-server): Don't query whether to go offline --
+ just do it. It doesn't really seem to matter what the user responds
+ here, I think, so it's just a confusing question.
+
+ * nnimap.el (nnimap-retrieve-group-data-early): Fix typo in the
+ non-streaming case.
+
+ * gnus-art.el (gnus-flush-original-article-buffer): Separate out.
+ (gnus-article-encrypt-body): Use it.
+
+ * gnus-sum.el (gnus-summary-show-complete-article): New command and
+ keystroke.
+
+ * nnimap.el (nnimap-find-wanted-parts-1):
+ Use gnus-fetch-partial-articles.
+
+ * gnus-art.el (gnus-fetch-partial-articles): New variable.
+
+ * nnimap.el (nnimap-insert-partial-structure): New function.
+ (nnimap-get-partial-article): New function.
+ (nnimap-request-article): Use it.
+ (nnimap-wait-for-response): Return whether the wait was successful.
+ (nnimap-finish-retrieve-group-infos): Don't do anything if the
+ retrieval wasn't successful.
+ (nnimap-retrieve-group-data-early): Allow throttling servers.
+ (nnimap-streaming): New variable.
+ (nnimap-fetch-partial-articles): Remove.
+
+ * mm-decode.el (mm-with-part): Protect against killed buffers.
+
+ * nndraft.el (nndraft-retrieve-headers): Insert Lines and Chars headers
+ for prettier summary display.
+
+2010-09-25 Andrew Cohen <cohen@andy.bu.edu> (tiny change)
+
+ * nnir.el (nnir-run-imap): Allow sending IMAP search patterns directly.
+
+2010-09-25 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus.el (gnus-local-domain): Put gnus-local-domain back again, since
+ apparently third-party libraries depend on it.
+
+ * nnimap.el (nnimap-open-connection): Wait for the response to STARTTLS
+ before starting negotiation.
+
+ * gnus-art.el (gnus-treat-from-gravatar): Change default to nil for
+ privacy reasons.
+ (gnus-treat-mail-gravatar): Ditto.
+
+ * gnus-ems.el (gnus-put-image): Don't put any non-blank text into the
+ buffer when inserting images. Inserting text into the headers, for
+ instance, can make them invalid.
+
+2010-09-25 Julien Danjou <julien@danjou.info>
+
+ * rfc1843.el: Remove useless rfc1843-old-gnus-decode-header-function
+ variables.
+
+ * nnheader.el: Remove useless variables news-reply-yank-from and
+ news-reply-yank-message-id.
+
+ * mml2015.el: Remove useless mc-default-scheme and mc-schemes
+ variables.
+
+ * mml1991.el: Remove useless mml1991-verbose.
+
+ * gnus.el: Remove useless variable gnus-use-generic-from.
+ Remove obsolete variable gnus-topic-indentation.
+
+ * gnus-uu.el: Remove useless gnus-uu-shar-file-name.
+
+ * gnus-sum.el: Remove useless gnus-newsgroup-none-id.
+
+ * gnus-picon.el: Remove useless gnus-picon-setup-p variable.
+
+ * gnus-group.el: Remove useless gnus-group-icon-cache.
+ Remove useless gnus-ephemeral-group-server.
+
+ * gnus-bookmark.el: Remove useless gnus-bookmark-after-jump-hook.
+
+ * mml2015.el: Remove useless mml2015-verbose.
+
+ * mml-smime.el: Remove useless mml-smime-verbose.
+
+ * gnus.el: Remove useless gnus-local-domain.
+
+ * gnus-gravatar.el (gnus-gravatar-transform-address):
+ Use gnus-gravatar-size.
+
+ * gnus-art.el: Remove useless gnus-treat-translate.
+
+2010-09-24 Julien Danjou <julien@danjou.info>
+
+ * gnus-sum.el: Add support for Gravatars.
+
+ * gnus-art.el: Add support for Gravatars.
+
+ * gnus-gravatar.el: Add this file.
+
+ * gravatar.el: Add this file.
+
+2010-09-24 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-sum.el (gnus-summary-fetch-faq): Remove.
+
+ * gnus-group.el (gnus-group-fetch-faq): Remove.
+
+ * gnus.el (gnus-group-faq-directory): Remove.
+
+ * gnus-group.el (gnus-group-fetch-charter): Remove.
+
+ * gnus.el (gnus-group-charter-alist): Remove.
+
+ * gnus-group.el (gnus-group-archive-directory): Remove.
+ (gnus-group-recent-archive-directory): Ditto.
+ (gnus-group-make-archive-group): Remove.
+
+ * nnimap.el (nnimap-update-info): Protect against nil uidnexts.
+
+ * gnus-cache.el (gnus-cache-braid-heads): When braiding heads, don't
+ use the same article number for all the cached articles.
+
+ * nnimap.el (nnimap-command): Register the last command time so
+ that we can use it for idling NOOPs.
+ (nnimap-open-connection): Start the keeplive timer.
+ (nnimap-make-process-buffer): Store all the process buffers.
+ (nnimap-keepalive): New function.
+
+ * starttls.el (starttls-open-stream): Add autoload cookie.
+
+2010-09-24 Michael Welsh Duggan <md5i@md5i.com> (tiny change)
+
+ * nnimap.el (nnimap-split-incoming-mail): Fix paren typo in the 'junk
+ handling.
+
+2010-09-24 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnrss.el (nnrss-retrieve-groups): Change to the group before checking
+ its data structures.
+
+ * gnus.el (gnus-sloppily-equal-method-parameters): Use copy-sequence
+ instead of the cl.el copy-list.
+ (gnus-sloppily-equal-method-parameters): Use equal instead of the cl
+ equalp.
+
+2010-09-24 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gmm-utils.el (gmm-tool-bar-from-list): Always use tool-bar-local-item
+ and tool-bar-local-item-from-menu.
+
+ * gnus-agent.el (gnus-agent-make-mode-line-string): Always use
+ mode-line-highlight face for Emacs.
+
+ * gnus-art.el (toplevel): Don't bind recursive-load-depth-limit while
+ loading gnus-sum.elc; fix comment for canlock-verify.
+ (gnus-article-jump-to-part): Use read-number.
+ (gnus-insert-mime-button, gnus-insert-mime-security-button):
+ Remove Emacs pre-21 compatible code for help-echo.
+ (gnus-article-next-page-1): No need to adjust the number of lines.
+ (gnus-article-describe-bindings): Always use help-buffer.
+
+ * gnus-audio.el (gnus-audio-inline-sound)
+ * gnus-cus.el (gnus-custom-mode)
+ * gnus-group.el (gnus-group-update-tool-bar): Comment fix.
+
+ * gnus-sum.el (gnus-remove-overlays): Doc fix.
+
+ * gnus-util.el (gnus-select-frame-set-input-focus): Remove Emacs 21
+ compatible code.
+
+2010-09-24 Glenn Morris <rgm@gnu.org>
* message.el (message-output): Use gnus-output-to-rmail if a buffer is
visiting the fcc file in rmail-mode.
+2010-09-24 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * nnir.el: Silence the byte compiler.
+
+ * gnus-html.el (gnus-html-encode-url-chars): New function, that's an
+ alias to browse-url-url-encode-chars if any.
+ (gnus-html-encode-url): Use it.
+
+2010-09-23 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-start.el (gnus-use-backend-marks): New variable.
+ (gnus-get-unread-articles-in-group): Use it.
+
+ * gnus-sum.el (gnus-summary-local-variables): Prepare for list/range
+ makeover.
+
+2010-09-23 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnimap.el (nnimap-retrieve-headers): Return 'headers.
+
+2010-09-23 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-start.el (gnus-fixup-nnimap-unread-after-getting-new-news):
+ Remove.
+ (gnus-setup-news-hook):
+ Remove gnus-fixup-nnimap-unread-after-getting-new-news.
+
+ * gnus-int.el (gnus-request-update-info): Protect against backends not
+ having the function.
+
+ * nnimap.el (nnimap-stream): Mention starttls.
+ (nnimap-open-connection): Add starttls support.
+
+2010-09-23 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el (nnir-run-imap): Fix up nnir to work with the new nnimap.
+
+2010-09-23 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-transform-headers): Don't bug out on invalid
+ BODYSTRUCTUREs.
+ (nnimap-transform-headers): Unfold quoted {42} headers.
+
+ * gnus-start.el (gnus-get-unread-articles): Allow backends to update
+ the info.
+ (gnus-get-unread-articles): Only call updatep on backends that support
+ it.
+
+ * nnweb.el (nnweb-request-update-info): NOOP.
+
+ * nnmaildir.el (nnmaildir-request-marks): Rename from -update-info.
+
+ * nnfolder.el (nnfolder-request-marks): Rename from -update-info,
+ since it only deals with marks.
+
+ * gnus-int.el (gnus-request-marks): Rename gnus-request-update-info to
+ gnus-request-marks, and make a new gnus-request-update-info.
+
+ * nnimap.el (nnimap-update-info): When UIDNEXT is present, use that for
+ the active instead of the high number, which is usually too low.
+
+2010-09-23 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * encrypt.el: Remove.
+
+2010-09-23 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-update-info): Sync non-standard flags from the
+ server in symbolic form.
+
+ * gnus-html.el (gnus-max-image-proportion): Increase proportion to 0.9.
+
+2010-09-22 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-parse-flags): Parse the data in any order.
+ (nnimap-update-info): Fix up code slightly.
+
+ * gnus-int.el (gnus-open-server): Add tracing for performance
+ debugging.
+
+ * gnus-group.el (gnus-group-highlight-line): Typo fix: beg, not start.
+ (gnus-group-insert-group-line): Pass the real group name so that it
+ gets the right data.
+
+ * gnus-start.el (gnus-get-unread-articles): Don't have
+ `gnus-get-unread-articles-in-group' update info, since that can be
+ really slow and doesn't seem to be needed?
+
+2010-09-22 Julien Danjou <julien@danjou.info>
+
+ * gnus-group.el (gnus-group-insert-group-line):
+ Call gnus-group-highlight-line.
+ (gnus-group-update-hook): Remove gnus-group-highlight-line from the
+ default hook list.
+ (gnus-group-update-eval-form): Add new function.
+ (gnus-group-highlight-line): Use gnus-group-update-eval-form.
+ (gnus-group-get-icon): Use gnus-group-update-eval-form.
+
+2010-09-22 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-request-expire-articles): If nnmail-expiry-wait is
+ immediate, then expire all articles.
+ (nnimap-update-info): Fix off-by-one errors.
+ (nnimap-flags-to-marks): Would return no marks lists for group with no
+ flags. Instead return the other data.
+
+2010-09-22 Julien Danjou <julien@danjou.info>
+
+ * gnus-group.el (gnus-group-get-icon): Rename gnus-group-add-icon that
+ Only return an icon.
+ (gnus-group-insert-group-line): Compute icon to return.
+
+ * gnus-html.el (gnus-html-image-automatic-caching): Add custom var.
+ (gnus-html-image-fetched): Only cache if
+ gnus-html-image-automatic-caching is set.
+ (gnus-html-image-fetched): Check for errors.
+
+2010-09-22 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-start.el (gnus-read-active-for-groups): Only run -request-scan
+ once per method on `g'. This ensures that backends like nnfolder don't
+ open all their folders.
+
+ * nnimap.el (nnimap-split-incoming-mail): Delete 'junk.
+ (nnimap-request-list): Nix out group in the correct buffer.
+ (nnimap-parse-flags): Implement by using `read' instead of
+ hand-parsing.
+ (nnimap-flags-to-marks): Pass on permanent-flags.
+ (nnimap-make-process-buffer): Record the server name.
+ (nnimap-parse-flags): Fix typo.
+ (nnimap-request-scan): Run split on the server in general, not just a
+ single group.
+
+ * nnmail.el (nnmail-split-incoming): Take an optional junk-func
+ parameter, and propagate this downwards.
+
+ * nnimap.el (nnimap-request-list): Set the current nnimap group to nil,
+ since EXAMINE changes it on the server.
+
+ * gnus-int.el (gnus-request-expire-articles): Inhibit the daemon, since
+ this command might take a while.
+
+2010-09-22 Julien Danjou <julien@danjou.info>
+
+ * gnus-html.el (gnus-html-put-image): Stop using markers. They are
+ harmful if you have 2 images side-by-side, they can't be properly
+ update on text deletion. Using text-property is safer here.
+ (gnus-html-image-fetched): Search also for \r\n\r\n to get the start of
+ data.
+
+2010-09-22 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-expunge-inbox): Remove.
+ (nnimap-mark-and-expunge-incoming): Use nnimap-expunge instead.
+ (nnimap-expunge): Flip default to t.
+
+ * gnus.el (gnus-method-to-server): Don't push things to the cache
+ unless it's unique.
+ (gnus-server-to-method): Ditto.
+
+2010-09-22 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * nnimap.el (nnimap-delete-article): Tell user if expunge won't happen.
+
+2010-09-22 Julien Danjou <julien@danjou.info>
+
+ * gnus-html.el (gnus-html-get-image-data): Search also for \r\n\r\n to
+ get the start of data.
+ (gnus-html-encode-url): Add this function to encode special chars in
+ URL.
+ (gnus-html-wash-images): Use gnus-html-encode-url to encode URL.
+ (gnus-html-prefetch-images): Use gnus-html-encode-url to encode URL.
+
+ * gnus-group.el (gnus-group-update-hook): Call gnus-group-add-icon by
+ default.
+ (gnus-group-add-icon): Move to gnus-group.el, and rewrite so it works.
+
+ * gnus-html.el (gnus-html-wash-images): Use xml-substitute-special on
+ images alt-text.
+ (gnus-html-put-image): Put alt-text as help-echo.
+
+2010-09-22 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * mailcap.el (mailcap-parse-mailcap, mailcap-parse-mimetypes)
+ * mm-util.el (mm-decompress-buffer)
+ * nnir.el (nnir-run-find-grep)
+ * pop3.el (pop3-list): Use 3rd arg of split-string.
+
+2010-09-21 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-sum.el (gnus-update-marks): Add sanity check to not delete marks
+ outside the active range. Suggested by Dan Christensen.
+
+ * gnus-start.el (gnus-get-unread-articles): Get the extended method
+ slightly later to avoid double-getting it.
+
+ * nnml.el (nnml-generate-nov-file): Fix variable name clobbering from
+ previous patch.
+
+ * gnus-sum.el (gnus-adjust-marked-articles): Fix another typo.
+
+2010-09-21 Adam Sjøgren <asjo@koldfront.dk>
+
+ * gnus-sum.el (gnus-adjust-marked-articles): Fix typo.
+
+2010-09-21 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-int.el (gnus-open-server): Give a better error message in the
+ "go offline" case.
+
+ * gnus-sum.el (gnus-adjust-marked-articles): Hack to avoid adjusting
+ marks for nnimap, which is seldom the right thing to do.
+
+ * gnus.el (gnus-sloppily-equal-method-parameters): Refactor out.
+ (gnus-same-method-different-name): New function.
+
+ * nnimap.el (parse-time): Require.
+
+ * gnus-start.el (gnus-get-unread-articles): Fix the prefixed select
+ method in the presence of many similar methods.
+
+ * nnmail.el (nnmail-expired-article-p): Fix typo: time-subtract.
+
+ * nnimap.el (nnimap-find-expired-articles): Don't refer to
+ nnml-inhibit-expiry.
+
+ * gnus-sum.el (gnus-summary-move-article): Use gnus-server-equal to
+ find out whether methods are equal.
+
+ * nnimap.el (nnimap-find-expired-articles): New function.
+ (nnimap-process-expiry-targets): New function.
+ (nnimap-request-move-article): Request the article before looking at
+ what the Message-ID is. Fix found by Andrew Cohen.
+ (nnimap-mark-and-expunge-incoming): Wait for the last sequence.
+
+ * nnmail.el (nnmail-expired-article-p): Allow returning the cutoff time
+ for oldness in addition to being a predicate.
+
+ * nnimap.el (nnimap-request-group): When we have zero articles, return
+ the right data to Gnus.
+ (nnimap-request-expire-articles): Only delete articles immediately if
+ the target is 'delete.
+
+ * gnus-sum.el (gnus-summary-move-article): When respooling to the same
+ method, this would bug out.
+
+ * gnus-group.el (gnus-group-expunge-group): Rename from
+ gnus-group-nnimap-expunge, and implemented as a normal interface
+ function.
+
+ * gnus-int.el (gnus-request-expunge-group): New function.
+
+ * nnimap.el (nnimap-request-create-group): Implement.
+ (nnimap-request-expunge-group): New function.
+
+2010-09-21 Julien Danjou <julien@danjou.info>
+
+ * gnus-html.el (gnus-html-image-cache-ttl): Add new variable.
+ (gnus-html-cache-expired): Add new function.
+ (gnus-html-wash-images): Use `gnus-html-cache-expired' to check
+ wethever we should display image for fetch it.
+ Compute alt-text earlier to pass it to the fetching function too.
+ (gnus-html-schedule-image-fetching): Change function argument to only
+ get one image at a time, not a list.
+ (gnus-html-image-fetched): Use `url-store-in-cache' to store image in
+ cache.
+ (gnus-html-get-image-data): New function to retrieve image data from
+ cache.
+ (gnus-html-put-image): Change buffer argument to use image data rather
+ than file, and place image above region rather than inserting a new
+ one. Do not take alt-text as argument, since it's useless now: we place
+ the image above alt-text.
+ (gnus-html-prune-cache): Remove.
+ (gnus-html-show-images): Start to fetch image when we find one, do not
+ push into a temporary list.
+ (gnus-html-prefetch-images): Only fetch image if they have expired.
+ (gnus-html-browse-image): Fix, use 'gnus-image-url.
+ (gnus-html-image-map): Add "v" to browse-url on undisplayed image.
+
+2010-09-20 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * rfc2047.el (rfc2047-encode-parameter): Doc fix.
+
+2010-09-20 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-group.el (gnus-group-line-format-alist): Have the ?U (unseen)
+ spec inser "*" if the group isn't active instead of 0.
+
+ * nnimap.el (nnimap-request-group): Don't select the imap buffer before
+ opening the server.
+ (nnimap-request-delete-group): Implement group deletion.
+ (nnimap-transform-headers): Return the size of the entire message in
+ the Bytes header, not just the size of the first part.
+ (nnimap-request-move-article): When moving an article from nnimap,
+ request the article first so the accepting form has an article to
+ accept. Reported by Dan Christensen.
+ (nnimap-command): Make sure that the error message doesn't error out.
+
+2010-09-20 David Edmondson <dme@dme.org> (tiny change)
+
+ * nnimap.el (nnimap-request-set-mark): Don't wait for a response when
+ we haven't requested anything.
+
+2010-09-20 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-fetch-inbox): Use "[]" as the parameter instead of
+ "". Fix found by Andrew Cohen.
+
+ * mail-parse.el (mail-header-encode-parameter): Use -encode-parameter
+ instead of -encode-string.
+
+2010-09-20 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-html.el (gnus-html-image-fetched): Pass arg to kill-buffer.
+
+ * gnus-sum.el (gnus-summary-update-mark): Replace subst-char-in-string
+ by mm-subst-char-in-string.
+
+2010-09-19 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-wait-for-connection): Avoid a race condition while
+ waiting for the connection string.
+
+ * gnus-html.el (gnus-html-image-fetched): Protect against the data not
+ arriving.
+
+ * gnus-start.el (gnus-ignored-newsgroups): Remove [] from the list of
+ bogus characters. This allows selecting certain Gmail groups.
+
+ * nnimap.el (nnimap-find-wanted-parts-1): New function.
+ (nnimap-fetch-partial-articles): New variable.
+ (nnimap-open-connection): When looking for credentials, also use the
+ nnimap-server-port.
+ (nnimap-request-article): Return the group/article number, so that Gnus
+ `^' works as expected.
+ (nnimap-find-wanted-parts-1): Return the MIME parts as IMAP wants them.
+
+ * gnus.el (gnus-similar-server-opened): Refactor a bit and add
+ comments.
+ (gnus-methods-sloppily-equal): New function.
+ (gnus): When using the development version of Gnus, load the gnus-load
+ file.
+
+ * gnus-start.el (gnus-get-unread-articles): Make sure that we call
+ `gnus-open-server' on each method before trying to scan them etc.
+ This ensures that all the backend parameters are set correctly.
+
+ * nnimap.el (nnimap-authenticator): New variable.
+ (nnimap-open-connection): Allow anonymous login.
+ (nnimap-transform-headers): The chars header is called Chars not Bytes.
+ (nnimap-wait-for-response): Don't infloop if the IMAP connection drops.
+
+ * gnus-art.el (gnus-article-describe-briefly): Fix up typo in last
+ patch, found by Knut Anders Hatlen.
+
+2010-09-19 Andreas Schwab <schwab@linux-m68k.org>
+
+ * gnus-agent.el (gnus-agent-batch-confirmation)
+ (gnus-agent-expire-group, gnus-agent-expire): Pass proper format string
+ to gnus-message.
+ * gnus-art.el (gnus-article-describe-briefly): Likewise.
+ * gnus-group.el (gnus-group-list-groups, gnus-group-describe-group)
+ (gnus-group-edit-global-kill, gnus-group-describe-briefly): Likewise.
+ * gnus-int.el (gnus-open-server): Likewise.
+ * gnus-score.el (gnus-score-edit-current-scores, gnus-score-edit-file)
+ (gnus-score-check-syntax): Likewise.
+ * gnus-srvr.el (gnus-browse-describe-briefly): Likewise.
+ * gnus-start.el (gnus-read-active-file-1, gnus-read-active-file-1):
+ Likewise.
+ * gnus-sum.el (gnus-summary-describe-briefly): Likewise.
+
+2010-09-19 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-html.el (gnus-html-prefetch-images): Fix up the url-retrieve
+ calling conventions so that prefetch doesn't bug out.
+
+2010-09-19 Julien Danjou <julien@danjou.info>
+
+ * gnus-sum.el (gnus-summary-update-mark): Use `subst-char-in-string'
+ rather than `subst-char-in-region' in order to be able to replace ASCII
+ char by UTF-8 ones.
+
+ * gnus-html.el (gnus-html-prefetch-images): Use `url-retrieve' rather
+ than curl.
+ (gnus-html-image-fetched): Fix `gnus-html-put-image' call not setting
+ the right URL and ALT text on images.
+ (gnus-html-wash-tags): Fix tag case.
+ Add support for `s' and `ins' tags. Use gnus-emphasis-* faces.
+ (gnus-article-html): Add -o display_ins_del=2 option.
+ (gnus-html-wash-tags): Add better support for <ul> tags symbols.
+
+2010-09-19 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnheader.el (nnheader-insert-nov): Protect against junk appearing in
+ the extra mail headers, which sometimes seem to happen for unknown
+ reasons.
+
+ * mail-parse.el (mail-header-encode-parameter): Define as
+ rfc2045-encode-string instead of as rfc2231-encode-string, since some
+ (or most, perhaps?) mail readers don't understand the latter, but do
+ understand the former.
+
+ * gnus-agent.el (gnus-agent-auto-agentize-methods): Switch the default
+ to nil, so that no methods are automatically agentized. I think this
+ is probably what most users want.
+
+ * gnus-html.el (gnus-html-schedule-image-fetching): Ignore all errors
+ from url-retrieve, for instance about invalid URLs.
+
+ * nnimap.el (nnimap-finish-retrieve-group-infos): Protect against
+ groups that have no articles.
+ (nnimap-request-article): Check that we really got an article when we
+ requested one.
+
+ * gnus-agent.el (gnus-agent-load-alist): Nix out the alist if the file
+ doesn't exist.
+
+ * nnimap.el (nnimap-finish-retrieve-group-infos): Return data in the
+ nntp buffer so the agent can save it.
+ (nnimap-open-shell-stream): Bind `process-connection-type' to nil, so
+ that CRLF doesn't get translated to \n.
+ (nnimap-open-connection): Don't make 'shell commands only send \n.
+
+2010-09-19 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * nnml.el (nnml-files): Add prefix to dynamic var `files'.
+ (nnml-generate-nov-databases-directory, nnml-generate-active-info):
+ Update var name.
+ (nnml-generate-nov-file): Use dolist.
+ (nnml-directory-articles, nnml-current-group-article-to-file-alist):
+ Use with-current-buffer.
+
+2010-09-18 Julien Danjou <julien@danjou.info>
+
+ * gnus-html.el (gnus-html-schedule-image-fetching): Fetch all images in
+ parallel.
+
+2010-09-18 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-update-info): When doing partial marks update, get
+ the range update right.
+ (nnimap-request-group): Don't make `M-g' bug out on group with no
+ marks.
+ (nnoo): Require, so that other packages can require nnimap.
+ (nnimap-wait-for-response): Be a bit more lax in finding the end of the
+ command we're looking for. This helps when the server sends more
+ responses after we've gotten everything we expected.
+ (nnimap): Add a `newlinep' field to keep track of end-of-line
+ conventions.
+ Don't send CRLF to things that don't want it.
+ (nnimap-request-accept-article): Ditto.
+
+2010-09-18 Julien Danjou <julien@danjou.info>
+
+ * gnus-html.el (gnus-html-schedule-image-fetching): Use `url' rather
+ than curl to retrieve images.
+
+2010-09-18 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-update-info): Extend the info so that we can set
+ the marks.
+ (nnimap-open-connection): Fix typo -- should be 'shell, not 'stream.
+ (nnimap-wait-for-connection): New function.
+ (nnimap-open-connection): If we have PREAUTH, don't query for login
+ credentials.
+ (nnimap-update-info): Fix off-by-one error when concatenating ranges
+ when doing a partial update.
+
+2010-09-18 Julien Danjou <julien@danjou.info>
+
+ * gnus-html.el (gnus-html-wash-tags): Add support for i, b and u HTML
+ tags.
+
+2010-09-18 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-credentials): New function.
+ (nnimap-open-connection): Use the new function to look for credentials
+ also on the numeric equivalents of "imap" and "imaps".
+
+ * gnus-start.el (gnus-activate-group): Send the info to
+ gnus-request-group.
+
+ * nnimap.el (nnimap-request-group): Have the "check" version of the
+ function parse flags and update the info, so that a `M-g' get a total
+ resync of all flags from the group.
+
+ * gnus-int.el (gnus-request-group): Take an optional `info' parameter
+ to allow backends to alter the info on group selection. Also alter all
+ the backend -request-group functions to take the parameter.
+
+ * nnimap.el (nnimap-store-info): New function.
+ (nnimap-update-info): Store the info for later usage.
+ (nnimap-request-group): Use the stored info for the dont-check case, so
+ that we don't retrieve all marks when we enter a group.
+
+ * nnimap.el: Use deffoo instead of defun for interface functions.
+
+ * gnus-start.el (gnus-get-unread-articles): Allow the backends to
+ update the group info. This makes the nndraft groups, for instance, go
+ back to their old behaviour.
+
+ * gnus-sum.el (gnus-select-newsgroup): Indent.
+
+ * nnimap.el (nnimap-possibly-change-group): Return nil if we can't log
+ in.
+ (nnimap-finish-retrieve-group-infos): Make sure we're not waiting for
+ nothing.
+
+ * gnus-start.el (gnus-get-unread-articles): Don't try to scan groups
+ from methods that are denied.
+
+ * gnus-int.el (gnus-method-denied-p): New function.
+
+ * nnimap.el (nnimap-open-connection): Use auth-sources to query and
+ store the password instead of netrc.
+ (nnimap-open-connection): Don't error out when we can't make a
+ connections.
+
+ * auth-source.el (auth-source-create): In the password prompt, say what
+ we're querying for. Also prompt for user name if that hasn't been
+ given.
+
+ * nnimap.el (nnimap-with-process-buffer): Remove.
+
+2010-09-17 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-start.el (gnus-read-active-for-groups): Don't use the "finish"
+ method when we're reading from the agent.
+
+ * nnagent.el (nnagent-retrieve-group-data-early): New dummy method.
+
+ * auth-source.el (auth-sources): Add ~/.authinfo to the default, since
+ that's probably most useful for users.
+
+ * gnus-int.el (gnus-check-server): Save result so that it doesn't say
+ "failed" all the time.
+
+ * gnus.el: Throughout all files, replace (save-excursion (set-buffer
+ ...)) with (with-current-buffer ... ).
+
+ * nntp.el (nntp-open-server): Return whether the open was successful or
+ not.
+
+ * gnus-sum.el (gnus-summary-first-subject): Have `unseen-or-unread'
+ select an unread unseen article first.
+
+ * nnimap.el (nnimap-open-connection): If the user doesn't have a
+ /etc/services, supply some sensible port defaults.
+
+2010-09-17 Julien Danjou <julien@danjou.info>
+
+ * mm-decode.el (mm-text-html-renderer): Document gnus-article-html.
+
+2010-09-17 Knut Anders Hatlen <kahatlen@gmail.com> (tiny change)
+
+ * nnimap.el (nnimap-get-groups): Don't bug out if the LIST command
+ doesn't have any parameters.
+
+2010-09-17 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-open-connection): Upcase all capabilities, and use
+ only upcased checks.
+
+ * nnmail.el (nnmail-article-group): Fix typo in "bogus" section.
+
+ * nnimap.el (nnimap-open-shell-stream): New function.
+ (nnimap-open-connection): Use it.
+ (nnimap-transform-headers): Get the number of lines in each message.
+ (nnimap-retrieve-headers): Query for BODYSTRUCTURE so that we get the
+ number of lines.
+ (nnimap-request-list): Not all servers return UIDNEXT. Work past this
+ problem.
+
+ * utf7.el (utf7-encode): Autoload.
+
+ * nnmail.el (nnmail-inhibit-default-split-group): New internal variable
+ to allow the mail splitting to not return a default group. This is
+ useful for nnimap, which will leave unmatched mail in the inbox.
+
+ * nnimap.el: Rewritten.
+
+ * gnus.el (gnus-article-special-mark-lists): Add uid/active tuples, for
+ nnimap usage.
+
+ * gnus-sum.el (gnus-summary-move-article): Pass the move-to group name
+ if the move is internal, so that nnimap can do fast internal moves.
+
+ * gnus-start.el (gnus-get-unread-articles): Support early retrieval of
+ data.
+ (gnus-read-active-for-groups): Support finishing the early retrieval of
+ data.
+
+ * gnus-range.el (gnus-range-nconcat): New function.
+
+ * gnus-int.el (gnus-finish-retrieve-group-infos)
+ (gnus-retrieve-group-data-early): New functions.
+
+2010-09-17 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * nnrss.el (nnrss-retrieve-headers, nnrss-request-list-newsgroups)
+ (nnrss-retrieve-groups):
+ * pop3.el (pop3-open-server, pop3-read-response, pop3-list, pop3-retr)
+ (pop3-quit): Use with-current-buffer.
+
+2010-09-17 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * pop3.el (pop3-wait-for-messages): Use pop3-accept-process-output
+ instead of nnheader-accept-process-output.
+
+ * gnus-html.el (gnus-html-schedule-image-fetching)
+ (gnus-html-prefetch-images): Replace process-kill-without-query by
+ gnus-set-process-query-on-exit-flag.
+
+2010-09-16 Romain Francoise <romain@orebokech.com>
+
+ * gnus-html.el: Require gnus-art for `gnus-with-article-buffer'.
+
+2010-09-14 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-registry.el (gnus-registry-install-shortcuts): The second
+ parameter to unintern is mandatory-ish in Emacs 24.
+
+ * gnus-html.el (gnus-html-schedule-image-fetching)
+ (gnus-html-prefetch-images): Check for curl before using it.
+
+ * mm-decode.el (mm-text-html-renderer): Don't have gnus-article-html
+ depend on curl, which isn't essential.
+
+ * imap.el: Revert back to version
+ cb950ed8ff3e0f40dac437a51b269166f9ffb60d, since some of the changes
+ seem problematic.
+
+2010-09-14 Juanma Barranquero <lekktu@gmail.com>
+
+ * gnus-registry.el (gnus-registry-install-shortcuts):
+ Explicitly pass `obarray' to `unintern' to avoid a warning.
+
+2010-09-14 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-start.el (gnus-read-active-for-groups): Revert the previous
+ change.
+
+ * nnrss.el (nnrss-request-list): Remove this function and related
+ functions, including the moreover stuff.
+
+2010-09-14 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnrss.el (nnrss-retrieve-groups): New function.
+
+2010-09-14 Juanma Barranquero <lekktu@gmail.com>
+
+ * .dir-locals.el: Add no-byte-compile cookie.
+
+2010-09-14 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-start.el (gnus-read-active-for-groups): Run gnus-activate-group
+ for back end that doesn't support request-scan.
+
+2010-09-10 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-start.el (gnus-read-active-file-1): If gnus-agent isn't set,
+ then do request scans from the backends.
+
+ * gnus-sum.el (gnus-summary-update-hook): Change default to nil, to
+ avoid running a hook per line, since this takes a lot of time,
+ profiling shows.
+ (gnus-summary-prepare-threads): Call `gnus-summary-highlight-line'
+ directly if gnus-visual-p is true.
+
+2010-09-10 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-start.el (gnus-read-active-for-groups): Check only subscribed
+ groups; replace mapcar with dolist which is a bit faster; pass groups
+ info to gnus-read-active-file-1.
+ (gnus-read-active-file-1): Scan only specified groups if the new
+ optional arg `infos' is given.
+
+2010-09-09 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * mail-source.el (mail-source-fetch-pop): Use pop3-movemail again.
+
+ * pop3.el (pop3-movemail): Remove.
+ (pop3-streaming-movemail): Rename to pop3-movemail.
+
+ * gnus-html.el (gnus-html-wash-tags): Refactor out the image bit, and
+ don't restrict end-tag searches to the end of the line.
+
+2010-09-09 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-start.el (gnus-get-unread-articles): Set the number of unread
+ articles of every unchecked group to t, which means unknown since the
+ server has never been opened.
+
+2010-09-08 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-html.el (gnus-html-show-alt-text): New command.
+ (gnus-html-browse-image): Ditto.
+ (gnus-html-wash-tags): Add the data to allow showing the ALT text and
+ to browse the image directly.
+ (gnus-html-wash-tags): Search for images first, so that <a><img> works
+ better.
+
+ * gnus-async.el (gnus-async-article-callback):
+ Call `gnus-html-prefetch-images' unconditionally.
+
+ * gnus-html.el (gnus-html-schedule-image-fetching): Decode entities
+ before feeding URLs to curl.
+
+2010-09-07 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-html.el (gnus-html-wash-tags, gnus-html-put-image): Mark cid and
+ internal images as deletable by `W D D'.
+
+ * gnus-async.el (gnus-html-prefetch-images): Autoload it when compiling.
+ (gnus-async-article-callback): Fix typo.
+
+2010-09-06 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-html.el (gnus-html-wash-tags): Limit end-tag matching to the
+ current line to work around bugs in the output from w3m.
+
+ * gnus-async.el (gnus-async-article-callback): Always prefetch images
+ for groups that want that.
+
+ * nntp.el (nntp-wait-for-string): Supply a timeout for
+ accept-process-output to ensure progress.
+
+ * gnus-start.el (gnus-get-unread-articles): If being given an explicit
+ level to get unread articles from, then use that for foreign groups,
+ too.
+
+ * gnus-html.el (gnus-html-wash-tags): Remove <a name...> tags, which
+ confuses the rest of the function.
+
+ * gnus-start.el (gnus-read-active-for-groups): Do a `gnus-request-scan'
+ for the methods that support -retrieve-groups, too.
+
+ * nnml.el (nnml-save-nov): Remove some debugging-related messages.
+
+2010-09-06 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * pop3.el: Require cl when compiling.
+ (pop3-number-of-responses): Search for "+OK", not "+OK ".
+
+2010-09-05 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-start.el (gnus-get-unread-articles): Don't bother with groups
+ that aren't going to be activated.
+ (gnus-get-unread-articles): Fix up the last commit.
+
+ * gnus-html.el (gnus-article-html): Allow calling without specifying
+ the handle. In that case, dissect the buffer first.
+
+ * gnus-sum.el (gnus-set-mode-line): Don't pad the mode line string.
+
+ * nnimap.el (nnimap-open-connection): Revert the change that would look
+ into authinfo for imaps instead of imap.
+
+ * gnus-start.el (gnus-activate-group): Take an optional parameter to
+ say that you don't want to call gnus-request-group with don-check, but
+ do check the reponse. This is for virtual groups only.
+ (gnus-get-unread-articles): Count the archive groups as secondary, so
+ that they're activated the same way as before.
+
+ * nnimap.el (nnimap-request-list): Servers may return \NoSelect
+ case-insensitively.
+ (nnimap-debug): Remove.
+
+ * mail-source.el (mail-source-fetch): Don't message if we're fetching
+ mail from a file, and the file doesn't exist.
+
+ * pop3.el (pop3-streaming-movemail): Return t for success.
+
+ * nnimap.el (nnimap-open-connection): Look for the "imaps" entry in the
+ .authinfo if we're using ssl connection.
+
+ * nnvirtual.el (nnvirtual-create-mapping): Use the active info we
+ already have if we're in a main Gnus `g' run.
+
+ * gnus-start.el (gnus-method-rank): Get info for virtual groups last.
+
+2010-09-05 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-start.el (gnus-method-rank): Replace equalp with equal.
+
+ * nnmh.el (nnmh-request-list-1): Bind `file'.
+
+ * pop3.el (pop3-set-process-query-on-exit-flag): New function that's an
+ alias to set-process-query-on-exit-flag or process-kill-without-query.
+ (pop3-open-server): Use it.
+
+2010-09-04 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * mail-source.el (mail-source-delete-crash-box): Always move the crash
+ box to the Incoming file. Fixes mistake in previous checkin.
+
+ * pop3.el (pop3-send-streaming-command): Off-by-one error on the
+ request loop (for debugging purposes) removed.
+
+ * nnml.el (nnml-save-nov): Message around nnml-save-nov so that the
+ culprit is more visible.
+ (nnml-save-incremental-nov, nnml-open-incremental-nov)
+ (nnml-add-incremental-nov): New functions to do "incremental" nov
+ updates, where we just append to the end of the existing nov files
+ without reading/writing them in full.
+
+ * mail-source.el (mail-source-delete-crash-box): Really only check the
+ incoming files once in a while.
+
+ * pop3.el (pop3-streaming-movemail): Always close the pop3 connection.
+
+ * mail-source.el (mail-source-delete-crash-box): Only check the
+ incoming files for deletion once per day to save a lot of file
+ accesses.
+
+ * pop3.el (pop3-logon): Fix up unbound variable typo.
+
+ * mail-source.el (pop3-streaming-movemail): Autoload.
+
+ * pop3.el (pop3-streaming-movemail):
+ Respect pop3-leave-mail-on-server.
+
+ * mail-source.el (mail-source-fetch-pop): Use streaming pop3
+ retrieval.
+
+ * pop3.el (pop3-process-filter): Remove unused function.
+ (pop3-streaming-movemail, pop3-send-streaming-command)
+ (pop3-wait-for-messages, pop3-write-to-file)
+ (pop3-number-of-responses): New functions for streaming pop3
+ retrieval.
+
+ * gnus-start.el (gnus-get-unread-articles): Protect against groups that
+ come from no known methods.
+ (gnus-make-hashtable-from-newsrc-alist): Remove duplicates from .newsrc
+ list.
+
+ * pop3.el (pop3-display-message-size-flag): Remove -- everybody wants
+ message sizes.
+ (pop3-movemail): Use erase-buffer instead of looping and deleting
+ regions, which seems rather odd.
+
+ * gnus-agent.el (gnus-agent-load-local): Only read the agent.lib/local
+ file once per `g' run.
+
+ * nnmh.el (nnmh-request-list-1): Output active lines also for empty
+ directories. This makes the draft queue directory work.
+
+ * gnus-start.el (gnus-get-unread-articles): Rewrite the way we request
+ data from the backends, so that we only request the list of groups from
+ each method once. This should speed things up considerably.
+
+ * nnvirtual.el (nnvirtual-request-list): Remove function so that we can
+ detect that it's not implemented.
+
+ * nnmh.el (nnmh-request-list-1): Fix up the recursion behavior so that
+ we actually do recurse down into the tree, but don't stat all leaf
+ nodes.
+
+ * gnus-html.el (gnus-html-show-images): If there are no images to show,
+ then say so instead of bugging out.
+
+ * gnus-agent.el (gnus-agent-load-alist): Check whether the agentview
+ files exist before trying to read them.
+
+ * gnus-html.el (gnus-html-wash-tags): Remove even more white space
+ around <pre_int>.
+
+ * gnus-art.el (gnus-article-copy-string): Say what data we copied.
+
+ * nnmh.el (nnmh-request-list-1): Optimize for speed.
+
+2010-09-03 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * mm-util.el (mm-image-load-path): Just return the image directories,
+ not all directories in the path in addition to the image directories.
+ (mm-image-load-path): Maintain a cache of the image directories so that
+ the `g' command in Gnus doesn't have to stat dozens of directories each
+ time.
+
+ * gnus-html.el (gnus-html-put-image): Allow images to be removed.
+ (gnus-html-wash-tags): Add a new `i' command to insert images.
+ (gnus-html-insert-image): New command and keystroke.
+ (gnus-html-redisplay-with-images): New command and keystroke.
+ (gnus-html-show-images): Rename command.
+ (gnus-html-wash-tags): Remove more white space before <pre_int> image
+ spacers.
+ (gnus-html-wash-tags): Decode entities at the end, so that entities
+ inside the tags don't mess up the rest of the "parsing".
+
+ * gnus-agent.el (gnus-agent-auto-agentize-methods): Change the default
+ so that nnimap methods aren't agentized by default. There's apparently
+ many problems related to agent/imap behaviour.
+
+ * gnus-art.el (gnus-article-copy-string): New command and key binding.
+
+ * gnus-html.el: Doc fix.
+
+2010-09-03 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-html.el (gnus-html-put-image): Use gnus-graphic-display-p,
+ glyph-width and glyph-height instead of display-graphic-p and
+ image-size; make avoidance of displaying small images work for XEmacs.
+
+ * gnus-util.el (gnus-graphic-display-p): Use device-on-window-system-p
+ for XEmacs.
+
+ * gnus-ems.el (gnus-set-process-plist, gnus-process-plist): Change name
+ of symbol that holds plist data.
+ (gnus-process-plist): Remove plist of process after getting it.
+
+2010-09-02 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * message.el (message-generate-hashcash): Change default to
+ 'opportunistic if hashcash is installed.
+
+ * gnus-html.el (gnus-html-rescale-image): Fix up typo in rescaling.
+ (gnus-html-put-image): Only call image-size once, since it's somewhat
+ time-consuming on remote X servers.
+
+2010-09-02 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-html.el (gnus-article-html): Make work buffer multibyte for
+ decoded contents.
+ (gnus-html-put-image, gnus-html-rescale-image): Pass `file' argument.
+
+2010-09-02 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-group.el (gnus-group-line-format): Remove %O (moderated) from
+ group line format, since it isn't very interesting.
+
+ * gnus-agent.el (gnus-agent-short-article),
+ (gnus-agent-long-article): Increase values for these two variables,
+ since most people are likely to have more network connection and
+ storage than before.
+
+ * gnus.el (gnus-refer-article-method): Change default to 'current.
+ When referring an article, the common behaviour is to refer it from the
+ current select method, not the native select method. The chances of
+ the native select method having the message in question is rather slim
+ these days.
+
+ * gnus-sum.el (gnus-auto-select-subject): Change default to
+ `unseen-or-unread'. I think it's likely that most people want to
+ select an unseen article over a previously seen, but unread one.
+
+ * gnus.el (gnus-mode-non-string-length): Change default to 30. nil
+ means that in the article buffer none of the minor mode elements will
+ be shown, usually, and this is not desirable in most cases.
+
+ * gnus-sum.el (gnus-summary-goto-unread): Change default to nil, so
+ that commands like `d' (and the like) go to the next line in the
+ buffer, instead of the next unread article. I think this is the
+ behaviour that is most natural for most users.
+ (gnus-single-article-buffer): Change default to nil, so that people can
+ have as many article buffers open as they have summary buffer. I think
+ this is the most natural way for the groups to behave.
+
+ * message.el (message-generate-new-buffers): Change default to
+ `unsent', so that all new message buffers start their names with the
+ string "*unsent", and it's easier to find the buffers if you move from
+ them.
+
+2010-09-01 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-html.el (gnus-html-wash-tags): Don't show images that are really
+ small. They're probably tracking images.
+ (gnus-html-wash-tags): Remove all <pre_int> place holders.
+ (gnus-html-rescale-image): Yet another try at getting the image sizing
+ right.
+
+ * nntp.el (nntp-request-set-mark): Refuse to do marks if
+ nntp-marks-file-name is nil.
+
+2010-09-01 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * gnus-html.el (gnus-html-wash-tags)
+ (gnus-html-schedule-image-fetching, gnus-html-image-url-blocked-p):
+ Better logging.
+
+2010-09-01 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nndoc.el (nndoc-type-alist): Add a new type for Google digests.
+
+ * gnus-html.el (gnus-html-wash-tags): Check the value of
+ gnus-blocked-images in the summary buffer.
+
+2010-09-01 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * gnus-html.el (gnus-html-image-url-blocked-p): Doc fix.
+
+2010-09-01 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-html.el (gnus-html-wash-tags): "A" is also used for links, just
+ like "a", it seems like.
+ (gnus-html-image-url-blocked-p): Take a parameter for blocked-images
+ since it needs to be picked from the correct buffer.
+
+ * nnwfm.el: Remove.
+
+ * nnlistserv.el: Remove.
+
+2010-09-01 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * gnus-html.el (gnus-html-image-url-blocked-p): New function.
+ (gnus-html-prefetch-images, gnus-html-wash-tags): Use it.
+
+2010-09-01 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnkiboze.el: Remove.
+
+ * nndb.el: Remove.
+
+ * gnus-html.el (gnus-html-put-image): Use the deleted text as the image
+ alt text.
+ (gnus-html-rescale-image): Try to get the rescaling logic right for
+ images that are just wide and not tall.
+
+ * gnus.el (gnus-string-or): Fix the syntax to not use eval or
+ overshadow variable bindings.
+
+2010-09-01 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * gnus-html.el (gnus-html-wash-tags)
+ (gnus-html-schedule-image-fetching, gnus-html-prefetch-images):
+ Add extra logging.
+
+2010-09-01 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-html.el (gnus-html-wash-tags): Delete the IMG_ALT region.
+ (gnus-max-image-proportion): New variable.
+ (gnus-html-rescale-image): New function.
+ (gnus-html-put-image): Rescale images.
+
+2010-09-01 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Fix up some byte-compiler warnings.
+ * gnus.el (gnus-group-find-parameter, gnus-kill-save-kill-buffer):
+ * gnus-cite.el (gnus-article-highlight-citation, gnus-dissect-cited-text)
+ (gnus-article-fill-cited-article, gnus-article-hide-citation)
+ (gnus-article-hide-citation-in-followups, gnus-cite-toggle):
+ * gnus-group.el (gnus-group-set-mode-line, gnus-group-quit)
+ (gnus-group-set-info, gnus-add-mark): Use with-current-buffer.
+ (gnus-group-update-group): Use save-excursion and with-current-buffer.
+
+2010-09-01 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-html.el (gnus-article-html): Decode contents by charset.
+
+2010-09-01 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-html.el (gnus-html-cache-directory, gnus-html-cache-size)
+ (gnus-html-frame-width, gnus-blocked-images)
+ * message.el (message-prune-recipient-rules): Add custom version.
+ * gnus-sum.el (gnus-auto-expirable-marks): Bump custom version.
+
+ * gnus-ems.el (gnus-process-get, gnus-process-put): New compatibility
+ functions.
+
+ * gnus-html.el (gnus-html-curl-sentinel): Replace process-get with
+ gnus-process-get.
+
+2010-08-31 Julien Danjou <julien@danjou.info> (tiny change)
+
+ * nnimap.el (nnimap-request-newgroups): Use nnimap-request-list-method
+ instead of lsub directly.
+
+2010-08-31 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnwarchive.el: Remove.
+
+ * gnus-soup.el: Remove.
+
+ * nnsoup.el: Remove.
+
+ * nnultimate.el: Remove.
+
+ * gnus-html.el (gnus-blocked-images): New variable.
+
+ * message.el (message-prune-recipients): New function.
+ (message-prune-recipient-rules): New variable.
+
+ * gnus-cite.el (gnus-article-natural-long-line-p): New function to
+ guess whether a long line is natural text or not.
+
+ * gnus-html.el (gnus-html-schedule-image-fetching):
+ Use gnus-process-plist and friends for compatibility.
+
+2010-08-31 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * gnus-html.el: Require packages that define macros used in this file.
+ (gnus-article-mouse-face): Declare to silence byte-compiler.
+ (gnus-html-curl-sentinel): Use with-current-buffer, inhibit-read-only, and
+ process-get.
+ (gnus-html-put-image): Use plist-get to avoid getf.
+ (gnus-html-prefetch-images): Use with-current-buffer.
+
+2010-08-31 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-ems.el: Provide compatibility functions for
+ gnus-set-process-plist.
+
+ * gnus-sum.el (gnus-summary-stop-at-end-of-message)
+ * gnus.el (gnus-valid-select-methods)
+ * message.el (message-send-mail-partially-limit)
+ * mm-decode.el (mm-text-html-renderer)
+ * mml.el (mml-insert-mime-headers-always)
+ * smiley.el (smiley-regexp-alist): Bump custom version.
+
+2010-08-31 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-html.el: require mm-url.
+ (gnus-html-wash-tags): Clarify the code a bit by renaming the variable
+ with the url to `url'.
+ (gnus-html-wash-tags): Support cid: URLs/images.
+
+2010-08-30 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-sum.el: As per discussion 3 years, 8 weeks, 3 days, 9 hours, 57
+ minutes, 56 seconds ago on the ding list, remove the `w' and `i'
+ bindings, as they aren't useful at all. `w' is moved to `W w'.
+
+ * gnus-move.el: Remove file, since it doesn't really work.
+
+ * gnus-html.el (gnus-article-html): Tell w3m that the input is
+ UTF-8. This seems to fix problems with some German web feeds.
+
+ * gnus.el (gnus-group-startup-message): Put the xpm version of the logo
+ at the top so that the proper colours are applied.
+
+ * gnus-art.el (gnus-article-view-part): Doc fix.
+
+ * gnus-html.el (gnus-html-put-image): Use gnus-create-image to be
+ XEmacs-compatible.
+ (gnus-html-put-image): Don't do images on non-graphic displays.
+
+ * nnslashdot.el: Remove this unused backend.
+
+ * gnus-undo.el (gnus-undo-register-1): Limit the undo actions to 100
+ actions.
+ (gnus-undo-register-1): Revert last change.
+
+ * gnus-group.el (gnus-group-completing-read): Protect against not
+ having completion-styles bound.
+
+ * mml.el (mml-insert-mime-headers-always): Change the default to t, to
+ make broken recipients happier.
+
+ * gnus-html.el (gnus-html-put-image): Use gnus-put-image.
+
+ * gnus-ems.el (gnus-put-image): Have gnus-put-image take an optional
+ point parameter.
+
+ * gnus-group.el (gnus-group-completing-read): Add 'substring to
+ completion-styles for group selection.
+
+2009-02-04 Andreas Schwab <schwab@suse.de>
+
+ * gnus-score.el (gnus-score-string): Fix regex for matching extra
+ headers and regexp-quote the match if necessary.
+
+2009-03-24 Miles Bader <miles@gnu.org>
+
+ * smiley.el (smiley-regexp-alist): Don't delete the semicolon before
+ the blinking smiley.
+
+2009-03-24 Simon Josefsson <simon@josefsson.org>
+
+ * smiley.el (smiley-regexp-alist): Disallow ;;) from being treated as a
+ blink smiley.
+
+2010-08-29 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-start.el (gnus-dribble-read-file): Ensure that the directory
+ where the dribbel file lives exists.
+
+ * message.el (message-send-mail-partially-limit): Change the default to
+ nil, since most people don't want this.
+
+ * mm-url.el (mm-url-decode-entities): Also decode entities like
+ &#x3212.
+
+2009-07-16 Kevin Ryde <user42@zip.com.au> (tiny change)
+
+ * gnus-sum.el (gnus-summary-idna-message):
+ * nnrss.el (nnrss-normalize-date, nnrss-discover-feed):
+ Hyperlink urls in docstrings with URL `...'.
+
+2010-08-29 Adam Sjøgren <asjo@koldfront.dk>
+
+ * gnus-html.el (gnus-html-put-image): Use XEmacs-compatible image
+ functions.
+
+2010-08-29 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-art.el (gnus-article-add-button): Take an optional parameter to
+ say what the mouseover text should be.
+
+ * gnus-html.el (gnus-html-prefetch-images): Use the summary-local
+ version of the mm-w3m-safe-url-regexp variable to only download images
+ in the groups where we want that to happen.
+
+ * gnus-sum.el (gnus-summary-stop-at-end-of-message): New variable.
+
+ * gnus-art.el (gnus-article-beginning-of-window): Make into defun for
+ easier debugging.
+ (gnus-article-beginning-of-window): Add kludge to allow spacing past
+ big pictures in the article buffer.
+
+ * mm-decode.el (mm-text-html-renderer): Default the html renderer to
+ gnus-article-html.
+ (mm-text-html-renderer): gnus-article-html needs curl in addition to
+ w3m.
+
+ * gnus-html.el: Start a new super-simple HTML renderer based on w3m.
+
+2010-08-28 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus.el (gnus-valid-select-methods): Remove reference to nngoogle,
+ which doesn't exist.
+
+ * message.el (message-inhibit-ecomplete): New variable to allow some
+ function to inhibit ecomplete address storage.
+ (message-resend): Disable ecomplete message storage when resending
+ messages.
+
+ * nntp.el (nntp-async-kluge): Remove the Emacs 20.3-related kluge.
+
+2010-08-27 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-sum.el (gnus-summary-move-article, gnus-summary-delete-article):
+ Save excursion while copying, moving, and deleting articles in order to
+ prevent the cursor from jumping to unforeseen place.
+
+2010-08-17 Glenn Morris <rgm@gnu.org>
+
+ * gnus-sync.el: Require gnus components whose functions are used.
+
+ * gnus-art.el (bookmark-make-record-function):
+ * gnus-sum.el (bookmark-yank-point, bookmark-current-bookmark):
+ Declare for compiler.
+
+ * mm-url.el (mml-compute-boundary): Autoload.
+
+2010-08-15 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-start.el (gnus-start-draft-setup): Move doc string forward.
+
+2010-08-14 Teodor Zlatanov <tzz@lifelogs.com>
+
+ Typo fix "hoo4a" -> "hook".
+
+ * gnus-sync.el (gnus-sync-install-hooks): Typo fix.
+
+2010-08-14 Glenn Morris <rgm@gnu.org>
+
+ * gnus-sync.el (gnus-sync): Fix defgroup version.
+
+2010-08-13 Teodor Zlatanov <tzz@lifelogs.com>
+
+ Doc fixes and keep unknown groups (ammended for nunion bug fix).
+
+ * gnus-sync.el: Fix docs.
+ (gnus-sync-save): Keep unknown groups in `gnus-sync-newsrc-loader'.
+ (gnus-sync-read): Don't wipe `gnus-sync-newsrc-loader' after reading.
+
+2010-08-12 Teodor Zlatanov <tzz@lifelogs.com>
+
+ Optimizations for gnus-sync.el.
+
+ * gnus-sync.el: Add docs about gnus-sync-backend
+ possibilities.
+ (gnus-sync-save): Remove unnecessary message.
+ (gnus-sync-read): Optimize and show what groups were skipped.
+
+2010-08-12 Teodor Zlatanov <tzz@lifelogs.com>
+
+ Minor bug fixes for gnus-sync.el.
+
+ * gnus-sync.el (gnus-sync-unload-hook, gnus-sync-install-hooks):
+ Don't read the sync on get-new-news.
+
+ * gnus-sync.el (gnus-sync-save): Define `variable' so the compiler is
+ quiet.
+
+ * gnus-sync.el (gnus-sync-read): Use `gnus-sync-newsrc-offsets'
+ (fix typo).
+
+2010-07-30 Lawrence Mitchell <wence@gmx.li>
+
+ Make saving and restoring of hidden threads work with overlays.
+ Patch applied by Ted Zlatanov.
+
+ * gnus-sum.el (gnus-hidden-threads-configuration)
+ (gnus-restore-hidden-threads-configuration): Update to deal with text
+ properties, rather than searching for a magic character.
+
+2010-08-12 Teodor Zlatanov <tzz@lifelogs.com>
+
+ New gnus-sync.el library for synchronization of marks.
+
+ * gnus-sync.el: New library for synchronization of marks.
+
+ * gnus-util.el (gnus-grep-in-list): Move from gnus-registry.el and
+ renamed from `gnus-registry-grep-in-list'.
+
+ * gnus-registry.el (gnus-registry-follow-group-p):
+ Use `gnus-grep-in-list'.
+
+ * gnus-start.el (gnus-start-draft-setup): Make it interactive.
+
+2010-08-06 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * rfc2047.el (rfc2047-encode): Use utf-8 as a last resort if
+ determining charset of text fails.
+
+2010-08-01 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * nnmail.el (nnmail-get-new-mail-1): Revert.
+
+ * nnml.el (nnml-active-number): Make sure names of newly created groups
+ in nnml-group-alist are encoded.
+
+2010-07-30 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * nnmail.el (nnmail-get-new-mail-1): Encode group names possibly
+ containing non-ASCII characters in active file for nnml back end.
+
+2010-07-24 David Engster <dengste@eml.cc>
+
+ * mml-smime.el (mml-smime-epg-verify): Also accept the older
+ x-pkcs7-signature MIME type as signature (RFC 2311, C.1).
+
+2010-07-21 Daiki Ueno <ueno@unixuser.org>
+
+ * mml.el (mml-parse-1): Collect "certfile" attributes in "<#secure>"
+ tag (Bug#6654).
+
+2010-07-20 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-sum.el (gnus-summary-bookmark-make-record): Bookmark position in
+ the article buffer, not the summary buffer.
+
+2010-07-15 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-sum.el (gnus-summary-bookmark-make-record): Make it work for
+ Emacs 23 as well.
+
+2010-07-13 Thierry Volpiatto <thierry.volpiatto@gmail.com>
+
+ Allow C-w when setting a bookmark in a Gnus Article buffer (Bug#5975).
+ Patch applied by Karl Fogel.
+
+ * gnus-sum.el (gnus-summary-bookmark-make-record):
+ Set `bookmark-yank-point' and `bookmark-current-buffer' to allow C-w.
+
+2010-07-13 Thierry Volpiatto <thierry.volpiatto@gmail.com>
+
+ Allow bookmarks to be set from Gnus Article buffers (Bug #5975).
+ Patch applied (with minor tweaks) by Karl Fogel. Note this leaves
+ C-w still not working correctly from Article buffers; Thierry's
+ patch to fix that will be applied after this.
+
+ * gnus-art.el (bookmark-make-record-function): New local variable.
+
+ * gnus-sum.el (gnus-summary-bookmark-make-record): Allow setting from
+ article buffer.
+ (gnus-summary-bookmark-jump): Maybe jump to article buffer.
+
+2010-07-13 Karl Fogel <kfogel@red-bean.com>
+
+ * gnus-sum.el (bookmark-make-record-default): Adjust declaration, based
+ on changes in bookmark.el.
+
+2010-06-22 Mark A. Hershberger <mah@everybody.org>
+
+ * mm-url.el (mm-url-encode-multipart-form-data): New function to handle
+ the *other* type of HTML form submission.
+
+2010-06-15 Michael Albinus <michael.albinus@gmx.de>
+
+ * auth-source.el (auth-source-pick): If choice does not contain a
+ questioned keyword, set the check to t.
+
+2010-06-12 Romain Francoise <romain@orebokech.com>
+
+ * gnus-util.el (gnus-date-get-time): Move up before first use.
+
+2010-06-10 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-art.el (gnus-mime-buttonized-part-id): New internal variable.
+ (gnus-article-edit-part): Bind it to make last part that is substituted
+ or deleted visible.
+ (gnus-mime-display-single): Buttonize part of which id equals to
+ gnus-mime-buttonized-part-id.
+
+2010-06-10 Dan Christensen <jdc@uwo.ca>
+
+ * gnus-util.el (gnus-user-date): Use gnus-date-get-time.
+ (gnus-dd-mmm): Use gnus-date-get-time.
+ * gnus-sum.el (gnus-thread-latest-date): Use gnus-date-get-time and
+ simplify logic.
+ (gnus-summary-limit-to-age): Use gnus-date-get-time.
+ (gnus-sort-threads): Emit message if gnus-sort-threads-loop used.
+
+2010-06-08 Michael Albinus <michael.albinus@gmx.de>
+
+ * auth-source.el (top): Autoload `secrets-list-collections',
+ `secrets-create-item', `secrets-delete-item'.
+ (auth-sources): Fix tag string.
+ (auth-get-source, auth-source-retrieve, auth-source-create)
+ (auth-source-delete): New defuns.
+ (auth-source-pick): Rewrite in order to avoid 2 passes.
+ (auth-source-forget-user-or-password): New parameter USERNAME.
+ (auth-source-user-or-password): New parameters CREATE-MISSING and
+ DELETE-EXISTING. Retrieve password interactively, if needed.
+
+2010-06-07 Teemu Likonen <tlikonen@iki.fi> (tiny change)
+
+ * gnus-agent.el (gnus-agent-expire-unagentized-dirs): Don't ask about
+ deleting unused directories when gnus-expert-user is t.
+
+2010-06-02 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-art.el (gnus-article-browse-delete-temp-files): Don't make query
+ for each temp file when gnus-article-browse-delete-temp is ask.
+
+2010-05-20 Kevin Ryde <user42@zip.com.au>
+
+ * gnus-start.el (gnus-level-unsubscribed): Doc fix. (Bug#6206)
+
+2010-05-14 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-sum.el (gnus-summary-save-article): Don't bother to re-fetch
+ article unless decoding article to be saved.
+
+2010-05-13 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * mml1991.el (mml1991-mailcrypt-encrypt, mml1991-gpg-encrypt)
+ * mml2015.el (mml2015-gpg-encrypt): Disable multibyte in buffers
+ generated within the mm-with-unibyte-current-buffer macro.
+
+2010-05-13 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-art.el (gnus-bind-safe-url-regexp): Bind mm-w3m-safe-url-regexp
+ to nil when we're in a mml-preview buffer and no group is selected.
+
+2010-05-12 Andreas Seltenreich <seltenreich@gmx.de>
+
+ * gnus-sum.el (gnus-summary-read-group-1): Don't jump to next group
+ when catching the `C-g'. Reported by "Leo".
+
+2010-05-12 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * message.el (message-forward-make-body-plain)
+ (message-forward-make-body-mml): Use mm-multibyte-string-p instead of
+ multibyte-string-p.
+
+2010-05-12 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * message.el (message-forward-make-body-mml): Assume original message
+ is multibyte string; error on unibyte.
+ (message-forward-make-body-plain): Ditto; don't add excessive newline
+ in body end.
+
+2010-05-11 Andreas Seltenreich <seltenreich@gmx.de>
+
+ * gnus-sum.el (gnus-summary-kill-thread): Use gnus-summary-mark-article
+ instead of g-s-m-a-as-unread to set the expirable mark. (Bug#5284)
+
+2010-05-11 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * mm-extern.el (mm-extern-url): Don't use
+ mm-with-unibyte-current-buffer.
+ (mm-extern-cache-contents): Use with-current-buffer instead of
+ save-excursion + set-buffer.
+
+2010-05-10 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * mm-util.el (mm-emacs-mule): Remove.
+
+2010-05-10 Andreas Seltenreich <seltenreich@gmx.de>
+
+ * gnus-sum.el (gnus-summary-mode): Don't make minor-mode-alist
+ buffer-local as it's incompatible with Stefan Monnier's 2010-05-03
+ change.
+
+2010-05-10 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * mm-util.el (mm-with-unibyte-current-buffer): Redefine it so as not to
+ bind the default value of enable-multibyte-characters to nil.
+
+2010-05-10 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * message.el (message-forward-make-body-plain)
+ (message-forward-make-body-mml):
+ Don't use mm-with-unibyte-current-buffer.
+
+2010-05-07 Christian von Roques <roques@mti.ag> (tiny change)
+
+ * mml2015.el (mml2015-epg-find-usable-key): Skip disabled key
+ (Bug#5592).
+
+2010-05-07 Julien Danjou <julien@danjou.info>
+
+ * gnus-art.el (gnus-mime-pipe-part): Add optional argument `cmd'; pass
+ it to mm-pipe-part.
+
+ * mm-decode.el (mm-pipe-part): Add optional argument `cmd'; use it if
+ it is given.
+
+2010-05-07 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * nnweb.el (nnweb-gmane-search)
+ * yenc.el (yenc-decode-region): Don't run set-buffer-multibyte for
+ XEmacs.
+
+ * gnus-art.el (gnus-article-browse-html-parts)
+ * gnus-group.el (gnus-read-ephemeral-gmane-group)
+ (gnus-read-ephemeral-bug-grou): Use mm-make-temp-file instead of
+ make-temp-file.
+
+ * gnus-dired.el (gnus-dired-mode): Bind gnus-dired-mode-hook,
+ gnus-dired-mode-on-hook and gnus-dired-mode-off-hook for XEmacs when
+ compiling.
+
+ * gnus-ml.el (gnus-mailing-list-mode): Bind gnus-mailing-list-mode-hook,
+ gnus-mailing-list-mode-on-hook and gnus-mailing-list-mode-off-hook for
+ XEmacs when compiling.
+
+ * gnus-salt.el (gnus-pick-mode): Bind gnus-pick-mode-on-hook and
+ gnus-pick-mode-off-hook for XEmacs when compiling.
+ (gnus-binary-mode): Bind gnus-binary-mode-on-hook and
+ gnus-binary-mode-off-hook for XEmacs when compiling.
+
+ * gnus-sum.el (gnus-summary-limit-strange-charsets-predicate):
+ Return nil if char-charset is not available.
+
+ * sieve-manage.el (sieve-manage-disable-multibyte): Redefine it as a
+ macro.
+
+ * mm-url.el (mm-url-form-encode-xwfu): Use mm-encode-coding-string
+ instead of encode-coding-string.
+
+ * mm-util.el (mm-enable-multibyte, mm-disable-multibyte): Use (featurep
+ 'xemacs) instead of mm-emacs-mule to switch function definitions.
+ (mm-with-unibyte-current-buffer): Make it a progn macro for XEmacs.
+
+2010-05-06 Tommi Vainikainen <thv@iki.fi> (tiny change)
+
+ * mml-sec.el (mml-secure-message-sign): Fix cut and paste error.
+
+2010-05-06 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-dired.el, gnus-draft.el, gnus-ml.el, gnus-salt.el, gnus-sum.el,
+ gnus-undo.el, mml.el: Require easy-mmode for XEmacs when compiling.
+
+2010-05-03 Juanma Barranquero <lekktu@gmail.com>
+
+ * mm-util.el (mm-decompress-buffer): Use `delete-file';
+ alias `jka-compr-delete-temp-file' no longer exists.
+
+2010-05-03 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Use define-minor-mode in Gnus where applicable.
+ * mml.el (mml-mode): Use define-minor-mode.
+ * gnus-undo.el (gnus-undo-mode-map): Initialize in declaration.
+ (gnus-undo-mode): Use define-minor-mode.
+ * gnus-sum.el (gnus-dead-summary-mode-map): Initialize in declaration.
+ (gnus-dead-summary-mode): Use define-minor-mode.
+ * gnus-salt.el (gnus-pick-mode-map, gnus-binary-mode-map):
+ Initialize in declaration.
+ (gnus-pick-mode, gnus-binary-mode): Use define-minor-mode.
+ * gnus-ml.el (gnus-mailing-list-mode-map): Initialize in declaration.
+ (gnus-mailing-list-mode): Use define-minor-mode.
+ * gnus-draft.el (gnus-draft-mode-map): Initialize in declaration.
+ (gnus-draft-mode): Use define-minor-mode.
+ * gnus-dired.el (gnus-dired-mode-map): Initialize in declaration.
+ (gnus-dired-mode): Use define-minor-mode.
+
+2010-05-01 Andreas Seltenreich <seltenreich@gmx.de>
+
+ * mml.el (mml-generate-mime-1,mml-compute-boundary-1): Update 'mml
+ handles on recursive mml-to-mime translation and check them for
+ boundary delimiter collisions. Reported by Greg Troxel.
+
+2010-04-27 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-util.el: Don't load tm and apel XEmacs packages when compiling.
+
+2010-04-23 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * mm-util.el (mm-find-buffer-file-coding-system):
+ * yenc.el (yenc-decode-region): Don't let-bind a read-only variable.
+
2010-04-22 Andreas Seltenreich <seltenreich@gmx.de>
* message.el (message-generate-headers): Record insertion of optional
@@ -26,22 +4198,86 @@
* nnir.el: Don't mention CVS.
+2010-04-14 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * gnus-sum.el (gnus-summary-bookmark-make-record):
+ Add `location' field.
+
+2010-04-12 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * gnus-sum.el: Add bookmark declarations to silence the compiler.
+ (gnus-mark-xrefs-as-read, gnus-summary-limit-to-bodies):
+ Use with-current-buffer to silence the byte-compiler.
+ (gnus-summary-bookmark-make-record): Use derived-mode-p and don't
+ bother to require `gnus'.
+ (gnus-summary-bookmark-jump): Don't forget to autoload. Simplify.
+
+2010-04-12 Thierry Volpiatto <thierry.volpiatto@gmail.com>
+
+ * gnus-sum.el (gnus-summary-bookmark-make-record)
+ (gnus-summary-bookmark-jump): New functions.
+ (gnus-summary-mode): Setup bookmark support.
+
2010-04-01 Andreas Schwab <schwab@linux-m68k.org>
* mm-uu.el (mm-uu-pgp-signed-extract-1): Use buffer-file-coding-system
if set.
-2010-03-29 Katsumi Yamaoka <yamaoka@jpl.org>
+2010-03-31 Katsumi Yamaoka <yamaoka@jpl.org>
- * mm-decode.el (mm-add-meta-html-tag): Fix regexp matching meta tag.
+ * gnus-art.el (gnus-article-browse-html-save-cid-content): Rename from
+ gnus-article-browse-html-save-cid-image; make it work recursively for
+ forwarded messages as well.
+ (gnus-article-browse-html-parts): Work when prefix arg is given.
+ (gnus-article-browse-html-article): Doc fix.
-2010-03-27 Chong Yidong <cyd@stupidchicken.com>
+2010-03-30 Chong Yidong <cyd@stupidchicken.com>
* message.el (message-default-mail-headers):
(message-default-headers): Carry the value mail-default-headers over
into message-default-mail-headers, rather than message-default-headers.
-2010-03-22 Juanma Barranquero <lekktu@gmail.com>
+2010-03-30 Martin Stjernholm <mast@lysator.liu.se>
+
+ * mm-decode.el (mm-add-meta-html-tag): Add option to override the
+ charset.
+
+ * gnus-art.el (gnus-article-browse-html-parts): Force the correct
+ charset into the <meta> tag when the article is encoded to utf-8.
+
+2010-03-30 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-art.el (gnus-article-browse-delete-temp-files):
+ Delete directories as well.
+ (gnus-article-browse-html-parts): Work for images that do not specify
+ file names; delete temp directory when quitting; insert header at the
+ right place; use file: scheme for image files.
+
+2010-03-30 Eric Schulte <schulte.eric@gmail.com>
+
+ * gnus-art.el (gnus-article-browse-html-save-cid-image): New function.
+ (gnus-article-browse-html-parts): Use it to make temporary cid image
+ files in addition to html file so that browser may display them.
+
+2010-03-29 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * mm-decode.el (mm-add-meta-html-tag): Fix regexp matching meta tag.
+
+2010-03-29 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * auth-source.el (auth-source-pick): Fix for non-secrets specifier.
+
+2010-03-27 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * auth-source.el (auth-sources): Change default to be simpler.
+ Explain about Secret Service API sources. Improve Customize options.
+ (auth-source-pick): Change to accept any number of search parameters.
+ Implement fallbacks iteratively, not recursively. Add scoring on the
+ second pass and sort by score. Call Secret Service API when needed.
+ (auth-source-user-or-password): Use it. Call Secret Service API
+ directly when needed to get the user name and the password.
+
+2010-03-24 Juanma Barranquero <lekktu@gmail.com>
* message.el (message-interactive): Doc fix.
(message-qmail-inject-args): Reflow.
@@ -49,6 +4285,199 @@
* smiley.el (smiley-buffer): Fix typo in docstring.
+2010-03-24 Glenn Morris <rgm@gnu.org>
+
+ * mail-source.el (gnus-message): Declare.
+ (mail-source-delete-old-incoming): Require gnus-util.
+
+2010-03-23 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * gnus-art.el (canlock-verify): Autoload it for Emacs 21.
+
+ * message.el (ecomplete-setup): Autoload it for Emacs <23.
+
+ * mml-sec.el (mml-secure-cache-passphrase): Default to t that is
+ password-cache's default if it is not bound.
+ (mml-secure-passphrase-cache-expiry): Default to 16 that is
+ password-cache-expiry's default if it is not bound.
+
+ * pop3.el (pop3-list): Don't use 3rd arg of `split-string' which is not
+ available in Emacs 21.
+
+2010-03-23 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * auth-source.el (auth-sources): Fix up definition so extra parameters
+ are always inline.
+
+2010-03-22 Martin Stjernholm <mast@lysator.liu.se>
+
+ * nnimap.el (nnimap-verify-uidvalidity): Fix bug where uidvalidity
+ wasn't updated after mismatch. Clear cached mailbox info correctly
+ when uidvalidity changes.
+ (nnimap-group-prefixed-name): New function to avoid some code
+ duplication.
+ (nnimap-verify-uidvalidity, nnimap-group-overview-filename)
+ (nnimap-request-group): Use it.
+ (nnimap-retrieve-groups, nnimap-verify-uidvalidity)
+ (nnimap-update-unseen): Significantly improved speed of Gnus startup
+ with many imap folders. This is done by caching the group status from
+ the imap server persistently in a group parameter `imap-status'. (This
+ was cached before too if `nnimap-retrieve-groups-asynchronous' was set,
+ but not persistently, so every Gnus startup was still very slow.)
+
+2010-03-20 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * auth-source.el: Set up autoloads. Bump to 23.2 because of the
+ secrets.el dependency.
+ (auth-sources): Add optional user name. Add secrets.el configuration
+ choice (unused right now).
+
+2010-03-20 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * gnus-sum.el (gnus-summary-make-menu-bar):
+ Let `gnus-registry-install-shortcuts' fill in the functions.
+
+ * gnus-registry.el (gnus-summary-misc-menu): Declare to avoid
+ warnings.
+ (gnus-registry-misc-menus): Variable to hold registry mark menus.
+ (gnus-registry-install-shortcuts): Populate and use it in a
+ `gnus-summary-menu-hook' lambda, under "Gnus"->"Registry Marks".
+
+2010-03-20 Martin Stjernholm <mast@lysator.liu.se>
+
+ * nnimap.el (nnimap-decode-group-name, nnimap-encode-group-name):
+ In-place substitutions for the group name encoding/decoding.
+ (nnimap-find-minmax-uid, nnimap-possibly-change-group)
+ (nnimap-retrieve-headers-progress, nnimap-possibly-change-group)
+ (nnimap-retrieve-headers-progress, nnimap-request-article-part)
+ (nnimap-update-unseen, nnimap-request-list)
+ (nnimap-retrieve-groups, nnimap-request-update-info-internal)
+ (nnimap-request-set-mark, nnimap-split-to-groups)
+ (nnimap-split-articles, nnimap-request-newgroups)
+ (nnimap-request-create-group, nnimap-request-accept-article)
+ (nnimap-request-delete-group, nnimap-request-rename-group)
+ (nnimap-acl-get, nnimap-acl-edit): Use them. Replace `mbx' with
+ `encoded-mbx' for consistency.
+ (nnimap-close-group): Call `imap-current-mailbox' instead of using the
+ variable `imap-current-mailbox'.
+
+ * gnus-agent.el (gnus-agent-fetch-articles, gnus-agent-fetch-headers)
+ (gnus-agent-regenerate-group): Use `gnus-agent-decoded-group-name'.
+
+2010-03-20 Bojan Petrovic <bpetrovi@f.bg.ac.rs>
+
+ * pop3.el (pop3-display-message-size-flag): Display message size byte
+ counts during POP3 download.
+ (pop3-movemail): Use it.
+ (pop3-list): Implement listing of available messages.
+
+2010-03-20 Mark Triggs <mst@dishevelled.net> (tiny change)
+
+ * nnir.el (nnir-get-article-nov-override-function): New function to
+ override the normal NOV retrieval.
+ (nnir-retrieve-headers): Use it.
+
+2010-03-19 Michael Albinus <michael.albinus@gmx.de>
+
+ * auth-source.el (netrc-machine-user-or-password): Autoload.
+
+2010-03-19 Glenn Morris <rgm@gnu.org>
+
+ Stop message.el from loading about 40 libraries it doesn't always need.
+ The general approach is to autoload rather than require, and to
+ require in the specific functions rather than the file. (Bug#5642)
+
+ * gmm-utils.el: Don't require wid-edit.
+ (widget-create-child-value, widget-convert, widget-default-get):
+ Autoload.
+
+ * gnus-util.el: Don't require time-date, netrc.
+ (message-fetch-field, gnus-group-name-decode): Declare rather than
+ autoloading.
+ (gnus-fetch-field): Require message.
+ (gnus-decode-newsgroups): Require gnus-group.
+
+ * ietf-drums.el: Don't require time-date.
+
+ * message.el: Don't require hashcash, canlock, ecomplete.
+ Do require mail-utils. Require nnheader only when compiling.
+ (smtpmail-default-smtp-server): Remove declaration.
+ (message-send-mail-function): Check smtpmail-default-smtp-server
+ is bound rather than requiring smtpmail.
+ (message-auto-save-directory, message-insert-signature):
+ Use expand-file-name rather than nnheader-concat.
+ (nnheader-insert-file-contents): Autoload.
+ (hashcash-wait-async): Declare.
+ (message-send-mail): Only call gnus-setup-posting-charset if
+ gnus-group-posting-charset-alist is bound. Require hashcash if needed.
+ (message-send-mail-with-sendmail): Require sendmail.
+ (canlock-password, canlock-password-for-verify): Declare.
+ (message-canlock-password): Require canlock.
+ (nnheader-get-report): Autoload.
+ (gnus-setup-posting-charset): Declare.
+ (message-send-news): Require gnus-msg.
+ (message-make-references, message-make-in-reply-to): Use mail-header-id
+ rather than the alias mail-header-message-id.
+ (ecomplete-add-item, ecomplete-save): Declare.
+ (message-put-addresses-in-ecomplete): Require ecomplete.
+ (ecomplete-display-matches): Autoload.
+
+ * mm-decode.el: Don't require mailcap, gnus-util.
+ (gnus-map-function, gnus-replace-in-string, gnus-read-shell-command)
+ (message-fetch-field, mailcap-parse-mailcaps, mailcap-mime-info):
+ Autoload.
+ (mailcap-mime-extensions): Declare.
+
+ * mm-encode.el: Don't require mailcap.
+ (mailcap-extension-to-mime): Autoload.
+
+ * mml-sec.el: Don't require password-cache.
+
+ * mml.el (gnus-setup-posting-charset): Declare rather than autoload.
+ (mailcap-parse-mimetypes, mailcap-mime-types): Declare.
+ (mml-minibuffer-read-type): Require mailcap.
+ (mml-preview): Require gnus-msg.
+
+ * mml1991.el: Require password-cache.
+ (password-cache-expiry): Remove declaration.
+
+ * mml2015.el: Require password-cache.
+ (password-cache-expiry): Remove declaration.
+
+ * nneething.el (mailcap): Require mailcap.
+
+ * nnheader.el (declare-function): Add compatibility stub.
+ (message-remove-header): Declare rather than autoload.
+ (nnheader-replace-header): Require message.
+
+ * nnimap.el (declare-function): Add compatibility stub.
+ (netrc-parse, netrc-machine-user-or-password): Declare.
+ (nnimap-open-connection): Require netrc.
+
+ * nntp.el (declare-function): Add compatibility stub.
+ (netrc-parse, netrc-machine, netrc-get): Declare.
+ (nntp-send-authinfo): Require netrc.
+
+ * rfc2047.el: Don't require qp.
+ (quoted-printable-encode-region, quoted-printable-decode-string):
+ Autoload.
+
+ * sieve-mode.el: Don't require easymenu.
+ (easy-menu-add-item): Autoload it.
+
+ * spam-stat.el (time-to-number-of-days): Autoload it.
+
+2010-03-17 Kevin Ryde <user42@zip.com.au>
+
+ * mml.el (mml-read-tag): Unquote values with `read' to reverse
+ prin1 in mml-insert-tag (just stripping the quotes gave wrong
+ value if any backslash escapes).
+
+2010-03-15 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * mm-util.el (mm-charset-to-coding-system): Use coding-system-from-name
+ if it is available. (bug#5647)
+
2010-02-26 Glenn Morris <rgm@gnu.org>
* message.el (message-send-mail-function): Change the default, so that
@@ -115,8 +4544,8 @@
2010-01-01 Chong Yidong <cyd@stupidchicken.com>
- * message.el (message-exchange-point-and-mark): Call
- exchange-point-and-mark with an argument rather than setting
+ * message.el (message-exchange-point-and-mark):
+ Call exchange-point-and-mark with an argument rather than setting
mark-active by hand (Bug#5175).
2009-12-18 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -710,9 +5139,9 @@
* legacy-gnus-agent.el (gnus-agent-unlist-expire-days): Don't use
cadar.
- * sieve-manage.el (sieve-manage-starttls-p): Renamed from
+ * sieve-manage.el (sieve-manage-starttls-p): Rename from
imap-starttls-p.
- (sieve-manage-starttls-open): Renamed from imap-starttls-open.
+ (sieve-manage-starttls-open): Rename from imap-starttls-open.
2008-12-22 Reiner Steib <Reiner.Steib@gmx.de>
@@ -739,8 +5168,8 @@
2008-12-21 Reiner Steib <Reiner.Steib@gmx.de>
- * gnus-start.el (gnus-before-startup-hook): Fix doc string. Reported
- by Stephen Berman <stephen.berman@gmx.net>.
+ * gnus-start.el (gnus-before-startup-hook): Fix doc string.
+ Reported by Stephen Berman <stephen.berman@gmx.net>.
2008-12-18 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -922,7 +5351,7 @@
2008-09-25 Teodor Zlatanov <tzz@lifelogs.com>
- * message.el (message-confirm-send): Fixed variable documentation to
+ * message.el (message-confirm-send): Fix variable documentation to
avoid the "y/n" wording.
2008-09-25 Francis Litterio <flitterio@gmail.com> (tiny change)
@@ -1056,8 +5485,8 @@
2008-07-22 Katsumi Yamaoka <yamaoka@jpl.org>
- * gnus-art.el (gnus-summary-save-in-pipe): Consider
- gnus-save-all-headers.
+ * gnus-art.el (gnus-summary-save-in-pipe):
+ Consider gnus-save-all-headers.
2008-07-21 Dan Nicolaescu <dann@ics.uci.edu>
@@ -1277,16 +5706,16 @@
* nnheader.el (nnheader-read-timeout): Change the default timeout from
0.1 seconds to 0.01 seconds. This will make nntp and pop3 article
- retrieval faster in some cases, but might make CPU usage larger. If
- this has any bad side effects, we might revert this change.
+ retrieval faster in some cases, but might make CPU usage larger.
+ If this has any bad side effects, we might revert this change.
* pop3.el (pop3-movemail): Change the sit-for from 0.1 to 0.01, which
seems to make mail retrieval much, much faster.
(pop3-movemail): Use nnheader-accept-process-output instead of sleeping
unconditionally.
- * gnus-draft.el (gnus-group-send-queue): Bind
- message-send-mail-partially-limit to nil to avoid being prompted.
+ * gnus-draft.el (gnus-group-send-queue):
+ Bind message-send-mail-partially-limit to nil to avoid being prompted.
2008-05-16 Reiner Steib <Reiner.Steib@gmx.de>
@@ -1319,7 +5748,7 @@
* nnimap.el: Autoload `auth-source-user-or-password'.
(nnimap-open-connection): Use it.
- * auth-source.el: Added docs on using with url-auth. Import gnus-util
+ * auth-source.el: Add docs on using with url-auth. Import gnus-util
for the gnus-message function.
(auth-source-user-or-password): Use it.
@@ -1462,7 +5891,7 @@
2008-04-09 Teodor Zlatanov <tzz@lifelogs.com>
- * auth-source.el: Added docs.
+ * auth-source.el: Add docs.
(auth-sources): Modify format to support server.
(auth-source-pick, auth-source-user-or-password)
(auth-source-user-or-password-imap)
@@ -1641,8 +6070,8 @@
2008-03-17 Teodor Zlatanov <tzz@lifelogs.com>
- * gnus-registry.el (gnus-registry-split-fancy-with-parent): Eliminate
- unnecessary duplicates from the match list.
+ * gnus-registry.el (gnus-registry-split-fancy-with-parent):
+ Eliminate unnecessary duplicates from the match list.
2008-03-17 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -1668,13 +6097,13 @@
2008-03-13 Teodor Zlatanov <tzz@lifelogs.com>
- * auth-source.el (auth-sources): Renamed from auth-source-choices.
+ * auth-source.el (auth-sources): Rename from auth-source-choices.
(auth-source-pick): Use it.
2008-03-12 Teodor Zlatanov <tzz@lifelogs.com>
* auth-source.el (auth-source-protocols)
- (auth-source-protocols-customize, auth-source-choices): Added and
+ (auth-source-protocols-customize, auth-source-choices): Add and
modified variable customizations and defaults.
(auth-source-pick, auth-source-user-or-password)
(auth-source-protocol-defaults, auth-source-user-or-password-imap)
@@ -1698,8 +6127,8 @@
nntp-with-open-group macro.
(nntp-with-open-group): Use the function, so it's easier to debug.
Add indentation and debugging info.
- (nntp-open-telnet-stream, nntp-open-via-rlogin-and-telnet): Recommend
- the use of the netcat alternatives.
+ (nntp-open-telnet-stream, nntp-open-via-rlogin-and-telnet):
+ Recommend the use of the netcat alternatives.
* rfc2047.el (rfc2047-decode-string): Don't use `m'.
Avoid mm-string-as-multibyte as well.
@@ -1805,12 +6234,12 @@
2008-03-04 Teodor Zlatanov <tzz@lifelogs.com>
- * gnus-registry.el (gnus-registry-user-format-function-M): Add
- formatting function.
+ * gnus-registry.el (gnus-registry-user-format-function-M):
+ Add formatting function.
2008-03-03 Teodor Zlatanov <tzz@lifelogs.com>
- * gnus-registry.el (gnus-registry-marks): Changed format to be nicer
+ * gnus-registry.el (gnus-registry-marks): Change format to be nicer
with plists.
(gnus-registry-do-marks, gnus-registry-install-shortcuts-and-menus):
Use new format.
@@ -1842,8 +6271,8 @@
* mml.el (mml-menu): Improve help entries. Move Sign/Encrypt Part.
(mml-dnd-attach-options): Fix typo in custom choice.
- * gnus-group.el (gnus-group-read-ephemeral-gmane-group): Change
- nndoc-article-type to mbox.
+ * gnus-group.el (gnus-group-read-ephemeral-gmane-group):
+ Change nndoc-article-type to mbox.
(gnus-group-read-ephemeral-gmane-group-url): Support permalink.
* mm-decode.el (mm-text-html-renderer): Prefer w3m over w3. Fall back
@@ -1907,14 +6336,14 @@
(nnmairix-last-server, nnmairix-current-server): Defvar them.
(nnmairix-goto-original-article): Defvar gnus-registry-install and
autoload gnus-registry-fetch-group when compiling.
- (nnmairix-request-group-with-article-number-correction): Remove
- unreferenced argument passed to nnmairix-call-backend.
+ (nnmairix-request-group-with-article-number-correction):
+ Remove unreferenced argument passed to nnmairix-call-backend.
2008-02-27 Reiner Steib <Reiner.Steib@gmx.de>
* mm-uu.el (mm-uu-type-alist): Fix message-marks non-hide arguments.
- (mm-uu-extract): Improve face for low color ttys. Reported by Sascha
- Wilde.
+ (mm-uu-extract): Improve face for low color ttys.
+ Reported by Sascha Wilde.
2008-02-27 Glenn Morris <rgm@gnu.org>
@@ -2105,8 +6534,8 @@
2008-01-12 Reiner Steib <Reiner.Steib@gmx.de>
* gnus-sum.el (gnus-article-sort-by-random)
- (gnus-thread-sort-by-random): Fix doc strings. Reported by
- jidanni@jidanni.org.
+ (gnus-thread-sort-by-random): Fix doc strings.
+ Reported by jidanni@jidanni.org.
2008-01-11 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -2118,13 +6547,13 @@
* gnus-art.el (gnus-article-read-summary-keys): Work for `C-h' on
XEmacs.
- (gnus-article-describe-key, gnus-article-describe-key-briefly): Protect
- against non-character events.
+ (gnus-article-describe-key, gnus-article-describe-key-briefly):
+ Protect against non-character events.
2008-01-09 Reiner Steib <Reiner.Steib@gmx.de>
- * gnus-group.el (gnus-group-read-ephemeral-gmane-group-url): New
- command.
+ * gnus-group.el (gnus-group-read-ephemeral-gmane-group-url):
+ New command.
(gnus-group-read-ephemeral-gmane-group): Use optional argument RANGE
instead of END. Change name of the temp file.
(gnus-group-gmane-group-download-format): Add doc string. Make it
@@ -2139,8 +6568,8 @@
continuation keys correctly in the echo area; describe bindings
correctly when keys end with `C-h'.
(gnus-article-read-summary-send-keys): New function.
- (gnus-article-describe-key, gnus-article-describe-key-briefly): Work
- for gnus-article-read-summary-send-keys; display continuation keys
+ (gnus-article-describe-key, gnus-article-describe-key-briefly):
+ Work for gnus-article-read-summary-send-keys; display continuation keys
correctly in the echo area.
(gnus-article-reply-with-original): Ignore prefix argument.
(gnus-article-wide-reply-with-original): New function.
@@ -2234,8 +6663,8 @@
2007-12-14 Reiner Steib <Reiner.Steib@gmx.de>
- * gnus-sum.el (gnus-summary-prev-article): Fix doc string. Reported by
- Christoph Conrad <christoph.conrad@gmx.de>.
+ * gnus-sum.el (gnus-summary-prev-article): Fix doc string.
+ Reported by Christoph Conrad <christoph.conrad@gmx.de>.
2007-12-14 Reiner Steib <Reiner.Steib@gmx.de>
@@ -2247,8 +6676,8 @@
* mm-decode.el (mm-add-meta-html-tag): New function.
(mm-save-part-to-file, mm-pipe-part): Use it.
- * gnus-art.el (gnus-article-browse-delete-temp-files): Use
- gnus-y-or-n-p instead of y-or-n-p.
+ * gnus-art.el (gnus-article-browse-delete-temp-files):
+ Use gnus-y-or-n-p instead of y-or-n-p.
(gnus-article-browse-html-parts): Work with message/external-body; use
mm-add-meta-html-tag.
@@ -2258,8 +6687,8 @@
* gnus-fun.el (gnus-display-x-face-in-from): Require gnus-art.
- * gnus-int.el (gnus-server-opened, gnus-status-message): Move
- definitions before use.
+ * gnus-int.el (gnus-server-opened, gnus-status-message):
+ Move definitions before use.
* mm-decode.el: Require gnus-util.
(mm-remove-part): Only call delete-annotation on XEmacs.
@@ -2367,15 +6796,15 @@
2007-12-06 Christian Plate <cplate@web.de> (tiny change)
- * nnmaildir.el (nnmaildir-request-update-info): Improved performance.
+ * nnmaildir.el (nnmaildir-request-update-info): Improve performance.
Call gnus-add-to-range ranges only once with a prepared article-list.
2007-12-06 Paul Jarc <prj@po.cwru.edu>
* nnmaildir.el (nnmaildir-request-list, nnmaildir-retrieve-groups)
(nnmaildir-request-group, nnmaildir-retrieve-headers): Escape spaces in
- group names with backslashes. Reported by Tassilo Horn
- <tassilo@member.fsf.org>.
+ group names with backslashes.
+ Reported by Tassilo Horn <tassilo@member.fsf.org>.
2007-12-06 Deepak Goel <deego3@gmail.com>
@@ -2394,8 +6823,8 @@
2007-12-05 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus-art.el (gnus-article-browse-html-parts): Add meta html tag to
- specify charset to html source. Reported by Christoph Conrad
- <christoph.conrad@gmx.de>.
+ specify charset to html source.
+ Reported by Christoph Conrad <christoph.conrad@gmx.de>.
2007-12-05 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -2419,8 +6848,8 @@
* gnus-group.el (gnus-group-highlight-line): Add FIXME.
* gnus-dired.el: Reduce Gnus dependencies.
- (gnus-ems, gnus-msg, gnus-util, message, mm-decode, mml): Don't
- require. Use autoloads instead.
+ (gnus-ems, gnus-msg, gnus-util, message, mm-decode, mml):
+ Don't require. Use autoloads instead.
(mml-attach-file, mm-default-file-encoding, mailcap-extension-to-mime)
(mailcap-mime-info, mm-mailcap-command, ps-print-preprint)
(message-buffers, gnus-setup-message, gnus-print-buffer): Autoload.
@@ -2479,8 +6908,7 @@
* yenc.el (yenc-first-part-p, yenc-last-part-p): New functions.
- * mm-uu.el (mm-uu-yenc-extract): Get the data from the original
- buffer.
+ * mm-uu.el (mm-uu-yenc-extract): Get the data from the original buffer.
2007-12-02 Glenn Morris <rgm@gnu.org>
@@ -2496,8 +6924,8 @@
* message.el (message-cite-prefix-regexp): Remove `-' and `+' to avoid
matches on patches.
- * gnus-art.el (gnus-article-browse-html-article): Mention
- `mm-text-html-renderer' in the doc string.
+ * gnus-art.el (gnus-article-browse-html-article):
+ Mention `mm-text-html-renderer' in the doc string.
* rfc2047.el (rfc2047-encode-max-chars): Refer to RFC 2047 in doc
string. Add comments.
@@ -2526,8 +6954,8 @@
(gnus-agent-method-p): Canonicalize server names by pushing their
method through `gnus-method-to-server' using the no-cache argument.
- * gnus-srvr.el (gnus-server-insert-server-line): Call
- `gnus-method-to-server' with `no-cache' argument.
+ * gnus-srvr.el (gnus-server-insert-server-line):
+ Call `gnus-method-to-server' with `no-cache' argument.
* gnus-agent.el (gnus-agent-toggle-plugged): Don't call
gnus-agent-possibly-synchronize-flags as this should be called when the
@@ -2769,12 +7197,12 @@
2007-11-15 Katsumi Yamaoka <yamaoka@jpl.org>
- * nntp.el (nntp-insert-buffer-substring, nntp-copy-to-buffer): New
- macros.
+ * nntp.el (nntp-insert-buffer-substring, nntp-copy-to-buffer):
+ New macros.
(nntp-wait-for, nntp-retrieve-articles, nntp-async-trigger)
(nntp-retrieve-headers-with-xover): Use nntp-insert-buffer-substring to
copy data from unibyte buffer to multibyte current buffer.
- (nntp-retrieve-headers, nntp-retrieve-groups); Use nntp-copy-to-buffer
+ (nntp-retrieve-headers, nntp-retrieve-groups): Use nntp-copy-to-buffer
to copy data from unibyte current buffer to multibyte buffer.
(nntp-make-process-buffer): Make process buffer unibyte.
@@ -2855,8 +7283,8 @@
2007-10-29 Stefan Monnier <monnier@iro.umontreal.ca>
- * message.el (message-check-news-body-syntax): Avoid
- mm-string-as-multibyte.
+ * message.el (message-check-news-body-syntax):
+ Avoid mm-string-as-multibyte.
(message-hide-headers): Don't assume (point-min)==1.
2007-10-28 Reiner Steib <Reiner.Steib@gmx.de>
@@ -2887,8 +7315,8 @@
2007-10-27 Reiner Steib <Reiner.Steib@gmx.de>
- * gnus-msg.el (gnus-message-setup-hook): Add
- `message-remove-blank-cited-lines' to options.
+ * gnus-msg.el (gnus-message-setup-hook):
+ Add `message-remove-blank-cited-lines' to options.
2007-10-26 Reiner Steib <Reiner.Steib@gmx.de>
@@ -2960,8 +7388,8 @@
* gnus-group.el (gnus-group-suspend): Replace mapcar called for effect
with dolist.
- * gnus-registry.el (gnus-registry-split-fancy-with-parent): Replace
- mapcar called for effect with dolist.
+ * gnus-registry.el (gnus-registry-split-fancy-with-parent):
+ Replace mapcar called for effect with dolist.
* gnus-spec.el (gnus-correct-length): Make it simple and fast.
@@ -2994,7 +7422,7 @@
* gnus-agent.el (gnus-agent-expire-group-1): The check for an unsorted
overview buffer needed a catch to receive its throw.
- (gnus-agent-flush-cache): Declared as interactive to make this function
+ (gnus-agent-flush-cache): Declare as interactive to make this function
easier to use.
2007-10-20 Reiner Steib <Reiner.Steib@gmx.de>
@@ -3058,8 +7486,8 @@
* mm-decode.el (mm-possibly-verify-or-decrypt): Replace PARTS with the
ones returned from the verify-function.
- * mm-uu.el (mm-uu-pgp-signed-extract-1): Call
- mml2015-extract-cleartext-signature if extraction failed.
+ * mm-uu.el (mm-uu-pgp-signed-extract-1):
+ Call mml2015-extract-cleartext-signature if extraction failed.
2007-10-07 Daiki Ueno <ueno@unixuser.org>
@@ -3235,7 +7663,7 @@
2007-08-14 Tassilo Horn <tassilo@member.fsf.org>
- * gnus-art.el (gnus-sticky-article): Fixed problems described in
+ * gnus-art.el (gnus-sticky-article): Fix problems described in
<b4mps1qitio.fsf@jpl.org> on ding. Thanks to Katsumi.
Don't perform gnus-configure-windows here; reuse existing sticky
article buffer.
@@ -3357,8 +7785,8 @@
2007-07-23 Katsumi Yamaoka <yamaoka@jpl.org>
- * gnus-sum.el (gnus-summary-move-article): Make
- gnus-summary-respool-article work.
+ * gnus-sum.el (gnus-summary-move-article):
+ Make gnus-summary-respool-article work.
2007-07-21 Reiner Steib <Reiner.Steib@gmx.de>
@@ -3417,8 +7845,8 @@
nnmail-pathname-coding-system.
(nnml-request-article): Pass server argument to nnml-find-group-number.
- (nnml-request-create-group, nnml-active-number, nnml-save-marks): Pass
- server argument to nnml-possibly-create-directory.
+ (nnml-request-create-group, nnml-active-number, nnml-save-marks):
+ Pass server argument to nnml-possibly-create-directory.
(nnml-request-accept-article): Pass server argument to
nnml-active-number and nnml-save-mail.
(nnml-find-group-number): Pass server argument to nnml-find-id.
@@ -3447,8 +7875,8 @@
2007-07-18 Katsumi Yamaoka <yamaoka@jpl.org>
- * gnus-agent.el (gnus-agent-save-active): Bind
- nnheader-file-coding-system to gnus-agent-file-coding-system.
+ * gnus-agent.el (gnus-agent-save-active):
+ Bind nnheader-file-coding-system to gnus-agent-file-coding-system.
* gnus-cache.el (gnus-cache-save-buffers)
(gnus-cache-possibly-enter-article, gnus-cache-request-article)
@@ -3457,10 +7885,10 @@
(gnus-cache-braid-nov, gnus-cache-braid-heads)
(gnus-cache-generate-active, gnus-cache-rename-group)
(gnus-cache-delete-group, gnus-cache-update-file-total-fetched-for)
- (gnus-cache-update-overview-total-fetched-for): Bind
- file-name-coding-system to nnmail-pathname-coding-system.
- (gnus-cache-decoded-group-names, gnus-cache-unified-group-names): New
- variables.
+ (gnus-cache-update-overview-total-fetched-for):
+ Bind file-name-coding-system to nnmail-pathname-coding-system.
+ (gnus-cache-decoded-group-names, gnus-cache-unified-group-names):
+ New variables.
(gnus-cache-decoded-group-name): New function.
(gnus-cache-file-name): Use it.
(gnus-cache-generate-active): Use non-decoded group name for active.
@@ -3494,8 +7922,8 @@
(gnus-agent-retrieve-headers, gnus-agent-request-article)
(gnus-agent-regenerate-group)
(gnus-agent-update-files-total-fetched-for)
- (gnus-agent-update-view-total-fetched-for): Bind
- file-name-coding-system to nnmail-pathname-coding-system.
+ (gnus-agent-update-view-total-fetched-for):
+ Bind file-name-coding-system to nnmail-pathname-coding-system.
(gnus-agent-group-pathname): Don't encode file names by
nnmail-pathname-coding-system.
(gnus-agent-save-local): Bind file-name-coding-system correctly; bind
@@ -3516,8 +7944,8 @@
* nnrss.el (nnrss-file-coding-system): Doc fix; make it begin with *.
(nnrss-request-delete-group): Bind file-name-coding-system to
nnmail-pathname-coding-system.
- (nnrss-read-server-data, nnrss-read-group-data): Bind
- file-name-coding-system correctly.
+ (nnrss-read-server-data, nnrss-read-group-data):
+ Bind file-name-coding-system correctly.
(nnrss-check-group): Pass nnrss-file-coding-system to md5.
* nntp.el: Require gnus-group for the function gnus-group-name-charset.
@@ -3592,8 +8020,8 @@
* message.el (message-fix-before-sending): Skip raw message part to be
forwarded while checking illegible text.
- (message-forward-make-body-mime, message-forward-make-body): Mark
- signed or encrypted raw message as having no illegible text.
+ (message-forward-make-body-mime, message-forward-make-body):
+ Mark signed or encrypted raw message as having no illegible text.
2007-06-19 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -3612,8 +8040,8 @@
2007-06-14 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus-agent.el (gnus-agent-fetch-headers)
- (gnus-agent-retrieve-headers): Bind
- gnus-decode-encoded-address-function to identity.
+ (gnus-agent-retrieve-headers):
+ Bind gnus-decode-encoded-address-function to identity.
* nntp.el (nntp-send-xover-command): Recognize an xover command is
available also when the server returns simply a dot.
@@ -3674,8 +8102,8 @@
2007-05-29 Katsumi Yamaoka <yamaoka@jpl.org>
- * gnus-sum.el (gnus-summary-limit-to-address): New function. Suggested
- by Loic Dachary <loic@dachary.org>.
+ * gnus-sum.el (gnus-summary-limit-to-address): New function.
+ Suggested by Loic Dachary <loic@dachary.org>.
(gnus-summary-limit-map, gnus-summary-make-menu-bar): Add it.
2007-05-28 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -3732,13 +8160,13 @@
* gnus-util.el (gnus-limit-string): Delete this function.
- * gnus-sum.el (gnus-simplify-subject-fully): Use
- `truncate-string-to-width' instead.
+ * gnus-sum.el (gnus-simplify-subject-fully):
+ Use `truncate-string-to-width' instead.
2007-05-11 Michaël Cadilhac <michael@cadilhac.name>
- * gnus-sum.el (gnus-summary-next-group-on-exit): New variable. Tell
- if, on summary exit, the next group has to be selected.
+ * gnus-sum.el (gnus-summary-next-group-on-exit): New variable.
+ Tell if, on summary exit, the next group has to be selected.
(gnus-summary-exit): Use it.
2007-05-10 Reiner Steib <Reiner.Steib@gmx.de>
@@ -3792,8 +8220,8 @@
2007-04-27 Didier Verna <didier@xemacs.org>
- * gnus-util.el (gnus-orify-regexp): Moved and renamed to ...
- * gmm-utils.el (gmm-regexp-concat): here.
+ * gnus-util.el (gnus-orify-regexp): Move and rename to ...
+ * gmm-utils.el (gmm-regexp-concat): ... here.
* message.el: Don't require 'gnus-util.
(message-dont-reply-to-names): Handle name change above.
* gnus-sum.el (gnus-ignored-from-addresses): Ditto.
@@ -3860,9 +8288,9 @@
2007-04-16 Didier Verna <didier@xemacs.org>
- * gnus-msg.el (gnus-configure-posting-styles): Handle
- message-signature-directory properly with :file syntax. Reported by
- "Leo".
+ * gnus-msg.el (gnus-configure-posting-styles):
+ Handle message-signature-directory properly with :file syntax.
+ Reported by "Leo".
2007-04-11 Didier Verna <didier@xemacs.org>
@@ -3874,8 +8302,8 @@
2007-04-10 Katsumi Yamaoka <yamaoka@jpl.org>
- * gnus-msg.el (gnus-inews-yank-articles): Use
- message-exchange-point-and-mark instead of exchange-point-and-mark.
+ * gnus-msg.el (gnus-inews-yank-articles):
+ Use message-exchange-point-and-mark instead of exchange-point-and-mark.
2007-04-09 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -4035,7 +8463,7 @@
2007-02-20 Daiki Ueno <ueno@unixuser.org>
- * mml2015.el (mml2015-epg-verify): Simplified.
+ * mml2015.el (mml2015-epg-verify): Simplify.
2007-02-19 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -4101,8 +8529,8 @@
(gnus-message-citation-keywords): Set LAXMATCH flag in every HIGHLIGHT.
(gnus-message-add-citation-keywords): Append keywords rather than
prepending; emulate font-lock-add-keywords if it is not available.
- (gnus-message-remove-citation-keywords): Emulate
- font-lock-remove-keywords if it is not available.
+ (gnus-message-remove-citation-keywords):
+ Emulate font-lock-remove-keywords if it is not available.
* gnus-msg.el (gnus-message-highlight-citation): Default to t.
@@ -4130,8 +8558,8 @@
2007-01-23 Reiner Steib <Reiner.Steib@gmx.de>
- * gnus-score.el (gnus-home-score-file, gnus-home-adapt-file): Fix
- custom choice.
+ * gnus-score.el (gnus-home-score-file, gnus-home-adapt-file):
+ Fix custom choice.
* gnus-art.el (gnus-signature-limit): Fix custom choice.
@@ -4173,8 +8601,8 @@
* gnus-sum.el (gnus-auto-select-first): Improve doc string.
- * message.el (message-cite-original-1): Call
- gnus-article-highlight-citation if requested.
+ * message.el (message-cite-original-1):
+ Call gnus-article-highlight-citation if requested.
(message-make-from): Allow name and address as optional arguments.
* gnus-cite.el (gnus-article-highlight-citation): Add SAME-BUFFER arg.
@@ -4292,8 +8720,8 @@
2006-12-29 Jouni K. Seppänen <jks@iki.fi>
- * nnimap.el (nnimap-expunge-search-string): Mention
- nnimap-search-uids-not-since-is-evil in docstring.
+ * nnimap.el (nnimap-expunge-search-string):
+ Mention nnimap-search-uids-not-since-is-evil in docstring.
2006-12-28 Reiner Steib <Reiner.Steib@gmx.de>
@@ -4305,8 +8733,8 @@
make-obsolete-variable.
(spam-bsfilter-path, spam-bsfilter-program)
(spam-spamassassin-path, spam-spamassassin-program)
- (spam-sa-learn-path, spam-sa-learn-program): Rename variables. Don't
- use "path" inappropriately.
+ (spam-sa-learn-path, spam-sa-learn-program): Rename variables.
+ Don't use "path" inappropriately.
(spam-check-spamassassin, spam-spamassassin-register-with-sa-learn)
(spam-check-bsfilter, spam-bsfilter-register-with-bsfilter): Use new
variable names.
@@ -4358,8 +8786,8 @@
(spam-spamoracle-database, spam-get-ifile-database-parameter): Fix doc
strings.
(spam-check-ifile, spam-ifile-register-with-ifile)
- (spam-check-bogofilter, spam-bogofilter-register-with-bogofilter): Use
- new variable names.
+ (spam-check-bogofilter, spam-bogofilter-register-with-bogofilter):
+ Use new variable names.
* gnus-art.el (gnus-treat-display-x-face, gnus-treat-display-face)
(gnus-treat-display-smileys): Simplify using
@@ -4434,7 +8862,7 @@
specifying array size.
(gnus-summary-insert-line, gnus-summary-prepare-threads): Regrow indent
array if it is too small.
- (gnus-sort-threads-recursive): Renamed from gnus-sort-thread-1.
+ (gnus-sort-threads-recursive): Rename from gnus-sort-thread-1.
(gnus-sort-threads-loop): New function.
2006-12-06 Chris Moore <dooglus@gmail.com>
@@ -4471,8 +8899,8 @@
2006-11-29 Katsumi Yamaoka <yamaoka@jpl.org>
- * nneething.el (nneething-decode-file-name): Replace
- decode-coding-string with mm-decode-coding-string.
+ * nneething.el (nneething-decode-file-name):
+ Replace decode-coding-string with mm-decode-coding-string.
* gnus-int.el (gnus-open-server): Say failed server's name.
@@ -4569,7 +8997,7 @@
2006-11-13 Daiki Ueno <ueno@unixuser.org>
- * mml2015.el (mml2015-epg-encrypt): Removed backward compatibility for
+ * mml2015.el (mml2015-epg-encrypt): Remove backward compatibility for
EasyPG (< 0.0.6).
(mml2015-always-trust): New user option.
(mml2015-epg-passphrase-callback): Display key ID on the passphrase
@@ -4595,12 +9023,12 @@
2006-11-07 Reiner Steib <Reiner.Steib@gmx.de>
* message.el (message-strip-subject-encoded-words): Reformat prompt.
- (message-simplify-subject-functions): Enable
- message-strip-subject-encoded-words by default.
+ (message-simplify-subject-functions):
+ Enable message-strip-subject-encoded-words by default.
2006-11-06 Reiner Steib <Reiner.Steib@gmx.de>
- * message.el (message-strip-subject-encoded-words): New function
+ * message.el (message-strip-subject-encoded-words): New function.
(message-simplify-subject-functions): New variable.
(message-simplify-subject): Use it. Fix typo in doc string.
Support message-strip-subject-encoded-words.
@@ -4628,8 +9056,8 @@
(mm-setup-codepage-iso-8859, mm-setup-codepage-ibm): New functions.
(mm-charset-synonym-alist): Move some entries to
mm-codepage-iso-8859-list.
- (mm-charset-synonym-alist, mm-charset-override-alist): Add
- iso-8859-8/windows-1255 and iso-8859-9/windows-1254.
+ (mm-charset-synonym-alist, mm-charset-override-alist):
+ Add iso-8859-8/windows-1255 and iso-8859-9/windows-1254.
2006-10-29 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -4656,8 +9084,8 @@
2006-10-24 Reiner Steib <Reiner.Steib@gmx.de>
- * mm-util.el (mm-codepage-iso-8859-list, mm-codepage-ibm-list): New
- variables.
+ * mm-util.el (mm-codepage-iso-8859-list, mm-codepage-ibm-list):
+ New variables.
(mm-setup-codepage-iso-8859, mm-setup-codepage-ibm): New functions.
(mm-charset-synonym-alist): Move some entries to
mm-codepage-iso-8859-list.
@@ -4672,8 +9100,8 @@
2006-10-20 Teodor Zlatanov <tzz@lifelogs.com>
- * spam.el (spam-check-BBDB, spam-enter-ham-BBDB, spam-parse-list): Use
- car-safe to avoid bad parses.
+ * spam.el (spam-check-BBDB, spam-enter-ham-BBDB, spam-parse-list):
+ Use car-safe to avoid bad parses.
2006-10-20 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -4703,8 +9131,8 @@
2006-10-16 Teodor Zlatanov <tzz@lifelogs.com>
- * spam.el (spam-check-BBDB, spam-enter-ham-BBDB, spam-parse-list): Use
- ietf-drums-parse-address instead of gnus-extract-address-components.
+ * spam.el (spam-check-BBDB, spam-enter-ham-BBDB, spam-parse-list):
+ Use ietf-drums-parse-address instead of gnus-extract-address-components.
Reported by Damien Elmes <damien@repose.cx>.
2006-10-19 Reiner Steib <Reiner.Steib@gmx.de>
@@ -4733,8 +9161,8 @@
2006-10-04 Reiner Steib <Reiner.Steib@gmx.de>
- * mm-util.el (mm-charset-synonym-alist, mm-charset-override-alist): Add
- iso-8859-8/windows-1255 and iso-8859-9/windows-1254.
+ * mm-util.el (mm-charset-synonym-alist, mm-charset-override-alist):
+ Add iso-8859-8/windows-1255 and iso-8859-9/windows-1254.
* nnheader.el (nnheader-find-file-noselect): Inhibit version-control.
@@ -4743,8 +9171,8 @@
(message-simplify-subject): New function to remove duplicate code.
(message-reply, message-followup): Use it.
- * gnus-sum.el (gnus-summary-make-menu-bar): Clarify
- gnus-summary-limit-to-articles.
+ * gnus-sum.el (gnus-summary-make-menu-bar):
+ Clarify gnus-summary-limit-to-articles.
2006-10-03 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -4782,8 +9210,8 @@
* gmm-utils.el (gmm): Adjust custom version.
- * mm-util.el (mm-charset-override-alist, mm-charset-eval-alist): Adjust
- custom version.
+ * mm-util.el (mm-charset-override-alist, mm-charset-eval-alist):
+ Adjust custom version.
* gnus-draft.el (gnus-draft-mode): Don't call `mml-mode'.
@@ -4803,8 +9231,9 @@
2006-09-20 Maxime Edouard Robert Froumentin <max@lapin-bleu.net>
- (gnus-insert-mime-button, gnus-insert-mime-security-button): Apply
- gnus-article-button-face to MIME and security buttons.
+ * gnus-art.el (gnus-insert-mime-button)
+ (gnus-insert-mime-security-button):
+ Apply gnus-article-button-face to MIME and security buttons.
2006-09-20 Reiner Steib <Reiner.Steib@gmx.de>
@@ -4968,8 +9397,8 @@
2006-08-09 Katsumi Yamaoka <yamaoka@jpl.org>
* compface.el (uncompface): Make sure the eol conversion doesn't take
- place when communicating with the external programs. Reported by
- ARISAWA Akihiro <ari@mbf.ocn.ne.jp>.
+ place when communicating with the external programs.
+ Reported by ARISAWA Akihiro <ari@mbf.ocn.ne.jp>.
2006-07-31 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -5089,8 +9518,8 @@
(mml2015-function-alist): Add epg.
(mml2015-epg-passphrase-callback, mml2015-epg-decrypt)
(mml2015-epg-clear-decrypt, mml2015-epg-verify)
- (mml2015-epg-clear-verify, mml2015-epg-sign, mml2015-epg-encrypt): New
- functions.
+ (mml2015-epg-clear-verify, mml2015-epg-sign, mml2015-epg-encrypt):
+ New functions.
2006-07-08 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de>
@@ -5100,8 +9529,8 @@
2006-06-27 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de>
- * gnus-group.el (gnus-group-sort-by-unread): Fix typo. Reported by
- Kenneth Jacker <khj@be.cs.appstate.edu>.
+ * gnus-group.el (gnus-group-sort-by-unread): Fix typo.
+ Reported by Kenneth Jacker <khj@be.cs.appstate.edu>.
2006-06-26 Reiner Steib <Reiner.Steib@gmx.de>
@@ -5145,8 +9574,8 @@
nnmail-fix-eudora-headers.
(nnmail-fix-eudora-headers): Now obsolete.
- * gnus-art.el (gnus-button-handle-custom): Support
- `customize-apropos*'.
+ * gnus-art.el (gnus-button-handle-custom):
+ Support `customize-apropos*'.
2006-06-21 Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -5180,8 +9609,8 @@
(gnus-bookmark-write-file): Simplify.
(gnus-bookmark-maybe-sort-alist): Use `when'.
(gnus-bookmark-get-bookmark): Fix typo in doc string.
- (gnus-bookmark-set-bookmark-name, gnus-bookmark-get-bookmark): Add
- FIXME about Emacs 21 and XEmacs compatibility.
+ (gnus-bookmark-set-bookmark-name, gnus-bookmark-get-bookmark):
+ Add FIXME about Emacs 21 and XEmacs compatibility.
(gnus-bookmark-set-bookmark-name): Use `gnus-replace-in-string' for
compatibility.
(gnus-bookmark-bmenu-mode): Use `gnus-run-mode-hooks' for
@@ -5268,17 +9697,17 @@
2006-05-29 Kevin Greiner <kevin.greiner@compsol.cc>
- * gnus-agent.el: Added gnus-agent-flush* to purge agent info.
- (gnus-agent-read-agentview): Fixed handling of end-of-file error.
- (gnus-agent-read-local): All symbols allocated in my-obarray
+ * gnus-agent.el: Add gnus-agent-flush* to purge agent info.
+ (gnus-agent-read-agentview): Fix handling of end-of-file error.
+ (gnus-agent-read-local): All symbols allocated in my-obarray.
(gnus-agent-set-local): Skip invalid entries (min and/or max is nil).
(gnus-agent-regenerate-group): Check numeric names to see if they are
messages or groups.
(gnus-agent-total-fetched-for): Ignore 'dummy.group' (there should be a
better way of do this...)
- * gnus-cache.el (gnus-agent-total-fetched-for): Ignore
- 'dummy.group' (there should be a better way of do this...)
+ * gnus-cache.el (gnus-agent-total-fetched-for):
+ Ignore 'dummy.group' (there should be a better way of do this...)
2006-05-29 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -5308,8 +9737,8 @@
(gnus-article-mode): Use it.
(gnus-article-toggle-truncate-lines): New function.
- * gnus-sum.el (gnus-summary-wash-map, gnus-summary-make-menu-bar): Add
- gnus-article-toggle-truncate-lines.
+ * gnus-sum.el (gnus-summary-wash-map, gnus-summary-make-menu-bar):
+ Add gnus-article-toggle-truncate-lines.
* uudecode.el (uudecode-decode-region-external): nil isn't a valid
coding system in XEmacs, use binary.
@@ -5336,8 +9765,8 @@
2006-05-25 Katsumi Yamaoka <yamaoka@jpl.org>
- * gnus-art.el (gnus-default-article-saver): Add
- gnus-summary-write-body-to-file.
+ * gnus-art.el (gnus-default-article-saver):
+ Add gnus-summary-write-body-to-file.
(gnus-article-save-coding-system): Don't use coding system object
in XEmacs.
(gnus-read-save-file-name): Add optional `dir-var' argument which
@@ -5402,13 +9831,14 @@
* gnus-art.el (gnus-button-alist): Improve gnus-button-handle-symbol
entry.
- * gnus-sum.el (gnus-summary-make-menu-bar): Add
- gnus-article-browse-html-article.
+ * gnus-sum.el (gnus-summary-make-menu-bar):
+ Add gnus-article-browse-html-article.
2006-05-23 Hynek Schlawack <hynek@ularx.de>
- * gnus-sum.el (gnus-summary-mime-map): Add
- gnus-article-browse-html-article.
+ * gnus-sum.el (gnus-summary-mime-map):
+ Add gnus-article-browse-html-article.
+
2006-05-23 Reiner Steib <Reiner.Steib@gmx.de>
* gnus-sum.el (gnus-summary-save-article-coding-system): Offer some
@@ -5424,16 +9854,16 @@
(gnus-summary-expire-articles-now): Shorten prompt.
* gmm-utils.el (wid-edit): Require.
- (defun-gmm): Renamed from `gmm-defun-compat'.
+ (defun-gmm): Rename from `gmm-defun-compat'.
(gmm-image-search-load-path): Use it.
(gmm-image-load-path-for-library): Use it. Sync with `mh-compat.el'.
2006-05-17 Katsumi Yamaoka <yamaoka@jpl.org>
- * gnus-sum.el (gnus-summary-save-article-coding-system): New
- variable.
- (gnus-summary-save-article): Add optional `decode' argument. If
- it is set and gnus-summary-save-article-coding-system is non-nil,
+ * gnus-sum.el (gnus-summary-save-article-coding-system):
+ New variable.
+ (gnus-summary-save-article): Add optional `decode' argument.
+ If it is set and gnus-summary-save-article-coding-system is non-nil,
save decoded article.
(gnus-summary-write-article-file): Save decoded article if
gnus-summary-save-article-coding-system is non-nil.
@@ -5450,8 +9880,8 @@
* gnus-art.el (gnus-article-setup-buffer): Go to summary buffer
first to test gnus-single-article-buffer which may be buffer-local.
- * gnus-sum.el (gnus-summary-setup-buffer): Make
- gnus-single-article-buffer buffer-local and nil in ephemeral
+ * gnus-sum.el (gnus-summary-setup-buffer):
+ Make gnus-single-article-buffer buffer-local and nil in ephemeral
group; make gnus-article-buffer, gnus-article-current, and
gnus-original-article-buffer always buffer-local.
(gnus-summary-exit): Kill article buffer belonging to ephemeral
@@ -5486,8 +9916,8 @@
(message-signature-file, message-signature-insert-empty-line):
Remove autoloads.
- * gnus-art.el (gnus-buttonized-mime-types): Remove
- "multipart/signed". Revert 2006-04-26 change.
+ * gnus-art.el (gnus-buttonized-mime-types):
+ Remove "multipart/signed". Revert 2006-04-26 change.
2006-05-01 Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -5506,8 +9936,8 @@
* message.el (hashcash): Require hashcash as normal.
- * ecomplete.el (ecomplete-highlight-match-line): Use
- point-at-eol.
+ * ecomplete.el (ecomplete-highlight-match-line):
+ Use point-at-eol.
(ecomplete-highlight-match-line): Use `highlight', because that
face exists in both Emacs and XEmacs.
@@ -5564,8 +9994,8 @@
* message.el (message-citation-line-format): New variable.
(message-insert-formated-citation-line): New function.
- (message-citation-line-function): Add
- `message-insert-formated-citation-line' to custom type.
+ (message-citation-line-function):
+ Add `message-insert-formated-citation-line' to custom type.
* mm-decode.el (mm-verify-option): Add gnus-buttonized-mime-types
to doc string.
@@ -5624,8 +10054,8 @@
(message-mode): Ditto.
(message-strip-forbidden-properties): Ditto.
- * ecomplete.el (ecomplete-database-file-coding-system): New
- variable.
+ * ecomplete.el (ecomplete-database-file-coding-system):
+ New variable.
(ecomplete-save): Use it.
(ecomplete-setup): Use it.
@@ -5701,8 +10131,8 @@
* rfc2231.el (rfc2231-parse-string): Sort the parameters first.
- * message.el (message-forward-make-body-plain): Allow
- message-forward-ignored-headers to be a list.
+ * message.el (message-forward-make-body-plain):
+ Allow message-forward-ignored-headers to be a list.
(message-remove-ignored-headers): Factor out into function.
(message-forward-make-body-mml): Use it.
* rfc2231.el (rfc2231-parse-string): Remove dead code.
@@ -5740,8 +10170,8 @@
2006-04-16 Lars Magne Ingebrigtsen <larsi@gnus.org>
- * message.el (message-put-addresses-in-ecomplete): Use
- gnus-replace-in-string.
+ * message.el (message-put-addresses-in-ecomplete):
+ Use gnus-replace-in-string.
(message-is-yours-p): Use the more correct
mail-header-parse-address instead of
mail-extract-address-components.
@@ -5755,8 +10185,8 @@
* message.el (message-hidden-headers): Add X-Draft-From.
- * gnus-sum.el (gnus-summary-repeat-search-article-forward): New
- command.
+ * gnus-sum.el (gnus-summary-repeat-search-article-forward):
+ New command.
(gnus-summary-repeat-search-article-backward): New command.
* gnus-topic.el (gnus-topic-display-missing-topic): Skip past
@@ -5770,7 +10200,7 @@
2006-04-16 Lars Magne Ingebrigtsen <larsi@gnus.org>
- * gnus-art.el (gnus-face-properties-alist): Moved here from
+ * gnus-art.el (gnus-face-properties-alist): Move here from
gnus-fun.
* gnus-fun.el (gnus-face-properties-alist): Move to gnus-art.
@@ -5802,8 +10232,8 @@
2006-04-15 Lars Magne Ingebrigtsen <larsi@gnus.org>
- * hashcash.el (hashcash-insert-payment-async-2): Use
- message-goto-eoh instead of doing it manually.
+ * hashcash.el (hashcash-insert-payment-async-2):
+ Use message-goto-eoh instead of doing it manually.
(mail-add-payment): Use message-narrow-to-header instead of trying
to do the same itself.
@@ -5843,8 +10273,8 @@
* ecomplete.el (ecomplete-display-matches): Allow automatic
display.
- * message.el (message-strip-forbidden-properties): Display
- abbrevs.
+ * message.el (message-strip-forbidden-properties):
+ Display abbrevs.
(message-display-abbrev): Get automatic display right.
* ecomplete.el (ecomplete-display-matches): Use M-n/M-p
@@ -5855,15 +10285,15 @@
TODO: Backport to v5-10!
* gnus-util.el (gnus-alist-to-hashtable, gnus-hashtable-to-alist):
- Moved here (and renamed) from gnus-registry.el.
+ Move here (and rename) from gnus-registry.el.
* gnus-registry.el: Require gnus-util.
Use `gnus-alist-to-hashtable' and `gnus-hashtable-to-alist'.
2006-04-13 Lars Magne Ingebrigtsen <larsi@gnus.org>
- * gnus-group.el (gnus-group-catchup-current): Change
- if-then-else-if-then-else into cond.
+ * gnus-group.el (gnus-group-catchup-current):
+ Change if-then-else-if-then-else into cond.
(gnus-group-catchup): Indent.
(group-name-at-point): New function.
(gnus-fetch-group): Provide default from thing at point.
@@ -5872,8 +10302,8 @@
* message.el (message-display-abbrev): Fix regexp.
- * ecomplete.el (ecomplete-highlight-match-line): Reimplement
- choosing.
+ * ecomplete.el (ecomplete-highlight-match-line):
+ Reimplement choosing.
(ecomplete-highlight-match-line): Fix up code rewrite, remove
dead variables.
@@ -5882,8 +10312,8 @@
2006-04-12 Reiner Steib <Reiner.Steib@gmx.de>
- * gnus-art.el (gnus-article-mode): Set
- cursor-in-non-selected-windows to nil.
+ * gnus-art.el (gnus-article-mode):
+ Set cursor-in-non-selected-windows to nil.
* smiley.el: Revert previous change.
(smiley-data-directory): defvar it before using it in the
@@ -5900,8 +10330,8 @@
* ecomplete.el (ecomplete-add-item): Chop off decimals.
- * gnus-sum.el (gnus-summary-save-parts): Bind
- gnus-summary-save-parts-counter and use it to make unique file
+ * gnus-sum.el (gnus-summary-save-parts):
+ Bind gnus-summary-save-parts-counter and use it to make unique file
names.
* gnus-art.el (gnus-ignored-headers): Add some more headers.
@@ -6008,8 +10438,8 @@
2006-04-05 Daiki Ueno <ueno@unixuser.org>
- * pgg-gpg.el (pgg-gpg-encrypt-region, pgg-gpg-sign-region): Wait
- for BEGIN_SIGNING too, new in GnuPG 1.4.3.
+ * pgg-gpg.el (pgg-gpg-encrypt-region, pgg-gpg-sign-region):
+ Wait for BEGIN_SIGNING too, new in GnuPG 1.4.3.
2006-04-04 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de>
@@ -6019,8 +10449,8 @@
2006-04-04 Reiner Steib <Reiner.Steib@gmx.de>
- * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups): Check
- gnus-extra-headers for 'Newsgroups.
+ * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups):
+ Check gnus-extra-headers for 'Newsgroups.
* message.el (message-tool-bar-gnome): Check if `flyspell-mode' is
bound.
@@ -6068,8 +10498,8 @@
2006-03-27 Karl Kleinpaste <karl@charcoal.com>
- * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups): Improve
- newsgroups handling for NNTP overviews which don't include
+ * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups):
+ Improve newsgroups handling for NNTP overviews which don't include
Newsgroups.
2006-03-26 Andreas Seltenreich <uwi7@rz.uni-karlsruhe.de>
@@ -6195,8 +10625,8 @@
2006-03-14 Reiner Steib <Reiner.Steib@gmx.de>
- * gmm-utils.el (gmm-image-load-path-for-library): Fix typo. Use
- `defun' instead of `gmm-defun-compat'.
+ * gmm-utils.el (gmm-image-load-path-for-library): Fix typo.
+ Use `defun' instead of `gmm-defun-compat'.
2006-03-14 Simon Josefsson <jas@extundo.com>
@@ -6281,8 +10711,8 @@
* gnus-group.el (gnus-group-make-tool-bar): Use add-hook.
Suggested by Stefan Monnier <monnier@iro.umontreal.ca>.
- * gnus-art.el (gnus-article-browse-delete-temp-files): Simplify
- resetting gnus-article-browse-html-temp-list.
+ * gnus-art.el (gnus-article-browse-delete-temp-files):
+ Simplify resetting gnus-article-browse-html-temp-list.
* gmm-utils.el (gmm-image-load-path-for-library): Sync with
mh-compat.el at 2006-03-04T21:23:21Z!wohler@newt.com in Emacs. Rename `gmm-image-load-path'.
@@ -6327,12 +10757,12 @@
* gnus-art.el (gnus-article-browse-html-temp-list): Rename from
gnus-article-browse-html-temp.
- (gnus-article-browse-delete-temp): Make it customizable. Add
- `file'. Adjust doc string.
- (gnus-article-browse-delete-temp-files): Add argument. Allow
- query for each file. Adjust doc string.
- (gnus-article-browse-html-parts): Add
- `gnus-article-browse-delete-temp-files' to
+ (gnus-article-browse-delete-temp): Make it customizable.
+ Add `file'. Adjust doc string.
+ (gnus-article-browse-delete-temp-files): Add argument.
+ Allow query for each file. Adjust doc string.
+ (gnus-article-browse-html-parts):
+ Add `gnus-article-browse-delete-temp-files' to
`gnus-summary-prepare-exit-hook' and `gnus-exit-gnus-hook'.
2006-03-02 Hynek Schlawack <hynek@ularx.de>
@@ -6350,8 +10780,8 @@
string.
* gnus-sum.el (gnus-summary-tool-bar-gnome): Don't use
- gnus-summary-insert-new-articles when unplugged. Remove
- gnus-summary-search-article-forward.
+ gnus-summary-insert-new-articles when unplugged.
+ Remove gnus-summary-search-article-forward.
* gmm-utils.el (gmm-tool-bar-style): Test tool-bar-mode and
display-visual-class instead of display-color-cells.
@@ -6401,8 +10831,8 @@
* gnus-art.el (gnus-button): New face.
(gnus-article-button-face): Use it.
- * gnus-sum.el (gnus-summary-tool-bar-gnome): Add
- gnus-summary-next-page. Re-order.
+ * gnus-sum.el (gnus-summary-tool-bar-gnome):
+ Add gnus-summary-next-page. Re-order.
* gnus-group.el (gnus-group-tool-bar-gnome): prev-node and
next-node are now included.
@@ -6415,8 +10845,8 @@
* spam.el (spam-spamassassin-score-regexp): New internal variable.
(spam-extra-header-to-number, spam-check-spamassassin-headers):
- Use it to match format of Spamassassin 3.0 and later. Reported by
- IRIE Tetsuya <irie@t.email.ne.jp>.
+ Use it to match format of Spamassassin 3.0 and later.
+ Reported by IRIE Tetsuya <irie@t.email.ne.jp>.
(spam-check-bogofilter)
(spam-bogofilter-register-with-bogofilter): Fix args of
`gnus-error' calls.
@@ -6424,8 +10854,8 @@
2006-02-28 Reiner Steib <Reiner.Steib@gmx.de>
* gnus-draft.el (gnus-draft-send): Bind message-signature to avoid
- unnecessary interaction when sending queued mails. Reported by
- TAKAHASHI Yoshio <tkh@jp.fujitsu.com>.
+ unnecessary interaction when sending queued mails.
+ Reported by TAKAHASHI Yoshio <tkh@jp.fujitsu.com>.
2006-02-27 Reiner Steib <Reiner.Steib@gmx.de>
@@ -6460,17 +10890,17 @@
2006-02-23 Reiner Steib <Reiner.Steib@gmx.de>
- * gnus-group.el (gnus-group-tool-bar-gnome): Fix
- gnus-agent-toggle-plugged. Re-order icons.
- (gnus-group-tool-bar-gnome): Add
- gnus-group-{prev,next}-unread-group.
+ * gnus-group.el (gnus-group-tool-bar-gnome):
+ Fix gnus-agent-toggle-plugged. Re-order icons.
+ (gnus-group-tool-bar-gnome):
+ Add gnus-group-{prev,next}-unread-group.
(gnus-group-tool-bar-gnome): Re-order icons.
- * gnus-sum.el (gnus-summary-tool-bar-gnome): Move
- gnus-summary-insert-new-articles.
+ * gnus-sum.el (gnus-summary-tool-bar-gnome):
+ Move gnus-summary-insert-new-articles.
- * message.el (message-tool-bar-gnome, message-tool-bar-retro): Fix
- comments.
+ * message.el (message-tool-bar-gnome, message-tool-bar-retro):
+ Fix comments.
* utf7.el (utf7-utf-16-coding-system): Fix comment. utf-16-be is
also available in Emacs 21.3.
@@ -6523,7 +10953,7 @@
* message.el (message-make-tool-bar): Ditto.
- * mml.el (mml-preview): Added comment concerning tool bar icons.
+ * mml.el (mml-preview): Add comment concerning tool bar icons.
* gnus-group.el (gnus-group-tool-bar-gnome): Use new icon names.
(gnus-group-make-tool-bar): Use `gmm-image-load-path'.
@@ -6534,10 +10964,10 @@
* message.el (message-tool-bar-gnome): Use new icon names.
(message-make-tool-bar): Use `gmm-image-load-path'.
- * gmm-utils.el (gmm-defun-compat, gmm-image-search-load-path): New
- functions from MH-E.
+ * gmm-utils.el (gmm-defun-compat, gmm-image-search-load-path):
+ New functions from MH-E.
(gmm-image-load-path): New variable from MH-E.
- (gmm-image-load-path): New function from MH-E. Added arguments
+ (gmm-image-load-path): New function from MH-E. Add arguments
LIBRARY, IMAGE and PATH. Don't modify paths. Don't use
*-image-load-path-called-flag.
@@ -6554,8 +10984,8 @@
* mm-util.el (mm-charset-override-alist): Fix type in doc string.
- * gnus-art.el (mm-url-insert-file-contents-external): Autoload
- mm-url.
+ * gnus-art.el (mm-url-insert-file-contents-external):
+ Autoload mm-url.
* mm-uu.el (mm-uu-type-alist): Improve `LaTeX'.
@@ -6576,13 +11006,13 @@
2006-02-17 Katsumi Yamaoka <yamaoka@jpl.org>
- * gnus-art.el (article-strip-banner): Call
- article-really-strip-banner only when the regexp match is made.
+ * gnus-art.el (article-strip-banner):
+ Call article-really-strip-banner only when the regexp match is made.
2006-02-16 Katsumi Yamaoka <yamaoka@jpl.org>
- * gnus-art.el (article-strip-banner): Use
- gnus-extract-address-components instead of
+ * gnus-art.el (article-strip-banner):
+ Use gnus-extract-address-components instead of
mail-header-parse-addresses to make it work with non-ASCII text;
remove mail-encode-encoded-word-string.
@@ -6674,8 +11104,8 @@
2006-02-08 Katsumi Yamaoka <yamaoka@jpl.org>
- * nnfolder.el (nnfolder-insert-newsgroup-line): Use
- message-make-date instead of current-time-string.
+ * nnfolder.el (nnfolder-insert-newsgroup-line):
+ Use message-make-date instead of current-time-string.
* mm-view.el (mm-inline-message): Don't set gnus-newsgroup-charset
to gnus-decoded which mm-uu might set.
@@ -6822,8 +11252,8 @@
2006-01-26 Steve Youngs <steve@sxemacs.org>
- * gmm-utils.el (gmm-tool-bar-item, gmm-tool-bar-zap-list): Don't
- autoload.
+ * gmm-utils.el (gmm-tool-bar-item, gmm-tool-bar-zap-list):
+ Don't autoload.
2006-01-26 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -6840,8 +11270,8 @@
`gmm-tool-bar-from-list'.
* gnus-group.el (gnus-group-tool-bar, gnus-group-tool-bar-gnome)
- (gnus-group-tool-bar-retro, gnus-group-tool-bar-zap-list): New
- variables.
+ (gnus-group-tool-bar-retro, gnus-group-tool-bar-zap-list):
+ New variables.
(gnus-group-make-tool-bar): Complete rewrite using
`gmm-tool-bar-from-list'.
(gnus-group-tool-bar-update): New function.
@@ -6891,13 +11321,13 @@
(mm-inline-text-html-render-with-w3m-standalone): Use it to alter
w3m usage.
- * gnus-art.el (gnus-article-wash-html-with-w3m-standalone): Use
- mm-w3m-standalone-supports-m17n-p to alter w3m usage.
+ * gnus-art.el (gnus-article-wash-html-with-w3m-standalone):
+ Use mm-w3m-standalone-supports-m17n-p to alter w3m usage.
2006-01-23 Reiner Steib <Reiner.Steib@gmx.de>
- * message.el (message-tool-bar-zap-list): Use
- gmm-tool-bar-zap-list as custom type.
+ * message.el (message-tool-bar-zap-list):
+ Use gmm-tool-bar-zap-list as custom type.
(message-tool-bar-update): New function.
(message-tool-bar, message-tool-bar-gnome)
(message-tool-bar-retro): Add message-tool-bar-update.
@@ -7017,8 +11447,8 @@
2006-01-13 Katsumi Yamaoka <yamaoka@jpl.org>
- * gnus-art.el (article-wash-html): Use
- gnus-summary-show-article-charset-alist if a numeric arg is given.
+ * gnus-art.el (article-wash-html):
+ Use gnus-summary-show-article-charset-alist if a numeric arg is given.
(gnus-article-wash-html-with-w3m-standalone): New function.
* mm-view.el (mm-text-html-renderer-alist): Map w3m-standalone to
@@ -7045,8 +11475,8 @@
* gnus-cus.el (gnus-group-parameters): Sync posting-style with
custom definition of `gnus-posting-styles'.
- * gnus-start.el (gnus-gnus-to-quick-newsrc-format): Bind
- print-circle. Suggested by Kalle Olavi Niemitalo <kon@iki.fi>.
+ * gnus-start.el (gnus-gnus-to-quick-newsrc-format):
+ Bind print-circle. Suggested by Kalle Olavi Niemitalo <kon@iki.fi>.
2006-01-05 Reiner Steib <Reiner.Steib@gmx.de>
@@ -7133,8 +11563,8 @@
`customize-apropos' for any "M-x customize-*" button but the
function called for. Accept both the function name and its
argument in order to achieve this.
- (gnus-button-alist): Remove support for "custom:" URL's. Pass
- function name to `gnus-button-handle-custom' in case of "M-x
+ (gnus-button-alist): Remove support for "custom:" URL's.
+ Pass function name to `gnus-button-handle-custom' in case of "M-x
customize-*" buttons.
2005-12-12 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -7163,11 +11593,11 @@
2005-12-12 Katsumi Yamaoka <yamaoka@jpl.org>
- * rfc2047.el (rfc2047-charset-to-coding-system): Recognize
- us-ascii as a MIME charset.
+ * rfc2047.el (rfc2047-charset-to-coding-system):
+ Recognize us-ascii as a MIME charset.
- * mm-bodies.el (mm-decode-content-transfer-encoding): Protect
- against the case where the 2nd arg TYPE is nil.
+ * mm-bodies.el (mm-decode-content-transfer-encoding):
+ Protect against the case where the 2nd arg TYPE is nil.
2005-12-09 Reiner Steib <Reiner.Steib@gmx.de>
@@ -7195,8 +11625,8 @@
* gnus-fun.el (gnus-face-from-file): Decrease quant in smaller
steps when < 10.
- * gnus-start.el (gnus-no-server-1): Mention
- `gnus-level-default-subscribed' in doc string.
+ * gnus-start.el (gnus-no-server-1):
+ Mention `gnus-level-default-subscribed' in doc string.
2005-12-02 ARISAWA Akihiro <ari@mbf.ocn.ne.jp> (tiny change)
@@ -7304,8 +11734,8 @@
2005-11-12 Kevin Greiner <kevin.greiner@compsol.cc>
- * gnus-agent.el (gnus-agent-article-alist-save-format): Changed
- internal variable to a custom variable. Changed default value
+ * gnus-agent.el (gnus-agent-article-alist-save-format):
+ Change internal variable to a custom variable. Change default value
from compressed(2) to uncompressed(1).
(gnus-agent-read-agentview): Reversed revision 7.8 to restore
support for uncompressed agentview files. Taken together, reading
@@ -7319,12 +11749,12 @@
2005-12-09 Reiner Steib <Reiner.Steib@gmx.de>
- * gnus-start.el (gnus-start-draft-setup): Enforce
- `gnus-draft-mode' for nndraft:drafts at startup.
+ * gnus-start.el (gnus-start-draft-setup):
+ Enforce `gnus-draft-mode' for nndraft:drafts at startup.
* gnus.el (gnus-splash): Change custom group.
- (gnus-group-get-parameter, gnus-group-parameter-value): Describe
- allow-list argument.
+ (gnus-group-get-parameter, gnus-group-parameter-value):
+ Describe allow-list argument.
* gnus-agent.el (gnus-agent-article-alist-save-format): Format doc
string.
@@ -7529,8 +11959,8 @@
* mm-uu.el (mm-uu-verbatim-marks-extract): Add four start and end
arguments.
- (mm-uu-type-alist): Add message-marks and insert-marks. Pass
- arguments to mm-uu-verbatim-marks-extract.
+ (mm-uu-type-alist): Add message-marks and insert-marks.
+ Pass arguments to mm-uu-verbatim-marks-extract.
(mm-uu-hide-markers): New variable.
(mm-uu-extract): Use face similar to `gnus-cite-3'.
@@ -7569,8 +11999,8 @@
* message.el (message-tool-bar-local-item-from-menu): Fix comment.
- * mm-bodies.el (mm-decode-string): Call
- `mm-charset-to-coding-system' with allow-override argument.
+ * mm-bodies.el (mm-decode-string):
+ Call `mm-charset-to-coding-system' with allow-override argument.
2005-10-19 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -7597,7 +12027,7 @@
2005-10-15 Bill Wohler <wohler@newt.com>
- * message.el (message-tool-bar-map): Renamed image file from
+ * message.el (message-tool-bar-map): Rename image file from
mail_send to mail/send.
2005-10-16 Masatake YAMATO <jet@gyve.org>
@@ -7609,14 +12039,14 @@
* mml-sec.el (mml-secure-method): New internal variable.
(mml-secure-sign, mml-secure-encrypt, mml-secure-message-sign)
- (mml-secure-message-sign-encrypt, mml-secure-message-encrypt): New
- functions using mml-secure-method.
+ (mml-secure-message-sign-encrypt, mml-secure-message-encrypt):
+ New functions using mml-secure-method.
* mml.el (mml-mode-map): Add key bindings for those functions.
(mml-menu): Simplify security menu entries. Suggested by Jesper
Harder <harder@myrealbox.com>.
- (mml-attach-file, mml-attach-buffer, mml-attach-external): Goto
- end of message if point is the headers of the message.
+ (mml-attach-file, mml-attach-buffer, mml-attach-external):
+ Goto end of message if point is the headers of the message.
* message.el (message-in-body-p): New function.
@@ -7625,8 +12055,8 @@
* mm-util.el (mm-charset-to-coding-system): Add allow-override.
Use `mm-charset-override-alist' only when decoding.
- * mm-bodies.el (mm-decode-body): Call
- `mm-charset-to-coding-system' with allow-override argument.
+ * mm-bodies.el (mm-decode-body):
+ Call `mm-charset-to-coding-system' with allow-override argument.
* gnus-art.el (gnus-mime-view-part-as-type-internal): Try to fetch
`filename' from Content-Disposition if Content-Type doesn't
@@ -7649,8 +12079,8 @@
(mm-charset-to-coding-system): Use it.
(mm-codepage-setup): New helper function.
(mm-charset-eval-alist): New variable.
- (mm-charset-to-coding-system): Use mm-charset-eval-alist. Warn
- about unknown charsets.
+ (mm-charset-to-coding-system): Use mm-charset-eval-alist.
+ Warn about unknown charsets.
2005-10-04 David Hansen <david.hansen@gmx.net>
@@ -7704,15 +12134,15 @@
2005-09-29 Simon Josefsson <jas@extundo.com>
- * spam.el: Load hashcash when compiling, to avoid warnings. Don't
- autoload mail-check-payment.
+ * spam.el: Load hashcash when compiling, to avoid warnings.
+ Don't autoload mail-check-payment.
(spam-check-hashcash): Define unconditionally, since hashcash.el
is part of Gnus now. Ignore errors from payment checking.
2005-09-28 Reiner Steib <Reiner.Steib@gmx.de>
- * message.el (message-bold-region, message-unbold-region): Rename
- from `bold-region' and `unbold-region'.
+ * message.el (message-bold-region, message-unbold-region):
+ Rename from `bold-region' and `unbold-region'.
* message.el: Remove useless autoloads.
@@ -7809,20 +12239,20 @@
* gnus-agent.el (gnus-agent-synchronize-flags): Explain why the
default value is nil.
- * mm-uu.el (mm-uu-type-alist): Added slrn style verbatim-marks.
+ * mm-uu.el (mm-uu-type-alist): Add slrn style verbatim-marks.
(mm-uu-verbatim-marks-extract): New function.
(mm-uu-extract): New face.
(mm-uu-copy-to-buffer): Use it.
- * spam-report.el (spam-report-gmane-ham): Renamed from
+ * spam-report.el (spam-report-gmane-ham): Rename from
`spam-report-gmane-unspam'.
- (spam-report-gmane-internal): Renamed from `spam-report-gmane'.
+ (spam-report-gmane-internal): Rename from `spam-report-gmane'.
Simplify use of UNSPAM argument. Fetch "X-Report-Unspam" header.
* spam.el (spam-report-gmane-spam, spam-report-gmane-ham):
Autoload.
- (spam-report-gmane-unregister-routine): Renamed
- `spam-report-gmane-unspam' to `spam-report-gmane-ham'.
+ (spam-report-gmane-unregister-routine):
+ Rename `spam-report-gmane-unspam' to `spam-report-gmane-ham'.
2005-09-21 Teodor Zlatanov <tzz@lifelogs.com>
@@ -7860,11 +12290,11 @@
* gnus-art.el (gnus-article-replace-part)
(gnus-mime-replace-part): New functions.
(gnus-mime-action-alist, gnus-mime-button-commands)
- (gnus-mime-save-part-and-strip): Added file argument.
- (gnus-article-part-wrapper): Added interactive argument.
+ (gnus-mime-save-part-and-strip): Add file argument.
+ (gnus-article-part-wrapper): Add interactive argument.
- * gnus-sum.el (gnus-summary-mime-map): Add
- `gnus-article-replace-part'.
+ * gnus-sum.el (gnus-summary-mime-map):
+ Add `gnus-article-replace-part'.
2005-09-19 Didier Verna <didier@xemacs.org>
@@ -7913,8 +12343,8 @@
(message-setup-1): Call `message-use-alternative-email-as-from'
after `message-setup-hook' to give it precedence over posting
styles, etc.
- (message-use-alternative-email-as-from): Add docstring. Remove
- the original From header if present.
+ (message-use-alternative-email-as-from): Add docstring.
+ Remove the original From header if present.
* nnml.el (nnml-compressed-files-size-threshold): New variable.
(nnml-save-mail): Use it.
@@ -7988,13 +12418,13 @@
2005-09-04 Reiner Steib <Reiner.Steib@gmx.de>
- * mml.el (mml-dnd-protocol-alist, mml-dnd-attach-options): New
- variables.
+ * mml.el (mml-dnd-protocol-alist, mml-dnd-attach-options):
+ New variables.
(mml-dnd-attach-file, mml-mode): Use them.
* nnweb.el (nnweb-type-definition, nnweb-google-wash-article):
- Make fetching article by MID work again for Google Groups. Added
- FIXME concerning gnus-group-make-web-group.
+ Make fetching article by MID work again for Google Groups.
+ Add FIXME concerning gnus-group-make-web-group.
* mml-smime.el (mml-smime-sign-query, mml-smime-get-dns-cert):
Don't depend on Gnus by using mail-extract-address-components if
@@ -8014,8 +12444,8 @@
2005-09-02 Hrvoje Niksic <hniksic@xemacs.org>
- * mm-encode.el (mm-encode-content-transfer-encoding): Likewise
- when encoding.
+ * mm-encode.el (mm-encode-content-transfer-encoding):
+ Likewise when encoding.
* mm-bodies.el (mm-decode-content-transfer-encoding):
De-canonicalize CRLF for all text content types, not just
@@ -8035,20 +12465,20 @@
2005-08-29 Jari Aalto <jari.aalto@cante.net>
- * gnus-msg.el (gnus-inews-add-send-actions): Made
- `message-post-method' lambda parameter ARG `&optional'.
+ * gnus-msg.el (gnus-inews-add-send-actions):
+ Make `message-post-method' lambda parameter ARG `&optional'.
2005-08-29 Reiner Steib <Reiner.Steib@gmx.de>
- * gnus-sum.el (gnus-summary-mime-map): Added
- gnus-article-save-part-and-strip, gnus-article-delete-part and
+ * gnus-sum.el (gnus-summary-mime-map):
+ Add gnus-article-save-part-and-strip, gnus-article-delete-part and
gnus-article-jump-to-part.
- * gnus-art.el (gnus-article-edit-article): Added quiet argument.
+ * gnus-art.el (gnus-article-edit-article): Add quiet argument.
(gnus-article-edit-part): Use it.
- (gnus-article-part-wrapper): Added no-handle argument.
- (gnus-article-save-part-and-strip, gnus-article-delete-part): New
- functions.
+ (gnus-article-part-wrapper): Add no-handle argument.
+ (gnus-article-save-part-and-strip, gnus-article-delete-part):
+ New functions.
2005-08-29 Romain Francoise <romain@orebokech.com>
@@ -8111,7 +12541,7 @@
* pgg.el (url-insert-file-contents): Don't autoload it, Emacs has
it in url-handlers.el and XEmacs in url.el. Reported by Luca
Capello and Romain Francoise.
- (pgg-fetch-key-function): Removed, not used?
+ (pgg-fetch-key-function): Remove, not used?
(pgg-insert-url-with-w3): Require url, to get
url-insert-file-contents regardless of where it is defined.
@@ -8168,8 +12598,8 @@
2005-08-02 Katsumi Yamaoka <yamaoka@jpl.org>
- * sieve-manage.el (sieve-manage-interactive-login): Use
- make-local-variable rather than make-variable-buffer-local.
+ * sieve-manage.el (sieve-manage-interactive-login):
+ Use make-local-variable rather than make-variable-buffer-local.
(sieve-manage-open): Ditto.
(sieve-manage-authenticate): Ditto.
@@ -8277,8 +12707,8 @@
2005-07-16 Lars Magne Ingebrigtsen <larsi@gnus.org>
- * gnus-msg.el (gnus-button-mailto): Remove
- save-selected-window-window hackery because it relies on
+ * gnus-msg.el (gnus-button-mailto):
+ Remove save-selected-window-window hackery because it relies on
save-selected-window internals.
2005-07-15 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -8292,14 +12722,14 @@
2005-07-14 Hiroshi Fujishima <hiroshi.fujishima@gmail.com> (tiny change)
- * gnus-score.el (gnus-score-edit-all-score): Set
- gnus-score-edit-exit-function to gnus-score-edit-done and call
+ * gnus-score.el (gnus-score-edit-all-score):
+ Set gnus-score-edit-exit-function to gnus-score-edit-done and call
gnus-message.
2005-07-14 Lars Magne Ingebrigtsen <larsi@gnus.org>
- * gnus-msg.el (gnus-button-mailto): Remove
- save-selected-window-window hackery because it relies on
+ * gnus-msg.el (gnus-button-mailto):
+ Remove save-selected-window-window hackery because it relies on
save-selected-window internals.
2005-07-13 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -8860,8 +13290,8 @@
2005-04-21 Reiner Steib <Reiner.Steib@gmx.de>
- * message.el (message-kill-buffer-query): Renamed from
- `message-kill-buffer-query-if-modified'. Added :version.
+ * message.el (message-kill-buffer-query): Rename from
+ `message-kill-buffer-query-if-modified'. Add :version.
2005-04-19 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -8933,7 +13363,7 @@
to get all the groups a message ID is in.
* spam-stat.el (spam-stat-split-fancy-spam-threshold)
- (spam-stat-split-fancy): Change "threshhold" to "threshold"
+ (spam-stat-split-fancy): Change "threshhold" to "threshold".
(spam-stat-score-buffer-user-functions): Add :number custom type.
2005-04-06 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -9039,8 +13469,8 @@
2005-03-09 Lars Magne Ingebrigtsen <larsi@gnus.org>
- * gnus-msg.el (gnus-confirm-mail-reply-to-news): Add
- gnus-expert-user to default.
+ * gnus-msg.el (gnus-confirm-mail-reply-to-news):
+ Add gnus-expert-user to default.
2005-03-08 Juergen Kreileder <jk@blackdown.de> (tiny change)
@@ -9056,12 +13486,12 @@
2005-03-06 Kevin Greiner <kevin.greiner@compsol.cc>
- * gnus-start.el (gnus-convert-old-newsrc): Fixed numeric
+ * gnus-start.el (gnus-convert-old-newsrc): Fix numeric
comparison on string.
* gnus-agent.el (gnus-agent-long-article, gnus-agent-short-article)
- (gnus-agent-score): Renamed category keywords to match gnus-cus.
- (gnus-agent-summary-fetch-series): Modified to protect against
+ (gnus-agent-score): Rename category keywords to match gnus-cus.
+ (gnus-agent-summary-fetch-series): Modify to protect against
gnus-agent-summary-fetch-group clearing processable flags.
(gnus-agent-synchronize-group-flags): Update live group buffer as
synchronization may occur due to the user toggle the plugged
@@ -9070,10 +13500,10 @@
successfully downloaded.
(gnus-agent-expire-group-1): Avoid using markers when the overview
is in ascending order; greatly improves performance.
- (gnus-agent-regenerate-group): Use
- gnus-agent-synchronize-group-flags to reset read status in both
+ (gnus-agent-regenerate-group):
+ Use gnus-agent-synchronize-group-flags to reset read status in both
gnus and server.
- (gnus-agent-update-files-total-fetched-for): Fixed initial size.
+ (gnus-agent-update-files-total-fetched-for): Fix initial size.
2005-03-04 Reiner Steib <Reiner.Steib@gmx.de>
@@ -9158,13 +13588,13 @@
2005-02-25 Teodor Zlatanov <tzz@lifelogs.com>
- * gnus-sum.el (gnus-summary-move-article): Set
- gnus-sum-hint-move-is-internal for gnus-request-move-article and
+ * gnus-sum.el (gnus-summary-move-article):
+ Set gnus-sum-hint-move-is-internal for gnus-request-move-article and
whatever it calls (right now, only nnimap-request-move article
respects it).
- * nnimap.el (nnimap-request-move-article): When
- gnus-sum-hint-move-is-internal is set, don't do the extra
+ * nnimap.el (nnimap-request-move-article):
+ When gnus-sum-hint-move-is-internal is set, don't do the extra
nnimap-request-article.
2005-02-24 Reiner Steib <Reiner.Steib@gmx.de>
@@ -9210,7 +13640,7 @@
2005-02-21 Arne Jørgensen <arne@arnested.dk>
- * nnrss.el (nnrss-verbose): Removed.
+ * nnrss.el (nnrss-verbose): Remove.
(nnrss-request-group): Use `nnheader-message' instead.
2005-02-19 Mark Plaksin <happy@usg.edu> (tiny change)
@@ -9268,7 +13698,7 @@
* smime.el (smime-cert-by-dns): Add doc-string.
(smime-cert-by-ldap-1): Indent.
- * mml-smime.el (mml-smime-get-ldap-cert): Renamed from
+ * mml-smime.el (mml-smime-get-ldap-cert): Rename from
mml-smime-get-dns-ldap.
(mml-smime-encrypt-query): Use new function. Default to ldap.
@@ -9336,8 +13766,8 @@
* mm-view.el (mm-display-inline-fontify): Allow the name parameter
as well as the filename parameter.
- * mm-util.el (mm-decompress-buffer): Merge
- gnus-mime-jka-compr-maybe-uncompress.
+ * mm-util.el (mm-decompress-buffer):
+ Merge gnus-mime-jka-compr-maybe-uncompress.
(mm-find-buffer-file-coding-system): Doc fix; force decompressing
of compressed data.
@@ -9421,7 +13851,7 @@
2005-01-26 Steve Youngs <steve@sxemacs.org>
- * run-at-time.el: Removed. It is no longer needed as
+ * run-at-time.el: Remove. It is no longer needed as
timer-funcs.el in the xemacs-base package has a working version of
`run-at-time'.
@@ -9505,8 +13935,8 @@
2005-01-10 Reiner Steib <Reiner.Steib@gmx.de>
* gnus.el (gnus-user-agent): Use list of symbols instead of
- symbols. Display full version number for (S)XEmacs. Optionally
- display (S)XEmacs codename.
+ symbols. Display full version number for (S)XEmacs.
+ Optionally display (S)XEmacs codename.
* gnus-util.el (gnus-emacs-version): Update for new
`gnus-user-agent'.
@@ -9718,12 +14148,12 @@
2004-11-25 Reiner Steib <Reiner.Steib@gmx.de>
- * message.el (message-forbidden-properties): Fixed typo in doc
+ * message.el (message-forbidden-properties): Fix typo in doc
string.
2004-11-25 Reiner Steib <Reiner.Steib@gmx.de>
- * gnus-util.el (gnus-replace-in-string): Added doc string.
+ * gnus-util.el (gnus-replace-in-string): Add doc string.
* nnmail.el (nnmail-split-header-length-limit): Increase to 2048
to avoid problems when splitting mails with many recipients.
@@ -9741,8 +14171,8 @@
2004-12-03 Reiner Steib <Reiner.Steib@gmx.de>
- * gnus-sum.el (gnus-summary-limit-to-recipient): Implement
- not-matching option.
+ * gnus-sum.el (gnus-summary-limit-to-recipient):
+ Implement not-matching option.
2004-12-02 Reiner Steib <Reiner.Steib@gmx.de>
@@ -9861,8 +14291,8 @@
2004-11-23 Lars Magne Ingebrigtsen <larsi@gnus.org>
- * message.el (message-strip-forbidden-properties): Bind
- buffer-read-only (etc) to nil.
+ * message.el (message-strip-forbidden-properties):
+ Bind buffer-read-only (etc) to nil.
2004-11-23 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -9917,21 +14347,21 @@
2004-11-14 Magnus Henoch <mange@freemail.hu>
- * hashcash.el (hashcash-default-payment): Change default to 20
- (hashcash-default-accept-payment): Change default to 20
- (hashcash-process-alist): New variable
- (hashcash-generate-payment-async): Add
- (hashcash-already-paid-p): Add
- (hashcash-insert-payment): Don't generate payments twice
- (hashcash-insert-payment-async): Add
- (hashcash-insert-payment-async-2): Add
- (hashcash-cancel-async): Add
- (hashcash-wait-async): Add
- (hashcash-processes-running-p): Add
- (hashcash-wait-or-cancel): Add
+ * hashcash.el (hashcash-default-payment): Change default to 20.
+ (hashcash-default-accept-payment): Change default to 20.
+ (hashcash-process-alist): New variable.
+ (hashcash-generate-payment-async): Add.
+ (hashcash-already-paid-p): Add.
+ (hashcash-insert-payment): Don't generate payments twice.
+ (hashcash-insert-payment-async): Add.
+ (hashcash-insert-payment-async-2): Add.
+ (hashcash-cancel-async): Add.
+ (hashcash-wait-async): Add.
+ (hashcash-processes-running-p): Add.
+ (hashcash-wait-or-cancel): Add.
(mail-add-payment): New optional argument. Conditionally start
asynchronous calculation.
- (mail-add-payment-async): Add
+ (mail-add-payment-async): Add.
* message.el (message-send-mail): Wait for asynchronous hashcash
results. Don't clobber existing X-Hashcash headers.
@@ -10069,8 +14499,8 @@
* deuglify.el (gnus-outlook-deuglify): Add :version.
- * html2text.el: Beautify code. Improve doc strings. Some
- checkdoc cleanup.
+ * html2text.el: Beautify code. Improve doc strings.
+ Some checkdoc cleanup.
(html2text-get-attr, html2text-fix-paragraph): Simplify code.
2004-11-01 Alfred M. Szmidt <ams@kemisten.nu> (tiny change)
@@ -10086,8 +14516,8 @@
for people who want to override the default SpamAssassin over
Bogofilter preference (when both are set).
(spam-necessary-extra-headers): Add spam-use-bogofilter as an option.
- (spam-user-format-function-S): Check
- spam-summary-score-preferred-header.
+ (spam-user-format-function-S):
+ Check spam-summary-score-preferred-header.
(spam-extra-header-to-number): Add X-Bogosity header parsing.
(spam-user-format-function-S): Format the score correctly.
@@ -10184,7 +14614,7 @@
2004-10-18 Reiner Steib <Reiner.Steib@gmx.de>
* gnus-art.el (gnus-copy-article-ignored-headers): Default to
- nil. Changed custom type.
+ nil. Change custom type.
2004-10-17 Reiner Steib <Reiner.Steib@gmx.de>
@@ -10236,8 +14666,8 @@
* netrc.el (netrc-machine-user-or-password): Add convenience wrapper
for netrc-machine.
- * nnimap.el (nnimap-open-connection): Use
- netrc-machine-user-or-password.
+ * nnimap.el (nnimap-open-connection):
+ Use netrc-machine-user-or-password.
2004-10-17 Richard M. Stallman <rms@gnu.org>
@@ -10290,7 +14720,7 @@
* pop3.el (pop3-maildrop, pop3-mailhost, pop3-port)
(pop3-password-required, pop3-authentication-scheme)
- (pop3-leave-mail-on-server): Made customizable.
+ (pop3-leave-mail-on-server): Make customizable.
(pop3): New custom group.
(pop3-retr): Remove `sleep-for' statements.
Suggested by Dave Love <fx@gnu.org>.
@@ -10299,8 +14729,8 @@
Windows/DOS.
* imap.el (imap-parse-flag-list, imap-parse-body-extension)
- (imap-parse-body): Fix incorrect use of `assert'. Suggested by
- Dave Love <fx@gnu.org>.
+ (imap-parse-body): Fix incorrect use of `assert'.
+ Suggested by Dave Love <fx@gnu.org>.
* mml.el (mml-minibuffer-read-disposition): Require match.
Suggested by Dave Love <fx@gnu.org>.
@@ -10359,8 +14789,8 @@
* mm-decode.el (mm-dissect-singlepart): Revert 2004-08-18 change.
- * gnus-topic.el (gnus-topic-hierarchical-parameters): Use
- gnus-current-topics instead of gnus-current-topic.
+ * gnus-topic.el (gnus-topic-hierarchical-parameters):
+ Use gnus-current-topics instead of gnus-current-topic.
2004-10-06 Jesper Harder <harder@ifa.au.dk>
@@ -10419,7 +14849,7 @@
(nnsoup-unpack-packets, nnsoup-make-active): Simplify.
* nnspool.el (nnspool-find-id): Use with-temp-buffer.
- (nnspool-sift-nov-with-sed): Use last
+ (nnspool-sift-nov-with-sed): Use last.
(nnspool-retrieve-headers-with-nov): Use mapc.
(nnspool-request-newgroups): Use dolist.
(nnspool-request-group): Use last.
@@ -10432,8 +14862,8 @@
2004-10-01 Kevin Greiner <kgreiner@compsol.cc>
- * gnus-agent.el (gnus-agent-synchronize-group-flags): Added
- support for sync'ing tick marks.
+ * gnus-agent.el (gnus-agent-synchronize-group-flags):
+ Add support for sync'ing tick marks.
2004-10-01 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -10442,8 +14872,8 @@
2004-10-01 Kevin Greiner <kgreiner@compsol.cc>
- * gnus-agent.el (gnus-agent-synchronize-group-flags): When
- necessary, pass full group name to gnus-request-set-marks.
+ * gnus-agent.el (gnus-agent-synchronize-group-flags):
+ When necessary, pass full group name to gnus-request-set-marks.
2004-10-01 Simon Josefsson <jas@extundo.com>
@@ -10472,11 +14902,11 @@
2004-09-28 Kevin Greiner <kgreiner@compsol.cc>
- * gnus-agent.el (gnus-agent-synchronize-group-flags): Replaced
+ * gnus-agent.el (gnus-agent-synchronize-group-flags): Replace
gnus-requst-update-info with explicit code to sync the in-memory
info read flags with the marks being sync'd to the backend.
- *gnus-util.el (gnus-pp): Added optional stream to match pp API.
+ *gnus-util.el (gnus-pp): Add optional stream to match pp API.
2004-09-28 Teodor Zlatanov <tzz@lifelogs.com>
@@ -10491,8 +14921,8 @@
2004-09-28 Teodor Zlatanov <tzz@lifelogs.com>
- * gnus-registry.el (gnus-registry-split-fancy-with-parent): Use
- gnus-extract-references instead of gnus-split-references.
+ * gnus-registry.el (gnus-registry-split-fancy-with-parent):
+ Use gnus-extract-references instead of gnus-split-references.
* gnus-util.el (gnus-extract-references): Add new function, analogous
to gnus-split-references but extracts only the message-ID without
@@ -10548,7 +14978,7 @@
2004-09-25 Kevin Greiner <kgreiner@compsol.cc>
- * gnus-agent.el (gnus-agent-check-overview-buffer): Fixed range of
+ * gnus-agent.el (gnus-agent-check-overview-buffer): Fix range of
deletion to remove entire duplicate line. Fixes merged article
number bug.
@@ -10565,10 +14995,10 @@
Updates marks in memory (in the info structure) AND in the
backend.
- * gnus-util.el (gnus-remassoc): Fixed typo in documentation.
+ * gnus-util.el (gnus-remassoc): Fix typo in documentation.
- * nnagent.el (nnagent-request-set-mark): Use
- gnus-agent-synchronize-group-flags, not backend's request-set-mark
+ * nnagent.el (nnagent-request-set-mark):
+ Use gnus-agent-synchronize-group-flags, not backend's request-set-mark
method, to ensure that synchronization updates marks in the
backend and in the info (in memory) structure.
@@ -10585,7 +15015,7 @@
an error.
* gnus-int.el (gnus-request-set-mark, gnus-request-update-mark):
- Reverted 2004-09-21 change. The backend must be opened while
+ Revert 2004-09-21 change. The backend must be opened while
synchronizing flags even when the backend stores the flags
locally.
@@ -10647,7 +15077,7 @@
* nnimap.el (nnimap-split-download-body, nnimap-dont-close)
(nnimap-retrieve-groups-asynchronous): Add :version.
- (nnimap-close-asynchronous): Add :version. Fixed typo in doc string.
+ (nnimap-close-asynchronous): Add :version. Fix typo in doc string.
* mml.el (mml-content-disposition-parameters)
(mml-insert-mime-headers-always): Add :version.
@@ -10861,8 +15291,8 @@
2004-09-09 Kevin Greiner <kgreiner@compsol.cc>
- * gnus-agent.el (directory-files-and-attributes): Optionally
- defined to support XEmacs.
+ * gnus-agent.el (directory-files-and-attributes):
+ Optionally defined to support XEmacs.
2004-09-09 Kevin Greiner <kgreiner@compsol.cc>
@@ -10873,27 +15303,27 @@
article numbers even when local .overview file is missing.
(gnus-agent-read-article-number): New function. Only accepts
27-bit article numbers.
- (gnus-agent-copy-nov-line, gnus-agent-uncached-articles): Use
- gnus-agent-read-article-number.
+ (gnus-agent-copy-nov-line, gnus-agent-uncached-articles):
+ Use gnus-agent-read-article-number.
(gnus-agent-braid-nov): Rewrote to validate article numbers coming
from backend while recognizing that article numbers in .overview
must be valid.
- (gnus-agent-update-files-total-fetched-for): Use
- directory-files-and-attributes to improve performance.
- * gnus-int.el (gnus-request-move-article): Use
- gnus-agent-unfetch-articles in place of gnus-agent-expire to
+ (gnus-agent-update-files-total-fetched-for):
+ Use directory-files-and-attributes to improve performance.
+ * gnus-int.el (gnus-request-move-article):
+ Use gnus-agent-unfetch-articles in place of gnus-agent-expire to
improve performance.
- * gnus-start.el (gnus-convert-old-newsrc): Changed message text as
+ * gnus-start.el (gnus-convert-old-newsrc): Change message text as
some users confused by references to .newsrc when they only have a
.newsrc.eld file.
(gnus-convert-mark-converter-prompt)
- (gnus-convert-converter-needs-prompt): Fixed use of property list.
+ (gnus-convert-converter-needs-prompt): Fix use of property list.
* legacy-gnus-agent.el (gnus-agent-convert-to-compressed-agentview-prompt):
New function. Used internally to only display 'gnus converting
files' message when actually necessary.
- * gnus-sum.el (): Removed (require 'gnus-agent) as required
+ * gnus-sum.el (): Remove (require 'gnus-agent) as required
methods now autoloaded.
2004-09-03 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -10918,7 +15348,7 @@
* message.el: Don't autoload sha1 (there is a autoload cookie in
sha1.el).
- * sha1-el.el: Renamed to sha1.el.
+ * sha1-el.el: Rename to sha1.el.
2004-08-30 Juanma Barranquero <lektu@terra.es>
@@ -11057,13 +15487,13 @@
* gnus-sum.el (gnus-summary-make-menu-bar): Add help texts.
- * gnus-art.el (gnus-button-alist): Improve
- `gnus-button-handle-library' entry.
+ * gnus-art.el (gnus-button-alist):
+ Improve `gnus-button-handle-library' entry.
2004-08-19 Sebastian Freundt <hroptatyr@gna.org> (tiny change)
- * nnmaildir.el (nnmaildir--emlink-p, nnmaildir--enoent-p): Use
- downcase, since XEmacs capitalizes error messages differently.
+ * nnmaildir.el (nnmaildir--emlink-p, nnmaildir--enoent-p):
+ Use downcase, since XEmacs capitalizes error messages differently.
2004-08-18 Jesper Harder <harder@ifa.au.dk>
@@ -11072,8 +15502,8 @@
2004-08-18 Florian Weimer <fw@deneb.enyo.de>
- * gnus-sum.el (gnus-summary-force-verify-and-decrypt): Bind
- `mm-fill-flowed'.
+ * gnus-sum.el (gnus-summary-force-verify-and-decrypt):
+ Bind `mm-fill-flowed'.
* mm-decode.el (mm-dissect-singlepart): Check it.
@@ -11107,8 +15537,8 @@
2004-08-06 Simon Josefsson <jas@extundo.com>
- * gnus-sum.el (gnus-article-loose-mime): Change default to t. Doc
- fix.
+ * gnus-sum.el (gnus-article-loose-mime): Change default to t.
+ Doc fix.
2004-08-05 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -11117,10 +15547,10 @@
2004-08-04 Teodor Zlatanov <tzz@lifelogs.com>
- * gnus-registry.el (gnus-registry-split-fancy-with-parent): Try
- to append in-reply-to: data to the references: header.
+ * gnus-registry.el (gnus-registry-split-fancy-with-parent):
+ Try to append in-reply-to: data to the references: header.
- * netrc.el: Remove old encryption support, autoload gnus-encrypt.el
+ * netrc.el: Remove old encryption support, autoload gnus-encrypt.el.
(netrc-parse): Use gnus-encrypt.el functions.
* gnus-encrypt.el: Add new file for encryption support; currently
@@ -11150,8 +15580,8 @@
2004-07-25 Katsumi Yamaoka <yamaoka@jpl.org>
- * rfc2047.el (rfc2047-encode-region): Don't infloop. Suggested by
- Hiroshi Fujishima <pooh@nature.tsukuba.ac.jp>.
+ * rfc2047.el (rfc2047-encode-region): Don't infloop.
+ Suggested by Hiroshi Fujishima <pooh@nature.tsukuba.ac.jp>.
2004-07-25 Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -11232,8 +15662,8 @@
2004-07-02 Katsumi Yamaoka <yamaoka@jpl.org>
- * mm-encode.el (mm-content-transfer-encoding-defaults): Use
- qp-or-base64 for the application/* types.
+ * mm-encode.el (mm-content-transfer-encoding-defaults):
+ Use qp-or-base64 for the application/* types.
2004-07-02 Joakim Verona <joakim@verona.se> (tiny change)
@@ -11257,8 +15687,8 @@
2004-06-29 Lars Magne Ingebrigtsen <larsi@gnus.org>
- * gnus-group.el (gnus-group-get-new-news-this-group): Don't
- update info that isn't there.
+ * gnus-group.el (gnus-group-get-new-news-this-group):
+ Don't update info that isn't there.
2004-06-29 Ilya N. Golubev <gin@mo.msk.ru>.
@@ -11289,15 +15719,15 @@
(mm-coding-system-priorities): Use shift_jis and iso-8859-1
instead of japanese-shift-jis and iso-latin-1 respectively in
order to share the default value with both Emacs and XEmacs-mule.
- (mm-mule-charset-to-mime-charset): Make
- mm-coding-system-priorities effective.
+ (mm-mule-charset-to-mime-charset):
+ Make mm-coding-system-priorities effective.
(mm-sort-coding-systems-predicate): Canonicalize coding-systems
while predicating of candidates upon the priorities.
2004-06-27 Jesper Harder <harder@ifa.au.dk>
- * gnus-sum.el (gnus-summary-make-menu-bar): Add
- gnus-uu-invert-processable.
+ * gnus-sum.el (gnus-summary-make-menu-bar):
+ Add gnus-uu-invert-processable.
* gnus.el: Autoload gnus-uu-invert-processable.
@@ -11317,8 +15747,8 @@
2004-06-23 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus-cite.el (gnus-cite-ignore-quoted-from): New user option.
- (gnus-cite-parse): Ignore quoted envelope From_. Suggested by
- Karl Chen <quarl@nospam.quarl.org>.
+ (gnus-cite-parse): Ignore quoted envelope From_.
+ Suggested by Karl Chen <quarl@nospam.quarl.org>.
2004-06-23 Jesper Harder <harder@ifa.au.dk>
@@ -11373,8 +15803,8 @@
(spam-move-ham-routine): Add code to copy/move ham or spam.
(spam-fetch-field-fast): Improve doc and code, plus allow the
'number request.
- (spam-list-of-checks, spam-list-of-statistical-checks): Remove
- variables.
+ (spam-list-of-checks, spam-list-of-statistical-checks):
+ Remove variables.
(spam-split, spam-find-spam): Use the new backend code.
(spam-registration-functions): Remove variable.
(spam-unregister-routine): Add convenience wrapper.
@@ -11449,8 +15879,8 @@
(nnheader-fake-message-id-p): Change regex to accommodate new fake
ID format.
- * gnus-sum.el (gnus-get-newsgroup-headers): Call
- nnheader-generate-fake-message-id with the article number.
+ * gnus-sum.el (gnus-get-newsgroup-headers):
+ Call nnheader-generate-fake-message-id with the article number.
2004-06-12 YAGI Tatsuya <ynyaaa@ybb.ne.jp> (tiny change)
@@ -11521,8 +15951,8 @@
2004-06-06 Lars Magne Ingebrigtsen <larsi@gnus.org>
- * message.el (message-cite-articles-with-x-no-archive): New
- variable.
+ * message.el (message-cite-articles-with-x-no-archive):
+ New variable.
(message-cite-original): Use it.
2004-06-04 Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -11556,12 +15986,12 @@
2004-05-28 Reiner Steib <Reiner.Steib@gmx.de>
- * gnus-art.el (gnus-button-alist): Fixed regexp for manual links.
+ * gnus-art.el (gnus-button-alist): Fix regexp for manual links.
- * gnus-group.el (gnus-group-get-new-news-this-group): Added
- doc-string.
+ * gnus-group.el (gnus-group-get-new-news-this-group):
+ Add doc-string.
- * gnus-start.el (gnus-activate-group): Added doc-string.
+ * gnus-start.el (gnus-activate-group): Add doc-string.
2004-05-28 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -11582,21 +16012,21 @@
2004-05-27 Daniel Pittman <daniel@rimspace.net>
- * spam.el (spam-report-resend-register-routine): Allow
- spam-report-resend-to to be a group parameter or a global value.
+ * spam.el (spam-report-resend-register-routine):
+ Allow spam-report-resend-to to be a group parameter or a global value.
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-connect, starttls-failure, starttls-success):
+ New variables.
(starttls-program, starttls-extra-args): Doc fix.
- (starttls-negotiate-gnutls, starttls-open-stream-gnutls): New
- functions.
- (starttls-negotiate, starttls-open-stream): Check
- `starttls-use-gnutls' and pass on to corresponding *-gnutls
+ (starttls-negotiate-gnutls, starttls-open-stream-gnutls):
+ New functions.
+ (starttls-negotiate, starttls-open-stream):
+ Check `starttls-use-gnutls' and pass on to corresponding *-gnutls
function if it is set.
2004-05-27 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -11610,14 +16040,14 @@
2004-05-26 Teodor Zlatanov <tzz@lifelogs.com>
- * spam.el (spam-mark-new-messages-in-spam-group-as-spam): Add
- variable.
+ * spam.el (spam-mark-new-messages-in-spam-group-as-spam):
+ Add variable.
(spam-mark-junk-as-spam-routine): Use it. Allow to disable
assigning the spam-mark to new messages.
2004-05-26 Adam Sjøgren <asjo@koldfront.dk> (tiny change)
- (spam-ham-copy-or-move-routine): Don't declare `todo' twice.
+ * spam.el (spam-ham-copy-or-move-routine): Don't declare `todo' twice.
2004-05-26 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -11663,8 +16093,8 @@
2004-05-24 Daniel Pittman <daniel@rimspace.net>
- * spam-report.el (spam-report-resend-to, spam-report-resend): Start
- with resend-to set to nil, and then ask the user if necessary.
+ * spam-report.el (spam-report-resend-to, spam-report-resend):
+ Start with resend-to set to nil, and then ask the user if necessary.
(spam-report-resend): spam-report-resend takes a list of articles, not
separate article numbers.
@@ -11753,8 +16183,8 @@
(spam-crm114-register-spam-routine)
(spam-crm114-unregister-spam-routine)
(spam-crm114-register-ham-routine)
- (spam-crm114-unregister-ham-routine): Add CRM114 support. From
- asjo@koldfront.dk (Adam Sjøgren).
+ (spam-crm114-unregister-ham-routine): Add CRM114 support.
+ From asjo@koldfront.dk (Adam Sjøgren).
* gnus.el: Add spam-use-crm114.
@@ -11782,7 +16212,7 @@
2004-05-20 Katsumi Yamaoka <yamaoka@jpl.org>
- * rfc2047.el (rfc2047-encode-function-alist): Renamed from
+ * rfc2047.el (rfc2047-encode-function-alist): Rename from
`rfc2047-encoding-function-alist' in order to avoid conflicting
with the old version.
(rfc2047-encode-region): Concatenate words containing non-ASCII
@@ -11795,17 +16225,17 @@
iso-2022-* charsets.
(rfc2047-fold-region): Use existing whitespace for LWSP; make it
sure not to break a line just after the header name.
- (rfc2047-b-encode-region): Removed.
+ (rfc2047-b-encode-region): Remove.
(rfc2047-b-encode-string): New function.
- (rfc2047-q-encode-region): Removed.
+ (rfc2047-q-encode-region): Remove.
(rfc2047-q-encode-string): New function.
* mm-util.el (mm-replace-in-string): New function.
2004-05-20 Lars Magne Ingebrigtsen <larsi@gnus.org>
- * gnus-msg.el (gnus-inews-make-draft-meta-information): Really
- get it right.
+ * gnus-msg.el (gnus-inews-make-draft-meta-information):
+ Really get it right.
(gnus-inews-make-draft): Really.
2004-05-19 Ben Menasha <bmenasha@benmenasha.net>
@@ -11818,8 +16248,8 @@
* gnus-msg.el (gnus-inews-make-draft-meta-information): Fix quote
stuff.
- * gnus-start.el (gnus-subscribe-hierarchical-interactive): Match
- on real group name.
+ * gnus-start.el (gnus-subscribe-hierarchical-interactive):
+ Match on real group name.
* gnus-art.el (gnus-signature-limit): Doc fix.
@@ -11827,8 +16257,8 @@
2004-05-19 Lars Magne Ingebrigtsen <larsi@gnus.org>
- * gnus-draft.el (gnus-draft-send): Bind
- rfc2047-encode-encoded-words.
+ * gnus-draft.el (gnus-draft-send):
+ Bind rfc2047-encode-encoded-words.
* rfc2047.el (rfc2047-encode-region): Encode =? strings.
(rfc2047-encodable-p): Say that =? needs encoding.
@@ -11847,8 +16277,8 @@
2004-05-19 Reiner Steib <Reiner.Steib@gmx.de>
- * gnus-msg.el (gnus-summary-followup-with-original): Document
- yanking of region when active.
+ * gnus-msg.el (gnus-summary-followup-with-original):
+ Document yanking of region when active.
2004-05-19 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -11858,7 +16288,7 @@
2004-05-18 Reiner Steib <Reiner.Steib@gmx.de>
* gnus-group.el (gnus-group-jump-to-group-prompt): Allow an alist.
- (gnus-group-jump-to-group): Added prefix argument using
+ (gnus-group-jump-to-group): Add prefix argument using
`gnus-group-jump-to-group-prompt'. Query before jumping to
non-active group.
@@ -11892,9 +16322,9 @@
2004-05-18 Reiner Steib <Reiner.Steib@gmx.de>
* gnus-picon.el (gnus-picon-style): New variable.
- (gnus-picon-insert-glyph): Added optional `nostring' argument.
- (gnus-picon-transform-address): Support `gnus-picon-style'. From
- Jesper Harder <harder@ifa.au.dk>.
+ (gnus-picon-insert-glyph): Add optional `nostring' argument.
+ (gnus-picon-transform-address): Support `gnus-picon-style'.
+ From Jesper Harder <harder@ifa.au.dk>.
2004-05-18 Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -11935,7 +16365,7 @@
(message-fill-field-address): Rename.
(message-narrow-to-field): Find the start of the header.
(message-header-format-alist): Don't pre-fill.
- (message-fill-header): Removed.
+ (message-fill-header): Remove.
(message-insert-header): New function.
(message-shorten-references): Use it.
@@ -11954,10 +16384,10 @@
2004-05-16 Lars Magne Ingebrigtsen <larsi@gnus.org>
- * message.el (message-idna-inside-rhs-p): Removed.
+ * message.el (message-idna-inside-rhs-p): Remove.
(message-idna-to-ascii-rhs-1): Use proper address parsing.
- * gnus-art.el (gnus-emphasis-alist): Removed strikethru; too many
+ * gnus-art.el (gnus-emphasis-alist): Remove strikethru; too many
false positives.
2004-05-16 Kim-Minh Kaplan <kmkaplan-AwwS6Bc0PDVoiYX5Tdu9fQ@public.gmane.org>
@@ -11980,7 +16410,7 @@
2004-05-15 Teodor Zlatanov <tzz@lifelogs.com>
- * spam.el (spam-summary-prepare-exit): Fixed (length).
+ * spam.el (spam-summary-prepare-exit): Fix (length).
2004-05-14 Teodor Zlatanov <tzz@lifelogs.com>
@@ -11995,8 +16425,8 @@
2004-05-14 Kai Grossjohann <kgrossjo@eu.uu.net>
- * nntp.el (nntp-request-set-mark, nntp-request-update-info): Call
- nntp-possibly-create-directory, not nntp-possibly-change-group.
+ * nntp.el (nntp-request-set-mark, nntp-request-update-info):
+ Call nntp-possibly-create-directory, not nntp-possibly-change-group.
(nntp-marks-changed-p): New arg SERVER.
(nntp-request-update-info): Adjust caller.
@@ -12011,13 +16441,13 @@
(nntp-marks-modtime, nntp-marks-directory): New variables.
(nntp-request-set-mark, nntp-request-update-info)
(nntp-possibly-create-directory, nntp-marks-changed-p)
- (nntp-save-marks, nntp-open-marks, nntp-marks-directory): New
- functions.
+ (nntp-save-marks, nntp-open-marks, nntp-marks-directory):
+ New functions.
2004-05-12 Jesper Harder <harder@ifa.au.dk>
- * gnus-score.el (gnus-score-insert-help): Use
- gnus-select-lowest-window.
+ * gnus-score.el (gnus-score-insert-help):
+ Use gnus-select-lowest-window.
* gnus-ems.el (gnus-select-lowest-window): Copy definition of
appt-select-lowest-window and rename to gnus-select-lowest-window.
@@ -12057,8 +16487,8 @@
2004-05-01 Lars Magne Ingebrigtsen <larsi@gnus.org>
- * gnus-agent.el (gnus-agent-read-agentview): Inline
- gnus-uncompress-range.
+ * gnus-agent.el (gnus-agent-read-agentview):
+ Inline gnus-uncompress-range.
2004-05-01 TSUCHIYA Masatoshi <tsuchiya@namazu.org>
@@ -12067,8 +16497,8 @@
2004-04-30 TSUCHIYA Masatoshi <tsuchiya@namazu.org>
- * gnus.el (spam-process, spam-autodetect-methods): Add
- bsfilter and bsfilter-headers.
+ * gnus.el (spam-process, spam-autodetect-methods):
+ Add bsfilter and bsfilter-headers.
* spam.el (spam-bsfilter): New customize group.
(spam-use-bsfilter, spam-use-bsfilter-headers, spam-bsfilter-path)
@@ -12118,7 +16548,7 @@
* spam.el (spam-summary-prepare-exit)
(spam-mark-junk-as-spam-routine, spam-fetch-field-fast)
(spam-split, spam-find-spam, spam-log-undo-registration)
- (spam-check-blackholes, spam-enter-ham-BBDB): Changed message
+ (spam-check-blackholes, spam-enter-ham-BBDB): Change message
level from 5 to 6.
2004-04-26 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -12219,7 +16649,7 @@
2004-04-15 Kevin Greiner <kgreiner@xpediantsolutions.com>
* legacy-gnus-agent.el
- (gnus-agent-convert-to-compressed-agentview): Fixed typos with
+ (gnus-agent-convert-to-compressed-agentview): Fix typos with
help from Florian Weimer <fw@deneb.enyo.de>
2004-04-15 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -12280,25 +16710,25 @@
`method' parameter is nil. Don't write nil entries into the
active file.
(gnus-agent-get-group-info): New function.
- (gnus-agent-fetch-articles): Use
- gnus-agent-update-files-total-fetched-for to increment disk space
+ (gnus-agent-fetch-articles):
+ Use gnus-agent-update-files-total-fetched-for to increment disk space
used.
- (gnus-agent-fetch-headers, gnus-agent-save-alist): Use
- gnus-agent-update-view-total-fetched-for to increment disk space
+ (gnus-agent-fetch-headers, gnus-agent-save-alist):
+ Use gnus-agent-update-view-total-fetched-for to increment disk space
used.
- (gnus-agent-get-local): Added optional parameters to avoid calling
+ (gnus-agent-get-local): Add optional parameters to avoid calling
gnus-group-real-name and gnus-find-method-for-group.
(gnus-agent-set-local): Delete stored entry if either min, or max,
are nil.
- (gnus-agent-fetch-session): Reworded error/quit messages. On
- quit, use gnus-agent-regenerate-group to record existence of any
+ (gnus-agent-fetch-session): Reworded error/quit messages.
+ On quit, use gnus-agent-regenerate-group to record existence of any
articles fetched to disk before the quit occurred.
(gnus-agent-expire-group-1): Use gnus-agent-with-refreshed-group,
gnus-agent-update-view-total-fetched-for, and
gnus-agent-update-files-total-fetched-for to decrement disk space
used.
- (gnus-agent-retrieve-headers): Use
- gnus-agent-update-view-total-fetched-for to increment disk space
+ (gnus-agent-retrieve-headers):
+ Use gnus-agent-update-view-total-fetched-for to increment disk space
used.
(gnus-agent-regenerate-group): Replace gnus-group-update-group
with gnus-agent-update-files-total-fetched-for to decrement disk
@@ -12309,14 +16739,14 @@
(gnus-agent-update-view-total-fetched-for): New function.
(gnus-agent-total-fetched-for): New function.
- * gnus-cache.el (gnus-cache-save-buffers): Use
- gnus-cache-update-overview-total-fetched-for to change disk space
+ * gnus-cache.el (gnus-cache-save-buffers):
+ Use gnus-cache-update-overview-total-fetched-for to change disk space
used by this group.
- (gnus-cache-possibly-enter-article): Use
- gnus-cache-update-file-total-fetched-for to increment disk space
+ (gnus-cache-possibly-enter-article):
+ Use gnus-cache-update-file-total-fetched-for to increment disk space
used by this group.
- (gnus-cache-possibly-remove-article): Use
- gnus-cache-update-file-total-fetched-for to decrement disk space
+ (gnus-cache-possibly-remove-article):
+ Use gnus-cache-update-file-total-fetched-for to decrement disk space
used by this group.
(gnus-cache-generate-nov-databases): Purge total fetched cache.
(gnus-cache-rename-group): New function.
@@ -12332,7 +16762,7 @@
* gnus-group.el: Require gnus-sum and autoload functions to
resolve warnings when gnus-group.el compiled alone.
- (gnus-group-line-format): Documented new %F
+ (gnus-group-line-format): Documented new %F.
(size of Fetched data) group line format; identifies disk space
used by agent and cache.
(gnus-group-line-format-alist): Defined new F format.
@@ -12387,8 +16817,8 @@
2004-03-27 Katsumi Yamaoka <yamaoka@jpl.org>
- * message.el (message-exchange-point-and-mark): Use
- message-mark-active-p. Suggested by Jesper Harder
+ * message.el (message-exchange-point-and-mark):
+ Use message-mark-active-p. Suggested by Jesper Harder
<harder@ifa.au.dk>.
2004-03-26 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -12437,8 +16867,8 @@
2004-03-19 Katsumi Yamaoka <yamaoka@jpl.org>
- * gnus-art.el (gnus-mime-recompute-hierarchical-structure): New
- user option.
+ * gnus-art.el (gnus-mime-recompute-hierarchical-structure):
+ New user option.
(gnus-mime-multipart-functions): Doc and customization fix.
(gnus-article-mime-hierarchy): New variable.
(gnus-article-mime-hierarchy-next): New variable.
@@ -12506,8 +16936,8 @@
2004-03-09 Kevin Greiner <kgreiner@xpediantsolutions.com>
- * gnus-agent.el (gnus-agent-read-local): Bind
- nnheader-file-coding-system to gnus-agent-file-coding-system to
+ * gnus-agent.el (gnus-agent-read-local):
+ Bind nnheader-file-coding-system to gnus-agent-file-coding-system to
avoid the implicit assumption that they will always be equal.
(gnus-agent-save-local): Bind buffer-file-coding-system, not
coding-system-for-write, as the with-temp-file macro first prints
@@ -12522,16 +16952,16 @@
2004-03-08 Kevin Greiner <kgreiner@xpediantsolutions.com>
- * gnus-agent.el (gnus-agent-read-agentview): Removed support for
+ * gnus-agent.el (gnus-agent-read-agentview): Remove support for
old file versions.
- (gnus-group-prepare-hook): Removed function that converted list
+ (gnus-group-prepare-hook): Remove function that converted list
form of gnus-agent-expire-days to group properties.
* gnus-int.el: Autoload gnus-agent-regenerate-group.
(gnus-request-accept-article): Re-indented.
* gnus-start.el (gnus-convert-old-newsrc): Registered new
- converters to handle old agent file formats. Added logic for a
+ converters to handle old agent file formats. Add logic for a
"backup before upgrading warning".
(gnus-convert-mark-converter-prompt): Developers can mark
functions as needing (default), or not needing,
@@ -12632,7 +17062,7 @@
2004-03-04 Kevin Greiner <kgreiner@xpediantsolutions.com>
- * gnus-agent.el (gnus-agent-file-header-cache): Removed.
+ * gnus-agent.el (gnus-agent-file-header-cache): Remove.
(gnus-agent-possibly-alter-active): Avoid null in numeric
comparison.
(gnus-agent-set-local): Refuse to save null in local object table.
@@ -12653,8 +17083,8 @@
* gnus-agent.el (gnus-agent-read-local, gnus-agent-save-local):
Don't bind "obarray".
- * gnus-sum.el (gnus-thread-sort-functions): Added
- `gnus-thread-sort-by-most-recent-number' and
+ * gnus-sum.el (gnus-thread-sort-functions):
+ Add `gnus-thread-sort-by-most-recent-number' and
`gnus-thread-sort-by-most-recent-date'.
Reported by Kai Grossjohann <kai@emptydomain.de>.
@@ -12664,8 +17094,8 @@
2004-03-02 Kevin Greiner <kgreiner@xpediantsolutions.com>
- * gnus-cus.el (gnus-agent-customize-category): Removed
- ignore-errors macro reference that required cl to be loaded at
+ * gnus-cus.el (gnus-agent-customize-category):
+ Remove ignore-errors macro reference that required cl to be loaded at
run-time.
* gnus-range.el (gnus-sorted-range-intersection): Now accepts
@@ -12703,8 +17133,8 @@
* gnus-msg.el (gnus-setup-message): Ignore an article copy while
parsing gnus-posting-styles when the message is not for replying.
- * nnrss.el (nnrss-opml-export): Use
- mm-set-buffer-file-coding-system instead of
+ * nnrss.el (nnrss-opml-export):
+ Use mm-set-buffer-file-coding-system instead of
set-buffer-file-coding-system.
2004-02-27 Jesper Harder <harder@ifa.au.dk>
@@ -12750,20 +17180,20 @@
* spam-stat.el (spam-stat-washing-hook): New option.
(spam-stat-buffer-words): Use it.
- (spam-stat-process-directory, spam-stat-test-directory): Use
- insert-file-contents-literally.
+ (spam-stat-process-directory, spam-stat-test-directory):
+ Use insert-file-contents-literally.
(spam-stat-coding-system): New variable.
(spam-stat-load, spam-stat-save): Use it.
2004-02-25 Katsumi Yamaoka <yamaoka@jpl.org>
- * spam-report.el (spam-report-plug-agent): Quote
- spam-report-url-to-file and spam-report-url-ping-plain.
+ * spam-report.el (spam-report-plug-agent):
+ Quote spam-report-url-to-file and spam-report-url-ping-plain.
2004-02-25 Reiner Steib <Reiner.Steib@gmx.de>
- * gnus-art.el (gnus-button-alist, gnus-header-button-alist): Allow
- / in mailto URLs.
+ * gnus-art.el (gnus-button-alist, gnus-header-button-alist):
+ Allow / in mailto URLs.
2004-02-24 Reiner Steib <Reiner.Steib@gmx.de>
@@ -12771,9 +17201,8 @@
(spam-report-url-ping-temp-agent-function, spam-report-plug-agent)
(spam-report-unplug-agent): Doc fixes.
(spam-report-url-ping-mm-url, spam-report-url-to-file)
- (spam-report-agentize, spam-report-deagentize): Autoload
-
-2004-02-24 Katsumi Yamaoka <yamaoka@jpl.org>
+ (spam-report-agentize, spam-report-deagentize):
+ Autoload 2004-02-24 Katsumi Yamaoka <yamaoka@jpl.org>
* message.el (message-setup-fill-variables): Add mml tags to
paragraph-start and paragraph-separate. Suggested by Andrew Korty
@@ -12835,8 +17264,8 @@
(nntp-send-buffer, nntp-retrieve-groups, nntp-handle-authinfo)
(nntp-possibly-change-group): Use it.
- * nnnil.el (nnnil-retrieve-headers, nnnil-request-list): Use
- with-current-buffer.
+ * nnnil.el (nnnil-retrieve-headers, nnnil-request-list):
+ Use with-current-buffer.
2004-02-12 TAKAI Kousuke <tak@kmc.gr.jp>
@@ -12973,8 +17402,8 @@
2004-02-03 Jesper Harder <harder@ifa.au.dk>
- * spam.el (spam-check-spamoracle, spam-spamoracle-learn): Fix
- format string mismatch.
+ * spam.el (spam-check-spamoracle, spam-spamoracle-learn):
+ Fix format string mismatch.
* sieve.el (sieve-deactivate-all): do.
@@ -13035,8 +17464,8 @@
New macros and functions.
* nnmaildir.el (nnmaildir--group-maxnum, nnmaildir--update-nov):
Handle > NLINK_MAX messages.
- * nnmaildir.el (nnmaildir-request-set-mark): Use
- nnmaildir--emlink-p and nnmaildir--eexist-p.
+ * nnmaildir.el (nnmaildir-request-set-mark):
+ Use nnmaildir--emlink-p and nnmaildir--eexist-p.
2004-01-25 Alex Schroeder <alex@gnu.org>
@@ -13076,8 +17505,8 @@
2004-01-23 Jesper Harder <harder@ifa.au.dk>
- * spam-stat.el (spam-stat-store-gnus-article-buffer): Use
- with-current-buffer.
+ * spam-stat.el (spam-stat-store-gnus-article-buffer):
+ Use with-current-buffer.
(spam-stat-store-current-buffer): Use insert-buffer-substring to
avoid consing a string.
@@ -13103,29 +17532,29 @@
(gnus-agent-prompt-send-queue): New variables.
(gnus-agent-send-mail): Use gnus-agent-queue-mail.
* gnus-draft.el (gnus-group-send-queue): Pass the group name
- "nndraft:queue" along to gnus-draft-send. Use
- gnus-agent-prompt-send-queue.
+ "nndraft:queue" along to gnus-draft-send.
+ Use gnus-agent-prompt-send-queue.
(gnus-draft-send): Rebind gnus-agent-queue-mail to nil when group
is "nndraft:queue". Suggested by Gaute Strokkenes
<gs234@srcf.ucam.org>
- * gnus-agent.el (agent-disable-undownloaded-faces): Removed
- (agent-enable-undownloaded-faces): Added
+ * gnus-agent.el (agent-disable-undownloaded-faces): Remove.
+ (agent-enable-undownloaded-faces): Add.
(gnus-agent-cat-groups): Use eval-and-compile, not
eval-when-compile, to define gnus-agent-set-cat-groups as the setf
method of gnus-agent-cat-groups even when the buffer has been
evaled.
- (gnus-agent-save-active, gnus-agent-save-active-1): Merged to
+ (gnus-agent-save-active, gnus-agent-save-active-1): Merge to
delete gnus-agent-save-active-1.
- (gnus-agent-save-groups): Deleted. Identical to
+ (gnus-agent-save-groups): Delete. Identical to
gnus-agent-save-active.
(gnus-agent-write-active): No longer adjust agent's copy of active
file as agent's adjustments are now stored in their own
- file. Removed optional parameter.
+ file. Remove optional parameter.
(gnus-agent-possibly-alter-active): Ignore groups of unagentized
servers. Add use of min/max range limits from server's local
file.
- (gnus-agent-save-alist): Removed unused optional argument.
+ (gnus-agent-save-alist): Remove unused optional argument.
(gnus-agent-load-local, gnus-agent-read-and-cache-local)
(gnus-agent-read-local, gnus-agent-save-local, gnus-agent-get-local)
(gnus-agent-set-local): A per-server file that keeps min/max range
@@ -13133,10 +17562,10 @@
for altering many active ranges.
(gnus-agent-expire-group, gnus-agent-expire): No longer save the
active file (local makes it unnecessary).
- (gnus-agent-regenerate-group): Fixed XEmacs compatibility.
+ (gnus-agent-regenerate-group): Fix XEmacs compatibility.
- * gnus-cus.el (agent-disable-undownloaded-faces): Removed
- (agent-enable-undownloaded-faces): Added
+ * gnus-cus.el (agent-disable-undownloaded-faces): Remove.
+ (agent-enable-undownloaded-faces): Add.
* gnus-draft.el (gnus-draft-send): Bind gnus-agent-queue-mail to
disable it when sending to "nndraft:queue".
@@ -13149,7 +17578,7 @@
numbers of articles. Use gnus-range-map to avoid having to
uncompress the unread list.
(gnus-group-archive-directory, gnus-group-recent-archive-directory):
- Fixed invalid ange-ftp reference.
+ Fix invalid ange-ftp reference.
* gnus-range.el (gnus-range-map): Iterate over list or sequence.
(gnus-sorted-range-intersection): Intersection of two ranges
@@ -13160,11 +17589,11 @@
and agentized articles.
(gnus-convert-old-newsrc): Rewrote in anticipation of having
multiple version-dependent converters.
- (gnus-groups-to-gnus-format): Replaced gnus-agent-save-groups with
+ (gnus-groups-to-gnus-format): Replace gnus-agent-save-groups with
gnus-agent-save-active.
(gnus-save-newsrc-file): Save dirty agent range limits.
- * gnus-sum.el (gnus-select-newgroup): Replaced inline code with
+ * gnus-sum.el (gnus-select-newgroup): Replace inline code with
gnus-agent-possibly-alter-active.
(gnus-adjust-marked-articles): Faster handling of simple lists
@@ -13205,8 +17634,8 @@
spam-use-spamassassin or spam-use-spamassassin-headers is on;
spam-bogofilter-score otherwise.
- * gnus.el (spam-process, spam-autodetect-methods): Add
- spamassassin and spamassassin-headers.
+ * gnus.el (spam-process, spam-autodetect-methods):
+ Add spamassassin and spamassassin-headers.
2004-01-20 Nevin Kapur <nkapur@cs.caltech.edu>
@@ -13270,7 +17699,7 @@
2004-01-14 Kai Grossjohann <kai@emptydomain.de>
- (message-kill-to-signature): Change docstring.
+ * message.el (message-kill-to-signature): Change docstring.
2004-01-14 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -13290,11 +17719,11 @@
2004-01-13 Simon Josefsson <jas@extundo.com>
* gnus-score.el (gnus-score-edit-all-score): Fix prototype.
- Invoke gnus-score-mode. Reported by
- bojohan+news@dd.chalmers.se (Johan Bockgård).
+ Invoke gnus-score-mode.
+ Reported by bojohan+news@dd.chalmers.se (Johan Bockgård).
- * gnus-range.el (gnus-compress-sequence): Doc fix. Suggested by
- Jim Blandy <jimb@redhat.com> (tiny change).
+ * gnus-range.el (gnus-compress-sequence): Doc fix.
+ Suggested by Jim Blandy <jimb@redhat.com> (tiny change).
2004-01-12 Jesper Harder <harder@ifa.au.dk>
@@ -13417,8 +17846,8 @@
* mm-bodies.el: base64 is always built-in.
- * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups): Use
- with-current-buffer.
+ * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups):
+ Use with-current-buffer.
2004-01-08 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -13455,8 +17884,8 @@
2004-01-08 Jesper Harder <harder@ifa.au.dk>
* gnus-art.el (gnus-mime-view-all-parts)
- (gnus-article-part-wrapper, gnus-article-view-part): Use
- with-current-buffer.
+ (gnus-article-part-wrapper, gnus-article-view-part):
+ Use with-current-buffer.
2004-01-07 Teodor Zlatanov <tzz@lifelogs.com>
@@ -13503,10 +17932,10 @@
(spam-find-spam): Don't try to guess spam-cache-lookups.
(spam-enter-whitelist, spam-enter-blacklist): Clear the
spam-caches entry.
- (spam-filelist-build-cache, spam-filelist-check-cache): Fix
- caching of whitelist/blacklist entries.
- (spam-check-whitelist, spam-check-blacklist): Invoke
- spam-from-listed-p with a type, not a cache variable.
+ (spam-filelist-build-cache, spam-filelist-check-cache):
+ Fix caching of whitelist/blacklist entries.
+ (spam-check-whitelist, spam-check-blacklist):
+ Invoke spam-from-listed-p with a type, not a cache variable.
(spam-from-listed-p): Wrap around spam-filelist-check-cache.
2004-01-07 Jesper Harder <harder@ifa.au.dk>
@@ -13585,7 +18014,7 @@
2004-01-06 Reiner Steib <Reiner.Steib@gmx.de>
- * gnus-art.el (gnus-treat-ansi-sequences): Changed default.
+ * gnus-art.el (gnus-treat-ansi-sequences): Change default.
2004-01-07 Steve Youngs <sryoungs@bigpond.net.au>
@@ -13618,10 +18047,10 @@
* gnus-art.el (gnus-button-push): Use set-text-properties instead
of gnus-.
- * gnus.el: Changed calls to nnheader-run-at-time and
+ * gnus.el: Change calls to nnheader-run-at-time and
password-run-at-time throughout to use run-at-time directly.
- * password.el: Removed definition of run-at-time.
+ * password.el: Remove definition of run-at-time.
2004-01-05 Karl Pflästerer <sigurd@12move.de> (tiny change)
@@ -13647,8 +18076,8 @@
* gnus-util.el (gnus-local-map-property): Remove.
- * mm-view.el (mm-view-pkcs7-decrypt): Replace
- gnus-completing-read-maybe-default with completing-read.
+ * mm-view.el (mm-view-pkcs7-decrypt):
+ Replace gnus-completing-read-maybe-default with completing-read.
* gnus-util.el (gnus-completing-read): do.
(gnus-completing-read-maybe-default): Remove.
@@ -13668,8 +18097,8 @@
* netrc.el: Autoload password-read.
(netrc): Add configuration group.
- (netrc-encoding-method, netrc-openssl-path): Add
- variables for encoding and decoding of files with symmetric
+ (netrc-encoding-method, netrc-openssl-path):
+ Add variables for encoding and decoding of files with symmetric
ciphers.
(netrc-encode): Add assistant function to encode a file with
netrc-encoding-method.
@@ -13689,7 +18118,7 @@
2004-01-05 Reiner Steib <Reiner.Steib@gmx.de>
- * gnus-art.el (gnus-treat-ansi-sequences,
+ * gnus-art.el (gnus-treat-ansi-sequences)
(article-treat-ansi-sequences): New variable and function.
Suggested by Dan Jacobson <jidanni@jidanni.org>.
@@ -13756,8 +18185,8 @@
* smime.el (smime-point-at-eol): Replace with point-at-eol.
- * rfc2047.el (rfc2047-point-at-bol, rfc2047-point-at-eol): Replace
- with point-at-{eol,bol}.
+ * rfc2047.el (rfc2047-point-at-bol, rfc2047-point-at-eol):
+ Replace with point-at-{eol,bol}.
* netrc.el (netrc-point-at-eol): Replace with point-at-eol.
@@ -13794,13 +18223,13 @@
ntlm-smb-perm5, smb-perm6 into ntlm-smb-perm6, smb-sc into
ntlm-smb-sc, smb-sbox into ntlm-smb-sbox, string-permute into
ntlm-string-permute, string-lshift into ntlm-string-lshift,
- string-xor into ntlm-string-xor. Suggested by
- Jesper Harder <harder@myrealbox.com>.
+ string-xor into ntlm-string-xor.
+ Suggested by Jesper Harder <harder@myrealbox.com>.
* ntlm.el: Don't include poem.
- * md4.el (print-int32, print-string-hexa): Remove. Suggested by
- Jesper Harder <harder@myrealbox.com>.
+ * md4.el (print-int32, print-string-hexa): Remove.
+ Suggested by Jesper Harder <harder@myrealbox.com>.
* sasl-ntlm.el, ntlm.el, md4.el: New files.
@@ -13814,8 +18243,8 @@
condition-case around loop.
* pgg.el (pgg-passphrase-cache, pgg-run-at-time): Remove.
- (pgg-add-passphrase-cache, pgg-remove-passphrase-cache): Use
- the password package.
+ (pgg-add-passphrase-cache, pgg-remove-passphrase-cache):
+ Use the password package.
2003-02-19 Simon Josefsson <jas@extundo.com>
@@ -13868,15 +18297,15 @@
2004-01-04 Mario Lang <lang@zid.tugraz.at>
* dns.el (dns-query-types): Fix typo.
- (dns-query-types): New function
+ (dns-query-types): New function.
(dns-read-type): Add support for AAAA records, see RFC 3596. Parse MX,
PTR and SOA replies, see RFC 1035.
2004-01-04 Lars Magne Ingebrigtsen <larsi@gnus.org>
- * gnus.el (gnus-logo-color-style): Changed colors to `no'.
+ * gnus.el (gnus-logo-color-style): Change colors to `no'.
- * Moved to Changelog.2.
+ * Move to Changelog.2.
2004-01-04 Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -13897,7 +18326,8 @@
See ChangeLog.2 for earlier changes.
- Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010
+ Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -13919,5 +18349,3 @@ See ChangeLog.2 for earlier changes.
;; fill-column: 79
;; add-log-time-zone-rule: t
;; End:
-
-;;; arch-tag: 3f33a3e7-090d-492b-bedd-02a1417d32b4
diff --git a/lisp/gnus/ChangeLog.1 b/lisp/gnus/ChangeLog.1
index e455770711b..520b3a4b735 100644
--- a/lisp/gnus/ChangeLog.1
+++ b/lisp/gnus/ChangeLog.1
@@ -28,10 +28,10 @@
* gnus-start.el (gnus-slave-save-newsrc):
* gnus-uu.el (gnus-uu-tmp-dir, gnus-uu-decode-binhex)
- (gnus-uu-decode-binhex-view, gnus-uu-digest-mail-forward)
- (gnus-uu-initialize):
+ (gnus-uu-decode-binhex-view, gnus-uu-digest-mail-forward)
+ (gnus-uu-initialize):
* nnmail.el (nnmail-make-complex-temp-name, nnmail-get-new-mail):
- Use make-temp-file.
+ Use make-temp-file.
1999-09-07 Eli Zaretskii <eliz@gnu.org>
@@ -506,10 +506,10 @@
1998-08-13 Simon Josefsson <jas@pdc.kth.se>
- * gnus-msg.el (gnus-setup-message): use message-setup-hook
- instead
- (gnus-configure-posting-styles): new posting-style 'body
- (gnus-configure-posting-styles): insert headers immediately
+ * gnus-msg.el (gnus-setup-message): Use message-setup-hook
+ instead.
+ (gnus-configure-posting-styles): New posting-style 'body.
+ (gnus-configure-posting-styles): Insert headers immediately
1998-08-13 Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -524,9 +524,9 @@
1998-08-12 Simon Josefsson <jas@pdc.kth.se>
- * gnus-cache.el (gnus-uncacheable-groups): doc change
- (gnus-cacheable-groups): new variable
- (gnus-cache-possibly-enter-article): use it
+ * gnus-cache.el (gnus-uncacheable-groups): Doc change.
+ (gnus-cacheable-groups): New variable.
+ (gnus-cache-possibly-enter-article): Use it.
1998-08-12 Lars Magne Ingebrigtsen <larsi@gnus.org>
diff --git a/lisp/gnus/ChangeLog.2 b/lisp/gnus/ChangeLog.2
index 78bc7d4acdc..767b50bbe09 100644
--- a/lisp/gnus/ChangeLog.2
+++ b/lisp/gnus/ChangeLog.2
@@ -694,11 +694,11 @@
(gnus-agent-regenerate): Uses new gnus-agent-covered-methods
function as gnus-agent-covered-methods variable no longer provides
methods.
- (gnus-agent-covered-methods): New function
+ (gnus-agent-covered-methods): New function.
(gnus-agent-expire-group, gnus-agent-expire): Final message will,
if gnus-verbose is greater than 4, report statistics of NOV
entries and files deleted as well as total bytes recovered.
- (gnus-agent-expire-done-message): New function
+ (gnus-agent-expire-done-message): New function.
(gnus-agent-unread-articles): Bug fix. No longer drops last
unread article onto read list.
(gnus-agent-regenerate-group): Changed prompt to use typical
@@ -900,7 +900,7 @@
* spam.el
(spam-log-processing-to-registry): Improved message and comments.
- (spam-log-unregistration-needed-p): New function
+ (spam-log-unregistration-needed-p): New function.
(spam-ifile-register-spam-routine)
(spam-ifile-register-ham-routine, spam-stat-register-spam-routine)
(spam-stat-register-ham-routine)
@@ -1120,7 +1120,7 @@
* message.el (message-mode-field-menu): Added
message-generate-unsubscribed-mail-followup-to.
- (message-forward-subject-fwd): Avoid double "Fwd: "
+ (message-forward-subject-fwd): Avoid double "Fwd: ".
(message-change-subject): Added comment.
2003-10-19 Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -2084,7 +2084,7 @@
(spam-spamoracle-learn-ham, spam-spamoracle-learn-spam): New functions.
* gnus.el (gnus-group-spam-exit-processor-spamoracle)
- (gnus-group-ham-exit-processor-spamoracle): New variables for SpamOracle
+ (gnus-group-ham-exit-processor-spamoracle): New variables for SpamOracle.
(spam-process, ham-process): Added spamoracle spam/ham processors.
2003-06-08 Jesper Harder <harder@ifa.au.dk>
@@ -2781,7 +2781,7 @@
* gnus-registry.el (gnus-registry-split-fancy-with-parent): Added
diagnostic message.
(gnus-registry-grep-in-list): Don't run when word is nil.
- (gnus-registry-fetch-message-id-fast): New function
+ (gnus-registry-fetch-message-id-fast): New function.
(gnus-registry-delete-group, gnus-registry-add-group): Make sure
the id and group are not nil.
(gnus-registry-register-message-ids): New function.
@@ -3561,7 +3561,7 @@
`message-valid-fqdn-regexp' for initialization.
(gnus-button-handle-info-url): Renamed and extended version of
`gnus-button-handle-info'.
- (gnus-button-message-level): Renamed from `gnus-button-mail-level'
+ (gnus-button-message-level): Renamed from `gnus-button-mail-level'.
(gnus-button-handle-symbol, gnus-button-handle-library)
(gnus-button-handle-info-keystrokes): New functions.
(gnus-button-browse-level): New variable.
@@ -4904,8 +4904,8 @@
2003-02-08 Michael Welsh Duggan <md5i@cs.cmu.edu>
* nnmail.el (nnmail-split-it): If a message ends up matching the
- same mailbox more than once, it will cause duplicates to appear
- in the mailbox.
+ same mailbox more than once, it will cause duplicates to appear
+ in the mailbox.
2003-02-08 Simon Josefsson <jas@extundo.com>
@@ -5552,8 +5552,8 @@
2003-01-13 Jhair Tocancipa Triana <jhair_tocancipa@gmx.net>
* gnus-audio.el (gnus-audio-au-player, gnus-audio-wav-player): Use
- /usr/bin/play as default player.
- (gnus-audio-play): Added ARG-DESCRIPTOR to prompt for a file to play.
+ /usr/bin/play as default player.
+ (gnus-audio-play): Added ARG-DESCRIPTOR to prompt for a file to play.
2003-01-14 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -6295,8 +6295,8 @@
2003-01-02 Reiner Steib <Reiner.Steib@gmx.de>
- * gnus-art.el (gnus-button-url-regexp,
- (gnus-button-mid-or-mail-regexp, gnus-button-alist,
+ * gnus-art.el (gnus-button-url-regexp)
+ (gnus-button-mid-or-mail-regexp, gnus-button-alist)
(gnus-header-button-alist): Regexps are case insensitive here.
2003-01-02 Simon Josefsson <jas@extundo.com>
@@ -7194,7 +7194,7 @@
2002-10-31 Alex Schroeder <alex@emacswiki.org>
- * spam-stat.el (spam-stat-process-directory): Add dir to message
+ * spam-stat.el (spam-stat-process-directory): Add dir to message.
(spam-stat-reduce-size): No longer remove words
with values close to 0.5, because the default value is 0.2.
@@ -9033,7 +9033,7 @@
boolean not a string
* gnus-group.el (gnus-group-line-format): Add description of %C
* gnus-group.el (gnus-group-line-format-alist): Add gnus-tmp-comment
- as %C
+ as %C
* gnus-group.el (gnus-group-insert-group-line): Add gnus-tmp-comment.
2002-04-22 Paul Jarc <prj@po.cwru.edu>
@@ -11325,7 +11325,7 @@
2002-01-02 ShengHuo ZHU <zsh@cs.rochester.edu>
* gnus-picon.el (gnus-picon-transform-newsgroups): Fix for the case
- "Newsgroups: rec.music.beatles.moderated, rec.music.beatles".
+ "Newsgroups: rec.music.beatles.moderated, rec.music.beatles".
2002-01-03 Steve Youngs <youngs@xemacs.org>
@@ -12255,7 +12255,7 @@
(imap-stream-alist): Backslash.
* gnus-sum.el (gnus-summary-limit-to-author): Missing arguments.
- Thanks to david.goldberg6@verizon.net (David S. Goldberg).
+ Thanks to david.goldberg6@verizon.net (David S. Goldberg).
2001-11-27 14:00:00 ShengHuo ZHU <zsh@cs.rochester.edu>
@@ -12402,7 +12402,7 @@
Support "Importance:" header in Message.
* message.el (message-mode-map): Bind C-c C-p to
- `message-insert-or-toggle-importance'
+ `message-insert-or-toggle-importance'.
(message-mode-menu): Add message-insert-importance-{high,low}.
(message-insert-importance-high, message-insert-importance-low)
(message-insert-or-toggle-importance): New functions.
@@ -12754,7 +12754,7 @@
2001-10-30 13:00:00 ShengHuo ZHU <zsh@cs.rochester.edu>
* gnus-spec.el (gnus-parse-simple-format): Use
- buffer-substring-no-properties.
+ buffer-substring-no-properties.
2001-10-30 Katsumi Yamaoka <yamaoka@jpl.org>
@@ -12870,7 +12870,7 @@
2001-10-21 Simon Josefsson <jas@extundo.com>
- * nnimap.el (nnimap): Defgroup
+ * nnimap.el (nnimap): Defgroup.
(nnimap-strict-function, nnimap-strict-function-match): New
widget, from Per Abrahamsen <abraham@dina.kvl.dk>.
(nnimap-split-crosspost, nnimap-split-inbox)
@@ -16433,7 +16433,7 @@
2001-01-09 Didier Verna <didier@xemacs.org>
* gnus-agent.el: Moved some XEmacs specific hook add-ons from
- `gnus-xmas-[re]define' to avoid loosing user custom settings.
+ `gnus-xmas-[re]define' to avoid losing user custom settings.
* gnus-art.el: Ditto.
* gnus-group.el: Ditto.
* gnus-salt.el: Ditto.
@@ -16688,7 +16688,7 @@
* gnus-cus.el (gnus-group-customize): Use it.
* gnus.el (gnus-define-group-parameter): New macro.
- (auto-expire): Use it
+ (auto-expire): Use it.
(total-expire): Use it.
* gnus-art.el (banner): Use it.
diff --git a/lisp/gnus/auth-source.el b/lisp/gnus/auth-source.el
index 284e6e911bd..20e4af189d9 100644
--- a/lisp/gnus/auth-source.el
+++ b/lisp/gnus/auth-source.el
@@ -29,12 +29,27 @@
;; See the auth.info Info documentation for details.
+;; TODO:
+
+;; - never decode the backend file unless it's necessary
+;; - a more generic way to match backends and search backend contents
+;; - absorb netrc.el and simplify it
+;; - protect passwords better
+;; - allow creating and changing netrc lines (not files) e.g. change a password
+
;;; Code:
(require 'gnus-util)
+(require 'netrc)
(eval-when-compile (require 'cl))
-(eval-when-compile (require 'netrc))
+(autoload 'secrets-create-item "secrets")
+(autoload 'secrets-delete-item "secrets")
+(autoload 'secrets-get-alias "secrets")
+(autoload 'secrets-get-attribute "secrets")
+(autoload 'secrets-get-secret "secrets")
+(autoload 'secrets-list-collections "secrets")
+(autoload 'secrets-search-items "secrets")
(defgroup auth-source nil
"Authentication sources."
@@ -42,28 +57,29 @@
:group 'gnus)
(defcustom auth-source-protocols '((imap "imap" "imaps" "143" "993")
- (pop3 "pop3" "pop" "pop3s" "110" "995")
- (ssh "ssh" "22")
- (sftp "sftp" "115")
- (smtp "smtp" "25"))
+ (pop3 "pop3" "pop" "pop3s" "110" "995")
+ (ssh "ssh" "22")
+ (sftp "sftp" "115")
+ (smtp "smtp" "25"))
"List of authentication protocols and their names"
:group 'auth-source
- :version "23.1" ;; No Gnus
+ :version "23.2" ;; No Gnus
:type '(repeat :tag "Authentication Protocols"
- (cons :tag "Protocol Entry"
- (symbol :tag "Protocol")
- (repeat :tag "Names"
- (string :tag "Name")))))
+ (cons :tag "Protocol Entry"
+ (symbol :tag "Protocol")
+ (repeat :tag "Names"
+ (string :tag "Name")))))
;;; generate all the protocols in a format Customize can use
+;;; TODO: generate on the fly from auth-source-protocols
(defconst auth-source-protocols-customize
(mapcar (lambda (a)
- (let ((p (car-safe a)))
- (list 'const
- :tag (upcase (symbol-name p))
- p)))
- auth-source-protocols))
+ (let ((p (car-safe a)))
+ (list 'const
+ :tag (upcase (symbol-name p))
+ p)))
+ auth-source-protocols))
(defvar auth-source-cache (make-hash-table :test 'equal)
"Cache for auth-source data")
@@ -71,7 +87,7 @@
(defcustom auth-source-do-cache t
"Whether auth-source should cache information."
:group 'auth-source
- :version "23.1" ;; No Gnus
+ :version "23.2" ;; No Gnus
:type `boolean)
(defcustom auth-source-debug nil
@@ -85,40 +101,63 @@ If the value is t, debug messages are logged with `message'.
If the value is a function, debug messages are logged by calling
that function using the same arguments as `message'."
:group 'auth-source
- :version "23.1" ;; No Gnus
- :type `(choice
- :tag "auth-source debugging mode"
- (const :tag "Log using `message' to the *Messages* buffer" t)
- (function :tag "Function that takes arguments like `message'")
- (const :tag "Don't log anything" nil)))
+ :version "23.2" ;; No Gnus
+ :type `(choice
+ :tag "auth-source debugging mode"
+ (const :tag "Log using `message' to the *Messages* buffer" t)
+ (function :tag "Function that takes arguments like `message'")
+ (const :tag "Don't log anything" nil)))
(defcustom auth-source-hide-passwords t
"Whether auth-source should hide passwords in log messages.
Only relevant if `auth-source-debug' is not nil."
:group 'auth-source
- :version "23.1" ;; No Gnus
+ :version "23.2" ;; No Gnus
:type `boolean)
-(defcustom auth-sources '((:source "~/.authinfo.gpg" :host t :protocol t))
+(defcustom auth-sources '((:source "~/.authinfo.gpg")
+ (:source "~/.authinfo"))
"List of authentication sources.
-Each entry is the authentication type with optional properties."
+The default will get login and password information from a .gpg
+file, which you should set up with the EPA/EPG packages to be
+encrypted. See the auth.info manual for details.
+
+Each entry is the authentication type with optional properties.
+
+It's best to customize this with `M-x customize-variable' because the choices
+can get pretty complex."
:group 'auth-source
- :version "23.1" ;; No Gnus
+ :version "23.2" ;; No Gnus
:type `(repeat :tag "Authentication Sources"
- (list :tag "Source definition"
- (const :format "" :value :source)
- (string :tag "Authentication Source")
- (const :format "" :value :host)
- (choice :tag "Host (machine) choice"
- (const :tag "Any" t)
- (regexp :tag "Host (machine) regular expression (TODO)")
- (const :tag "Fallback" nil))
- (const :format "" :value :protocol)
- (choice :tag "Protocol"
- (const :tag "Any" t)
- (const :tag "Fallback" nil)
- ,@auth-source-protocols-customize))))
+ (list :tag "Source definition"
+ (const :format "" :value :source)
+ (choice :tag "Authentication backend choice"
+ (string :tag "Authentication Source (file)")
+ (list :tag "secrets.el (Secret Service API/KWallet/GNOME Keyring)"
+ (const :format "" :value :secrets)
+ (choice :tag "Collection to use"
+ (string :tag "Collection name")
+ (const :tag "Default" 'default)
+ (const :tag "Login" "login")
+ (const :tag "Temporary" "session"))))
+ (repeat :tag "Extra Parameters" :inline t
+ (choice :tag "Extra parameter"
+ (list :tag "Host (omit to match as a fallback)"
+ (const :format "" :value :host)
+ (choice :tag "Host (machine) choice"
+ (const :tag "Any" t)
+ (regexp :tag "Host (machine) regular expression")))
+ (list :tag "Protocol (omit to match as a fallback)"
+ (const :format "" :value :protocol)
+ (choice :tag "Protocol"
+ (const :tag "Any" t)
+ ,@auth-source-protocols-customize))
+ (list :tag "User (omit to match as a fallback)" :inline t
+ (const :format "" :value :user)
+ (choice :tag "Personality or username"
+ (const :tag "Any" t)
+ (string :tag "Specific user name"))))))))
;; temp for debugging
;; (unintern 'auth-source-protocols)
@@ -129,7 +168,7 @@ Each entry is the authentication type with optional properties."
;; (customize-variable 'auth-source-protocols)
;; (setq auth-source-protocols nil)
;; (format "%S" auth-source-protocols)
-;; (auth-source-pick "a" 'imap)
+;; (auth-source-pick nil :host "a" :port 'imap)
;; (auth-source-user-or-password "login" "imap.myhost.com" 'imap)
;; (auth-source-user-or-password "password" "imap.myhost.com" 'imap)
;; (auth-source-user-or-password-imap "login" "imap.myhost.com")
@@ -145,78 +184,300 @@ Each entry is the authentication type with optional properties."
;; we also check the value
(when auth-source-debug
(let ((logger (if (functionp auth-source-debug)
- auth-source-debug
- 'message)))
+ auth-source-debug
+ 'message)))
(apply logger msg))))
-(defun auth-source-pick (host protocol &optional fallback)
- "Parse `auth-sources' for HOST, and PROTOCOL matches.
-
-Returns fallback choices (where PROTOCOL or HOST are nil) with FALLBACK t."
- (interactive "sHost: \nsProtocol: \n") ;for testing
- (let (choices)
- (dolist (choice auth-sources)
- (let ((h (plist-get choice :host))
- (p (plist-get choice :protocol)))
- (when (and
- (or (equal t h)
- (and (stringp h) (string-match h host))
- (and fallback (equal h nil)))
- (or (equal t p)
- (and (symbolp p) (equal p protocol))
- (and fallback (equal p nil))))
- (push choice choices))))
- (if choices
- choices
- (unless fallback
- (auth-source-pick host protocol t)))))
-
-(defun auth-source-forget-user-or-password (mode host protocol)
+;; (auth-source-pick nil :host "any" :protocol 'imap :user "joe")
+;; (auth-source-pick t :host "any" :protocol 'imap :user "joe")
+;; (setq auth-sources '((:source (:secrets default) :host t :protocol t :user "joe")
+;; (:source (:secrets "session") :host t :protocol t :user "joe")
+;; (:source (:secrets "login") :host t :protocol t)
+;; (:source "~/.authinfo.gpg" :host t :protocol t)))
+
+;; (setq auth-sources '((:source (:secrets default) :host t :protocol t :user "joe")
+;; (:source (:secrets "session") :host t :protocol t :user "joe")
+;; (:source (:secrets "login") :host t :protocol t)
+;; ))
+
+;; (setq auth-sources '((:source "~/.authinfo.gpg" :host t :protocol t)))
+
+(defun auth-get-source (entry)
+ "Return the source string of ENTRY, which is one entry in `auth-sources'.
+If it is a Secret Service API, return the collection name, otherwise
+the file name."
+ (let ((source (plist-get entry :source)))
+ (if (stringp source)
+ source
+ ;; Secret Service API.
+ (setq source (plist-get source :secrets))
+ (when (eq source 'default)
+ (setq source (or (secrets-get-alias "default") "login")))
+ (or source "session"))))
+
+(defun auth-source-pick (&rest spec)
+ "Parse `auth-sources' for matches of the SPEC plist.
+
+Common keys are :host, :protocol, and :user. A value of t in
+SPEC means to always succeed in the match. A string value is
+matched as a regex."
+ (let ((keys (loop for i below (length spec) by 2 collect (nth i spec)))
+ choices)
+ (dolist (choice (copy-tree auth-sources) choices)
+ (let ((source (plist-get choice :source))
+ (match t))
+ (when
+ (and
+ ;; Check existence of source.
+ (if (consp source)
+ ;; Secret Service API.
+ (member (auth-get-source choice) (secrets-list-collections))
+ ;; authinfo file.
+ (file-exists-p source))
+
+ ;; Check keywords.
+ (dolist (k keys match)
+ (let* ((v (plist-get spec k))
+ (choicev (if (plist-member choice k)
+ (plist-get choice k) t)))
+ (setq match
+ (and match
+ (or
+ ;; source always matches spec key
+ (eq t choicev)
+ ;; source key gives regex to match against spec
+ (and (stringp choicev) (string-match choicev v))
+ ;; source key gives symbol to match against spec
+ (and (symbolp choicev) (eq choicev v))))))))
+
+ (add-to-list 'choices choice 'append))))))
+
+(defun auth-source-retrieve (mode entry &rest spec)
+ "Retrieve MODE credentials according to SPEC from ENTRY."
+ (catch 'no-password
+ (let ((host (plist-get spec :host))
+ (user (plist-get spec :user))
+ (prot (plist-get spec :protocol))
+ (source (plist-get entry :source))
+ result)
+ (cond
+ ;; Secret Service API.
+ ((consp source)
+ (let ((coll (auth-get-source entry))
+ item)
+ ;; Loop over candidates with a matching host attribute.
+ (dolist (elt (secrets-search-items coll :host host) item)
+ (when (and (or (not user)
+ (string-equal
+ user (secrets-get-attribute coll elt :user)))
+ (or (not prot)
+ (string-equal
+ prot (secrets-get-attribute coll elt :protocol))))
+ (setq item elt)
+ (return elt)))
+ ;; Compose result.
+ (when item
+ (setq result
+ (mapcar (lambda (m)
+ (if (string-equal "password" m)
+ (or (secrets-get-secret coll item)
+ ;; When we do not find a password,
+ ;; we return nil anyway.
+ (throw 'no-password nil))
+ (or (secrets-get-attribute coll item :user)
+ user)))
+ (if (consp mode) mode (list mode)))))
+ (if (consp mode) result (car result))))
+ ;; Anything else is netrc.
+ (t
+ (let ((search (list source (list host) (list (format "%s" prot))
+ (auth-source-protocol-defaults prot))))
+ (setq result
+ (mapcar (lambda (m)
+ (if (string-equal "password" m)
+ (or (apply
+ 'netrc-machine-user-or-password m search)
+ ;; When we do not find a password, we
+ ;; return nil anyway.
+ (throw 'no-password nil))
+ (or (apply
+ 'netrc-machine-user-or-password m search)
+ user)))
+ (if (consp mode) mode (list mode)))))
+ (if (consp mode) result (car result)))))))
+
+(defun auth-source-create (mode entry &rest spec)
+ "Create interactively credentials according to SPEC in ENTRY.
+Return structure as specified by MODE."
+ (let* ((host (plist-get spec :host))
+ (user (plist-get spec :user))
+ (prot (plist-get spec :protocol))
+ (source (plist-get entry :source))
+ (name (concat (if user (format "%s@" user))
+ host
+ (if prot (format ":%s" prot))))
+ result)
+ (setq result
+ (mapcar
+ (lambda (m)
+ (cons
+ m
+ (cond
+ ((equal "password" m)
+ (let ((passwd (read-passwd
+ (format "Password for %s on %s: " prot host))))
+ (cond
+ ;; Secret Service API.
+ ((consp source)
+ (apply
+ 'secrets-create-item
+ (auth-get-source entry) name passwd spec))
+ (t)) ;; netrc not implemented yes.
+ passwd))
+ ((equal "login" m)
+ (or user
+ (read-string
+ (format "User name for %s on %s (default %s): " prot host
+ (user-login-name))
+ nil nil (user-login-name))))
+ (t
+ "unknownuser"))))
+ (if (consp mode) mode (list mode))))
+ ;; Allow the source to save the data.
+ (cond
+ ((consp source)
+ ;; Secret Service API -- not implemented.
+ )
+ (t
+ ;; netrc interface.
+ (when (y-or-n-p (format "Do you want to save this password in %s? "
+ source))
+ (netrc-store-data source host prot
+ (or user (cdr (assoc "login" result)))
+ (cdr (assoc "password" result))))))
+ (if (consp mode)
+ (mapcar #'cdr result)
+ (cdar result))))
+
+(defun auth-source-delete (entry &rest spec)
+ "Delete credentials according to SPEC in ENTRY."
+ (let ((host (plist-get spec :host))
+ (user (plist-get spec :user))
+ (prot (plist-get spec :protocol))
+ (source (plist-get entry :source)))
+ (cond
+ ;; Secret Service API.
+ ((consp source)
+ (let ((coll (auth-get-source entry)))
+ ;; Loop over candidates with a matching host attribute.
+ (dolist (elt (secrets-search-items coll :host host))
+ (when (and (or (not user)
+ (string-equal
+ user (secrets-get-attribute coll elt :user)))
+ (or (not prot)
+ (string-equal
+ prot (secrets-get-attribute coll elt :protocol))))
+ (secrets-delete-item coll elt)))))
+ (t)))) ;; netrc not implemented yes.
+
+(defun auth-source-forget-user-or-password
+ (mode host protocol &optional username)
+ "Remove cached authentication token."
(interactive "slogin/password: \nsHost: \nsProtocol: \n") ;for testing
- (remhash (format "%s %s:%s" mode host protocol) auth-source-cache))
+ (remhash
+ (if username
+ (format "%s %s:%s %s" mode host protocol username)
+ (format "%s %s:%s" mode host protocol))
+ auth-source-cache))
(defun auth-source-forget-all-cached ()
"Forget all cached auth-source authentication tokens."
(interactive)
(setq auth-source-cache (make-hash-table :test 'equal)))
-(defun auth-source-user-or-password (mode host protocol)
+;; (progn
+;; (auth-source-forget-all-cached)
+;; (list
+;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" "other")
+;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" "other" "tzz")
+;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" "other" "joe")))
+
+(defun auth-source-user-or-password
+ (mode host protocol &optional username create-missing delete-existing)
"Find MODE (string or list of strings) matching HOST and PROTOCOL.
-MODE can be \"login\" or \"password\" for example."
+
+USERNAME is optional and will be used as \"login\" in a search
+across the Secret Service API (see secrets.el) if the resulting
+items don't have a username. This means that if you search for
+username \"joe\" and it matches an item but the item doesn't have
+a :user attribute, the username \"joe\" will be returned.
+
+A non nil DELETE-EXISTING means deleting any matching password
+entry in the respective sources. This is useful only when
+CREATE-MISSING is non nil as well; the intended use case is to
+remove wrong password entries.
+
+If no matching entry is found, and CREATE-MISSING is non nil,
+the password will be retrieved interactively, and it will be
+stored in the password database which matches best (see
+`auth-sources').
+
+MODE can be \"login\" or \"password\"."
(auth-source-do-debug
- "auth-source-user-or-password: get %s for %s (%s)"
- mode host protocol)
+ "auth-source-user-or-password: get %s for %s (%s) + user=%s"
+ mode host protocol username)
(let* ((listy (listp mode))
- (mode (if listy mode (list mode)))
- (cname (format "%s %s:%s" mode host protocol))
- (found (gethash cname auth-source-cache)))
+ (mode (if listy mode (list mode)))
+ (cname (if username
+ (format "%s %s:%s %s" mode host protocol username)
+ (format "%s %s:%s" mode host protocol)))
+ (search (list :host host :protocol protocol))
+ (search (if username (append search (list :user username)) search))
+ (found (if (not delete-existing)
+ (gethash cname auth-source-cache)
+ (remhash cname auth-source-cache)
+ nil)))
(if found
- (progn
- (auth-source-do-debug
- "auth-source-user-or-password: cached %s=%s for %s (%s)"
- mode
- ;; don't show the password
- (if (and (member "password" mode) auth-source-hide-passwords) "SECRET" found)
- host protocol)
- found)
- (dolist (choice (auth-source-pick host protocol))
- (setq found (netrc-machine-user-or-password
- mode
- (plist-get choice :source)
- (list host)
- (list (format "%s" protocol))
- (auth-source-protocol-defaults protocol)))
- (when found
- (auth-source-do-debug
- "auth-source-user-or-password: found %s=%s for %s (%s)"
- mode
- ;; don't show the password
- (if (and (member "password" mode) auth-source-hide-passwords) "SECRET" found)
- host protocol)
- (setq found (if listy found (car-safe found)))
- (when auth-source-do-cache
- (puthash cname found auth-source-cache)))
- (return found)))))
+ (progn
+ (auth-source-do-debug
+ "auth-source-user-or-password: cached %s=%s for %s (%s) + %s"
+ mode
+ ;; don't show the password
+ (if (and (member "password" mode) auth-source-hide-passwords)
+ "SECRET"
+ found)
+ host protocol username)
+ found) ; return the found data
+ ;; else, if not found
+ (let ((choices (apply 'auth-source-pick search)))
+ (dolist (choice choices)
+ (if delete-existing
+ (apply 'auth-source-delete choice search)
+ (setq found (apply 'auth-source-retrieve mode choice search)))
+ (and found (return found)))
+
+ ;; We haven't found something, so we will create it interactively.
+ (when (and (not found) create-missing)
+ (setq found (apply 'auth-source-create
+ mode (if choices
+ (car choices)
+ (car auth-sources))
+ search)))
+
+ ;; Cache the result.
+ (when found
+ (auth-source-do-debug
+ "auth-source-user-or-password: found %s=%s for %s (%s) + %s"
+ mode
+ ;; don't show the password
+ (if (and (member "password" mode) auth-source-hide-passwords)
+ "SECRET" found)
+ host protocol username)
+ (setq found (if listy found (car-safe found)))
+ (when auth-source-do-cache
+ (puthash cname found auth-source-cache)))
+
+ found))))
(defun auth-source-protocol-defaults (protocol)
"Return a list of default ports and names for PROTOCOL."
@@ -239,5 +500,4 @@ MODE can be \"login\" or \"password\" for example."
(provide 'auth-source)
-;; arch-tag: ff1afe78-06e9-42c2-b693-e9f922cbe4ab
;;; auth-source.el ends here
diff --git a/lisp/gnus/canlock.el b/lisp/gnus/canlock.el
index 7f7f7694e0a..4298bc901cd 100644
--- a/lisp/gnus/canlock.el
+++ b/lisp/gnus/canlock.el
@@ -247,5 +247,4 @@ it fails."
(provide 'canlock)
-;; arch-tag: 033c4f09-b9f1-459d-bd0d-254430283f78
;;; canlock.el ends here
diff --git a/lisp/gnus/color.el b/lisp/gnus/color.el
new file mode 100644
index 00000000000..4d3718bc8df
--- /dev/null
+++ b/lisp/gnus/color.el
@@ -0,0 +1,268 @@
+;;; color.el --- Color manipulation laboratory routines -*- coding: utf-8; -*-
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Julien Danjou <julien@danjou.info>
+;; Keywords: 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 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package provides color manipulation functions.
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+
+;; Emacs < 23.3
+(eval-and-compile
+ (unless (boundp 'float-pi)
+ (defconst float-pi (* 4 (atan 1)) "The value of Pi (3.1415926...).")))
+
+(defun color-rgb->hex (red green blue)
+ "Return hexadecimal notation for RED GREEN BLUE color.
+RED GREEN BLUE must be values between [0,1]."
+ (format "#%02x%02x%02x"
+ (* red 255) (* green 255) (* blue 255)))
+
+(defun color-complement (color)
+ "Return the color that is the complement of COLOR."
+ (let ((color (color-rgb->normalize color)))
+ (list (- 1.0 (car color))
+ (- 1.0 (cadr color))
+ (- 1.0 (caddr color)))))
+
+(defun color-complement-hex (color)
+ "Return the color that is the complement of COLOR, in hexadecimal format."
+ (apply 'color-rgb->hex (color-complement color)))
+
+(defun color-rgb->hsv (red green blue)
+ "Convert RED GREEN BLUE values to HSV representation.
+Hue is in radian. Saturation and values are between [0,1]."
+ (let* ((r (float red))
+ (g (float green))
+ (b (float blue))
+ (max (max r g b))
+ (min (min r g b)))
+ (list
+ (/ (* 2 float-pi
+ (cond ((and (= r g) (= g b)) 0)
+ ((and (= r max)
+ (>= g b))
+ (* 60 (/ (- g b) (- max min))))
+ ((and (= r max)
+ (< g b))
+ (+ 360 (* 60 (/ (- g b) (- max min)))))
+ ((= max g)
+ (+ 120 (* 60 (/ (- b r) (- max min)))))
+ ((= max b)
+ (+ 240 (* 60 (/ (- r g) (- max min)))))))
+ 360)
+ (if (= max 0)
+ 0
+ (- 1 (/ min max)))
+ (/ max 255.0))))
+
+(defun color-rgb->hsl (red green blue)
+ "Convert RED GREEN BLUE colors to their HSL representation.
+RED, GREEN and BLUE must be between [0,1]."
+ (let* ((r red)
+ (g green)
+ (b blue)
+ (max (max r g b))
+ (min (min r g b))
+ (delta (- max min))
+ (l (/ (+ max min) 2.0)))
+ (list
+ (if (= max min)
+ 0
+ (* 2 float-pi
+ (/ (cond ((= max r)
+ (+ (/ (- g b) delta) (if (< g b) 6 0)))
+ ((= max g)
+ (+ (/ (- b r) delta) 2))
+ (t
+ (+ (/ (- r g) delta) 4)))
+ 6)))
+ (if (= max min)
+ 0
+ (if (> l 0.5)
+ (/ delta (- 2 (+ max min)))
+ (/ delta (+ max min))))
+ l)))
+
+(defun color-srgb->xyz (red green blue)
+ "Converts RED GREEN BLUE colors from the sRGB color space to CIE XYZ.
+RED, BLUE and GREEN must be between [0,1]."
+ (let ((r (if (<= red 0.04045)
+ (/ red 12.95)
+ (expt (/ (+ red 0.055) 1.055) 2.4)))
+ (g (if (<= green 0.04045)
+ (/ green 12.95)
+ (expt (/ (+ green 0.055) 1.055) 2.4)))
+ (b (if (<= blue 0.04045)
+ (/ blue 12.95)
+ (expt (/ (+ blue 0.055) 1.055) 2.4))))
+ (list (+ (* 0.4124564 r) (* 0.3575761 g) (* 0.1804375 b))
+ (+ (* 0.21266729 r) (* 0.7151522 g) (* 0.0721750 b))
+ (+ (* 0.0193339 r) (* 0.1191920 g) (* 0.9503041 b)))))
+
+(defun color-xyz->srgb (X Y Z)
+ "Converts CIE X Y Z colors to sRGB color space."
+ (let ((r (+ (* 3.2404542 X) (* -1.5371385 Y) (* -0.4985314 Z)))
+ (g (+ (* -0.9692660 X) (* 1.8760108 Y) (* 0.0415560 Z)))
+ (b (+ (* 0.0556434 X) (* -0.2040259 Y) (* 1.0572252 Z))))
+ (list (if (<= r 0.0031308)
+ (* 12.92 r)
+ (- (* 1.055 (expt r (/ 1 2.4))) 0.055))
+ (if (<= g 0.0031308)
+ (* 12.92 g)
+ (- (* 1.055 (expt g (/ 1 2.4))) 0.055))
+ (if (<= b 0.0031308)
+ (* 12.92 b)
+ (- (* 1.055 (expt b (/ 1 2.4))) 0.055)))))
+
+(defconst color-d65-xyz '(0.950455 1.0 1.088753)
+ "D65 white point in CIE XYZ.")
+
+(defconst color-cie-ε (/ 216 24389.0))
+(defconst color-cie-κ (/ 24389 27.0))
+
+(defun color-xyz->lab (X Y Z &optional white-point)
+ "Converts CIE XYZ to CIE L*a*b*.
+WHITE-POINT can be specified as (X Y Z) white point to use. If
+none is set, `color-d65-xyz' is used."
+ (destructuring-bind (Xr Yr Zr) (or white-point color-d65-xyz)
+ (let* ((xr (/ X Xr))
+ (yr (/ Y Yr))
+ (zr (/ Z Zr))
+ (fx (if (> xr color-cie-ε)
+ (expt xr (/ 1 3.0))
+ (/ (+ (* color-cie-κ xr) 16) 116.0)))
+ (fy (if (> yr color-cie-ε)
+ (expt yr (/ 1 3.0))
+ (/ (+ (* color-cie-κ yr) 16) 116.0)))
+ (fz (if (> zr color-cie-ε)
+ (expt zr (/ 1 3.0))
+ (/ (+ (* color-cie-κ zr) 16) 116.0))))
+ (list
+ (- (* 116 fy) 16) ; L
+ (* 500 (- fx fy)) ; a
+ (* 200 (- fy fz)))))) ; b
+
+(defun color-lab->xyz (L a b &optional white-point)
+ "Converts CIE L*a*b* to CIE XYZ.
+WHITE-POINT can be specified as (X Y Z) white point to use. If
+none is set, `color-d65-xyz' is used."
+ (destructuring-bind (Xr Yr Zr) (or white-point color-d65-xyz)
+ (let* ((fy (/ (+ L 16) 116.0))
+ (fz (- fy (/ b 200.0)))
+ (fx (+ (/ a 500.0) fy))
+ (xr (if (> (expt fx 3.0) color-cie-ε)
+ (expt fx 3.0)
+ (/ (- (* fx 116) 16) color-cie-κ)))
+ (yr (if (> L (* color-cie-κ color-cie-ε))
+ (expt (/ (+ L 16) 116.0) 3.0)
+ (/ L color-cie-κ)))
+ (zr (if (> (expt fz 3) color-cie-ε)
+ (expt fz 3.0)
+ (/ (- (* 116 fz) 16) color-cie-κ))))
+ (list (* xr Xr) ; X
+ (* yr Yr) ; Y
+ (* zr Zr))))) ; Z
+
+(defun color-srgb->lab (red green blue)
+ "Converts RGB to CIE L*a*b*."
+ (apply 'color-xyz->lab (color-srgb->xyz red green blue)))
+
+(defun color-rgb->normalize (color)
+ "Normalize a RGB color to values between [0,1]."
+ (mapcar (lambda (x) (/ x 65535.0)) (x-color-values color)))
+
+(defun color-lab->srgb (L a b)
+ "Converts CIE L*a*b* to RGB."
+ (apply 'color-xyz->rgb (color-lab->xyz L a b)))
+
+(defun color-cie-de2000 (color1 color2 &optional kL kC kH)
+ "Computes the CIEDE2000 color distance between COLOR1 and COLOR2.
+Colors must be in CIE L*a*b* format."
+ (destructuring-bind (L₁ a₁ b₁) color1
+ (destructuring-bind (L₂ a₂ b₂) color2
+ (let* ((kL (or kL 1))
+ (kC (or kC 1))
+ (kH (or kH 1))
+ (C₁ (sqrt (+ (expt a₁ 2.0) (expt b₁ 2.0))))
+ (C₂ (sqrt (+ (expt a₂ 2.0) (expt b₂ 2.0))))
+ (C̄ (/ (+ C₁ C₂) 2.0))
+ (G (* 0.5 (- 1 (sqrt (/ (expt C̄ 7.0) (+ (expt C̄ 7.0) (expt 25 7.0)))))))
+ (a′₁ (* (+ 1 G) a₁))
+ (a′₂ (* (+ 1 G) a₂))
+ (C′₁ (sqrt (+ (expt a′₁ 2.0) (expt b₁ 2.0))))
+ (C′₂ (sqrt (+ (expt a′₂ 2.0) (expt b₂ 2.0))))
+ (h′₁ (if (and (= b₁ 0) (= a′₁ 0))
+ 0
+ (let ((v (atan b₁ a′₁)))
+ (if (< v 0)
+ (+ v (* 2 float-pi))
+ v))))
+ (h′₂ (if (and (= b₂ 0) (= a′₂ 0))
+ 0
+ (let ((v (atan b₂ a′₂)))
+ (if (< v 0)
+ (+ v (* 2 float-pi))
+ v))))
+ (ΔL′ (- L₂ L₁))
+ (ΔC′ (- C′₂ C′₁))
+ (Δh′ (cond ((= (* C′₁ C′₂) 0)
+ 0)
+ ((<= (abs (- h′₂ h′₁)) float-pi)
+ (- h′₂ h′₁))
+ ((> (- h′₂ h′₁) float-pi)
+ (- (- h′₂ h′₁) (* 2 float-pi)))
+ ((< (- h′₂ h′₁) (- float-pi))
+ (+ (- h′₂ h′₁) (* 2 float-pi)))))
+ (ΔH′ (* 2 (sqrt (* C′₁ C′₂)) (sin (/ Δh′ 2.0))))
+ (L̄′ (/ (+ L₁ L₂) 2.0))
+ (C̄′ (/ (+ C′₁ C′₂) 2.0))
+ (h̄′ (cond ((= (* C′₁ C′₂) 0)
+ (+ h′₁ h′₂))
+ ((<= (abs (- h′₁ h′₂)) float-pi)
+ (/ (+ h′₁ h′₂) 2.0))
+ ((< (+ h′₁ h′₂) (* 2 float-pi))
+ (/ (+ h′₁ h′₂ (* 2 float-pi)) 2.0))
+ ((>= (+ h′₁ h′₂) (* 2 float-pi))
+ (/ (+ h′₁ h′₂ (* -2 float-pi)) 2.0))))
+ (T (+ 1
+ (- (* 0.17 (cos (- h̄′ (degrees-to-radians 30)))))
+ (* 0.24 (cos (* h̄′ 2)))
+ (* 0.32 (cos (+ (* h̄′ 3) (degrees-to-radians 6))))
+ (- (* 0.20 (cos (- (* h̄′ 4) (degrees-to-radians 63)))))))
+ (Δθ (* (degrees-to-radians 30) (exp (- (expt (/ (- h̄′ (degrees-to-radians 275)) (degrees-to-radians 25)) 2.0)))))
+ (Rc (* 2 (sqrt (/ (expt C̄′ 7.0) (+ (expt C̄′ 7.0) (expt 25.0 7.0))))))
+ (Sl (+ 1 (/ (* 0.015 (expt (- L̄′ 50) 2.0)) (sqrt (+ 20 (expt (- L̄′ 50) 2.0))))))
+ (Sc (+ 1 (* C̄′ 0.045)))
+ (Sh (+ 1 (* 0.015 C̄′ T)))
+ (Rt (- (* (sin (* Δθ 2)) Rc))))
+ (sqrt (+ (expt (/ ΔL′ (* Sl kL)) 2.0)
+ (expt (/ ΔC′ (* Sc kC)) 2.0)
+ (expt (/ ΔH′ (* Sh kH)) 2.0)
+ (* Rt (/ ΔC′ (* Sc kC)) (/ ΔH′ (* Sh kH)))))))))
+
+(provide 'color)
+
+;;; color.el ends here
diff --git a/lisp/gnus/compface.el b/lisp/gnus/compface.el
index 371d3467ec6..8c26341a6e2 100644
--- a/lisp/gnus/compface.el
+++ b/lisp/gnus/compface.el
@@ -58,5 +58,4 @@ or `faces-xface' and `netpbm' or `libgr-progs', for instance."
(provide 'compface)
-;; arch-tag: f9c78e84-98c0-4142-9682-8ba4cf4c3441
;;; compface.el ends here
diff --git a/lisp/gnus/deuglify.el b/lisp/gnus/deuglify.el
index d4b94a77e29..60f8c95bb2e 100644
--- a/lisp/gnus/deuglify.el
+++ b/lisp/gnus/deuglify.el
@@ -476,5 +476,4 @@ NODISPLAY is non-nil, don't redisplay the article buffer."
;; coding: iso-8859-1
;; End:
-;; arch-tag: 5f895cc9-51a9-487c-b42e-28844d79eb73
;;; deuglify.el ends here
diff --git a/lisp/gnus/earcon.el b/lisp/gnus/earcon.el
deleted file mode 100644
index c2ec52e21cd..00000000000
--- a/lisp/gnus/earcon.el
+++ /dev/null
@@ -1,233 +0,0 @@
-;;; earcon.el --- Sound effects for messages
-
-;; Copyright (C) 1996, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Steven L. Baur <steve@miranova.com>
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;; This file provides access to sound effects in Gnus.
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-(require 'gnus)
-(require 'gnus-audio)
-(require 'gnus-art)
-
-(defgroup earcon nil
- "Turn ** sounds ** into noise."
- :group 'gnus-visual)
-
-(defcustom earcon-prefix "**"
- "*String denoting the start of an earcon."
- :type 'string
- :group 'earcon)
-
-(defcustom earcon-suffix "**"
- "String denoting the end of an earcon."
- :type 'string
- :group 'earcon)
-
-(defcustom earcon-regexp-alist
- '(("boring" 1 "Boring.au")
- ("evil[ \t]+laugh" 1 "Evil_Laugh.au")
- ("gag\\|puke" 1 "Puke.au")
- ("snicker" 1 "Snicker.au")
- ("meow" 1 "catmeow.wav")
- ("sob\\|boohoo" 1 "cry.wav")
- ("drum[ \t]*roll" 1 "drumroll.au")
- ("blast" 1 "explosion.au")
- ("flush\\|plonk!*" 1 "flush.au")
- ("kiss" 1 "kiss.wav")
- ("tee[ \t]*hee" 1 "laugh.au")
- ("shoot" 1 "shotgun.wav")
- ("yawn" 1 "snore.wav")
- ("cackle" 1 "witch.au")
- ("yell\\|roar" 1 "yell2.au")
- ("whoop-de-doo" 1 "whistle.au"))
- "*A list of regexps to map earcons to real sounds."
- :type '(repeat (list regexp
- (integer :tag "Match")
- (string :tag "Sound")))
- :group 'earcon)
-(defvar earcon-button-marker-list nil)
-(make-variable-buffer-local 'earcon-button-marker-list)
-
-;;; FIXME!! clone of code from gnus-vis.el FIXME!!
-(defun earcon-article-push-button (event)
- "Check text under the mouse pointer for a callback function.
-If the text under the mouse pointer has a `earcon-callback' property,
-call it with the value of the `earcon-data' text property."
- (interactive "e")
- (set-buffer (window-buffer (posn-window (event-start event))))
- (let* ((pos (posn-point (event-start event)))
- (data (get-text-property pos 'earcon-data))
- (fun (get-text-property pos 'earcon-callback)))
- (if fun (funcall fun data))))
-
-(defun earcon-article-press-button ()
- "Check text at point for a callback function.
-If the text at point has a `earcon-callback' property,
-call it with the value of the `earcon-data' text property."
- (interactive)
- (let* ((data (get-text-property (point) 'earcon-data))
- (fun (get-text-property (point) 'earcon-callback)))
- (if fun (funcall fun data))))
-
-(defun earcon-article-prev-button (n)
- "Move point to N buttons backward.
-If N is negative, move forward instead."
- (interactive "p")
- (earcon-article-next-button (- n)))
-
-(defun earcon-article-next-button (n)
- "Move point to N buttons forward.
-If N is negative, move backward instead."
- (interactive "p")
- (let ((function (if (< n 0) 'previous-single-property-change
- 'next-single-property-change))
- (inhibit-point-motion-hooks t)
- (backward (< n 0))
- (limit (if (< n 0) (point-min) (point-max))))
- (setq n (abs n))
- (while (and (not (= limit (point)))
- (> n 0))
- ;; Skip past the current button.
- (when (get-text-property (point) 'earcon-callback)
- (goto-char (funcall function (point) 'earcon-callback nil limit)))
- ;; Go to the next (or previous) button.
- (gnus-goto-char (funcall function (point) 'earcon-callback nil limit))
- ;; Put point at the start of the button.
- (when (and backward (not (get-text-property (point) 'earcon-callback)))
- (goto-char (funcall function (point) 'earcon-callback nil limit)))
- ;; Skip past intangible buttons.
- (when (get-text-property (point) 'intangible)
- (incf n))
- (decf n))
- (unless (zerop n)
- (gnus-message 5 "No more buttons"))
- n))
-
-(defun earcon-article-add-button (from to fun &optional data)
- "Create a button between FROM and TO with callback FUN and data DATA."
- (and (boundp gnus-article-button-face)
- gnus-article-button-face
- (gnus-overlay-put (gnus-make-overlay from to)
- 'face gnus-article-button-face))
- (gnus-add-text-properties
- from to
- (nconc (and gnus-article-mouse-face
- (list gnus-mouse-face-prop gnus-article-mouse-face))
- (list 'gnus-callback fun)
- (and data (list 'gnus-data data)))))
-
-(defun earcon-button-entry ()
- ;; Return the first entry in `gnus-button-alist' matching this place.
- (let ((alist earcon-regexp-alist)
- (case-fold-search t)
- (entry nil))
- (while alist
- (setq entry (pop alist))
- (if (looking-at (car entry))
- (setq alist nil)
- (setq entry nil)))
- entry))
-
-(defun earcon-button-push (marker)
- ;; Push button starting at MARKER.
- (save-excursion
- (set-buffer gnus-article-buffer)
- (goto-char marker)
- (let* ((entry (earcon-button-entry))
- (inhibit-point-motion-hooks t)
- (fun 'gnus-audio-play)
- (args (list (nth 2 entry))))
- (cond
- ((fboundp fun)
- (apply fun args))
- ((and (boundp fun)
- (fboundp (symbol-value fun)))
- (apply (symbol-value fun) args))
- (t
- (gnus-message 1 "You must define `%S' to use this button"
- (cons fun args)))))))
-
-;;; FIXME!! clone of code from gnus-vis.el FIXME!!
-
-;;;###interactive
-(defun earcon-region (beg end)
- "Play Sounds in the region between point and mark."
- (interactive "r")
- (earcon-buffer (current-buffer) beg end))
-
-;;;###interactive
-(defun earcon-buffer (&optional buffer st nd)
- (interactive)
- (save-excursion
- ;; clear old markers.
- (if (boundp 'earcon-button-marker-list)
- (while earcon-button-marker-list
- (set-marker (pop earcon-button-marker-list) nil))
- (setq earcon-button-marker-list nil))
- (and buffer (set-buffer buffer))
- (let ((buffer-read-only nil)
- (inhibit-point-motion-hooks t)
- (case-fold-search t)
- (alist earcon-regexp-alist)
- beg entry regexp)
- (goto-char (point-min))
- (setq beg (point))
- (while (setq entry (pop alist))
- (setq regexp (concat (regexp-quote earcon-prefix)
- ".*\\("
- (car entry)
- "\\).*"
- (regexp-quote earcon-suffix)))
- (goto-char beg)
- (while (re-search-forward regexp nil t)
- (let* ((start (and entry (match-beginning 1)))
- (end (and entry (match-end 1)))
- (from (match-beginning 1)))
- (earcon-article-add-button
- start end 'earcon-button-push
- (car (push (set-marker (make-marker) from)
- earcon-button-marker-list)))
- (gnus-audio-play (caddr entry))))))))
-
-;;;###autoload
-(defun gnus-earcon-display ()
- "Play sounds in message buffers."
- (interactive)
- (save-excursion
- (set-buffer gnus-article-buffer)
- (goto-char (point-min))
- ;; Skip headers
- (unless (search-forward "\n\n" nil t)
- (goto-char (point-max)))
- (sit-for 0)
- (earcon-buffer (current-buffer) (point))))
-
-;;;***
-
-(provide 'earcon)
-
-(run-hooks 'earcon-load-hook)
-
-;; arch-tag: 844dfeea-980c-4ed0-907f-a30bf139691c
-;;; earcon.el ends here
diff --git a/lisp/gnus/ecomplete.el b/lisp/gnus/ecomplete.el
index 7aca7492a6d..1f705674962 100644
--- a/lisp/gnus/ecomplete.el
+++ b/lisp/gnus/ecomplete.el
@@ -1,6 +1,7 @@
;;; ecomplete.el --- electric completion of addresses and the like
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: mail
@@ -27,11 +28,6 @@
(eval-when-compile
(require 'cl))
-(eval-when-compile
- (unless (fboundp 'with-no-warnings)
- (defmacro with-no-warnings (&rest body)
- `(progn ,@body))))
-
(defgroup ecomplete nil
"Electric completion of email addresses and the like."
:group 'mail)
@@ -61,11 +57,10 @@
(defun ecomplete-add-item (type key text)
(let ((elems (assq type ecomplete-database))
(now (string-to-number
- (format "%.0f" (if (and (fboundp 'float-time)
- (subrp (symbol-function 'float-time)))
+ (format "%.0f" (if (featurep 'emacs)
(float-time)
- (with-no-warnings
- (time-to-seconds (current-time)))))))
+ (require 'gnus-util)
+ (gnus-float-time)))))
entry)
(unless elems
(push (setq elems (list type)) ecomplete-database))
@@ -95,7 +90,7 @@
(let* ((elems (cdr (assq type ecomplete-database)))
(match (regexp-quote match))
(candidates
- (sort
+ (sort
(loop for (key count time text) in elems
when (string-match match text)
collect (list count time text))
@@ -156,5 +151,4 @@
(provide 'ecomplete)
-;; arch-tag: 34622935-bb81-4711-a600-57b89c2ece72
;;; ecomplete.el ends here
diff --git a/lisp/gnus/flow-fill.el b/lisp/gnus/flow-fill.el
index 69066de2c4e..2420577ea45 100644
--- a/lisp/gnus/flow-fill.el
+++ b/lisp/gnus/flow-fill.el
@@ -97,8 +97,7 @@ RFC 2646 suggests 66 characters for readability."
;;;###autoload
(defun fill-flowed (&optional buffer delete-space)
- (save-excursion
- (set-buffer (or (current-buffer) buffer))
+ (with-current-buffer (or (current-buffer) buffer)
(goto-char (point-min))
;; Remove space stuffing.
(while (re-search-forward "^\\( \\|>+ $\\)" nil t)
@@ -221,5 +220,4 @@ RFC 2646 suggests 66 characters for readability."
(provide 'flow-fill)
-;; arch-tag: addc0040-bc53-4f17-b4bc-1eb44eed6f0b
;;; flow-fill.el ends here
diff --git a/lisp/gnus/gmm-utils.el b/lisp/gnus/gmm-utils.el
index b44d3c08c4a..e16fc5efa63 100644
--- a/lisp/gnus/gmm-utils.el
+++ b/lisp/gnus/gmm-utils.el
@@ -1,6 +1,7 @@
;;; gmm-utils.el --- Utility functions for Gnus, Message and MML
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Reiner Steib <reiner.steib@gmx.de>
;; Keywords: news
@@ -28,8 +29,6 @@
;;; Code:
-(require 'wid-edit)
-
(defgroup gmm nil
"Utility functions for Gnus, Message and MML."
:prefix "gmm-"
@@ -95,6 +94,10 @@ ARGS are passed to `message'."
"Non-nil if SYMBOL is a widget."
(get symbol 'widget-type))
+(autoload 'widget-create-child-value "wid-edit")
+(autoload 'widget-convert "wid-edit")
+(autoload 'widget-default-get "wid-edit")
+
;; Copy of the `nnmail-lazy' code from `nnmail.el':
(define-widget 'gmm-lazy 'default
"Base widget for recursive datastructures.
@@ -265,27 +268,16 @@ DEFAULT-MAP specifies the default key map for ICON-LIST."
;; (tool-bar-add-item ICON DEF KEY &rest PROPS)
(apply 'tool-bar-add-item icon nil nil :enable nil props)))
((equal fmap t) ;; Not a menu command
- (if (fboundp 'tool-bar-local-item)
- (apply 'tool-bar-local-item
- icon command
- (intern icon) ;; reuse icon or fmap here?
- tool-bar-map props)
- ;; Emacs 21 compatibility:
- (apply 'tool-bar-add-item
- icon command
- (intern icon)
- props)))
+ (apply 'tool-bar-local-item
+ icon command
+ (intern icon) ;; reuse icon or fmap here?
+ tool-bar-map props))
(t ;; A menu command
- (if (fboundp 'tool-bar-local-item-from-menu)
- (apply 'tool-bar-local-item-from-menu
- ;; (apply 'tool-bar-local-item icon def key
- ;; tool-bar-map props)
- command icon tool-bar-map (symbol-value fmap)
- props)
- ;; Emacs 21 compatibility:
- (apply 'tool-bar-add-item-from-menu
- command icon (symbol-value fmap)
- props))))
+ (apply 'tool-bar-local-item-from-menu
+ ;; (apply 'tool-bar-local-item icon def key
+ ;; tool-bar-map props)
+ command icon tool-bar-map (symbol-value fmap)
+ props)))
t))
(if (symbolp icon-list)
(eval icon-list)
@@ -420,16 +412,12 @@ If mode is nil, use `major-mode' of the current buffer."
In XEmacs, the seventh argument of `write-region' specifies the
coding-system."
- (if (and mustbenew
- (or (featurep 'xemacs)
- (= emacs-major-version 20)))
+ (if (and mustbenew (featurep 'xemacs))
(if (file-exists-p filename)
- (signal 'file-already-exists
- (list "File exists" filename))
+ (signal 'file-already-exists (list "File exists" filename))
(write-region start end filename append visit lockname))
(write-region start end filename append visit lockname mustbenew)))
(provide 'gmm-utils)
-;; arch-tag: e0b60920-2ce6-40c1-bfc0-cadbbe26b602
;;; gmm-utils.el ends here
diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el
index f385c71069b..8edfecde152 100644
--- a/lisp/gnus/gnus-agent.el
+++ b/lisp/gnus/gnus-agent.el
@@ -184,7 +184,7 @@ When found, offer to remove them."
:type 'boolean
:group 'gnus-agent)
-(defcustom gnus-agent-auto-agentize-methods '(nntp nnimap)
+(defcustom gnus-agent-auto-agentize-methods nil
"Initially, all servers from these methods are agentized.
The user may remove or add servers using the Server buffer.
See Info node `(gnus)Server Buffer'."
@@ -305,8 +305,7 @@ buffer. Automatically blocks multiple updates due to recursion."
`(prog1 (let ((gnus-agent-inhibit-update-total-fetched-for t)) ,@body)
(when (and gnus-agent-need-update-total-fetched-for
(not gnus-agent-inhibit-update-total-fetched-for))
- (save-excursion
- (set-buffer gnus-group-buffer)
+ (with-current-buffer gnus-group-buffer
(setq gnus-agent-need-update-total-fetched-for nil)
(gnus-group-update-group ,group t)))))
@@ -460,10 +459,7 @@ manipulated as follows:
(let ((def (or (gnus-group-group-name) gnus-newsgroup-name)))
(when def
(setq def (gnus-group-decoded-name def)))
- (gnus-group-completing-read (if def
- (concat "Group Name (" def "): ")
- "Group Name: ")
- nil nil t nil nil def)))
+ (gnus-group-completing-read nil nil t nil nil def)))
;;; Fetching setup functions.
@@ -474,8 +470,7 @@ manipulated as follows:
(defun gnus-agent-stop-fetch ()
"Save all data structures and clean up."
(setq gnus-agent-spam-hashtb nil)
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(widen)))
(defmacro gnus-agent-with-fetch (&rest forms)
@@ -518,8 +513,8 @@ manipulated as follows:
;; Set up the menu.
(when (gnus-visual-p 'agent-menu 'menu)
(funcall (intern (format "gnus-agent-%s-make-menu-bar" buffer))))
- (unless (assq 'gnus-agent-mode minor-mode-alist)
- (push gnus-agent-mode-status minor-mode-alist))
+ (unless (assq mode minor-mode-alist)
+ (push (cons mode (cdr gnus-agent-mode-status)) minor-mode-alist))
(unless (assq mode minor-mode-map-alist)
(push (cons mode (symbol-value (intern (format "gnus-agent-%s-mode-map"
buffer))))
@@ -608,16 +603,13 @@ manipulated as follows:
(propertize string 'local-map
(make-mode-line-mouse-map mouse-button mouse-func)
'mouse-face
- (cond ((and (featurep 'xemacs)
- ;; XEmacs' `facep' only checks for a face
- ;; object, not for a face name, so it's useless
- ;; to check with `facep'.
- (find-face 'modeline))
- 'modeline)
- ((facep 'mode-line-highlight) ;; Emacs 22
- 'mode-line-highlight)
- ((facep 'mode-line) ;; Emacs 21
- 'mode-line)) )
+ (if (and (featurep 'xemacs)
+ ;; XEmacs' `facep' only checks for a face
+ ;; object, not for a face name, so it's useless
+ ;; to check with `facep'.
+ (find-face 'modeline))
+ 'modeline
+ 'mode-line-highlight))
string))
(defun gnus-agent-toggle-plugged (set-to)
@@ -703,7 +695,9 @@ minor mode in all Gnus buffers."
;; If the servers file doesn't exist, auto-agentize some servers and
;; save the servers file so this auto-agentizing isn't invoked
;; again.
- (unless (file-exists-p (nnheader-concat gnus-agent-directory "lib/servers"))
+ (when (and (not (file-exists-p (nnheader-concat
+ gnus-agent-directory "lib/servers")))
+ gnus-agent-auto-agentize-methods)
(gnus-message 3 "First time agent user, agentizing remote groups...")
(mapc
(lambda (server-or-method)
@@ -809,23 +803,24 @@ be a select method."
(setq group (or group gnus-newsgroup-name))
(unless group
(error "No group on the current line"))
-
- (gnus-agent-while-plugged
- (let ((gnus-command-method (gnus-find-method-for-group group)))
- (gnus-agent-with-fetch
- (gnus-agent-fetch-group-1 group gnus-command-method)
- (gnus-message 5 "Fetching %s...done" group)))))
+ (if (not (gnus-agent-group-covered-p group))
+ (message "%s isn't covered by the agent" group)
+ (gnus-agent-while-plugged
+ (let ((gnus-command-method (gnus-find-method-for-group group)))
+ (gnus-agent-with-fetch
+ (gnus-agent-fetch-group-1 group gnus-command-method)
+ (gnus-message 5 "Fetching %s...done" group))))))
(defun gnus-agent-add-group (category arg)
"Add the current group to an agent category."
(interactive
(list
(intern
- (completing-read
- "Add to category: "
- (mapcar (lambda (cat) (list (symbol-name (car cat))))
+ (gnus-completing-read
+ "Add to category"
+ (mapcar (lambda (cat) (symbol-name (car cat)))
gnus-category-alist)
- nil t))
+ t))
current-prefix-arg))
(let ((cat (assq category gnus-category-alist))
c groups)
@@ -1031,7 +1026,7 @@ supported."
(unless (member server gnus-agent-covered-methods)
(push server gnus-agent-covered-methods)
(setq gnus-agent-method-p-cache nil))
- (gnus-message 1 "Ignoring disappeared server `%s'" server))))
+ (gnus-message 8 "Ignoring disappeared server `%s'" server))))
(prog1 gnus-agent-covered-methods
(setq gnus-agent-covered-methods nil))))
@@ -1583,7 +1578,8 @@ downloaded into the agent."
(setq selected-sets (nreverse selected-sets))
(gnus-make-directory dir)
- (gnus-message 7 "Fetching articles for %s..." group)
+ (gnus-message 7 "Fetching articles for %s..."
+ (gnus-agent-decoded-group-name group))
(unwind-protect
(while (setq articles (pop selected-sets))
@@ -1594,7 +1590,8 @@ downloaded into the agent."
(let (article)
(while (setq article (pop articles))
(gnus-message 10 "Fetching article %s for %s..."
- article group)
+ article
+ (gnus-agent-decoded-group-name group))
(when (or
(gnus-backlog-request-article group article
nntp-server-buffer)
@@ -1606,8 +1603,7 @@ downloaded into the agent."
nntp-server-buffer (point-min) (point-max))
(setq pos (nreverse pos)))))
;; Then save these articles into the Agent.
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(while pos
(narrow-to-region (cdar pos) (or (cdadr pos) (point-max)))
(goto-char (point-min))
@@ -1691,8 +1687,7 @@ downloaded into the agent."
(setq date (or date t))
(let (gnus-agent-article-alist group alist beg end)
- (save-excursion
- (set-buffer gnus-agent-overview-buffer)
+ (with-current-buffer gnus-agent-overview-buffer
(when (nnheader-find-nov-line article)
(forward-word 1)
(setq beg (point))
@@ -1703,9 +1698,8 @@ downloaded into the agent."
(push (setq alist (list group (gnus-agent-load-alist (caar crosses))))
gnus-agent-group-alist))
(setcdr alist (cons (cons (cdar crosses) date) (cdr alist)))
- (save-excursion
- (set-buffer (gnus-get-buffer-create (format " *Gnus agent overview %s*"
- group)))
+ (with-current-buffer (gnus-get-buffer-create
+ (format " *Gnus agent overview %s*"group))
(when (= (point-max) (point-min))
(push (cons group (current-buffer)) gnus-agent-buffer-alist)
(ignore-errors
@@ -1786,7 +1780,7 @@ and that there are no duplicates."
(while alist
(let ((entry (pop alist)))
(when (gnus-methods-equal-p gnus-command-method (gnus-info-method entry))
- (gnus-agent-flush-group (gnus-info-group entry)))))))
+ (gnus-agent-flush-group (gnus-info-group entry)))))))
(defun gnus-agent-flush-group (group)
"Flush the agent's index files such that the GROUP no longer
@@ -1937,12 +1931,11 @@ article numbers will be returned."
10 "gnus-agent-fetch-headers: undownloaded articles are '%s'"
(gnus-compress-sequence articles t))
- (save-excursion
- (set-buffer nntp-server-buffer)
-
+ (with-current-buffer nntp-server-buffer
(if articles
(progn
- (gnus-message 7 "Fetching headers for %s..." group)
+ (gnus-message 7 "Fetching headers for %s..."
+ (gnus-agent-decoded-group-name group))
;; Fetch them.
(gnus-make-directory (nnheader-translate-file-chars
@@ -2105,13 +2098,15 @@ doesn't exist, to valid the overview buffer."
(defun gnus-agent-load-alist (group)
"Load the article-state alist for GROUP."
;; Bind free variable that's used in `gnus-agent-read-agentview'.
- (let ((gnus-agent-read-agentview group)
- (file-name-coding-system nnmail-pathname-coding-system))
+ (let* ((gnus-agent-read-agentview group)
+ (file-name-coding-system nnmail-pathname-coding-system)
+ (agentview (gnus-agent-article-name ".agentview" group)))
(setq gnus-agent-article-alist
- (gnus-cache-file-contents
- (gnus-agent-article-name ".agentview" group)
- 'gnus-agent-file-loading-cache
- 'gnus-agent-read-agentview))))
+ (and (file-exists-p agentview)
+ (gnus-cache-file-contents
+ agentview
+ 'gnus-agent-file-loading-cache
+ 'gnus-agent-read-agentview)))))
(defun gnus-agent-read-agentview (file)
"Load FILE and do a `read' there."
@@ -2159,13 +2154,13 @@ doesn't exist, to valid the overview buffer."
(gnus-agent-save-alist gnus-agent-read-agentview)))
alist))
((end-of-file file-error)
- ;; The agentview file is missing.
+ ;; The agentview file is missing.
(condition-case nil
;; If the agent directory exists, attempt to perform a brute-force
;; reconstruction of its contents.
(let* (alist
(file-name-coding-system nnmail-pathname-coding-system)
- (file-attributes (directory-files-and-attributes
+ (file-attributes (directory-files-and-attributes
(gnus-agent-article-name ""
gnus-agent-read-agentview) nil "^[0-9]+$" t)))
(while file-attributes
@@ -2227,23 +2222,28 @@ doesn't exist, to valid the overview buffer."
(gnus-agent-update-view-total-fetched-for group nil)))
(defvar gnus-agent-article-local nil)
+(defvar gnus-agent-article-local-times nil)
(defvar gnus-agent-file-loading-local nil)
(defun gnus-agent-load-local (&optional method)
"Load the METHOD'S local file. The local file contains min/max
article counts for each of the method's subscribed groups."
(let ((gnus-command-method (or method gnus-command-method)))
- (setq gnus-agent-article-local
- (gnus-cache-file-contents
- (gnus-agent-lib-file "local")
- 'gnus-agent-file-loading-local
- 'gnus-agent-read-and-cache-local))))
+ (when (or (null gnus-agent-article-local-times)
+ (zerop gnus-agent-article-local-times))
+ (setq gnus-agent-article-local
+ (gnus-cache-file-contents
+ (gnus-agent-lib-file "local")
+ 'gnus-agent-file-loading-local
+ 'gnus-agent-read-and-cache-local))
+ (when gnus-agent-article-local-times
+ (incf gnus-agent-article-local-times)))
+ gnus-agent-article-local))
(defun gnus-agent-read-and-cache-local (file)
"Load and read FILE then bind its contents to
gnus-agent-article-local. If that variable had `dirty' (also known as
modified) original contents, they are first saved to their own file."
-
(if (and gnus-agent-article-local
(symbol-value (intern "+dirty" gnus-agent-article-local)))
(gnus-agent-save-local))
@@ -2350,7 +2350,6 @@ modified) original contents, they are first saved to their own file."
(local (or local (gnus-agent-load-local)))
(symb (intern gmane local))
(minmax (and (boundp symb) (symbol-value symb))))
-
(if (cond ((and minmax
(or (not (eq min (car minmax)))
(not (eq max (cdr minmax))))
@@ -2375,7 +2374,7 @@ modified) original contents, they are first saved to their own file."
(defun gnus-agent-batch-confirmation (msg)
"Show error message and return t."
- (gnus-message 1 msg)
+ (gnus-message 1 "%s" msg)
t)
;;;###autoload
@@ -2641,10 +2640,10 @@ General format specifiers can also be used. See Info node
(defvar gnus-agent-predicate 'false
"The selection predicate used when no other source is available.")
-(defvar gnus-agent-short-article 100
+(defvar gnus-agent-short-article 500
"Articles that have fewer lines than this are short.")
-(defvar gnus-agent-long-article 200
+(defvar gnus-agent-long-article 1000
"Articles that have more lines than this are long.")
(defvar gnus-agent-low-score 0
@@ -2757,8 +2756,7 @@ The following commands are available:
(defun gnus-category-setup-buffer ()
(unless (get-buffer gnus-category-buffer)
- (save-excursion
- (set-buffer (gnus-get-buffer-create gnus-category-buffer))
+ (with-current-buffer (gnus-get-buffer-create gnus-category-buffer)
(gnus-category-mode))))
(defun gnus-category-prepare ()
@@ -3122,7 +3120,7 @@ FORCE is equivalent to setting the expiration predicates to true."
group overview (gnus-gethash-safe group orig)
articles force))))
(kill-buffer overview))))
- (gnus-message 4 (gnus-agent-expire-done-message)))))
+ (gnus-message 4 "%s" (gnus-agent-expire-done-message)))))
(defun gnus-agent-expire-group-1 (group overview active articles force)
;; Internal function - requires caller to have set
@@ -3255,7 +3253,7 @@ FORCE is equivalent to setting the expiration predicates to true."
(gnus-message 7 "gnus-agent-expire: Loading overview...")
(nnheader-insert-file-contents nov-file)
(goto-char (point-min))
-
+
(let (p)
(while (< (setq p (point)) (point-max))
(condition-case nil
@@ -3547,7 +3545,7 @@ articles in every agentized group? "))
expiring-group overview active articles force))))))))
(kill-buffer overview))
(gnus-agent-expire-unagentized-dirs)
- (gnus-message 4 (gnus-agent-expire-done-message))))))
+ (gnus-message 4 "%s" (gnus-agent-expire-done-message))))))
(defun gnus-agent-expire-done-message ()
(if (and (> gnus-verbose 4)
@@ -3631,7 +3629,8 @@ articles in every agentized group? "))
deleting them?")))
(while to-remove
(let ((dir (pop to-remove)))
- (if (gnus-y-or-n-p (format "Delete %s? " dir))
+ (if (or gnus-expert-user
+ (gnus-y-or-n-p (format "Delete %s? " dir)))
(let* (delete-recursive
files f
(delete-recursive
@@ -3753,7 +3752,7 @@ has been fetched."
(erase-buffer)
(cond ((not (eq 'nov (let (gnus-agent) ; Turn off agent
(gnus-retrieve-headers
- uncached-articles group fetch-old))))
+ uncached-articles group))))
(nnvirtual-convert-headers))
((eq 'nntp (car gnus-current-select-method))
;; The author of gnus-get-newsgroup-headers-xover
@@ -3904,7 +3903,7 @@ If REREAD is not nil, downloaded articles are marked as unread."
(sit-for 1)
t)))))
(when group
- (gnus-message 5 "Regenerating in %s" group)
+ (gnus-message 5 "Regenerating in %s" (gnus-agent-decoded-group-name group))
(let* ((gnus-command-method (or gnus-command-method
(gnus-find-method-for-group group)))
(file (gnus-agent-article-name ".overview" group))
@@ -3981,7 +3980,8 @@ If REREAD is not nil, downloaded articles are marked as unread."
(or (not nov-arts)
(> (car downloaded) (car nov-arts))))
;; This entry is missing from the overview file
- (gnus-message 3 "Regenerating NOV %s %d..." group
+ (gnus-message 3 "Regenerating NOV %s %d..."
+ (gnus-agent-decoded-group-name group)
(car downloaded))
(let ((file (concat dir (number-to-string (car downloaded)))))
(mm-with-unibyte-buffer
@@ -4222,5 +4222,4 @@ modified."
(provide 'gnus-agent)
-;; arch-tag: b0ba4afc-5229-4cee-ad25-9956daa4e91e
;;; gnus-agent.el ends here
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el
index 1a66404f841..8d8aaa0e36e 100644
--- a/lisp/gnus/gnus-art.el
+++ b/lisp/gnus/gnus-art.el
@@ -25,7 +25,7 @@
;;; Code:
-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
(eval-when-compile
@@ -34,10 +34,7 @@
(defvar w3m-minor-mode-map)
(require 'gnus)
-;; Avoid the "Recursive load suspected" error in Emacs 21.1.
-(eval-and-compile
- (let ((recursive-load-depth-limit 100))
- (require 'gnus-sum)))
+(require 'gnus-sum)
(require 'gnus-spec)
(require 'gnus-int)
(require 'gnus-win)
@@ -728,7 +725,7 @@ Each element is a regular expression."
:group 'gnus-article-various)
(make-obsolete-variable 'gnus-article-hide-pgp-hook nil
- "Gnus 5.10 (Emacs-22.1)")
+ "Gnus 5.10 (Emacs 22.1)")
(defface gnus-button
'((t (:weight bold)))
@@ -919,25 +916,25 @@ image type in XEmacs if it is built with the libcompface library."
"Function used to decode addresses.")
(defvar gnus-article-dumbquotes-map
- '(("\200" "EUR")
- ("\202" ",")
- ("\203" "f")
- ("\204" ",,")
- ("\205" "...")
- ("\213" "<")
- ("\214" "OE")
- ("\221" "`")
- ("\222" "'")
- ("\223" "``")
- ("\224" "\"")
- ("\225" "*")
- ("\226" "-")
- ("\227" "--")
- ("\230" "~")
- ("\231" "(TM)")
- ("\233" ">")
- ("\234" "oe")
- ("\264" "'"))
+ '((?\200 "EUR")
+ (?\202 ",")
+ (?\203 "f")
+ (?\204 ",,")
+ (?\205 "...")
+ (?\213 "<")
+ (?\214 "OE")
+ (?\221 "`")
+ (?\222 "'")
+ (?\223 "``")
+ (?\224 "\"")
+ (?\225 "*")
+ (?\226 "-")
+ (?\227 "--")
+ (?\230 "~")
+ (?\231 "(TM)")
+ (?\233 ">")
+ (?\234 "oe")
+ (?\264 "'"))
"Table for MS-to-Latin1 translation.")
(defcustom gnus-ignored-mime-types nil
@@ -1415,7 +1412,7 @@ predicate. See Info node `(gnus)Customizing Articles'."
:type gnus-article-treat-custom)
(make-obsolete-variable 'gnus-treat-display-xface
- 'gnus-treat-display-x-face "22.1")
+ 'gnus-treat-display-x-face "Emacs 22.1")
(defcustom gnus-treat-display-x-face
(and (not noninteractive)
@@ -1532,10 +1529,38 @@ node `(gnus)Picons' for details."
:type gnus-article-treat-head-custom)
(put 'gnus-treat-newsgroups-picon 'highlight t)
+(defcustom gnus-treat-from-gravatar nil
+ "Display gravatars in the From header.
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles' and Info
+node `(gnus)Gravatars' for details."
+ :version "24.1"
+ :group 'gnus-article-treat
+ :group 'gnus-gravatar
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :link '(custom-manual "(gnus)Gravatars")
+ :type gnus-article-treat-head-custom)
+(put 'gnus-treat-from-gravatar 'highlight t)
+
+(defcustom gnus-treat-mail-gravatar nil
+ "Display gravatars in To and Cc headers.
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles' and Info
+node `(gnus)Gravatars' for details."
+ :version "24.1"
+ :group 'gnus-article-treat
+ :group 'gnus-gravatar
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :link '(custom-manual "(gnus)Gravatars")
+ :type gnus-article-treat-head-custom)
+(put 'gnus-treat-mail-gravatar 'highlight t)
+
(defcustom gnus-treat-body-boundary
(if (or gnus-treat-newsgroups-picon
gnus-treat-mail-picon
- gnus-treat-from-picon)
+ gnus-treat-from-picon
+ gnus-treat-from-gravatar
+ gnus-treat-mail-gravatar)
;; If there's much decoration, the user might prefer a boundery.
'head
nil)
@@ -1565,7 +1590,7 @@ predicate. See Info node `(gnus)Customizing Articles'."
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
-(defcustom gnus-treat-fill-long-lines nil
+(defcustom gnus-treat-fill-long-lines '(typep "text/plain")
"Fill long lines.
Valid values are nil, t, `head', `first', `last', an integer or a
predicate. See Info node `(gnus)Customizing Articles'."
@@ -1573,24 +1598,6 @@ predicate. See Info node `(gnus)Customizing Articles'."
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
-(defcustom gnus-treat-play-sounds nil
- "Play sounds.
-Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles'."
- :version "21.1"
- :group 'gnus-article-treat
- :link '(custom-manual "(gnus)Customizing Articles")
- :type gnus-article-treat-custom)
-
-(defcustom gnus-treat-translate nil
- "Translate articles from one language to another.
-Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles'."
- :version "21.1"
- :group 'gnus-article-treat
- :link '(custom-manual "(gnus)Customizing Articles")
- :type gnus-article-treat-custom)
-
(defcustom gnus-treat-x-pgp-sig nil
"Verify X-PGP-Sig.
To automatically treat X-PGP-Sig, set it to head.
@@ -1614,9 +1621,6 @@ It is a string, such as \"PGP\". If nil, ask user."
:type 'string
:group 'mime-security)
-(defvar gnus-article-wash-function nil
- "Function used for converting HTML into text.")
-
(defcustom gnus-use-idna (and (condition-case nil (require 'idna) (file-error))
(mm-coding-system-p 'utf-8)
(executable-find idna-program))
@@ -1632,6 +1636,21 @@ This requires GNU Libidn, and by default only enabled if it is found."
:group 'gnus-article
:type 'boolean)
+(defcustom gnus-inhibit-images nil
+ "Non-nil means inhibit displaying of images inline in the article body."
+ :version "24.1"
+ :group 'gnus-article
+ :type 'boolean)
+
+(defcustom gnus-blocked-images 'gnus-block-private-groups
+ "Images that have URLs matching this regexp will be blocked.
+This can also be a function to be evaluated. If so, it will be
+called with the group name as the parameter, and should return a
+regexp."
+ :version "24.1"
+ :group 'gnus-art
+ :type 'regexp)
+
;;; Internal variables
(defvar gnus-english-month-names
@@ -1651,7 +1670,7 @@ This requires GNU Libidn, and by default only enabled if it is found."
(gnus-treat-highlight-signature gnus-article-highlight-signature)
(gnus-treat-buttonize gnus-article-add-buttons)
(gnus-treat-fill-article gnus-article-fill-cited-article)
- (gnus-treat-fill-long-lines gnus-article-fill-long-lines)
+ (gnus-treat-fill-long-lines gnus-article-fill-cited-long-lines)
(gnus-treat-strip-cr gnus-article-remove-cr)
(gnus-treat-unsplit-urls gnus-article-unsplit-urls)
(gnus-treat-date-ut gnus-article-date-ut)
@@ -1668,10 +1687,12 @@ This requires GNU Libidn, and by default only enabled if it is found."
(gnus-treat-hide-signature gnus-article-hide-signature)
(gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers)
(gnus-treat-leading-whitespace gnus-article-remove-leading-whitespace)
- (gnus-treat-strip-pem gnus-article-hide-pem)
(gnus-treat-from-picon gnus-treat-from-picon)
(gnus-treat-mail-picon gnus-treat-mail-picon)
(gnus-treat-newsgroups-picon gnus-treat-newsgroups-picon)
+ (gnus-treat-strip-pem gnus-article-hide-pem)
+ (gnus-treat-from-gravatar gnus-treat-from-gravatar)
+ (gnus-treat-mail-gravatar gnus-treat-mail-gravatar)
(gnus-treat-highlight-headers gnus-article-highlight-headers)
(gnus-treat-highlight-signature gnus-article-highlight-signature)
(gnus-treat-strip-trailing-blank-lines
@@ -1693,8 +1714,7 @@ This requires GNU Libidn, and by default only enabled if it is found."
(gnus-treat-hide-citation gnus-article-hide-citation)
(gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe)
(gnus-treat-highlight-citation gnus-article-highlight-citation)
- (gnus-treat-body-boundary gnus-article-treat-body-boundary)
- (gnus-treat-play-sounds gnus-earcon-display)))
+ (gnus-treat-body-boundary gnus-article-treat-body-boundary)))
(defvar gnus-article-mime-handle-alist nil)
(defvar article-lapsed-timer nil)
@@ -2100,6 +2120,35 @@ try this wash."
(interactive)
(article-translate-strings gnus-article-dumbquotes-map))
+(defvar org-entities)
+
+(defun article-treat-non-ascii ()
+ "Translate many Unicode characters into their ASCII equivalents."
+ (interactive)
+ (require 'org-entities)
+ (let ((table (make-char-table (if (featurep 'xemacs) 'generic))))
+ (dolist (elem org-entities)
+ (when (and (listp elem)
+ (= (length (nth 6 elem)) 1))
+ (if (featurep 'xemacs)
+ (put-char-table (aref (nth 6 elem) 0) (nth 4 elem) table)
+ (set-char-table-range table (aref (nth 6 elem) 0) (nth 4 elem)))))
+ (save-excursion
+ (when (article-goto-body)
+ (let ((inhibit-read-only t)
+ replace props)
+ (while (not (eobp))
+ (if (not (setq replace (if (featurep 'xemacs)
+ (get-char-table (following-char) table)
+ (aref table (following-char)))))
+ (forward-char 1)
+ (if (prog1
+ (setq props (text-properties-at (point)))
+ (delete-char 1))
+ (add-text-properties (point) (progn (insert replace) (point))
+ props)
+ (insert replace)))))))))
+
(defun article-translate-characters (from to)
"Translate all characters in the body of the article according to FROM and TO.
FROM is a string of characters to translate from; to is a string of
@@ -2124,9 +2173,18 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")."
(when (article-goto-body)
(let ((inhibit-read-only t))
(dolist (elem map)
- (save-excursion
- (while (search-forward (car elem) nil t)
- (replace-match (cadr elem)))))))))
+ (let ((from (car elem))
+ (to (cadr elem)))
+ (save-excursion
+ (if (stringp from)
+ (while (search-forward from nil t)
+ (replace-match to))
+ (while (not (eobp))
+ (if (eq (following-char) from)
+ (progn
+ (delete-char 1)
+ (insert to))
+ (forward-char 1)))))))))))
(defun article-treat-overstrike ()
"Translate overstrikes into bold text."
@@ -2219,6 +2277,17 @@ unfolded."
(dolist (elem gnus-article-image-alist)
(gnus-delete-images (car elem)))))
+(defun gnus-article-show-images ()
+ "Show any images that are in the HTML-rendered article buffer.
+This only works if the article in question is HTML."
+ (interactive)
+ (gnus-with-article-buffer
+ (dolist (region (gnus-find-text-property-region (point-min) (point-max)
+ 'image-displayer))
+ (destructuring-bind (start end function) region
+ (funcall function (get-text-property start 'image-url)
+ start end)))))
+
(defun gnus-article-treat-fold-newsgroups ()
"Unfold folded message headers.
Only the headers that fit into the current window width will be
@@ -2277,9 +2346,9 @@ long lines if and only if arg is positive."
(insert "X-Boundary: ")
(gnus-add-text-properties start (point) '(invisible t intangible t))
(insert (let (str)
- (while (>= (1- (window-width)) (length str))
+ (while (>= (window-width) (length str))
(setq str (concat str gnus-body-boundary-delimiter)))
- (substring str 0 (1- (window-width))))
+ (substring str 0 (window-width)))
"\n")
(gnus-put-text-property start (point) 'gnus-decoration 'header)))))
@@ -2671,118 +2740,16 @@ If READ-CHARSET, ask for a coding system."
(when (interactive-p)
(gnus-treat-article nil))))
-
-(defun article-wash-html (&optional read-charset)
- "Format an HTML article.
-If READ-CHARSET, ask for a coding system. If it is a number, the
-charset defined in `gnus-summary-show-article-charset-alist' is used."
- (interactive "P")
- (save-excursion
- (let ((inhibit-read-only t)
- charset)
- (if read-charset
- (if (or (and (numberp read-charset)
- (setq charset
- (cdr
- (assq read-charset
- gnus-summary-show-article-charset-alist))))
- (setq charset (mm-read-coding-system "Charset: ")))
- (let ((gnus-summary-show-article-charset-alist
- (list (cons 1 charset))))
- (with-current-buffer gnus-summary-buffer
- (gnus-summary-show-article 1)))
- (error "No charset is given"))
- (when (gnus-buffer-live-p gnus-original-article-buffer)
- (with-current-buffer gnus-original-article-buffer
- (let* ((ct (gnus-fetch-field "content-type"))
- (ctl (and ct (mail-header-parse-content-type ct))))
- (setq charset (and ctl
- (mail-content-type-get ctl 'charset)))
- (when (stringp charset)
- (setq charset (intern (downcase charset)))))))
- (unless charset
- (setq charset gnus-newsgroup-charset)))
- (article-goto-body)
- (save-window-excursion
- (save-restriction
- (narrow-to-region (point) (point-max))
- (let* ((func (or gnus-article-wash-function mm-text-html-renderer))
- (entry (assq func mm-text-html-washer-alist)))
- (when entry
- (setq func (cdr entry)))
- (cond
- ((functionp func)
- (funcall func))
- (t
- (apply (car func) (cdr func))))))))))
-
-;; External.
-(declare-function w3-region "ext:w3-display" (st nd))
-
-(defun gnus-article-wash-html-with-w3 ()
- "Wash the current buffer with w3."
- (mm-setup-w3)
- (let ((w3-strict-width (window-width))
- (url-standalone-mode t)
- (url-gateway-unplugged t)
- (w3-honor-stylesheets nil))
- (condition-case ()
- (w3-region (point-min) (point-max))
- (error))))
-
-;; External.
-(declare-function w3m-region "ext:w3m" (start end &optional url charset))
-
-(defun gnus-article-wash-html-with-w3m ()
- "Wash the current buffer with emacs-w3m."
- (mm-setup-w3m)
- (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp)
- w3m-force-redisplay)
- (w3m-region (point-min) (point-max)))
- ;; Put the mark meaning this part was rendered by emacs-w3m.
- (put-text-property (point-min) (point-max) 'mm-inline-text-html-with-w3m t)
- (when (and mm-inline-text-html-with-w3m-keymap
- (boundp 'w3m-minor-mode-map)
- w3m-minor-mode-map)
- (if (and (boundp 'w3m-link-map)
- w3m-link-map)
- (let* ((start (point-min))
- (end (point-max))
- (on (get-text-property start 'w3m-href-anchor))
- (map (copy-keymap w3m-link-map))
- next)
- (set-keymap-parent map w3m-minor-mode-map)
- (while (< start end)
- (if on
- (progn
- (setq next (or (text-property-any start end
- 'w3m-href-anchor nil)
- end))
- (put-text-property start next 'keymap map))
- (setq next (or (text-property-not-all start end
- 'w3m-href-anchor nil)
- end))
- (put-text-property start next 'keymap w3m-minor-mode-map))
- (setq start next
- on (not on))))
- (put-text-property (point-min) (point-max) 'keymap w3m-minor-mode-map))))
-
-(defvar charset) ;; Bound by `article-wash-html'.
-
-(defun gnus-article-wash-html-with-w3m-standalone ()
- "Wash the current buffer with w3m."
- (if (mm-w3m-standalone-supports-m17n-p)
- (progn
- (unless (mm-coding-system-p charset) ;; Bound by `article-wash-html'.
- ;; The default.
- (setq charset 'iso-8859-1))
- (let ((coding-system-for-write charset)
- (coding-system-for-read charset))
- (call-process-region
- (point-min) (point-max)
- "w3m" t t nil "-dump" "-T" "text/html"
- "-I" (symbol-name charset) "-O" (symbol-name charset))))
- (mm-inline-wash-with-stdin nil "w3m" "-dump" "-T" "text/html")))
+(defun article-wash-html ()
+ "Format an HTML article."
+ (interactive)
+ (let ((handles nil)
+ (buffer-read-only nil))
+ (when (gnus-buffer-live-p gnus-original-article-buffer)
+ (setq handles (mm-dissect-buffer t t)))
+ (article-goto-body)
+ (delete-region (point) (point-max))
+ (mm-inline-text-html handles)))
(defvar gnus-article-browse-html-temp-list nil
"List of temporary files created by `gnus-article-browse-html-parts'.
@@ -2806,31 +2773,66 @@ summary buffer."
(defun gnus-article-browse-delete-temp-files (&optional how)
"Delete temp-files created by `gnus-article-browse-html-parts'."
(when (and gnus-article-browse-html-temp-list
- (or how
- (setq how gnus-article-browse-delete-temp)))
- (when (and (eq how 'ask)
- (gnus-y-or-n-p (format
- "Delete all %s temporary HTML file(s)? "
- (length gnus-article-browse-html-temp-list)))
- (setq how t)))
+ (progn
+ (or how (setq how gnus-article-browse-delete-temp))
+ (if (eq how 'ask)
+ (let ((files (length gnus-article-browse-html-temp-list)))
+ (gnus-y-or-n-p (format
+ "Delete all %s temporary HTML file%s? "
+ files
+ (if (> files 1) "s" ""))))
+ how)))
(dolist (file gnus-article-browse-html-temp-list)
- (when (and (file-exists-p file)
- (or (eq how t)
- ;; `how' is neither `nil', `ask' nor `t' (i.e. `file'):
- (gnus-y-or-n-p
- (format "Delete temporary HTML file `%s'? " file))))
- (delete-file file)))
+ (cond ((file-directory-p file)
+ (when (or (not (eq how 'file))
+ (gnus-y-or-n-p
+ (format
+ "Delete temporary HTML file(s) in directory `%s'? "
+ (file-name-as-directory file))))
+ (gnus-delete-directory file)))
+ ((file-exists-p file)
+ (when (or (not (eq how 'file))
+ (gnus-y-or-n-p
+ (format "Delete temporary HTML file `%s'? " file)))
+ (delete-file file)))))
;; Also remove file from the list when not deleted or if file doesn't
;; exist anymore.
(setq gnus-article-browse-html-temp-list nil))
gnus-article-browse-html-temp-list)
+(defun gnus-article-browse-html-save-cid-content (cid handles directory)
+ "Find CID content in HANDLES and save it in a file in DIRECTORY.
+Return file name."
+ (save-match-data
+ (let (file type)
+ (catch 'found
+ (dolist (handle handles)
+ (cond
+ ((not (listp handle)))
+ ((equal (mm-handle-media-supertype handle) "multipart")
+ (when (setq file (gnus-article-browse-html-save-cid-content
+ cid handle directory))
+ (throw 'found file)))
+ ((equal (concat "<" cid ">") (mm-handle-id handle))
+ (setq file
+ (expand-file-name
+ (or (mail-content-type-get
+ (mm-handle-disposition handle) 'filename)
+ (mail-content-type-get
+ (setq type (mm-handle-type handle)) 'name)
+ (concat
+ (make-temp-name "cid")
+ (car (rassoc (car type) mailcap-mime-extensions))))
+ directory))
+ (mm-save-part-to-file handle file)
+ (throw 'found file))))))))
+
(defun gnus-article-browse-html-parts (list &optional header)
"View all \"text/html\" parts from LIST.
Recurse into multiparts. The optional HEADER that should be a decoded
message header will be added to the bodies of the \"text/html\" parts."
;; Internal function used by `gnus-article-browse-html-article'.
- (let (type file charset tmp-file showed)
+ (let (type file charset content cid-dir tmp-file showed)
;; Find and show the html-parts.
(dolist (handle list)
;; If HTML, show it:
@@ -2853,16 +2855,42 @@ message header will be added to the bodies of the \"text/html\" parts."
(setq handle (mm-handle-cache handle)
type (mm-handle-type handle))
(equal (car type) "text/html"))))
- (when (or (setq charset (mail-content-type-get type 'charset))
- header
- (not file))
+ (setq charset (mail-content-type-get type 'charset)
+ content (mm-get-part handle))
+ (with-temp-buffer
+ (if (eq charset 'gnus-decoded)
+ (mm-enable-multibyte)
+ (mm-disable-multibyte))
+ (insert content)
+ ;; resolve cid contents
+ (let ((case-fold-search t)
+ cid-file)
+ (goto-char (point-min))
+ (while (re-search-forward "\
+<img[\t\n ]+\\(?:[^\t\n >]+[\t\n ]+\\)*src=\"\\(cid:\\([^\"]+\\)\\)\""
+ nil t)
+ (unless cid-dir
+ (setq cid-dir (mm-make-temp-file "cid" t))
+ (add-to-list 'gnus-article-browse-html-temp-list cid-dir))
+ (setq file nil
+ content nil)
+ (when (setq cid-file
+ (gnus-article-browse-html-save-cid-content
+ (match-string 2)
+ (with-current-buffer gnus-article-buffer
+ gnus-article-mime-handles)
+ cid-dir))
+ (replace-match (concat "file://" cid-file)
+ nil nil nil 1))))
+ (unless content (setq content (buffer-string))))
+ (when (or charset header (not file))
(setq tmp-file (mm-make-temp-file
;; Do we need to care for 8.3 filenames?
"mm-" nil ".html")))
;; Add a meta html tag to specify charset and a header.
(cond
(header
- (let (title eheader body hcharset coding)
+ (let (title eheader body hcharset coding force-charset)
(with-temp-buffer
(mm-enable-multibyte)
(setq case-fold-search t)
@@ -2885,8 +2913,8 @@ message header will be added to the bodies of the \"text/html\" parts."
charset)
title (when title
(mm-encode-coding-string title charset))
- body (mm-encode-coding-string (mm-get-part handle)
- charset))
+ body (mm-encode-coding-string content charset)
+ force-charset t)
(setq hcharset (mm-find-mime-charset-region (point-min)
(point-max)))
(cond ((= (length hcharset) 1)
@@ -2907,7 +2935,7 @@ message header will be added to the bodies of the \"text/html\" parts."
title (when title
(mm-encode-coding-string
title coding))
- body (mm-get-part handle))
+ body content)
(setq charset 'utf-8
eheader (mm-encode-coding-string
(buffer-string) charset)
@@ -2916,22 +2944,23 @@ message header will be added to the bodies of the \"text/html\" parts."
title charset))
body (mm-encode-coding-string
(mm-decode-coding-string
- (mm-get-part handle) body)
- charset))))
+ content body)
+ charset)
+ force-charset t)))
(setq charset hcharset
eheader (mm-encode-coding-string
(buffer-string) coding)
title (when title
(mm-encode-coding-string
title coding))
- body (mm-get-part handle)))
+ body content))
(setq eheader (mm-string-as-unibyte (buffer-string))
- body (mm-get-part handle))))
+ body content)))
(erase-buffer)
(mm-disable-multibyte)
(insert body)
(when charset
- (mm-add-meta-html-tag handle charset))
+ (mm-add-meta-html-tag handle charset force-charset))
(when title
(goto-char (point-min))
(unless (search-forward "<title>" nil t)
@@ -2948,10 +2977,9 @@ message header will be added to the bodies of the \"text/html\" parts."
(charset
(mm-with-unibyte-buffer
(insert (if (eq charset 'gnus-decoded)
- (mm-encode-coding-string
- (mm-get-part handle)
- (setq charset 'utf-8))
- (mm-get-part handle)))
+ (mm-encode-coding-string content
+ (setq charset 'utf-8))
+ content))
(if (or (mm-add-meta-html-tag handle charset)
(not file))
(mm-write-region (point-min) (point-max)
@@ -2998,17 +3026,23 @@ message header will be added to the bodies of the \"text/html\" parts."
(defun gnus-article-browse-html-article (&optional arg)
"View \"text/html\" parts of the current article with a WWW browser.
+Inline images embedded in a message using the cid scheme, as they are
+generally considered to be safe, will be processed properly.
The message header is added to the beginning of every html part unless
the prefix argument ARG is given.
-Warning: Spammers use links to images in HTML articles to verify
-whether you have read the message. As
+Warning: Spammers use links to images (using the http scheme) in HTML
+articles to verify whether you have read the message. As
`gnus-article-browse-html-article' passes the HTML content to the
browser without eliminating these \"web bugs\" you should only
use it for mails from trusted senders.
If you always want to display HTML parts in the browser, set
-`mm-text-html-renderer' to nil."
+`mm-text-html-renderer' to nil.
+
+This command creates temporary files to pass HTML contents including
+images if any to the browser, and deletes them when exiting the group
+\(if you want)."
;; Cf. `mm-w3m-safe-url-regexp'
(interactive "P")
(if arg
@@ -3883,7 +3917,7 @@ Directory to save to is default to `gnus-article-save-directory'."
"Save %s in rmail file" filename
gnus-rmail-save-name gnus-newsgroup-name
gnus-current-headers 'gnus-newsgroup-last-rmail))
- (gnus-eval-in-buffer-window gnus-save-article-buffer
+ (with-current-buffer gnus-save-article-buffer
(save-excursion
(save-restriction
(widen)
@@ -3901,7 +3935,7 @@ Directory to save to is default to `gnus-article-save-directory'."
"Save %s in Unix mail file" filename
gnus-mail-save-name gnus-newsgroup-name
gnus-current-headers 'gnus-newsgroup-last-mail))
- (gnus-eval-in-buffer-window gnus-save-article-buffer
+ (with-current-buffer gnus-save-article-buffer
(save-excursion
(save-restriction
(widen)
@@ -3922,7 +3956,7 @@ Directory to save to is default to `gnus-article-save-directory'."
"Save %s in file" filename
gnus-file-save-name gnus-newsgroup-name
gnus-current-headers 'gnus-newsgroup-last-file))
- (gnus-eval-in-buffer-window gnus-save-article-buffer
+ (with-current-buffer gnus-save-article-buffer
(save-excursion
(save-restriction
(widen)
@@ -3954,7 +3988,7 @@ The directory to save in defaults to `gnus-article-save-directory'."
"Save %s body in file" filename
gnus-file-save-name gnus-newsgroup-name
gnus-current-headers 'gnus-newsgroup-last-file))
- (gnus-eval-in-buffer-window gnus-save-article-buffer
+ (with-current-buffer gnus-save-article-buffer
(save-excursion
(save-restriction
(widen)
@@ -4033,7 +4067,7 @@ and the raw article including all headers will be piped."
(if default
(setq command default)
(error "A command is required")))
- (gnus-eval-in-buffer-window save-buffer
+ (with-current-buffer save-buffer
(save-restriction
(widen)
(shell-command-on-region (point-min) (point-max) command nil)))
@@ -4192,6 +4226,8 @@ If variable `gnus-use-long-file-name' is non-nil, it is
(put-text-property (match-end 0) (point-max)
'face eface)))))))))
+(autoload 'canlock-verify "canlock" nil t) ;; for XEmacs.
+
(defun article-verify-cancel-lock ()
"Verify Cancel-Lock header."
(interactive)
@@ -4258,6 +4294,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is
article-date-lapsed
article-emphasize
article-treat-dumbquotes
+ article-treat-non-ascii
article-normalize-headers
;;(article-show-all . gnus-article-show-all-headers)
)))
@@ -4310,7 +4347,6 @@ If variable `gnus-use-long-file-name' is non-nil, it is
(defun gnus-article-make-menu-bar ()
(unless (boundp 'gnus-article-commands-menu)
(gnus-summary-make-menu-bar))
- (gnus-turn-off-edit-menu 'article)
(unless (boundp 'gnus-article-article-menu)
(easy-menu-define
gnus-article-article-menu gnus-article-mode-map ""
@@ -4345,6 +4381,8 @@ If variable `gnus-use-long-file-name' is non-nil, it is
(gnus-run-hooks 'gnus-article-menu-hook)))
+(defvar bookmark-make-record-function)
+
(defun gnus-article-mode ()
"Major mode for displaying an article.
@@ -4383,11 +4421,12 @@ commands:
(make-local-variable 'gnus-article-image-alist)
(make-local-variable 'gnus-article-charset)
(make-local-variable 'gnus-article-ignored-charsets)
+ (set (make-local-variable 'bookmark-make-record-function)
+ 'gnus-summary-bookmark-make-record)
;; Prevent Emacs 22 from displaying non-break space with `nobreak-space'
;; face.
(set (make-local-variable 'nobreak-char-display) nil)
(setq cursor-in-non-selected-windows nil)
- (setq truncate-lines gnus-article-truncate-lines)
(gnus-set-default-directory)
(buffer-disable-undo)
(setq buffer-read-only t
@@ -4447,9 +4486,11 @@ Internal variable.")
(setq gnus-button-marker-list nil)
(unless (eq major-mode 'gnus-article-mode)
(gnus-article-mode))
+ (setq truncate-lines gnus-article-truncate-lines)
(current-buffer))
(with-current-buffer (gnus-get-buffer-create name)
(gnus-article-mode)
+ (setq truncate-lines gnus-article-truncate-lines)
(make-local-variable 'gnus-summary-buffer)
(setq gnus-summary-buffer
(gnus-summary-buffer-name gnus-newsgroup-name))
@@ -4750,6 +4791,22 @@ General format specifiers can also be used. See Info node
(vector (caddr c) (car c) :active t))
gnus-mime-button-commands)))
+(defvar gnus-url-button-commands
+ '((gnus-article-copy-string "u" "Copy URL to kill ring")))
+
+(defvar gnus-url-button-map
+ (let ((map (make-sparse-keymap)))
+ (dolist (c gnus-url-button-commands)
+ (define-key map (cadr c) (car c)))
+ map))
+
+(easy-menu-define
+ gnus-url-button-menu gnus-url-button-map "URL button menu."
+ `("Url Button"
+ ,@(mapcar (lambda (c)
+ (vector (caddr c) (car c) :active t))
+ gnus-url-button-commands)))
+
(defmacro gnus-bind-safe-url-regexp (&rest body)
"Bind `mm-w3m-safe-url-regexp' according to `gnus-safe-html-newsgroups'."
`(let ((mm-w3m-safe-url-regexp
@@ -4759,7 +4816,11 @@ General format specifiers can also be used. See Info node
(with-current-buffer gnus-article-current-summary
gnus-newsgroup-name)
gnus-newsgroup-name)))
- (if (cond ((stringp gnus-safe-html-newsgroups)
+ (if (cond ((not group)
+ ;; Maybe we're in a mml-preview buffer
+ ;; and no group is selected.
+ t)
+ ((stringp gnus-safe-html-newsgroups)
(string-match gnus-safe-html-newsgroups group))
((consp gnus-safe-html-newsgroups)
(member group gnus-safe-html-newsgroups)))
@@ -4797,14 +4858,17 @@ General format specifiers can also be used. See Info node
(defun gnus-article-jump-to-part (n)
"Jump to MIME part N."
(interactive "P")
- (pop-to-buffer gnus-article-buffer)
- ;; FIXME: why is it necessary?
- (sit-for 0)
- (let ((parts (length gnus-article-mime-handle-alist)))
- (or n (setq n
- (string-to-number
- (read-string ;; Emacs 21 doesn't have `read-number'.
- (format "Jump to part (2..%s): " parts)))))
+ (let ((parts (with-current-buffer gnus-article-buffer
+ (length gnus-article-mime-handle-alist))))
+ (when (zerop parts)
+ (error "No such part"))
+ (pop-to-buffer gnus-article-buffer)
+ ;; FIXME: why is it necessary?
+ (sit-for 0)
+ (or n
+ (setq n (if (= parts 1)
+ 1
+ (read-number (format "Jump to part (1..%s): " parts)))))
(unless (and (integerp n) (<= n parts) (>= n 1))
(setq n
(progn
@@ -4823,6 +4887,10 @@ General format specifiers can also be used. See Info node
(t
(gnus-article-goto-part n)))))
+(defvar gnus-mime-buttonized-part-id nil
+ "ID of a mime part that should be buttonized.
+`gnus-mime-save-part-and-strip' and `gnus-mime-delete-part' bind it.")
+
(eval-when-compile
(defsubst gnus-article-edit-part (handles &optional current-id)
"Edit an article in order to delete a mime part.
@@ -4865,10 +4933,15 @@ and `gnus-mime-delete-part', and not provided at run-time normally."
,(gnus-group-read-only-p)
,gnus-summary-buffer no-highlight))
t)
- (gnus-article-edit-done)
+ ;; Force buttonizing this part.
+ (let ((gnus-mime-buttonized-part-id current-id))
+ (gnus-article-edit-done))
(gnus-configure-windows 'article)
(when (and current-id (integerp gnus-auto-select-part))
- (gnus-article-jump-to-part (+ current-id gnus-auto-select-part)))))
+ (gnus-article-jump-to-part
+ (min (max (+ current-id gnus-auto-select-part) 1)
+ (with-current-buffer gnus-article-buffer
+ (length gnus-article-mime-handle-alist)))))))
(defun gnus-mime-replace-part (file)
"Replace MIME part under point with an external body."
@@ -4949,7 +5022,7 @@ Deleting parts may malfunction or destroy the article; continue? "))
(unless data
(error "No MIME part under point"))
(with-current-buffer (mm-handle-buffer data)
- (let ((bsize (format "%s" (buffer-size))))
+ (let ((bsize (buffer-size)))
(erase-buffer)
(insert
(concat
@@ -4958,7 +5031,10 @@ Deleting parts may malfunction or destroy the article; continue? "))
"|\n"
"| Type: " type "\n"
"| Filename: " filename "\n"
- "| Size (encoded): " bsize " Byte\n"
+ "| Size (encoded): " (format "%s byte%s\n"
+ bsize (if (= bsize 1)
+ ""
+ "s"))
(when description
(concat "| Description: " description "\n"))
"`----\n"))
@@ -4978,13 +5054,14 @@ Deleting parts may malfunction or destroy the article; continue? "))
(when data
(mm-save-part data))))
-(defun gnus-mime-pipe-part ()
- "Pipe the MIME part under point to a process."
+(defun gnus-mime-pipe-part (&optional cmd)
+ "Pipe the MIME part under point to a process.
+Use CMD as the process."
(interactive)
(gnus-article-check-buffer)
(let ((data (get-text-property (point) 'gnus-data)))
(when data
- (mm-pipe-part data))))
+ (mm-pipe-part data cmd))))
(defun gnus-mime-view-part ()
"Interactively choose a viewing method for the MIME part under point."
@@ -5020,11 +5097,12 @@ available media-types."
(unless mime-type
(setq mime-type
(let ((default (gnus-mime-view-part-as-type-internal)))
- (completing-read
- (format "View as MIME type (default %s): "
- (car default))
- (mapcar #'list (mailcap-mime-types))
- pred nil nil nil
+ (gnus-completing-read
+ "View as MIME type"
+ (if pred
+ (gnus-remove-if-not pred (mailcap-mime-types))
+ (mailcap-mime-types))
+ nil nil nil
(car default)))))
(gnus-article-check-buffer)
(let ((handle (get-text-property (point) 'gnus-data)))
@@ -5090,7 +5168,7 @@ are decompressed."
(if (or coding-system
(and charset
(setq coding-system (mm-charset-to-coding-system charset))
- (not (eq charset 'ascii))))
+ (not (eq coding-system 'ascii))))
(progn
(mm-enable-multibyte)
(insert (mm-decode-coding-string contents coding-system))
@@ -5263,11 +5341,9 @@ specified charset."
(mm-enable-external t))
(if (not (stringp method))
(gnus-mime-view-part-as-type
- nil (lambda (types) (stringp (mailcap-mime-info (car types)))))
+ nil (lambda (type) (stringp (mailcap-mime-info type))))
(when handle
- (if (mm-handle-undisplayer handle)
- (mm-remove-part handle)
- (mm-display-part handle))))))
+ (mm-display-part handle nil t)))))
(defun gnus-mime-view-part-internally (&optional handle)
"View the MIME part under point with an internal viewer.
@@ -5284,16 +5360,14 @@ If no internal viewer is available, use an external viewer."
(inhibit-read-only t))
(if (not (mm-inlinable-p handle))
(gnus-mime-view-part-as-type
- nil (lambda (types) (mm-inlinable-p handle (car types))))
+ nil (lambda (type) (mm-inlinable-p handle type)))
(when handle
- (if (mm-handle-undisplayer handle)
- (mm-remove-part handle)
- (gnus-bind-safe-url-regexp (mm-display-part handle)))))))
+ (gnus-bind-safe-url-regexp (mm-display-part handle))))))
(defun gnus-mime-action-on-part (&optional action)
"Do something with the MIME attachment at \(point\)."
(interactive
- (list (completing-read "Action: " gnus-mime-action-alist nil t)))
+ (list (gnus-completing-read "Action" (mapcar 'car gnus-mime-action-alist) t)))
(gnus-article-check-buffer)
(let ((action-pair (assoc action gnus-mime-action-alist)))
(if action-pair
@@ -5351,6 +5425,10 @@ If INTERACTIVE, call FUNCTION interactivly."
(when (gnus-article-goto-part n)
;; We point the cursor and the arrow at the MIME button
;; when the `function' prompt the user for something.
+ (unless (and (pos-visible-in-window-p)
+ (> (count-lines (point) (window-end))
+ (/ (1- (window-height)) 3)))
+ (recenter (/ (1- (window-height)) 3)))
(let ((cursor-in-non-selected-windows t)
(overlay-arrow-string "=>")
(overlay-arrow-position (point-marker)))
@@ -5362,11 +5440,10 @@ If INTERACTIVE, call FUNCTION interactivly."
(funcall function))
(interactive
(call-interactively
- function
- (cdr (assq n gnus-article-mime-handle-alist))))
+ function (get-text-property (point) 'gnus-data)))
(t
(funcall function
- (cdr (assq n gnus-article-mime-handle-alist)))))
+ (get-text-property (point) 'gnus-data))))
(set-marker overlay-arrow-position nil)
(unless gnus-auto-select-part
(gnus-select-frame-set-input-focus frame)
@@ -5462,7 +5539,9 @@ N is the numerical prefix."
1))
(defun gnus-article-view-part (&optional n)
- "View MIME part N, which is the numerical prefix."
+ "View MIME part N, which is the numerical prefix.
+If the part is already shown, hide the part. If N is nil, view
+all parts."
(interactive "P")
(with-current-buffer gnus-article-buffer
(or (numberp n) (setq n (gnus-article-mime-match-handle-first
@@ -5529,7 +5608,41 @@ N is the numerical prefix."
(defun gnus-article-goto-part (n)
"Go to MIME part N."
- (gnus-goto-char (text-property-any (point-min) (point-max) 'gnus-part n)))
+ (when gnus-break-pages
+ (widen))
+ (prog1
+ (let ((start (text-property-any (point-min) (point-max) 'gnus-part n))
+ part handle end next handles)
+ (when start
+ (goto-char start)
+ (if (setq handle (get-text-property start 'gnus-data))
+ start
+ ;; Go to the displayed subpart, assuming this is
+ ;; multipart/alternative.
+ (setq part start
+ end (point-at-eol))
+ (while (and (not handle)
+ part
+ (< part end)
+ (setq next (text-property-not-all part end
+ 'gnus-data nil)))
+ (setq part next
+ handle (get-text-property part 'gnus-data))
+ (push (cons handle part) handles)
+ (unless (mm-handle-displayed-p handle)
+ (setq handle nil
+ part (text-property-any part end 'gnus-data nil))))
+ (unless handle
+ ;; No subpart is displayed, so we find preferred one.
+ (setq part
+ (cdr (assq (mm-preferred-alternative
+ (nreverse (mapcar 'car handles)))
+ handles))))
+ (if part
+ (goto-char (1+ part))
+ start))))
+ (when gnus-break-pages
+ (gnus-narrow-to-page))))
(defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)
(let ((gnus-tmp-name
@@ -5576,7 +5689,7 @@ N is the numerical prefix."
:action 'gnus-widget-press-button
:button-keymap gnus-mime-button-map
:help-echo
- (lambda (widget/window &optional overlay pos)
+ (lambda (widget)
;; Needed to properly clear the message due to a bug in
;; wid-edit (XEmacs only).
(if (boundp 'help-echo-owns-message)
@@ -5584,14 +5697,7 @@ N is the numerical prefix."
(format
"%S: %s the MIME part; %S: more options"
(aref gnus-mouse-2 0)
- ;; XEmacs will get a single widget arg; Emacs 21 will get
- ;; window, overlay, position.
- (if (mm-handle-displayed-p
- (if overlay
- (with-current-buffer (gnus-overlay-buffer overlay)
- (widget-get (widget-at (gnus-overlay-start overlay))
- :mime-handle))
- (widget-get widget/window :mime-handle)))
+ (if (mm-handle-displayed-p (widget-get widget :mime-handle))
"hide" "show")
(aref gnus-down-mouse-3 0))))))
@@ -5645,7 +5751,7 @@ N is the numerical prefix."
(save-restriction
(article-goto-body)
(narrow-to-region (point) (point-max))
- (gnus-treat-article nil 1 1)
+ (gnus-treat-article nil 1 1 "text/plain")
(widen)))
(unless ihandles
;; Highlight the headers.
@@ -5745,7 +5851,12 @@ If displaying \"text/html\" is discouraged \(see
(while ignored
(when (string-match (pop ignored) type)
(throw 'ignored nil)))
- (if (and (setq not-attachment
+ (if (and (not (and (if (gnus-buffer-live-p gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
+ gnus-inhibit-images)
+ gnus-inhibit-images)
+ (string-match "\\`image/" type)))
+ (setq not-attachment
(and (not (mm-inline-override-p handle))
(or (not (mm-handle-disposition handle))
(equal (car (mm-handle-disposition handle))
@@ -5770,7 +5881,8 @@ If displaying \"text/html\" is discouraged \(see
((or (bobp) (eq (char-before (1- (point))) ?\n)) 0)
(t 1))))
(when (or (not display)
- (not (gnus-unbuttonized-mime-type-p type)))
+ (not (gnus-unbuttonized-mime-type-p type))
+ (eq id gnus-mime-buttonized-part-id))
(gnus-insert-mime-button
handle id (list (or display (and not-attachment text))))
(gnus-article-insert-newline)
@@ -5932,7 +6044,7 @@ If displaying \"text/html\" is discouraged \(see
(gnus-treat-article
nil (length gnus-article-mime-handle-alist)
(gnus-article-mime-total-parts)
- (mm-handle-media-type handle))))))
+ (mm-handle-media-type preferred))))))
(goto-char (point-max))
(setcdr begend (point-marker)))))
(when ibegend
@@ -6195,29 +6307,24 @@ Argument LINES specifies lines to be scrolled up."
(gnus-article-next-page-1 lines)
nil))
-(defmacro gnus-article-beginning-of-window ()
+(defun gnus-article-beginning-of-window ()
"Move point to the beginning of the window.
In Emacs, the point is placed at the line number which `scroll-margin'
specifies."
(if (featurep 'xemacs)
- '(move-to-window-line 0)
- '(move-to-window-line
- (min (max 0 scroll-margin)
- (max 1 (- (window-height)
- (if mode-line-format 1 0)
- (if header-line-format 1 0)
- 2))))))
+ (move-to-window-line 0)
+ ;; There is an obscure bug in Emacs that makes it impossible to
+ ;; scroll past big pictures in the article buffer. Try to fix
+ ;; this by adding a sanity check by counting the lines visible.
+ (when (> (count-lines (window-start) (window-end)) 30)
+ (move-to-window-line
+ (min (max 0 scroll-margin)
+ (max 1 (- (window-height)
+ (if mode-line-format 1 0)
+ (if header-line-format 1 0)
+ 2)))))))
(defun gnus-article-next-page-1 (lines)
- (unless (featurep 'xemacs)
- ;; Protect against the bug that Emacs 21.x hangs up when scrolling up for
- ;; too many number of lines if `scroll-margin' is set as two or greater.
- (when (and (numberp lines)
- (> lines 0)
- (> scroll-margin 0))
- (setq lines (min lines
- (max 0 (- (count-lines (window-start) (point-max))
- scroll-margin))))))
(condition-case ()
(let ((scroll-in-place nil))
(scroll-up lines))
@@ -6296,7 +6403,7 @@ not have a face in `gnus-article-boring-faces'."
(defun gnus-article-describe-briefly ()
"Describe article mode commands briefly."
(interactive)
- (gnus-message 6 (substitute-command-keys "\\<gnus-article-mode-map>\\[gnus-article-goto-next-page]:Next page \\[gnus-article-goto-prev-page]:Prev page \\[gnus-article-show-summary]:Show summary \\[gnus-info-find-node]:Run Info \\[gnus-article-describe-briefly]:This help")))
+ (gnus-message 6 "%s" (substitute-command-keys "\\<gnus-article-mode-map>\\[gnus-article-goto-next-page]:Next page \\[gnus-article-goto-prev-page]:Prev page \\[gnus-article-show-summary]:Show summary \\[gnus-info-find-node]:Run Info \\[gnus-article-describe-briefly]:This help")))
(defun gnus-article-check-buffer ()
"Beep if not in an article buffer."
@@ -6471,6 +6578,9 @@ KEY is a string or a vector."
(defvar gnus-draft-mode)
;; Calling help-buffer will autoload help-mode.
(defvar help-xref-stack-item)
+;; Emacs 22 doesn't load it in the batch mode.
+(eval-when-compile
+ (autoload 'help-buffer "help-mode"))
(defun gnus-article-describe-bindings (&optional prefix)
"Show a list of all defined keys, and their definitions.
@@ -6521,9 +6631,7 @@ then we display only bindings that start with that prefix."
(with-current-buffer ,(current-buffer)
(gnus-article-describe-bindings prefix)))
,prefix)))
- (with-current-buffer (if (fboundp 'help-buffer)
- (let (help-xref-following) (help-buffer))
- "*Help*") ;; Emacs 21
+ (with-current-buffer (let (help-xref-following) (help-buffer))
(setq help-xref-stack-item item)))))
(defun gnus-article-reply-with-original (&optional wide)
@@ -6777,6 +6885,18 @@ If given a prefix, show the hidden text instead."
(point))
(set-buffer buf))))))
+(defun gnus-block-private-groups (group)
+ (if (gnus-news-group-p group)
+ ;; Block nothing in news groups.
+ nil
+ ;; Block everything anywhere else.
+ "."))
+
+(defun gnus-blocked-images ()
+ (if (functionp gnus-blocked-images)
+ (funcall gnus-blocked-images gnus-newsgroup-name)
+ gnus-blocked-images))
+
;;;
;;; Article editing
;;;
@@ -6920,9 +7040,7 @@ groups."
(gnus-backlog-remove-article
(car gnus-article-current) (cdr gnus-article-current)))
;; Flush original article as well.
- (when (get-buffer gnus-original-article-buffer)
- (with-current-buffer gnus-original-article-buffer
- (setq gnus-original-article nil)))
+ (gnus-flush-original-article-buffer)
(when gnus-use-cache
(gnus-cache-update-article
(car gnus-article-current) (cdr gnus-article-current)))
@@ -6936,6 +7054,11 @@ groups."
(set-window-point (get-buffer-window buf) (point)))
(gnus-summary-show-article))
+(defun gnus-flush-original-article-buffer ()
+ (when (get-buffer gnus-original-article-buffer)
+ (with-current-buffer gnus-original-article-buffer
+ (setq gnus-original-article nil))))
+
(defun gnus-article-edit-exit ()
"Exit the article editing without updating."
(interactive)
@@ -7024,46 +7147,6 @@ man page."
(function :tag "Other"))
:group 'gnus-article-buttons)
-(defcustom gnus-ctan-url "http://tug.ctan.org/tex-archive/"
- "Top directory of a CTAN \(Comprehensive TeX Archive Network\) archive.
-If the default site is too slow, try to find a CTAN mirror, see
-<URL:http://tug.ctan.org/tex-archive/CTAN.sites?action=/index.html>. See also
-the variable `gnus-button-handle-ctan'."
- :version "22.1"
- :group 'gnus-article-buttons
- :link '(custom-manual "(gnus)Group Parameters")
- :type '(choice (const "http://www.tex.ac.uk/tex-archive/")
- (const "http://tug.ctan.org/tex-archive/")
- (const "http://www.dante.de/CTAN/")
- (string :tag "Other")))
-
-(defcustom gnus-button-ctan-handler 'browse-url
- "Function to use for displaying CTAN links.
-The function must take one argument, the string naming the URL."
- :version "22.1"
- :type '(choice (function-item :tag "Browse Url" browse-url)
- (function :tag "Other"))
- :group 'gnus-article-buttons)
-
-(defcustom gnus-button-handle-ctan-bogus-regexp "^/?tex-archive/\\|^/"
- "Bogus strings removed from CTAN URLs."
- :version "22.1"
- :group 'gnus-article-buttons
- :type '(choice (const "^/?tex-archive/\\|/")
- (regexp :tag "Other")))
-
-(defcustom gnus-button-ctan-directory-regexp
- (regexp-opt
- (list "archive-tools" "biblio" "bibliography" "digests" "documentation"
- "dviware" "fonts" "graphics" "help" "indexing" "info" "language"
- "languages" "macros" "nonfree" "obsolete" "support" "systems"
- "tds" "tools" "usergrps" "web") t)
- "Regular expression for ctan directories.
-It should match all directories in the top level of `gnus-ctan-url'."
- :version "22.1"
- :group 'gnus-article-buttons
- :type 'regexp)
-
(defcustom gnus-button-mid-or-mail-regexp
(concat "\\b\\(<?" gnus-button-valid-localpart-regexp "@"
gnus-button-valid-fqdn-regexp
@@ -7321,26 +7404,6 @@ Calls `describe-variable' or `describe-function'."
(gnus-message 1 "Cannot locale library `%s'." url)
(find-file-read-only file))))
-(defun gnus-button-handle-ctan (url)
- "Call `browse-url' when pushing a CTAN URL button."
- (funcall
- gnus-button-ctan-handler
- (concat
- gnus-ctan-url
- (gnus-replace-in-string url gnus-button-handle-ctan-bogus-regexp ""))))
-
-(defcustom gnus-button-tex-level 5
- "*Integer that says how many TeX-related buttons Gnus will show.
-The higher the number, the more buttons will appear and the more false
-positives are possible. Note that you can set this variable local to
-specific groups. Setting it higher in TeX groups is probably a good idea.
-See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on
-how to set variables in specific groups."
- :version "22.1"
- :group 'gnus-article-buttons
- :link '(custom-manual "(gnus)Group Parameters")
- :type 'integer)
-
(defcustom gnus-button-man-level 5
"*Integer that says how many man-related buttons Gnus will show.
The higher the number, the more buttons will appear and the more false
@@ -7407,20 +7470,6 @@ positives are possible."
0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
("\\bmailto:\\([^ \n\t]+\\)"
0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
- ;; CTAN
- ((concat "\\bCTAN:[ \t\n]?[^>)!;:,'\n\t ]*\\("
- gnus-button-ctan-directory-regexp
- "[^][>)!;:,'\n\t ]+\\)")
- 0 (>= gnus-button-tex-level 1) gnus-button-handle-ctan 1)
- ((concat "\\btex-archive/\\("
- gnus-button-ctan-directory-regexp
- "/[-_.a-z0-9/]+[-_./a-z0-9]+[/a-z0-9]\\)")
- 1 (>= gnus-button-tex-level 6) gnus-button-handle-ctan 1)
- ((concat
- "\\b\\("
- gnus-button-ctan-directory-regexp
- "/[-_.a-z0-9]+/[-_./a-z0-9]+[/a-z0-9]\\)")
- 1 (>= gnus-button-tex-level 8) gnus-button-handle-ctan 1)
;; Info Konqueror style <info:/foo/bar baz>.
;; Must come before " Gnus home-grown style".
("\\binfo://?\\([^'\">\n\t]+\\)"
@@ -7719,7 +7768,11 @@ specified by `gnus-button-alist'."
(unless (and (eq (car entry) 'gnus-button-url-regexp)
(gnus-article-extend-url-button from start end))
(gnus-article-add-button start end
- 'gnus-button-push from)))))))))
+ 'gnus-button-push from)
+ (gnus-put-text-property
+ start end
+ 'gnus-string (buffer-substring-no-properties
+ start end))))))))))
(defun gnus-article-extend-url-button (beg start end)
"Extend url button if url is folded into two or more lines.
@@ -7811,7 +7864,7 @@ url is put as the `gnus-button-url' overlay property on the button."
;;; External functions:
-(defun gnus-article-add-button (from to fun &optional data)
+(defun gnus-article-add-button (from to fun &optional data text)
"Create a button between FROM and TO with callback FUN and data DATA."
(when gnus-article-button-face
(gnus-overlay-put (gnus-make-overlay from to nil t)
@@ -7823,8 +7876,21 @@ url is put as the `gnus-button-url' overlay property on the button."
(list 'gnus-callback fun)
(and data (list 'gnus-data data))))
(widget-convert-button 'link from to :action 'gnus-widget-press-button
+ :help-echo (or text "Follow the link")
+ :keymap gnus-url-button-map
:button-keymap gnus-widget-button-keymap))
+(defun gnus-article-copy-string ()
+ "Copy the string in the button to the kill ring."
+ (interactive)
+ (gnus-article-check-buffer)
+ (let ((data (get-text-property (point) 'gnus-string)))
+ (when data
+ (with-temp-buffer
+ (insert data)
+ (copy-region-as-kill (point-min) (point-max))
+ (message "Copied %s" data)))))
+
;;; Internal functions:
(defun gnus-article-set-globals ()
@@ -8080,6 +8146,7 @@ url is put as the `gnus-button-url' overlay property on the button."
(defun gnus-url-mailto (url)
;; Send mail to someone
+ (setq url (replace-regexp-in-string "\n" " " url))
(when (string-match "mailto:/*\\(.*\\)" url)
(setq url (substring url (match-beginning 1) nil)))
(let (to args subject func)
@@ -8089,8 +8156,7 @@ url is put as the `gnus-button-url' overlay property on the button."
(if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url)
(concat "to=" (match-string 1 url) "&"
(match-string 2 url))
- (concat "to=" url)))
- t)
+ (concat "to=" url))))
subject (cdr-safe (assoc "subject" args)))
(gnus-msg-mail)
(while args
@@ -8123,9 +8189,6 @@ url is put as the `gnus-button-url' overlay property on the button."
(defvar gnus-next-page-map
(let ((map (make-sparse-keymap)))
- (unless (>= emacs-major-version 21)
- ;; XEmacs doesn't care.
- (set-keymap-parent map gnus-article-mode-map))
(define-key map gnus-mouse-2 'gnus-button-next-page)
(define-key map "\r" 'gnus-button-next-page)
map))
@@ -8244,16 +8307,19 @@ For example:
;;; Treatment top-level handling.
;;;
-(defun gnus-treat-article (condition &optional part-number total-parts type)
- (let ((length (- (point-max) (point-min)))
+(defvar gnus-inhibit-article-treatments nil)
+
+(defun gnus-treat-article (gnus-treat-condition
+ &optional part-number total-parts gnus-treat-type)
+ (let ((gnus-treat-length (- (point-max) (point-min)))
(alist gnus-treatment-function-alist)
(article-goto-body-goes-to-point-min-p t)
(treated-type
- (or (not type)
+ (or (not gnus-treat-type)
(catch 'found
(let ((list gnus-article-treat-types))
(while list
- (when (string-match (pop list) type)
+ (when (string-match (pop list) gnus-treat-type)
(throw 'found t)))))))
(highlightp (gnus-visual-p 'article-highlight 'highlight))
val elem)
@@ -8266,6 +8332,8 @@ For example:
(symbol-value (car elem))))
(when (and (or (consp val)
treated-type)
+ (or (not gnus-inhibit-article-treatments)
+ (eq gnus-treat-condition 'head))
(gnus-treat-predicate val)
(or (not (get (car elem) 'highlight))
highlightp))
@@ -8275,16 +8343,16 @@ For example:
;; Dynamic variables.
(defvar part-number)
(defvar total-parts)
-(defvar type)
-(defvar condition)
-(defvar length)
+(defvar gnus-treat-type)
+(defvar gnus-treat-condition)
+(defvar gnus-treat-length)
(defun gnus-treat-predicate (val)
(cond
((null val)
nil)
- (condition
- (eq condition val))
+ (gnus-treat-condition
+ (eq gnus-treat-condition val))
((and (listp val)
(stringp (car val)))
(apply 'gnus-or (mapcar `(lambda (s)
@@ -8300,7 +8368,7 @@ For example:
((eq pred 'not)
(not (gnus-treat-predicate (car val))))
((eq pred 'typep)
- (equal (car val) type))
+ (equal (car val) gnus-treat-type))
(t
(error "%S is not a valid predicate" pred)))))
((eq val t)
@@ -8312,7 +8380,7 @@ For example:
((eq val 'last)
(eq part-number total-parts))
((numberp val)
- (< length val))
+ (< gnus-treat-length val))
(t
(error "%S is not a valid value" val))))
@@ -8321,9 +8389,9 @@ For example:
(interactive
(list
(or gnus-article-encrypt-protocol
- (completing-read "Encrypt protocol: "
- gnus-article-encrypt-protocol-alist
- nil t))
+ (gnus-completing-read "Encrypt protocol"
+ (mapcar 'car gnus-article-encrypt-protocol-alist)
+ t))
current-prefix-arg))
;; User might hit `K E' instead of `K e', so prompt once.
(when (and gnus-article-encrypt-protocol
@@ -8385,9 +8453,7 @@ For example:
(when gnus-keep-backlog
(gnus-backlog-remove-article
(car gnus-article-current) (cdr gnus-article-current)))
- (when (get-buffer gnus-original-article-buffer)
- (with-current-buffer gnus-original-article-buffer
- (setq gnus-original-article nil)))
+ (gnus-flush-original-article-buffer)
(when gnus-use-cache
(gnus-cache-update-article
(car gnus-article-current) (cdr gnus-article-current))))))))
@@ -8575,7 +8641,7 @@ For example:
:action 'gnus-widget-press-button
:button-keymap gnus-mime-security-button-map
:help-echo
- (lambda (widget/window &optional overlay pos)
+ (lambda (widget)
;; Needed to properly clear the message due to a bug in
;; wid-edit (XEmacs only).
(when (boundp 'help-echo-owns-message)
@@ -8637,5 +8703,4 @@ For example:
(run-hooks 'gnus-art-load-hook)
-;; arch-tag: 2654516f-6279-48f9-a83b-05c1fa450c33
;;; gnus-art.el ends here
diff --git a/lisp/gnus/gnus-async.el b/lisp/gnus/gnus-async.el
index 432990e3c2c..9bb28f3a05d 100644
--- a/lisp/gnus/gnus-async.el
+++ b/lisp/gnus/gnus-async.el
@@ -71,6 +71,13 @@ It should return non-nil if the article is to be prefetched."
:group 'gnus-asynchronous
:type 'function)
+(defcustom gnus-async-post-fetch-function nil
+ "Function called after an article has been prefetched.
+The function will be called narrowed to the region of the article
+that was fetched."
+ :group 'gnus-asynchronous
+ :type 'function)
+
;;; Internal variables.
(defvar gnus-async-prefetch-article-buffer " *Async Prefetch Article*")
@@ -138,8 +145,7 @@ It should return non-nil if the article is to be prefetched."
(when (and (gnus-buffer-live-p summary)
gnus-asynchronous
(gnus-group-asynchronous-p group))
- (save-excursion
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
(let ((next (caadr (gnus-data-find-list article))))
(when next
(if (not (fboundp 'run-with-idle-timer))
@@ -198,8 +204,7 @@ It should return non-nil if the article is to be prefetched."
(when (and do-fetch article)
;; We want to fetch some more articles.
- (save-excursion
- (set-buffer summary)
+ (with-current-buffer summary
(let (mark)
(gnus-async-set-buffer)
(goto-char (point-max))
@@ -221,12 +226,23 @@ It should return non-nil if the article is to be prefetched."
`(lambda (arg)
(gnus-async-article-callback arg ,group ,article ,mark ,summary ,next)))
+(eval-when-compile
+ (autoload 'gnus-html-prefetch-images "gnus-html"))
+
(defun gnus-async-article-callback (arg group article mark summary next)
"Function called when an async article is done being fetched."
(save-excursion
(setq gnus-async-current-prefetch-article nil)
(when arg
(gnus-async-set-buffer)
+ (save-excursion
+ (save-restriction
+ (narrow-to-region mark (point-max))
+ ;; Prefetch images for the groups that want that.
+ (when (fboundp 'gnus-html-prefetch-images)
+ (gnus-html-prefetch-images summary))
+ (when gnus-async-post-fetch-function
+ (funcall gnus-async-post-fetch-function summary))))
(gnus-async-with-semaphore
(setq
gnus-async-article-alist
@@ -300,7 +316,8 @@ It should return non-nil if the article is to be prefetched."
(set-marker (caddr entry) nil))
(gnus-async-with-semaphore
(setq gnus-async-article-alist
- (delq entry gnus-async-article-alist))))
+ (delq entry gnus-async-article-alist))
+ (unintern (car entry) gnus-async-hashtb)))
(defun gnus-async-prefetch-remove-group (group)
"Remove all articles belonging to GROUP from the prefetch buffer."
@@ -316,8 +333,8 @@ It should return non-nil if the article is to be prefetched."
"Return the entry for ARTICLE in GROUP if it has been prefetched."
(let ((entry (save-excursion
(gnus-async-set-buffer)
- (assq (intern (format "%s-%d" group article)
- gnus-async-hashtb)
+ (assq (intern-soft (format "%s-%d" group article)
+ gnus-async-hashtb)
gnus-async-article-alist))))
;; Perhaps something has emptied the buffer?
(if (and entry
@@ -372,5 +389,4 @@ It should return non-nil if the article is to be prefetched."
(provide 'gnus-async)
-;; arch-tag: fee61de5-3ea2-4de6-8578-2f90ce89391d
;;; gnus-async.el ends here
diff --git a/lisp/gnus/gnus-audio.el b/lisp/gnus/gnus-audio.el
deleted file mode 100644
index a3ba9776645..00000000000
--- a/lisp/gnus/gnus-audio.el
+++ /dev/null
@@ -1,150 +0,0 @@
-;;; gnus-audio.el --- Sound effects for Gnus
-
-;; Copyright (C) 1996, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Steven L. Baur <steve@miranova.com>
-;; Keywords: news, mail, 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 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This file provides access to sound effects in Gnus.
-;; This file is partially stripped to support earcons.el.
-
-;;; Code:
-
-(require 'nnheader)
-
-(defgroup gnus-audio nil
- "Playing sound in Gnus."
- :version "21.1"
- :group 'gnus-visual
- :group 'multimedia)
-
-(defvar gnus-audio-inline-sound
- (or (if (fboundp 'device-sound-enabled-p)
- (device-sound-enabled-p)) ; XEmacs
- (fboundp 'play-sound)) ; Emacs 21
- "Non-nil means try to play sounds without using an external program.")
-
-(defcustom gnus-audio-directory (nnheader-find-etc-directory "sounds")
- "The directory containing the Sound Files."
- :type '(choice directory (const nil))
- :group 'gnus-audio)
-
-(defcustom gnus-audio-au-player (executable-find "play")
- "Executable program for playing sun AU format sound files."
- :group 'gnus-audio
- :type '(choice file (const nil)))
-
-(defcustom gnus-audio-wav-player (executable-find "play")
- "Executable program for playing WAV files."
- :group 'gnus-audio
- :type '(choice file (const nil)))
-
-;;; The following isn't implemented yet. Wait for Millennium Gnus.
-;;(defvar gnus-audio-effects-enabled t
-;; "When t, Gnus will use sound effects.")
-;;(defvar gnus-audio-enable-hooks nil
-;; "Functions run when enabling sound effects.")
-;;(defvar gnus-audio-disable-hooks nil
-;; "Functions run when disabling sound effects.")
-;;(defvar gnus-audio-theme-song nil
-;; "Theme song for Gnus.")
-;;(defvar gnus-audio-enter-group nil
-;; "Sound effect played when selecting a group.")
-;;(defvar gnus-audio-exit-group nil
-;; "Sound effect played when exiting a group.")
-;;(defvar gnus-audio-score-group nil
-;; "Sound effect played when scoring a group.")
-;;(defvar gnus-audio-busy-sound nil
-;; "Sound effect played when going into a ... sequence.")
-
-
-;;;###autoload
-;;(defun gnus-audio-enable-sound ()
-;; "Enable Sound Effects for Gnus."
-;; (interactive)
-;; (setq gnus-audio-effects-enabled t)
-;; (gnus-run-hooks gnus-audio-enable-hooks))
-
-;;;###autoload
- ;(defun gnus-audio-disable-sound ()
-;; "Disable Sound Effects for Gnus."
-;; (interactive)
-;; (setq gnus-audio-effects-enabled nil)
-;; (gnus-run-hooks gnus-audio-disable-hooks))
-
-;;;###autoload
-(defun gnus-audio-play (file)
- "Play a sound FILE through the speaker."
- (interactive "fSound file name: ")
- (let ((sound-file (if (file-exists-p file)
- file
- (expand-file-name file gnus-audio-directory))))
- (when (file-exists-p sound-file)
- (cond ((and gnus-audio-inline-sound
- (condition-case nil
- ;; Even if we have audio, we may fail with the
- ;; wrong sort of sound file.
- (progn (play-sound-file sound-file)
- t)
- (error nil))))
- ;; If we don't have built-in sound, or playing it failed,
- ;; try with external program.
- ((equal "wav" (file-name-extension sound-file))
- (call-process gnus-audio-wav-player
- sound-file
- 0
- nil
- sound-file))
- ((equal "au" (file-name-extension sound-file))
- (call-process gnus-audio-au-player
- sound-file
- 0
- nil
- sound-file))))))
-
-
-;;; The following isn't implemented yet, wait for Red Gnus
-;;(defun gnus-audio-startrek-sounds ()
-;; "Enable sounds from Star Trek the original series."
-;; (interactive)
-;; (setq gnus-audio-busy-sound "working.au")
-;; (setq gnus-audio-enter-group "bulkhead_door.au")
-;; (setq gnus-audio-exit-group "bulkhead_door.au")
-;; (setq gnus-audio-score-group "ST_laser.au")
-;; (setq gnus-audio-theme-song "startrek.au")
-;; (add-hook 'gnus-select-group-hook 'gnus-audio-startrek-select-group)
-;; (add-hook 'gnus-exit-group-hook 'gnus-audio-startrek-exit-group))
-;;;***
-
-(defvar gnus-startup-jingle "Tuxedomoon.Jingle4.au"
- "Name of the Gnus startup jingle file.")
-
-(defun gnus-play-jingle ()
- "Play the Gnus startup jingle, unless that's inhibited."
- (interactive)
- (gnus-audio-play gnus-startup-jingle))
-
-(provide 'gnus-audio)
-
-(run-hooks 'gnus-audio-load-hook)
-
-;; arch-tag: 6f129e78-3416-4fc9-973f-6cf5ac8d654b
-;;; gnus-audio.el ends here
diff --git a/lisp/gnus/gnus-bcklg.el b/lisp/gnus/gnus-bcklg.el
index f490d8a37d9..68233328802 100644
--- a/lisp/gnus/gnus-bcklg.el
+++ b/lisp/gnus/gnus-bcklg.el
@@ -40,8 +40,7 @@
(defun gnus-backlog-buffer ()
"Return the backlog buffer."
(or (get-buffer gnus-backlog-buffer)
- (save-excursion
- (set-buffer (gnus-get-buffer-create gnus-backlog-buffer))
+ (with-current-buffer (gnus-get-buffer-create gnus-backlog-buffer)
(buffer-disable-undo)
(setq buffer-read-only t)
(get-buffer gnus-backlog-buffer))))
@@ -76,8 +75,7 @@
(gnus-backlog-remove-oldest-article))
(push ident gnus-backlog-articles)
;; Insert the new article.
- (save-excursion
- (set-buffer (gnus-backlog-buffer))
+ (with-current-buffer (gnus-backlog-buffer)
(let (buffer-read-only)
(goto-char (point-max))
(unless (bolp)
@@ -90,8 +88,7 @@
(gnus-error 3 "Article %d is blank" number))))))))
(defun gnus-backlog-remove-oldest-article ()
- (save-excursion
- (set-buffer (gnus-backlog-buffer))
+ (with-current-buffer (gnus-backlog-buffer)
(goto-char (point-min))
(if (zerop (buffer-size))
() ; The buffer is empty.
@@ -114,8 +111,7 @@
beg end)
(when (memq ident gnus-backlog-articles)
;; It was in the backlog.
- (save-excursion
- (set-buffer (gnus-backlog-buffer))
+ (with-current-buffer (gnus-backlog-buffer)
(let (buffer-read-only)
(when (setq beg (text-property-any
(point-min) (point-max) 'gnus-backlog
@@ -138,8 +134,7 @@
beg end)
(when (memq ident gnus-backlog-articles)
;; It was in the backlog.
- (save-excursion
- (set-buffer (gnus-backlog-buffer))
+ (with-current-buffer (gnus-backlog-buffer)
(if (not (setq beg (text-property-any
(point-min) (point-max) 'gnus-backlog
ident)))
@@ -150,8 +145,7 @@
(setq end
(next-single-property-change
(1+ beg) 'gnus-backlog (current-buffer) (point-max)))))
- (save-excursion
- (and buffer (set-buffer buffer))
+ (with-current-buffer (or (current-buffer) buffer)
(let ((buffer-read-only nil))
(erase-buffer)
(insert-buffer-substring gnus-backlog-buffer beg end)))
@@ -159,5 +153,4 @@
(provide 'gnus-bcklg)
-;; arch-tag: 66259e56-505a-4bba-8a0d-3552c5b94e39
;;; gnus-bcklg.el ends here
diff --git a/lisp/gnus/gnus-bookmark.el b/lisp/gnus/gnus-bookmark.el
index a85c1af44bb..1fcbf352f14 100644
--- a/lisp/gnus/gnus-bookmark.el
+++ b/lisp/gnus/gnus-bookmark.el
@@ -1,6 +1,7 @@
;;; gnus-bookmark.el --- Bookmarks in Gnus
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Bastien Guerry <bzg AT altern DOT org>
;; Keywords: news
@@ -156,9 +157,6 @@ The default value is \(author subject date group annotation\)."
"The current version of the format used by bookmark files.
You should never need to change this.")
-(defvar gnus-bookmark-after-jump-hook nil
- "Hook run after `gnus-bookmark-jump' jumps to a Gnus bookmark.")
-
(defvar gnus-bookmark-alist ()
"Association list of Gnus bookmarks and their records.
The format of the alist is
@@ -292,8 +290,8 @@ So the cdr of each bookmark is an alist too.")
(interactive)
(gnus-bookmark-maybe-load-default-file)
(let* ((bookmark (or bmk-name
- (completing-read "Jump to bookmarked article: "
- gnus-bookmark-alist)))
+ (gnus-completing-read "Jump to bookmarked article"
+ (mapcar 'car gnus-bookmark-alist))))
(bmk-record (cadr (assoc bookmark gnus-bookmark-alist)))
(group (cdr (assoc 'group bmk-record)))
(message-id (cdr (assoc 'message-id bmk-record))))
@@ -541,7 +539,7 @@ Optional argument SHOW means show them unconditionally."
(let ((bmrk (gnus-bookmark-bmenu-bookmark)))
(setq gnus-bookmark-bmenu-hidden-bookmarks
(cons bmrk gnus-bookmark-bmenu-hidden-bookmarks))
- (let ((start (save-excursion (end-of-line) (point))))
+ (let ((start (point-at-eol)))
(move-to-column gnus-bookmark-bmenu-file-column t)
;; Strip off `mouse-face' from the white spaces region.
(if (gnus-bookmark-mouse-available-p)
@@ -575,10 +573,9 @@ Optional argument SHOW means show them unconditionally."
"Kill from point to end of line.
If optional arg NEWLINE-TOO is non-nil, delete the newline too.
Does not affect the kill ring."
- (let ((eol (save-excursion (end-of-line) (point))))
- (delete-region (point) eol)
- (if (and newline-too (looking-at "\n"))
- (delete-char 1))))
+ (delete-region (point) (point-at-eol))
+ (if (and newline-too (looking-at "\n"))
+ (delete-char 1)))
(defun gnus-bookmark-get-details (bmk-name details-list)
"Get details for a Gnus BMK-NAME depending on DETAILS-LIST."
@@ -828,5 +825,4 @@ probably because we were called from there."
(provide 'gnus-bookmark)
-;; arch-tag: 779df694-366f-46e8-84b2-1d0340e6f525
;;; gnus-bookmark.el ends here
diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el
index 113233c1d32..50ab1c64a23 100644
--- a/lisp/gnus/gnus-cache.el
+++ b/lisp/gnus/gnus-cache.el
@@ -25,7 +25,7 @@
;;; Code:
-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
@@ -180,8 +180,7 @@ it's not cached."
;; Save the article in the cache.
(if (file-exists-p file)
t ; The article already is saved.
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(require 'gnus-art)
(let ((gnus-use-cache nil)
(gnus-article-decode-hook nil))
@@ -384,9 +383,14 @@ Returns the list of articles removed."
"Insert all the articles cached for this group into the current buffer."
(interactive)
(let ((gnus-verbose (max 6 gnus-verbose)))
- (if (not gnus-newsgroup-cached)
- (gnus-message 3 "No cached articles for this group")
- (gnus-summary-goto-subjects gnus-newsgroup-cached))))
+ (cond
+ ((not gnus-newsgroup-cached)
+ (gnus-message 3 "No cached articles for this group"))
+ ;; This is faster if there are few articles to insert.
+ ((< (length gnus-newsgroup-cached) 20)
+ (gnus-summary-goto-subjects gnus-newsgroup-cached))
+ (t
+ (gnus-summary-include-articles gnus-newsgroup-cached)))))
(defun gnus-summary-limit-include-cached ()
"Limit the summary buffer to articles that are cached."
@@ -554,8 +558,7 @@ system for example was used.")
(let ((cache-buf (gnus-get-buffer-create " *gnus-cache*"))
beg end)
(gnus-cache-save-buffers)
- (save-excursion
- (set-buffer cache-buf)
+ (with-current-buffer cache-buf
(erase-buffer)
(let ((coding-system-for-read gnus-cache-overview-coding-system)
(file-name-coding-system nnmail-pathname-coding-system))
@@ -605,7 +608,7 @@ system for example was used.")
(insert-file-contents (gnus-cache-file-name group entry)))
(goto-char (point-min))
(insert "220 ")
- (princ (car cached) (current-buffer))
+ (princ (pop cached) (current-buffer))
(insert " Article retrieved.\n")
(search-forward "\n\n" nil 'move)
(delete-region (point) (point-max))
@@ -844,8 +847,7 @@ supported."
,@body)
(when (and gnus-cache-need-update-total-fetched-for
(not gnus-cache-inhibit-update-total-fetched-for))
- (save-excursion
- (set-buffer gnus-group-buffer)
+ (with-current-buffer gnus-group-buffer
(setq gnus-cache-need-update-total-fetched-for nil)
(gnus-group-update-group ,group t)))))
@@ -868,7 +870,7 @@ supported."
(while (setq file (pop files))
(setq attrs (file-attributes file))
(unless (nth 0 attrs)
- (incf size (float (nth 7 attrs)))))))
+ (incf size (float (nth 7 attrs)))))))
(setq gnus-cache-need-update-total-fetched-for t)
@@ -879,10 +881,10 @@ supported."
(gnus-cache-with-refreshed-group
group
(let* ((entry (or (gnus-gethash group gnus-cache-total-fetched-hashtb)
- (gnus-sethash group (make-list 2 0)
+ (gnus-sethash group (make-list 2 0)
gnus-cache-total-fetched-hashtb)))
(file-name-coding-system nnmail-pathname-coding-system)
- (size (or (nth 7 (file-attributes
+ (size (or (nth 7 (file-attributes
(or file
(gnus-cache-file-name group ".overview"))))
0)))
@@ -911,11 +913,10 @@ supported."
(if entry
(apply '+ entry)
(let ((gnus-cache-inhibit-update-total-fetched-for (not no-inhibit)))
- (+
+ (+
(gnus-cache-update-overview-total-fetched-for group nil)
(gnus-cache-update-file-total-fetched-for group nil)))))))
(provide 'gnus-cache)
-;; arch-tag: 05a79442-8c58-4e65-bd0a-3cbb1b89a33a
;;; gnus-cache.el ends here
diff --git a/lisp/gnus/gnus-cite.el b/lisp/gnus/gnus-cite.el
index adec9cfd725..aa719076e36 100644
--- a/lisp/gnus/gnus-cite.el
+++ b/lisp/gnus/gnus-cite.el
@@ -407,9 +407,7 @@ lines matches `message-cite-prefix-regexp' with the same prefix.
Lines matching `gnus-cite-attribution-suffix' and perhaps
`gnus-cite-attribution-prefix' are considered attribution lines."
(interactive (list 'force))
- (save-excursion
- (unless same-buffer
- (set-buffer gnus-article-buffer))
+ (with-current-buffer (if same-buffer (current-buffer) gnus-article-buffer)
(gnus-cite-parse-maybe force)
(let ((buffer-read-only nil)
(alist gnus-cite-prefix-alist)
@@ -462,8 +460,7 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps
(defun gnus-dissect-cited-text ()
"Dissect the article buffer looking for cited text."
- (save-excursion
- (set-buffer gnus-article-buffer)
+ (with-current-buffer gnus-article-buffer
(gnus-cite-parse-maybe nil t)
(let ((alist gnus-cite-prefix-alist)
prefix numbers number marks m)
@@ -519,12 +516,16 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps
(setq m (cdr m))))
marks))))
-(defun gnus-article-fill-cited-article (&optional force width)
+(defun gnus-article-fill-cited-long-lines ()
+ (gnus-article-fill-cited-article nil t))
+
+(defun gnus-article-fill-cited-article (&optional width long-lines)
"Do word wrapping in the current article.
-If WIDTH (the numerical prefix), use that text width when filling."
- (interactive (list t current-prefix-arg))
- (save-excursion
- (set-buffer gnus-article-buffer)
+If WIDTH (the numerical prefix), use that text width when
+filling. If LONG-LINES, only fill sections that have lines
+longer than the frame width."
+ (interactive "P")
+ (with-current-buffer gnus-article-buffer
(let ((buffer-read-only nil)
(inhibit-point-motion-hooks t)
(marks (gnus-dissect-cited-text))
@@ -539,8 +540,24 @@ If WIDTH (the numerical prefix), use that text width when filling."
(fill-prefix
(if (string= (cdar marks) "") ""
(concat (cdar marks) " ")))
+ (do-fill (not long-lines))
use-hard-newlines)
- (fill-region (point-min) (point-max)))
+ (unless do-fill
+ (setq do-fill (gnus-article-foldable-buffer (cdar marks))))
+ ;; Note: the XEmacs version of `fill-region' inserts a newline
+ ;; unless the region ends with a newline.
+ (when do-fill
+ (if (not long-lines)
+ (fill-region (point-min) (point-max))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (end-of-line)
+ (when (prog1
+ (> (current-column) (window-width))
+ (forward-line 1))
+ (save-restriction
+ (narrow-to-region (line-beginning-position 0) (point))
+ (fill-region (point-min) (point-max))))))))
(set-marker (caar marks) nil)
(setq marks (cdr marks)))
(when marks
@@ -552,6 +569,29 @@ If WIDTH (the numerical prefix), use that text width when filling."
gnus-cite-loose-attribution-alist nil
gnus-cite-article nil)))))
+(defun gnus-article-foldable-buffer (prefix)
+ (let ((do-fill nil)
+ columns)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (unless (> (length prefix) (- (point-max) (point)))
+ (forward-char (length prefix)))
+ (skip-chars-forward " \t")
+ (unless (eolp)
+ (let ((elem (assq (current-column) columns)))
+ (unless elem
+ (setq elem (cons (current-column) 0))
+ (push elem columns))
+ (setcdr elem (1+ (cdr elem)))))
+ (end-of-line)
+ (when (> (current-column) (window-width))
+ (setq do-fill t))
+ (forward-line 1))
+ (and do-fill
+ ;; We know know that there are long lines here, but does this look
+ ;; like code? Check for ragged edges on the left.
+ (< (length columns) 3))))
+
(defun gnus-article-hide-citation (&optional arg force)
"Toggle hiding of all cited text except attribution lines.
See the documentation for `gnus-article-highlight-citation'.
@@ -560,67 +600,66 @@ always hide."
(interactive (append (gnus-article-hidden-arg) (list 'force)))
(gnus-set-format 'cited-opened-text-button t)
(gnus-set-format 'cited-closed-text-button t)
- (save-excursion
- (set-buffer gnus-article-buffer)
- (let ((buffer-read-only nil)
- marks
- (inhibit-point-motion-hooks t)
- (props (nconc (list 'article-type 'cite)
- gnus-hidden-properties))
- (point (point-min))
- found beg end start)
- (while (setq point
- (text-property-any point (point-max)
- 'gnus-callback
- 'gnus-article-toggle-cited-text))
- (setq found t)
- (goto-char point)
- (gnus-article-toggle-cited-text
- (get-text-property point 'gnus-data) arg)
- (forward-line 1)
- (setq point (point)))
- (unless found
- (setq marks (gnus-dissect-cited-text))
- (while marks
- (setq beg nil
- end nil)
- (while (and marks (string= (cdar marks) ""))
- (setq marks (cdr marks)))
- (when marks
- (setq beg (caar marks)))
- (while (and marks (not (string= (cdar marks) "")))
- (setq marks (cdr marks)))
- (when marks
+ (with-current-buffer gnus-article-buffer
+ (let ((buffer-read-only nil)
+ marks
+ (inhibit-point-motion-hooks t)
+ (props (nconc (list 'article-type 'cite)
+ gnus-hidden-properties))
+ (point (point-min))
+ found beg end start)
+ (while (setq point
+ (text-property-any point (point-max)
+ 'gnus-callback
+ 'gnus-article-toggle-cited-text))
+ (setq found t)
+ (goto-char point)
+ (gnus-article-toggle-cited-text
+ (get-text-property point 'gnus-data) arg)
+ (forward-line 1)
+ (setq point (point)))
+ (unless found
+ (setq marks (gnus-dissect-cited-text))
+ (while marks
+ (setq beg nil
+ end nil)
+ (while (and marks (string= (cdar marks) ""))
+ (setq marks (cdr marks)))
+ (when marks
+ (setq beg (caar marks)))
+ (while (and marks (not (string= (cdar marks) "")))
+ (setq marks (cdr marks)))
+ (when marks
(setq end (caar marks)))
- ;; Skip past lines we want to leave visible.
- (when (and beg end gnus-cited-lines-visible)
- (goto-char beg)
- (forward-line (if (consp gnus-cited-lines-visible)
- (car gnus-cited-lines-visible)
- gnus-cited-lines-visible))
- (if (>= (point) end)
- (setq beg nil)
- (setq beg (point-marker))
- (when (consp gnus-cited-lines-visible)
- (goto-char end)
- (forward-line (- (cdr gnus-cited-lines-visible)))
- (if (<= (point) beg)
- (setq beg nil)
+ ;; Skip past lines we want to leave visible.
+ (when (and beg end gnus-cited-lines-visible)
+ (goto-char beg)
+ (forward-line (if (consp gnus-cited-lines-visible)
+ (car gnus-cited-lines-visible)
+ gnus-cited-lines-visible))
+ (if (>= (point) end)
+ (setq beg nil)
+ (setq beg (point-marker))
+ (when (consp gnus-cited-lines-visible)
+ (goto-char end)
+ (forward-line (- (cdr gnus-cited-lines-visible)))
+ (if (<= (point) beg)
+ (setq beg nil)
(setq end (point-marker))))))
- (when (and beg end)
- (gnus-add-wash-type 'cite)
- ;; We use markers for the end-points to facilitate later
- ;; wrapping and mangling of text.
- (setq beg (set-marker (make-marker) beg)
- end (set-marker (make-marker) end))
- (gnus-add-text-properties-when 'article-type nil beg end props)
- (goto-char beg)
- (when (and gnus-cite-blank-line-after-header
- (not (save-excursion (search-backward "\n\n" nil t))))
- (insert "\n"))
- (put-text-property
- (setq start (point-marker))
- (progn
+ (when (and beg end)
+ (gnus-add-wash-type 'cite)
+ ;; We use markers for the end-points to facilitate later
+ ;; wrapping and mangling of text.
+ (setq beg (set-marker (make-marker) beg)
+ end (set-marker (make-marker) end))
+ (gnus-add-text-properties-when 'article-type nil beg end props)
+ (goto-char beg)
+ (when (and gnus-cite-blank-line-after-header
+ (not (save-excursion (search-backward "\n\n" nil t))))
+ (insert "\n"))
+ (put-text-property
+ (setq start (point-marker))
+ (progn
(gnus-article-add-button
(point)
(progn (eval gnus-cited-closed-text-button-line-format-spec)
@@ -628,8 +667,8 @@ always hide."
`gnus-article-toggle-cited-text
(list (cons beg end) start))
(point))
- 'article-type 'annotation)
- (set-marker beg (point))))))))
+ 'article-type 'annotation)
+ (set-marker beg (point))))))))
(defun gnus-article-toggle-cited-text (args &optional arg)
"Toggle hiding the text in REGION.
@@ -732,11 +771,9 @@ See also the documentation for `gnus-article-highlight-citation'."
(defun gnus-article-hide-citation-in-followups ()
"Hide cited text in non-root articles."
(interactive)
- (save-excursion
- (set-buffer gnus-article-buffer)
+ (with-current-buffer gnus-article-buffer
(let ((article (cdr gnus-article-current)))
- (unless (save-excursion
- (set-buffer gnus-summary-buffer)
+ (unless (with-current-buffer gnus-summary-buffer
(gnus-article-displayed-root-p article))
(gnus-article-hide-citation)))))
@@ -1079,8 +1116,7 @@ See also the documentation for `gnus-article-highlight-citation'."
(gnus-overlay-put overlay 'face face))))))
(defun gnus-cite-toggle (prefix)
- (save-excursion
- (set-buffer gnus-article-buffer)
+ (with-current-buffer gnus-article-buffer
(gnus-cite-parse-maybe nil t)
(let ((buffer-read-only nil)
(numbers (cdr (assoc prefix gnus-cite-prefix-alist)))
@@ -1248,5 +1284,4 @@ is turned on."
;; coding: iso-8859-1
;; End:
-;; arch-tag: 1997b044-6067-471e-8c8f-dc903093098a
;;; gnus-cite.el ends here
diff --git a/lisp/gnus/gnus-cus.el b/lisp/gnus/gnus-cus.el
index eb0dc51936a..6da91bdc266 100644
--- a/lisp/gnus/gnus-cus.el
+++ b/lisp/gnus/gnus-cus.el
@@ -50,7 +50,7 @@ if that value is non-nil."
(setq major-mode 'gnus-custom-mode
mode-name "Gnus Customize")
(use-local-map widget-keymap)
- ;; Emacs 21 stuff:
+ ;; Emacs stuff:
(when (and (facep 'custom-button-face)
(facep 'custom-button-pressed-face))
(set (make-local-variable 'widget-button-face)
@@ -865,11 +865,6 @@ This can be changed using the `\\[gnus-score-change-score-file]' command."
Check the [ ] for the entries you want to apply to this score file, then
edit the value to suit your taste. Don't forget to mark the checkbox,
if you do all your changes will be lost. ")
- (widget-create 'push-button
- :action (lambda (&rest ignore)
- (require 'gnus-audio)
- (gnus-audio-play "Evil_Laugh.au"))
- "Bhahahah!")
(widget-insert "\n\n")
(make-local-variable 'gnus-custom-scores)
(setq gnus-custom-scores
@@ -1118,5 +1113,4 @@ articles in the thread.
(provide 'gnus-cus)
-;; arch-tag: a37c285a-49bc-4235-8244-804536effeaf
;;; gnus-cus.el ends here
diff --git a/lisp/gnus/gnus-delay.el b/lisp/gnus/gnus-delay.el
index e9d1a131068..a257e5495a7 100644
--- a/lisp/gnus/gnus-delay.el
+++ b/lisp/gnus/gnus-delay.el
@@ -133,8 +133,7 @@ DELAY is a string, giving the length of the time. Possible values are:
(message-add-header (format "%s: %s" gnus-delay-header deadline)))
(set-buffer-modified-p t)
;; If group does not exist, create it.
- (let ((group (format "nndraft:%s" gnus-delay-group)))
- (gnus-agent-queue-setup gnus-delay-group))
+ (gnus-agent-queue-setup gnus-delay-group)
(message-disassociate-draft)
(nndraft-request-associate-buffer gnus-delay-group)
(save-buffer 0)
@@ -192,5 +191,4 @@ Checking delayed messages is skipped if optional arg NO-CHECK is non-nil."
;; coding: iso-8859-1
;; End:
-;; arch-tag: fb2ad634-a897-4142-a503-f5991ec2349d
;;; gnus-delay.el ends here
diff --git a/lisp/gnus/gnus-demon.el b/lisp/gnus/gnus-demon.el
index 74aebf73b1d..94a49525847 100644
--- a/lisp/gnus/gnus-demon.el
+++ b/lisp/gnus/gnus-demon.el
@@ -32,9 +32,6 @@
(require 'nnheader)
(require 'nntp)
(require 'nnmail)
-(require 'gnus-util)
-
-(autoload 'parse-time-string "parse-time" nil nil)
(defgroup gnus-demon nil
"Demonic behavior."
@@ -46,14 +43,16 @@ Each handler is a list on the form
\(FUNCTION TIME IDLE)
-FUNCTION is the function to be called.
-TIME is the number of `gnus-demon-timestep's between each call.
-If nil, never call. If t, call each `gnus-demon-timestep'.
-If IDLE is t, only call if Emacs has been idle for a while. If IDLE
-is a number, only call when Emacs has been idle more than this number
-of `gnus-demon-timestep's. If IDLE is nil, don't care about
-idleness. If IDLE is a number and TIME is nil, then call once each
-time Emacs has been idle for IDLE `gnus-demon-timestep's."
+FUNCTION is the function to be called. TIME is the number of
+`gnus-demon-timestep's between each call.
+If nil, never call. If t, call each `gnus-demon-timestep'.
+
+If IDLE is t, only call each time Emacs has been idle for TIME.
+If IDLE is a number, only call when Emacs has been idle more than
+this number of `gnus-demon-timestep's.
+If IDLE is nil, don't care about idleness.
+If IDLE is a number and TIME is nil, then call once each time
+Emacs has been idle for IDLE `gnus-demon-timestep's."
:group 'gnus-demon
:type '(repeat (list function
(choice :tag "Time"
@@ -66,19 +65,16 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's."
(integer :tag "steps" 1)))))
(defcustom gnus-demon-timestep 60
- "*Number of seconds in each demon timestep."
+ "Number of seconds in each demon timestep."
:group 'gnus-demon
:type 'integer)
;;; Internal variables.
-(defvar gnus-demon-timer nil)
-(defvar gnus-demon-idle-has-been-called nil)
-(defvar gnus-demon-idle-time 0)
-(defvar gnus-demon-handler-state nil)
-(defvar gnus-demon-last-keys nil)
+(defvar gnus-demon-timers nil
+ "List of idle timers which are running.")
(defvar gnus-inhibit-demon nil
- "*If non-nil, no daemonic function will be run.")
+ "If non-nil, no daemonic function will be run.")
;;; Functions.
@@ -92,162 +88,71 @@ time Emacs has been idle for IDLE `gnus-demon-timestep's."
(defun gnus-demon-remove-handler (function &optional no-init)
"Remove the handler FUNCTION from the list of handlers."
- (gnus-pull function gnus-demon-handlers)
+ (gnus-alist-pull function gnus-demon-handlers)
(unless no-init
(gnus-demon-init)))
+(defun gnus-demon-idle-since ()
+ "Return the number of seconds since when Emacs is idle."
+ (if (featurep 'xemacs)
+ (itimer-time-difference (current-time) last-command-event-time)
+ (float-time (or (current-idle-time)
+ '(0 0 0)))))
+
+(defun gnus-demon-run-callback (func &optional idle)
+ "Run FUNC if Emacs has been idle for longer than IDLE seconds."
+ (unless gnus-inhibit-demon
+ (when (or (not idle)
+ (<= idle (gnus-demon-idle-since)))
+ (with-local-quit
+ (ignore-errors
+ (funcall func))))))
+
(defun gnus-demon-init ()
"Initialize the Gnus daemon."
(interactive)
(gnus-demon-cancel)
- (when gnus-demon-handlers
+ (dolist (handler gnus-demon-handlers)
;; Set up the timer.
- (setq gnus-demon-timer
- (run-at-time
- gnus-demon-timestep gnus-demon-timestep 'gnus-demon))
- ;; Reset control variables.
- (setq gnus-demon-handler-state
- (mapcar
- (lambda (handler)
- (list (car handler) (gnus-demon-time-to-step (nth 1 handler))
- (nth 2 handler)))
- gnus-demon-handlers))
- (setq gnus-demon-idle-time 0)
- (setq gnus-demon-idle-has-been-called nil)))
+ (let* ((func (nth 0 handler))
+ (time (nth 1 handler))
+ (idle (nth 2 handler))
+ ;; Compute time according with timestep.
+ ;; If t, replace by 1
+ (time (cond ((eq time t)
+ gnus-demon-timestep)
+ ((null time))
+ (t (* time gnus-demon-timestep))))
+ (timer
+ (cond
+ ;; (func number t)
+ ;; Call when Emacs has been idle for `time'
+ ((and (numberp time) (eq idle t))
+ (run-with-timer t time 'gnus-demon-run-callback func time))
+ ;; (func number number)
+ ;; Call every `time' when Emacs has been idle for `idle'
+ ((and (numberp time) (numberp idle))
+ (run-with-timer t time 'gnus-demon-run-callback func idle))
+ ;; (func nil number)
+ ;; Only call when Emacs has been idle for `idle'
+ ((and (null time) (numberp idle))
+ (run-with-idle-timer (* idle gnus-demon-timestep) t
+ 'gnus-demon-run-callback func))
+ ;; (func number nil)
+ ;; Call every `time'
+ ((and (numberp time) (null idle))
+ (run-with-timer t time 'gnus-demon-run-callback func)))))
+ (when timer
+ (add-to-list 'gnus-demon-timers timer)))))
(gnus-add-shutdown 'gnus-demon-cancel 'gnus)
(defun gnus-demon-cancel ()
"Cancel any Gnus daemons."
(interactive)
- (when gnus-demon-timer
- (nnheader-cancel-timer gnus-demon-timer))
- (setq gnus-demon-timer nil
- gnus-demon-idle-has-been-called nil)
- (condition-case ()
- (nnheader-cancel-function-timers 'gnus-demon)
- (error t)))
-
-(defun gnus-demon-is-idle-p ()
- "Whether Emacs is idle or not."
- ;; We do this simply by comparing the 100 most recent keystrokes
- ;; with the ones we had last time. If they are the same, one might
- ;; guess that Emacs is indeed idle. This only makes sense if one
- ;; calls this function seldom -- like once a minute, which is what
- ;; we do here.
- (let ((keys (recent-keys)))
- (or (equal keys gnus-demon-last-keys)
- (progn
- (setq gnus-demon-last-keys keys)
- nil))))
-
-(defun gnus-demon-time-to-step (time)
- "Find out how many seconds to TIME, which is on the form \"17:43\"."
- (if (not (stringp time))
- time
- (let* ((now (current-time))
- ;; obtain NOW as discrete components -- make a vector for speed
- (nowParts (decode-time now))
- ;; obtain THEN as discrete components
- (thenParts (parse-time-string time))
- (thenHour (elt thenParts 2))
- (thenMin (elt thenParts 1))
- ;; convert time as elements into number of seconds since EPOCH.
- (then (encode-time 0
- thenMin
- thenHour
- ;; If THEN is earlier than NOW, make it
- ;; same time tomorrow. Doc for encode-time
- ;; says that this is OK.
- (+ (elt nowParts 3)
- (if (or (< thenHour (elt nowParts 2))
- (and (= thenHour (elt nowParts 2))
- (<= thenMin (elt nowParts 1))))
- 1 0))
- (elt nowParts 4)
- (elt nowParts 5)
- (elt nowParts 6)
- (elt nowParts 7)
- (elt nowParts 8)))
- ;; calculate number of seconds between NOW and THEN
- (diff (+ (* 65536 (- (car then) (car now)))
- (- (cadr then) (cadr now)))))
- ;; return number of timesteps in the number of seconds
- (round (/ diff gnus-demon-timestep)))))
-
-(defun gnus-demon ()
- "The Gnus daemon that takes care of running all Gnus handlers."
- ;; Increase or reset the time Emacs has been idle.
- (if (gnus-demon-is-idle-p)
- (incf gnus-demon-idle-time)
- (setq gnus-demon-idle-time 0)
- (setq gnus-demon-idle-has-been-called nil))
- ;; Disable all daemonic stuff if we're in the minibuffer
- (when (and (not (window-minibuffer-p (selected-window)))
- (not gnus-inhibit-demon))
- ;; Then we go through all the handler and call those that are
- ;; sufficiently ripe.
- (let ((handlers gnus-demon-handler-state)
- (gnus-inhibit-demon t)
- ;; Try to avoid dialog boxes, e.g. by Mailcrypt.
- ;; Unfortunately, Emacs 20's `message-or-box...' doesn't
- ;; obey `use-dialog-box'.
- use-dialog-box (last-nonmenu-event 10)
- handler time idle)
- (while handlers
- (setq handler (pop handlers))
- (cond
- ((numberp (setq time (nth 1 handler)))
- ;; These handlers use a regular timeout mechanism. We decrease
- ;; the timer if it hasn't reached zero yet.
- (unless (zerop time)
- (setcar (nthcdr 1 handler) (decf time)))
- (and (zerop time) ; If the timer now is zero...
- ;; Test for appropriate idleness
- (progn
- (setq idle (nth 2 handler))
- (cond
- ((null idle) t) ; Don't care about idle.
- ((numberp idle) ; Numerical idle...
- (< idle gnus-demon-idle-time)) ; Idle timed out.
- (t (< 0 gnus-demon-idle-time)))) ; Or just need to be idle.
- ;; So we call the handler.
- (gnus-with-local-quit
- (ignore-errors (funcall (car handler)))
- ;; And reset the timer.
- (setcar (nthcdr 1 handler)
- (gnus-demon-time-to-step
- (nth 1 (assq (car handler) gnus-demon-handlers)))))))
- ;; These are only supposed to be called when Emacs is idle.
- ((null (setq idle (nth 2 handler)))
- ;; We do nothing.
- )
- ((and (not (numberp idle))
- (gnus-demon-is-idle-p))
- ;; We want to call this handler each and every time that
- ;; Emacs is idle.
- (gnus-with-local-quit
- (ignore-errors (funcall (car handler)))))
- (t
- ;; We want to call this handler only if Emacs has been idle
- ;; for a specified number of timesteps.
- (and (not (memq (car handler) gnus-demon-idle-has-been-called))
- (< idle gnus-demon-idle-time)
- (gnus-demon-is-idle-p)
- (gnus-with-local-quit
- (ignore-errors (funcall (car handler)))
- ;; Make sure the handler won't be called once more in
- ;; this idle-cycle.
- (push (car handler) gnus-demon-idle-has-been-called)))))))))
-
-(defun gnus-demon-add-nocem ()
- "Add daemonic NoCeM handling to Gnus."
- (gnus-demon-add-handler 'gnus-demon-scan-nocem 60 30))
-
-(defun gnus-demon-scan-nocem ()
- "Scan NoCeM groups for NoCeM messages."
- (save-window-excursion
- (gnus-nocem-scan-groups)))
+ (dolist (timer gnus-demon-timers)
+ (nnheader-cancel-timer timer))
+ (setq gnus-demon-timers nil))
(defun gnus-demon-add-disconnection ()
"Add daemonic server disconnection to Gnus."
@@ -291,11 +196,9 @@ minutes, the connection is closed."
(let ((win (current-window-configuration)))
(unwind-protect
(save-window-excursion
- (save-excursion
- (when (gnus-alive-p)
- (save-excursion
- (set-buffer gnus-group-buffer)
- (gnus-group-get-new-news)))))
+ (when (gnus-alive-p)
+ (with-current-buffer gnus-group-buffer
+ (gnus-group-get-new-news))))
(set-window-configuration win))))
(defun gnus-demon-add-scan-timestamps ()
@@ -319,5 +222,4 @@ minutes, the connection is closed."
(provide 'gnus-demon)
-;; arch-tag: 8dd5cd3d-6ae4-46b4-9b15-f5fca09fd392
;;; gnus-demon.el ends here
diff --git a/lisp/gnus/gnus-diary.el b/lisp/gnus/gnus-diary.el
index 8bd4cfde3f6..c2b95c7099b 100644
--- a/lisp/gnus/gnus-diary.el
+++ b/lisp/gnus/gnus-diary.el
@@ -368,11 +368,11 @@ If ARG (or prefix) is non-nil, force prompting for all fields."
header ": ")))
(setq value
(if (listp (nth 1 head))
- (completing-read prompt (cons '("*" nil) (nth 1 head))
- nil t value
- gnus-diary-header-value-history)
+ (gnus-completing-read prompt (cons "*" (mapcar 'car (nth 1 head)))
+ t value
+ 'gnus-diary-header-value-history)
(read-string prompt value
- gnus-diary-header-value-history))))
+ 'gnus-diary-header-value-history))))
(setq ask nil)
(setq invalid nil)
(condition-case ()
@@ -401,5 +401,4 @@ If ARG (or prefix) is non-nil, force prompting for all fields."
(provide 'gnus-diary)
-;; arch-tag: 98467e70-337e-4ddc-b92d-45d403ff1b4b
;;; gnus-diary.el ends here
diff --git a/lisp/gnus/gnus-dired.el b/lisp/gnus/gnus-dired.el
index 595a9fe4ffd..8b6d3911e11 100644
--- a/lisp/gnus/gnus-dired.el
+++ b/lisp/gnus/gnus-dired.el
@@ -1,7 +1,7 @@
;;; gnus-dired.el --- utility functions where gnus and dired meet
-;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2002, 2003, 2004, 2005,
+;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Authors: Benjamin Rutt <brutt@bloomington.in.us>,
;; Shenghuo Zhu <zsh@cs.rochester.edu>
@@ -39,6 +39,9 @@
;;; Code:
+(eval-when-compile
+ (when (featurep 'xemacs)
+ (require 'easy-mmode))) ; for `define-minor-mode'
(require 'dired)
(autoload 'mml-attach-file "mml")
(autoload 'mm-default-file-encoding "mm-decode");; Shift this to `mailcap.el'?
@@ -55,17 +58,12 @@
(autoload 'message-buffers "message")
(autoload 'gnus-print-buffer "gnus-sum")
-(defvar gnus-dired-mode nil
- "Minor mode for intersections of MIME mail composition and dired.")
-
-(defvar gnus-dired-mode-map nil)
-
-(unless gnus-dired-mode-map
- (setq gnus-dired-mode-map (make-sparse-keymap))
-
- (define-key gnus-dired-mode-map "\C-c\C-m\C-a" 'gnus-dired-attach)
- (define-key gnus-dired-mode-map "\C-c\C-m\C-l" 'gnus-dired-find-file-mailcap)
- (define-key gnus-dired-mode-map "\C-c\C-m\C-p" 'gnus-dired-print))
+(defvar gnus-dired-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\C-c\C-m\C-a" 'gnus-dired-attach)
+ (define-key map "\C-c\C-m\C-l" 'gnus-dired-find-file-mailcap)
+ (define-key map "\C-c\C-m\C-p" 'gnus-dired-print)
+ map))
;; FIXME: Make it customizable, change the default to `mail-user-agent' when
;; this file is renamed (e.g. to `dired-mime.el').
@@ -89,19 +87,19 @@ See `mail-user-agent' for more information."
gnus-user-agent)
(function :tag "Other")))
-(defun gnus-dired-mode (&optional arg)
+(eval-when-compile
+ (when (featurep 'xemacs)
+ (defvar gnus-dired-mode-hook)
+ (defvar gnus-dired-mode-on-hook)
+ (defvar gnus-dired-mode-off-hook)))
+
+(define-minor-mode gnus-dired-mode
"Minor mode for intersections of gnus and dired.
\\{gnus-dired-mode-map}"
- (interactive "P")
- (when (eq major-mode 'dired-mode)
- (set (make-local-variable 'gnus-dired-mode)
- (if (null arg) (not gnus-dired-mode)
- (> (prefix-numeric-value arg) 0)))
- (when gnus-dired-mode
- (add-minor-mode 'gnus-dired-mode "" gnus-dired-mode-map)
- (save-current-buffer
- (run-hooks 'gnus-dired-mode-hook)))))
+ :keymap gnus-dired-mode-map
+ (unless (derived-mode-p 'dired-mode)
+ (setq gnus-dired-mode nil)))
;;;###autoload
(defun turn-on-gnus-dired-mode ()
@@ -124,6 +122,8 @@ See `mail-user-agent' for more information."
(push (buffer-name buffer) buffers))))
(nreverse buffers))))
+(autoload 'gnus-completing-read "gnus-util")
+
;; Method to attach files to a mail composition.
(defun gnus-dired-attach (files-to-attach)
"Attach dired's marked files to a gnus message composition.
@@ -135,7 +135,9 @@ filenames."
(mapcar
;; don't attach directories
(lambda (f) (if (file-directory-p f) nil f))
- (nreverse (dired-map-over-marks (dired-get-filename) nil))))))
+ (nreverse
+ (let ((arg nil)) ;; Silence XEmacs 21.5 when compiling.
+ (dired-map-over-marks (dired-get-filename) arg)))))))
(let ((destination nil)
(files-str nil)
(bufs nil))
@@ -154,12 +156,8 @@ filenames."
(setq destination
(if (= (length bufs) 1)
(get-buffer (car bufs))
- (completing-read "Attach to which mail composition buffer: "
- (mapcar
- (lambda (b)
- (cons b (get-buffer b)))
- bufs)
- nil t)))
+ (gnus-completing-read "Attach to which mail composition buffer"
+ bufs t)))
;; setup a new mail composition buffer
(let ((mail-user-agent gnus-dired-mail-mode)
;; A workaround to prevent Gnus from displaying the Gnus
@@ -206,7 +204,7 @@ If ARG is non-nil, open it in a new buffer."
(setq method
(cdr (assoc 'viewer
(car (mailcap-mime-info mime-type
- 'all
+ 'all
'no-decode)))))))
(let ((view-command (mm-mailcap-command method file-name nil)))
(message "viewing via %s" view-command)
@@ -263,5 +261,4 @@ file to save in."
(provide 'gnus-dired)
-;; arch-tag: 44737731-e445-4638-a31e-713c7590ec76
;;; gnus-dired.el ends here
diff --git a/lisp/gnus/gnus-draft.el b/lisp/gnus/gnus-draft.el
index 1e6b7ee5dee..e397a701da8 100644
--- a/lisp/gnus/gnus-draft.el
+++ b/lisp/gnus/gnus-draft.el
@@ -32,23 +32,21 @@
(require 'nndraft)
(require 'gnus-agent)
(eval-when-compile (require 'cl))
+(eval-when-compile
+ (when (featurep 'xemacs)
+ (require 'easy-mmode))) ; for `define-minor-mode'
;;; Draft minor mode
-(defvar gnus-draft-mode nil
- "Minor mode for providing a draft summary buffers.")
-
-(defvar gnus-draft-mode-map nil)
-
-(unless gnus-draft-mode-map
- (setq gnus-draft-mode-map (make-sparse-keymap))
-
- (gnus-define-keys gnus-draft-mode-map
- "Dt" gnus-draft-toggle-sending
- "e" gnus-draft-edit-message ;; Use `B w' for `gnus-summary-edit-article'
- "De" gnus-draft-edit-message
- "Ds" gnus-draft-send-message
- "DS" gnus-draft-send-all-messages))
+(defvar gnus-draft-mode-map
+ (let ((map (make-sparse-keymap)))
+ (gnus-define-keys map
+ "Dt" gnus-draft-toggle-sending
+ "e" gnus-draft-edit-message ;; Use `B w' for `gnus-summary-edit-article'
+ "De" gnus-draft-edit-message
+ "Ds" gnus-draft-send-message
+ "DS" gnus-draft-send-all-messages)
+ map))
(defun gnus-draft-make-menu-bar ()
(unless (boundp 'gnus-draft-menu)
@@ -61,20 +59,17 @@
["Send all messages" gnus-draft-send-all-messages t]
["Delete draft" gnus-summary-delete-article t]))))
-(defun gnus-draft-mode (&optional arg)
+(define-minor-mode gnus-draft-mode
"Minor mode for providing a draft summary buffers.
\\{gnus-draft-mode-map}"
- (interactive "P")
- (when (eq major-mode 'gnus-summary-mode)
- (when (set (make-local-variable 'gnus-draft-mode)
- (if (null arg) (not gnus-draft-mode)
- (> (prefix-numeric-value arg) 0)))
- ;; Set up the menu.
- (when (gnus-visual-p 'draft-menu 'menu)
- (gnus-draft-make-menu-bar))
- (add-minor-mode 'gnus-draft-mode " Draft" gnus-draft-mode-map)
- (gnus-run-hooks 'gnus-draft-mode-hook))))
+ :lighter " Draft" :keymap gnus-draft-mode-map
+ (cond
+ ((not (derived-mode-p 'gnus-summary-mode)) (setq gnus-draft-mode nil))
+ (gnus-draft-mode
+ ;; Set up the menu.
+ (when (gnus-visual-p 'draft-menu 'menu)
+ (gnus-draft-make-menu-bar)))))
;;; Commands
@@ -315,6 +310,8 @@ Obeys the standard process/prefix convention."
(while buffs
(set-buffer (setq buff (pop buffs)))
(if (and buffer-file-name
+ (equal (file-remote-p file)
+ (file-remote-p buffer-file-name))
(string-equal (file-truename buffer-file-name)
(file-truename file))
(buffer-modified-p))
@@ -330,5 +327,4 @@ Obeys the standard process/prefix convention."
(provide 'gnus-draft)
-;; arch-tag: 3d92af58-8c97-4a5c-9db4-a98e85198022
;;; gnus-draft.el ends here
diff --git a/lisp/gnus/gnus-dup.el b/lisp/gnus/gnus-dup.el
index 71f6a39d7d1..be909ccd798 100644
--- a/lisp/gnus/gnus-dup.el
+++ b/lisp/gnus/gnus-dup.el
@@ -159,5 +159,4 @@ seen in the same session."
(provide 'gnus-dup)
-;; arch-tag: 903e94db-7b00-4d19-83ee-cf34a81fa5fb
;;; gnus-dup.el ends here
diff --git a/lisp/gnus/gnus-eform.el b/lisp/gnus/gnus-eform.el
index c8f43aed798..96b645686e9 100644
--- a/lisp/gnus/gnus-eform.el
+++ b/lisp/gnus/gnus-eform.el
@@ -130,5 +130,4 @@ The optional LAYOUT overrides the `edit-form' window layout."
(provide 'gnus-eform)
-;; arch-tag: ef50678c-2c28-49ef-affc-e53b3b2c0bf6
;;; gnus-eform.el ends here
diff --git a/lisp/gnus/gnus-ems.el b/lisp/gnus/gnus-ems.el
index efa74146a91..d7d90767124 100644
--- a/lisp/gnus/gnus-ems.el
+++ b/lisp/gnus/gnus-ems.el
@@ -162,102 +162,6 @@
(autoload 'gnus-alive-p "gnus-util")
(autoload 'mm-disable-multibyte "mm-util")
-(defun gnus-x-splash ()
- "Show a splash screen using a pixmap in the current buffer."
- (interactive)
- (unless window-system
- (error "`gnus-x-splash' requires running on the window system"))
- (switch-to-buffer (gnus-get-buffer-create (if (or (gnus-alive-p)
- (interactive-p))
- "*gnus-x-splash*"
- gnus-group-buffer)))
- (let ((inhibit-read-only t)
- (file (nnheader-find-etc-directory "images/gnus/x-splash" t))
- pixmap fcw fch width height fringes sbars left yoffset top ls)
- (erase-buffer)
- (sit-for 0) ;; Necessary for measuring the window size correctly.
- (when (and file
- (ignore-errors
- (let ((coding-system-for-read 'raw-text))
- (with-temp-buffer
- (mm-disable-multibyte)
- (insert-file-contents file)
- (goto-char (point-min))
- (setq pixmap (read (current-buffer)))))))
- (setq fcw (float (frame-char-width))
- fch (float (frame-char-height))
- width (/ (car pixmap) fcw)
- height (/ (cadr pixmap) fch)
- fringes (if (fboundp 'window-fringes)
- (eval '(window-fringes))
- '(10 11 nil))
- sbars (frame-parameter nil 'vertical-scroll-bars))
- (cond ((eq sbars 'right)
- (setq sbars
- (cons 0 (/ (or (frame-parameter nil 'scroll-bar-width) 14)
- fcw))))
- (sbars
- (setq sbars
- (cons (/ (or (frame-parameter nil 'scroll-bar-width) 14)
- fcw)
- 0)))
- (t
- (setq sbars '(0 . 0))))
- (setq left (- (* (round (/ (1- (/ (+ (window-width)
- (car sbars) (cdr sbars)
- (/ (+ (or (car fringes) 0)
- (or (cadr fringes) 0))
- fcw))
- width))
- 2))
- width)
- (car sbars)
- (/ (or (car fringes) 0) fcw))
- yoffset (cadr (window-edges))
- top (max 0 (- (* (max (if (and (boundp 'tool-bar-mode)
- tool-bar-mode
- (not (featurep 'gtk))
- (eq (frame-first-window)
- (selected-window)))
- 1 0)
- (round (/ (1- (/ (+ (1- (window-height))
- (* 2 yoffset))
- height))
- 2)))
- height)
- yoffset))
- ls (/ (or line-spacing 0) fch)
- height (max 0 (- height ls)))
- (cond ((>= (- top ls) 1)
- (insert
- (propertize
- " "
- 'display `(space :width 0 :ascent 100))
- "\n"
- (propertize
- " "
- 'display `(space :width 0 :height ,(- top ls 1) :ascent 100))
- "\n"))
- ((> (- top ls) 0)
- (insert
- (propertize
- " "
- 'display `(space :width 0 :height ,(- top ls) :ascent 100))
- "\n")))
- (if (and (> width 0) (> left 0))
- (insert (propertize
- " "
- 'display `(space :width ,left :height ,height :ascent 0)))
- (setq width (+ width left)))
- (when (> width 0)
- (insert (propertize
- " "
- 'display `(space :width ,width :height ,height :ascent 0)
- 'face `(gnus-splash :stipple ,pixmap))))
- (goto-char (if (<= (- top ls) 0) (1- (point)) (point-min)))
- (redraw-frame (selected-frame))
- (sit-for 0))))
-
;;; Image functions.
(defun gnus-image-type-available-p (type)
@@ -272,7 +176,8 @@
(when face
(setq props (plist-put props :foreground (face-foreground face)))
(setq props (plist-put props :background (face-background face))))
- (apply 'create-image file type data-p props)))
+ (ignore-errors
+ (apply 'create-image file type data-p props))))
(defun gnus-put-image (glyph &optional string category)
(let ((point (point)))
@@ -305,7 +210,53 @@
(setq start end
end nil))))))
+(eval-and-compile
+ ;; XEmacs does not have window-inside-pixel-edges
+ (defalias 'gnus-window-inside-pixel-edges
+ (if (fboundp 'window-inside-pixel-edges)
+ 'window-inside-pixel-edges
+ 'window-pixel-edges))
+
+ (if (fboundp 'set-process-plist)
+ (progn
+ (defalias 'gnus-set-process-plist 'set-process-plist)
+ (defalias 'gnus-process-plist 'process-plist)
+ (defalias 'gnus-process-get 'process-get)
+ (defalias 'gnus-process-put 'process-put))
+ (defun gnus-set-process-plist (process plist)
+ "Replace the plist of PROCESS with PLIST. Returns PLIST."
+ (put 'gnus-process-plist-internal process plist))
+
+ (defun gnus-process-plist (process)
+ "Return the plist of PROCESS."
+ ;; This form works but can't prevent the plist data from
+ ;; growing infinitely.
+ ;;(get 'gnus-process-plist-internal process)
+ (let* ((plist (symbol-plist 'gnus-process-plist-internal))
+ (tem (memq process plist)))
+ (prog1
+ (cadr tem)
+ ;; Remove it from the plist data.
+ (when tem
+ (if (eq plist tem)
+ (progn
+ (setcar plist (caddr plist))
+ (setcdr plist (or (cdddr plist) '(nil))))
+ (setcdr (nthcdr (- (length plist) (length tem) 1) plist)
+ (cddr tem)))))))
+
+ (defun gnus-process-get (process propname)
+ "Return the value of PROCESS' PROPNAME property.
+This is the last value stored with `(gnus-process-put PROCESS PROPNAME VALUE)'."
+ (plist-get (gnus-process-plist process) propname))
+
+ (defun gnus-process-put (process propname value)
+ "Change PROCESS' PROPNAME property to VALUE.
+It can be retrieved with `(gnus-process-get PROCESS PROPNAME)'."
+ (gnus-set-process-plist process
+ (plist-put (gnus-process-plist process)
+ propname value)))))
+
(provide 'gnus-ems)
-;; arch-tag: e7360b45-14b5-4171-aa39-69a44aed3cdb
;;; gnus-ems.el ends here
diff --git a/lisp/gnus/gnus-fun.el b/lisp/gnus/gnus-fun.el
index 5ca707c5a39..0f28bf5e5ea 100644
--- a/lisp/gnus/gnus-fun.el
+++ b/lisp/gnus/gnus-fun.el
@@ -24,7 +24,7 @@
;;; Code:
-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
@@ -290,5 +290,4 @@ colors of the displayed X-Faces."
(provide 'gnus-fun)
-;; arch-tag: 9d000a69-15cc-4491-9dc0-4627484f50c1
;;; gnus-fun.el ends here
diff --git a/lisp/gnus/gnus-gravatar.el b/lisp/gnus/gnus-gravatar.el
new file mode 100644
index 00000000000..fd62f175a2a
--- /dev/null
+++ b/lisp/gnus/gnus-gravatar.el
@@ -0,0 +1,138 @@
+;;; gnus-gravatar.el --- Gnus Gravatar support
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Julien Danjou <julien@danjou.info>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gravatar)
+(require 'gnus-art)
+
+(defgroup gnus-gravatar nil
+ "Gnus Gravatar."
+ :group 'gnus-visual)
+
+(defcustom gnus-gravatar-size 32
+ "How big should gravatars be displayed."
+ :type 'integer
+ :version "24.1"
+ :group 'gnus-gravatar)
+
+(defcustom gnus-gravatar-properties '(:ascent center :relief 1)
+ "List of image properties applied to Gravatar images."
+ :type 'list
+ :version "24.1"
+ :group 'gnus-gravatar)
+
+(defcustom gnus-gravatar-too-ugly gnus-article-x-face-too-ugly
+ "Regexp matching posters whose avatar shouldn't be shown automatically."
+ :type '(choice regexp (const nil))
+ :version "24.1"
+ :group 'gnus-gravatar)
+
+(defun gnus-gravatar-transform-address (header category &optional force)
+ (gnus-with-article-headers
+ (let ((addresses
+ (mail-header-parse-addresses
+ ;; mail-header-parse-addresses does not work (reliably) on
+ ;; decoded headers.
+ (or
+ (ignore-errors
+ (mail-encode-encoded-word-string
+ (or (mail-fetch-field header) "")))
+ (mail-fetch-field header))))
+ (gravatar-size gnus-gravatar-size)
+ name)
+ (dolist (address addresses)
+ (when (setq name (cdr address))
+ (setcdr address (setq name (mail-decode-encoded-word-string name))))
+ (when (or force
+ (not (and gnus-gravatar-too-ugly
+ (or (string-match gnus-gravatar-too-ugly
+ (car address))
+ (and name
+ (string-match gnus-gravatar-too-ugly
+ name))))))
+ (ignore-errors
+ (gravatar-retrieve
+ (car address)
+ 'gnus-gravatar-insert
+ (list header address category))))))))
+
+(defun gnus-gravatar-insert (gravatar header address category)
+ "Insert GRAVATAR for ADDRESS in HEADER in current article buffer.
+Set image category to CATEGORY."
+ (unless (eq gravatar 'error)
+ (gnus-with-article-headers
+ ;; The buffer can be gone at this time
+ (when (buffer-live-p (current-buffer))
+ (gnus-article-goto-header header)
+ (mail-header-narrow-to-field)
+ (let ((real-name (cdr address))
+ (mail-address (car address)))
+ (when (if real-name
+ (re-search-forward (concat (regexp-quote real-name) "\\|"
+ (regexp-quote mail-address))
+ nil t)
+ (search-forward mail-address nil t))
+ (goto-char (1- (match-beginning 0)))
+ ;; If we're on the " quoting the name, go backward
+ (when (looking-at "[\"<]")
+ (goto-char (1- (point))))
+ ;; Do not do anything if there's already a gravatar. This can
+ ;; happens if the buffer has been regenerated in the mean time, for
+ ;; example we were fetching someaddress, and then we change to
+ ;; another mail with the same someaddress.
+ (unless (memq 'gnus-gravatar (text-properties-at (point)))
+ (let ((inhibit-read-only t)
+ (point (point)))
+ (unless (featurep 'xemacs)
+ (setq gravatar (append gravatar gnus-gravatar-properties)))
+ (gnus-put-image gravatar nil category)
+ (put-text-property point (point) 'gnus-gravatar address)
+ (gnus-add-wash-type category)
+ (gnus-add-image category gravatar)))))))))
+
+;;;###autoload
+(defun gnus-treat-from-gravatar (&optional force)
+ "Display gravatar in the From header.
+If gravatar is already displayed, remove it."
+ (interactive (list t)) ;; When type `W D g'
+ (gnus-with-article-buffer
+ (if (memq 'from-gravatar gnus-article-wash-types)
+ (gnus-delete-images 'from-gravatar)
+ (gnus-gravatar-transform-address "from" 'from-gravatar force))))
+
+;;;###autoload
+(defun gnus-treat-mail-gravatar (&optional force)
+ "Display gravatars in the Cc and To headers.
+If gravatars are already displayed, remove them."
+ (interactive (list t)) ;; When type `W D h'
+ (gnus-with-article-buffer
+ (if (memq 'mail-gravatar gnus-article-wash-types)
+ (gnus-delete-images 'mail-gravatar)
+ (gnus-gravatar-transform-address "cc" 'mail-gravatar force)
+ (gnus-gravatar-transform-address "to" 'mail-gravatar force))))
+
+(provide 'gnus-gravatar)
+
+;;; gnus-gravatar.el ends here
diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el
index 6d3b80e4f88..5ece1457163 100644
--- a/lisp/gnus/gnus-group.el
+++ b/lisp/gnus/gnus-group.el
@@ -25,7 +25,7 @@
;;; Code:
-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
@@ -55,17 +55,7 @@
(autoload 'gnus-agent-total-fetched-for "gnus-agent")
(autoload 'gnus-cache-total-fetched-for "gnus-cache")
-(defcustom gnus-group-archive-directory
- "/ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/"
- "*The address of the (ding) archives."
- :group 'gnus-group-foreign
- :type 'directory)
-
-(defcustom gnus-group-recent-archive-directory
- "/ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list-recent/"
- "*The address of the most recent (ding) articles."
- :group 'gnus-group-foreign
- :type 'directory)
+(autoload 'gnus-group-make-nnir-group "nnir")
(defcustom gnus-no-groups-message "No Gnus is good news"
"*Message displayed by Gnus when no groups are available."
@@ -129,10 +119,11 @@ If nil, only list groups that have unread articles."
:type 'boolean)
(defcustom gnus-group-default-list-level gnus-level-subscribed
- "*Default listing level.
+ "Default listing level.
Ignored if `gnus-group-use-permanent-levels' is non-nil."
:group 'gnus-group-listing
- :type 'integer)
+ :type '(choice (integer :tag "Level")
+ (function :tag "Function returning level")))
(defcustom gnus-group-list-inactive-groups t
"*If non-nil, inactive groups will be listed."
@@ -169,7 +160,7 @@ list."
(function-item gnus-group-sort-by-rank)
(function :tag "other" nil))))
-(defcustom gnus-group-line-format "%M\%S\%p\%P\%5y:%B%(%g%)%O\n"
+(defcustom gnus-group-line-format "%M\%S\%p\%P\%5y:%B%(%g%)\n"
"*Format of group lines.
It works along the same lines as a normal formatting string,
with some simple extensions.
@@ -292,14 +283,10 @@ If you want to modify the group buffer, you can use this hook."
:group 'gnus-exit
:type 'hook)
-(defcustom gnus-group-update-hook '(gnus-group-highlight-line)
- "Hook called when a group line is changed.
-The hook will not be called if `gnus-visual' is nil.
-
-The default function `gnus-group-highlight-line' will
-highlight the line according to the `gnus-group-highlight'
-variable."
+(defcustom gnus-group-update-hook nil
+ "Hook called when a group line is changed."
:group 'gnus-group-visual
+ :version "24.1"
:type 'hook)
(defcustom gnus-useful-groups
@@ -428,7 +415,6 @@ group: The name of the group.
unread: The number of unread articles in the group.
method: The select method used.
mailp: Whether it's a mail group or not.
-newsp: Whether it's a news group or not
level: The level of the group.
score: The score of the group.
ticked: The number of ticked articles."
@@ -509,7 +495,10 @@ simple manner.")
(gnus-range-length (cdr (assq 'tick gnus-tmp-marked))))))
(t number)) ?s)
(?R gnus-tmp-number-of-read ?s)
- (?U (gnus-number-of-unseen-articles-in-group gnus-tmp-group) ?d)
+ (?U (if (gnus-active gnus-tmp-group)
+ (gnus-number-of-unseen-articles-in-group gnus-tmp-group)
+ "*")
+ ?s)
(?t gnus-tmp-number-total ?d)
(?y gnus-tmp-number-of-unread ?s)
(?I (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) ?d)
@@ -562,8 +551,6 @@ simple manner.")
(defvar gnus-group-list-mode nil)
-(defvar gnus-group-icon-cache nil)
-
(defvar gnus-group-listed-groups nil)
(defvar gnus-group-list-option nil)
@@ -659,8 +646,6 @@ simple manner.")
"d" gnus-group-make-directory-group
"h" gnus-group-make-help-group
"u" gnus-group-make-useful-group
- "a" gnus-group-make-archive-group
- "k" gnus-group-make-kiboze-group
"l" gnus-group-nnimap-edit-acl
"m" gnus-group-make-group
"E" gnus-group-edit-group
@@ -671,22 +656,16 @@ simple manner.")
"D" gnus-group-enter-directory
"f" gnus-group-make-doc-group
"w" gnus-group-make-web-group
+ "G" gnus-group-make-nnir-group
"M" gnus-group-read-ephemeral-group
"r" gnus-group-rename-group
"R" gnus-group-make-rss-group
"c" gnus-group-customize
"z" gnus-group-compact-group
- "x" gnus-group-nnimap-expunge
+ "x" gnus-group-expunge-group
"\177" gnus-group-delete-group
[delete] gnus-group-delete-group)
-(gnus-define-keys (gnus-group-soup-map "s" gnus-group-group-map)
- "b" gnus-group-brew-soup
- "w" gnus-soup-save-areas
- "s" gnus-soup-send-replies
- "p" gnus-soup-pack-packet
- "r" nnsoup-pack-replies)
-
(gnus-define-keys (gnus-group-sort-map "S" gnus-group-group-map)
"s" gnus-group-sort-groups
"a" gnus-group-sort-groups-by-alphabet
@@ -762,10 +741,7 @@ simple manner.")
"e" gnus-score-edit-all-score)
(gnus-define-keys (gnus-group-help-map "H" gnus-group-mode-map)
- "c" gnus-group-fetch-charter
- "C" gnus-group-fetch-control
"d" gnus-group-describe-group
- "f" gnus-group-fetch-faq
"v" gnus-version)
(gnus-define-keys (gnus-group-sub-map "S" gnus-group-mode-map)
@@ -784,7 +760,6 @@ simple manner.")
(symbol-value 'gnus-topic-mode)))
(defun gnus-group-make-menu-bar ()
- (gnus-turn-off-edit-menu 'group)
(unless (boundp 'gnus-group-reading-menu)
(easy-menu-define
@@ -831,15 +806,6 @@ simple manner.")
["Describe" gnus-group-describe-group :active (gnus-group-group-name)
,@(if (featurep 'xemacs) nil
'(:help "Display description of the current group"))]
- ["Fetch FAQ" gnus-group-fetch-faq (gnus-group-group-name)]
- ["Fetch charter" gnus-group-fetch-charter
- :active (gnus-group-group-name)
- ,@(if (featurep 'xemacs) nil
- '(:help "Display the charter of the current group"))]
- ["Fetch control message" gnus-group-fetch-control
- :active (gnus-group-group-name)
- ,@(if (featurep 'xemacs) nil
- '(:help "Display the archived control message for the current group"))]
;; Actually one should check, if any of the marked groups gives t for
;; (gnus-check-backend-function 'request-expire-articles ...)
["Expire articles" gnus-group-expire-articles
@@ -935,10 +901,9 @@ simple manner.")
["Make a foreign group..." gnus-group-make-group t]
["Add a directory group..." gnus-group-make-directory-group t]
["Add the help group" gnus-group-make-help-group t]
- ["Add the archive group" gnus-group-make-archive-group t]
["Make a doc group..." gnus-group-make-doc-group t]
["Make a web group..." gnus-group-make-web-group t]
- ["Make a kiboze group..." gnus-group-make-kiboze-group t]
+ ["Make a search group..." gnus-group-make-nnir-group t]
["Make a virtual group..." gnus-group-make-empty-virtual t]
["Add a group to a virtual..." gnus-group-add-to-virtual t]
["Make an ephemeral group..." gnus-group-read-ephemeral-group t]
@@ -972,13 +937,6 @@ simple manner.")
(easy-menu-define
gnus-group-misc-menu gnus-group-mode-map ""
`("Gnus"
- ("SOUP"
- ["Pack replies" nnsoup-pack-replies (fboundp 'nnsoup-request-group)]
- ["Send replies" gnus-soup-send-replies
- (fboundp 'gnus-soup-pack-packet)]
- ["Pack packet" gnus-soup-pack-packet (fboundp 'gnus-soup-pack-packet)]
- ["Save areas" gnus-soup-save-areas (fboundp 'gnus-soup-pack-packet)]
- ["Brew SOUP" gnus-group-brew-soup (fboundp 'gnus-soup-pack-packet)])
["Send a mail" gnus-group-mail t]
["Send a message (mail or news)" gnus-group-post-news t]
["Create a local message" gnus-group-news t]
@@ -996,7 +954,6 @@ simple manner.")
["Browse foreign server..." gnus-group-browse-foreign-server t]
["Enter server buffer" gnus-group-enter-server-mode t]
["Expire all expirable articles" gnus-group-expire-all-groups t]
- ["Generate any kiboze groups" nnkiboze-generate-groups t]
["Gnus version" gnus-version t]
["Save .newsrc files" gnus-group-save-newsrc t]
["Suspend Gnus" gnus-group-suspend t]
@@ -1128,8 +1085,7 @@ When FORCE, rebuild the tool bar."
(when (and (not (featurep 'xemacs))
(boundp 'tool-bar-mode)
tool-bar-mode
- ;; The Gnus 5.10.6 code checked (default-value 'tool-bar-mode).
- ;; Why? --rsteib
+ (display-graphic-p)
(or (not gnus-group-tool-bar-map) force))
(let* ((load-path
(gmm-image-load-path-for-library "gnus"
@@ -1208,6 +1164,12 @@ The following commands are available:
(mouse-set-point e)
(gnus-group-read-group nil))
+(defun gnus-group-default-list-level ()
+ "Return the real value for `gnus-group-default-list-level'."
+ (if (functionp gnus-group-default-list-level)
+ (funcall gnus-group-default-list-level)
+ gnus-group-default-list-level))
+
;; Look at LEVEL and find out what the level is really supposed to be.
;; If LEVEL is non-nil, LEVEL will be returned, if not, what happens
;; will depend on whether `gnus-group-use-permanent-levels' is used.
@@ -1217,20 +1179,18 @@ The following commands are available:
(or (setq gnus-group-use-permanent-levels
(or level (if (numberp gnus-group-use-permanent-levels)
gnus-group-use-permanent-levels
- (or gnus-group-default-list-level
+ (or (gnus-group-default-list-level)
gnus-level-subscribed))))
- gnus-group-default-list-level gnus-level-subscribed))
+ (gnus-group-default-list-level) gnus-level-subscribed))
(number-or-nil
level)
(t
- (or level gnus-group-default-list-level gnus-level-subscribed))))
+ (or level (gnus-group-default-list-level) gnus-level-subscribed))))
(defun gnus-group-setup-buffer ()
(set-buffer (gnus-get-buffer-create gnus-group-buffer))
(unless (eq major-mode 'gnus-group-mode)
- (gnus-group-mode)
- (when gnus-carpal
- (gnus-carpal-setup-buffer 'group))))
+ (gnus-group-mode)))
(defun gnus-group-name-charset (method group)
(if (null method)
@@ -1271,7 +1231,7 @@ Also see the `gnus-group-use-permanent-levels' variable."
(prefix-numeric-value current-prefix-arg)
(or
(gnus-group-default-level nil t)
- gnus-group-default-list-level
+ (gnus-group-default-list-level)
gnus-level-subscribed))))
(unless level
(setq level (car gnus-group-list-mode)
@@ -1290,7 +1250,7 @@ Also see the `gnus-group-use-permanent-levels' variable."
(zerop number))
(zerop (buffer-size)))
;; No groups in the buffer.
- (gnus-message 5 gnus-no-groups-message))
+ (gnus-message 5 "%s" gnus-no-groups-message))
;; We have some groups displayed.
(goto-char (point-max))
(when (or (not gnus-group-goto-next-group-function)
@@ -1534,7 +1494,7 @@ if it is a string, only list groups matching REGEXP."
(and (not (featurep 'xemacs))
(boundp 'tool-bar-mode)
tool-bar-mode
- ;; Using `redraw-frame' (see `gnus-tool-bar-update') in Emacs 21 might
+ ;; Using `redraw-frame' (see `gnus-tool-bar-update') in Emacs might
;; be confusing, so maybe we shouldn't call it by default.
(fboundp 'force-window-update))
"Force updating the group buffer tool bar."
@@ -1592,7 +1552,7 @@ if it is a string, only list groups matching REGEXP."
?m ? ))
(gnus-tmp-moderated-string
(if (eq gnus-tmp-moderated ?m) "(m)" ""))
- (gnus-tmp-group-icon "==&&==")
+ (gnus-tmp-group-icon (gnus-group-get-icon gnus-tmp-group))
(gnus-tmp-news-server (or (cadr gnus-tmp-method) ""))
(gnus-tmp-news-method (or (car gnus-tmp-method) ""))
(gnus-tmp-news-method-string
@@ -1639,138 +1599,148 @@ if it is a string, only list groups matching REGEXP."
'gnus-tool-bar-update))
(forward-line -1)
(when (inline (gnus-visual-p 'group-highlight 'highlight))
- (gnus-run-hooks 'gnus-group-update-hook))
- (forward-line)
- ;; Allow XEmacs to remove front-sticky text properties.
- (gnus-group-remove-excess-properties)))
-
-(defun gnus-group-highlight-line ()
- "Highlight the current line according to `gnus-group-highlight'."
- (let* ((list gnus-group-highlight)
- (p (point))
- (end (point-at-eol))
- ;; now find out where the line starts and leave point there.
- (beg (progn (beginning-of-line) (point)))
- (group (gnus-group-group-name))
- (entry (gnus-group-entry group))
- (unread (if (numberp (car entry)) (car entry) 0))
- (active (gnus-active group))
- (total (if active (1+ (- (cdr active) (car active))) 0))
- (info (nth 2 entry))
- (method (inline (gnus-server-get-method group (gnus-info-method info))))
- (marked (gnus-info-marks info))
- (mailp (apply 'append
- (mapcar
- (lambda (x)
- (memq x (assoc (symbol-name
- (car (or method gnus-select-method)))
- gnus-valid-select-methods)))
- '(mail post-mail))))
- (level (or (gnus-info-level info) gnus-level-killed))
- (score (or (gnus-info-score info) 0))
- (ticked (gnus-range-length (cdr (assq 'tick marked))))
- (group-age (gnus-group-timestamp-delta group))
- (inhibit-read-only t))
- ;; FIXME: http://thread.gmane.org/gmane.emacs.gnus.general/65451/focus=65465
- ;; ======================================================================
- ;; From: Richard Stallman
- ;; Subject: Re: Rewriting gnus-group-highlight-line (was: [...])
- ;; Cc: ding@gnus.org
- ;; Date: Sat, 27 Oct 2007 19:41:20 -0400
- ;; Message-ID: <E1IlvHM-0006TS-7t@fencepost.gnu.org>
- ;;
- ;; [...]
- ;; The kludge is that the alist elements contain expressions that refer
- ;; to local variables with short names. Perhaps write your own tiny
- ;; evaluator that handles just `and', `or', and numeric comparisons
- ;; and just a few specific variables.
- ;; ======================================================================
- ;;
- ;; Similar for other evaluated variables. Grep for risky-local-variable
- ;; to find them! -- rsteib
- ;;
- ;; Eval the cars of the lists until we find a match.
- (while (and list
- (not (eval (caar list))))
- (setq list (cdr list)))
- (let ((face (cdar list)))
- (unless (eq face (get-text-property beg 'face))
- (gnus-put-text-property-excluding-characters-with-faces
- beg end 'face
- (setq face (if (boundp face) (symbol-value face) face)))
- (gnus-extent-start-open beg)))
- (goto-char p)))
+ (gnus-group-highlight-line gnus-tmp-group beg end))
+ (gnus-run-hooks 'gnus-group-update-hook)
+ (forward-line)))
+
+(defun gnus-group-update-eval-form (group list)
+ "Eval `car' of each element of LIST, and return the first that return t.
+Some value are bound so the form can use them."
+ (when list
+ (let* ((entry (gnus-group-entry group))
+ (unread (if (numberp (car entry)) (car entry) 0))
+ (active (gnus-active group))
+ (total (if active (1+ (- (cdr active) (car active))) 0))
+ (info (nth 2 entry))
+ (method (inline (gnus-server-get-method group (gnus-info-method info))))
+ (marked (gnus-info-marks info))
+ (mailp (apply 'append
+ (mapcar
+ (lambda (x)
+ (memq x (assoc (symbol-name
+ (car (or method gnus-select-method)))
+ gnus-valid-select-methods)))
+ '(mail post-mail))))
+ (level (or (gnus-info-level info) gnus-level-killed))
+ (score (or (gnus-info-score info) 0))
+ (ticked (gnus-range-length (cdr (assq 'tick marked))))
+ (group-age (gnus-group-timestamp-delta group)))
+ ;; FIXME: http://thread.gmane.org/gmane.emacs.gnus.general/65451/focus=65465
+ ;; ======================================================================
+ ;; From: Richard Stallman
+ ;; Subject: Re: Rewriting gnus-group-highlight-line (was: [...])
+ ;; Cc: ding@gnus.org
+ ;; Date: Sat, 27 Oct 2007 19:41:20 -0400
+ ;; Message-ID: <E1IlvHM-0006TS-7t@fencepost.gnu.org>
+ ;;
+ ;; [...]
+ ;; The kludge is that the alist elements contain expressions that refer
+ ;; to local variables with short names. Perhaps write your own tiny
+ ;; evaluator that handles just `and', `or', and numeric comparisons
+ ;; and just a few specific variables.
+ ;; ======================================================================
+ ;;
+ ;; Similar for other evaluated variables. Grep for risky-local-variable
+ ;; to find them! -- rsteib
+ ;;
+ ;; Eval the cars of the lists until we find a match.
+ (while (and list
+ (not (eval (caar list))))
+ (setq list (cdr list)))
+ list)))
+
+(defun gnus-group-highlight-line (group beg end)
+ "Highlight the current line according to `gnus-group-highlight'.
+GROUP is current group, and the line to highlight starts at BEG
+and ends at END."
+ (let ((face (cdar (gnus-group-update-eval-form
+ group
+ gnus-group-highlight))))
+ (unless (eq face (get-text-property beg 'face))
+ (let ((inhibit-read-only t))
+ (gnus-put-text-property-excluding-characters-with-faces
+ beg end 'face
+ (if (boundp face) (symbol-value face) face)))
+ (gnus-extent-start-open beg))))
+
+(defun gnus-group-get-icon (group)
+ "Return an icon for GROUP according to `gnus-group-icon-list'."
+ (if gnus-group-icon-list
+ (let ((image-path
+ (cdar (gnus-group-update-eval-form group gnus-group-icon-list))))
+ (if image-path
+ (propertize " "
+ 'display
+ (append
+ (gnus-create-image (expand-file-name image-path))
+ '(:ascent center)))
+ " "))
+ " "))
(defun gnus-group-update-group (group &optional visible-only)
"Update all lines where GROUP appear.
If VISIBLE-ONLY is non-nil, the group won't be displayed if it isn't
already."
- ;; Can't use `save-excursion' here, so we do it manually.
- (let ((buf (current-buffer))
- mark)
- (set-buffer gnus-group-buffer)
- (setq mark (point-marker))
- ;; The buffer may be narrowed.
- (save-restriction
- (widen)
- (let ((ident (gnus-intern-safe group gnus-active-hashtb))
- (loc (point-min))
- found buffer-read-only)
- ;; Enter the current status into the dribble buffer.
- (let ((entry (gnus-group-entry group)))
- (when (and entry
- (not (gnus-ephemeral-group-p group)))
- (gnus-dribble-enter
- (concat "(gnus-group-set-info '"
- (gnus-prin1-to-string (nth 2 entry))
- ")"))))
- ;; Find all group instances. If topics are in use, each group
- ;; may be listed in more than once.
- (while (setq loc (text-property-any
- loc (point-max) 'gnus-group ident))
- (setq found t)
- (goto-char loc)
- (let ((gnus-group-indentation (gnus-group-group-indentation)))
- (gnus-delete-line)
- (gnus-group-insert-group-line-info group)
- (save-excursion
- (forward-line -1)
- (gnus-run-hooks 'gnus-group-update-group-hook)))
- (setq loc (1+ loc)))
- (unless (or found visible-only)
- ;; No such line in the buffer, find out where it's supposed to
- ;; go, and insert it there (or at the end of the buffer).
- (if gnus-goto-missing-group-function
- (funcall gnus-goto-missing-group-function group)
- (let ((entry (cddr (gnus-group-entry group))))
- (while (and entry (car entry)
- (not
- (gnus-goto-char
- (text-property-any
- (point-min) (point-max)
- 'gnus-group (gnus-intern-safe
- (caar entry) gnus-active-hashtb)))))
- (setq entry (cdr entry)))
- (or entry (goto-char (point-max)))))
- ;; Finally insert the line.
- (let ((gnus-group-indentation (gnus-group-group-indentation)))
- (gnus-group-insert-group-line-info group)
- (save-excursion
- (forward-line -1)
- (gnus-run-hooks 'gnus-group-update-group-hook))))
- (when gnus-group-update-group-function
- (funcall gnus-group-update-group-function group))
- (gnus-group-set-mode-line)))
- (goto-char mark)
- (set-marker mark nil)
- (set-buffer buf)))
+ (with-current-buffer gnus-group-buffer
+ (save-excursion
+ ;; The buffer may be narrowed.
+ (save-restriction
+ (widen)
+ (let ((ident (gnus-intern-safe group gnus-active-hashtb))
+ (loc (point-min))
+ found buffer-read-only)
+ ;; Enter the current status into the dribble buffer.
+ (let ((entry (gnus-group-entry group)))
+ (when (and entry
+ (not (gnus-ephemeral-group-p group)))
+ (gnus-dribble-enter
+ (concat "(gnus-group-set-info '"
+ (gnus-prin1-to-string (nth 2 entry))
+ ")"))))
+ ;; Find all group instances. If topics are in use, each group
+ ;; may be listed in more than once.
+ (while (setq loc (text-property-any
+ loc (point-max) 'gnus-group ident))
+ (setq found t)
+ (goto-char loc)
+ (let ((gnus-group-indentation (gnus-group-group-indentation)))
+ (gnus-delete-line)
+ (gnus-group-insert-group-line-info group)
+ (save-excursion
+ (forward-line -1)
+ (gnus-run-hooks 'gnus-group-update-group-hook)))
+ (setq loc (1+ loc)))
+ (unless (or found visible-only)
+ ;; No such line in the buffer, find out where it's supposed to
+ ;; go, and insert it there (or at the end of the buffer).
+ (if gnus-goto-missing-group-function
+ (funcall gnus-goto-missing-group-function group)
+ (let ((entry (cddr (gnus-group-entry group))))
+ (while (and entry (car entry)
+ (not
+ (gnus-goto-char
+ (text-property-any
+ (point-min) (point-max)
+ 'gnus-group (gnus-intern-safe
+ (caar entry)
+ gnus-active-hashtb)))))
+ (setq entry (cdr entry)))
+ (or entry (goto-char (point-max)))))
+ ;; Finally insert the line.
+ (let ((gnus-group-indentation (gnus-group-group-indentation)))
+ (gnus-group-insert-group-line-info group)
+ (save-excursion
+ (forward-line -1)
+ (gnus-run-hooks 'gnus-group-update-group-hook))))
+ (when gnus-group-update-group-function
+ (funcall gnus-group-update-group-function group))
+ (gnus-group-set-mode-line))))))
(defun gnus-group-set-mode-line ()
"Update the mode line in the group buffer."
(when (memq 'group gnus-updated-mode-lines)
;; Yes, we want to keep this mode line updated.
- (save-excursion
- (set-buffer gnus-group-buffer)
+ (with-current-buffer gnus-group-buffer
(let* ((gformat (or gnus-group-mode-line-format-spec
(gnus-set-format 'group-mode)))
(gnus-tmp-news-server (cadr gnus-select-method))
@@ -1783,8 +1753,7 @@ already."
(and gnus-dribble-buffer
(buffer-name gnus-dribble-buffer)
(buffer-modified-p gnus-dribble-buffer)
- (save-excursion
- (set-buffer gnus-dribble-buffer)
+ (with-current-buffer gnus-dribble-buffer
(not (zerop (buffer-size))))))
(mode-string (eval gformat)))
;; Say whether the dribble buffer has been modified.
@@ -1921,7 +1890,7 @@ If FIRST-TOO, the current line is also eligible as a target."
(unless no-advance
(gnus-group-next-group 1))
(decf n))
- (gnus-summary-position-point)
+ (gnus-group-position-point)
n))
(defun gnus-group-unmark-group (n)
@@ -2195,41 +2164,49 @@ be permanent."
group)))
(goto-char start)))))
-(defun gnus-group-completing-read (prompt &optional collection predicate
- require-match initial-input hist def
- &rest args)
+(defun gnus-group-completing-read (&optional prompt collection
+ require-match initial-input hist
+ def)
"Read a group name with completion. Non-ASCII group names are allowed.
The arguments are the same as `completing-read' except that COLLECTION
and HIST default to `gnus-active-hashtb' and `gnus-group-history'
-respectively if they are omitted."
- (let (group)
- (mapatoms (lambda (symbol)
- (setq group (symbol-name symbol))
- (set (intern (if (string-match "[^\000-\177]" group)
- (gnus-group-decoded-name group)
- group)
- collection)
- group))
- (prog1
- (or collection
- (setq collection (or gnus-active-hashtb [0])))
- (setq collection (gnus-make-hashtable (length collection)))))
- (setq group (apply 'completing-read prompt collection predicate
- require-match initial-input
- (or hist 'gnus-group-history)
- def args))
- (or (prog1
- (symbol-value (intern-soft group collection))
- (setq collection nil))
- (mm-encode-coding-string group (gnus-group-name-charset nil group)))))
+respectively if they are omitted. Regards COLLECTION as a hash table
+if it is not a list."
+ (or collection (setq collection gnus-active-hashtb))
+ (let (choices group)
+ (if (listp collection)
+ (dolist (symbol collection)
+ (setq group (symbol-name symbol))
+ (push (if (string-match "[^\000-\177]" group)
+ (gnus-group-decoded-name group)
+ group)
+ choices))
+ (mapatoms (lambda (symbol)
+ (setq group (symbol-name symbol))
+ (push (if (string-match "[^\000-\177]" group)
+ (gnus-group-decoded-name group)
+ group)
+ choices))
+ collection))
+ (setq group (gnus-completing-read (or prompt "Group") (nreverse choices)
+ require-match initial-input
+ (or hist 'gnus-group-history)
+ def))
+ (unless (if (listp collection)
+ (member group (mapcar 'symbol-name collection))
+ (symbol-value (intern-soft group collection)))
+ (setq group
+ (mm-encode-coding-string
+ group (gnus-group-name-charset nil group))))
+ (gnus-replace-in-string group "\n" "")))
;;;###autoload
(defun gnus-fetch-group (group &optional articles)
"Start Gnus if necessary and enter GROUP.
If ARTICLES, display those articles.
Returns whether the fetching was successful or not."
- (interactive (list (gnus-group-completing-read "Group name: "
- nil nil nil
+ (interactive (list (gnus-group-completing-read nil
+ nil nil
(gnus-group-name-at-point))))
(unless (gnus-alive-p)
(gnus-no-server))
@@ -2248,8 +2225,6 @@ Returns whether the fetching was successful or not."
(other-frame 1))))
(gnus-fetch-group group))
-(defvar gnus-ephemeral-group-server 0)
-
(defcustom gnus-large-ephemeral-newsgroup 200
"The number of articles which indicates a large ephemeral newsgroup.
Same as `gnus-large-newsgroup', but only used for ephemeral newsgroups.
@@ -2291,8 +2266,8 @@ Return the name of the group if selection was successful."
(interactive
(list
;; (gnus-read-group "Group name: ")
- (gnus-group-completing-read "Group: ")
- (gnus-read-method "From method: ")))
+ (gnus-group-completing-read)
+ (gnus-read-method "From method")))
;; Transform the select method into a unique server.
(when (stringp method)
(setq method (gnus-server-to-method method)))
@@ -2358,13 +2333,13 @@ specified by `gnus-gmane-group-download-format'."
;; See <http://gmane.org/export.php> for more information.
(interactive
(list
- (gnus-group-completing-read "Gmane group: ")
+ (gnus-group-completing-read "Gmane group")
(read-number "Start article number: ")
(read-number "How many articles: ")))
(unless range (setq range 500))
(when (< range 1)
(error "Invalid range: %s" range))
- (let ((tmpfile (make-temp-file
+ (let ((tmpfile (mm-make-temp-file
(format "%s.start-%s.range-%s." group start range)))
(gnus-thread-sort-functions '(gnus-thread-sort-by-number)))
(with-temp-file tmpfile
@@ -2392,7 +2367,7 @@ Valid input formats include:
;; prompt the user to decide: "View via `browse-url' or in Gnus? "
;; (`gnus-read-ephemeral-gmane-group-url')
(interactive
- (list (gnus-group-completing-read "Gmane URL: ")))
+ (list (gnus-group-completing-read "Gmane URL")))
(let (group start range)
(cond
;; URLs providing `group', `start' and `range':
@@ -2445,9 +2420,17 @@ the bug number, and browsing the URL must return mbox output."
(cdr (assoc 'emacs gnus-bug-group-download-format-alist))))
(when (stringp number)
(setq number (string-to-number number)))
- (let ((tmpfile (make-temp-file "gnus-temp-group-")))
+ (let ((tmpfile (mm-make-temp-file "gnus-temp-group-")))
(with-temp-file tmpfile
(url-insert-file-contents (format mbox-url number))
+ (goto-char (point-min))
+ ;; Add the debbugs address so that we can respond to reports easily.
+ (while (re-search-forward "^To: " nil t)
+ (end-of-line)
+ (insert (format ", %s@%s" number
+ (gnus-replace-in-string
+ (gnus-replace-in-string mbox-url "^http://" "")
+ "/.*$" ""))))
(write-region (point-min) (point-max) tmpfile)
(gnus-group-read-ephemeral-group
"gnus-read-ephemeral-bug"
@@ -2478,13 +2461,13 @@ If PROMPT (the prefix) is a number, use the prompt specified in
`gnus-group-jump-to-group-prompt'."
(interactive
(list (gnus-group-completing-read
- "Group: " nil nil (gnus-read-active-file-p)
- (if current-prefix-arg
- (cdr (assq current-prefix-arg gnus-group-jump-to-group-prompt))
- (or (and (stringp gnus-group-jump-to-group-prompt)
- gnus-group-jump-to-group-prompt)
- (let ((p (cdr (assq 0 gnus-group-jump-to-group-prompt))))
- (and (stringp p) p)))))))
+ nil nil (gnus-read-active-file-p)
+ (if current-prefix-arg
+ (cdr (assq current-prefix-arg gnus-group-jump-to-group-prompt))
+ (or (and (stringp gnus-group-jump-to-group-prompt)
+ gnus-group-jump-to-group-prompt)
+ (let ((p (cdr (assq 0 gnus-group-jump-to-group-prompt))))
+ (and (stringp p) p)))))))
(when (equal group "")
(error "Empty group name"))
@@ -2675,7 +2658,7 @@ If EXCLUDE-GROUP, do not go to that group."
(defun gnus-group-make-group-simple (&optional group)
"Add a new newsgroup.
The user will be prompted for GROUP."
- (interactive (list (gnus-group-completing-read "Group: ")))
+ (interactive (list (gnus-group-completing-read)))
(gnus-group-make-group (gnus-group-real-name group)
(gnus-group-server group)
nil nil t))
@@ -2684,11 +2667,14 @@ The user will be prompted for GROUP."
"Add a new newsgroup.
The user will be prompted for a NAME, for a select METHOD, and an
ADDRESS. NAME should be a human-readable string (i.e., not be encoded
-even if it contains non-ASCII characters) unless ENCODED is non-nil."
+even if it contains non-ASCII characters) unless ENCODED is non-nil.
+
+If the backend supports it, the group will also be created on the
+server."
(interactive
(list
(gnus-read-group "Group name: ")
- (gnus-read-method "From method: ")))
+ (gnus-read-method "From method")))
(when (stringp method)
(setq method (or (gnus-server-to-method method) method)))
@@ -2934,8 +2920,9 @@ and NEW-NAME will be prompted for."
(defun gnus-group-make-useful-group (group method)
"Create one of the groups described in `gnus-useful-groups'."
(interactive
- (let ((entry (assoc (completing-read "Create group: " gnus-useful-groups
- nil t)
+ (let ((entry (assoc (gnus-completing-read "Create group"
+ (mapcar 'car gnus-useful-groups)
+ t)
gnus-useful-groups)))
(list (cadr entry)
;; Don't use `caddr' here since macros within the `interactive'
@@ -3027,11 +3014,11 @@ If SOLID (the prefix), create a solid group."
(symbol-name (caar nnweb-type-definition))))
(type
(gnus-string-or
- (completing-read
- (format "Search engine type (default %s): " default-type)
- (mapcar (lambda (elem) (list (symbol-name (car elem))))
+ (gnus-completing-read
+ "Search engine type"
+ (mapcar (lambda (elem) (symbol-name (car elem)))
nnweb-type-definition)
- nil t nil 'gnus-group-web-type-history)
+ t nil 'gnus-group-web-type-history)
default-type))
(search
(read-string
@@ -3044,7 +3031,7 @@ If SOLID (the prefix), create a solid group."
(nnweb-ephemeral-p t))))
(if solid
(progn
- (gnus-pull 'nnweb-ephemeral-p method)
+ (gnus-alist-pull 'nnweb-ephemeral-p method)
(gnus-group-make-group group method))
(gnus-group-read-ephemeral-group
group method t
@@ -3094,58 +3081,6 @@ If there is, use Gnus to create an nnrss group"
(nnrss-save-server-data nil))
(error "No feeds found for %s" url))))
-(defvar nnwarchive-type-definition)
-(defvar gnus-group-warchive-type-history nil)
-(defvar gnus-group-warchive-login-history nil)
-(defvar gnus-group-warchive-address-history nil)
-
-(defun gnus-group-make-warchive-group ()
- "Create a nnwarchive group."
- (interactive)
- (require 'nnwarchive)
- (let* ((group (gnus-read-group "Group name: "))
- (default-type (or (car gnus-group-warchive-type-history)
- (symbol-name (caar nnwarchive-type-definition))))
- (type
- (gnus-string-or
- (completing-read
- (format "Warchive type (default %s): " default-type)
- (mapcar (lambda (elem) (list (symbol-name (car elem))))
- nnwarchive-type-definition)
- nil t nil 'gnus-group-warchive-type-history)
- default-type))
- (address (read-string "Warchive address: "
- nil 'gnus-group-warchive-address-history))
- (default-login (or (car gnus-group-warchive-login-history)
- user-mail-address))
- (login
- (gnus-string-or
- (read-string
- (format "Warchive login (default %s): " user-mail-address)
- default-login 'gnus-group-warchive-login-history)
- user-mail-address))
- (method
- `(nnwarchive ,address
- (nnwarchive-type ,(intern type))
- (nnwarchive-login ,login))))
- (gnus-group-make-group group method)))
-
-(defun gnus-group-make-archive-group (&optional all)
- "Create the (ding) Gnus archive group of the most recent articles.
-Given a prefix, create a full group."
- (interactive "P")
- (let ((group (gnus-group-prefixed-name
- (if all "ding.archives" "ding.recent") '(nndir ""))))
- (when (gnus-group-entry group)
- (error "Archive group already exists"))
- (gnus-group-make-group
- (gnus-group-real-name group)
- (list 'nndir (if all "hpc" "edu")
- (list 'nndir-directory
- (if all gnus-group-archive-directory
- gnus-group-recent-archive-directory))))
- (gnus-group-add-parameter group (cons 'to-address "ding@gnus.org"))))
-
(defun gnus-group-make-directory-group (dir)
"Create an nndir group.
The user will be prompted for a directory. The contents of this
@@ -3170,47 +3105,12 @@ mail messages or news articles in files that have numeric names."
(gnus-group-real-name group)
(list 'nndir (gnus-group-real-name group) (list 'nndir-directory dir)))))
-(defvar nnkiboze-score-file)
-(declare-function nnkiboze-score-file "nnkiboze" (group))
-
-(defun gnus-group-make-kiboze-group (group address scores)
- "Create an nnkiboze group.
-The user will be prompted for a name, a regexp to match groups, and
-score file entries for articles to include in the group."
- (interactive
- (list
- (read-string "nnkiboze group name: ")
- (read-string "Source groups (regexp): ")
- (let ((headers (mapcar 'list
- '("subject" "from" "number" "date" "message-id"
- "references" "chars" "lines" "xref"
- "followup" "all" "body" "head")))
- scores header regexp regexps)
- (while (not (equal "" (setq header (completing-read
- "Match on header: " headers nil t))))
- (setq regexps nil)
- (while (not (equal "" (setq regexp (read-string
- (format "Match on %s (regexp): "
- header)))))
- (push (list regexp nil nil 'r) regexps))
- (push (cons header regexps) scores))
- scores)))
- (gnus-group-make-group group "nnkiboze" address)
- (let* ((nnkiboze-current-group group)
- (score-file (car (nnkiboze-score-file "")))
- (score-dir (file-name-directory score-file)))
- (unless (file-exists-p score-dir)
- (make-directory score-dir))
- (with-temp-file score-file
- (let (emacs-lisp-mode-hook)
- (gnus-pp scores)))))
-
(defun gnus-group-add-to-virtual (n vgroup)
"Add the current group to a virtual group."
(interactive
(list current-prefix-arg
- (completing-read "Add to virtual group: " gnus-newsrc-hashtb nil t
- "nnvirtual:")))
+ (gnus-group-completing-read "Add to virtual group"
+ nil t "nnvirtual:")))
(unless (eq (car (gnus-find-method-for-group vgroup)) 'nnvirtual)
(error "%s is not an nnvirtual group" vgroup))
(gnus-close-group vgroup)
@@ -3255,21 +3155,17 @@ score file entries for articles to include in the group."
'summary 'group)))
(error "Couldn't enter %s" dir))))
-(autoload 'nnimap-expunge "nnimap")
-(autoload 'nnimap-acl-get "nnimap")
-(autoload 'nnimap-acl-edit "nnimap")
-
-(defun gnus-group-nnimap-expunge (group)
+(defun gnus-group-expunge-group (group)
"Expunge deleted articles in current nnimap GROUP."
(interactive (list (gnus-group-group-name)))
- (let ((mailbox (gnus-group-real-name group)) method)
- (unless group
- (error "No group on current line"))
- (unless (gnus-get-info group)
- (error "Killed group; can't be edited"))
- (unless (eq 'nnimap (car (setq method (gnus-find-method-for-group group))))
- (error "%s is not an nnimap group" group))
- (nnimap-expunge mailbox (cadr method))))
+ (let ((method (gnus-find-method-for-group group)))
+ (if (not (gnus-check-backend-function
+ 'request-expunge-group (car method)))
+ (error "%s does not support expunging" (car method))
+ (gnus-request-expunge-group group method))))
+
+(autoload 'nnimap-acl-get "nnimap")
+(autoload 'nnimap-acl-edit "nnimap")
(defun gnus-group-nnimap-edit-acl (group)
"Edit the Access Control List of current nnimap GROUP."
@@ -3785,7 +3681,7 @@ If given numerical prefix, toggle the N next groups."
Killed newsgroups are subscribed. If SILENT, don't try to update the
group line."
(interactive (list (gnus-group-completing-read
- "Group: " nil nil (gnus-read-active-file-p))))
+ nil nil (gnus-read-active-file-p))))
(let ((newsrc (gnus-group-entry group)))
(cond
((string-match "^[ \t]*$" group)
@@ -4067,30 +3963,12 @@ re-scanning. If ARG is non-nil and not a number, this will force
(unless gnus-slave
(gnus-master-read-slave-newsrc))
- ;; We might read in new NoCeM messages here.
- (when (and gnus-use-nocem
- (or (and (numberp gnus-use-nocem)
- (numberp arg)
- (>= arg gnus-use-nocem))
- (not arg)))
- (gnus-nocem-scan-groups))
- ;; If ARG is not a number, then we read the active file.
- (when (and arg (not (numberp arg)))
- (let ((gnus-read-active-file t))
- (gnus-read-active-file))
- (setq arg nil)
-
- ;; If the user wants it, we scan for new groups.
- (when (eq gnus-check-new-newsgroups 'always)
- (gnus-find-new-newsgroups)))
-
- (setq arg (gnus-group-default-level arg t))
- (if (and gnus-read-active-file (not arg))
- (progn
- (gnus-read-active-file)
- (gnus-get-unread-articles arg))
- (let ((gnus-read-active-file (if arg nil gnus-read-active-file)))
- (gnus-get-unread-articles arg)))
+ (gnus-get-unread-articles arg)
+
+ ;; If the user wants it, we scan for new groups.
+ (when (eq gnus-check-new-newsgroups 'always)
+ (gnus-find-new-newsgroups))
+
(gnus-check-reasonable-setup)
(gnus-run-hooks 'gnus-after-getting-new-news-hook)
(gnus-group-list-groups (and (numberp arg)
@@ -4105,7 +3983,7 @@ If DONT-SCAN is non-nil, scan non-activated groups as well."
(let* ((groups (gnus-group-process-prefix n))
(ret (if (numberp n) (- n (length groups)) 0))
(beg (unless n
- (point)))
+ (point-marker)))
group method
(gnus-inhibit-demon t)
;; Binding this variable will inhibit multiple fetchings
@@ -4136,91 +4014,9 @@ If DONT-SCAN is non-nil, scan non-activated groups as well."
(goto-char beg))
(when gnus-goto-next-group-when-activating
(gnus-group-next-unread-group 1 t))
- (gnus-summary-position-point)
+ (gnus-group-position-point)
ret))
-(defun gnus-group-fetch-faq (group &optional faq-dir)
- "Fetch the FAQ for the current group.
-If given a prefix argument, prompt for the FAQ dir
-to use."
- (interactive
- (list
- (gnus-group-group-name)
- (when current-prefix-arg
- (completing-read
- "FAQ dir: " (and (listp gnus-group-faq-directory)
- (mapcar #'list
- gnus-group-faq-directory))))))
- (unless group
- (error "No group name given"))
- (let ((dirs (or faq-dir gnus-group-faq-directory))
- dir found file)
- (unless (listp dirs)
- (setq dirs (list dirs)))
- (while (and (not found)
- (setq dir (pop dirs)))
- (let ((name (gnus-group-real-name group)))
- (setq file (expand-file-name name dir)))
- (if (not (file-exists-p file))
- (gnus-message 1 "No such file: %s" file)
- (let ((enable-local-variables nil))
- (find-file file)
- (setq found t))))))
-
-(defun gnus-group-fetch-charter (group)
- "Fetch the charter for the current group.
-If given a prefix argument, prompt for a group."
- (interactive
- (list (or (when current-prefix-arg
- (gnus-group-completing-read "Group: "))
- (gnus-group-group-name)
- gnus-newsgroup-name)))
- (unless group
- (error "No group name given"))
- (require 'mm-url)
- (condition-case nil (require 'url-http) (error nil))
- (let ((name (mm-url-form-encode-xwfu (gnus-group-real-name group)))
- url hierarchy)
- (when (string-match "\\(^[^\\.]+\\)\\..*" name)
- (setq hierarchy (match-string 1 name))
- (if (and (setq url (cdr (assoc hierarchy gnus-group-charter-alist)))
- (if (fboundp 'url-http-file-exists-p)
- (url-http-file-exists-p (eval url))
- t))
- (browse-url (eval url))
- (setq url (concat "http://" hierarchy
- ".news-admin.org/charters/" name))
- (if (and (fboundp 'url-http-file-exists-p)
- (url-http-file-exists-p url))
- (browse-url url)
- (gnus-group-fetch-control group))))))
-
-(defun gnus-group-fetch-control (group)
- "Fetch the archived control messages for the current group.
-If given a prefix argument, prompt for a group."
- (interactive
- (list (or (when current-prefix-arg
- (gnus-group-completing-read "Group: "))
- (gnus-group-group-name)
- gnus-newsgroup-name)))
- (unless group
- (error "No group name given"))
- (let ((name (gnus-group-real-name group))
- hierarchy)
- (when (string-match "\\(^[^\\.]+\\)\\..*" name)
- (setq hierarchy (match-string 1 name))
- (if gnus-group-fetch-control-use-browse-url
- (browse-url (concat "ftp://ftp.isc.org/usenet/control/"
- hierarchy "/" name ".gz"))
- (let ((enable-local-variables nil))
- (gnus-group-read-ephemeral-group
- group
- `(nndoc ,group (nndoc-address
- ,(find-file-noselect
- (concat "/ftp@ftp.isc.org:/usenet/control/"
- hierarchy "/" name ".gz")))
- (nndoc-article-type mbox)) t nil nil))))))
-
(defun gnus-group-describe-group (force &optional group)
"Display a description of the current newsgroup."
(interactive (list current-prefix-arg (gnus-group-group-name)))
@@ -4238,7 +4034,7 @@ If given a prefix argument, prompt for a group."
(gnus-gethash mname gnus-description-hashtb))
(setq desc (gnus-group-get-description group))
(gnus-read-descriptions-file method))
- (gnus-message 1
+ (gnus-message 1 "%s"
(or desc (gnus-gethash group gnus-description-hashtb)
"No description available")))))
@@ -4390,8 +4186,14 @@ groups.
With 2 C-u's, use most complete method possible to query the server
for new groups, and subscribe the new groups as zombies."
(interactive "p")
- (gnus-find-new-newsgroups (or arg 1))
- (gnus-group-list-groups))
+ (let ((new-groups (gnus-find-new-newsgroups (or arg 1)))
+ current-group)
+ (gnus-group-list-groups)
+ (setq current-group (gnus-group-group-name))
+ (dolist (group new-groups)
+ (gnus-group-jump-to-group group))
+ (when current-group
+ (gnus-group-jump-to-group current-group))))
(defun gnus-group-edit-global-kill (&optional article group)
"Edit the global kill file.
@@ -4399,11 +4201,9 @@ If GROUP, edit that local kill file instead."
(interactive "P")
(setq gnus-current-kill-article article)
(gnus-kill-file-edit-file group)
- (gnus-message
- 6
- (substitute-command-keys
- (format "Editing a %s kill file (Type \\[gnus-kill-file-exit] to exit)"
- (if group "local" "global")))))
+ (gnus-message 6 "Editing a %s kill file (Type %s to exit)"
+ (if group "local" "global")
+ (substitute-command-keys "\\[gnus-kill-file-exit]")))
(defun gnus-group-edit-local-kill (article group)
"Edit a local kill file."
@@ -4480,8 +4280,7 @@ The hook `gnus-exit-gnus-hook' is called before actually exiting."
(gnus-run-hooks 'gnus-exit-gnus-hook)
(gnus-configure-windows 'group t)
(when (and (gnus-buffer-live-p gnus-dribble-buffer)
- (not (zerop (save-excursion
- (set-buffer gnus-dribble-buffer)
+ (not (zerop (with-current-buffer gnus-dribble-buffer
(buffer-size)))))
(gnus-dribble-enter
";;; Gnus was exited on purpose without saving the .newsrc files."))
@@ -4495,7 +4294,7 @@ The hook `gnus-exit-gnus-hook' is called before actually exiting."
(defun gnus-group-describe-briefly ()
"Give a one line description of the group mode commands."
(interactive)
- (gnus-message 7 (substitute-command-keys "\\<gnus-group-mode-map>\\[gnus-group-read-group]:Select \\[gnus-group-next-unread-group]:Forward \\[gnus-group-prev-unread-group]:Backward \\[gnus-group-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-group-describe-briefly]:This help")))
+ (gnus-message 7 "%s" (substitute-command-keys "\\<gnus-group-mode-map>\\[gnus-group-read-group]:Select \\[gnus-group-next-unread-group]:Forward \\[gnus-group-prev-unread-group]:Backward \\[gnus-group-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-group-describe-briefly]:This help")))
(defun gnus-group-browse-foreign-server (method)
"Browse a foreign news server.
@@ -4504,18 +4303,19 @@ If called interactively, this function will ask for a select method
If not, METHOD should be a list where the first element is the method
and the second element is the address."
(interactive
- (list (let ((how (completing-read
- "Which back end: "
- (append gnus-valid-select-methods gnus-server-alist)
- nil t (cons "nntp" 0) 'gnus-method-history)))
+ (list (let ((how (gnus-completing-read
+ "Which back end"
+ (mapcar 'car (append gnus-valid-select-methods
+ gnus-server-alist))
+ t (cons "nntp" 0) 'gnus-method-history)))
;; We either got a back end name or a virtual server name.
;; If the first, we also need an address.
(if (assoc how gnus-valid-select-methods)
(list (intern how)
;; Suggested by mapjph@bath.ac.uk.
- (completing-read
- "Address: "
- (mapcar 'list gnus-secondary-servers)))
+ (gnus-completing-read
+ "Address"
+ gnus-secondary-servers))
;; We got a server name.
how))))
(gnus-browse-foreign-server method))
@@ -4542,13 +4342,11 @@ and the second element is the address."
(setcar (nthcdr (1- total) info) part-info)))
(unless entry
;; This is a new group, so we just create it.
- (save-excursion
- (set-buffer gnus-group-buffer)
+ (with-current-buffer gnus-group-buffer
(setq method (gnus-info-method info))
(when (gnus-server-equal method "native")
(setq method nil))
- (save-excursion
- (set-buffer gnus-group-buffer)
+ (with-current-buffer gnus-group-buffer
(if method
;; It's a foreign group...
(gnus-group-make-group
@@ -4612,8 +4410,7 @@ and the second element is the address."
"Mark ARTICLE in GROUP with MARK, whether the group is displayed or not."
(let ((buffer (gnus-summary-buffer-name group)))
(if (gnus-buffer-live-p buffer)
- (save-excursion
- (set-buffer (get-buffer buffer))
+ (with-current-buffer (get-buffer buffer)
(gnus-summary-add-mark article mark))
(gnus-add-marked-articles group (cdr (assq mark gnus-article-mark-lists))
(list article)))))
@@ -4813,5 +4610,4 @@ Compacting group %s... (this may take a long time)"
(provide 'gnus-group)
-;; arch-tag: 2eb5440f-0bca-4091-814c-e37817536af6
;;; gnus-group.el ends here
diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el
new file mode 100644
index 00000000000..174e128a7e9
--- /dev/null
+++ b/lisp/gnus/gnus-html.el
@@ -0,0 +1,526 @@
+;;; gnus-html.el --- Render HTML in a buffer.
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Keywords: html, web
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; The idea is to provide a simple, fast and pretty minimal way to
+;; render HTML (including links and images) in a buffer, based on an
+;; external HTML renderer (i.e., w3m).
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(require 'gnus-art)
+(eval-when-compile (require 'mm-decode))
+
+(require 'mm-url)
+(require 'url)
+(require 'url-cache)
+(require 'xml)
+(require 'browse-url)
+(eval-and-compile (unless (featurep 'xemacs) (require 'help-fns)))
+
+(defcustom gnus-html-image-cache-ttl (days-to-time 7)
+ "Time used to determine if we should use images from the cache."
+ :version "24.1"
+ :group 'gnus-art
+ :type 'integer)
+
+(defcustom gnus-html-image-automatic-caching t
+ "Whether automatically cache retrieve images."
+ :version "24.1"
+ :group 'gnus-art
+ :type 'boolean)
+
+(defcustom gnus-html-frame-width 70
+ "What width to use when rendering HTML."
+ :version "24.1"
+ :group 'gnus-art
+ :type 'integer)
+
+(defcustom gnus-max-image-proportion 0.9
+ "How big pictures displayed are in relation to the window they're in.
+A value of 0.7 means that they are allowed to take up 70% of the
+width and height of the window. If they are larger than this,
+and Emacs supports it, then the images will be rescaled down to
+fit these criteria."
+ :version "24.1"
+ :group 'gnus-art
+ :type 'float)
+
+(defvar gnus-html-image-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "u" 'gnus-article-copy-string)
+ (define-key map "i" 'gnus-html-insert-image)
+ (define-key map "v" 'gnus-html-browse-url)
+ map))
+
+(defvar gnus-html-displayed-image-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "a" 'gnus-html-show-alt-text)
+ (define-key map "i" 'gnus-html-browse-image)
+ (define-key map "\r" 'gnus-html-browse-url)
+ (define-key map "u" 'gnus-article-copy-string)
+ (define-key map [tab] 'widget-forward)
+ map))
+
+(eval-and-compile
+ (defalias 'gnus-html-encode-url-chars
+ (if (fboundp 'browse-url-url-encode-chars)
+ 'browse-url-url-encode-chars
+ (lambda (text chars)
+ "URL-encode the chars in TEXT that match CHARS.
+CHARS is a regexp-like character alternative (e.g., \"[)$]\")."
+ (let ((encoded-text (copy-sequence text))
+ (s 0))
+ (while (setq s (string-match chars encoded-text s))
+ (setq encoded-text
+ (replace-match (format "%%%x"
+ (string-to-char
+ (match-string 0 encoded-text)))
+ t t encoded-text)
+ s (1+ s)))
+ encoded-text)))))
+
+(defun gnus-html-encode-url (url)
+ "Encode URL."
+ (gnus-html-encode-url-chars url "[)$ ]"))
+
+(defun gnus-html-cache-expired (url ttl)
+ "Check if URL is cached for more than TTL."
+ (cond (url-standalone-mode
+ (not (file-exists-p (url-cache-create-filename url))))
+ (t (let ((cache-time (url-is-cached url)))
+ (if cache-time
+ (time-less-p
+ (time-add
+ cache-time
+ ttl)
+ (current-time))
+ t)))))
+
+;;;###autoload
+(defun gnus-article-html (&optional handle)
+ (let ((article-buffer (current-buffer)))
+ (unless handle
+ (setq handle (mm-dissect-buffer t)))
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (save-excursion
+ (mm-with-part handle
+ (let* ((coding-system-for-read 'utf-8)
+ (coding-system-for-write 'utf-8)
+ (default-process-coding-system
+ (cons coding-system-for-read coding-system-for-write))
+ (charset (mail-content-type-get (mm-handle-type handle)
+ 'charset)))
+ (when (and charset
+ (setq charset (mm-charset-to-coding-system charset))
+ (not (eq charset 'ascii)))
+ (insert (prog1
+ (mm-decode-coding-string (buffer-string) charset)
+ (erase-buffer)
+ (mm-enable-multibyte))))
+ (call-process-region (point-min) (point-max)
+ "w3m"
+ nil article-buffer nil
+ "-halfdump"
+ "-no-cookie"
+ "-I" "UTF-8"
+ "-O" "UTF-8"
+ "-o" "ext_halfdump=1"
+ "-o" "display_ins_del=2"
+ "-o" "pre_conv=1"
+ "-t" (format "%s" tab-width)
+ "-cols" (format "%s" gnus-html-frame-width)
+ "-o" "display_image=on"
+ "-T" "text/html"))))
+ (gnus-html-wash-tags))))
+
+(defvar gnus-article-mouse-face)
+
+(defun gnus-html-pre-wash ()
+ (goto-char (point-min))
+ (while (re-search-forward " *<pre_int> *</pre_int> *\n" nil t)
+ (replace-match "" t t))
+ (goto-char (point-min))
+ (while (re-search-forward "<a name[^\n>]+>" nil t)
+ (replace-match "" t t)))
+
+(defun gnus-html-wash-images ()
+ "Run through current buffer and replace img tags by images."
+ (let (tag parameters string start end images url alt-text
+ inhibit-images blocked-images)
+ (if (buffer-live-p gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
+ (setq inhibit-images gnus-inhibit-images
+ blocked-images (gnus-blocked-images)))
+ (setq inhibit-images gnus-inhibit-images
+ blocked-images (gnus-blocked-images)))
+ (goto-char (point-min))
+ ;; Search for all the images first.
+ (while (re-search-forward "<img_alt \\([^>]*\\)>" nil t)
+ (setq parameters (match-string 1)
+ start (match-beginning 0))
+ (delete-region start (point))
+ (when (search-forward "</img_alt>" (line-end-position) t)
+ (delete-region (match-beginning 0) (match-end 0)))
+ (setq end (point))
+ (when (string-match "src=\"\\([^\"]+\\)" parameters)
+ (gnus-message 8 "gnus-html-wash-tags: fetching image URL %s" url)
+ (setq url (gnus-html-encode-url (match-string 1 parameters))
+ alt-text (when (string-match "\\(alt\\|title\\)=\"\\([^\"]+\\)"
+ parameters)
+ (xml-substitute-special (match-string 2 parameters))))
+ (gnus-add-text-properties
+ start end
+ (list 'image-url url
+ 'image-displayer `(lambda (url start end)
+ (gnus-html-display-image url start end
+ ,alt-text))
+ 'gnus-image (list url start end alt-text)))
+ (gnus-overlay-put (gnus-make-overlay start end)
+ 'local-map gnus-html-image-map)
+ (if (string-match "\\`cid:" url)
+ ;; URLs with cid: have their content stashed in other
+ ;; parts of the MIME structure, so just insert them
+ ;; immediately.
+ (let* ((handle (mm-get-content-id (substring url (match-end 0))))
+ (image (when (and handle
+ (not inhibit-images))
+ (gnus-create-image
+ (mm-with-part handle (buffer-string))
+ nil t))))
+ (if image
+ (progn
+ (gnus-put-image
+ (gnus-rescale-image
+ image (gnus-html-maximum-image-size))
+ (gnus-string-or (prog1
+ (buffer-substring start end)
+ (delete-region start end))
+ "*")
+ 'cid)
+ (gnus-add-image 'cid image))
+ (widget-convert-button
+ 'link start end
+ :action 'gnus-html-insert-image
+ :help-echo url
+ :keymap gnus-html-image-map
+ :button-keymap gnus-html-image-map)))
+ ;; Normal, external URL.
+ (if (or inhibit-images
+ (gnus-html-image-url-blocked-p url blocked-images))
+ (widget-convert-button
+ 'link start end
+ :action 'gnus-html-insert-image
+ :help-echo url
+ :keymap gnus-html-image-map
+ :button-keymap gnus-html-image-map)
+ ;; Non-blocked url
+ (let ((width
+ (when (string-match "width=\"?\\([0-9]+\\)" parameters)
+ (string-to-number (match-string 1 parameters))))
+ (height
+ (when (string-match "height=\"?\\([0-9]+\\)" parameters)
+ (string-to-number (match-string 1 parameters)))))
+ ;; Don't fetch images that are really small. They're
+ ;; probably tracking pictures.
+ (when (and (or (null height)
+ (> height 4))
+ (or (null width)
+ (> width 4)))
+ (gnus-html-display-image url start end alt-text)))))))))
+
+(defun gnus-html-display-image (url start end &optional alt-text)
+ "Display image at URL on text from START to END.
+Use ALT-TEXT for the image string."
+ (or alt-text (setq alt-text "*"))
+ (if (string-match "\\`cid:" url)
+ (let ((handle (mm-get-content-id (substring url (match-end 0)))))
+ (when handle
+ (gnus-html-put-image (mm-with-part handle (buffer-string))
+ url alt-text)))
+ (if (gnus-html-cache-expired url gnus-html-image-cache-ttl)
+ ;; We don't have it, so schedule it for fetching
+ ;; asynchronously.
+ (gnus-html-schedule-image-fetching
+ (current-buffer)
+ (list url alt-text))
+ ;; It's already cached, so just insert it.
+ (gnus-html-put-image (gnus-html-get-image-data url) url alt-text))))
+
+(defun gnus-html-wash-tags ()
+ (let (tag parameters string start end images url)
+ (gnus-html-pre-wash)
+ (gnus-html-wash-images)
+
+ (goto-char (point-min))
+ ;; Then do the other tags.
+ (while (re-search-forward "<\\([^ />]+\\)\\([^>]*\\)>" nil t)
+ (setq tag (match-string 1)
+ parameters (match-string 2)
+ start (match-beginning 0))
+ (when (> (length parameters) 0)
+ (set-text-properties 0 (1- (length parameters)) nil parameters))
+ (delete-region start (point))
+ (when (search-forward (concat "</" tag ">") nil t)
+ (delete-region (match-beginning 0) (match-end 0)))
+ (setq end (point))
+ (cond
+ ;; Fetch and insert a picture.
+ ((equal tag "img_alt"))
+ ;; Add a link.
+ ((or (equal tag "a")
+ (equal tag "A"))
+ (when (string-match "href=\"\\([^\"]+\\)" parameters)
+ (setq url (match-string 1 parameters))
+ (gnus-message 8 "gnus-html-wash-tags: fetching link URL %s" url)
+ (gnus-article-add-button start end
+ 'browse-url (mm-url-decode-entities-string url)
+ url)
+ (let ((overlay (gnus-make-overlay start end)))
+ (gnus-overlay-put overlay 'evaporate t)
+ (gnus-overlay-put overlay 'gnus-button-url url)
+ (gnus-put-text-property start end 'gnus-string url)
+ (when gnus-article-mouse-face
+ (gnus-overlay-put overlay 'mouse-face gnus-article-mouse-face)))))
+ ;; The upper-case IMG_ALT is apparently just an artifact that
+ ;; should be deleted.
+ ((equal tag "IMG_ALT")
+ (delete-region start end))
+ ;; w3m does not normalize the case
+ ((or (equal tag "b")
+ (equal tag "B"))
+ (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-bold))
+ ((or (equal tag "u")
+ (equal tag "U"))
+ (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-underline))
+ ((or (equal tag "i")
+ (equal tag "I"))
+ (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-italic))
+ ((or (equal tag "s")
+ (equal tag "S"))
+ (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-strikethru))
+ ((or (equal tag "ins")
+ (equal tag "INS"))
+ (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-underline))
+ ;; Handle different UL types
+ ((equal tag "_SYMBOL")
+ (when (string-match "TYPE=\\(.+\\)" parameters)
+ (let ((type (string-to-number (match-string 1 parameters))))
+ (delete-region start end)
+ (cond ((= type 33) (insert " "))
+ ((= type 34) (insert " "))
+ ((= type 35) (insert " "))
+ ((= type 36) (insert " "))
+ ((= type 37) (insert " "))
+ ((= type 38) (insert " "))
+ ((= type 39) (insert " "))
+ ((= type 40) (insert " "))
+ ((= type 42) (insert " "))
+ ((= type 43) (insert " "))
+ (t (insert " "))))))
+ ;; Whatever. Just ignore the tag.
+ (t
+ ))
+ (goto-char start))
+ (goto-char (point-min))
+ ;; The output from -halfdump isn't totally regular, so strip
+ ;; off any </pre_int>s that were left over.
+ (while (re-search-forward "</pre_int>\\|</internal>" nil t)
+ (replace-match "" t t))
+ (mm-url-decode-entities)))
+
+(defun gnus-html-insert-image (&rest args)
+ "Fetch and insert the image under point."
+ (interactive)
+ (apply 'gnus-html-display-image (get-text-property (point) 'gnus-image)))
+
+(defun gnus-html-show-alt-text ()
+ "Show the ALT text of the image under point."
+ (interactive)
+ (message "%s" (get-text-property (point) 'gnus-alt-text)))
+
+(defun gnus-html-browse-image ()
+ "Browse the image under point."
+ (interactive)
+ (browse-url (get-text-property (point) 'image-url)))
+
+(defun gnus-html-browse-url ()
+ "Browse the image under point."
+ (interactive)
+ (let ((url (get-text-property (point) 'gnus-string)))
+ (cond
+ ((not url)
+ (message "No link under point"))
+ ((string-match "^mailto:" url)
+ (gnus-url-mailto url))
+ (t
+ (browse-url url)))))
+
+(defun gnus-html-schedule-image-fetching (buffer image)
+ "Retrieve IMAGE, and place it into BUFFER on arrival."
+ (gnus-message 8 "gnus-html-schedule-image-fetching: buffer %s, image %s"
+ buffer image)
+ (let ((args (list (car image)
+ 'gnus-html-image-fetched
+ (list buffer image))))
+ (when (> (length (if (featurep 'xemacs)
+ (cdr (split-string (function-arglist 'url-retrieve)))
+ (help-function-arglist 'url-retrieve)))
+ 4)
+ (setq args (nconc args (list t))))
+ (ignore-errors
+ (apply #'url-retrieve args))))
+
+(defun gnus-html-image-fetched (status buffer image)
+ "Callback function called when image has been fetched."
+ (unless (plist-get status :error)
+ (when gnus-html-image-automatic-caching
+ (url-store-in-cache (current-buffer)))
+ (when (and (or (search-forward "\n\n" nil t)
+ (search-forward "\r\n\r\n" nil t))
+ (buffer-live-p buffer))
+ (let ((data (buffer-substring (point) (point-max))))
+ (with-current-buffer buffer
+ (let ((inhibit-read-only t))
+ (gnus-html-put-image data (car image) (cadr image)))))))
+ (kill-buffer (current-buffer)))
+
+(defun gnus-html-get-image-data (url)
+ "Get image data for URL.
+Return a string with image data."
+ (with-temp-buffer
+ (mm-disable-multibyte)
+ (url-cache-extract (url-cache-create-filename url))
+ (when (or (search-forward "\n\n" nil t)
+ (search-forward "\r\n\r\n" nil t))
+ (buffer-substring (point) (point-max)))))
+
+(defun gnus-html-maximum-image-size ()
+ "Return the maximum size of an image according to `gnus-max-image-proportion'."
+ (let ((edges (gnus-window-inside-pixel-edges
+ (get-buffer-window (current-buffer)))))
+ ;; (width . height)
+ (cons
+ ;; Aimed width
+ (truncate
+ (* gnus-max-image-proportion
+ (- (nth 2 edges) (nth 0 edges))))
+ ;; Aimed height
+ (truncate (* gnus-max-image-proportion
+ (- (nth 3 edges) (nth 1 edges)))))))
+
+(defun gnus-html-put-image (data url &optional alt-text)
+ "Put an image with DATA from URL and optional ALT-TEXT."
+ (when (gnus-graphic-display-p)
+ (let* ((start (text-property-any (point-min) (point-max)
+ 'image-url url))
+ (end (when start
+ (next-single-property-change start 'image-url))))
+ ;; Image found?
+ (when start
+ (let* ((image
+ (ignore-errors
+ (gnus-create-image data nil t)))
+ (size (and image
+ (if (featurep 'xemacs)
+ (cons (glyph-width image) (glyph-height image))
+ (image-size image t)))))
+ (save-excursion
+ (goto-char start)
+ (let ((alt-text (or alt-text
+ (buffer-substring-no-properties start end)))
+ (inhibit-read-only t))
+ (if (and image
+ ;; Kludge to avoid displaying 30x30 gif images, which
+ ;; seems to be a signal of a broken image.
+ (not (and (if (featurep 'xemacs)
+ (glyphp image)
+ (listp image))
+ (eq (if (featurep 'xemacs)
+ (let ((d (cdadar
+ (specifier-spec-list
+ (glyph-image image)))))
+ (and (vectorp d)
+ (aref d 0)))
+ (plist-get (cdr image) :type))
+ 'gif)
+ (= (car size) 30)
+ (= (cdr size) 30))))
+ ;; Good image, add it!
+ (let ((image (gnus-rescale-image image (gnus-html-maximum-image-size))))
+ (delete-region start end)
+ (gnus-put-image image alt-text 'external)
+ (gnus-put-text-property start (point) 'help-echo alt-text)
+ (gnus-overlay-put
+ (gnus-make-overlay start (point)) 'local-map
+ gnus-html-displayed-image-map)
+ (gnus-put-text-property start (point)
+ 'gnus-alt-text alt-text)
+ (when url
+ (gnus-put-text-property start (point)
+ 'image-url url))
+ (gnus-add-image 'external image)
+ t)
+ ;; Bad image, try to show something else
+ (when (fboundp 'find-image)
+ (delete-region start end)
+ (setq image (find-image
+ '((:type xpm :file "lock-broken.xpm"))))
+ (gnus-put-image image alt-text 'internal)
+ (gnus-add-image 'internal image))
+ nil))))))))
+
+(defun gnus-html-image-url-blocked-p (url blocked-images)
+ "Find out if URL is blocked by BLOCKED-IMAGES."
+ (let ((ret (and blocked-images
+ (string-match blocked-images url))))
+ (if ret
+ (gnus-message 8 "gnus-html-image-url-blocked-p: %s blocked by regex %s"
+ url blocked-images)
+ (gnus-message 9 "gnus-html-image-url-blocked-p: %s passes regex %s"
+ url blocked-images))
+ ret))
+
+;;;###autoload
+(defun gnus-html-prefetch-images (summary)
+ (when (buffer-live-p summary)
+ (let (inhibit-images blocked-images)
+ (with-current-buffer summary
+ (setq inhibit-images gnus-inhibit-images
+ blocked-images (gnus-blocked-images)))
+ (save-match-data
+ (while (re-search-forward "<img[^>]+src=[\"']\\(http[^\"']+\\)" nil t)
+ (let ((url (gnus-html-encode-url
+ (mm-url-decode-entities-string (match-string 1)))))
+ (unless (or inhibit-images
+ (gnus-html-image-url-blocked-p url blocked-images))
+ (when (gnus-html-cache-expired url gnus-html-image-cache-ttl)
+ (gnus-html-schedule-image-fetching nil
+ (list url))))))))))
+
+(provide 'gnus-html)
+
+;;; gnus-html.el ends here
diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el
index a0795916ea7..bcfff347968 100644
--- a/lisp/gnus/gnus-int.el
+++ b/lisp/gnus/gnus-int.el
@@ -31,6 +31,7 @@
(require 'message)
(require 'gnus-range)
+(autoload 'gnus-run-hook-with-args "gnus-util")
(autoload 'gnus-agent-expire "gnus-agent")
(autoload 'gnus-agent-regenerate-group "gnus-agent")
(autoload 'gnus-agent-read-servers-validate-native "gnus-agent")
@@ -41,6 +42,16 @@
:group 'gnus-start
:type 'hook)
+(defcustom gnus-after-set-mark-hook nil
+ "Hook called just after marks are set in a group."
+ :group 'gnus-start
+ :type 'hook)
+
+(defcustom gnus-before-update-mark-hook nil
+ "Hook called just before marks are updated in a group."
+ :group 'gnus-start
+ :type 'hook)
+
(defcustom gnus-server-unopen-status nil
"The default status if the server is not able to open.
If the server is covered by Gnus agent, the possible values are
@@ -89,16 +100,13 @@ If CONFIRM is non-nil, the user will be asked for an NNTP server."
;; Stream is already opened.
nil
;; Open NNTP server.
- (unless gnus-nntp-service
- (setq gnus-nntp-server nil))
(when confirm
;; Read server name with completion.
(setq gnus-nntp-server
- (completing-read "NNTP server: "
- (mapcar 'list
- (cons (list gnus-nntp-server)
- gnus-secondary-servers))
- nil nil gnus-nntp-server)))
+ (gnus-completing-read "NNTP server"
+ (cons gnus-nntp-server
+ gnus-secondary-servers)
+ nil gnus-nntp-server)))
(when (and gnus-nntp-server
(stringp gnus-nntp-server)
@@ -179,15 +187,17 @@ If it is down, start it up (again)."
(format " on %s" (nth 1 method)))))
(gnus-run-hooks 'gnus-open-server-hook)
(prog1
- (condition-case ()
- (setq result (gnus-open-server method))
- (quit (message "Quit gnus-check-server")
- nil))
+ (setq result (gnus-open-server method))
(unless silent
- (gnus-message 5 "Opening %s server%s...%s" (car method)
- (if (equal (nth 1 method) "") ""
- (format " on %s" (nth 1 method)))
- (if result "done" "failed")))))))
+ (gnus-message
+ (if result 5 3)
+ "Opening %s server%s...%s" (car method)
+ (if (equal (nth 1 method) "") ""
+ (format " on %s" (nth 1 method)))
+ (if result
+ "done"
+ (format "failed: %s"
+ (nnheader-get-report-string (car method))))))))))
(defun gnus-get-function (method function &optional noerror)
"Return a function symbol based on METHOD and FUNCTION."
@@ -225,10 +235,22 @@ If it is down, start it up (again)."
;;; Interface functions to the backends.
;;;
+(defun gnus-method-denied-p (method)
+ (eq (nth 1 (assoc method gnus-opened-servers))
+ 'denied))
+
+(defvar gnus-backend-trace t)
+
(defun gnus-open-server (gnus-command-method)
"Open a connection to GNUS-COMMAND-METHOD."
(when (stringp gnus-command-method)
(setq gnus-command-method (gnus-server-to-method gnus-command-method)))
+ (when gnus-backend-trace
+ (with-current-buffer (get-buffer-create "*gnus trace*")
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert (format-time-string "%H:%M:%S")
+ (format " %S\n" gnus-command-method))))
(let ((elem (assoc gnus-command-method gnus-opened-servers))
(server (gnus-method-to-server-name gnus-command-method)))
;; If this method was previously denied, we just return nil.
@@ -244,9 +266,8 @@ If it is down, start it up (again)."
(nth 1 gnus-command-method)
(nthcdr 2 gnus-command-method))
(error
- (gnus-message 1 (format
- "Unable to open server %s due to: %s"
- server (error-message-string err)))
+ (gnus-message 1 "Unable to open server %s due to: %s"
+ server (error-message-string err))
nil)
(quit
(gnus-message 1 "Quit trying to open server %s" server)
@@ -257,34 +278,31 @@ If it is down, start it up (again)."
(setq elem (list gnus-command-method nil)
gnus-opened-servers (cons elem gnus-opened-servers)))
;; Set the status of this server.
- (setcar (cdr elem)
- (cond (result
- (if (eq open-server-function #'nnagent-open-server)
- ;; The agent's backend has a "special" status
- 'offline
- 'ok))
- ((and gnus-agent
- (gnus-agent-method-p gnus-command-method))
- (cond (gnus-server-unopen-status
- ;; Set the server's status to the unopen
- ;; status. If that status is offline,
- ;; recurse to open the agent's backend.
- (setq open-offline (eq gnus-server-unopen-status 'offline))
- gnus-server-unopen-status)
- ((and
- (not gnus-batch-mode)
- (gnus-y-or-n-p
- (format
- "Unable to open server %s, go offline? "
- server)))
- (setq open-offline t)
- 'offline)
- (t
- ;; This agentized server was still denied
- 'denied)))
- (t
- ;; This unagentized server must be denied
- 'denied)))
+ (setcar
+ (cdr elem)
+ (cond (result
+ (if (eq open-server-function #'nnagent-open-server)
+ ;; The agent's backend has a "special" status
+ 'offline
+ 'ok))
+ ((and gnus-agent
+ (gnus-agent-method-p gnus-command-method))
+ (cond
+ (gnus-server-unopen-status
+ ;; Set the server's status to the unopen
+ ;; status. If that status is offline,
+ ;; recurse to open the agent's backend.
+ (setq open-offline (eq gnus-server-unopen-status 'offline))
+ gnus-server-unopen-status)
+ ((not gnus-batch-mode)
+ (setq open-offline t)
+ 'offline)
+ (t
+ ;; This agentized server was still denied
+ 'denied)))
+ (t
+ ;; This unagentized server must be denied
+ 'denied)))
;; NOTE: I MUST set the server's status to offline before this
;; recursive call as this status will drive the
@@ -319,6 +337,22 @@ If it is down, start it up (again)."
(funcall (gnus-get-function gnus-command-method 'request-list)
(nth 1 gnus-command-method)))
+(defun gnus-finish-retrieve-group-infos (gnus-command-method infos data)
+ "Read and update infos from GNUS-COMMAND-METHOD."
+ (when (stringp gnus-command-method)
+ (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
+ (funcall (gnus-get-function gnus-command-method 'finish-retrieve-group-infos)
+ (nth 1 gnus-command-method)
+ infos data))
+
+(defun gnus-retrieve-group-data-early (gnus-command-method infos)
+ "Start early async retrival of data from GNUS-COMMAND-METHOD."
+ (when (stringp gnus-command-method)
+ (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
+ (funcall (gnus-get-function gnus-command-method 'retrieve-group-data-early)
+ (nth 1 gnus-command-method)
+ infos))
+
(defun gnus-request-list-newsgroups (gnus-command-method)
"Request the newsgroups file from GNUS-COMMAND-METHOD."
(when (stringp gnus-command-method)
@@ -358,16 +392,17 @@ If it is down, start it up (again)."
(funcall (gnus-get-function gnus-command-method 'request-compact)
(nth 1 gnus-command-method)))
-(defun gnus-request-group (group &optional dont-check gnus-command-method)
+(defun gnus-request-group (group &optional dont-check gnus-command-method info)
"Request GROUP. If DONT-CHECK, no information is required."
(let ((gnus-command-method
(or gnus-command-method (inline (gnus-find-method-for-group group)))))
(when (stringp gnus-command-method)
(setq gnus-command-method
(inline (gnus-server-to-method gnus-command-method))))
- (funcall (inline (gnus-get-function gnus-command-method 'request-group))
+ (funcall (inline (gnus-get-function gnus-command-method 'request-group))
(gnus-group-real-name group) (nth 1 gnus-command-method)
- dont-check)))
+ dont-check
+ info)))
(defun gnus-list-active-group (group)
"Request active information on GROUP."
@@ -445,7 +480,8 @@ If FETCH-OLD, retrieve all headers (or some subset thereof) in the group."
action
(funcall (gnus-get-function gnus-command-method 'request-set-mark)
(gnus-group-real-name group) action
- (nth 1 gnus-command-method)))))
+ (nth 1 gnus-command-method))
+ (gnus-run-hook-with-args gnus-after-set-mark-hook group action))))
(defun gnus-request-update-mark (group article mark)
"Allow the back end to change the mark the user tries to put on an article."
@@ -453,6 +489,7 @@ If FETCH-OLD, retrieve all headers (or some subset thereof) in the group."
(if (not (gnus-check-backend-function
'request-update-mark (car gnus-command-method)))
mark
+ (gnus-run-hook-with-args gnus-before-update-mark-hook group article mark)
(funcall (gnus-get-function gnus-command-method 'request-update-mark)
(gnus-group-real-name group) article mark))))
@@ -465,6 +502,23 @@ If BUFFER, insert the article in that group."
article (gnus-group-real-name group)
(nth 1 gnus-command-method) buffer)))
+(defun gnus-request-thread (id)
+ "Request the headers in the thread containing the article
+specified by Message-ID id."
+ (let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name)))
+ (funcall (gnus-get-function gnus-command-method 'request-thread)
+ id)))
+
+(defun gnus-warp-to-article ()
+ "Warps from an article in a virtual group to the article in its
+real group. Does nothing on a real group."
+ (interactive)
+ (let ((gnus-command-method
+ (gnus-find-method-for-group gnus-newsgroup-name)))
+ (when (gnus-check-backend-function
+ 'warp-to-article (car gnus-command-method))
+ (funcall (gnus-get-function gnus-command-method 'warp-to-article)))))
+
(defun gnus-request-head (article group)
"Request the head of ARTICLE in GROUP."
(let* ((gnus-command-method (gnus-find-method-for-group group))
@@ -490,8 +544,7 @@ If BUFFER, insert the article in that group."
(setq res (gnus-request-article article group)
clean-up t)))
(when clean-up
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(goto-char (point-min))
(when (search-forward "\n\n" nil t)
(delete-region (1- (point)) (point-max)))
@@ -523,8 +576,7 @@ If BUFFER, insert the article in that group."
(setq res (gnus-request-article article group)
clean-up t)))
(when clean-up
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(goto-char (point-min))
(when (search-forward "\n\n" nil t)
(delete-region (point-min) (1- (point))))))
@@ -537,6 +589,14 @@ If BUFFER, insert the article in that group."
(funcall (gnus-get-function gnus-command-method 'request-post)
(nth 1 gnus-command-method)))
+(defun gnus-request-expunge-group (group gnus-command-method)
+ "Expunge GROUP, which is removing articles that have been marked as deleted."
+ (when (stringp gnus-command-method)
+ (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
+ (funcall (gnus-get-function gnus-command-method 'request-expunge-group)
+ (gnus-group-real-name group)
+ (nth 1 gnus-command-method)))
+
(defun gnus-request-scan (group gnus-command-method)
"Request a SCAN being performed in GROUP from GNUS-COMMAND-METHOD.
If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
@@ -544,18 +604,28 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
(if group (gnus-find-method-for-group group) gnus-command-method))
(gnus-inhibit-demon t)
(mail-source-plugged gnus-plugged))
- (when (or gnus-plugged (not (gnus-agent-method-p gnus-command-method)))
+ (when (or gnus-plugged
+ (not (gnus-agent-method-p gnus-command-method)))
(setq gnus-internal-registry-spool-current-method gnus-command-method)
(funcall (gnus-get-function gnus-command-method 'request-scan)
(and group (gnus-group-real-name group))
(nth 1 gnus-command-method)))))
-(defsubst gnus-request-update-info (info gnus-command-method)
+(defun gnus-request-update-info (info gnus-command-method)
+ (when (gnus-check-backend-function
+ 'request-update-info (car gnus-command-method))
+ (when (stringp gnus-command-method)
+ (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
+ (funcall (gnus-get-function gnus-command-method 'request-update-info)
+ (gnus-group-real-name (gnus-info-group info)) info
+ (nth 1 gnus-command-method))))
+
+(defsubst gnus-request-marks (info gnus-command-method)
"Request that GNUS-COMMAND-METHOD update INFO."
(when (stringp gnus-command-method)
(setq gnus-command-method (gnus-server-to-method gnus-command-method)))
(when (gnus-check-backend-function
- 'request-update-info (car gnus-command-method))
+ 'request-marks (car gnus-command-method))
(let ((group (gnus-info-group info)))
(and (funcall (gnus-get-function gnus-command-method
'request-update-info)
@@ -575,6 +645,7 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
(defun gnus-request-expire-articles (articles group &optional force)
(let* ((gnus-command-method (gnus-find-method-for-group group))
+ (gnus-inhibit-demon t)
(not-deleted
(funcall
(gnus-get-function gnus-command-method 'request-expire-articles)
@@ -593,7 +664,8 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
(result (funcall (gnus-get-function gnus-command-method
'request-move-article)
article (gnus-group-real-name group)
- (nth 1 gnus-command-method) accept-function last move-is-internal)))
+ (nth 1 gnus-command-method) accept-function
+ last move-is-internal)))
(when (and result gnus-agent
(gnus-agent-method-p gnus-command-method))
(gnus-agent-unfetch-articles group (list article)))
@@ -716,5 +788,4 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
(provide 'gnus-int)
-;; arch-tag: bbc90087-9b7f-4017-a92c-3abf180ac86d
;;; gnus-int.el ends here
diff --git a/lisp/gnus/gnus-kill.el b/lisp/gnus/gnus-kill.el
index e81d03207cb..17a6266c9b9 100644
--- a/lisp/gnus/gnus-kill.el
+++ b/lisp/gnus/gnus-kill.el
@@ -349,8 +349,7 @@ If NEWSGROUP is nil, return the global kill file instead."
(defun gnus-expunge (marks)
"Remove lines marked with MARKS."
- (save-excursion
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
(gnus-summary-limit-to-marks marks 'reverse)))
(defun gnus-apply-kill-file-unless-scored ()
@@ -442,8 +441,7 @@ Returns the number of articles marked as read."
(progn
(delete-region beg (point))
(insert (or (eval form) "")))
- (save-excursion
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
(ignore-errors (eval form)))))
(and (buffer-modified-p)
gnus-kill-save-kill-file
@@ -482,7 +480,7 @@ Returns the number of articles marked as read."
(or (cdr (assq modifier mod-to-header)) "subject")
pattern
(if (string-match "m" commands)
- '(gnus-summary-mark-as-unread nil " ")
+ '(gnus-summary-tick-article nil " ")
'(gnus-summary-mark-as-read nil "X"))
nil t))
(forward-line 1))))
@@ -555,8 +553,7 @@ COMMAND must be a Lisp expression or a string representing a key sequence."
(and (eq 'quote (car (nth 2 object)))
(not (consp (cdadr (nth 2 object))))))
(concat "\n" (gnus-prin1-to-string object))
- (save-excursion
- (set-buffer (gnus-get-buffer-create "*Gnus PP*"))
+ (with-current-buffer (gnus-get-buffer-create "*Gnus PP*")
(buffer-disable-undo)
(erase-buffer)
(insert (format "\n(%S %S\n '(" (nth 0 object) (nth 1 object)))
@@ -610,8 +607,7 @@ COMMAND must be a Lisp expression or a string representing a key sequence."
6 "Searching for article: %d..." (mail-header-number header))
(gnus-article-setup-buffer)
(gnus-article-prepare (mail-header-number header) t)
- (when (save-excursion
- (set-buffer gnus-article-buffer)
+ (when (with-current-buffer gnus-article-buffer
(goto-char (point-min))
(setq did-kill (re-search-forward regexp nil t)))
(cond ((stringp form) ;Keyboard macro.
@@ -715,5 +711,4 @@ Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score"
(provide 'gnus-kill)
-;; arch-tag: b30c0f53-df1a-490b-b81e-17b13474f395
;;; gnus-kill.el ends here
diff --git a/lisp/gnus/gnus-logic.el b/lisp/gnus/gnus-logic.el
index 6875c324cb2..9637ebfb387 100644
--- a/lisp/gnus/gnus-logic.el
+++ b/lisp/gnus/gnus-logic.el
@@ -179,8 +179,7 @@
(defun gnus-advanced-body (header match type)
(when (string= header "all")
(setq header "article"))
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(let* ((request-func (cond ((string= "head" header)
'gnus-request-head)
((string= "body" header)
@@ -225,5 +224,4 @@
(provide 'gnus-logic)
-;; arch-tag: 9651a100-4a59-4b69-a55b-e511e67c0f8d
;;; gnus-logic.el ends here
diff --git a/lisp/gnus/gnus-mh.el b/lisp/gnus/gnus-mh.el
index 67548d7cac6..7df4b466292 100644
--- a/lisp/gnus/gnus-mh.el
+++ b/lisp/gnus/gnus-mh.el
@@ -109,5 +109,4 @@ Otherwise, it is like +news/group."
(provide 'gnus-mh)
-;; arch-tag: 2d5696d3-b363-48e5-8749-c256be56acca
;;; gnus-mh.el ends here
diff --git a/lisp/gnus/gnus-ml.el b/lisp/gnus/gnus-ml.el
index 078a8cfa15c..5c42ef515fa 100644
--- a/lisp/gnus/gnus-ml.el
+++ b/lisp/gnus/gnus-ml.el
@@ -30,27 +30,25 @@
(require 'gnus)
(require 'gnus-msg)
(eval-when-compile (require 'cl))
+(eval-when-compile
+ (when (featurep 'xemacs)
+ (require 'easy-mmode))) ; for `define-minor-mode'
;;; Mailing list minor mode
-(defvar gnus-mailing-list-mode nil
- "Minor mode for providing mailing-list commands.")
-
-(defvar gnus-mailing-list-mode-map nil)
+(defvar gnus-mailing-list-mode-map
+ (let ((map (make-sparse-keymap)))
+ (gnus-define-keys map
+ "\C-c\C-nh" gnus-mailing-list-help
+ "\C-c\C-ns" gnus-mailing-list-subscribe
+ "\C-c\C-nu" gnus-mailing-list-unsubscribe
+ "\C-c\C-np" gnus-mailing-list-post
+ "\C-c\C-no" gnus-mailing-list-owner
+ "\C-c\C-na" gnus-mailing-list-archive)
+ map))
(defvar gnus-mailing-list-menu)
-(unless gnus-mailing-list-mode-map
- (setq gnus-mailing-list-mode-map (make-sparse-keymap))
-
- (gnus-define-keys gnus-mailing-list-mode-map
- "\C-c\C-nh" gnus-mailing-list-help
- "\C-c\C-ns" gnus-mailing-list-subscribe
- "\C-c\C-nu" gnus-mailing-list-unsubscribe
- "\C-c\C-np" gnus-mailing-list-post
- "\C-c\C-no" gnus-mailing-list-owner
- "\C-c\C-na" gnus-mailing-list-archive))
-
(defun gnus-mailing-list-make-menu-bar ()
(unless (boundp 'gnus-mailing-list-menu)
(easy-menu-define
@@ -87,22 +85,26 @@ If FORCE is non-nil, replace the old ones."
(gnus-mailing-list-mode 1))
(gnus-message 1 "no list-post in this message."))))
+(eval-when-compile
+ (when (featurep 'xemacs)
+ (defvar gnus-mailing-list-mode-hook)
+ (defvar gnus-mailing-list-mode-on-hook)
+ (defvar gnus-mailing-list-mode-off-hook)))
+
;;;###autoload
-(defun gnus-mailing-list-mode (&optional arg)
+(define-minor-mode gnus-mailing-list-mode
"Minor mode for providing mailing-list commands.
\\{gnus-mailing-list-mode-map}"
- (interactive "P")
- (when (eq major-mode 'gnus-summary-mode)
- (when (set (make-local-variable 'gnus-mailing-list-mode)
- (if (null arg) (not gnus-mailing-list-mode)
- (> (prefix-numeric-value arg) 0)))
- ;; Set up the menu.
- (when (gnus-visual-p 'mailing-list-menu 'menu)
- (gnus-mailing-list-make-menu-bar))
- (add-minor-mode 'gnus-mailing-list-mode " Mailing-List"
- gnus-mailing-list-mode-map)
- (gnus-run-hooks 'gnus-mailing-list-mode-hook))))
+ :lighter " Mailing-List"
+ :keymap gnus-mailing-list-mode-map
+ (cond
+ ((not (derived-mode-p 'gnus-summary-mode))
+ (setq gnus-mailing-list-mode nil))
+ (gnus-mailing-list-mode
+ ;; Set up the menu.
+ (when (gnus-visual-p 'mailing-list-menu 'menu)
+ (gnus-mailing-list-make-menu-bar)))))
;;; Commands
@@ -178,5 +180,4 @@ ADDRESS is specified by a \"mailto:\" URL."
(provide 'gnus-ml)
-;; arch-tag: 936c0fe6-acce-4c16-87d0-eded88078896
;;; gnus-ml.el ends here
diff --git a/lisp/gnus/gnus-mlspl.el b/lisp/gnus/gnus-mlspl.el
index fb2fa3511ad..509e391480c 100644
--- a/lisp/gnus/gnus-mlspl.el
+++ b/lisp/gnus/gnus-mlspl.el
@@ -227,5 +227,4 @@ Calling (gnus-group-split-fancy nil nil \"mail.others\") returns:
(provide 'gnus-mlspl)
-;; arch-tag: 62b3381f-1e45-4b61-be1a-29fb27703322
;;; gnus-mlspl.el ends here
diff --git a/lisp/gnus/gnus-move.el b/lisp/gnus/gnus-move.el
deleted file mode 100644
index 2c7a9585fec..00000000000
--- a/lisp/gnus/gnus-move.el
+++ /dev/null
@@ -1,181 +0,0 @@
-;;; gnus-move.el --- commands for moving Gnus from one server to another
-
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; Keywords: news
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-
-(require 'gnus)
-(require 'gnus-start)
-(require 'gnus-int)
-(require 'gnus-range)
-
-;;;
-;;; Moving by comparing Message-ID's.
-;;;
-
-;;;###autoload
-(defun gnus-change-server (from-server to-server)
- "Move from FROM-SERVER to TO-SERVER.
-Update the .newsrc.eld file to reflect the change of nntp server."
- (interactive
- (list gnus-select-method (gnus-read-method "Move to method: ")))
-
- ;; First start Gnus.
- (let ((gnus-activate-level 0)
- (mail-sources nil))
- (gnus))
-
- (save-excursion
- ;; Go through all groups and translate.
- (let ((nntp-nov-gap nil))
- (dolist (info gnus-newsrc-alist)
- (when (gnus-group-native-p (gnus-info-group info))
- (gnus-move-group-to-server info from-server to-server))))))
-
-(defun gnus-move-group-to-server (info from-server to-server)
- "Move group INFO from FROM-SERVER to TO-SERVER."
- (let ((group (gnus-info-group info))
- to-active hashtb type mark marks
- to-article to-reads to-marks article
- act-articles)
- (gnus-message 7 "Translating %s..." group)
- (when (gnus-request-group group nil to-server)
- (setq to-active (gnus-parse-active)
- hashtb (gnus-make-hashtable 1024)
- act-articles (gnus-uncompress-range to-active))
- ;; Fetch the headers from the `to-server'.
- (when (and to-active
- act-articles
- (setq type (gnus-retrieve-headers
- act-articles
- group to-server)))
- ;; Convert HEAD headers. I don't care.
- (when (eq type 'headers)
- (nnvirtual-convert-headers))
- ;; Create a mapping from Message-ID to article number.
- (set-buffer nntp-server-buffer)
- (goto-char (point-min))
- (while (looking-at
- "^[0-9]+\t[^\t]*\t[^\t]*\t[^\t]*\t\\([^\t]*\\)\t")
- (gnus-sethash
- (buffer-substring (match-beginning 1) (match-end 1))
- (read (current-buffer))
- hashtb)
- (forward-line 1))
- ;; Then we read the headers from the `from-server'.
- (when (and (gnus-request-group group nil from-server)
- (gnus-active group)
- (gnus-uncompress-range
- (gnus-active group))
- (setq type (gnus-retrieve-headers
- (gnus-uncompress-range
- (gnus-active group))
- group from-server)))
- ;; Make it easier to map marks.
- (let ((mark-lists (gnus-info-marks info))
- ms type m)
- (while mark-lists
- (setq type (caar mark-lists)
- ms (gnus-uncompress-range (cdr (pop mark-lists))))
- (while ms
- (if (setq m (assq (car ms) marks))
- (setcdr m (cons type (cdr m)))
- (push (list (car ms) type) marks))
- (pop ms))))
- ;; Convert.
- (when (eq type 'headers)
- (nnvirtual-convert-headers))
- ;; Go through the headers and map away.
- (set-buffer nntp-server-buffer)
- (goto-char (point-min))
- (while (looking-at
- "^[0-9]+\t[^\t]*\t[^\t]*\t[^\t]*\t\\([^\t]*\\)\t")
- (when (setq to-article
- (gnus-gethash
- (buffer-substring (match-beginning 1) (match-end 1))
- hashtb))
- ;; Add this article to the list of read articles.
- (push to-article to-reads)
- ;; See if there are any marks and then add them.
- (when (setq mark (assq (read (current-buffer)) marks))
- (setq marks (delq mark marks))
- (setcar mark to-article)
- (push mark to-marks))
- (forward-line 1)))
- ;; Now we know what the read articles are and what the
- ;; article marks are. We transform the information
- ;; into the Gnus info format.
- (setq to-reads
- (gnus-range-add
- (gnus-compress-sequence
- (and (setq to-reads (delq nil to-reads))
- (sort to-reads '<))
- t)
- (cons 1 (1- (car to-active)))))
- (gnus-info-set-read info to-reads)
- ;; Do the marks. I'm sure y'all understand what's
- ;; going on down below, so I won't bother with any
- ;; further comments. <duck>
- (let ((mlists gnus-article-mark-lists)
- lists ms a)
- (while mlists
- (push (list (cdr (pop mlists))) lists))
- (while (setq ms (pop marks))
- (setq article (pop ms))
- (while ms
- (setcdr (setq a (assq (pop ms) lists))
- (cons article (cdr a)))))
- (setq a lists)
- (while a
- (setcdr (car a) (gnus-compress-sequence
- (and (cdar a) (sort (cdar a) '<))))
- (pop a))
- (gnus-info-set-marks info lists t)))))
- (gnus-message 7 "Translating %s...done" group)))
-
-(defun gnus-group-move-group-to-server (info from-server to-server)
- "Move the group on the current line from FROM-SERVER to TO-SERVER."
- (interactive
- (let ((info (gnus-get-info (gnus-group-group-name))))
- (list info (gnus-find-method-for-group (gnus-info-group info))
- (gnus-read-method (format "Move group %s to method: "
- (gnus-info-group info))))))
- (save-excursion
- (gnus-move-group-to-server info from-server to-server)
- ;; We have to update the group info to point use the right server.
- (gnus-info-set-method info to-server t)
- ;; We also have to change the name of the group and stuff.
- (let* ((group (gnus-info-group info))
- (new-name (gnus-group-prefixed-name
- (gnus-group-real-name group) to-server)))
- (gnus-info-set-group info new-name)
- (gnus-sethash new-name (gnus-group-entry group) gnus-newsrc-hashtb)
- (gnus-sethash group nil gnus-newsrc-hashtb))))
-
-(provide 'gnus-move)
-
-;; arch-tag: 503742b8-7d66-4d79-bb31-4a698070707b
-;;; gnus-move.el ends here
diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el
index f314d33c6d6..544aa7776a8 100644
--- a/lisp/gnus/gnus-msg.el
+++ b/lisp/gnus/gnus-msg.el
@@ -420,7 +420,7 @@ Thank you for your help in stamping out bugs.
;; There may be an old " *gnus article copy*" buffer.
(let (gnus-article-copy)
(gnus-configure-posting-styles ,group)))))
- (gnus-pull ',(intern gnus-draft-meta-information-header)
+ (gnus-alist-pull ',(intern gnus-draft-meta-information-header)
message-required-headers)
(when (and ,group
(not (string= ,group "")))
@@ -578,8 +578,8 @@ If ARG is 1, prompt for a group name to find the posting style."
(if arg
(if (= 1 (prefix-numeric-value arg))
(gnus-group-completing-read
- "Use posting style of group: "
- nil nil (gnus-read-active-file-p))
+ "Use posting style of group"
+ nil (gnus-read-active-file-p))
(gnus-group-group-name))
""))
;; #### see comment in gnus-setup-message -- drv
@@ -607,8 +607,8 @@ network. The corresponding back end must have a 'request-post method."
(setq gnus-newsgroup-name
(if arg
(if (= 1 (prefix-numeric-value arg))
- (gnus-group-completing-read "Use group: "
- nil nil
+ (gnus-group-completing-read "Use group"
+ nil
(gnus-read-active-file-p))
(gnus-group-group-name))
""))
@@ -628,7 +628,7 @@ a news."
(let ((gnus-newsgroup-name
(if arg
(if (= 1 (prefix-numeric-value arg))
- (gnus-group-completing-read "Newsgroup: " nil nil
+ (gnus-group-completing-read "Newsgroup" nil
(gnus-read-active-file-p))
(gnus-group-group-name))
""))
@@ -654,8 +654,8 @@ posting style."
(setq gnus-newsgroup-name
(if arg
(if (= 1 (prefix-numeric-value arg))
- (gnus-group-completing-read "Use group: "
- nil nil
+ (gnus-group-completing-read "Use group"
+ nil
(gnus-read-active-file-p))
"")
gnus-newsgroup-name))
@@ -684,8 +684,8 @@ network. The corresponding back end must have a 'request-post method."
(setq gnus-newsgroup-name
(if arg
(if (= 1 (prefix-numeric-value arg))
- (gnus-group-completing-read "Use group: "
- nil nil
+ (gnus-group-completing-read "Use group"
+ nil
(gnus-read-active-file-p))
"")
gnus-newsgroup-name))
@@ -710,7 +710,7 @@ a news."
(let ((gnus-newsgroup-name
(if arg
(if (= 1 (prefix-numeric-value arg))
- (gnus-group-completing-read "Newsgroup: " nil nil
+ (gnus-group-completing-read "Newsgroup" nil
(gnus-read-active-file-p))
"")
gnus-newsgroup-name))
@@ -1028,8 +1028,8 @@ If SILENT, don't prompt the user."
gnus-last-posting-server)
;; Just use the last value.
gnus-last-posting-server
- (completing-read
- "Posting method: " method-alist nil t
+ (gnus-completing-read
+ "Posting method" (mapcar 'car method-alist) t
(cons (or gnus-last-posting-server "") 0))))
method-alist))))
;; Override normal method.
@@ -1265,7 +1265,8 @@ For the `inline' alternatives, also see the variable
(dolist (article (gnus-summary-work-articles n))
(gnus-summary-select-article nil nil nil article)
(with-current-buffer gnus-original-article-buffer
- (message-resend address))
+ (let ((gnus-gcc-externalize-attachments nil))
+ (message-resend address)))
(gnus-summary-mark-article-as-forwarded article)))
;; From: Matthieu Moy <Matthieu.Moy@imag.fr>
@@ -1487,7 +1488,7 @@ If YANK is non-nil, include the original article."
(defun gnus-summary-yank-message (buffer n)
"Yank the current article into a composed message."
(interactive
- (list (completing-read "Buffer: " (mapcar 'list (message-buffers)) nil t)
+ (list (gnus-completing-read "Buffer" (message-buffers) t)
current-prefix-arg))
(gnus-summary-iterate n
(let ((gnus-inhibit-treatment t))
@@ -1627,7 +1628,7 @@ this is a reply."
(unless (gnus-check-server method)
(error "Can't open server %s" (if (stringp method) method
(car method))))
- (unless (gnus-request-group group nil method)
+ (unless (gnus-request-group group t method)
(gnus-request-create-group group method))
(setq mml-externalize-attachments
(if (stringp gnus-gcc-externalize-attachments)
@@ -1890,7 +1891,11 @@ this is a reply."
(setq v
(cond
((stringp value)
- value)
+ (if (and (stringp match)
+ (gnus-string-match-p "\\\\[&[:digit:]]" value)
+ (match-beginning 1))
+ (gnus-match-substitute-replacement value nil nil group)
+ value))
((or (symbolp value)
(functionp value))
(cond ((functionp value)
@@ -1989,5 +1994,4 @@ this is a reply."
(provide 'gnus-msg)
-;; arch-tag: 9f22b2f5-1c0a-49de-916e-4c88e984852b
;;; gnus-msg.el ends here
diff --git a/lisp/gnus/gnus-nocem.el b/lisp/gnus/gnus-nocem.el
deleted file mode 100644
index c6c396d7af0..00000000000
--- a/lisp/gnus/gnus-nocem.el
+++ /dev/null
@@ -1,453 +0,0 @@
-;;; gnus-nocem.el --- NoCeM pseudo-cancellation treatment
-
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; Keywords: news
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-
-(require 'gnus)
-(require 'nnmail)
-(require 'gnus-art)
-(require 'gnus-sum)
-(require 'gnus-range)
-
-(defgroup gnus-nocem nil
- "NoCeM pseudo-cancellation treatment."
- :group 'gnus-score)
-
-(defcustom gnus-nocem-groups
- '("news.lists.filters" "alt.nocem.misc")
- "*List of groups that will be searched for NoCeM messages."
- :group 'gnus-nocem
- :version "23.1"
- :type '(repeat (string :tag "Group")))
-
-(defcustom gnus-nocem-issuers
- '("Adri Verhoef"
- "alba-nocem@albasani.net"
- "bleachbot@httrack.com"
- "news@arcor-online.net"
- "news@uni-berlin.de"
- "nocem@arcor.de"
- "pgpmoose@killfile.org"
- "xjsppl@gmx.de")
- "*List of NoCeM issuers to pay attention to.
-
-This can also be a list of `(ISSUER CONDITION ...)' elements.
-
-See <URL:http://www.xs4all.nl/~rosalind/nocemreg/nocemreg.html> for an
-issuer registry."
- :group 'gnus-nocem
- :link '(url-link "http://www.xs4all.nl/~rosalind/nocemreg/nocemreg.html")
- :version "23.1"
- :type '(repeat (cons :format "%v" (string :tag "Issuer")
- (repeat :tag "Condition"
- (group (checklist :inline t (const not))
- (regexp :tag "Type" :value ".*")))))
- :get (lambda (symbol)
- (mapcar (lambda (elem)
- (if (consp elem)
- (cons (car elem)
- (mapcar (lambda (elt)
- (if (consp elt) elt (list elt)))
- (cdr elem)))
- (list elem)))
- (default-value symbol)))
- :set (lambda (symbol value)
- (custom-set-default
- symbol
- (mapcar (lambda (elem)
- (if (consp elem)
- (if (cdr elem)
- (mapcar (lambda (elt)
- (if (consp elt)
- (if (cdr elt) elt (car elt))
- elt))
- elem)
- (car elem))
- elem))
- value))))
-
-(defcustom gnus-nocem-directory
- (nnheader-concat gnus-article-save-directory "NoCeM/")
- "*Directory where NoCeM files will be stored."
- :group 'gnus-nocem
- :type 'directory)
-
-(defcustom gnus-nocem-expiry-wait 15
- "*Number of days to keep NoCeM headers in the cache."
- :group 'gnus-nocem
- :type 'integer)
-
-(defcustom gnus-nocem-verifyer (if (locate-library "epg")
- 'gnus-nocem-epg-verify
- 'pgg-verify)
- "*Function called to verify that the NoCeM message is valid.
-If the function in this variable isn't bound, the message will be used
-unconditionally."
- :group 'gnus-nocem
- :version "23.1"
- :type '(radio (function-item gnus-nocem-epg-verify)
- (function-item pgg-verify)
- (function-item mc-verify)
- (function :tag "other"))
- :set (lambda (symbol value)
- (custom-set-default symbol
- (if (and (eq value 'gnus-nocem-epg-verify)
- (not (locate-library "epg")))
- 'pgg-verify
- value))))
-
-(defcustom gnus-nocem-liberal-fetch nil
- "*If t try to fetch all messages which have @@NCM in the subject.
-Otherwise don't fetch messages which have references or whose message-id
-matches a previously scanned and verified nocem message."
- :group 'gnus-nocem
- :type 'boolean)
-
-(defcustom gnus-nocem-check-article-limit 500
- "*If non-nil, the maximum number of articles to check in any NoCeM group."
- :group 'gnus-nocem
- :version "21.1"
- :type '(choice (const :tag "unlimited" nil)
- (integer 1000)))
-
-(defcustom gnus-nocem-check-from t
- "Non-nil means check for valid issuers in message bodies.
-Otherwise don't bother fetching articles unless their author matches a
-valid issuer, which is much faster if you are selective about the issuers."
- :group 'gnus-nocem
- :version "21.1"
- :type 'boolean)
-
-;;; Internal variables
-
-(defvar gnus-nocem-active nil)
-(defvar gnus-nocem-alist nil)
-(defvar gnus-nocem-touched-alist nil)
-(defvar gnus-nocem-hashtb nil)
-(defvar gnus-nocem-seen-message-ids nil)
-
-;;; Functions
-
-(defun gnus-nocem-active-file ()
- (concat (file-name-as-directory gnus-nocem-directory) "active"))
-
-(defun gnus-nocem-cache-file ()
- (concat (file-name-as-directory gnus-nocem-directory) "cache"))
-
-;;
-;; faster lookups for group names:
-;;
-
-(defvar gnus-nocem-real-group-hashtb nil
- "Real-name mappings of subscribed groups.")
-
-(defun gnus-fill-real-hashtb ()
- "Fill up a hash table with the real-name mappings from the user's active file."
- (if (hash-table-p gnus-nocem-real-group-hashtb)
- (clrhash gnus-nocem-real-group-hashtb)
- (setq gnus-nocem-real-group-hashtb (make-hash-table :test 'equal)))
- (mapcar (lambda (group)
- (setq group (gnus-group-real-name (car group)))
- (puthash group t gnus-nocem-real-group-hashtb))
- gnus-newsrc-alist))
-
-;;;###autoload
-(defun gnus-nocem-scan-groups ()
- "Scan all NoCeM groups for new NoCeM messages."
- (interactive)
- (let ((groups gnus-nocem-groups)
- (gnus-inhibit-demon t)
- group active gactive articles check-headers)
- (gnus-make-directory gnus-nocem-directory)
- ;; Load any previous NoCeM headers.
- (gnus-nocem-load-cache)
- ;; Get the group name mappings:
- (gnus-fill-real-hashtb)
- ;; Read the active file if it hasn't been read yet.
- (and (file-exists-p (gnus-nocem-active-file))
- (not gnus-nocem-active)
- (ignore-errors
- (load (gnus-nocem-active-file) t t t)))
- ;; Go through all groups and see whether new articles have
- ;; arrived.
- (while (setq group (pop groups))
- (if (not (setq gactive (gnus-activate-group group)))
- () ; This group doesn't exist.
- (setq active (nth 1 (assoc group gnus-nocem-active)))
- (when (and (not (< (cdr gactive) (car gactive))) ; Empty group.
- (or (not active)
- (< (cdr active) (cdr gactive))))
- ;; Ok, there are new articles in this group, se we fetch the
- ;; headers.
- (save-excursion
- (let ((dependencies (make-vector 10 nil))
- headers header)
- (with-temp-buffer
- (setq headers
- (if (eq 'nov
- (gnus-retrieve-headers
- (setq articles
- (gnus-uncompress-range
- (cons
- (if active (1+ (cdr active))
- (car gactive))
- (cdr gactive))))
- group))
- (gnus-get-newsgroup-headers-xover
- articles nil dependencies)
- (gnus-get-newsgroup-headers dependencies)))
- (while (setq header (pop headers))
- ;; We take a closer look on all articles that have
- ;; "@@NCM" in the subject. Unless we already read
- ;; this cross posted message. Nocem messages
- ;; are not allowed to have references, so we can
- ;; ignore scanning followups.
- (and (string-match "@@NCM" (mail-header-subject header))
- (and gnus-nocem-check-from
- (let ((case-fold-search t))
- (catch 'ok
- (mapc
- (lambda (author)
- (if (consp author)
- (setq author (car author)))
- (if (string-match
- author (mail-header-from header))
- (throw 'ok t)))
- gnus-nocem-issuers)
- nil)))
- (or gnus-nocem-liberal-fetch
- (and (or (string= "" (mail-header-references
- header))
- (null (mail-header-references header)))
- (not (member (mail-header-message-id header)
- gnus-nocem-seen-message-ids))))
- (push header check-headers)))
- (setq check-headers (last (nreverse check-headers)
- gnus-nocem-check-article-limit))
- (let ((i 0)
- (len (length check-headers)))
- (dolist (h check-headers)
- (gnus-message
- 7 "Checking article %d in %s for NoCeM (%d of %d)..."
- (mail-header-number h) group (incf i) len)
- (gnus-nocem-check-article group h)))))))
- (setq gnus-nocem-active
- (cons (list group gactive)
- (delq (assoc group gnus-nocem-active)
- gnus-nocem-active)))))
- ;; Save the results, if any.
- (gnus-nocem-save-cache)
- (gnus-nocem-save-active)))
-
-(defun gnus-nocem-check-article (group header)
- "Check whether the current article is an NCM article and that we want it."
- ;; Get the article.
- (let ((date (mail-header-date header))
- (gnus-newsgroup-name group)
- issuer b e type)
- (when (or (not date)
- (time-less-p
- (time-since (date-to-time date))
- (days-to-time gnus-nocem-expiry-wait)))
- (gnus-request-article-this-buffer (mail-header-number header) group)
- (goto-char (point-min))
- (when (re-search-forward
- "-----BEGIN PGP\\(?: SIGNED\\)? MESSAGE-----"
- nil t)
- (delete-region (point-min) (match-beginning 0)))
- (when (re-search-forward
- "-----END PGP \\(?:MESSAGE\\|SIGNATURE\\)-----\n?"
- nil t)
- (delete-region (match-end 0) (point-max)))
- (goto-char (point-min))
- ;; The article has to have proper NoCeM headers.
- (when (and (setq b (search-forward "\n@@BEGIN NCM HEADERS\n" nil t))
- (setq e (search-forward "\n@@BEGIN NCM BODY\n" nil t)))
- ;; We get the name of the issuer.
- (narrow-to-region b e)
- (setq issuer (mail-fetch-field "issuer")
- type (mail-fetch-field "type"))
- (widen)
- (if (not (gnus-nocem-message-wanted-p issuer type))
- (message "invalid NoCeM issuer: %s" issuer)
- (and (gnus-nocem-verify-issuer issuer) ; She is who she says she is.
- (gnus-nocem-enter-article) ; We gobble the message.
- (push (mail-header-message-id header) ; But don't come back for
- gnus-nocem-seen-message-ids))))))) ; second helpings.
-
-(defun gnus-nocem-message-wanted-p (issuer type)
- (let ((issuers gnus-nocem-issuers)
- wanted conditions condition)
- (cond
- ;; Do the quick check first.
- ((member issuer issuers)
- t)
- ((setq conditions (cdr (assoc issuer issuers)))
- ;; Check whether we want this type.
- (while (setq condition (pop conditions))
- (cond
- ((stringp condition)
- (when (string-match condition type)
- (setq wanted t)))
- ((and (consp condition)
- (eq (car condition) 'not)
- (stringp (cadr condition)))
- (when (string-match (cadr condition) type)
- (setq wanted nil)))
- (t
- (error "Invalid NoCeM condition: %S" condition))))
- wanted))))
-
-(defun gnus-nocem-verify-issuer (person)
- "Verify using PGP that the canceler is who she says she is."
- (if (functionp gnus-nocem-verifyer)
- (ignore-errors
- (funcall gnus-nocem-verifyer))
- ;; If we don't have Mailcrypt, then we use the message anyway.
- t))
-
-(defun gnus-nocem-enter-article ()
- "Enter the current article into the NoCeM cache."
- (goto-char (point-min))
- (let ((b (search-forward "\n@@BEGIN NCM BODY\n" nil t))
- (e (search-forward "\n@@END NCM BODY\n" nil t))
- (buf (current-buffer))
- ncm id group)
- (when (and b e)
- (narrow-to-region b (1+ (match-beginning 0)))
- (goto-char (point-min))
- (while (search-forward "\t" nil t)
- (cond
- ((not (ignore-errors
- (setq group (gnus-group-real-name (symbol-name (read buf))))
- (gethash group gnus-nocem-real-group-hashtb)))
- ;; An error.
- )
- (t
- ;; Valid group.
- (beginning-of-line)
- (while (eq (char-after) ?\t)
- (forward-line -1))
- (setq id (buffer-substring (point) (1- (search-forward "\t"))))
- (unless (if (hash-table-p gnus-nocem-hashtb)
- (gethash id gnus-nocem-hashtb)
- (setq gnus-nocem-hashtb (make-hash-table :test 'equal))
- nil)
- ;; only store if not already present
- (puthash id t gnus-nocem-hashtb)
- (push id ncm))
- (forward-line 1)
- (while (eq (char-after) ?\t)
- (forward-line 1)))))
- (when ncm
- (setq gnus-nocem-touched-alist t)
- (push (cons (let ((time (current-time))) (setcdr (cdr time) nil) time)
- ncm)
- gnus-nocem-alist))
- t)))
-
-;;;###autoload
-(defun gnus-nocem-load-cache ()
- "Load the NoCeM cache."
- (interactive)
- (unless gnus-nocem-alist
- ;; The buffer doesn't exist, so we create it and load the NoCeM
- ;; cache.
- (when (file-exists-p (gnus-nocem-cache-file))
- (load (gnus-nocem-cache-file) t t t)
- (gnus-nocem-alist-to-hashtb))))
-
-(defun gnus-nocem-save-cache ()
- "Save the NoCeM cache."
- (when (and gnus-nocem-alist
- gnus-nocem-touched-alist)
- (with-temp-file (gnus-nocem-cache-file)
- (gnus-prin1 `(setq gnus-nocem-alist ',gnus-nocem-alist)))
- (setq gnus-nocem-touched-alist nil)))
-
-(defun gnus-nocem-save-active ()
- "Save the NoCeM active file."
- (with-temp-file (gnus-nocem-active-file)
- (gnus-prin1 `(setq gnus-nocem-active ',gnus-nocem-active))))
-
-(defun gnus-nocem-alist-to-hashtb ()
- "Create a hashtable from the Message-IDs we have."
- (let* ((alist gnus-nocem-alist)
- (pprev (cons nil alist))
- (prev pprev)
- (expiry (days-to-time gnus-nocem-expiry-wait))
- entry)
- (if (hash-table-p gnus-nocem-hashtb)
- (clrhash gnus-nocem-hashtb)
- (setq gnus-nocem-hashtb (make-hash-table :test 'equal)))
- (while (setq entry (car alist))
- (if (not (time-less-p (time-since (car entry)) expiry))
- ;; This entry has expired, so we remove it.
- (setcdr prev (cdr alist))
- (setq prev alist)
- ;; This is ok, so we enter it into the hashtable.
- (setq entry (cdr entry))
- (while entry
- (puthash (car entry) t gnus-nocem-hashtb)
- (setq entry (cdr entry))))
- (setq alist (cdr alist)))))
-
-(gnus-add-shutdown 'gnus-nocem-close 'gnus)
-
-(defun gnus-nocem-close ()
- "Clear internal NoCeM variables."
- (setq gnus-nocem-alist nil
- gnus-nocem-hashtb nil
- gnus-nocem-active nil
- gnus-nocem-touched-alist nil
- gnus-nocem-seen-message-ids nil
- gnus-nocem-real-group-hashtb nil))
-
-(defun gnus-nocem-unwanted-article-p (id)
- "Say whether article ID in the current group is wanted."
- (and gnus-nocem-hashtb
- (gethash id gnus-nocem-hashtb)))
-
-(autoload 'epg-make-context "epg")
-(eval-when-compile
- (autoload 'epg-verify-string "epg")
- (autoload 'epg-context-result-for "epg")
- (autoload 'epg-signature-status "epg"))
-
-(defun gnus-nocem-epg-verify ()
- "Return t if EasyPG verifies a signed message in the current buffer."
- (let ((context (epg-make-context 'OpenPGP))
- result)
- (epg-verify-string context (buffer-string))
- (and (setq result (epg-context-result-for context 'verify))
- (not (cdr result))
- (eq (epg-signature-status (car result)) 'good))))
-
-(provide 'gnus-nocem)
-
-;; arch-tag: 0e0c74ea-2f8e-4f3e-8fff-09f767c1adef
-;;; gnus-nocem.el ends here
diff --git a/lisp/gnus/gnus-picon.el b/lisp/gnus/gnus-picon.el
index 0b3b3b5c6a2..d24f04e0215 100644
--- a/lisp/gnus/gnus-picon.el
+++ b/lisp/gnus/gnus-picon.el
@@ -38,7 +38,7 @@
;;
;;; Code:
-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
@@ -85,23 +85,14 @@ added right to the textual representation."
(const right))
:group 'gnus-picon)
-(defface gnus-picon-xbm '((t (:foreground "black" :background "white")))
- "Face to show xbm picon in."
+(defcustom gnus-picon-inhibit-top-level-domains t
+ "If non-nil, don't piconify top-level domains.
+These are often not very interesting."
+ :type 'boolean
:group 'gnus-picon)
-;; backward-compatibility alias
-(put 'gnus-picon-xbm-face 'face-alias 'gnus-picon-xbm)
-(put 'gnus-picon-xbm-face 'obsolete-face "22.1")
-
-(defface gnus-picon '((t (:foreground "black" :background "white")))
- "Face to show picon in."
- :group 'gnus-picon)
-;; backward-compatibility alias
-(put 'gnus-picon-face 'face-alias 'gnus-picon)
-(put 'gnus-picon-face 'obsolete-face "22.1")
;;; Internal variables:
-(defvar gnus-picon-setup-p nil)
(defvar gnus-picon-glyph-alist nil
"Picon glyphs cache.
List of pairs (KEY . GLYPH) where KEY is either a filename or an URL.")
@@ -166,7 +157,9 @@ replacement is added."
(defun gnus-picon-create-glyph (file)
(or (cdr (assoc file gnus-picon-glyph-alist))
- (cdar (push (cons file (gnus-create-image file))
+ (cdar (push (cons file (gnus-create-image
+ file nil nil
+ :color-symbols '(("None" . "white"))))
gnus-picon-glyph-alist))))
;;; Functions that does picon transformations:
@@ -201,7 +194,9 @@ replacement is added."
(setcar spec (cons (gnus-picon-create-glyph file)
(car spec))))
- (dotimes (i (1- (length spec)))
+ (dotimes (i (- (length spec)
+ (if gnus-picon-inhibit-top-level-domains
+ 2 1)))
(when (setq file (gnus-picon-find-face
(concat "unknown@"
(mapconcat
@@ -319,5 +314,4 @@ If picons are already displayed, remove them."
(provide 'gnus-picon)
-;; arch-tag: fe9aede0-1b1b-463a-b4ab-807f98bcb31f
;;; gnus-picon.el ends here
diff --git a/lisp/gnus/gnus-range.el b/lisp/gnus/gnus-range.el
index 78b05929deb..a4262df5328 100644
--- a/lisp/gnus/gnus-range.el
+++ b/lisp/gnus/gnus-range.el
@@ -59,6 +59,36 @@ If RANGE is a single range, return (RANGE). Otherwise, return RANGE."
(setq list2 (cdr list2)))
list1))
+(defun gnus-range-nconcat (&rest ranges)
+ "Return a range comprising all the RANGES, which are pre-sorted.
+RANGES will be destructively altered."
+ (setq ranges (delete nil ranges))
+ (let* ((result (gnus-range-normalize (pop ranges)))
+ (last (last result)))
+ (dolist (range ranges)
+ (setq range (gnus-range-normalize range))
+ ;; Normalize the single-number case, so that we don't need to
+ ;; special-case that so much.
+ (when (numberp (car last))
+ (setcar last (cons (car last) (car last))))
+ (when (numberp (car range))
+ (setcar range (cons (car range) (car range))))
+ (if (= (1+ (cdar last)) (caar range))
+ (progn
+ (setcdr (car last) (cdar range))
+ (setcdr last (cdr range)))
+ (setcdr last range)
+ ;; Denormalize back, since we couldn't join the ranges up.
+ (when (= (caar range) (cdar range))
+ (setcar range (caar range)))
+ (when (= (caar last) (cdar last))
+ (setcar last (caar last))))
+ (setq last (last last)))
+ (if (and (consp (car result))
+ (= (length result) 1))
+ (car result)
+ result)))
+
(defun gnus-range-difference (range1 range2)
"Return the range of elements in RANGE1 that do not appear in RANGE2.
Both ranges must be in ascending order."
@@ -187,7 +217,7 @@ LIST1 and LIST2 have to be sorted over <."
RANGE1 and RANGE2 have to be sorted over <."
(let* (out
(min1 (car range1))
- (max1 (if (numberp min1)
+ (max1 (if (numberp min1)
(if (numberp (cdr range1))
(prog1 (cdr range1)
(setq range1 nil)) min1)
@@ -196,8 +226,8 @@ RANGE1 and RANGE2 have to be sorted over <."
(min2 (car range2))
(max2 (if (numberp min2)
(if (numberp (cdr range2))
- (prog1 (cdr range2)
- (setq range2 nil)) min2)
+ (prog1 (cdr range2)
+ (setq range2 nil)) min2)
(prog1 (cdr min2)
(setq min2 (car min2))))))
(setq range1 (cdr range1)
@@ -654,5 +684,4 @@ LIST is a sorted list."
(provide 'gnus-range)
-;; arch-tag: 4780bdd8-5a15-4aff-be28-18727895b6ad
;;; gnus-range.el ends here
diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el
index e77b66e150d..79080f21b7a 100644
--- a/lisp/gnus/gnus-registry.el
+++ b/lisp/gnus/gnus-registry.el
@@ -1,6 +1,6 @@
;;; gnus-registry.el --- article registry for Gnus
-;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
;;; Free Software Foundation, Inc.
;; Author: Ted Zlatanov <tzz@lifelogs.com>
@@ -45,6 +45,9 @@
;; (: gnus-registry-split-fancy-with-parent)
+;; You should also consider using the nnregistry backend to look up
+;; articles. See the Gnus manual for more information.
+
;; TODO:
;; - get the correct group on spool actions
@@ -60,6 +63,7 @@
(require 'gnus-sum)
(require 'gnus-util)
(require 'nnmail)
+(require 'easymenu)
(defvar gnus-adaptive-word-syntax-table)
@@ -71,7 +75,7 @@
:version "22.1"
:group 'gnus)
-(defvar gnus-registry-hashtb (make-hash-table
+(defvar gnus-registry-hashtb (make-hash-table
:size 256
:test 'equal)
"*The article registry by Message ID.")
@@ -96,7 +100,7 @@
"List of registry marks and their options.
`gnus-registry-mark-article' will offer symbols from this list
-for completion.
+for completion.
Each entry must have a character to be useful for summary mode
line display and for keyboard shortcuts.
@@ -120,13 +124,15 @@ display."
:group 'gnus-registry
:type 'symbol)
-(defcustom gnus-registry-unfollowed-groups
- '("delayed$" "drafts$" "queue$" "INBOX$")
+(defcustom gnus-registry-unfollowed-groups
+ '("delayed$" "drafts$" "queue$" "INBOX$" "^nnmairix:")
"List of groups that gnus-registry-split-fancy-with-parent won't return.
The group names are matched, they don't have to be fully
qualified. This parameter tells the Registry 'never split a
message into a group that matches one of these, regardless of
-references.'"
+references.'
+
+nnmairix groups are specifically excluded because they are ephemeral."
:group 'gnus-registry
:type '(repeat regexp))
@@ -137,6 +143,10 @@ references.'"
(const :tag "Always Install" t)
(const :tag "Ask Me" ask)))
+(defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning.
+
+(defvar gnus-registry-misc-menus nil) ; ugly way to keep the menus
+
(defcustom gnus-registry-clean-empty t
"Whether the empty registry entries should be deleted.
Registry entries are considered empty when they have no groups
@@ -201,9 +211,9 @@ considered precious) will not be trimmed."
:group 'gnus-registry
:type '(repeat symbol))
-(defcustom gnus-registry-cache-file
- (nnheader-concat
- (or gnus-dribble-directory gnus-home-directory "~/")
+(defcustom gnus-registry-cache-file
+ (nnheader-concat
+ (or gnus-dribble-directory gnus-home-directory "~/")
".gnus.registry.eld")
"File where the Gnus registry will be stored."
:group 'gnus-registry
@@ -236,8 +246,7 @@ considered precious) will not be trimmed."
"Save the registry cache file."
(interactive)
(let ((file gnus-registry-cache-file))
- (save-excursion
- (set-buffer (gnus-get-buffer-create " *Gnus-registry-cache*"))
+ (with-current-buffer (gnus-get-buffer-create " *Gnus-registry-cache*")
(make-local-variable 'version-control)
(setq version-control gnus-backup-startup-file)
(setq buffer-file-name file)
@@ -248,7 +257,7 @@ considered precious) will not be trimmed."
(if gnus-save-startup-file-via-temp-buffer
(let ((coding-system-for-write gnus-ding-file-coding-system)
(standard-output (current-buffer)))
- (gnus-gnus-to-quick-newsrc-format
+ (gnus-gnus-to-quick-newsrc-format
t "gnus registry startup file" 'gnus-registry-alist)
(gnus-registry-cache-whitespace file)
(save-buffer))
@@ -271,7 +280,7 @@ considered precious) will not be trimmed."
(unwind-protect
(progn
(gnus-with-output-to-file working-file
- (gnus-gnus-to-quick-newsrc-format
+ (gnus-gnus-to-quick-newsrc-format
t "gnus registry startup file" 'gnus-registry-alist))
;; These bindings will mislead the current buffer
@@ -321,7 +330,7 @@ considered precious) will not be trimmed."
(when gnus-registry-clean-empty
(gnus-registry-clean-empty-function))
;; now trim and clean text properties from the registry appropriately
- (setq gnus-registry-alist
+ (setq gnus-registry-alist
(gnus-registry-remove-alist-text-properties
(gnus-registry-trim
(gnus-hashtable-to-alist
@@ -341,7 +350,7 @@ considered precious) will not be trimmed."
(dolist (group (gnus-registry-fetch-groups key))
(when (gnus-parameter-registry-ignore group)
(gnus-message
- 10
+ 10
"gnus-registry: deleted ignored group %s from key %s"
group key)
(gnus-registry-delete-group key group)))
@@ -356,14 +365,14 @@ considered precious) will not be trimmed."
(gnus-registry-fetch-extra key 'label))
(incf count)
(gnus-registry-delete-id key))
-
+
(unless (stringp key)
- (gnus-message
- 10
- "gnus-registry key %s was not a string, removing"
+ (gnus-message
+ 10
+ "gnus-registry key %s was not a string, removing"
key)
(gnus-registry-delete-id key))))
-
+
gnus-registry-hashtb)
count))
@@ -386,7 +395,7 @@ considered precious) will not be trimmed."
(defun gnus-registry-trim (alist)
"Trim alist to size, using gnus-registry-max-entries.
Any entries with extra data (marks, currently) are left alone."
- (if (null gnus-registry-max-entries)
+ (if (null gnus-registry-max-entries)
alist ; just return the alist
;; else, when given max-entries, trim the alist
(let* ((timehash (make-hash-table
@@ -415,25 +424,25 @@ Any entries with extra data (marks, currently) are left alone."
(push item precious-list)
(push item junk-list))))
- (sort
+ (sort
junk-list
(lambda (a b)
- (let ((t1 (or (cdr (gethash (car a) timehash))
+ (let ((t1 (or (cdr (gethash (car a) timehash))
'(0 0 0)))
- (t2 (or (cdr (gethash (car b) timehash))
+ (t2 (or (cdr (gethash (car b) timehash))
'(0 0 0))))
(time-less-p t1 t2))))
;; we use the return value of this setq, which is the trimmed alist
(setq alist (append precious-list
(nthcdr trim-length junk-list))))))
-
+
(defun gnus-registry-action (action data-header from &optional to method)
(let* ((id (mail-header-id data-header))
(subject (gnus-string-remove-all-properties
(gnus-registry-simplify-subject
(mail-header-subject data-header))))
- (sender (gnus-string-remove-all-properties
+ (sender (gnus-string-remove-all-properties
(mail-header-from data-header)))
(from (gnus-group-guess-full-name-from-command-method from))
(to (if to (gnus-group-guess-full-name-from-command-method to) nil))
@@ -484,7 +493,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(let* ((refstr (or (message-fetch-field "references") "")) ; guaranteed
(reply-to (message-fetch-field "in-reply-to")) ; may be nil
;; now, if reply-to is valid, append it to the References
- (refstr (if reply-to
+ (refstr (if reply-to
(concat refstr " " reply-to)
refstr))
;; these may not be used, but the code is cleaner having them up here
@@ -512,8 +521,8 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
9
"%s is looking for matches for reference %s from [%s]"
log-agent reference refstr)
- (dolist (group (gnus-registry-fetch-groups
- reference
+ (dolist (group (gnus-registry-fetch-groups
+ reference
gnus-registry-max-track-groups))
(when (and group (gnus-registry-follow-group-p group))
(gnus-message
@@ -523,9 +532,9 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(push group found))))
;; filter the found groups and return them
;; the found groups are the full groups
- (setq found (gnus-registry-post-process-groups
+ (setq found (gnus-registry-post-process-groups
"references" refstr found found)))
-
+
;; else: there were no matches, now try the extra tracking by sender
((and (gnus-registry-track-sender-p)
sender
@@ -538,12 +547,13 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
matches)
(when (and this-sender
(equal sender this-sender))
- (let ((groups (gnus-registry-fetch-groups
+ (let ((groups (gnus-registry-fetch-groups
key
gnus-registry-max-track-groups)))
(dolist (group groups)
- (push group found-full)
- (setq found (append (list group) (delete group found)))))
+ (when (and group (gnus-registry-follow-group-p group))
+ (push group found-full)
+ (setq found (append (list group) (delete group found))))))
(push key matches)
(gnus-message
;; raise level of messaging if gnus-registry-track-extra
@@ -553,9 +563,9 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
gnus-registry-hashtb)
;; filter the found groups and return them
;; the found groups are NOT the full groups
- (setq found (gnus-registry-post-process-groups
+ (setq found (gnus-registry-post-process-groups
"sender" sender found found-full)))
-
+
;; else: there were no matches, now try the extra tracking by subject
((and (gnus-registry-track-subject-p)
subject
@@ -567,12 +577,13 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
matches)
(when (and this-subject
(equal subject this-subject))
- (let ((groups (gnus-registry-fetch-groups
+ (let ((groups (gnus-registry-fetch-groups
key
gnus-registry-max-track-groups)))
(dolist (group groups)
- (push group found-full)
- (setq found (append (list group) (delete group found)))))
+ (when (and group (gnus-registry-follow-group-p group))
+ (push group found-full)
+ (setq found (append (list group) (delete group found))))))
(push key matches)
(gnus-message
;; raise level of messaging if gnus-registry-track-extra
@@ -582,7 +593,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
gnus-registry-hashtb)
;; filter the found groups and return them
;; the found groups are NOT the full groups
- (setq found (gnus-registry-post-process-groups
+ (setq found (gnus-registry-post-process-groups
"subject" subject found found-full))))
;; after the (cond) we extract the actual value safely
(car-safe found)))
@@ -622,7 +633,7 @@ necessary."
(lambda (a b)
(> (gethash a freq 0)
(gethash b freq 0)))))))))
-
+
(if gnus-registry-use-long-group-names
(dolist (group groups)
(let ((m1 (gnus-find-method-for-group group))
@@ -656,10 +667,10 @@ necessary."
"Determines if a group name should be followed.
Consults `gnus-registry-unfollowed-groups' and
`nnmail-split-fancy-with-parent-ignore-groups'."
- (not (or (gnus-registry-grep-in-list
+ (not (or (gnus-grep-in-list
group
gnus-registry-unfollowed-groups)
- (gnus-registry-grep-in-list
+ (gnus-grep-in-list
group
nnmail-split-fancy-with-parent-ignore-groups))))
@@ -669,8 +680,7 @@ Consults `gnus-registry-unfollowed-groups' and
word words)
(if (or (not (gnus-registry-fetch-extra id 'keywords))
force)
- (save-excursion
- (set-buffer gnus-article-buffer)
+ (with-current-buffer gnus-article-buffer
(article-goto-body)
(save-window-excursion
(save-restriction
@@ -703,8 +713,8 @@ Consults `gnus-registry-unfollowed-groups' and
(unless (member gnus-newsgroup-name (gnus-registry-fetch-groups id))
(gnus-message 9 "Registry: Registering article %d with group %s"
article gnus-newsgroup-name)
- (gnus-registry-add-group
- id
+ (gnus-registry-add-group
+ id
gnus-newsgroup-name
(gnus-registry-fetch-simplified-message-subject-fast article)
(gnus-registry-fetch-sender-fast article)))))))
@@ -740,14 +750,6 @@ Consults `gnus-registry-unfollowed-groups' and
(assoc article (gnus-data-list nil)))))
nil))
-(defun gnus-registry-grep-in-list (word list)
-"Find if a WORD matches any regular expression in the given LIST."
- (when (and word list)
- (catch 'found
- (dolist (r list)
- (when (string-match r word)
- (throw 'found r))))))
-
(defun gnus-registry-do-marks (type function)
"For each known mark, call FUNCTION for each cell of type TYPE.
@@ -764,7 +766,8 @@ FUNCTION should take two parameters, a mark symbol and the cell value."
"Install the keyboard shortcuts and menus for the registry.
Uses `gnus-registry-marks' to find what shortcuts to install."
(let (keys-plist)
- (gnus-registry-do-marks
+ (setq gnus-registry-misc-menus nil)
+ (gnus-registry-do-marks
:char
(lambda (mark data)
(let ((function-format
@@ -785,20 +788,20 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
(function-name (format function-format variant-name))
(shortcut (format "%c" data))
(shortcut (if remove (upcase shortcut) shortcut)))
- (unintern function-name)
+ (unintern function-name obarray)
(eval
- `(defun
+ `(defun
;; function name
- ,(intern function-name)
+ ,(intern function-name)
;; parameter definition
(&rest articles)
;; documentation
- ,(format
+ ,(format
"%s the %s mark over process-marked ARTICLES."
(upcase-initials variant-name)
mark)
;; interactive definition
- (interactive
+ (interactive
(gnus-summary-work-articles current-prefix-arg))
;; actual code
@@ -809,34 +812,49 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
;; now the user is asked if gnus-registry-install is 'ask
(when (gnus-registry-install-p)
- (gnus-registry-set-article-mark-internal
+ (gnus-registry-set-article-mark-internal
;; all this just to get the mark, I must be doing it wrong
(intern ,(symbol-name mark))
articles ,remove t)
+ (gnus-message
+ 9
+ "Applying mark %s to %d articles"
+ ,(symbol-name mark) (length articles))
(dolist (article articles)
- (gnus-summary-update-article
- article
+ (gnus-summary-update-article
+ article
(assoc article (gnus-data-list nil)))))))
(push (intern function-name) keys-plist)
(push shortcut keys-plist)
- (gnus-message
- 9
- "Defined mark handling function %s"
+ (push (vector (format "%s %s"
+ (upcase-initials variant-name)
+ (symbol-name mark))
+ (intern function-name) t)
+ gnus-registry-misc-menus)
+ (gnus-message
+ 9
+ "Defined mark handling function %s"
function-name))))))
(gnus-define-keys-1
- '(gnus-registry-mark-map "M" gnus-summary-mark-map)
- keys-plist)))
+ '(gnus-registry-mark-map "M" gnus-summary-mark-map)
+ keys-plist)
+ (add-hook 'gnus-summary-menu-hook
+ (lambda ()
+ (easy-menu-add-item
+ gnus-summary-misc-menu
+ nil
+ (cons "Registry Marks" gnus-registry-misc-menus))))))
;;; use like this:
-;;; (defalias 'gnus-user-format-function-M
+;;; (defalias 'gnus-user-format-function-M
;;; 'gnus-registry-user-format-function-M)
(defun gnus-registry-user-format-function-M (headers)
(let* ((id (mail-header-message-id headers))
(marks (when id (gnus-registry-fetch-extra-marks id))))
(apply 'concat (mapcar (lambda(mark)
- (let ((c
+ (let ((c
(plist-get
- (cdr-safe
+ (cdr-safe
(assoc mark gnus-registry-marks))
:char)))
(if c
@@ -846,12 +864,11 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
(defun gnus-registry-read-mark ()
"Read a mark name from the user with completion."
- (let ((mark (gnus-completing-read-with-default
- (symbol-name gnus-registry-default-mark)
- "Label"
- (mapcar (lambda (x) ; completion list
- (cons (symbol-name (car-safe x)) (car-safe x)))
- gnus-registry-marks))))
+ (let ((mark (gnus-completing-read
+ "Label"
+ (mapcar 'symbol-name (mapcar 'car gnus-registry-marks))
+ nil nil nil
+ (symbol-name gnus-registry-default-mark))))
(when (stringp mark)
(intern mark))))
@@ -883,7 +900,7 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
(gnus-message 1 "%s mark %s with message ID %s, resulting in %S"
(if remove "Removing" "Adding")
mark id new-marks))
-
+
(apply 'gnus-registry-store-extra-marks ; set the extra marks
id ; for the message ID
new-marks)))))
@@ -994,7 +1011,7 @@ The message must have at least one group name."
"Put a specific entry in the extras field of the registry entry for id."
(let* ((extra (gnus-registry-fetch-extra id))
;; all the entries except the one for `key'
- (the-rest (gnus-assq-delete-all key (gnus-registry-fetch-extra id)))
+ (the-rest (gnus-assq-delete-all key (gnus-registry-fetch-extra id)))
(alist (if value
(gnus-registry-remove-alist-text-properties
(cons (cons key value)
@@ -1021,7 +1038,7 @@ Returns the first place where the trail finds a group name."
(dolist (crumb trail)
(when (stringp crumb)
;; push the group name into the list
- (setq
+ (setq
groups
(cons
(if (or (not (stringp crumb)) gnus-registry-use-long-group-names)
@@ -1162,13 +1179,8 @@ Returns the first place where the trail finds a group name."
;;; we could call it here: (customize-variable 'gnus-registry-install)
gnus-registry-install)
-(when (or (eq gnus-registry-install t)
- (gnus-registry-install-p))
- (gnus-registry-initialize))
-
;; TODO: a few things
(provide 'gnus-registry)
-;; arch-tag: 5cba0a32-718a-4a97-8c91-0a15af21da94
;;; gnus-registry.el ends here
diff --git a/lisp/gnus/gnus-salt.el b/lisp/gnus/gnus-salt.el
index d729fada009..a72d594a386 100644
--- a/lisp/gnus/gnus-salt.el
+++ b/lisp/gnus/gnus-salt.el
@@ -26,6 +26,9 @@
;;; Code:
(eval-when-compile (require 'cl))
+(eval-when-compile
+ (when (featurep 'xemacs)
+ (require 'easy-mmode))) ; for `define-minor-mode'
(require 'gnus)
(require 'gnus-sum)
@@ -35,10 +38,6 @@
;;; gnus-pick-mode
;;;
-(defvar gnus-pick-mode nil
- "Minor mode for providing a pick-and-read interface in Gnus
-summary buffers.")
-
(defcustom gnus-pick-display-summary nil
"*Display summary while reading."
:type 'boolean
@@ -72,17 +71,15 @@ It accepts the same format specs that `gnus-summary-line-format' does."
;;; Internal variables.
-(defvar gnus-pick-mode-map nil)
-
-(unless gnus-pick-mode-map
- (setq gnus-pick-mode-map (make-sparse-keymap))
-
- (gnus-define-keys gnus-pick-mode-map
- " " gnus-pick-next-page
- "u" gnus-pick-unmark-article-or-thread
- "." gnus-pick-article-or-thread
- gnus-down-mouse-2 gnus-pick-mouse-pick-region
- "\r" gnus-pick-start-reading))
+(defvar gnus-pick-mode-map
+ (let ((map (make-sparse-keymap)))
+ (gnus-define-keys map
+ " " gnus-pick-next-page
+ "u" gnus-pick-unmark-article-or-thread
+ "." gnus-pick-article-or-thread
+ gnus-down-mouse-2 gnus-pick-mouse-pick-region
+ "\r" gnus-pick-start-reading)
+ map))
(defun gnus-pick-make-menu-bar ()
(unless (boundp 'gnus-pick-menu)
@@ -104,30 +101,35 @@ It accepts the same format specs that `gnus-summary-line-format' does."
["Start reading" gnus-pick-start-reading t]
["Switch pick mode off" gnus-pick-mode gnus-pick-mode]))))
-(defun gnus-pick-mode (&optional arg)
+(eval-when-compile
+ (when (featurep 'xemacs)
+ (defvar gnus-pick-mode-on-hook)
+ (defvar gnus-pick-mode-off-hook)))
+
+(define-minor-mode gnus-pick-mode
"Minor mode for providing a pick-and-read interface in Gnus summary buffers.
\\{gnus-pick-mode-map}"
- (interactive "P")
- (when (eq major-mode 'gnus-summary-mode)
- (if (not (set (make-local-variable 'gnus-pick-mode)
- (if (null arg) (not gnus-pick-mode)
- (> (prefix-numeric-value arg) 0))))
- (remove-hook 'gnus-message-setup-hook 'gnus-pick-setup-message)
- ;; Make sure that we don't select any articles upon group entry.
- (set (make-local-variable 'gnus-auto-select-first) nil)
- ;; Change line format.
- (setq gnus-summary-line-format gnus-summary-pick-line-format)
- (setq gnus-summary-line-format-spec nil)
- (gnus-update-format-specifications nil 'summary)
- (gnus-update-summary-mark-positions)
- (add-hook 'gnus-message-setup-hook 'gnus-pick-setup-message)
- (set (make-local-variable 'gnus-summary-goto-unread) 'never)
- ;; Set up the menu.
- (when (gnus-visual-p 'pick-menu 'menu)
- (gnus-pick-make-menu-bar))
- (add-minor-mode 'gnus-pick-mode " Pick" gnus-pick-mode-map)
- (gnus-run-hooks 'gnus-pick-mode-hook))))
+ :lighter " Pick" :keymap gnus-pick-mode-map
+ (cond
+ ((not (derived-mode-p 'gnus-summary-mode)) (setq gnus-pick-mode nil))
+ ((not gnus-pick-mode)
+ ;; FIXME: a buffer-local minor mode removing globally from a hook??
+ (remove-hook 'gnus-message-setup-hook 'gnus-pick-setup-message))
+ (t
+ ;; Make sure that we don't select any articles upon group entry.
+ (set (make-local-variable 'gnus-auto-select-first) nil)
+ ;; Change line format.
+ (setq gnus-summary-line-format gnus-summary-pick-line-format)
+ (setq gnus-summary-line-format-spec nil)
+ (gnus-update-format-specifications nil 'summary)
+ (gnus-update-summary-mark-positions)
+ ;; FIXME: a buffer-local minor mode adding globally to a hook??
+ (add-hook 'gnus-message-setup-hook 'gnus-pick-setup-message)
+ (set (make-local-variable 'gnus-summary-goto-unread) 'never)
+ ;; Set up the menu.
+ (when (gnus-visual-p 'pick-menu 'menu)
+ (gnus-pick-make-menu-bar)))))
(defun gnus-pick-setup-message ()
"Make Message do the right thing on exit."
@@ -319,20 +321,14 @@ This must be bound to a button-down mouse event."
;;; gnus-binary-mode
;;;
-(defvar gnus-binary-mode nil
- "Minor mode for providing a binary group interface in Gnus summary buffers.")
-
(defvar gnus-binary-mode-hook nil
"Hook run in summary binary mode buffers.")
-(defvar gnus-binary-mode-map nil)
-
-(unless gnus-binary-mode-map
- (setq gnus-binary-mode-map (make-sparse-keymap))
-
- (gnus-define-keys
- gnus-binary-mode-map
- "g" gnus-binary-show-article))
+(defvar gnus-binary-mode-map
+ (let ((map (make-sparse-keymap)))
+ (gnus-define-keys map
+ "g" gnus-binary-show-article)
+ map))
(defun gnus-binary-make-menu-bar ()
(unless (boundp 'gnus-binary-menu)
@@ -341,25 +337,25 @@ This must be bound to a button-down mouse event."
'("Pick"
["Switch binary mode off" gnus-binary-mode t]))))
-(defun gnus-binary-mode (&optional arg)
+(eval-when-compile
+ (when (featurep 'xemacs)
+ (defvar gnus-binary-mode-on-hook)
+ (defvar gnus-binary-mode-off-hook)))
+
+(define-minor-mode gnus-binary-mode
"Minor mode for providing a binary group interface in Gnus summary buffers."
- (interactive "P")
- (when (eq major-mode 'gnus-summary-mode)
- (make-local-variable 'gnus-binary-mode)
- (setq gnus-binary-mode
- (if (null arg) (not gnus-binary-mode)
- (> (prefix-numeric-value arg) 0)))
- (when gnus-binary-mode
- ;; Make sure that we don't select any articles upon group entry.
- (make-local-variable 'gnus-auto-select-first)
- (setq gnus-auto-select-first nil)
- (make-local-variable 'gnus-summary-display-article-function)
- (setq gnus-summary-display-article-function 'gnus-binary-display-article)
- ;; Set up the menu.
- (when (gnus-visual-p 'binary-menu 'menu)
- (gnus-binary-make-menu-bar))
- (add-minor-mode 'gnus-binary-mode " Binary" gnus-binary-mode-map)
- (gnus-run-hooks 'gnus-binary-mode-hook))))
+ :lighter " Binary" :keymap gnus-binary-mode-map
+ (cond
+ ((not (derived-mode-p 'gnus-summary-mode)) (setq gnus-binary-mode nil))
+ (gnus-binary-mode
+ ;; Make sure that we don't select any articles upon group entry.
+ (make-local-variable 'gnus-auto-select-first)
+ (setq gnus-auto-select-first nil)
+ (make-local-variable 'gnus-summary-display-article-function)
+ (setq gnus-summary-display-article-function 'gnus-binary-display-article)
+ ;; Set up the menu.
+ (when (gnus-visual-p 'binary-menu 'menu)
+ (gnus-binary-make-menu-bar)))))
(defun gnus-binary-display-article (article &optional all-header)
"Run ARTICLE through the binary decode functions."
@@ -873,181 +869,9 @@ Two predefined functions are available:
(set-window-point
(gnus-get-buffer-window (current-buffer) t) (cdr region))))))
-;;;
-;;; gnus-carpal
-;;;
-
-(defvar gnus-carpal-group-buffer-buttons
- '(("next" . gnus-group-next-unread-group)
- ("prev" . gnus-group-prev-unread-group)
- ("read" . gnus-group-read-group)
- ("select" . gnus-group-select-group)
- ("catch-up" . gnus-group-catchup-current)
- ("new-news" . gnus-group-get-new-news-this-group)
- ("toggle-sub" . gnus-group-unsubscribe-current-group)
- ("subscribe" . gnus-group-unsubscribe-group)
- ("kill" . gnus-group-kill-group)
- ("yank" . gnus-group-yank-group)
- ("describe" . gnus-group-describe-group)
- "list"
- ("subscribed" . gnus-group-list-groups)
- ("all" . gnus-group-list-all-groups)
- ("killed" . gnus-group-list-killed)
- ("zombies" . gnus-group-list-zombies)
- ("matching" . gnus-group-list-matching)
- ("post" . gnus-group-post-news)
- ("mail" . gnus-group-mail)
- ("local" . (lambda () (interactive) (gnus-group-news 0)))
- ("rescan" . gnus-group-get-new-news)
- ("browse-foreign" . gnus-group-browse-foreign)
- ("exit" . gnus-group-exit)))
-
-(defvar gnus-carpal-summary-buffer-buttons
- '("mark"
- ("read" . gnus-summary-mark-as-read-forward)
- ("tick" . gnus-summary-tick-article-forward)
- ("clear" . gnus-summary-clear-mark-forward)
- ("expirable" . gnus-summary-mark-as-expirable)
- "move"
- ("scroll" . gnus-summary-next-page)
- ("next-unread" . gnus-summary-next-unread-article)
- ("prev-unread" . gnus-summary-prev-unread-article)
- ("first" . gnus-summary-first-unread-article)
- ("best" . gnus-summary-best-unread-article)
- "article"
- ("headers" . gnus-summary-toggle-header)
- ("uudecode" . gnus-uu-decode-uu)
- ("enter-digest" . gnus-summary-enter-digest-group)
- ("fetch-parent" . gnus-summary-refer-parent-article)
- "mail"
- ("move" . gnus-summary-move-article)
- ("copy" . gnus-summary-copy-article)
- ("respool" . gnus-summary-respool-article)
- "threads"
- ("lower" . gnus-summary-lower-thread)
- ("kill" . gnus-summary-kill-thread)
- "post"
- ("post" . gnus-summary-post-news)
- ("local" . gnus-summary-news-other-window)
- ("mail" . gnus-summary-mail-other-window)
- ("followup" . gnus-summary-followup-with-original)
- ("reply" . gnus-summary-reply-with-original)
- ("cancel" . gnus-summary-cancel-article)
- "misc"
- ("exit" . gnus-summary-exit)
- ("fed-up" . gnus-summary-catchup-and-goto-next-group)))
-
-(defvar gnus-carpal-server-buffer-buttons
- '(("add" . gnus-server-add-server)
- ("browse" . gnus-server-browse-server)
- ("list" . gnus-server-list-servers)
- ("kill" . gnus-server-kill-server)
- ("yank" . gnus-server-yank-server)
- ("copy" . gnus-server-copy-server)
- ("exit" . gnus-server-exit)))
-
-(defvar gnus-carpal-browse-buffer-buttons
- '(("subscribe" . gnus-browse-unsubscribe-current-group)
- ("exit" . gnus-browse-exit)))
-
-(defvar gnus-carpal-group-buffer "*Carpal Group*")
-(defvar gnus-carpal-summary-buffer "*Carpal Summary*")
-(defvar gnus-carpal-server-buffer "*Carpal Server*")
-(defvar gnus-carpal-browse-buffer "*Carpal Browse*")
-
-(defvar gnus-carpal-attached-buffer nil)
-
-(defvar gnus-carpal-mode-hook nil
- "*Hook run in carpal mode buffers.")
-
-(defvar gnus-carpal-button-face 'bold
- "*Face used on carpal buttons.")
-
-(defvar gnus-carpal-header-face 'bold-italic
- "*Face used on carpal buffer headers.")
-
-(defvar gnus-carpal-mode-map nil)
-(put 'gnus-carpal-mode 'mode-class 'special)
-
-(if gnus-carpal-mode-map
- nil
- (setq gnus-carpal-mode-map (make-keymap))
- (suppress-keymap gnus-carpal-mode-map)
- (define-key gnus-carpal-mode-map " " 'gnus-carpal-select)
- (define-key gnus-carpal-mode-map "\r" 'gnus-carpal-select)
- (define-key gnus-carpal-mode-map gnus-mouse-2 'gnus-carpal-mouse-select))
-
-(defun gnus-carpal-mode ()
- "Major mode for clicking buttons.
-
-All normal editing commands are switched off.
-\\<gnus-carpal-mode-map>
-The following commands are available:
-
-\\{gnus-carpal-mode-map}"
- (interactive)
- (kill-all-local-variables)
- (setq mode-line-modified (cdr gnus-mode-line-modified))
- (setq major-mode 'gnus-carpal-mode)
- (setq mode-name "Gnus Carpal")
- (setq mode-line-process nil)
- (use-local-map gnus-carpal-mode-map)
- (buffer-disable-undo)
- (setq buffer-read-only t)
- (make-local-variable 'gnus-carpal-attached-buffer)
- (gnus-run-mode-hooks 'gnus-carpal-mode-hook))
-
-(defun gnus-carpal-setup-buffer (type)
- (let ((buffer (symbol-value (intern (format "gnus-carpal-%s-buffer" type)))))
- (if (get-buffer buffer)
- ()
- (with-current-buffer (gnus-get-buffer-create buffer)
- (gnus-carpal-mode)
- (setq gnus-carpal-attached-buffer
- (intern (format "gnus-%s-buffer" type)))
- (let ((buttons (symbol-value
- (intern (format "gnus-carpal-%s-buffer-buttons"
- type))))
- (buffer-read-only nil)
- button)
- (while buttons
- (setq button (car buttons)
- buttons (cdr buttons))
- (if (stringp button)
- (set-text-properties
- (point)
- (prog2 (insert button) (point) (insert " "))
- (list 'face gnus-carpal-header-face))
- (set-text-properties
- (point)
- (prog2 (insert (car button)) (point) (insert " "))
- (list 'gnus-callback (cdr button)
- 'face gnus-carpal-button-face
- gnus-mouse-face-prop 'highlight))))
- (let ((fill-column (- (window-width) 2)))
- (fill-region (point-min) (point-max)))
- (set-window-point (get-buffer-window (current-buffer))
- (point-min)))))))
-
-(defun gnus-carpal-select ()
- "Select the button under point."
- (interactive)
- (let ((func (get-text-property (point) 'gnus-callback)))
- (if (null func)
- ()
- (pop-to-buffer (symbol-value gnus-carpal-attached-buffer))
- (call-interactively func))))
-
-(defun gnus-carpal-mouse-select (event)
- "Select the button under the mouse pointer."
- (interactive "e")
- (mouse-set-point event)
- (gnus-carpal-select))
-
;;; Allow redefinition of functions.
(gnus-ems-redefine)
(provide 'gnus-salt)
-;; arch-tag: 35449164-77b3-4398-bcbd-a2e3e998f810
;;; gnus-salt.el ends here
diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el
index 26c01229e33..a9c666e246e 100644
--- a/lisp/gnus/gnus-score.el
+++ b/lisp/gnus/gnus-score.el
@@ -680,14 +680,14 @@ file for the command instead of the current score file."
(and gnus-extra-headers
(equal (nth 1 entry) "extra")
(intern ; need symbol
- (gnus-completing-read-with-default
- (symbol-name (car gnus-extra-headers)) ; default response
- "Score extra header" ; prompt
- (mapcar (lambda (x) ; completion list
- (cons (symbol-name x) x))
- gnus-extra-headers)
- nil ; no completion limit
- t)))) ; require match
+ (let ((collection (mapcar 'symbol-name gnus-extra-headers)))
+ (gnus-completing-read
+ "Score extra header" ; prompt
+ collection ; completion list
+ t ; require match
+ nil ; no history
+ nil ; no initial-input
+ (car collection)))))) ; default value
;; extra is now nil or a symbol.
;; We have all the data, so we enter this score.
@@ -708,8 +708,7 @@ file for the command instead of the current score file."
;; Change score file to the "all.SCORE" file.
(when (eq symp 'a)
- (save-excursion
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
(gnus-score-load-file
;; This is a kludge; yes...
(cond
@@ -735,14 +734,12 @@ file for the command instead of the current score file."
(when (eq symp 'a)
;; We change the score file back to the previous one.
- (save-excursion
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
(gnus-score-load-file current-score-file)))))
(defun gnus-score-insert-help (string alist idx)
(setq gnus-score-help-winconf (current-window-configuration))
- (save-excursion
- (set-buffer (gnus-get-buffer-create "*Score Help*"))
+ (with-current-buffer (gnus-get-buffer-create "*Score Help*")
(buffer-disable-undo)
(delete-windows-on (current-buffer))
(erase-buffer)
@@ -916,10 +913,13 @@ MATCH is the string we are looking for.
TYPE is the score type.
SCORE is the score to add.
EXTRA is the possible non-standard header."
- (interactive (list (completing-read "Header: "
- gnus-header-index
- (lambda (x) (fboundp (nth 2 x)))
- t)
+ (interactive (list (gnus-completing-read "Header"
+ (mapcar
+ 'car
+ (gnus-remove-if-not
+ (lambda (x) (fboundp (nth 2 x)))
+ gnus-header-index))
+ t)
(read-string "Match: ")
(if (y-or-n-p "Use regexp match? ") 'r 's)
(string-to-number (read-string "Score: "))))
@@ -1117,8 +1117,8 @@ EXTRA is the possible non-standard header."
(make-local-variable 'gnus-prev-winconf)
(setq gnus-prev-winconf winconf))
(gnus-message
- 4 (substitute-command-keys
- "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits"))))
+ 4 "%s" (substitute-command-keys
+ "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits"))))
(defun gnus-score-edit-all-score ()
"Edit the all.SCORE file."
@@ -1145,8 +1145,8 @@ EXTRA is the possible non-standard header."
(make-local-variable 'gnus-prev-winconf)
(setq gnus-prev-winconf winconf))
(gnus-message
- 4 (substitute-command-keys
- "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits")))
+ 4 "%s" (substitute-command-keys
+ "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits")))
(defun gnus-score-edit-file-at-point (&optional format)
"Edit score file at point in Score Trace buffers.
@@ -1270,8 +1270,7 @@ If FORMAT, also format the current score file."
exclude-files))
gnus-scores-exclude-files))
(when local
- (save-excursion
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
(while local
(and (consp (car local))
(symbolp (caar local))
@@ -1395,7 +1394,7 @@ If FORMAT, also format the current score file."
(if err
(progn
(ding)
- (gnus-message 3 err)
+ (gnus-message 3 "%s" err)
(sit-for 2)
nil)
alist)))))
@@ -1528,8 +1527,7 @@ If FORMAT, also format the current score file."
(cons (cons header (or gnus-summary-default-score 0))
gnus-scores-articles))))
- (save-excursion
- (set-buffer (gnus-get-buffer-create "*Headers*"))
+ (with-current-buffer (gnus-get-buffer-create "*Headers*")
(buffer-disable-undo)
(when (gnus-buffer-live-p gnus-summary-buffer)
(message-clone-locals gnus-summary-buffer))
@@ -1854,8 +1852,7 @@ score in `gnus-newsgroup-scored' by SCORE."
;; Change score file to the adaptive score file. All entries that
;; this function makes will be put into this file.
- (save-excursion
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
(gnus-score-load-file
(or gnus-newsgroup-adaptive-score-file
(gnus-score-file-name
@@ -1946,15 +1943,13 @@ score in `gnus-newsgroup-scored' by SCORE."
(setq rest entries)))
(setq entries rest))))
;; We change the score file back to the previous one.
- (save-excursion
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
(gnus-score-load-file current-score-file))
(list (cons "references" news)))))
(defun gnus-score-add-followups (header score scores &optional thread)
"Add a score entry to the adapt file."
- (save-excursion
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
(let* ((id (mail-header-id header))
(scores (car scores))
entry dont)
@@ -2055,8 +2050,11 @@ score in `gnus-newsgroup-scored' by SCORE."
;; Evil hackery to make match usable in non-standard headers.
(when extra
- (setq match (concat "[ (](" extra " \\. \"[^)]*"
- match "[^\"]*\")[ )]")
+ (setq match (concat "[ (](" extra " \\. \"\\([^\"]*\\\\\"\\)*[^\"]*"
+ (if (eq search-func 're-search-forward)
+ match
+ (regexp-quote match))
+ "\\([^\"]*\\\\\"\\)*[^\"]*\")[ )]")
search-func 're-search-forward)) ; XXX danger?!?
(cond
@@ -2279,8 +2277,7 @@ score in `gnus-newsgroup-scored' by SCORE."
"Create adaptive score rules for this newsgroup."
(when gnus-newsgroup-adaptive
;; We change the score file to the adaptive score file.
- (save-excursion
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
(gnus-score-load-file
(or gnus-newsgroup-adaptive-score-file
(gnus-home-score-file gnus-newsgroup-name t)
@@ -2694,8 +2691,7 @@ GROUP using BNews sys file syntax."
(trans (cdr (assq ?: nnheader-file-name-translation-alist)))
(group-trans (nnheader-translate-file-chars group t))
ofiles not-match regexp)
- (save-excursion
- (set-buffer (gnus-get-buffer-create "*gnus score files*"))
+ (with-current-buffer (gnus-get-buffer-create "*gnus score files*")
(buffer-disable-undo)
;; Go through all score file names and create regexp with them
;; as the source.
@@ -3119,5 +3115,4 @@ See Info node `(gnus)Scoring Tips' for examples of good regular expressions."
(provide 'gnus-score)
-;; arch-tag: d3922589-764d-46ae-9954-9330fd192634
;;; gnus-score.el ends here
diff --git a/lisp/gnus/gnus-setup.el b/lisp/gnus/gnus-setup.el
index 9cfa6584177..d5578ff6933 100644
--- a/lisp/gnus/gnus-setup.el
+++ b/lisp/gnus/gnus-setup.el
@@ -189,5 +189,4 @@ score the alt hierarchy, you'd say \"!alt.all\"." t nil))
(run-hooks 'gnus-setup-load-hook)
-;; arch-tag: 08e4af93-8565-46bf-905c-36229400609d
;;; gnus-setup.el ends here
diff --git a/lisp/gnus/gnus-sieve.el b/lisp/gnus/gnus-sieve.el
index abc63c1d1c6..a7ddbf08f7f 100644
--- a/lisp/gnus/gnus-sieve.el
+++ b/lisp/gnus/gnus-sieve.el
@@ -235,5 +235,4 @@ This is returned as a string."
(provide 'gnus-sieve)
-;; arch-tag: 3b906527-c7f3-4c86-9e82-62e2697998a3
;;; gnus-sieve.el ends here
diff --git a/lisp/gnus/gnus-soup.el b/lisp/gnus/gnus-soup.el
deleted file mode 100644
index 13271a9c15a..00000000000
--- a/lisp/gnus/gnus-soup.el
+++ /dev/null
@@ -1,611 +0,0 @@
-;;; gnus-soup.el --- SOUP packet writing support for Gnus
-
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
-;; Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; Keywords: news, mail
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-
-(require 'gnus)
-(require 'gnus-art)
-(require 'message)
-(require 'gnus-start)
-(require 'gnus-range)
-
-(defgroup gnus-soup nil
- "SOUP packet writing support for Gnus."
- :group 'gnus)
-
-;;; User Variables:
-
-(defcustom gnus-soup-directory (nnheader-concat gnus-home-directory "SoupBrew/")
- "Directory containing an unpacked SOUP packet."
- :version "22.1" ;; Gnus 5.10.9
- :type 'directory
- :group 'gnus-soup)
-
-(defcustom gnus-soup-replies-directory
- (nnheader-concat gnus-soup-directory "SoupReplies/")
- "Directory where Gnus will do processing of replies."
- :version "22.1" ;; Gnus 5.10.9
- :type 'directory
- :group 'gnus-soup)
-
-(defcustom gnus-soup-prefix-file "gnus-prefix"
- "Name of the file where Gnus stores the last used prefix."
- :version "22.1" ;; Gnus 5.10.9
- :type 'file
- :group 'gnus-soup)
-
-(defcustom gnus-soup-packer "tar cf - %s | gzip > $HOME/Soupout%d.tgz"
- "Format string command for packing a SOUP packet.
-The SOUP files will be inserted where the %s is in the string.
-This string MUST contain both %s and %d. The file number will be
-inserted where %d appears."
- :version "22.1" ;; Gnus 5.10.9
- :type 'string
- :group 'gnus-soup)
-
-(defcustom gnus-soup-unpacker "gunzip -c %s | tar xvf -"
- "Format string command for unpacking a SOUP packet.
-The SOUP packet file name will be inserted at the %s."
- :version "22.1" ;; Gnus 5.10.9
- :type 'string
- :group 'gnus-soup)
-
-(defcustom gnus-soup-packet-directory gnus-home-directory
- "Where gnus-soup will look for REPLIES packets."
- :version "22.1" ;; Gnus 5.10.9
- :type 'directory
- :group 'gnus-soup)
-
-(defcustom gnus-soup-packet-regexp "Soupin"
- "Regular expression matching SOUP REPLIES packets in `gnus-soup-packet-directory'."
- :version "22.1" ;; Gnus 5.10.9
- :type 'regexp
- :group 'gnus-soup)
-
-(defcustom gnus-soup-ignored-headers "^Xref:"
- "Regexp to match headers to be removed when brewing SOUP packets."
- :version "22.1" ;; Gnus 5.10.9
- :type 'regexp
- :group 'gnus-soup)
-
-;;; Internal Variables:
-
-(defvar gnus-soup-encoding-type ?u
- "*Soup encoding type.
-`u' is USENET news format, `m' is Unix mbox format, and `M' is MMDF mailbox
-format.")
-
-(defvar gnus-soup-index-type ?c
- "*Soup index type.
-`n' means no index file and `c' means standard Cnews overview
-format.")
-
-(defvar gnus-soup-areas nil)
-(defvar gnus-soup-last-prefix nil)
-(defvar gnus-soup-prev-prefix nil)
-(defvar gnus-soup-buffers nil)
-
-;;; Access macros:
-
-(defmacro gnus-soup-area-prefix (area)
- `(aref ,area 0))
-(defmacro gnus-soup-set-area-prefix (area prefix)
- `(aset ,area 0 ,prefix))
-(defmacro gnus-soup-area-name (area)
- `(aref ,area 1))
-(defmacro gnus-soup-area-encoding (area)
- `(aref ,area 2))
-(defmacro gnus-soup-area-description (area)
- `(aref ,area 3))
-(defmacro gnus-soup-area-number (area)
- `(aref ,area 4))
-(defmacro gnus-soup-area-set-number (area value)
- `(aset ,area 4 ,value))
-
-(defmacro gnus-soup-encoding-format (encoding)
- `(aref ,encoding 0))
-(defmacro gnus-soup-encoding-index (encoding)
- `(aref ,encoding 1))
-(defmacro gnus-soup-encoding-kind (encoding)
- `(aref ,encoding 2))
-
-(defmacro gnus-soup-reply-prefix (reply)
- `(aref ,reply 0))
-(defmacro gnus-soup-reply-kind (reply)
- `(aref ,reply 1))
-(defmacro gnus-soup-reply-encoding (reply)
- `(aref ,reply 2))
-
-;;; Commands:
-
-(defun gnus-soup-send-replies ()
- "Unpack and send all replies in the reply packet."
- (interactive)
- (let ((packets (directory-files
- gnus-soup-packet-directory t gnus-soup-packet-regexp)))
- (while packets
- (when (gnus-soup-send-packet (car packets))
- (delete-file (car packets)))
- (setq packets (cdr packets)))))
-
-(defun gnus-soup-add-article (n)
- "Add the current article to SOUP packet.
-If N is a positive number, add the N next articles.
-If N is a negative number, add the N previous articles.
-If N is nil and any articles have been marked with the process mark,
-move those articles instead."
- (interactive "P")
- (let* ((articles (gnus-summary-work-articles n))
- (tmp-buf (gnus-get-buffer-create "*soup work*"))
- (area (gnus-soup-area gnus-newsgroup-name))
- (prefix (gnus-soup-area-prefix area))
- headers)
- (buffer-disable-undo tmp-buf)
- (save-excursion
- (while articles
- ;; Put the article in a buffer.
- (set-buffer tmp-buf)
- (when (gnus-request-article-this-buffer
- (car articles) gnus-newsgroup-name)
- (setq headers (nnheader-parse-head t))
- (save-restriction
- (message-narrow-to-head)
- (message-remove-header gnus-soup-ignored-headers t))
- (gnus-soup-store gnus-soup-directory prefix headers
- gnus-soup-encoding-type
- gnus-soup-index-type)
- (gnus-soup-area-set-number
- area (1+ (or (gnus-soup-area-number area) 0)))
- ;; Mark article as read.
- (set-buffer gnus-summary-buffer)
- (gnus-summary-mark-as-read (car articles) gnus-souped-mark))
- (gnus-summary-remove-process-mark (car articles))
- (setq articles (cdr articles)))
- (kill-buffer tmp-buf))
- (gnus-soup-save-areas)
- (gnus-set-mode-line 'summary)))
-
-(defun gnus-soup-pack-packet ()
- "Make a SOUP packet from the SOUP areas."
- (interactive)
- (gnus-soup-read-areas)
- (if (file-exists-p gnus-soup-directory)
- (if (directory-files gnus-soup-directory nil "\\.MSG$")
- (gnus-soup-pack gnus-soup-directory gnus-soup-packer)
- (message "No files to pack."))
- (message "No such directory: %s" gnus-soup-directory)))
-
-(defun gnus-group-brew-soup (n)
- "Make a soup packet from the current group.
-Uses the process/prefix convention."
- (interactive "P")
- (let ((groups (gnus-group-process-prefix n)))
- (while groups
- (gnus-group-remove-mark (car groups))
- (gnus-soup-group-brew (car groups) t)
- (setq groups (cdr groups)))
- (gnus-soup-save-areas)))
-
-(defun gnus-brew-soup (&optional level)
- "Go through all groups on LEVEL or less and make a soup packet."
- (interactive "P")
- (let ((level (or level gnus-level-subscribed))
- (newsrc (cdr gnus-newsrc-alist)))
- (while newsrc
- (when (<= (nth 1 (car newsrc)) level)
- (gnus-soup-group-brew (caar newsrc) t))
- (setq newsrc (cdr newsrc)))
- (gnus-soup-save-areas)))
-
-;;;###autoload
-(defun gnus-batch-brew-soup ()
- "Brew a SOUP packet from groups mention on the command line.
-Will use the remaining command line arguments as regular expressions
-for matching on group names.
-
-For instance, if you want to brew on all the nnml groups, as well as
-groups with \"emacs\" in the name, you could say something like:
-
-$ emacs -batch -f gnus-batch-brew-soup ^nnml \".*emacs.*\"
-
-Note -- this function hasn't been implemented yet."
- (interactive)
- nil)
-
-;;; Internal Functions:
-
-;; Store the current buffer.
-(defun gnus-soup-store (directory prefix headers format index)
- ;; Create the directory, if needed.
- (gnus-make-directory directory)
- (let* ((msg-buf (nnheader-find-file-noselect
- (concat directory prefix ".MSG")))
- (idx-buf (if (= index ?n)
- nil
- (nnheader-find-file-noselect
- (concat directory prefix ".IDX"))))
- (article-buf (current-buffer))
- from head-line beg type)
- (setq gnus-soup-buffers (cons msg-buf (delq msg-buf gnus-soup-buffers)))
- (buffer-disable-undo msg-buf)
- (when idx-buf
- (push idx-buf gnus-soup-buffers)
- (buffer-disable-undo idx-buf))
- (save-excursion
- ;; Make sure the last char in the buffer is a newline.
- (goto-char (point-max))
- (unless (= (current-column) 0)
- (insert "\n"))
- ;; Find the "from".
- (goto-char (point-min))
- (setq from
- (gnus-mail-strip-quoted-names
- (or (mail-fetch-field "from")
- (mail-fetch-field "really-from")
- (mail-fetch-field "sender"))))
- (goto-char (point-min))
- ;; Depending on what encoding is supposed to be used, we make
- ;; a soup header.
- (setq head-line
- (cond
- ((or (= gnus-soup-encoding-type ?u)
- (= gnus-soup-encoding-type ?n)) ;;Gnus back compatibility.
- (format "#! rnews %d\n" (buffer-size)))
- ((= gnus-soup-encoding-type ?m)
- (while (search-forward "\nFrom " nil t)
- (replace-match "\n>From " t t))
- (concat "From " (or from "unknown")
- " " (current-time-string) "\n"))
- ((= gnus-soup-encoding-type ?M)
- "\^a\^a\^a\^a\n")
- (t (error "Unsupported type: %c" gnus-soup-encoding-type))))
- ;; Insert the soup header and the article in the MSG buf.
- (set-buffer msg-buf)
- (goto-char (point-max))
- (insert head-line)
- (setq beg (point))
- (insert-buffer-substring article-buf)
- ;; Insert the index in the IDX buf.
- (cond ((= index ?c)
- (set-buffer idx-buf)
- (gnus-soup-insert-idx beg headers))
- ((/= index ?n)
- (error "Unknown index type: %c" type)))
- ;; Return the MSG buf.
- msg-buf)))
-
-(defun gnus-soup-group-brew (group &optional not-all)
- "Enter GROUP and add all articles to a SOUP package.
-If NOT-ALL, don't pack ticked articles."
- (let ((gnus-expert-user t)
- (gnus-large-newsgroup nil)
- (entry (gnus-group-entry group)))
- (when (or (null entry)
- (eq (car entry) t)
- (and (car entry)
- (> (car entry) 0))
- (and (not not-all)
- (gnus-range-length (cdr (assq 'tick (gnus-info-marks
- (nth 2 entry)))))))
- (when (gnus-summary-read-group group nil t)
- (setq gnus-newsgroup-processable
- (reverse
- (if (not not-all)
- (append gnus-newsgroup-marked gnus-newsgroup-unreads)
- gnus-newsgroup-unreads)))
- (gnus-soup-add-article nil)
- (gnus-summary-exit)))))
-
-(defun gnus-soup-insert-idx (offset header)
- ;; [number subject from date id references chars lines xref]
- (goto-char (point-max))
- (insert
- (format "%d\t%s\t%s\t%s\t%s\t%s\t%d\t%s\t\t\n"
- offset
- (or (mail-header-subject header) "(none)")
- (or (mail-header-from header) "(nobody)")
- (or (mail-header-date header) "")
- (or (mail-header-id header)
- (concat "soup-dummy-id-"
- (mapconcat
- (lambda (time) (int-to-string time))
- (current-time) "-")))
- (or (mail-header-references header) "")
- (or (mail-header-chars header) 0)
- (or (mail-header-lines header) "0"))))
-
-(defun gnus-soup-save-areas ()
- "Write all SOUP buffers."
- (interactive)
- (gnus-soup-write-areas)
- (save-excursion
- (let (buf)
- (while gnus-soup-buffers
- (setq buf (car gnus-soup-buffers)
- gnus-soup-buffers (cdr gnus-soup-buffers))
- (if (not (buffer-name buf))
- ()
- (set-buffer buf)
- (when (buffer-modified-p)
- (save-buffer))
- (kill-buffer (current-buffer)))))
- (gnus-soup-write-prefixes)))
-
-(defun gnus-soup-write-prefixes ()
- (let ((prefixes gnus-soup-last-prefix)
- prefix)
- (save-excursion
- (gnus-set-work-buffer)
- (while (setq prefix (pop prefixes))
- (erase-buffer)
- (insert (format "(setq gnus-soup-prev-prefix %d)\n" (cdr prefix)))
- (let ((coding-system-for-write mm-text-coding-system))
- (gnus-write-buffer (concat (car prefix) gnus-soup-prefix-file)))))))
-
-(defun gnus-soup-pack (dir packer)
- (let* ((files (mapconcat 'identity
- '("AREAS" "*.MSG" "*.IDX" "INFO"
- "LIST" "REPLIES" "COMMANDS" "ERRORS")
- " "))
- (packer (if (< (string-match "%s" packer)
- (string-match "%d" packer))
- (format packer files
- (string-to-number (gnus-soup-unique-prefix dir)))
- (format packer
- (string-to-number (gnus-soup-unique-prefix dir))
- files)))
- (dir (expand-file-name dir)))
- (gnus-make-directory dir)
- (setq gnus-soup-areas nil)
- (gnus-message 4 "Packing %s..." packer)
- (if (eq 0 (call-process shell-file-name
- nil nil nil shell-command-switch
- (concat "cd " dir " ; " packer)))
- (progn
- (call-process shell-file-name nil nil nil shell-command-switch
- (concat "cd " dir " ; rm " files))
- (gnus-message 4 "Packing...done" packer))
- (error "Couldn't pack packet"))))
-
-(defun gnus-soup-parse-areas (file)
- "Parse soup area file FILE.
-The result is a of vectors, each containing one entry from the AREA file.
-The vector contain five strings,
- [prefix name encoding description number]
-though the two last may be nil if they are missing."
- (let (areas)
- (when (file-exists-p file)
- (save-excursion
- (set-buffer (nnheader-find-file-noselect file 'force))
- (buffer-disable-undo)
- (goto-char (point-min))
- (while (not (eobp))
- (push (vector (gnus-soup-field)
- (gnus-soup-field)
- (gnus-soup-field)
- (and (eq (preceding-char) ?\t)
- (gnus-soup-field))
- (and (eq (preceding-char) ?\t)
- (string-to-number (gnus-soup-field))))
- areas)
- (when (eq (preceding-char) ?\t)
- (beginning-of-line 2)))
- (kill-buffer (current-buffer))))
- areas))
-
-(defun gnus-soup-parse-replies (file)
- "Parse soup REPLIES file FILE.
-The result is a of vectors, each containing one entry from the REPLIES
-file. The vector contain three strings, [prefix name encoding]."
- (let (replies)
- (save-excursion
- (set-buffer (nnheader-find-file-noselect file))
- (buffer-disable-undo)
- (goto-char (point-min))
- (while (not (eobp))
- (push (vector (gnus-soup-field) (gnus-soup-field)
- (gnus-soup-field))
- replies)
- (when (eq (preceding-char) ?\t)
- (beginning-of-line 2)))
- (kill-buffer (current-buffer)))
- replies))
-
-(defun gnus-soup-field ()
- (prog1
- (buffer-substring (point) (progn (skip-chars-forward "^\t\n") (point)))
- (forward-char 1)))
-
-(defun gnus-soup-read-areas ()
- (or gnus-soup-areas
- (setq gnus-soup-areas
- (gnus-soup-parse-areas (concat gnus-soup-directory "AREAS")))))
-
-(defun gnus-soup-write-areas ()
- "Write the AREAS file."
- (interactive)
- (when gnus-soup-areas
- (with-temp-file (concat gnus-soup-directory "AREAS")
- (let ((areas gnus-soup-areas)
- area)
- (while (setq area (pop areas))
- (insert
- (format
- "%s\t%s\t%s%s\n"
- (gnus-soup-area-prefix area)
- (gnus-soup-area-name area)
- (gnus-soup-area-encoding area)
- (if (or (gnus-soup-area-description area)
- (gnus-soup-area-number area))
- (concat "\t" (or (gnus-soup-area-description
- area) "")
- (if (gnus-soup-area-number area)
- (concat "\t" (int-to-string
- (gnus-soup-area-number area)))
- "")) ""))))))))
-
-(defun gnus-soup-write-replies (dir areas)
- "Write a REPLIES file in DIR containing AREAS."
- (with-temp-file (concat dir "REPLIES")
- (let (area)
- (while (setq area (pop areas))
- (insert (format "%s\t%s\t%s\n"
- (gnus-soup-reply-prefix area)
- (gnus-soup-reply-kind area)
- (gnus-soup-reply-encoding area)))))))
-
-(defun gnus-soup-area (group)
- (gnus-soup-read-areas)
- (let ((areas gnus-soup-areas)
- (real-group (gnus-group-real-name group))
- area result)
- (while areas
- (setq area (car areas)
- areas (cdr areas))
- (when (equal (gnus-soup-area-name area) real-group)
- (setq result area)))
- (unless result
- (setq result
- (vector (gnus-soup-unique-prefix)
- real-group
- (format "%c%c%c"
- gnus-soup-encoding-type
- gnus-soup-index-type
- (if (gnus-member-of-valid 'mail group) ?m ?n))
- nil nil)
- gnus-soup-areas (cons result gnus-soup-areas)))
- result))
-
-(defun gnus-soup-unique-prefix (&optional dir)
- (let* ((dir (file-name-as-directory (or dir gnus-soup-directory)))
- (entry (assoc dir gnus-soup-last-prefix))
- gnus-soup-prev-prefix)
- (if entry
- ()
- (when (file-exists-p (concat dir gnus-soup-prefix-file))
- (ignore-errors
- (load (concat dir gnus-soup-prefix-file) nil t t)))
- (push (setq entry (cons dir (or gnus-soup-prev-prefix 0)))
- gnus-soup-last-prefix))
- (setcdr entry (1+ (cdr entry)))
- (gnus-soup-write-prefixes)
- (int-to-string (cdr entry))))
-
-(defun gnus-soup-unpack-packet (dir unpacker packet)
- "Unpack PACKET into DIR using UNPACKER.
-Return whether the unpacking was successful."
- (gnus-make-directory dir)
- (gnus-message 4 "Unpacking: %s" (format unpacker packet))
- (prog1
- (eq 0 (call-process
- shell-file-name nil nil nil shell-command-switch
- (format "cd %s ; %s" (expand-file-name dir)
- (format unpacker packet))))
- (gnus-message 4 "Unpacking...done")))
-
-(defun gnus-soup-send-packet (packet)
- (gnus-soup-unpack-packet
- gnus-soup-replies-directory gnus-soup-unpacker packet)
- (let ((replies (gnus-soup-parse-replies
- (concat gnus-soup-replies-directory "REPLIES"))))
- (save-excursion
- (while replies
- (let* ((msg-file (concat gnus-soup-replies-directory
- (gnus-soup-reply-prefix (car replies))
- ".MSG"))
- (msg-buf (and (file-exists-p msg-file)
- (nnheader-find-file-noselect msg-file)))
- (tmp-buf (gnus-get-buffer-create " *soup send*"))
- beg end)
- (cond
- ((and (/= (gnus-soup-encoding-format
- (gnus-soup-reply-encoding (car replies)))
- ?u)
- (/= (gnus-soup-encoding-format
- (gnus-soup-reply-encoding (car replies)))
- ?n)) ;; Gnus back compatibility.
- (error "Unsupported encoding"))
- ((null msg-buf)
- t)
- (t
- (buffer-disable-undo msg-buf)
- (set-buffer msg-buf)
- (goto-char (point-min))
- (while (not (eobp))
- (unless (looking-at "#! *rnews +\\([0-9]+\\)")
- (error "Bad header"))
- (forward-line 1)
- (setq beg (point)
- end (+ (point) (string-to-number
- (buffer-substring
- (match-beginning 1) (match-end 1)))))
- (switch-to-buffer tmp-buf)
- (erase-buffer)
- (mm-disable-multibyte)
- (insert-buffer-substring msg-buf beg end)
- (cond
- ((string= (gnus-soup-reply-kind (car replies)) "news")
- (gnus-message 5 "Sending news message to %s..."
- (mail-fetch-field "newsgroups"))
- (sit-for 1)
- (let ((message-syntax-checks
- 'dont-check-for-anything-just-trust-me)
- (method (if (functionp message-post-method)
- (funcall message-post-method)
- message-post-method))
- result)
- (run-hooks 'message-send-news-hook)
- (gnus-open-server method)
- (message "Sending news via %s..."
- (gnus-server-string method))
- (unless (let ((mail-header-separator ""))
- (gnus-request-post method))
- (message "Couldn't send message via news: %s"
- (nnheader-get-report (car method))))))
- ((string= (gnus-soup-reply-kind (car replies)) "mail")
- (gnus-message 5 "Sending mail to %s..."
- (mail-fetch-field "to"))
- (sit-for 1)
- (let ((mail-header-separator ""))
- (funcall (or message-send-mail-real-function
- message-send-mail-function))))
- (t
- (error "Unknown reply kind")))
- (set-buffer msg-buf)
- (goto-char end))
- (delete-file (buffer-file-name))
- (kill-buffer msg-buf)
- (kill-buffer tmp-buf)
- (gnus-message 4 "Sent packet"))))
- (setq replies (cdr replies)))
- t)))
-
-(provide 'gnus-soup)
-
-;; arch-tag: eddfa69d-13e8-4aea-84ef-62a526ef185c
-;;; gnus-soup.el ends here
diff --git a/lisp/gnus/gnus-spec.el b/lisp/gnus/gnus-spec.el
index 1c5fa4741af..31e440e22dd 100644
--- a/lisp/gnus/gnus-spec.el
+++ b/lisp/gnus/gnus-spec.el
@@ -25,7 +25,7 @@
;;; Code:
-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
(eval-when-compile (require 'cl))
@@ -680,7 +680,7 @@ are supported for %s."
((string= fstring "%d")
(setq dontinsert t)
(if insert
- (list `(princ ,(car flist)))
+ `(insert (int-to-string ,(car flist)))
(list `(int-to-string ,(car flist)))))
;; Just lots of chars and strings.
((string-match "\\`\\(%[cs]\\)+\\'" fstring)
@@ -767,5 +767,4 @@ If PROPS, insert the result."
;; coding: iso-8859-1
;; End:
-;; arch-tag: a4328fa1-1f84-4b09-97ad-4b5767cfd50f
;;; gnus-spec.el ends here
diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el
index ba5609efc99..19fd5fe6636 100644
--- a/lisp/gnus/gnus-srvr.el
+++ b/lisp/gnus/gnus-srvr.el
@@ -28,11 +28,14 @@
(eval-when-compile (require 'cl))
(require 'gnus)
+(require 'gnus-start)
(require 'gnus-spec)
(require 'gnus-group)
(require 'gnus-int)
(require 'gnus-range)
+(autoload 'gnus-group-make-nnir-group "nnir")
+
(defcustom gnus-server-mode-hook nil
"Hook run in `gnus-server-mode' buffers."
:group 'gnus-server
@@ -112,6 +115,7 @@ If nil, a faster, but more primitive, buffer is used instead."
["Kill" gnus-server-kill-server t]
["Yank" gnus-server-yank-server t]
["Copy" gnus-server-copy-server t]
+ ["Show" gnus-server-show-server t]
["Edit" gnus-server-edit-server t]
["Regenerate" gnus-server-regenerate-server t]
["Compact" gnus-server-compact-server t]
@@ -149,6 +153,7 @@ If nil, a faster, but more primitive, buffer is used instead."
"c" gnus-server-copy-server
"a" gnus-server-add-server
"e" gnus-server-edit-server
+ "S" gnus-server-show-server
"s" gnus-server-scan-server
"O" gnus-server-open-server
@@ -164,6 +169,8 @@ If nil, a faster, but more primitive, buffer is used instead."
"g" gnus-server-regenerate-server
+ "G" gnus-group-make-nnir-group
+
"z" gnus-server-compact-server
"\C-c\C-i" gnus-info-find-node
@@ -300,9 +307,7 @@ The following commands are available:
"Initialize the server buffer."
(unless (get-buffer gnus-server-buffer)
(with-current-buffer (gnus-get-buffer-create gnus-server-buffer)
- (gnus-server-mode)
- (when gnus-carpal
- (gnus-carpal-setup-buffer 'server)))))
+ (gnus-server-mode))))
(defun gnus-server-prepare ()
(gnus-set-format 'server-mode)
@@ -547,6 +552,7 @@ The following commands are available:
(gnus-server-list-servers))
(defun gnus-server-copy-server (from to)
+ "Copy a server definiton to a new name."
(interactive
(list
(or (gnus-server-server-name)
@@ -569,8 +575,9 @@ The following commands are available:
(defun gnus-server-add-server (how where)
(interactive
- (list (intern (completing-read "Server method: "
- gnus-valid-select-methods nil t))
+ (list (intern (gnus-completing-read "Server method"
+ (mapcar 'car gnus-valid-select-methods)
+ t))
(read-string "Server name: ")))
(when (assq where gnus-server-alist)
(error "Server with that name already defined"))
@@ -580,7 +587,7 @@ The following commands are available:
(defun gnus-server-goto-server (server)
"Jump to a server line."
(interactive
- (list (completing-read "Goto server: " gnus-server-alist nil t)))
+ (list (gnus-completing-read "Goto server" (mapcar 'car gnus-server-alist) t)))
(let ((to (text-property-any (point-min) (point-max)
'gnus-server (intern server))))
(when to
@@ -604,6 +611,18 @@ The following commands are available:
(gnus-server-position-point))
'edit-server)))
+(defun gnus-server-show-server (server)
+ "Show the definition of the server on the current line."
+ (interactive (list (gnus-server-server-name)))
+ (unless server
+ (error "No server on current line"))
+ (let ((info (gnus-server-to-method server)))
+ (gnus-edit-form
+ info "Showing the server."
+ `(lambda (form)
+ (gnus-server-position-point))
+ 'edit-server)))
+
(defun gnus-server-scan-server (server)
"Request a scan from the current server."
(interactive (list (gnus-server-server-name)))
@@ -643,6 +662,30 @@ The following commands are available:
(defvar gnus-browse-menu-hook nil
"*Hook run after the creation of the browse mode menu.")
+(defcustom gnus-browse-subscribe-newsgroup-method
+ 'gnus-subscribe-alphabetically
+ "Function(s) called when subscribing groups in the Browse Server Buffer
+A few pre-made functions are supplied: `gnus-subscribe-randomly'
+inserts new groups at the beginning of the list of groups;
+`gnus-subscribe-alphabetically' inserts new groups in strict
+alphabetic order; `gnus-subscribe-hierarchically' inserts new groups
+in hierarchical newsgroup order; `gnus-subscribe-interactively' asks
+for your decision; `gnus-subscribe-killed' kills all new groups;
+`gnus-subscribe-zombies' will make all new groups into zombies;
+`gnus-subscribe-topics' will enter groups into the topics that
+claim them."
+ :version "24.1"
+ :group 'gnus-server
+ :type '(radio (function-item gnus-subscribe-randomly)
+ (function-item gnus-subscribe-alphabetically)
+ (function-item gnus-subscribe-hierarchically)
+ (function-item gnus-subscribe-interactively)
+ (function-item gnus-subscribe-killed)
+ (function-item gnus-subscribe-zombies)
+ (function-item gnus-subscribe-topics)
+ function
+ (repeat function)))
+
(defvar gnus-browse-mode-hook nil)
(defvar gnus-browse-mode-map nil)
(put 'gnus-browse-mode 'mode-class 'special)
@@ -779,8 +822,6 @@ The following commands are available:
(funcall gnus-group-prepare-function
gnus-level-killed 'ignore 1 'ignore))
(gnus-get-buffer-create gnus-browse-buffer)
- (when gnus-carpal
- (gnus-carpal-setup-buffer 'browse))
(gnus-configure-windows 'browse)
(buffer-disable-undo)
(let ((buffer-read-only nil))
@@ -890,7 +931,9 @@ If NUMBER, fetch this number of articles."
(gnus-browse-next-group (- n)))
(defun gnus-browse-unsubscribe-current-group (arg)
- "(Un)subscribe to the next ARG groups."
+ "(Un)subscribe to the next ARG groups.
+The variable `gnus-browse-subscribe-newsgroup-method' determines
+how new groups will be entered into the group buffer."
(interactive "p")
(when (eobp)
(error "No group at current line"))
@@ -939,22 +982,24 @@ If NUMBER, fetch this number of articles."
;; subscribe to it.
(if (gnus-ephemeral-group-p group)
(gnus-kill-ephemeral-group group))
- ;; We need to discern between killed/zombie groups and
- ;; just unsubscribed ones.
- (gnus-group-change-level
- (or (gnus-group-entry group)
- (list t group gnus-level-default-subscribed
- nil nil (if (gnus-server-equal
- gnus-browse-current-method "native")
- nil
- (gnus-method-simplify
- gnus-browse-current-method))))
- gnus-level-default-subscribed (gnus-group-level group)
- (and (car (nth 1 gnus-newsrc-alist))
- (gnus-group-entry (car (nth 1 gnus-newsrc-alist))))
- (null (gnus-group-entry group)))
+ (let ((entry (gnus-group-entry group)))
+ (if entry
+ ;; Just change the subscription level if it is an
+ ;; unsubscribed group.
+ (gnus-group-change-level entry
+ gnus-level-default-subscribed)
+ ;; If it is a killed group or a zombie, feed it to the
+ ;; mechanism for new group subscription.
+ (gnus-call-subscribe-functions
+ gnus-browse-subscribe-newsgroup-method
+ group)))
(delete-char 1)
- (insert ? ))
+ (insert (let ((lvl (gnus-group-level group)))
+ (cond
+ ((< lvl gnus-level-unsubscribed) ? )
+ ((< lvl gnus-level-zombie) ?U)
+ ((< lvl gnus-level-killed) ?Z)
+ (t ?K)))))
(gnus-group-change-level
group gnus-level-unsubscribed gnus-level-default-subscribed)
(delete-char 1)
@@ -976,7 +1021,7 @@ If NUMBER, fetch this number of articles."
(defun gnus-browse-describe-briefly ()
"Give a one line description of the group mode commands."
(interactive)
- (gnus-message 6
+ (gnus-message 6 "%s"
(substitute-command-keys "\\<gnus-browse-mode-map>\\[gnus-group-next-group]:Forward \\[gnus-group-prev-group]:Backward \\[gnus-browse-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-browse-describe-briefly]:This help")))
(defun gnus-server-regenerate-server ()
@@ -1033,5 +1078,4 @@ Requesting compaction of %s... (this may take a long time)"
(provide 'gnus-srvr)
-;; arch-tag: c0117f64-27ca-475d-9406-8da6854c7a25
;;; gnus-srvr.el ends here
diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el
index bf08ba6f888..8663d67fd0a 100644
--- a/lisp/gnus/gnus-start.el
+++ b/lisp/gnus/gnus-start.el
@@ -181,7 +181,7 @@ Groups with levels less than `gnus-level-subscribed', which
should be less than this variable, are subscribed. Groups with
levels from `gnus-level-subscribed' (exclusive) upto this
variable (inclusive) are unsubscribed. See also
-`gnus-level-zombie', `gnus-level-killed' and the Info node `Group
+`gnus-level-zombie', `gnus-level-killed' and the Info node `(gnus)Group
Levels' for details.")
(defconst gnus-level-zombie 8
@@ -268,7 +268,7 @@ not match this regexp will be removed before saving the list."
(mapconcat 'identity
'("^to\\." ; not "real" groups
"^[0-9. \t]+\\( \\|$\\)" ; all digits in name
- "^[\"][]\"[#'()]" ; bogus characters
+ "^[\"][\"#'()]" ; bogus characters
)
"\\|")
"*A regexp to match uninteresting newsgroups in the active file.
@@ -380,6 +380,13 @@ disc."
:group 'gnus-newsrc
:type 'boolean)
+(defcustom gnus-use-backend-marks nil
+ "If non-nil, Gnus will store and retrieve marks from the backends.
+This means that marks will be stored both in .newsrc.eld and in
+the backend, and will slow operation down somewhat."
+ :group 'gnus-newsrc
+ :type 'boolean)
+
(defcustom gnus-check-bogus-groups-hook nil
"A hook run after removing bogus groups."
:group 'gnus-start-server
@@ -402,8 +409,7 @@ This hook is called as the first thing when Gnus is started."
:group 'gnus-start
:type 'hook)
-(defcustom gnus-setup-news-hook
- '(gnus-fixup-nnimap-unread-after-getting-new-news)
+(defcustom gnus-setup-news-hook nil
"A hook after reading the .newsrc file, but before generating the buffer."
:group 'gnus-start
:type 'hook)
@@ -420,9 +426,9 @@ This hook is called as the first thing when Gnus is started."
:type 'hook)
(defcustom gnus-after-getting-new-news-hook
- '(gnus-display-time-event-handler
- gnus-fixup-nnimap-unread-after-getting-new-news)
+ '(gnus-display-time-event-handler)
"*A hook run after Gnus checks for new news when Gnus is already running."
+ :version "24.1"
:group 'gnus-group-new
:type 'hook)
@@ -594,8 +600,7 @@ Can be used to turn version control on or off."
(defun gnus-subscribe-hierarchically (newgroup)
"Subscribe new NEWGROUP and insert it in hierarchical newsgroup order."
;; Basic ideas by mike-w@cs.aukuni.ac.nz (Mike Williams)
- (save-excursion
- (set-buffer (nnheader-find-file-noselect gnus-current-startup-file))
+ (with-current-buffer (nnheader-find-file-noselect gnus-current-startup-file)
(prog1
(let ((groupkey newgroup) before)
(while (and (not before) groupkey)
@@ -706,6 +711,7 @@ the first newsgroup."
nnoo-state-alist nil
gnus-current-select-method nil
nnmail-split-history nil
+ gnus-extended-servers nil
gnus-ephemeral-servers nil)
(gnus-shutdown 'gnus)
;; Kill the startup file.
@@ -765,18 +771,10 @@ prompt the user for the name of an NNTP server to use."
(when gnus-select-method
(push (cons "native" gnus-select-method)
gnus-predefined-server-alist))
-
+
(if gnus-agent
(gnus-agentize))
- (when gnus-simple-splash
- (setq gnus-simple-splash nil)
- (cond
- ((featurep 'xemacs)
- (gnus-xmas-splash))
- (window-system
- (gnus-x-splash))))
-
(let ((level (and (numberp arg) (> arg 0) arg))
did-connect)
(unwind-protect
@@ -814,6 +812,7 @@ prompt the user for the name of an NNTP server to use."
(defun gnus-start-draft-setup ()
"Make sure the draft group exists."
+ (interactive)
(gnus-request-create-group "drafts" '(nndraft ""))
(unless (gnus-group-entry "nndraft:drafts")
(let ((gnus-level-default-subscribed 1))
@@ -856,8 +855,7 @@ prompt the user for the name of an NNTP server to use."
;; it's not needed).
;; (set-window-point (get-buffer-window (current-buffer)) (point-max))
(bury-buffer gnus-dribble-buffer)
- (save-excursion
- (set-buffer gnus-group-buffer)
+ (with-current-buffer gnus-group-buffer
(gnus-group-set-mode-line))
(set-buffer obuf))))
@@ -868,10 +866,11 @@ prompt the user for the name of an NNTP server to use."
(defun gnus-dribble-read-file ()
"Read the dribble file from disk."
(let ((dribble-file (gnus-dribble-file-name)))
- (save-excursion
- (set-buffer (setq gnus-dribble-buffer
- (gnus-get-buffer-create
- (file-name-nondirectory dribble-file))))
+ (unless (file-exists-p (file-name-directory dribble-file))
+ (make-directory (file-name-directory dribble-file) t))
+ (with-current-buffer (setq gnus-dribble-buffer
+ (gnus-get-buffer-create
+ (file-name-nondirectory dribble-file)))
(set (make-local-variable 'file-precious-flag) t)
(erase-buffer)
(setq buffer-file-name dribble-file)
@@ -920,8 +919,7 @@ prompt the user for the name of an NNTP server to use."
(when (file-exists-p (gnus-dribble-file-name))
(delete-file (gnus-dribble-file-name)))
(when gnus-dribble-buffer
- (save-excursion
- (set-buffer gnus-dribble-buffer)
+ (with-current-buffer gnus-dribble-buffer
(let ((auto (make-auto-save-file-name)))
(when (file-exists-p auto)
(delete-file auto))
@@ -931,14 +929,12 @@ prompt the user for the name of an NNTP server to use."
(defun gnus-dribble-save ()
(when (and gnus-dribble-buffer
(buffer-name gnus-dribble-buffer))
- (save-excursion
- (set-buffer gnus-dribble-buffer)
+ (with-current-buffer gnus-dribble-buffer
(save-buffer))))
(defun gnus-dribble-clear ()
(when (gnus-buffer-exists-p gnus-dribble-buffer)
- (save-excursion
- (set-buffer gnus-dribble-buffer)
+ (with-current-buffer gnus-dribble-buffer
(erase-buffer)
(set-buffer-modified-p nil)
(setq buffer-saved-size (buffer-size)))))
@@ -1059,15 +1055,6 @@ If LEVEL is non-nil, the news will be set up at level LEVEL."
(gnus-server-opened gnus-select-method))
(gnus-check-bogus-newsgroups))
- ;; We might read in new NoCeM messages here.
- (when (and (not dont-connect)
- gnus-use-nocem
- (or (and (numberp gnus-use-nocem)
- (numberp level)
- (>= level gnus-use-nocem))
- (not level)))
- (gnus-nocem-scan-groups))
-
;; Read any slave files.
(gnus-master-read-slave-newsrc)
@@ -1113,53 +1100,53 @@ for new groups, and subscribe the new groups as zombies."
'gnus-subscribe-zombies)
t)
(t gnus-check-new-newsgroups))))
- (unless (gnus-check-first-time-used)
- (if (or (consp check)
- (eq check 'ask-server))
- ;; Ask the server for new groups.
- (gnus-ask-server-for-new-groups)
- ;; Go through the active hashtb and look for new groups.
- (let ((groups 0)
- group new-newsgroups)
- (gnus-message 5 "Looking for new newsgroups...")
- (unless gnus-have-read-active-file
- (gnus-read-active-file))
- (setq gnus-newsrc-last-checked-date (message-make-date))
- (unless gnus-killed-hashtb
- (gnus-make-hashtable-from-killed))
- ;; Go though every newsgroup in `gnus-active-hashtb' and compare
- ;; with `gnus-newsrc-hashtb' and `gnus-killed-hashtb'.
- (mapatoms
- (lambda (sym)
- (if (or (null (setq group (symbol-name sym)))
- (not (boundp sym))
- (null (symbol-value sym))
- (gnus-gethash group gnus-killed-hashtb)
- (gnus-gethash group gnus-newsrc-hashtb))
- ()
- (let ((do-sub (gnus-matches-options-n group)))
- (cond
- ((eq do-sub 'subscribe)
- (setq groups (1+ groups))
- (gnus-sethash group group gnus-killed-hashtb)
- (gnus-call-subscribe-functions
- gnus-subscribe-options-newsgroup-method group))
- ((eq do-sub 'ignore)
- nil)
- (t
- (setq groups (1+ groups))
- (gnus-sethash group group gnus-killed-hashtb)
- (if gnus-subscribe-hierarchical-interactive
- (push group new-newsgroups)
- (gnus-call-subscribe-functions
- gnus-subscribe-newsgroup-method group)))))))
- gnus-active-hashtb)
- (when new-newsgroups
- (gnus-subscribe-hierarchical-interactive new-newsgroups))
- (if (> groups 0)
- (gnus-message 5 "%d new newsgroup%s arrived."
- groups (if (> groups 1) "s have" " has"))
- (gnus-message 5 "No new newsgroups.")))))))
+ (if (or (consp check)
+ (eq check 'ask-server))
+ ;; Ask the server for new groups.
+ (gnus-ask-server-for-new-groups)
+ ;; Go through the active hashtb and look for new groups.
+ (let ((groups 0)
+ group new-newsgroups)
+ (gnus-message 5 "Looking for new newsgroups...")
+ (unless gnus-have-read-active-file
+ (gnus-read-active-file))
+ (setq gnus-newsrc-last-checked-date (message-make-date))
+ (unless gnus-killed-hashtb
+ (gnus-make-hashtable-from-killed))
+ ;; Go though every newsgroup in `gnus-active-hashtb' and compare
+ ;; with `gnus-newsrc-hashtb' and `gnus-killed-hashtb'.
+ (mapatoms
+ (lambda (sym)
+ (if (or (null (setq group (symbol-name sym)))
+ (not (boundp sym))
+ (null (symbol-value sym))
+ (gnus-gethash group gnus-killed-hashtb)
+ (gnus-gethash group gnus-newsrc-hashtb))
+ ()
+ (let ((do-sub (gnus-matches-options-n group)))
+ (cond
+ ((eq do-sub 'subscribe)
+ (setq groups (1+ groups))
+ (gnus-sethash group group gnus-killed-hashtb)
+ (gnus-call-subscribe-functions
+ gnus-subscribe-options-newsgroup-method group))
+ ((eq do-sub 'ignore)
+ nil)
+ (t
+ (setq groups (1+ groups))
+ (gnus-sethash group group gnus-killed-hashtb)
+ (if gnus-subscribe-hierarchical-interactive
+ (push group new-newsgroups)
+ (gnus-call-subscribe-functions
+ gnus-subscribe-newsgroup-method group)))))))
+ gnus-active-hashtb)
+ (when new-newsgroups
+ (gnus-subscribe-hierarchical-interactive new-newsgroups))
+ (if (> groups 0)
+ (gnus-message 5 "%d new newsgroup%s arrived."
+ groups (if (> groups 1) "s have" " has"))
+ (gnus-message 5 "No new newsgroups."))
+ groups))))
(defun gnus-matches-options-n (group)
;; Returns `subscribe' if the group is to be unconditionally
@@ -1257,55 +1244,7 @@ for new groups, and subscribe the new groups as zombies."
(gnus-message 5 "No new newsgroups"))
(when got-new
(setq gnus-newsrc-last-checked-date new-date))
- got-new))
-
-(defun gnus-check-first-time-used ()
- (catch 'ended
- ;; First check if any of the following files exist. If they do,
- ;; it's not the first time the user has used Gnus.
- (dolist (file (list (concat gnus-current-startup-file ".el")
- (concat gnus-current-startup-file ".eld")
- (concat gnus-startup-file ".el")
- (concat gnus-startup-file ".eld")))
- (when (file-exists-p file)
- (throw 'ended nil)))
- (gnus-message 6 "First time user; subscribing you to default groups")
- (unless (gnus-read-active-file-p)
- (let ((gnus-read-active-file t))
- (gnus-read-active-file)))
- (setq gnus-newsrc-last-checked-date (message-make-date))
- ;; Subscribe to the default newsgroups.
- (let ((groups (or gnus-default-subscribed-newsgroups
- gnus-backup-default-subscribed-newsgroups))
- group)
- (if (eq groups t)
- ;; If t, we subscribe (or not) all groups as if they were new.
- (mapatoms
- (lambda (sym)
- (when (setq group (symbol-name sym))
- (let ((do-sub (gnus-matches-options-n group)))
- (cond
- ((eq do-sub 'subscribe)
- (gnus-sethash group group gnus-killed-hashtb)
- (gnus-call-subscribe-functions
- gnus-subscribe-options-newsgroup-method group))
- ((eq do-sub 'ignore)
- nil)
- (t
- (push group gnus-killed-list))))))
- gnus-active-hashtb)
- (dolist (group groups)
- ;; Only subscribe the default groups that are activated.
- (when (gnus-active group)
- (gnus-group-change-level
- group gnus-level-default-subscribed gnus-level-killed)))
- (save-excursion
- (set-buffer gnus-group-buffer)
- ;; Don't error if the group already exists. This happens when a
- ;; first-time user types 'F'. -- didier
- (gnus-group-make-help-group t))
- (when gnus-novice-user
- (gnus-message 7 "`A k' to list killed groups"))))))
+ new-newsgroups))
(defun gnus-subscribe-group (group &optional previous method)
"Subscribe GROUP and put it after PREVIOUS."
@@ -1471,7 +1410,7 @@ newsgroup."
(push group bogus)))
(if confirm
(map-y-or-n-p
- "Remove bogus group %s? "
+ (format "Remove bogus group %%s (of %d groups)? " (length bogus))
(lambda (group)
;; Remove all bogus subscribed groups by first killing them, and
;; then removing them from the list of killed groups.
@@ -1523,7 +1462,8 @@ newsgroup."
(when (> (cdr cache-active) (cdr active))
(setcdr active (cdr cache-active))))))))
-(defun gnus-activate-group (group &optional scan dont-check method)
+(defun gnus-activate-group (group &optional scan dont-check method
+ dont-sub-check)
"Check whether a group has been activated or not.
If SCAN, request a scan of that group as well."
(let ((method (or method (inline (gnus-find-method-for-group group))))
@@ -1538,9 +1478,13 @@ If SCAN, request a scan of that group as well."
(gnus-request-scan group method))
t)
(if (or debug-on-error debug-on-quit)
- (inline (gnus-request-group group dont-check method))
+ (inline (gnus-request-group group (or dont-sub-check dont-check)
+ method
+ (gnus-get-info group)))
(condition-case nil
- (inline (gnus-request-group group dont-check method))
+ (inline (gnus-request-group group (or dont-sub-check dont-check)
+ method
+ (gnus-get-info group)))
;;(error nil)
(quit
(message "Quit activating %s" group)
@@ -1578,6 +1522,13 @@ If SCAN, request a scan of that group as well."
(gnus-info-group info)))))
(gnus-activate-group (gnus-info-group info) nil t))
+ ;; Allow backends to update marks,
+ (when gnus-use-backend-marks
+ (let ((method (inline (gnus-find-method-for-group
+ (gnus-info-group info)))))
+ (when (gnus-check-backend-function 'request-marks (car method))
+ (gnus-request-marks info method))))
+
(let* ((range (gnus-info-read info))
(num 0))
@@ -1668,148 +1619,162 @@ If SCAN, request a scan of that group as well."
;; and compute how many unread articles there are in each group.
(defun gnus-get-unread-articles (&optional level)
(setq gnus-server-method-cache nil)
+ (require 'gnus-agent)
(let* ((newsrc (cdr gnus-newsrc-alist))
(alevel (or level gnus-activate-level (1+ gnus-level-subscribed)))
(foreign-level
- (min
- (cond ((and gnus-activate-foreign-newsgroups
- (not (numberp gnus-activate-foreign-newsgroups)))
- (1+ gnus-level-subscribed))
- ((numberp gnus-activate-foreign-newsgroups)
- gnus-activate-foreign-newsgroups)
- (t 0))
- alevel))
+ (or
+ level
+ (min
+ (cond ((and gnus-activate-foreign-newsgroups
+ (not (numberp gnus-activate-foreign-newsgroups)))
+ (1+ gnus-level-subscribed))
+ ((numberp gnus-activate-foreign-newsgroups)
+ gnus-activate-foreign-newsgroups)
+ (t 0))
+ alevel)))
(methods-cache nil)
(type-cache nil)
- scanned-methods info group active method retrieve-groups cmethod
- method-type)
+ (gnus-agent-article-local-times 0)
+ (archive-method (gnus-server-to-method "archive"))
+ infos info group active method cmethod
+ method-type method-group-list entry)
(gnus-message 6 "Checking new news...")
(while newsrc
(setq active (gnus-active (setq group (gnus-info-group
(setq info (pop newsrc))))))
-
- ;; Check newsgroups. If the user doesn't want to check them, or
- ;; they can't be checked (for instance, if the news server can't
- ;; be reached) we just set the number of unread articles in this
- ;; newsgroup to t. This means that Gnus thinks that there are
- ;; unread articles, but it has no idea how many.
-
- ;; To be more explicit:
- ;; >0 for an active group with messages
- ;; 0 for an active group with no unread messages
- ;; nil for non-foreign groups that the user has requested not be checked
- ;; t for unchecked foreign groups or bogus groups, or groups that can't
- ;; be checked, for one reason or other.
- (when (setq method (gnus-info-method info))
+ ;; First go through all the groups, see what select methods they
+ ;; belong to, and then collect them into lists per unique select
+ ;; method.
+ (if (not (setq method (gnus-info-method info)))
+ (setq method gnus-select-method)
+ ;; There may be several similar methods. Possibly extend the
+ ;; method.
(if (setq cmethod (assoc method methods-cache))
(setq method (cdr cmethod))
- (setq cmethod (inline (gnus-server-get-method nil method)))
+ (setq cmethod (if (stringp method)
+ (gnus-server-to-method method)
+ (inline (gnus-find-method-for-group
+ (gnus-info-group info) info))))
(push (cons method cmethod) methods-cache)
(setq method cmethod)))
- (when (and method
- (not (setq method-type (cdr (assoc method type-cache)))))
+ (setq method-group-list (assoc method type-cache))
+ (unless method-group-list
(setq method-type
(cond
- ((gnus-secondary-method-p method)
+ ((or (gnus-secondary-method-p method)
+ (and (gnus-archive-server-wanted-p)
+ (gnus-methods-equal-p archive-method method)))
'secondary)
((inline (gnus-server-equal gnus-select-method method))
'primary)
(t
'foreign)))
- (push (cons method method-type) type-cache))
-
- (cond ((and method (eq method-type 'foreign))
- ;; These groups are foreign. Check the level.
- (if (<= (gnus-info-level info) foreign-level)
- (when (setq active (gnus-activate-group group 'scan))
- ;; Let the Gnus agent save the active file.
- (when (and gnus-agent active (gnus-online method))
- (gnus-agent-save-group-info
- method (gnus-group-real-name group) active))
- (unless (inline (gnus-virtual-group-p group))
- (inline (gnus-close-group group)))
- (when (fboundp (intern (concat (symbol-name (car method))
- "-request-update-info")))
- (inline (gnus-request-update-info info method))))
- (if (and level
- ;; If `active' is nil that means the group has
- ;; never been read, the group should be marked
- ;; as having never been checked (see below).
- active
- (> (gnus-info-level info) level))
- ;; Don't check groups of which levels are higher
- ;; than the one that a user specified.
- (setq active 'ignore))))
- ;; These groups are native or secondary.
- ((> (gnus-info-level info) alevel)
- ;; We don't want these groups.
- (setq active 'ignore))
- ;; Activate groups.
- ((not gnus-read-active-file)
- (if (gnus-check-backend-function 'retrieve-groups group)
- ;; if server support gnus-retrieve-groups we push
- ;; the group onto retrievegroups for later checking
- (if (assoc method retrieve-groups)
- (setcdr (assoc method retrieve-groups)
- (cons group (cdr (assoc method retrieve-groups))))
- (push (list method group) retrieve-groups))
- ;; hack: `nnmail-get-new-mail' changes the mail-source depending
- ;; on the group, so we must perform a scan for every group
- ;; if the users has any directory mail sources.
- ;; hack: if `nnmail-scan-directory-mail-source-once' is non-nil,
- ;; for it scan all spool files even when the groups are
- ;; not required.
- (if (and
- (or nnmail-scan-directory-mail-source-once
- (null (assq 'directory mail-sources)))
- (member method scanned-methods))
- (setq active (gnus-activate-group group))
- (setq active (gnus-activate-group group 'scan))
- (push method scanned-methods))
- (when active
- (gnus-close-group group)))))
-
- ;; Get the number of unread articles in the group.
- (cond
- ((eq active 'ignore)
- ;; Don't do anything.
- )
- (active
- (inline (gnus-get-unread-articles-in-group info active t)))
- (t
- ;; The group couldn't be reached, so we nix out the number of
- ;; unread articles and stuff.
- (gnus-set-active group nil)
- (let ((tmp (gnus-group-entry group)))
- (when tmp
- (setcar tmp t))))))
-
- ;; iterate through groups on methods which support gnus-retrieve-groups
- ;; and fetch a partial active file and use it to find new news.
- (dolist (rg retrieve-groups)
- (let ((method (or (car rg) gnus-select-method))
- (groups (cdr rg)))
- (when (gnus-check-server method)
- ;; Request that the backend scan its incoming messages.
- (when (gnus-check-backend-function 'request-scan (car method))
- (gnus-request-scan nil method))
- (gnus-read-active-file-2
- (mapcar (lambda (group) (gnus-group-real-name group)) groups)
- method)
- (dolist (group groups)
- (cond
- ((setq active (gnus-active (gnus-info-group
- (setq info (gnus-get-info group)))))
- (inline (gnus-get-unread-articles-in-group info active t)))
- (t
- ;; The group couldn't be reached, so we nix out the number of
- ;; unread articles and stuff.
- (gnus-set-active group nil)
- (setcar (gnus-group-entry group) t)))))))
-
+ (push (setq method-group-list (list method method-type nil nil))
+ type-cache))
+ ;; Only add groups that need updating.
+ (if (<= (gnus-info-level info)
+ (if (eq (cadr method-group-list) 'foreign)
+ foreign-level
+ alevel))
+ (setcar (nthcdr 2 method-group-list)
+ (cons info (nth 2 method-group-list)))
+ ;; The group is inactive, so we nix out the number of unread articles.
+ ;; It leads `(gnus-group-unread group)' to return t. See also
+ ;; `gnus-group-prepare-flat'.
+ (unless active
+ (when (setq entry (gnus-group-entry group))
+ (setcar entry t)))))
+
+ ;; Sort the methods based so that the primary and secondary
+ ;; methods come first. This is done for legacy reasons to try to
+ ;; ensure that side-effect behaviour doesn't change from previous
+ ;; Gnus versions.
+ (setq type-cache
+ (sort (nreverse type-cache)
+ (lambda (c1 c2)
+ (< (gnus-method-rank (cadr c1) (car c1))
+ (gnus-method-rank (cadr c2) (car c2))))))
+
+ ;; Start early async retrieval of data.
+ (dolist (elem type-cache)
+ (destructuring-bind (method method-type infos dummy) elem
+ (when (and method infos
+ (not (gnus-method-denied-p method)))
+ ;; If the open-server method doesn't exist, then the method
+ ;; itself doesn't exist, so we ignore it.
+ (if (not (ignore-errors (gnus-get-function method 'open-server)))
+ (setq type-cache (delq elem type-cache))
+ (unless (gnus-server-opened method)
+ (gnus-open-server method))
+ (when (and
+ (gnus-server-opened method)
+ (gnus-check-backend-function
+ 'retrieve-group-data-early (car method)))
+ (when (gnus-check-backend-function 'request-scan (car method))
+ (gnus-request-scan nil method))
+ (setcar (nthcdr 3 elem)
+ (gnus-retrieve-group-data-early method infos)))))))
+
+ ;; Do the rest of the retrieval.
+ (dolist (elem type-cache)
+ (destructuring-bind (method method-type infos early-data) elem
+ (when (and method infos)
+ (let ((updatep (gnus-check-backend-function
+ 'request-update-info (car method))))
+ ;; See if any of the groups from this method require updating.
+ (gnus-read-active-for-groups method infos early-data)
+ (dolist (info infos)
+ (inline (gnus-get-unread-articles-in-group
+ info (gnus-active (gnus-info-group info))
+ updatep)))))))
(gnus-message 6 "Checking new news...done")))
+(defun gnus-method-rank (type method)
+ (cond
+ ;; Get info for virtual groups last.
+ ((eq (car method) 'nnvirtual)
+ 200)
+ ((eq type 'primary)
+ 1)
+ ;; Compute the rank of the secondary methods based on where they
+ ;; are in the secondary select list.
+ ((eq type 'secondary)
+ (let ((i 2))
+ (block nil
+ (dolist (smethod gnus-secondary-select-methods)
+ (when (equal method smethod)
+ (return i))
+ (incf i))
+ i)))
+ ;; Just say that all foreign groups have the same rank.
+ (t
+ 100)))
+
+(defun gnus-read-active-for-groups (method infos early-data)
+ (with-current-buffer nntp-server-buffer
+ (cond
+ ((and
+ (gnus-check-backend-function 'finish-retrieve-group-infos (car method))
+ (or (not (gnus-agent-method-p method))
+ (gnus-online method)))
+ (gnus-finish-retrieve-group-infos method infos early-data)
+ (gnus-agent-save-active method))
+ ((gnus-check-backend-function 'retrieve-groups (car method))
+ (when (gnus-check-backend-function 'request-scan (car method))
+ (gnus-request-scan nil method))
+ (let (groups)
+ (gnus-read-active-file-2
+ (dolist (info infos (nreverse groups))
+ (push (gnus-group-real-name (gnus-info-group info)) groups))
+ method)))
+ ((gnus-check-backend-function 'request-list (car method))
+ (gnus-read-active-file-1 method nil infos))
+ (t
+ (dolist (info infos)
+ (gnus-activate-group (gnus-info-group info) nil nil method t))))))
+
;; Create a hash table out of the newsrc alist. The `car's of the
;; alist elements are used as keys.
(defun gnus-make-hashtable-from-newsrc-alist ()
@@ -1830,14 +1795,18 @@ If SCAN, request a scan of that group as well."
(if (setq rest (member method methods))
(gnus-info-set-method info (car rest))
(push method methods)))
- (gnus-sethash
- (car info)
- ;; Preserve number of unread articles in groups.
- (cons (and ohashtb (car (gnus-gethash (car info) ohashtb)))
- prev)
- gnus-newsrc-hashtb)
- (setq prev alist
- alist (cdr alist)))
+ ;; Check for duplicates.
+ (if (gnus-gethash (car info) gnus-newsrc-hashtb)
+ ;; Remove this entry from the alist.
+ (setcdr prev (cddr prev))
+ (gnus-sethash
+ (car info)
+ ;; Preserve number of unread articles in groups.
+ (cons (and ohashtb (car (gnus-gethash (car info) ohashtb)))
+ prev)
+ gnus-newsrc-hashtb)
+ (setq prev alist))
+ (setq alist (cdr alist)))
;; Make the same select-methods in `gnus-server-alist' identical
;; as well.
(while methods
@@ -1859,8 +1828,7 @@ If SCAN, request a scan of that group as well."
(defun gnus-parse-active ()
"Parse active info in the nntp server buffer."
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(goto-char (point-min))
;; Parse the result we got from `gnus-request-group'.
(when (looking-at "[0-9]+ [0-9]+ \\([0-9]+\\) [0-9]+")
@@ -2014,12 +1982,13 @@ If SCAN, request a scan of that group as well."
(list "archive")))))
method)
(setq gnus-have-read-active-file nil)
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(while (setq method (pop methods))
;; Only do each method once, in case the methods appear more
;; than once in this list.
- (unless (member method methods)
+ (when (and (not (member method methods))
+ ;; Check whether the backend exists.
+ (ignore-errors (gnus-get-function method 'open-server)))
(if (or debug-on-error debug-on-quit)
(gnus-read-active-file-1 method force)
(condition-case ()
@@ -2030,17 +1999,20 @@ If SCAN, request a scan of that group as well."
(message "Quit reading the active file")
nil))))))))
-(defun gnus-read-active-file-1 (method force)
+(defun gnus-read-active-file-1 (method force &optional infos)
(let (where mesg)
(setq where (nth 1 method)
mesg (format "Reading active file%s via %s..."
(if (and where (not (zerop (length where))))
(concat " from " where) "")
(car method)))
- (gnus-message 5 mesg)
+ (gnus-message 5 "%s" mesg)
(when (gnus-check-server method)
;; Request that the backend scan its incoming messages.
- (when (gnus-check-backend-function 'request-scan (car method))
+ (when (and (or (and gnus-agent
+ (gnus-online method))
+ (not gnus-agent))
+ (gnus-check-backend-function 'request-scan (car method)))
(gnus-request-scan nil method))
(cond
((and (eq gnus-read-active-file 'some)
@@ -2066,17 +2038,16 @@ If SCAN, request a scan of that group as well."
(unless (equal method gnus-message-archive-method)
(gnus-error 1 "Cannot read active file from %s server"
(car method)))
- (gnus-message 5 mesg)
+ (gnus-message 5 "%s" mesg)
(gnus-active-to-gnus-format method gnus-active-hashtb nil t)
;; We mark this active file as read.
- (push method gnus-have-read-active-file)
+ (add-to-list 'gnus-have-read-active-file method)
(gnus-message 5 "%sdone" mesg)))))))
(defun gnus-read-active-file-2 (groups method)
"Read an active file for GROUPS in METHOD using `gnus-retrieve-groups'."
(when groups
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(gnus-check-server method)
(let ((list-type (gnus-retrieve-groups groups method)))
(cond ((not list-type)
@@ -2757,8 +2728,7 @@ If FORCE is non-nil, the .newsrc file is read."
(not force)
(or (not gnus-dribble-buffer)
(not (buffer-name gnus-dribble-buffer))
- (zerop (save-excursion
- (set-buffer gnus-dribble-buffer)
+ (zerop (with-current-buffer gnus-dribble-buffer
(buffer-size)))))
(gnus-message 4 "(No changes need to be saved)")
(gnus-run-hooks 'gnus-save-newsrc-hook)
@@ -2892,8 +2862,7 @@ If FORCE is non-nil, the .newsrc file is read."
(defun gnus-gnus-to-newsrc-format ()
;; Generate and save the .newsrc file.
- (save-excursion
- (set-buffer (create-file-buffer gnus-current-startup-file))
+ (with-current-buffer (create-file-buffer gnus-current-startup-file)
(let ((newsrc (cdr gnus-newsrc-alist))
(standard-output (current-buffer))
info ranges range method)
@@ -2960,12 +2929,13 @@ If FORCE is non-nil, the .newsrc file is read."
(defun gnus-slave-mode ()
"Minor mode for slave Gnusae."
+ ;; FIXME: gnus-slave-mode appears to never be set (i.e. it'll always be nil):
+ ;; Remove, or fix and use define-minor-mode.
(add-minor-mode 'gnus-slave-mode " Slave" (make-sparse-keymap))
(gnus-run-hooks 'gnus-slave-mode-hook))
(defun gnus-slave-save-newsrc ()
- (save-excursion
- (set-buffer gnus-dribble-buffer)
+ (with-current-buffer gnus-dribble-buffer
(let ((slave-name
(mm-make-temp-file (concat gnus-current-startup-file "-slave-")))
(modes (ignore-errors
@@ -2989,8 +2959,7 @@ If FORCE is non-nil, the .newsrc file is read."
(if (not slave-files)
() ; There are no slave files to read.
(gnus-message 7 "Reading slave newsrcs...")
- (save-excursion
- (set-buffer (gnus-get-buffer-create " *gnus slave*"))
+ (with-current-buffer (gnus-get-buffer-create " *gnus slave*")
(setq slave-files
(sort (mapcar (lambda (file)
(list (nth 5 (file-attributes file)) file))
@@ -3058,6 +3027,7 @@ If FORCE is non-nil, the .newsrc file is read."
nil)
(t
(save-excursion
+ ;; FIXME: Shouldn't save-restriction be done after set-buffer?
(save-restriction
(set-buffer nntp-server-buffer)
(goto-char (point-min))
@@ -3109,8 +3079,7 @@ If FORCE is non-nil, the .newsrc file is read."
(defun gnus-group-get-description (group)
"Get the description of a group by sending XGTITLE to the server."
(when (gnus-request-group-description group)
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(goto-char (point-min))
(when (looking-at "[^ \t]+[ \t]+\\(.*\\)")
(match-string 1)))))
@@ -3137,20 +3106,6 @@ If this variable is nil, don't do anything."
(gnus-boundp 'display-time-timer))
(display-time-event-handler)))
-;;;###autoload
-(defun gnus-fixup-nnimap-unread-after-getting-new-news ()
- (let (server group info)
- (mapatoms
- (lambda (sym)
- (when (and (setq group (symbol-name sym))
- (gnus-group-entry group)
- (setq info (symbol-value sym)))
- (gnus-sethash group (cons (nth 2 info) (cdr (gnus-group-entry group)))
- gnus-newsrc-hashtb)))
- (if (boundp 'nnimap-mailbox-info)
- (symbol-value 'nnimap-mailbox-info)
- (make-vector 1 0)))))
-
(defun gnus-check-reasonable-setup ()
;; Check whether nnml and nnfolder share a directory.
(let ((display-warn
@@ -3189,7 +3144,4 @@ If this variable is nil, don't do anything."
(provide 'gnus-start)
-;; arch-tag: f4584a22-b7b7-4853-abfc-a637329af5d2
;;; gnus-start.el ends here
-
-
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index 2464b132839..2d679dab246 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -25,11 +25,14 @@
;;; Code:
-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
(eval-when-compile
(require 'cl))
+(eval-when-compile
+ (when (featurep 'xemacs)
+ (require 'easy-mmode))) ; for `define-minor-mode'
(defvar tool-bar-mode)
(defvar gnus-tmp-header)
@@ -73,6 +76,13 @@ See `gnus-group-goto-unread'."
:version "23.1" ;; No Gnus
:type 'boolean)
+(defcustom gnus-summary-stop-at-end-of-message nil
+ "If non-nil, don't select the next message when using `SPC'."
+ :link '(custom-manual "(gnus)Group Maneuvering")
+ :group 'gnus-summary-maneuvering
+ :version "24.1"
+ :type 'boolean)
+
(defcustom gnus-fetch-old-headers nil
"*Non-nil means that Gnus will try to build threads by grabbing old headers.
If an unread article in the group refers to an older, already
@@ -211,7 +221,7 @@ This variable will only be used if the value of
:group 'gnus-summary-format
:type 'string)
-(defcustom gnus-summary-goto-unread t
+(defcustom gnus-summary-goto-unread nil
"*If t, many commands will go to the next unread article.
This applies to marking commands as well as other commands that
\"naturally\" select the next article, like, for instance, `SPC' at
@@ -221,6 +231,7 @@ If nil, the marking commands do NOT go to the next unread article
\(they go to the next article instead). If `never', commands that
usually go to the next unread article, will go to the next article,
whether it is read or not."
+ :version "24.1"
:group 'gnus-summary-marks
:link '(custom-manual "(gnus)Setting Marks")
:type '(choice (const :tag "off" nil)
@@ -339,7 +350,7 @@ newsgroups, set the variable to nil in `gnus-select-group-hook'."
:type '(choice (const :tag "none" nil)
(sexp :menu-tag "first" t)))
-(defcustom gnus-auto-select-subject 'unread
+(defcustom gnus-auto-select-subject 'unseen-or-unread
"*Says what subject to place under point when entering a group.
This variable can either be the symbols `first' (place point on the
@@ -350,7 +361,7 @@ the first unseen article), `unseen-or-unread' (place point on the subject
line of the first unseen article or, if all article have been seen, on the
subject line of the first unread article), or a function to be called to
place point on some subject line."
- :version "22.1"
+ :version "24.1"
:group 'gnus-group-select
:type '(choice (const best)
(const unread)
@@ -440,8 +451,10 @@ and non-`vertical', do both horizontal and vertical recentering."
(integer :tag "height")
(sexp :menu-tag "both" t)))
-(defvar gnus-auto-center-group t
- "*If non-nil, always center the group buffer.")
+(defcustom gnus-auto-center-group t
+ "If non-nil, always center the group buffer."
+ :group 'gnus-summary-maneuvering
+ :type 'boolean)
(defcustom gnus-show-all-headers nil
"*If non-nil, don't hide any headers."
@@ -454,9 +467,16 @@ and non-`vertical', do both horizontal and vertical recentering."
:group 'gnus-summary
:type 'boolean)
-(defcustom gnus-single-article-buffer t
+(defcustom gnus-single-article-buffer nil
"*If non-nil, display all articles in the same buffer.
If nil, each group will get its own article buffer."
+ :version "24.1"
+ :group 'gnus-article-various
+ :type 'boolean)
+
+(defcustom gnus-widen-article-window nil
+ "If non-nil, selecting the article buffer will display only the article buffer."
+ :version "24.1"
:group 'gnus-article-various
:type 'boolean)
@@ -528,11 +548,6 @@ string with the suggested prefix."
:group 'gnus-summary-marks
:type 'character)
-(defcustom gnus-souped-mark ?F
- "*Mark used for souped articles."
- :group 'gnus-summary-marks
- :type 'character)
-
(defcustom gnus-kill-file-mark ?X
"*Mark used for articles killed by kill files."
:group 'gnus-summary-marks
@@ -656,9 +671,9 @@ string with the suggested prefix."
(defcustom gnus-auto-expirable-marks
(list gnus-killed-mark gnus-del-mark gnus-catchup-mark
gnus-low-score-mark gnus-ancient-mark gnus-read-mark
- gnus-souped-mark gnus-duplicate-mark)
+ gnus-duplicate-mark)
"*The list of marks converted into expiration if a group is auto-expirable."
- :version "21.1"
+ :version "24.1"
:group 'gnus-summary
:type '(repeat character))
@@ -978,8 +993,7 @@ This hook is not called from the non-updating exit commands like `Q'."
:group 'gnus-various
:type 'hook)
-(defcustom gnus-summary-update-hook
- (list 'gnus-summary-highlight-line)
+(defcustom gnus-summary-update-hook nil
"*A hook called when a summary line is changed.
The hook will not be called if `gnus-visual' is nil.
@@ -1248,7 +1262,7 @@ type of files to save."
"Whether Gnus should parse all headers made available to it.
This is mostly relevant for slow back ends where the user may
wish to widen the summary buffer to include all headers
-that were fetched. Say, for nnultimate groups."
+that were fetched."
:version "22.1"
:group 'gnus-summary
:type '(choice boolean regexp))
@@ -1296,6 +1310,7 @@ the normal Gnus MIME machinery."
(defvar gnus-article-decoded-p nil)
(defvar gnus-article-charset nil)
(defvar gnus-article-ignored-charsets nil)
+(defvar gnus-article-original-subject nil)
(defvar gnus-scores-exclude-files nil)
(defvar gnus-page-broken nil)
@@ -1321,6 +1336,7 @@ the normal Gnus MIME machinery."
(defvar gnus-current-copy-group nil)
(defvar gnus-current-crosspost-group nil)
(defvar gnus-newsgroup-display nil)
+(defvar gnus-newsgroup-original-name nil)
(defvar gnus-newsgroup-dependencies nil)
(defvar gnus-newsgroup-adaptive nil)
@@ -1423,6 +1439,7 @@ the type of the variable (string, integer, character, etc).")
(defvar gnus-newsgroup-last-directory nil)
(defvar gnus-newsgroup-auto-expire nil)
(defvar gnus-newsgroup-active nil)
+(defvar gnus-newsgroup-highest nil)
(defvar gnus-newsgroup-data nil)
(defvar gnus-newsgroup-data-reverse nil)
@@ -1533,22 +1550,34 @@ This list will always be a subset of gnus-newsgroup-undownloaded.")
(defvar gnus-summary-local-variables
'(gnus-newsgroup-name
+
+ ;; Marks lists
+ gnus-newsgroup-unreads
+ gnus-newsgroup-unselected
+ gnus-newsgroup-marked
+ gnus-newsgroup-spam-marked
+ gnus-newsgroup-reads
+ gnus-newsgroup-saved
+ gnus-newsgroup-replied
+ gnus-newsgroup-forwarded
+ gnus-newsgroup-recent
+ gnus-newsgroup-expirable
+ gnus-newsgroup-killed
+ gnus-newsgroup-unseen
+ gnus-newsgroup-seen
+ gnus-newsgroup-cached
+ gnus-newsgroup-downloadable
+ gnus-newsgroup-undownloaded
+ gnus-newsgroup-unsendable
+
gnus-newsgroup-begin gnus-newsgroup-end
gnus-newsgroup-last-rmail gnus-newsgroup-last-mail
gnus-newsgroup-last-folder gnus-newsgroup-last-file
gnus-newsgroup-last-directory
- gnus-newsgroup-auto-expire gnus-newsgroup-unreads
- gnus-newsgroup-unselected gnus-newsgroup-marked
- gnus-newsgroup-spam-marked
- gnus-newsgroup-reads gnus-newsgroup-saved
- gnus-newsgroup-replied gnus-newsgroup-forwarded
- gnus-newsgroup-recent
- gnus-newsgroup-expirable
- gnus-newsgroup-processable gnus-newsgroup-killed
- gnus-newsgroup-downloadable gnus-newsgroup-undownloaded
+ gnus-newsgroup-auto-expire
+ gnus-newsgroup-processable
gnus-newsgroup-unfetched
- gnus-newsgroup-unsendable gnus-newsgroup-unseen
- gnus-newsgroup-seen gnus-newsgroup-articles
+ gnus-newsgroup-articles
gnus-newsgroup-bookmarks gnus-newsgroup-dormant
gnus-newsgroup-headers gnus-newsgroup-threads
gnus-newsgroup-prepared gnus-summary-highlight-line-function
@@ -1562,12 +1591,13 @@ This list will always be a subset of gnus-newsgroup-undownloaded.")
(gnus-summary-mark-below . global)
(gnus-orphan-score . global)
gnus-newsgroup-active gnus-scores-exclude-files
+ gnus-newsgroup-highest
gnus-newsgroup-history gnus-newsgroup-ancient
gnus-newsgroup-sparse gnus-newsgroup-process-stack
(gnus-newsgroup-adaptive . gnus-use-adaptive-scoring)
gnus-newsgroup-adaptive-score-file (gnus-reffed-article-number . -1)
(gnus-newsgroup-expunged-tally . 0)
- gnus-cache-removable-articles gnus-newsgroup-cached
+ gnus-cache-removable-articles
gnus-newsgroup-data gnus-newsgroup-data-reverse
gnus-newsgroup-limit gnus-newsgroup-limits
gnus-newsgroup-charset gnus-newsgroup-display
@@ -1850,7 +1880,6 @@ increase the score of each group you read."
"=" gnus-summary-expand-window
"\C-x\C-s" gnus-summary-reselect-current-group
"\M-g" gnus-summary-rescan-group
- "w" gnus-summary-stop-page-breaking
"\C-c\C-r" gnus-summary-caesar-message
"f" gnus-summary-followup
"F" gnus-summary-followup-with-original
@@ -1872,9 +1901,9 @@ increase the score of each group you read."
[follow-link] mouse-face
"m" gnus-summary-mail-other-window
"a" gnus-summary-post-news
- "i" gnus-summary-news-other-window
"x" gnus-summary-limit-to-unread
"s" gnus-summary-isearch-article
+ [tab] gnus-summary-widget-forward
"t" gnus-summary-toggle-header
"g" gnus-summary-show-article
"l" gnus-summary-goto-last-article
@@ -2031,11 +2060,14 @@ increase the score of each group you read."
"e" gnus-summary-end-of-article
"^" gnus-summary-refer-parent-article
"r" gnus-summary-refer-parent-article
+ "C" gnus-summary-show-complete-article
"D" gnus-summary-enter-digest-group
"R" gnus-summary-refer-references
"T" gnus-summary-refer-thread
+ "W" gnus-warp-to-article
"g" gnus-summary-show-article
"s" gnus-summary-isearch-article
+ [tab] gnus-summary-widget-forward
"P" gnus-summary-print-article
"S" gnus-sticky-article
"M" gnus-mailing-list-insinuate
@@ -2068,6 +2100,7 @@ increase the score of each group you read."
"a" gnus-article-strip-headers-in-body ;; mnemonic: wash archive
"p" gnus-article-verify-x-pgp-sig
"d" gnus-article-treat-dumbquotes
+ "U" gnus-article-treat-non-ascii
"i" gnus-summary-idna-message)
(gnus-define-keys (gnus-summary-wash-deuglify-map "Y" gnus-summary-wash-map)
@@ -2105,9 +2138,12 @@ increase the score of each group you read."
"d" gnus-article-display-face
"s" gnus-treat-smiley
"D" gnus-article-remove-images
+ "W" gnus-article-show-images
"f" gnus-treat-from-picon
"m" gnus-treat-mail-picon
- "n" gnus-treat-newsgroups-picon)
+ "n" gnus-treat-newsgroups-picon
+ "g" gnus-treat-from-gravatar
+ "h" gnus-treat-mail-gravatar)
(gnus-define-keys (gnus-summary-wash-mime-map "M" gnus-summary-wash-map)
"w" gnus-article-decode-mime-words
@@ -2137,12 +2173,9 @@ increase the score of each group you read."
(gnus-define-keys (gnus-summary-help-map "H" gnus-summary-mode-map)
"v" gnus-version
- "f" gnus-summary-fetch-faq
"d" gnus-summary-describe-group
"h" gnus-summary-describe-briefly
- "i" gnus-info-find-node
- "c" gnus-group-fetch-charter
- "C" gnus-group-fetch-control)
+ "i" gnus-info-find-node)
(gnus-define-keys (gnus-summary-backend-map "B" gnus-summary-mode-map)
"e" gnus-summary-expire-articles
@@ -2172,8 +2205,7 @@ increase the score of each group you read."
"h" gnus-summary-save-article-folder
"v" gnus-summary-save-article-vm
"p" gnus-summary-pipe-output
- "P" gnus-summary-muttprint
- "s" gnus-soup-add-article)
+ "P" gnus-summary-muttprint)
(gnus-define-keys (gnus-summary-mime-map "K" gnus-summary-mode-map)
"b" gnus-summary-display-buttonized
@@ -2358,6 +2390,8 @@ increase the score of each group you read."
["Show picons in From" gnus-treat-from-picon t]
["Show picons in mail headers" gnus-treat-mail-picon t]
["Show picons in news headers" gnus-treat-newsgroups-picon t]
+ ["Show Gravatars in From" gnus-treat-from-gravatar t]
+ ["Show Gravatars in mail headers" gnus-treat-mail-gravatar t]
("View as different encoding"
,@(gnus-summary-menu-split
(mapcar
@@ -2391,6 +2425,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs))))
gnus-article-remove-leading-whitespace t])
["Overstrike" gnus-article-treat-overstrike t]
["Dumb quotes" gnus-article-treat-dumbquotes t]
+ ["Non-ASCII" gnus-article-treat-non-ascii t]
["Emphasis" gnus-article-emphasize t]
["Word wrap" gnus-article-fill-cited-article t]
["Fill long lines" gnus-article-fill-long-lines t]
@@ -2437,7 +2472,6 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs))))
["Save in RMAIL mbox..." gnus-summary-save-article-rmail t]
["Save body in file..." gnus-summary-save-article-body-file t]
["Pipe through a filter..." gnus-summary-pipe-output t]
- ["Add to SOUP packet" gnus-soup-add-article t]
["Print with Muttprint..." gnus-summary-muttprint t]
["Print" gnus-summary-print-article
,@(if (featurep 'xemacs) '(t)
@@ -2635,17 +2669,6 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs))))
["Set expirable mark" gnus-summary-mark-as-expirable t]
["Set bookmark" gnus-summary-set-bookmark t]
["Remove bookmark" gnus-summary-remove-bookmark t])
- ("Registry Mark"
- ["Important" gnus-registry-set-article-Important-mark t]
- ["Not Important" gnus-registry-remove-article-Important-mark t]
- ["Work" gnus-registry-set-article-Work-mark t]
- ["Not Work" gnus-registry-remove-article-Work-mark t]
- ["Later" gnus-registry-set-article-Later-mark t]
- ["Not Later" gnus-registry-remove-article-Later-mark t]
- ["Personal" gnus-registry-set-article-Personal-mark t]
- ["Not Personal" gnus-registry-remove-article-Personal-mark t]
- ["To Do" gnus-registry-set-article-To-Do-mark t]
- ["Not To Do" gnus-registry-remove-article-To-Do-mark t])
("Limit to"
["Marks..." gnus-summary-limit-to-marks t]
["Subject..." gnus-summary-limit-to-subject t]
@@ -2691,6 +2714,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs))))
gnus-newsgroup-process-stack]
["Save" gnus-summary-save-process-mark t]
["Run command on marked..." gnus-summary-universal-argument t]))
+ ("Registry Marks")
("Scroll article"
["Page forward" gnus-summary-next-page
,@(if (featurep 'xemacs) '(t)
@@ -2728,14 +2752,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs))))
["Randomize" gnus-summary-sort-by-random t]
["Original sort" gnus-summary-sort-by-original t])
("Help"
- ["Fetch group FAQ" gnus-summary-fetch-faq t]
["Describe group" gnus-summary-describe-group t]
- ["Fetch charter" gnus-group-fetch-charter
- ,@(if (featurep 'xemacs) nil
- '(:help "Display the charter of the current group"))]
- ["Fetch control message" gnus-group-fetch-control
- ,@(if (featurep 'xemacs) nil
- '(:help "Display the archived control message for the current group"))]
["Read manual" gnus-info-find-node t])
("Modes"
["Pick and read" gnus-pick-mode t]
@@ -3027,7 +3044,7 @@ When FORCE, rebuild the tool bar."
(declare-function turn-on-gnus-mailing-list-mode "gnus-ml" ())
-
+(defvar bookmark-make-record-function)
(defun gnus-summary-mode (&optional group)
@@ -3063,7 +3080,6 @@ The following commands are available:
(gnus-simplify-mode-line)
(setq major-mode 'gnus-summary-mode)
(setq mode-name "Summary")
- (make-local-variable 'minor-mode-alist)
(use-local-map gnus-summary-mode-map)
(buffer-disable-undo)
(setq buffer-read-only t ;Disable modification
@@ -3082,6 +3098,8 @@ The following commands are available:
(gnus-run-mode-hooks 'gnus-summary-mode-hook)
(turn-on-gnus-mailing-list-mode)
(mm-enable-multibyte)
+ (set (make-local-variable 'bookmark-make-record-function)
+ 'gnus-summary-bookmark-make-record)
(gnus-update-format-specifications nil 'summary 'summary-mode 'summary-dummy)
(gnus-update-summary-mark-positions))
@@ -3100,16 +3118,6 @@ The following commands are available:
;; Simple nil-valued local variable.
(set (make-local-variable local) nil)))))
-(defun gnus-summary-clear-local-variables ()
- (let ((locals gnus-summary-local-variables))
- (while locals
- (if (consp (car locals))
- (and (symbolp (caar locals))
- (set (caar locals) nil))
- (and (symbolp (car locals))
- (set (car locals) nil)))
- (setq locals (cdr locals)))))
-
;; Summary data functions.
(defmacro gnus-data-number (data)
@@ -3412,8 +3420,10 @@ marks of articles."
(save-excursion
(let (config)
(goto-char (point-min))
- (while (search-forward "\r" nil t)
- (push (1- (point)) config))
+ (while (not (eobp))
+ (when (eq (get-char-property (point-at-eol) 'invisible) 'gnus-sum)
+ (push (save-excursion (forward-line 0) (point)) config))
+ (forward-line 1))
config)))
(defun gnus-restore-hidden-threads-configuration (config)
@@ -3421,10 +3431,8 @@ marks of articles."
(save-excursion
(let (point (inhibit-read-only t))
(while (setq point (pop config))
- (when (and (< point (point-max))
- (goto-char point)
- (eq (char-after) ?\n))
- (subst-char-in-region point (1+ point) ?\n ?\r))))))
+ (goto-char point)
+ (gnus-summary-hide-thread)))))
;; Various summary mode internalish functions.
@@ -3494,8 +3502,6 @@ display only a single character."
;; Fix by Sudish Joseph <joseph@cis.ohio-state.edu>
(setq gnus-summary-buffer (set-buffer (gnus-get-buffer-create buffer)))
(gnus-summary-mode group)
- (when gnus-carpal
- (gnus-carpal-setup-buffer 'summary))
(when (gnus-group-quit-config group)
(set (make-local-variable 'gnus-single-article-buffer) nil))
(make-local-variable 'gnus-article-buffer)
@@ -3758,6 +3764,7 @@ buffer that was in action when the last article was fetched."
(error (gnus-message 5 "Error updating the summary line")))
(when (gnus-visual-p 'summary-highlight 'highlight)
(forward-line -1)
+ (gnus-summary-highlight-line)
(gnus-run-hooks 'gnus-summary-update-hook)
(forward-line 1))))
@@ -3790,6 +3797,7 @@ buffer that was in action when the last article was fetched."
'score))
;; Do visual highlighting.
(when (gnus-visual-p 'summary-highlight 'highlight)
+ (gnus-summary-highlight-line)
(gnus-run-hooks 'gnus-summary-update-hook)))))
(defvar gnus-tmp-new-adopts nil)
@@ -3836,7 +3844,8 @@ This function is intended to be used in
(defun gnus-summary-set-local-parameters (group)
"Go through the local params of GROUP and set all variable specs in that list."
- (let ((vars '(quit-config))) ; Ignore quit-config.
+ (let ((vars '(quit-config active))) ; Ignore things that aren't
+ ; really variables.
(dolist (elem (gnus-group-find-parameter group))
(and (consp elem) ; Has to be a cons.
(consp (cdr elem)) ; The cdr has to be a list.
@@ -3937,7 +3946,6 @@ If NO-DISPLAY, don't generate a summary buffer."
(progn
(set-buffer gnus-group-buffer)
(gnus-group-jump-to-group group)
- (gnus-group-next-unread-group 1)
(gnus-configure-windows 'group 'force))
(gnus-handle-ephemeral-exit quit-config))
;; Finally signal the quit.
@@ -3949,6 +3957,7 @@ If NO-DISPLAY, don't generate a summary buffer."
(setq gnus-newsgroup-active
(gnus-copy-sequence
(gnus-active gnus-newsgroup-name)))
+ (setq gnus-newsgroup-highest (cdr gnus-newsgroup-active))
;; You can change the summary buffer in some way with this hook.
(gnus-run-hooks 'gnus-select-group-hook)
(when (memq 'summary (gnus-update-format-specifications
@@ -4504,7 +4513,7 @@ the id of the parent article (if any)."
(while (not (eobp))
(ignore-errors
(setq article (read (current-buffer))
- header (gnus-nov-parse-line article dependencies)))
+ header (gnus-nov-parse-line article dependencies t)))
(when header
(with-current-buffer gnus-summary-buffer
(push header gnus-newsgroup-headers)
@@ -4826,7 +4835,8 @@ If LINE, insert the rebuilt thread starting on line LINE."
;; Even after binding max-lisp-eval-depth, the recursive
;; sorter might fail for very long threads. In that case,
;; try using a (less well-tested) non-recursive sorter.
- (error (gnus-sort-threads-loop
+ (error (gnus-message 9 "Sorting threads with loop...")
+ (gnus-sort-threads-loop
threads (gnus-make-sort-function
gnus-thread-sort-functions))))
(gnus-message 8 "Sorting threads...done"))))
@@ -4979,6 +4989,10 @@ Unscored articles will be counted as having a score of zero."
(t
(gnus-thread-total-score-1 (list thread)))))
+(defun gnus-article-sort-by-most-recent-number (h1 h2)
+ "Sort articles by number."
+ (gnus-article-sort-by-number h1 h2))
+
(defun gnus-thread-sort-by-most-recent-number (h1 h2)
"Sort threads such that the thread with the most recently arrived article comes first."
(> (gnus-thread-highest-number h1) (gnus-thread-highest-number h2)))
@@ -4989,26 +5003,25 @@ Unscored articles will be counted as having a score of zero."
(mail-header-number header))
(message-flatten-list thread))))
+(defun gnus-article-sort-by-most-recent-date (h1 h2)
+ "Sort articles by number."
+ (gnus-article-sort-by-date h1 h2))
+
(defun gnus-thread-sort-by-most-recent-date (h1 h2)
"Sort threads such that the thread with the most recently dated article comes first."
(> (gnus-thread-latest-date h1) (gnus-thread-latest-date h2)))
+; Since this is called not only to sort the top-level threads, but
+; also in recursive sorts to order the articles within a thread, each
+; article will be processed many times. Thus it speeds things up
+; quite a bit to use gnus-date-get-time, which caches the time value.
(defun gnus-thread-latest-date (thread)
"Return the highest article date in THREAD."
- (let ((previous-time 0))
- (apply 'max
- (mapcar
- (lambda (header)
- (setq previous-time
- (condition-case ()
- (gnus-float-time (mail-header-parse-date
- (mail-header-date header)))
- (error previous-time))))
- (sort
- (message-flatten-list thread)
- (lambda (h1 h2)
- (< (mail-header-number h1)
- (mail-header-number h2))))))))
+ (apply 'max
+ (mapcar (lambda (header) (gnus-float-time
+ (gnus-date-get-time
+ (mail-header-date header))))
+ (message-flatten-list thread))))
(defun gnus-thread-total-score-1 (root)
;; This function find the total score of the thread below ROOT.
@@ -5367,16 +5380,18 @@ or a straight list of headers."
(if (= gnus-tmp-lines -1)
(setq gnus-tmp-lines "?")
(setq gnus-tmp-lines (number-to-string gnus-tmp-lines)))
- (gnus-put-text-property
- (point)
- (progn (eval gnus-summary-line-format-spec) (point))
- 'gnus-number number)
- (when gnus-visual-p
- (forward-line -1)
- (gnus-run-hooks 'gnus-summary-update-hook)
- (forward-line 1))
-
- (setq gnus-tmp-prev-subject simp-subject)))
+ (gnus-put-text-property
+ (point)
+ (progn (eval gnus-summary-line-format-spec) (point))
+ 'gnus-number number)
+ (when gnus-visual-p
+ (forward-line -1)
+ (gnus-summary-highlight-line)
+ (when gnus-summary-update-hook
+ (gnus-run-hooks 'gnus-summary-update-hook))
+ (forward-line 1))
+
+ (setq gnus-tmp-prev-subject simp-subject)))
(when (nth 1 thread)
(push (list (max 0 gnus-tmp-level)
@@ -5460,7 +5475,7 @@ or a straight list of headers."
(substring subject (match-end 1)))))
(mail-header-set-subject header subject))))))
-(defun gnus-fetch-headers (articles)
+(defun gnus-fetch-headers (articles &optional limit force-new dependencies)
"Fetch headers of ARTICLES."
(let ((name (gnus-group-decoded-name gnus-newsgroup-name)))
(gnus-message 5 "Fetching headers for %s..." name)
@@ -5469,16 +5484,17 @@ or a straight list of headers."
(setq gnus-headers-retrieved-by
(gnus-retrieve-headers
articles gnus-newsgroup-name
- ;; We might want to fetch old headers, but
- ;; not if there is only 1 article.
- (and (or (and
- (not (eq gnus-fetch-old-headers 'some))
- (not (numberp gnus-fetch-old-headers)))
- (> (length articles) 1))
- gnus-fetch-old-headers))))
+ (or limit
+ ;; We might want to fetch old headers, but
+ ;; not if there is only 1 article.
+ (and (or (and
+ (not (eq gnus-fetch-old-headers 'some))
+ (not (numberp gnus-fetch-old-headers)))
+ (> (length articles) 1))
+ gnus-fetch-old-headers)))))
(gnus-get-newsgroup-headers-xover
- articles nil nil gnus-newsgroup-name t)
- (gnus-get-newsgroup-headers))
+ articles force-new dependencies gnus-newsgroup-name t)
+ (gnus-get-newsgroup-headers dependencies force-new))
(gnus-message 5 "Fetching headers for %s...done" name))))
(defun gnus-select-newsgroup (group &optional read-all select-articles)
@@ -5511,11 +5527,11 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(mm-decode-coding-string (gnus-status-message group) charset))))
(unless (gnus-request-group group t)
- (when (equal major-mode 'gnus-summary-mode)
- (gnus-kill-buffer (current-buffer)))
- (error "Couldn't request group %s: %s"
- (mm-decode-coding-string group charset)
- (mm-decode-coding-string (gnus-status-message group) charset)))
+ (when (equal major-mode 'gnus-summary-mode)
+ (gnus-kill-buffer (current-buffer)))
+ (error "Couldn't request group %s: %s"
+ (mm-decode-coding-string group charset)
+ (mm-decode-coding-string (gnus-status-message group) charset)))
(when gnus-agent
(gnus-agent-possibly-alter-active group (gnus-active group) info)
@@ -5671,17 +5687,17 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(unseen . unseen))
gnus-article-mark-lists))
(push (cons (cdr elem)
- (gnus-byte-compile
+ (gnus-byte-compile ;Why bother?
`(lambda () (gnus-article-marked-p ',(cdr elem)))))
gnus-summary-display-cache)))
(let ((gnus-category-predicate-alist gnus-summary-display-cache)
(gnus-category-predicate-cache gnus-summary-display-cache))
(gnus-get-predicate display)))
-;; Uses the dynamically bound `number' variable.
-(defvar number)
+;; Uses the dynamically bound `gnus-number' variable.
+(defvar gnus-number)
(defun gnus-article-marked-p (type &optional article)
- (let ((article (or article number)))
+ (let ((article (or article gnus-number)))
(cond
((eq type 'tick)
(memq article gnus-newsgroup-marked))
@@ -5857,6 +5873,10 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(types gnus-article-mark-lists)
marks var articles article mark mark-type
bgn end)
+ ;; Hack to avoid adjusting marks for imap.
+ (when (eq (car (gnus-find-method-for-group (gnus-info-group info)))
+ 'nnimap)
+ (setq min 1))
(dolist (marks marked-lists)
(setq mark (car marks)
@@ -5979,6 +5999,10 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(when add
(push (list add 'add (list (cdr type))) delta-marks))
(when del
+ ;; Don't delete marks from outside the active range. This
+ ;; shouldn't happen, but is a sanity check.
+ (setq del (gnus-sorted-range-intersection
+ (gnus-active gnus-newsgroup-name) del))
(push (list del 'del (list (cdr type))) delta-marks))))
(when list
@@ -6061,9 +6085,7 @@ If WHERE is `summary', the summary mode line format will be used."
(when (> (length mode-string) max-len)
(setq mode-string
(concat (truncate-string-to-width mode-string (- max-len 3))
- "...")))
- ;; Pad the mode string a bit.
- (setq mode-string (format (format "%%-%ds" max-len) mode-string))))
+ "...")))))
;; Update the mode line.
(setq mode-line-buffer-identification
(gnus-mode-line-buffer-identification (list mode-string)))
@@ -6100,8 +6122,7 @@ The resulting hash table is returned, or nil if no Xrefs were found."
"Look through all the headers and mark the Xrefs as read."
(let ((virtual (gnus-virtual-group-p from-newsgroup))
name info xref-hashtb idlist method nth4)
- (save-excursion
- (set-buffer gnus-group-buffer)
+ (with-current-buffer gnus-group-buffer
(when (setq xref-hashtb
(gnus-create-xref-hashtb from-newsgroup headers unreads))
(mapatoms
@@ -6173,7 +6194,13 @@ The resulting hash table is returned, or nil if no Xrefs were found."
(info (nth 2 entry))
(active (gnus-active group))
range)
- (when entry
+ (if (not entry)
+ ;; Group that Gnus doesn't know exists, but still allow the
+ ;; backend to set marks.
+ (gnus-request-set-mark
+ group (list (list (gnus-compress-sequence (sort articles #'<))
+ 'add '(read))))
+ ;; Normal, subscribed groups.
(setq range (gnus-compute-read-articles group articles))
(with-current-buffer gnus-group-buffer
(gnus-undo-register
@@ -6208,8 +6235,6 @@ The resulting hash table is returned, or nil if no Xrefs were found."
(unless (gnus-ephemeral-group-p group)
(gnus-group-update-group group t))))))
-(defvar gnus-newsgroup-none-id 0)
-
(defun gnus-get-newsgroup-headers (&optional dependencies force-new)
(let ((cur nntp-server-buffer)
(dependencies
@@ -6927,11 +6952,19 @@ displayed, no centering will be performed."
;; Various summary commands
(defun gnus-summary-select-article-buffer ()
- "Reconfigure windows to show article buffer."
+ "Reconfigure windows to show the article buffer.
+If `gnus-widen-article-buffer' is set, show only the article
+buffer."
(interactive)
(if (not (gnus-buffer-live-p gnus-article-buffer))
(error "There is no article buffer for this summary buffer")
- (gnus-configure-windows 'article)
+ (unless (get-buffer-window gnus-article-buffer)
+ (gnus-summary-show-article))
+ (gnus-configure-windows
+ (if gnus-widen-article-window
+ 'only-article
+ 'article)
+ t)
(select-window (get-buffer-window gnus-article-buffer))))
(defun gnus-summary-universal-argument (arg)
@@ -7004,7 +7037,11 @@ The prefix argument ALL means to select all articles."
(defun gnus-summary-rescan-group (&optional all)
"Exit the newsgroup, ask for new articles, and select the newsgroup."
(interactive "P")
- (gnus-summary-reselect-current-group all t))
+ (let ((config gnus-current-window-configuration))
+ (gnus-summary-reselect-current-group all t)
+ (gnus-configure-windows config)
+ (when (eq config 'article)
+ (gnus-summary-select-article))))
(defun gnus-summary-update-info (&optional non-destructive)
(save-excursion
@@ -7081,15 +7118,6 @@ If FORCE (the prefix), also save the .newsrc file(s)."
(when gnus-use-scoring
(gnus-score-save)))
(gnus-run-hooks 'gnus-summary-prepare-exit-hook)
- ;; If we have several article buffers, we kill them at exit.
- (unless gnus-single-article-buffer
- (when (gnus-buffer-live-p gnus-article-buffer)
- (with-current-buffer gnus-article-buffer
- ;; Don't kill sticky article buffers
- (unless (eq major-mode 'gnus-sticky-article-mode)
- (gnus-kill-buffer gnus-article-buffer)
- (setq gnus-article-current nil))))
- (gnus-kill-buffer gnus-original-article-buffer))
(when gnus-use-cache
(gnus-cache-possibly-remove-articles)
(gnus-cache-save-buffers))
@@ -7126,18 +7154,22 @@ If FORCE (the prefix), also save the .newsrc file(s)."
(progn
(gnus-deaden-summary)
(setq mode nil))
- ;; We set all buffer-local variables to nil. It is unclear why
- ;; this is needed, but if we don't, buffer-local variables are
- ;; not garbage-collected, it seems. This would the lead to en
- ;; ever-growing Emacs.
- (gnus-summary-clear-local-variables)
- (let ((gnus-summary-local-variables gnus-newsgroup-variables))
- (gnus-summary-clear-local-variables))
(when (get-buffer gnus-article-buffer)
(bury-buffer gnus-article-buffer))
;; Return to group mode buffer.
(when (eq mode 'gnus-summary-mode)
(gnus-kill-buffer buf)))
+
+ ;; If we have several article buffers, we kill them at exit.
+ (unless gnus-single-article-buffer
+ (when (gnus-buffer-live-p gnus-article-buffer)
+ (with-current-buffer gnus-article-buffer
+ ;; Don't kill sticky article buffers
+ (unless (eq major-mode 'gnus-sticky-article-mode)
+ (gnus-kill-buffer gnus-article-buffer)
+ (setq gnus-article-current nil))))
+ (gnus-kill-buffer gnus-original-article-buffer))
+
(setq gnus-current-select-method gnus-select-method)
(set-buffer gnus-group-buffer)
(if quit-config
@@ -7180,9 +7212,6 @@ If FORCE (the prefix), also save the .newsrc file(s)."
(if (not gnus-kill-summary-on-exit)
(gnus-deaden-summary)
(gnus-close-group group)
- (gnus-summary-clear-local-variables)
- (let ((gnus-summary-local-variables gnus-newsgroup-variables))
- (gnus-summary-clear-local-variables))
(gnus-kill-buffer gnus-summary-buffer))
(unless gnus-single-article-buffer
(setq gnus-article-current nil))
@@ -7246,33 +7275,21 @@ The state which existed when entering the ephemeral is reset."
;;; Dead summaries.
-(defvar gnus-dead-summary-mode-map nil)
-
-(unless gnus-dead-summary-mode-map
- (setq gnus-dead-summary-mode-map (make-keymap))
- (suppress-keymap gnus-dead-summary-mode-map)
- (substitute-key-definition
- 'undefined 'gnus-summary-wake-up-the-dead gnus-dead-summary-mode-map)
- (dolist (key '("\C-d" "\r" "\177" [delete]))
- (define-key gnus-dead-summary-mode-map
- key 'gnus-summary-wake-up-the-dead))
- (dolist (key '("q" "Q"))
- (define-key gnus-dead-summary-mode-map key 'bury-buffer)))
-
-(defvar gnus-dead-summary-mode nil
- "Minor mode for Gnus summary buffers.")
-
-(defun gnus-dead-summary-mode (&optional arg)
+(defvar gnus-dead-summary-mode-map
+ (let ((map (make-keymap)))
+ (suppress-keymap map)
+ (substitute-key-definition 'undefined 'gnus-summary-wake-up-the-dead map)
+ (dolist (key '("\C-d" "\r" "\177" [delete]))
+ (define-key map key 'gnus-summary-wake-up-the-dead))
+ (dolist (key '("q" "Q"))
+ (define-key map key 'bury-buffer))
+ map))
+
+(define-minor-mode gnus-dead-summary-mode
"Minor mode for Gnus summary buffers."
- (interactive "P")
- (when (eq major-mode 'gnus-summary-mode)
- (make-local-variable 'gnus-dead-summary-mode)
- (setq gnus-dead-summary-mode
- (if (null arg) (not gnus-dead-summary-mode)
- (> (prefix-numeric-value arg) 0)))
- (when gnus-dead-summary-mode
- (add-minor-mode
- 'gnus-dead-summary-mode " Dead" gnus-dead-summary-mode-map))))
+ :lighter " Dead" :keymap gnus-dead-summary-mode-map
+ (unless (derived-mode-p 'gnus-summary-mode)
+ (setq gnus-dead-summary-mode nil)))
(defun gnus-deaden-summary ()
"Make the current summary buffer into a dead summary buffer."
@@ -7326,23 +7343,6 @@ The state which existed when entering the ephemeral is reset."
t)))
(gnus-message 3 "This dead summary is now alive again"))
-;; Suggested by Andrew Eskilsson <pi92ae@pt.hk-r.se>.
-(defun gnus-summary-fetch-faq (&optional faq-dir)
- "Fetch the FAQ for the current group.
-If FAQ-DIR (the prefix), prompt for a directory to search for the faq
-in."
- (interactive
- (list
- (when current-prefix-arg
- (completing-read
- "FAQ dir: " (and (listp gnus-group-faq-directory)
- (mapcar 'list
- gnus-group-faq-directory))))))
- (let (gnus-faq-buffer)
- (when (setq gnus-faq-buffer
- (gnus-group-fetch-faq gnus-newsgroup-name faq-dir))
- (gnus-configure-windows 'summary-faq))))
-
;; Suggested by Per Abrahamsen <amanda@iesd.auc.dk>.
(defun gnus-summary-describe-group (&optional force)
"Describe the current newsgroup."
@@ -7352,7 +7352,7 @@ in."
(defun gnus-summary-describe-briefly ()
"Describe summary mode commands briefly."
(interactive)
- (gnus-message 6 (substitute-command-keys "\\<gnus-summary-mode-map>\\[gnus-summary-next-page]:Select \\[gnus-summary-next-unread-article]:Forward \\[gnus-summary-prev-unread-article]:Backward \\[gnus-summary-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-summary-describe-briefly]:This help")))
+ (gnus-message 6 "%s" (substitute-command-keys "\\<gnus-summary-mode-map>\\[gnus-summary-next-page]:Select \\[gnus-summary-next-unread-article]:Forward \\[gnus-summary-prev-unread-article]:Backward \\[gnus-summary-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-summary-describe-briefly]:This help")))
;; Walking around group mode buffer from summary mode.
@@ -7416,7 +7416,7 @@ If prefix argument NO-ARTICLE is non-nil, no article is selected initially."
"Go to the first subject satisfying any non-nil constraint.
If UNREAD is non-nil, the article should be unread.
If UNDOWNLOADED is non-nil, the article should be undownloaded.
-If UNSEEN is non-nil, the article should be unseen.
+If UNSEEN is non-nil, the article should be unseen as well as unread.
Returns the article selected or nil if there are no matching articles."
(interactive "P")
(cond
@@ -7439,7 +7439,8 @@ Returns the article selected or nil if there are no matching articles."
(and undownloaded
(memq num gnus-newsgroup-undownloaded))
(and unseen
- (memq num gnus-newsgroup-unseen)))))))
+ (memq num gnus-newsgroup-unseen)
+ (memq num gnus-newsgroup-unreads)))))))
(setq data (cdr data)))
(prog1
(if data
@@ -7599,9 +7600,11 @@ be displayed."
(null (get-buffer gnus-article-buffer))
(not (eq article (cdr gnus-article-current)))
(not (equal (car gnus-article-current)
- gnus-newsgroup-name))))
+ gnus-newsgroup-name))
+ (not (get-buffer gnus-original-article-buffer))))
(and (not gnus-single-article-buffer)
(or (null gnus-current-article)
+ (not (get-buffer gnus-original-article-buffer))
(not (eq gnus-current-article article))))
force)
;; The requested article is different from the current article.
@@ -7805,7 +7808,7 @@ Also see the variable `gnus-article-skip-boring'."
(setq endp (or (gnus-article-next-page lines)
(gnus-article-only-boring-p))))
(when endp
- (cond (stop
+ (cond ((or stop gnus-summary-stop-at-end-of-message)
(gnus-message 3 "End of message"))
(circular
(gnus-summary-beginning-of-article))
@@ -7858,7 +7861,8 @@ If at the beginning of the article, go to the next article."
(defun gnus-summary-scroll-up (lines)
"Scroll up (or down) one line current article.
-Argument LINES specifies lines to be scrolled up (or down if negative)."
+Argument LINES specifies lines to be scrolled up (or down if negative).
+If no article is selected, then the current article will be selected first."
(interactive "p")
(gnus-configure-windows 'article)
(gnus-summary-show-thread)
@@ -7874,7 +7878,8 @@ Argument LINES specifies lines to be scrolled up (or down if negative)."
(defun gnus-summary-scroll-down (lines)
"Scroll down (or up) one line current article.
-Argument LINES specifies lines to be scrolled down (or up if negative)."
+Argument LINES specifies lines to be scrolled down (or up if negative).
+If no article is selected, then the current article will be selected first."
(interactive "p")
(gnus-summary-scroll-up (- lines)))
@@ -7930,8 +7935,8 @@ Return nil if there are no unseen articles."
(gnus-summary-position-point)))
(defun gnus-summary-first-unseen-or-unread-subject ()
- "Place the point on the subject line of the first unseen article or,
-if all article have been seen, on the subject line of the first unread
+ "Place the point on the subject line of the first unseen and unread article.
+If all article have been seen, on the subject line of the first unread
article."
(interactive)
(prog1
@@ -8013,10 +8018,9 @@ If FORCE, go to the article even if it isn't displayed. If FORCE
is a number, it is the line the article is to be displayed on."
(interactive
(list
- (completing-read
- "Article number or Message-ID: "
- (mapcar (lambda (number) (list (int-to-string number)))
- gnus-newsgroup-limit))
+ (gnus-completing-read
+ "Article number or Message-ID"
+ (mapcar 'int-to-string gnus-newsgroup-limit))
current-prefix-arg
t))
(prog1
@@ -8203,14 +8207,15 @@ in `nnmail-extra-headers'."
(gnus-summary-position-point))))
(defun gnus-summary-limit-strange-charsets-predicate (header)
- (let ((string (concat (mail-header-subject header)
- (mail-header-from header)))
- charset found)
- (dotimes (i (1- (length string)))
- (setq charset (format "%s" (char-charset (aref string (1+ i)))))
- (when (string-match "unicode\\|big\\|japanese" charset)
- (setq found t)))
- found))
+ (when (fboundp 'char-charset)
+ (let ((string (concat (mail-header-subject header)
+ (mail-header-from header)))
+ charset found)
+ (dotimes (i (1- (length string)))
+ (setq charset (format "%s" (char-charset (aref string (1+ i)))))
+ (when (string-match "unicode\\|big\\|japanese" charset)
+ (setq found t)))
+ found)))
(defun gnus-summary-limit-to-predicate (predicate)
"Limit to articles where PREDICATE returns non-nil.
@@ -8255,9 +8260,7 @@ articles that are younger than AGE days."
(when (and (vectorp (gnus-data-header d))
(setq date (mail-header-date (gnus-data-header d))))
(setq is-younger (time-less-p
- (time-since (condition-case ()
- (date-to-time date)
- (error '(0 0))))
+ (time-since (gnus-date-get-time date))
cutoff))
(when (if younger-p
is-younger
@@ -8271,16 +8274,13 @@ articles that are younger than AGE days."
(interactive
(let ((header
(intern
- (gnus-completing-read-with-default
- (symbol-name (car gnus-extra-headers))
+ (gnus-completing-read
(if current-prefix-arg
"Exclude extra header"
"Limit extra header")
- (mapcar (lambda (x)
- (cons (symbol-name x) x))
- gnus-extra-headers)
- nil
- t))))
+ (mapcar 'symbol-name gnus-extra-headers)
+ t nil nil
+ (symbol-name (car gnus-extra-headers))))))
(list header
(read-string (format "%s header %s (regexp): "
(if current-prefix-arg "Exclude" "Limit to")
@@ -8302,16 +8302,12 @@ articles that are younger than AGE days."
(unless gnus-newsgroup-display
(error "There is no `display' group parameter"))
(let (articles)
- (dolist (number gnus-newsgroup-articles)
+ (dolist (gnus-number gnus-newsgroup-articles)
(when (funcall gnus-newsgroup-display)
- (push number articles)))
+ (push gnus-number articles)))
(gnus-summary-limit articles))
(gnus-summary-position-point))
-(defalias 'gnus-summary-delete-marked-as-read 'gnus-summary-limit-to-unread)
-(make-obsolete
- 'gnus-summary-delete-marked-as-read 'gnus-summary-limit-to-unread "Emacs 20.4")
-
(defun gnus-summary-limit-to-unread (&optional all)
"Limit the summary buffer to articles that are not marked as read.
If ALL is non-nil, limit strictly to unread articles."
@@ -8325,7 +8321,7 @@ If ALL is non-nil, limit strictly to unread articles."
gnus-killed-mark gnus-spam-mark gnus-kill-file-mark
gnus-low-score-mark gnus-expirable-mark
gnus-canceled-mark gnus-catchup-mark gnus-sparse-mark
- gnus-duplicate-mark gnus-souped-mark)
+ gnus-duplicate-mark)
'reverse)))
(defun gnus-summary-limit-to-headers (match &optional reverse)
@@ -8351,8 +8347,7 @@ If REVERSE (the prefix), limit to articles that don't match."
(dolist (data gnus-newsgroup-data)
(let (gnus-mark-article-hook)
(gnus-summary-select-article t t nil (gnus-data-number data)))
- (save-excursion
- (set-buffer gnus-article-buffer)
+ (with-current-buffer gnus-article-buffer
(article-goto-body)
(let* ((case-fold-search t)
(found (if headersp
@@ -8403,10 +8398,6 @@ If UNREPLIED (the prefix), limit to unreplied articles."
(gnus-summary-limit gnus-newsgroup-replied))
(gnus-summary-position-point))
-(defalias 'gnus-summary-delete-marked-with 'gnus-summary-limit-exclude-marks)
-(make-obsolete 'gnus-summary-delete-marked-with
- 'gnus-summary-limit-exclude-marks "Emacs 20.4")
-
(defun gnus-summary-limit-exclude-marks (marks &optional reverse)
"Exclude articles that are marked with MARKS (e.g. \"DK\").
If REVERSE, limit the summary buffer to articles that are marked
@@ -8462,7 +8453,11 @@ When called interactively, ID is the Message-ID of the current
article."
(interactive (list (mail-header-id (gnus-summary-article-header))))
(let ((articles (gnus-articles-in-thread
- (gnus-id-to-thread (gnus-root-id id)))))
+ (gnus-id-to-thread (gnus-root-id id))))
+ ;;we REALLY want the whole thread---this prevents cut-threads
+ ;;from removing the thread we want to include.
+ (gnus-fetch-old-headers nil)
+ (gnus-build-sparse-threads nil))
(prog1
(gnus-summary-limit (nconc articles gnus-newsgroup-limit))
(gnus-summary-limit-include-matching-articles
@@ -8507,6 +8502,18 @@ fetched for this group."
(gnus-summary-limit (append gnus-newsgroup-dormant gnus-newsgroup-limit))
(gnus-summary-position-point)))
+(defun gnus-summary-include-articles (articles)
+ "Fetch the headers for ARTICLES and then display the summary lines."
+ (let ((gnus-inhibit-demon t)
+ (gnus-agent nil)
+ (gnus-read-all-available-headers t))
+ (setq gnus-newsgroup-headers
+ (gnus-merge
+ 'list gnus-newsgroup-headers
+ (gnus-fetch-headers articles nil t)
+ 'gnus-article-sort-by-number))
+ (gnus-summary-limit (append articles gnus-newsgroup-limit))))
+
(defun gnus-summary-limit-exclude-dormant ()
"Hide all dormant articles."
(interactive)
@@ -8669,8 +8676,7 @@ fetch-old-headers verbiage, and so on."
(null gnus-summary-expunge-below)
(not (eq gnus-build-sparse-threads 'some))
(not (eq gnus-build-sparse-threads 'more))
- (null gnus-thread-expunge-below)
- (not gnus-use-nocem)))
+ (null gnus-thread-expunge-below)))
(push gnus-newsgroup-limit gnus-newsgroup-limits)
(setq gnus-newsgroup-limit nil)
(mapatoms
@@ -8707,8 +8713,8 @@ fetch-old-headers verbiage, and so on."
(apply '+ (mapcar 'gnus-summary-limit-children
(cdr thread)))
0))
- (number (mail-header-number (car thread)))
- score)
+ (number (mail-header-number (car thread)))
+ score)
(if (and
(not (memq number gnus-newsgroup-marked))
(or
@@ -8753,14 +8759,8 @@ fetch-old-headers verbiage, and so on."
t)
;; Do the `display' group parameter.
(and gnus-newsgroup-display
- (not (funcall gnus-newsgroup-display)))
- ;; Check NoCeM things.
- (when (and gnus-use-nocem
- (gnus-nocem-unwanted-article-p
- (mail-header-id (car thread))))
- (setq gnus-newsgroup-unreads
- (delq number gnus-newsgroup-unreads))
- t)))
+ (let ((gnus-number number))
+ (not (funcall gnus-newsgroup-display))))))
;; Nope, invisible article.
0
;; Ok, this article is to be visible, so we add it to the limit
@@ -8850,31 +8850,44 @@ Return the number of articles fetched."
(defun gnus-summary-refer-thread (&optional limit)
"Fetch all articles in the current thread.
-If LIMIT (the numerical prefix), fetch that many old headers instead
-of what's specified by the `gnus-refer-thread-limit' variable."
+If no backend-specific 'request-thread function is available
+fetch LIMIT (the numerical prefix) old headers. If LIMIT is nil
+fetch what's specified by the `gnus-refer-thread-limit'
+variable."
(interactive "P")
+ (gnus-warp-to-article)
(let ((id (mail-header-id (gnus-summary-article-header)))
+ (gnus-inhibit-demon t)
+ (gnus-agent nil)
+ (gnus-summary-ignore-duplicates t)
+ (gnus-read-all-available-headers t)
(limit (if limit (prefix-numeric-value limit)
gnus-refer-thread-limit)))
- (unless (eq gnus-fetch-old-headers 'invisible)
- (gnus-message 5 "Fetching headers for %s..." gnus-newsgroup-name)
- ;; Retrieve the headers and read them in.
- (if (eq (if (numberp limit)
- (gnus-retrieve-headers
- (list (min
- (+ (mail-header-number
- (gnus-summary-article-header))
- limit)
- gnus-newsgroup-end))
- gnus-newsgroup-name (* limit 2))
- ;; gnus-refer-thread-limit is t, i.e. fetch _all_
- ;; headers.
- (gnus-retrieve-headers (list gnus-newsgroup-end)
- gnus-newsgroup-name limit))
- 'nov)
- (gnus-build-all-threads)
- (error "Can't fetch thread from back ends that don't support NOV"))
- (gnus-message 5 "Fetching headers for %s...done" gnus-newsgroup-name))
+ (setq gnus-newsgroup-headers
+ (gnus-merge
+ 'list gnus-newsgroup-headers
+ (if (gnus-check-backend-function
+ 'request-thread gnus-newsgroup-name)
+ (gnus-request-thread id)
+ (let* ((last (if (numberp limit)
+ (min (+ (mail-header-number
+ (gnus-summary-article-header))
+ limit)
+ gnus-newsgroup-highest)
+ gnus-newsgroup-highest))
+ (subject (gnus-simplify-subject
+ (mail-header-subject
+ (gnus-summary-article-header))))
+ (refs (split-string (or (mail-header-references
+ (gnus-summary-article-header))
+ "")))
+ (gnus-parse-headers-hook
+ (lambda () (goto-char (point-min))
+ (keep-lines
+ (regexp-opt (append refs (list id subject)))))))
+ (gnus-fetch-headers (list last) (if (numberp limit)
+ (* 2 limit) limit) t)))
+ 'gnus-article-sort-by-number))
(gnus-summary-limit-include-thread id)))
(defun gnus-summary-refer-article (message-id)
@@ -9036,7 +9049,7 @@ Obeys the standard process/prefix convention."
(setq group (format "%s-%d" gnus-newsgroup-name article))
(gnus-summary-remove-process-mark article)
(when (gnus-summary-display-article article)
- (save-excursion
+ (save-excursion ;;What for?
(with-temp-buffer
(insert-buffer-substring gnus-original-article-buffer)
;; Remove some headers that may lead nndoc to make
@@ -9071,6 +9084,15 @@ Obeys the standard process/prefix convention."
(t
(error "Couldn't select virtual nndoc group")))))
+(defun gnus-summary-widget-forward (arg)
+ "Move point to the next field or button in the article.
+With optional ARG, move across that many fields."
+ (interactive "p")
+ (gnus-summary-select-article)
+ (gnus-configure-windows 'article)
+ (select-window (gnus-get-buffer-window gnus-article-buffer))
+ (widget-forward arg))
+
(defun gnus-summary-isearch-article (&optional regexp-p)
"Do incremental search forward on the current article.
If REGEXP-P (the prefix) is non-nil, do regexp isearch."
@@ -9258,14 +9280,14 @@ If HEADER is an empty string (or nil), the match is done on the entire
article. If BACKWARD (the prefix) is non-nil, search backward instead."
(interactive
(list (let ((completion-ignore-case t))
- (completing-read
- "Header name: "
- (mapcar (lambda (header) (list (format "%s" header)))
+ (gnus-completing-read
+ "Header name"
+ (mapcar 'symbol-name
(append
- '("Number" "Subject" "From" "Lines" "Date"
- "Message-ID" "Xref" "References" "Body")
+ '(Number Subject From Lines Date
+ Message-ID Xref References Body)
gnus-extra-headers))
- nil 'require-match))
+ 'require-match))
(read-string "Regexp: ")
(read-key-sequence "Command: ")
current-prefix-arg))
@@ -9345,50 +9367,58 @@ to save in."
(ps-despool filename))
(defun gnus-print-buffer ()
- (let ((buffer (generate-new-buffer " *print*")))
+ (let ((ps-left-header
+ (list
+ (concat "("
+ (gnus-summary-print-truncate-and-quote
+ (mail-header-subject gnus-current-headers)
+ 66) ")")
+ (concat "("
+ (gnus-summary-print-truncate-and-quote
+ (mail-header-from gnus-current-headers)
+ 45) ")")))
+ (ps-right-header
+ (list
+ "/pagenumberstring load"
+ (concat "("
+ (mail-header-date gnus-current-headers) ")"))))
+ (gnus-run-hooks 'gnus-ps-print-hook)
+ (save-excursion
+ (if ps-print-color-p
+ (ps-spool-buffer-with-faces)
+ (ps-spool-buffer)))))
+
+(defun gnus-summary-show-complete-article ()
+ "Show a complete version of the current article.
+This is only useful if you're looking at a partial version of the
+article currently."
+ (interactive)
+ (let ((gnus-keep-backlog nil)
+ (gnus-use-cache nil)
+ (gnus-agent nil)
+ (variable (intern
+ (format "%s-fetch-partial-articles"
+ (car (gnus-find-method-for-group
+ gnus-newsgroup-name)))
+ obarray))
+ old-val)
(unwind-protect
(progn
- (copy-to-buffer buffer (point-min) (point-max))
- (set-buffer buffer)
- (gnus-remove-text-with-property 'gnus-decoration)
- (when (gnus-visual-p 'article-highlight 'highlight)
- ;; Copy-to-buffer doesn't copy overlay. So redo
- ;; highlight.
- (let ((gnus-article-buffer buffer))
- (gnus-article-highlight-citation t)
- (gnus-article-highlight-signature)
- (gnus-article-emphasize)
- (gnus-article-delete-invisible-text)))
- (let ((ps-left-header
- (list
- (concat "("
- (gnus-summary-print-truncate-and-quote
- (mail-header-subject gnus-current-headers)
- 66) ")")
- (concat "("
- (gnus-summary-print-truncate-and-quote
- (mail-header-from gnus-current-headers)
- 45) ")")))
- (ps-right-header
- (list
- "/pagenumberstring load"
- (concat "("
- (mail-header-date gnus-current-headers) ")"))))
- (gnus-run-hooks 'gnus-ps-print-hook)
- (save-excursion
- (if ps-print-color-p
- (ps-spool-buffer-with-faces)
- (ps-spool-buffer)))))
- (kill-buffer buffer))))
+ (setq old-val (symbol-value variable))
+ (set variable nil)
+ (gnus-flush-original-article-buffer)
+ (gnus-summary-show-article))
+ (set variable old-val))))
(defun gnus-summary-show-article (&optional arg)
"Force redisplaying of the current article.
If ARG (the prefix) is a number, show the article with the charset
defined in `gnus-summary-show-article-charset-alist', or the charset
input.
-If ARG (the prefix) is non-nil and not a number, show the raw article
-without any article massaging functions being run. Normally, the key
-strokes are `C-u g'."
+If ARG (the prefix) is non-nil and not a number, show the article,
+but without running any of the article treatment functions
+article. Normally, the keystroke is `C-u g'. When using `C-u
+C-u g', show the raw article."
(interactive "P")
(cond
((numberp arg)
@@ -9430,7 +9460,9 @@ strokes are `C-u g'."
((not arg)
;; Select the article the normal way.
(gnus-summary-select-article nil 'force))
- (t
+ ((or (equal arg '(16))
+ (eq arg t))
+ ;; C-u C-u g
;; We have to require this here to make sure that the following
;; dynamic binding isn't shadowed by autoloading.
(require 'gnus-async)
@@ -9448,6 +9480,9 @@ strokes are `C-u g'."
;; Set it to nil for safety reason.
(setq gnus-article-mime-handle-alist nil)
(setq gnus-article-mime-handles nil)))
+ (gnus-summary-select-article nil 'force)))
+ (t
+ (let ((gnus-inhibit-article-treatments t))
(gnus-summary-select-article nil 'force))))
(gnus-summary-goto-subject gnus-current-article)
(gnus-summary-position-point))
@@ -9544,7 +9579,7 @@ IDNA encoded domain names looks like `xn--bar'. If a string
remain unencoded after running this function, it is likely an
invalid IDNA string (`xn--bar' is invalid).
-You must have GNU Libidn (`http://www.gnu.org/software/libidn/')
+You must have GNU Libidn (URL `http://www.gnu.org/software/libidn/')
installed for this command to work."
(interactive "P")
(if (not (and (condition-case nil (require 'idna)
@@ -9693,193 +9728,216 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
articles)
(while articles
(setq article (pop articles))
- (setq
- art-group
- (cond
- ;; Move the article.
- ((eq action 'move)
- ;; Remove this article from future suppression.
- (gnus-dup-unsuppress-article article)
- (let* ((from-method (gnus-find-method-for-group
- gnus-newsgroup-name))
- (to-method (or select-method
- (gnus-find-method-for-group to-newsgroup)))
- (move-is-internal (gnus-method-equal from-method to-method)))
- (gnus-request-move-article
- article ; Article to move
- gnus-newsgroup-name ; From newsgroup
- (nth 1 (gnus-find-method-for-group
- gnus-newsgroup-name)) ; Server
- (list 'gnus-request-accept-article
- to-newsgroup (list 'quote select-method)
- (not articles) t) ; Accept form
- (not articles) ; Only save nov last time
- move-is-internal))) ; is this move internal?
- ;; Copy the article.
- ((eq action 'copy)
- (with-current-buffer copy-buf
- (when (gnus-request-article-this-buffer article gnus-newsgroup-name)
- (save-restriction
- (nnheader-narrow-to-headers)
- (dolist (hdr gnus-copy-article-ignored-headers)
- (message-remove-header hdr t)))
- (gnus-request-accept-article
- to-newsgroup select-method (not articles) t))))
- ;; Crosspost the article.
- ((eq action 'crosspost)
- (let ((xref (message-tokenize-header
- (mail-header-xref (gnus-summary-article-header article))
- " ")))
- (setq new-xref (concat (gnus-group-real-name gnus-newsgroup-name)
- ":" (number-to-string article)))
- (unless xref
- (setq xref (list (system-name))))
- (setq new-xref
- (concat
- (mapconcat 'identity
- (delete "Xref:" (delete new-xref xref))
- " ")
- " " new-xref))
+ ;; Set any marks that may have changed in the summary buffer.
+ (when gnus-preserve-marks
+ (gnus-summary-push-marks-to-backend article))
+ (let ((gnus-newsgroup-original-name gnus-newsgroup-name)
+ (gnus-article-original-subject
+ (mail-header-subject
+ (gnus-data-header (assoc article (gnus-data-list nil))))))
+ (setq
+ art-group
+ (cond
+ ;; Move the article.
+ ((eq action 'move)
+ ;; Remove this article from future suppression.
+ (gnus-dup-unsuppress-article article)
+ (let* ((from-method (gnus-find-method-for-group
+ gnus-newsgroup-name))
+ (to-method (or select-method
+ (gnus-find-method-for-group to-newsgroup)))
+ (move-is-internal (gnus-server-equal from-method to-method)))
+ (gnus-request-move-article
+ article ; Article to move
+ gnus-newsgroup-name ; From newsgroup
+ (nth 1 (gnus-find-method-for-group
+ gnus-newsgroup-name)) ; Server
+ (list 'gnus-request-accept-article
+ to-newsgroup (list 'quote select-method)
+ (not articles) t) ; Accept form
+ (not articles) ; Only save nov last time
+ (and move-is-internal
+ to-newsgroup ; Not respooling
+ ; Is this move internal?
+ (gnus-group-real-name to-newsgroup)))))
+ ;; Copy the article.
+ ((eq action 'copy)
(with-current-buffer copy-buf
- ;; First put the article in the destination group.
- (gnus-request-article-this-buffer article gnus-newsgroup-name)
- (when (consp (setq art-group
- (gnus-request-accept-article
- to-newsgroup select-method (not articles) t)))
- (setq new-xref (concat new-xref " " (car art-group)
- ":"
- (number-to-string (cdr art-group))))
- ;; Now we have the new Xrefs header, so we insert
- ;; it and replace the new article.
- (nnheader-replace-header "Xref" new-xref)
- (gnus-request-replace-article
- (cdr art-group) to-newsgroup (current-buffer) t)
- art-group))))))
- (cond
- ((not art-group)
- (gnus-message 1 "Couldn't %s article %s: %s"
- (cadr (assq action names)) article
- (nnheader-get-report (car to-method))))
- ((eq art-group 'junk)
- (when (eq action 'move)
- (gnus-summary-mark-article article gnus-canceled-mark)
- (gnus-message 4 "Deleted article %s" article)
- ;; run the delete hook
- (run-hook-with-args 'gnus-summary-article-delete-hook
- action
- (gnus-data-header
- (assoc article (gnus-data-list nil)))
- gnus-newsgroup-name nil
- select-method)))
- (t
- (let* ((pto-group (gnus-group-prefixed-name
- (car art-group) to-method))
- (info (gnus-get-info pto-group))
- (to-group (gnus-info-group info))
- to-marks)
- ;; Update the group that has been moved to.
- (when (and info
- (memq action '(move copy)))
- (unless (member to-group to-groups)
- (push to-group to-groups))
-
- (unless (memq article gnus-newsgroup-unreads)
- (push 'read to-marks)
- (gnus-info-set-read
- info (gnus-add-to-range (gnus-info-read info)
- (list (cdr art-group)))))
-
- ;; See whether the article is to be put in the cache.
- (let* ((expirable (gnus-group-auto-expirable-p to-group))
- (marks (if expirable
- gnus-article-mark-lists
- (delete '(expirable . expire)
- (copy-sequence gnus-article-mark-lists))))
- (to-article (cdr art-group)))
-
- ;; Enter the article into the cache in the new group,
- ;; if that is required.
- (when gnus-use-cache
- (gnus-cache-possibly-enter-article
- to-group to-article
- (memq article gnus-newsgroup-marked)
- (memq article gnus-newsgroup-dormant)
- (memq article gnus-newsgroup-unreads)))
-
- (when gnus-preserve-marks
- ;; Copy any marks over to the new group.
- (when (and (equal to-group gnus-newsgroup-name)
- (not (memq article gnus-newsgroup-unreads)))
- ;; Mark this article as read in this group.
- (push (cons to-article gnus-read-mark) gnus-newsgroup-reads)
- (setcdr (gnus-active to-group) to-article)
- (setcdr gnus-newsgroup-active to-article))
-
- (while marks
- (when (eq (gnus-article-mark-to-type (cdar marks)) 'list)
- (when (memq article (symbol-value
- (intern (format "gnus-newsgroup-%s"
- (caar marks)))))
- (push (cdar marks) to-marks)
- ;; If the other group is the same as this group,
- ;; then we have to add the mark to the list.
- (when (equal to-group gnus-newsgroup-name)
- (set (intern (format "gnus-newsgroup-%s" (caar marks)))
- (cons to-article
- (symbol-value
- (intern (format "gnus-newsgroup-%s"
- (caar marks)))))))
- ;; Copy the marks to other group.
- (gnus-add-marked-articles
- to-group (cdar marks) (list to-article) info)))
- (setq marks (cdr marks)))
-
- (when (and expirable
- gnus-mark-copied-or-moved-articles-as-expirable
- (not (memq 'expire to-marks)))
- ;; Mark this article as expirable.
- (push 'expire to-marks)
- (when (equal to-group gnus-newsgroup-name)
- (push to-article gnus-newsgroup-expirable))
- ;; Copy the expirable mark to other group.
- (gnus-add-marked-articles
- to-group 'expire (list to-article) info))
-
- (gnus-request-set-mark
- to-group (list (list (list to-article) 'add to-marks))))
-
- (gnus-dribble-enter
- (concat "(gnus-group-set-info '"
- (gnus-prin1-to-string (gnus-get-info to-group))
- ")"))))
-
- ;; Update the Xref header in this article to point to
- ;; the new crossposted article we have just created.
- (when (eq action 'crosspost)
- (with-current-buffer copy-buf
- (gnus-request-article-this-buffer article gnus-newsgroup-name)
- (nnheader-replace-header "Xref" new-xref)
- (gnus-request-replace-article
- article gnus-newsgroup-name (current-buffer) t)))
-
- ;; run the move/copy/crosspost/respool hook
- (run-hook-with-args 'gnus-summary-article-move-hook
- action
- (gnus-data-header
- (assoc article (gnus-data-list nil)))
- gnus-newsgroup-name
- to-newsgroup
- select-method))
-
- ;;;!!!Why is this necessary?
- (set-buffer gnus-summary-buffer)
-
- (gnus-summary-goto-subject article)
- (when (eq action 'move)
- (gnus-summary-mark-article article gnus-canceled-mark))))
- (push article articles-to-update-marks))
-
- (apply 'gnus-summary-remove-process-mark articles-to-update-marks)
+ (when (gnus-request-article-this-buffer article
+ gnus-newsgroup-name)
+ (save-restriction
+ (nnheader-narrow-to-headers)
+ (dolist (hdr gnus-copy-article-ignored-headers)
+ (message-remove-header hdr t)))
+ (gnus-request-accept-article
+ to-newsgroup select-method (not articles) t))))
+ ;; Crosspost the article.
+ ((eq action 'crosspost)
+ (let ((xref (message-tokenize-header
+ (mail-header-xref (gnus-summary-article-header
+ article))
+ " ")))
+ (setq new-xref (concat (gnus-group-real-name gnus-newsgroup-name)
+ ":" (number-to-string article)))
+ (unless xref
+ (setq xref (list (system-name))))
+ (setq new-xref
+ (concat
+ (mapconcat 'identity
+ (delete "Xref:" (delete new-xref xref))
+ " ")
+ " " new-xref))
+ (with-current-buffer copy-buf
+ ;; First put the article in the destination group.
+ (gnus-request-article-this-buffer article gnus-newsgroup-name)
+ (when (consp (setq art-group
+ (gnus-request-accept-article
+ to-newsgroup select-method (not articles)
+ t)))
+ (setq new-xref (concat new-xref " " (car art-group)
+ ":"
+ (number-to-string (cdr art-group))))
+ ;; Now we have the new Xrefs header, so we insert
+ ;; it and replace the new article.
+ (nnheader-replace-header "Xref" new-xref)
+ (gnus-request-replace-article
+ (cdr art-group) to-newsgroup (current-buffer) t)
+ art-group))))))
+ (cond
+ ((not art-group)
+ (gnus-message 1 "Couldn't %s article %s: %s"
+ (cadr (assq action names)) article
+ (nnheader-get-report (car to-method))))
+ ((eq art-group 'junk)
+ (when (eq action 'move)
+ (gnus-summary-mark-article article gnus-canceled-mark)
+ (gnus-message 4 "Deleted article %s" article)
+ ;; run the delete hook
+ (run-hook-with-args 'gnus-summary-article-delete-hook
+ action
+ (gnus-data-header
+ (assoc article (gnus-data-list nil)))
+ gnus-newsgroup-original-name nil
+ select-method)))
+ (t
+ (let* ((pto-group (gnus-group-prefixed-name
+ (car art-group) to-method))
+ (info (gnus-get-info pto-group))
+ (to-group (gnus-info-group info))
+ to-marks)
+ ;; Update the group that has been moved to.
+ (when (and info
+ (memq action '(move copy)))
+ (unless (member to-group to-groups)
+ (push to-group to-groups))
+
+ (unless (memq article gnus-newsgroup-unreads)
+ (push 'read to-marks)
+ (gnus-info-set-read
+ info (gnus-add-to-range (gnus-info-read info)
+ (list (cdr art-group)))))
+
+ ;; See whether the article is to be put in the cache.
+ (let* ((expirable (gnus-group-auto-expirable-p to-group))
+ (marks (if expirable
+ gnus-article-mark-lists
+ (delete '(expirable . expire)
+ (copy-sequence
+ gnus-article-mark-lists))))
+ (to-article (cdr art-group)))
+
+ ;; Enter the article into the cache in the new group,
+ ;; if that is required.
+ (when gnus-use-cache
+ (gnus-cache-possibly-enter-article
+ to-group to-article
+ (memq article gnus-newsgroup-marked)
+ (memq article gnus-newsgroup-dormant)
+ (memq article gnus-newsgroup-unreads)))
+
+ (when gnus-preserve-marks
+ ;; Copy any marks over to the new group.
+ (when (and (equal to-group gnus-newsgroup-name)
+ (not (memq article gnus-newsgroup-unreads)))
+ ;; Mark this article as read in this group.
+ (push (cons to-article gnus-read-mark)
+ gnus-newsgroup-reads)
+ ;; Increase the active status of this group.
+ (setcdr (gnus-active to-group) to-article)
+ (setcdr gnus-newsgroup-active to-article))
+
+ (while marks
+ (when (eq (gnus-article-mark-to-type (cdar marks)) 'list)
+ (when (memq article (symbol-value
+ (intern (format "gnus-newsgroup-%s"
+ (caar marks)))))
+ (push (cdar marks) to-marks)
+ ;; If the other group is the same as this group,
+ ;; then we have to add the mark to the list.
+ (when (equal to-group gnus-newsgroup-name)
+ (set (intern (format "gnus-newsgroup-%s"
+ (caar marks)))
+ (cons to-article
+ (symbol-value
+ (intern (format "gnus-newsgroup-%s"
+ (caar marks)))))))
+ ;; Copy the marks to other group.
+ (gnus-add-marked-articles
+ to-group (cdar marks) (list to-article) info)))
+ (setq marks (cdr marks)))
+
+ (when (and expirable
+ gnus-mark-copied-or-moved-articles-as-expirable
+ (not (memq 'expire to-marks)))
+ ;; Mark this article as expirable.
+ (push 'expire to-marks)
+ (when (equal to-group gnus-newsgroup-name)
+ (push to-article gnus-newsgroup-expirable))
+ ;; Copy the expirable mark to other group.
+ (gnus-add-marked-articles
+ to-group 'expire (list to-article) info))
+
+ (when to-marks
+ (gnus-request-set-mark
+ to-group (list (list (list to-article) 'add to-marks)))))
+
+ (gnus-dribble-enter
+ (concat "(gnus-group-set-info '"
+ (gnus-prin1-to-string (gnus-get-info to-group))
+ ")"))))
+
+ ;; Update the Xref header in this article to point to
+ ;; the new crossposted article we have just created.
+ (when (eq action 'crosspost)
+ (with-current-buffer copy-buf
+ (gnus-request-article-this-buffer article gnus-newsgroup-name)
+ (nnheader-replace-header "Xref" new-xref)
+ (gnus-request-replace-article
+ article gnus-newsgroup-name (current-buffer) t)))
+
+ ;; run the move/copy/crosspost/respool hook
+ (let ((header (gnus-data-header
+ (assoc article (gnus-data-list nil)))))
+ (mail-header-set-subject header gnus-article-original-subject)
+ (run-hook-with-args 'gnus-summary-article-move-hook
+ action
+ (gnus-data-header
+ (assoc article (gnus-data-list nil)))
+ gnus-newsgroup-original-name
+ to-newsgroup
+ select-method)))
+
+ ;;;!!!Why is this necessary?
+ (set-buffer gnus-summary-buffer)
+
+ (when (eq action 'move)
+ (save-excursion
+ (gnus-summary-goto-subject article)
+ (gnus-summary-mark-article article gnus-canceled-mark)))))
+ (push article articles-to-update-marks)))
+
+ (save-excursion
+ (apply 'gnus-summary-remove-process-mark articles-to-update-marks))
;; Re-activate all groups that have been moved to.
(with-current-buffer gnus-group-buffer
(let ((gnus-group-marked to-groups))
@@ -9889,6 +9947,20 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
(gnus-summary-position-point)
(gnus-set-mode-line 'summary)))
+(defun gnus-summary-push-marks-to-backend (article)
+ (let ((set nil)
+ (marks gnus-article-mark-lists))
+ (when (memq article gnus-newsgroup-unreads)
+ (push 'read set))
+ (while marks
+ (when (and (eq (gnus-article-mark-to-type (cdar marks)) 'list)
+ (memq article (symbol-value
+ (intern (format "gnus-newsgroup-%s"
+ (caar marks))))))
+ (push (cdar marks) set))
+ (pop marks))
+ (gnus-request-set-mark gnus-newsgroup-name `(((,article) set ,set)))))
+
(defun gnus-summary-copy-article (&optional n to-newsgroup select-method)
"Copy the current article to some other group.
If TO-NEWSGROUP is string, do not prompt for a newsgroup to copy to.
@@ -9933,9 +10005,9 @@ latter case, they will be copied into the relevant groups."
(car (gnus-find-method-for-group
gnus-newsgroup-name)))))
(method
- (gnus-completing-read-with-default
- methname "Backend to use when respooling"
- methods nil t nil 'gnus-mail-method-history))
+ (gnus-completing-read
+ "Backend to use when respooling"
+ methods t nil 'gnus-mail-method-history methname))
ms)
(cond
((zerop (length (setq ms (gnus-servers-using-backend
@@ -9945,7 +10017,7 @@ latter case, they will be copied into the relevant groups."
(car ms))
(t
(let ((ms-alist (mapcar (lambda (m) (cons (cadr m) m)) ms)))
- (cdr (assoc (completing-read "Server name: " ms-alist nil t)
+ (cdr (assoc (gnus-completing-read "Server name" ms-alist t)
ms-alist))))))))
(unless method
(error "No method given for respooling"))
@@ -10135,19 +10207,20 @@ confirmation before the articles are deleted."
;; Delete the articles.
(setq not-deleted (gnus-request-expire-articles
articles gnus-newsgroup-name 'force))
- (while articles
- (gnus-summary-remove-process-mark (car articles))
- ;; The backend might not have been able to delete the article
- ;; after all.
- (unless (memq (car articles) not-deleted)
- (gnus-summary-mark-article (car articles) gnus-canceled-mark))
- (let* ((article (car articles))
- (ghead (gnus-data-header
- (assoc article (gnus-data-list nil)))))
- (run-hook-with-args 'gnus-summary-article-delete-hook
- 'delete ghead gnus-newsgroup-name nil
- nil))
- (setq articles (cdr articles)))
+ (save-excursion
+ (while articles
+ (gnus-summary-remove-process-mark (car articles))
+ ;; The backend might not have been able to delete the article
+ ;; after all.
+ (unless (memq (car articles) not-deleted)
+ (gnus-summary-mark-article (car articles) gnus-canceled-mark))
+ (let* ((article (car articles))
+ (ghead (gnus-data-header
+ (assoc article (gnus-data-list nil)))))
+ (run-hook-with-args 'gnus-summary-article-delete-hook
+ 'delete ghead gnus-newsgroup-name nil
+ nil))
+ (setq articles (cdr articles))))
(when not-deleted
(gnus-message 4 "Couldn't delete articles %s" not-deleted)))
(gnus-summary-position-point)
@@ -10245,7 +10318,7 @@ groups."
"Make edits to the current article permanent."
(interactive)
(save-excursion
- ;; The buffer restriction contains the entire article if it exists.
+ ;; The buffer restriction contains the entire article if it exists.
(when (article-goto-body)
(let ((lines (count-lines (point) (point-max)))
(length (- (point-max) (point)))
@@ -10265,15 +10338,25 @@ groups."
(delete-region (match-beginning 1) (match-end 1))
(insert (number-to-string lines))))))
;; Replace the article.
- (let ((buf (current-buffer)))
+ (let ((buf (current-buffer))
+ (article (cdr gnus-article-current))
+ replace-result)
(with-temp-buffer
(insert-buffer-substring buf)
-
(if (and (not read-only)
- (not (gnus-request-replace-article
- (cdr gnus-article-current) (car gnus-article-current)
- (current-buffer) t)))
+ (not (setq replace-result
+ (gnus-request-replace-article
+ article (car gnus-article-current)
+ (current-buffer) t))))
(error "Couldn't replace article")
+ ;; If we got a number back, then that's the new article number
+ ;; for this article. Otherwise, the article number didn't change.
+ (when (numberp replace-result)
+ (with-current-buffer gnus-summary-buffer
+ (setq gnus-newsgroup-limit (delq article gnus-newsgroup-limit))
+ (gnus-summary-limit gnus-newsgroup-limit)
+ (setq article replace-result)
+ (gnus-summary-goto-subject article t)))
;; Update the summary buffer.
(if (and references
(equal (message-tokenize-header references " ")
@@ -10287,38 +10370,29 @@ groups."
(point-min) (point-max)))
header)
(with-temp-buffer
- (insert (format "211 %d Article retrieved.\n"
- (cdr gnus-article-current)))
+ (insert (format "211 %d Article retrieved.\n" article))
(insert head)
(insert ".\n")
(let ((nntp-server-buffer (current-buffer)))
- (setq header (car (gnus-get-newsgroup-headers
- nil t))))
+ (setq header (car (gnus-get-newsgroup-headers nil t))))
(with-current-buffer gnus-summary-buffer
- (gnus-data-set-header
- (gnus-data-find (cdr gnus-article-current))
- header)
- (gnus-summary-update-article-line
- (cdr gnus-article-current) header)
- (if (gnus-summary-goto-subject
- (cdr gnus-article-current) nil t)
- (gnus-summary-update-secondary-mark
- (cdr gnus-article-current))))))))
+ (gnus-data-set-header (gnus-data-find article) header)
+ (gnus-summary-update-article-line article header)
+ (if (gnus-summary-goto-subject article nil t)
+ (gnus-summary-update-secondary-mark article)))))))
;; Update threads.
(set-buffer (or buffer gnus-summary-buffer))
- (gnus-summary-update-article (cdr gnus-article-current))
- (if (gnus-summary-goto-subject (cdr gnus-article-current) nil t)
- (gnus-summary-update-secondary-mark
- (cdr gnus-article-current))))
+ (gnus-summary-update-article article)
+ (if (gnus-summary-goto-subject article nil t)
+ (gnus-summary-update-secondary-mark article)))
;; Prettify the article buffer again.
(unless no-highlight
(with-current-buffer gnus-article-buffer
- ;;;!!! Fix this -- article should be rehighlighted.
- ;;;(gnus-run-hooks 'gnus-article-display-hook)
+ ;;!!! Fix this -- article should be rehighlighted.
+ ;;(gnus-run-hooks 'gnus-article-display-hook)
(set-buffer gnus-original-article-buffer)
(gnus-request-article
- (cdr gnus-article-current)
- (car gnus-article-current) (current-buffer))))
+ article (car gnus-article-current) (current-buffer))))
;; Prettify the summary buffer line.
(when (gnus-visual-p 'summary-highlight 'highlight)
(gnus-run-hooks 'gnus-visual-mark-article-hook))))))
@@ -10526,7 +10600,7 @@ ARTICLE can also be a list of articles."
(not (equal gnus-newsgroup-name (car gnus-article-current))))
(error "No current article selected"))
;; Remove old bookmark, if one exists.
- (gnus-pull article gnus-newsgroup-bookmarks)
+ (gnus-alist-pull article gnus-newsgroup-bookmarks)
;; Set the new bookmark, which is on the form
;; (article-number . line-number-in-body).
(push
@@ -10547,7 +10621,7 @@ ARTICLE can also be a list of articles."
;; Remove old bookmark, if one exists.
(if (not (assq article gnus-newsgroup-bookmarks))
(gnus-message 6 "No bookmark in current article.")
- (gnus-pull article gnus-newsgroup-bookmarks)
+ (gnus-alist-pull article gnus-newsgroup-bookmarks)
(gnus-message 6 "Removed bookmark.")))
;; Suggested by Daniel Quinlan <quinlan@best.com>.
@@ -10673,7 +10747,7 @@ If NO-EXPIRE, auto-expiry will be inhibited."
(setq gnus-newsgroup-unreads
(gnus-add-to-sorted-list gnus-newsgroup-unreads
article))))
- (gnus-pull article gnus-newsgroup-reads)
+ (gnus-alist-pull article gnus-newsgroup-reads)
;; See whether the article is to be put in the cache.
(and gnus-use-cache
@@ -10758,6 +10832,7 @@ If NO-EXPIRE, auto-expiry will be inhibited."
(t gnus-no-mark))
'replied)
(when (gnus-visual-p 'summary-highlight 'highlight)
+ (gnus-summary-highlight-line)
(gnus-run-hooks 'gnus-summary-update-hook))
t)
@@ -10785,7 +10860,12 @@ If NO-EXPIRE, auto-expiry will be inhibited."
;; Go to the right position on the line.
(goto-char (+ forward (point)))
;; Replace the old mark with the new mark.
- (subst-char-in-region (point) (1+ (point)) (char-after) mark)
+ (let ((to-insert
+ (mm-subst-char-in-string
+ (char-after) mark
+ (buffer-substring (point) (1+ (point))))))
+ (delete-region (point) (1+ (point)))
+ (insert to-insert))
;; Optionally update the marks by some user rule.
(when (eq type 'unread)
(gnus-data-set-mark
@@ -10841,13 +10921,9 @@ If NO-EXPIRE, auto-expiry will be inhibited."
(t
(setq gnus-newsgroup-unreads
(gnus-add-to-sorted-list gnus-newsgroup-unreads article))))
- (gnus-pull article gnus-newsgroup-reads)
+ (gnus-alist-pull article gnus-newsgroup-reads)
t)))
-(defalias 'gnus-summary-mark-as-unread-forward
- 'gnus-summary-tick-article-forward)
-(make-obsolete 'gnus-summary-mark-as-unread-forward
- 'gnus-summary-tick-article-forward "Emacs 20.4")
(defun gnus-summary-tick-article-forward (n)
"Tick N articles forwards.
If N is negative, tick backwards instead.
@@ -10855,18 +10931,12 @@ The difference between N and the number of articles ticked is returned."
(interactive "p")
(gnus-summary-mark-forward n gnus-ticked-mark))
-(defalias 'gnus-summary-mark-as-unread-backward
- 'gnus-summary-tick-article-backward)
-(make-obsolete 'gnus-summary-mark-as-unread-backward
- 'gnus-summary-tick-article-backward "Emacs 20.4")
(defun gnus-summary-tick-article-backward (n)
"Tick N articles backwards.
The difference between N and the number of articles ticked is returned."
(interactive "p")
(gnus-summary-mark-forward (- n) gnus-ticked-mark))
-(defalias 'gnus-summary-mark-as-unread 'gnus-summary-tick-article)
-(make-obsolete 'gnus-summary-mark-as-unread 'gnus-summary-tick-article "Emacs 20.4")
(defun gnus-summary-tick-article (&optional article clear-mark)
"Mark current article as unread.
Optional 1st argument ARTICLE specifies article number to be marked as unread.
@@ -11202,6 +11272,7 @@ with that article."
(mail-header-subject (gnus-data-header (car data)))))
(t nil)))
(end-point (save-excursion
+ (goto-char (gnus-data-pos (car data)))
(if (gnus-summary-go-to-next-thread)
(point) (point-max))))
articles)
@@ -11309,7 +11380,7 @@ If ARG is positive number, turn showing conversation threads on."
(defalias 'gnus-remove-overlays 'remove-overlays)
(defun gnus-remove-overlays (beg end name val)
"Clear BEG and END of overlays whose property NAME has value VAL.
-For compatibility with Emacs 21 and XEmacs."
+For compatibility with XEmacs."
(dolist (ov (gnus-overlays-in beg end))
(when (eq (gnus-overlay-get ov name) val)
(gnus-delete-overlay ov))))))
@@ -11320,15 +11391,19 @@ For compatibility with Emacs 21 and XEmacs."
(gnus-remove-overlays (point-min) (point-max) 'invisible 'gnus-sum)
(gnus-summary-position-point))
+(defsubst gnus-summary--inv (p)
+ (and (eq (get-char-property p 'invisible) 'gnus-sum) p))
+
(defun gnus-summary-show-thread ()
"Show thread subtrees.
Returns nil if no thread was there to be shown."
(interactive)
(let* ((orig (point))
(end (point-at-eol))
+ (end (or (gnus-summary--inv end) (gnus-summary--inv (1- end))))
;; Leave point at bol
(beg (progn (beginning-of-line) (if (bobp) (point) (1- (point)))))
- (eoi (when (eq (get-char-property end 'invisible) 'gnus-sum)
+ (eoi (when end
(if (fboundp 'next-single-char-property-change)
(or (next-single-char-property-change end 'invisible)
(point-max))
@@ -11527,7 +11602,7 @@ If the prefix argument is negative, tick articles instead."
((> unmark 0)
(gnus-summary-mark-article-as-unread gnus-unread-mark))
((= unmark 0)
- (gnus-summary-mark-article-as-unread gnus-expirable-mark))
+ (gnus-summary-mark-article nil gnus-expirable-mark))
(t
(gnus-summary-mark-article-as-unread gnus-ticked-mark)))
(setq articles (cdr articles))))
@@ -11684,12 +11759,8 @@ will not be marked as saved."
(gnus-message 1 "Article %d is unsaveable" article))
;; This is a real article.
(save-window-excursion
- (let ((gnus-display-mime-function (when decode
- gnus-display-mime-function))
- (gnus-article-prepare-hook (when decode
- gnus-article-prepare-hook)))
- (gnus-summary-select-article t t nil article)
- (gnus-summary-goto-subject article)))
+ (gnus-summary-select-article decode decode nil article)
+ (gnus-summary-goto-subject article))
(with-current-buffer save-buffer
(erase-buffer)
(insert-buffer-substring (if decode
@@ -11897,7 +11968,8 @@ save those articles instead."
(nreverse split-name)))
(defun gnus-valid-move-group-p (group)
- (and (boundp group)
+ (and (symbolp group)
+ (boundp group)
(symbol-name group)
(symbol-value group)
(gnus-get-function (gnus-find-method-for-group
@@ -11914,29 +11986,21 @@ save those articles instead."
(format "these %d articles" (length articles))
"this article")))
(to-newsgroup
- (let (active group)
- (when (or (null split-name) (= 1 (length split-name)))
- (setq active (gnus-make-hashtable (length gnus-active-hashtb)))
- (mapatoms (lambda (symbol)
- (setq group (symbol-name symbol))
- (when (string-match "[^\000-\177]" group)
- (setq group (gnus-group-decoded-name group)))
- (set (intern group active) group))
- gnus-active-hashtb))
- (cond
- ((null split-name)
- (gnus-completing-read-with-default
- default prom active 'gnus-valid-move-group-p nil prefix
- 'gnus-group-history))
- ((= 1 (length split-name))
- (gnus-completing-read-with-default
- (car split-name) prom active 'gnus-valid-move-group-p nil nil
- 'gnus-group-history))
- (t
- (gnus-completing-read-with-default
- nil prom (mapcar 'list (nreverse split-name)) nil nil nil
- 'gnus-group-history)))))
- (to-method (gnus-server-to-method (gnus-group-method to-newsgroup)))
+ (cond
+ ((null split-name)
+ (gnus-group-completing-read
+ prom
+ (gnus-remove-if-not 'gnus-valid-move-group-p gnus-active-hashtb t)
+ nil prefix nil default))
+ ((= 1 (length split-name))
+ (gnus-group-completing-read
+ prom
+ (gnus-remove-if-not 'gnus-valid-move-group-p gnus-active-hashtb t)
+ nil prefix 'gnus-group-history (car split-name)))
+ (t
+ (gnus-completing-read
+ prom (nreverse split-name) nil nil 'gnus-group-history))))
+ (to-method (gnus-server-to-method (gnus-group-method to-newsgroup)))
encoded)
(when to-newsgroup
(if (or (string= to-newsgroup "")
@@ -12633,13 +12697,15 @@ If ALL is a number, fetch this number of articles."
(interactive)
(prog1
(let ((old (sort (mapcar 'car gnus-newsgroup-data) '<))
- (old-active gnus-newsgroup-active)
+ (old-high gnus-newsgroup-highest)
(nnmail-fetched-sources (list t))
i new)
(setq gnus-newsgroup-active
- (gnus-activate-group gnus-newsgroup-name 'scan))
- (setq i (cdr gnus-newsgroup-active))
- (while (> i (cdr old-active))
+ (gnus-copy-sequence
+ (gnus-activate-group gnus-newsgroup-name 'scan)))
+ (setq i (cdr gnus-newsgroup-active)
+ gnus-newsgroup-highest i)
+ (while (> i old-high)
(push i new)
(decf i))
(if (not new)
@@ -12650,6 +12716,64 @@ If ALL is a number, fetch this number of articles."
(gnus-summary-limit (gnus-sorted-nunion old new))))
(gnus-summary-position-point)))
+;;; Bookmark support for Gnus.
+(declare-function bookmark-make-record-default
+ "bookmark" (&optional no-file no-context posn))
+(declare-function bookmark-prop-get "bookmark" (bookmark prop))
+(declare-function bookmark-default-handler "bookmark" (bmk))
+(declare-function bookmark-get-bookmark-record "bookmark" (bmk))
+(defvar bookmark-yank-point)
+(defvar bookmark-current-buffer)
+
+(defun gnus-summary-bookmark-make-record ()
+ "Make a bookmark entry for a Gnus summary buffer."
+ (let (pos buf)
+ (unless (and (derived-mode-p 'gnus-summary-mode) gnus-article-current)
+ (save-restriction ; FIXME is it necessary to widen?
+ (widen) (setq pos (point))) ; Set position in gnus-article buffer.
+ (setq buf "art") ; We are recording bookmark from article buffer.
+ (setq bookmark-yank-point (point))
+ (setq bookmark-current-buffer (current-buffer))
+ (gnus-article-show-summary)) ; Go back in summary buffer.
+ ;; We are now recording bookmark from summary buffer.
+ (unless buf (setq buf "sum"))
+ (let* ((subject (elt (gnus-summary-article-header) 1))
+ (grp (car gnus-article-current))
+ (art (cdr gnus-article-current))
+ (head (gnus-summary-article-header art))
+ (id (mail-header-id head)))
+ `(,subject
+ ,@(condition-case nil
+ (bookmark-make-record-default 'no-file 'no-context pos)
+ (wrong-number-of-arguments
+ (bookmark-make-record-default 'point-only)))
+ (location . ,(format "Gnus-%s %s:%d:%s" buf grp art id))
+ (group . ,grp) (article . ,art)
+ (message-id . ,id) (handler . gnus-summary-bookmark-jump)))))
+
+;;;###autoload
+(defun gnus-summary-bookmark-jump (bookmark)
+ "Handler function for record returned by `gnus-summary-bookmark-make-record'.
+BOOKMARK is a bookmark name or a bookmark record."
+ (let ((group (bookmark-prop-get bookmark 'group))
+ (article (bookmark-prop-get bookmark 'article))
+ (id (bookmark-prop-get bookmark 'message-id))
+ (buf (car (split-string (bookmark-prop-get bookmark 'location)))))
+ (gnus-fetch-group group (list article))
+ (gnus-summary-insert-cached-articles)
+ (gnus-summary-goto-article id nil 'force)
+ ;; FIXME we have to wait article buffer is ready (only large buffer)
+ ;; Is there a better solution to know that?
+ ;; If we don't wait `bookmark-default-handler' will have no chance
+ ;; to set position. However there is no error, just wrong pos.
+ (sit-for 1)
+ (when (string= buf "Gnus-art")
+ (other-window 1))
+ (bookmark-default-handler
+ `(""
+ (buffer . ,(current-buffer))
+ . ,(bookmark-get-bookmark-record bookmark)))))
+
(gnus-summary-make-all-marking-commands)
(gnus-ems-redefine)
@@ -12662,5 +12786,4 @@ If ALL is a number, fetch this number of articles."
;; coding: iso-8859-1
;; End:
-;; arch-tag: 17c6748f-6d00-4d36-bf01-835c42f31235
;;; gnus-sum.el ends here
diff --git a/lisp/gnus/gnus-sync.el b/lisp/gnus/gnus-sync.el
new file mode 100644
index 00000000000..8a492e8d2c3
--- /dev/null
+++ b/lisp/gnus/gnus-sync.el
@@ -0,0 +1,240 @@
+;;; gnus-sync.el --- synchronization facility for Gnus
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Ted Zlatanov <tzz@lifelogs.com>
+;; Keywords: news synchronization nntp nnrss
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This is the gnus-sync.el package.
+
+;; It's due for a rewrite using gnus-after-set-mark-hook and
+;; gnus-before-update-mark-hook. Until then please consider it
+;; experimental.
+
+;; Put this in your startup file (~/.gnus.el for instance)
+
+;; possibilities for gnus-sync-backend:
+;; Tramp over SSH: /ssh:user@host:/path/to/filename
+;; Tramp over IMAP: /imaps:user@yourhosthere.com:/INBOX.test/filename
+;; ...or any other file Tramp and Emacs can handle...
+
+;; (setq gnus-sync-backend "/remote:/path.gpg" ; will use Tramp+EPA if loaded
+;; gnus-sync-global-vars `(gnus-newsrc-last-checked-date)
+;; gnus-sync-newsrc-groups `("nntp" "nnrss")
+;; gnus-sync-newsrc-offsets `(2 3))
+
+;; TODO:
+
+;; - after gnus-sync-read, the message counts are wrong
+
+;; - use gnus-after-set-mark-hook and gnus-before-update-mark-hook to
+;; catch the mark updates
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'gnus)
+(require 'gnus-start)
+(require 'gnus-util)
+
+(defgroup gnus-sync nil
+ "The Gnus synchronization facility."
+ :version "24.1"
+ :group 'gnus)
+
+(defcustom gnus-sync-newsrc-groups `("nntp" "nnrss")
+ "List of groups to be synchronized in the gnus-newsrc-alist.
+The group names are matched, they don't have to be fully
+qualified. Typically you would choose all of these. That's the
+default because there is no active sync backend by default, so
+this setting is harmless until the user chooses a sync backend."
+ :group 'gnus-sync
+ :type '(repeat regexp))
+
+(defcustom gnus-sync-newsrc-offsets '(2 3)
+ "List of per-group data to be synchronized."
+ :group 'gnus-sync
+ :type '(set (const :tag "Read ranges" 2)
+ (const :tag "Marks" 3)))
+
+(defcustom gnus-sync-global-vars nil
+ "List of global variables to be synchronized.
+You may want to sync `gnus-newsrc-last-checked-date' but pretty
+much any symbol is fair game. You could additionally sync
+`gnus-newsrc-alist', `gnus-server-alist', `gnus-topic-topology',
+and `gnus-topic-alist' to cover all the variables in
+newsrc.eld (except for `gnus-format-specs' which should not be
+synchronized, I believe). Also see `gnus-variable-list'."
+ :group 'gnus-sync
+ :type '(repeat (choice (variable :tag "A known variable")
+ (symbol :tag "Any symbol"))))
+
+(defcustom gnus-sync-backend nil
+ "The synchronization backend."
+ :group 'gnus-sync
+ :type '(radio (const :format "None" nil)
+ (string :tag "Sync to a file")))
+
+(defvar gnus-sync-newsrc-loader nil
+ "Carrier for newsrc data")
+
+(defun gnus-sync-save ()
+"Save the Gnus sync data to the backend."
+ (interactive)
+ (cond
+ ((stringp gnus-sync-backend)
+ (gnus-message 7 "gnus-sync: saving to backend %s" gnus-sync-backend)
+ ;; populate gnus-sync-newsrc-loader from all but the first dummy
+ ;; entry in gnus-newsrc-alist whose group matches any of the
+ ;; gnus-sync-newsrc-groups
+ ;; TODO: keep the old contents for groups we don't have!
+ (let ((gnus-sync-newsrc-loader
+ (loop for entry in (cdr gnus-newsrc-alist)
+ when (gnus-grep-in-list
+ (car entry) ;the group name
+ gnus-sync-newsrc-groups)
+ collect (cons (car entry)
+ (mapcar (lambda (offset)
+ (cons offset (nth offset entry)))
+ gnus-sync-newsrc-offsets)))))
+ (with-temp-file gnus-sync-backend
+ (progn
+ (let ((coding-system-for-write gnus-ding-file-coding-system)
+ (standard-output (current-buffer)))
+ (princ (format ";; -*- mode:emacs-lisp; coding: %s; -*-\n"
+ gnus-ding-file-coding-system))
+ (princ ";; Gnus sync data v. 0.0.1\n")
+ (let* ((print-quoted t)
+ (print-readably t)
+ (print-escape-multibyte nil)
+ (print-escape-nonascii t)
+ (print-length nil)
+ (print-level nil)
+ (print-circle nil)
+ (print-escape-newlines t)
+ (variables (cons 'gnus-sync-newsrc-loader
+ gnus-sync-global-vars))
+ variable)
+ (while variables
+ (if (and (boundp (setq variable (pop variables)))
+ (symbol-value variable))
+ (progn
+ (princ "\n(setq ")
+ (princ (symbol-name variable))
+ (princ " '")
+ (prin1 (symbol-value variable))
+ (princ ")\n"))
+ (princ "\n;;; skipping empty variable ")
+ (princ (symbol-name variable)))))
+ (gnus-message
+ 7
+ "gnus-sync: stored variables %s and %d groups in %s"
+ gnus-sync-global-vars
+ (length gnus-sync-newsrc-loader)
+ gnus-sync-backend)
+
+ ;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu>
+ ;; Save the .eld file with extra line breaks.
+ (gnus-message 8 "gnus-sync: adding whitespace to %s"
+ gnus-sync-backend)
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward "^(\\|(\\\"" nil t)
+ (replace-match "\n\\&" t))
+ (goto-char (point-min))
+ (while (re-search-forward " $" nil t)
+ (replace-match "" t t))))))))
+ ;; the pass-through case: gnus-sync-backend is not a known choice
+ (nil)))
+
+(defun gnus-sync-read ()
+"Load the Gnus sync data from the backend."
+ (interactive)
+ (when gnus-sync-backend
+ (gnus-message 7 "gnus-sync: loading from backend %s" gnus-sync-backend)
+ (cond ((stringp gnus-sync-backend)
+ ;; read data here...
+ (if (or debug-on-error debug-on-quit)
+ (load gnus-sync-backend nil t)
+ (condition-case var
+ (load gnus-sync-backend nil t)
+ (error
+ (error "Error in %s: %s" gnus-sync-backend (cadr var)))))
+ (let ((valid-count 0)
+ invalid-groups)
+ (dolist (node gnus-sync-newsrc-loader)
+ (if (gnus-gethash (car node) gnus-newsrc-hashtb)
+ (progn
+ (incf valid-count)
+ (loop for store in (cdr node)
+ do (setf (nth (car store)
+ (assoc (car node) gnus-newsrc-alist))
+ (cdr store))))
+ (push (car node) invalid-groups)))
+ (gnus-message
+ 7
+ "gnus-sync: loaded %d groups (out of %d) from %s"
+ valid-count (length gnus-sync-newsrc-loader)
+ gnus-sync-backend)
+ (when invalid-groups
+ (gnus-message
+ 7
+ "gnus-sync: skipped %d groups (out of %d) from %s"
+ (length invalid-groups)
+ (length gnus-sync-newsrc-loader)
+ gnus-sync-backend)
+ (gnus-message 9 "gnus-sync: skipped groups: %s"
+ (mapconcat 'identity invalid-groups ", ")))))
+ (nil))
+ ;; make the hashtable again because the newsrc-alist may have been modified
+ (when gnus-sync-newsrc-offsets
+ (gnus-message 9 "gnus-sync: remaking the newsrc hashtable")
+ (gnus-make-hashtable-from-newsrc-alist))))
+
+;;;###autoload
+(defun gnus-sync-initialize ()
+"Initialize the Gnus sync facility."
+ (interactive)
+ (gnus-message 5 "Initializing the sync facility")
+ (gnus-sync-install-hooks))
+
+;;;###autoload
+(defun gnus-sync-install-hooks ()
+ "Install the sync hooks."
+ (interactive)
+ ;; (add-hook 'gnus-get-new-news-hook 'gnus-sync-read)
+ (add-hook 'gnus-save-newsrc-hook 'gnus-sync-save)
+ (add-hook 'gnus-read-newsrc-el-hook 'gnus-sync-read))
+
+(defun gnus-sync-unload-hook ()
+ "Uninstall the sync hooks."
+ (interactive)
+ ;; (remove-hook 'gnus-get-new-news-hook 'gnus-sync-read)
+ (remove-hook 'gnus-save-newsrc-hook 'gnus-sync-save)
+ (remove-hook 'gnus-read-newsrc-el-hook 'gnus-sync-read))
+
+(add-hook 'gnus-sync-unload-hook 'gnus-sync-unload-hook)
+
+;; this is harmless by default, until the gnus-sync-backend is set
+(gnus-sync-initialize)
+
+(provide 'gnus-sync)
+
+;;; gnus-sync.el ends here
diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el
index 9d259881b09..e4afc7c2fb4 100644
--- a/lisp/gnus/gnus-topic.el
+++ b/lisp/gnus/gnus-topic.el
@@ -148,8 +148,7 @@ See Info node `(gnus)Formatting Variables'."
(defun gnus-group-parent-topic (group)
"Return the topic GROUP is member of by looking at the group buffer."
- (save-excursion
- (set-buffer gnus-group-buffer)
+ (with-current-buffer gnus-group-buffer
(if (gnus-group-goto-group group)
(gnus-current-topic)
(gnus-group-topic group))))
@@ -162,9 +161,7 @@ See Info node `(gnus)Formatting Variables'."
(defun gnus-topic-jump-to-topic (topic)
"Go to TOPIC."
(interactive
- (list (completing-read "Go to topic: "
- (mapcar 'list (gnus-topic-list))
- nil t)))
+ (list (gnus-completing-read "Go to topic" (gnus-topic-list) t)))
(let ((buffer-read-only nil))
(dolist (topic (gnus-current-topics topic))
(unless (gnus-topic-goto-topic topic)
@@ -912,8 +909,7 @@ articles in the topic and its subtopics."
(defun gnus-topic-change-level (group level oldlevel &optional previous)
"Run when changing levels to enter/remove groups from topics."
- (save-excursion
- (set-buffer gnus-group-buffer)
+ (with-current-buffer gnus-group-buffer
(let ((buffer-read-only nil))
(unless gnus-topic-inhibit-change-level
(gnus-group-goto-group (or (car (nth 2 previous)) group))
@@ -1140,6 +1136,7 @@ articles in the topic and its subtopics."
(defun gnus-topic-mode (&optional arg redisplay)
"Minor mode for topicsifying Gnus group buffers."
+ ;; FIXME: Use define-minor-mode.
(interactive (list current-prefix-arg t))
(when (eq major-mode 'gnus-group-mode)
(make-local-variable 'gnus-topic-mode)
@@ -1258,6 +1255,8 @@ that group.
If performed over a topic line, toggle folding the topic."
(interactive "P")
+ (when (and (eobp) (not (gnus-group-group-name)))
+ (forward-line -1))
(if (gnus-group-topic-p)
(let ((gnus-group-list-mode
(if all (cons (if (numberp all) all 7) t) gnus-group-list-mode)))
@@ -1304,8 +1303,8 @@ When used interactively, PARENT will be the topic under point."
If COPYP, copy the groups instead."
(interactive
(list current-prefix-arg
- (gnus-completing-read "Move to topic" gnus-topic-alist nil t
- 'gnus-topic-history)))
+ (gnus-completing-read "Move to topic" (mapcar 'car gnus-topic-alist) t
+ nil 'gnus-topic-history)))
(let ((use-marked (and (not n) (not (gnus-region-active-p))
gnus-group-marked t))
(groups (gnus-group-process-prefix n))
@@ -1351,7 +1350,8 @@ If COPYP, copy the groups instead."
"Copy the current group to a topic."
(interactive
(list current-prefix-arg
- (completing-read "Copy to topic: " gnus-topic-alist nil t)))
+ (gnus-completing-read
+ "Copy to topic" (mapcar 'car gnus-topic-alist) t)))
(gnus-topic-move-group n topic t))
(defun gnus-topic-kill-group (&optional n discard)
@@ -1444,7 +1444,8 @@ If PERMANENT, make it stay shown in subsequent sessions as well."
(gnus-topic-remove-topic t nil)
(let ((topic
(gnus-topic-find-topology
- (completing-read "Show topic: " gnus-topic-alist nil t))))
+ (gnus-completing-read "Show topic"
+ (mapcar 'car gnus-topic-alist) t))))
(setcar (cddr (cadr topic)) nil)
(setcar (cdr (cadr topic)) 'visible)
(gnus-group-list-groups)))))
@@ -1492,7 +1493,8 @@ If NON-RECURSIVE (which is the prefix) is t, don't unmark its subtopics."
(let (topic)
(nreverse
(list
- (setq topic (completing-read "Move to topic: " gnus-topic-alist nil t))
+ (setq topic (gnus-completing-read "Move to topic"
+ (mapcar 'car gnus-topic-alist) t))
(read-string (format "Move to %s (regexp): " topic))))))
(gnus-group-mark-regexp regexp)
(gnus-topic-move-group nil topic copyp))
@@ -1503,7 +1505,8 @@ If NON-RECURSIVE (which is the prefix) is t, don't unmark its subtopics."
(let (topic)
(nreverse
(list
- (setq topic (completing-read "Copy to topic: " gnus-topic-alist nil t))
+ (setq topic (gnus-completing-read "Copy to topic"
+ (mapcar 'car gnus-topic-alist) t))
(read-string (format "Copy to %s (regexp): " topic))))))
(gnus-topic-move-matching regexp topic t))
@@ -1724,8 +1727,9 @@ If REVERSE, sort in reverse order."
"Sort topics in TOPIC alphabetically by topic name.
If REVERSE, reverse the sorting order."
(interactive
- (list (completing-read "Sort topics in : " gnus-topic-alist nil t
- (gnus-current-topic))
+ (list (gnus-completing-read "Sort topics in"
+ (mapcar 'car gnus-topic-alist) t
+ (gnus-current-topic))
current-prefix-arg))
(let ((topic-topology (or (and topic (cdr (gnus-topic-find-topology topic)))
gnus-topic-topology)))
@@ -1739,7 +1743,7 @@ If REVERSE, reverse the sorting order."
(interactive
(list
(gnus-group-topic-name)
- (completing-read "Move to topic: " gnus-topic-alist nil t)))
+ (gnus-completing-read "Move to topic" (mapcar 'car gnus-topic-alist) t)))
(unless (and current to)
(error "Can't find topic"))
(let ((current-top (cdr (gnus-topic-find-topology current)))
@@ -1778,5 +1782,4 @@ If REVERSE, reverse the sorting order."
(provide 'gnus-topic)
-;; arch-tag: bf176856-f30c-40f0-ae77-e41529a1134c
;;; gnus-topic.el ends here
diff --git a/lisp/gnus/gnus-undo.el b/lisp/gnus/gnus-undo.el
index 8030c084c39..5c45d3241d3 100644
--- a/lisp/gnus/gnus-undo.el
+++ b/lisp/gnus/gnus-undo.el
@@ -45,6 +45,9 @@
;;; Code:
(eval-when-compile (require 'cl))
+(eval-when-compile
+ (when (featurep 'xemacs)
+ (require 'easy-mmode))) ; for `define-minor-mode'
(require 'gnus-util)
(require 'gnus)
@@ -59,6 +62,10 @@
:group 'gnus-undo)
(defcustom gnus-undo-mode nil
+ ;; FIXME: This is a buffer-local minor mode which requires running
+ ;; code upon activation/deactivation, so defining it as a defcustom
+ ;; doesn't seem very useful: setting it to non-nil via Customize
+ ;; probably won't do the right thing.
"Minor mode for undoing in Gnus buffers."
:type 'boolean
:group 'gnus-undo)
@@ -77,17 +84,15 @@
;;; Minor mode definition.
-(defvar gnus-undo-mode-map nil)
-
-(unless gnus-undo-mode-map
- (setq gnus-undo-mode-map (make-sparse-keymap))
-
- (gnus-define-keys gnus-undo-mode-map
- "\M-\C-_" gnus-undo
- "\C-_" gnus-undo
- "\C-xu" gnus-undo
- ;; many people are used to type `C-/' on X terminals and get `C-_'.
- [(control /)] gnus-undo))
+(defvar gnus-undo-mode-map
+ (let ((map (make-sparse-keymap)))
+ (gnus-define-keys map
+ "\M-\C-_" gnus-undo
+ "\C-_" gnus-undo
+ "\C-xu" gnus-undo
+ ;; many people are used to type `C-/' on X terminals and get `C-_'.
+ [(control /)] gnus-undo)
+ map))
(defun gnus-undo-make-menu-bar ()
;; This is disabled for the time being.
@@ -96,24 +101,19 @@
(cons "Undo" 'gnus-undo-actions)
[menu-bar file whatever])))
-(defun gnus-undo-mode (&optional arg)
+(define-minor-mode gnus-undo-mode
"Minor mode for providing `undo' in Gnus buffers.
\\{gnus-undo-mode-map}"
- (interactive "P")
- (set (make-local-variable 'gnus-undo-mode)
- (if (null arg) (not gnus-undo-mode)
- (> (prefix-numeric-value arg) 0)))
+ :keymap gnus-undo-mode-map
(set (make-local-variable 'gnus-undo-actions) nil)
(set (make-local-variable 'gnus-undo-boundary) t)
(when gnus-undo-mode
;; Set up the menu.
(when (gnus-visual-p 'undo-menu 'menu)
(gnus-undo-make-menu-bar))
- (add-minor-mode 'gnus-undo-mode "" gnus-undo-mode-map)
(gnus-make-local-hook 'post-command-hook)
- (add-hook 'post-command-hook 'gnus-undo-boundary nil t)
- (gnus-run-hooks 'gnus-undo-mode-hook)))
+ (add-hook 'post-command-hook 'gnus-undo-boundary nil t)))
;;; Interface functions.
@@ -188,5 +188,4 @@ A numeric argument serves as a repeat count."
(provide 'gnus-undo)
-;; arch-tag: 0d787bc7-787d-499a-837f-211d2cb07f2e
;;; gnus-undo.el ends here
diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el
index d101047280c..9deedbeb010 100644
--- a/lisp/gnus/gnus-util.el
+++ b/lisp/gnus/gnus-util.el
@@ -33,16 +33,41 @@
;;; Code:
-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
(eval-when-compile
(require 'cl))
-(eval-when-compile
- (unless (fboundp 'with-no-warnings)
- (defmacro with-no-warnings (&rest body)
- `(progn ,@body))))
+(defcustom gnus-completing-read-function 'gnus-emacs-completing-read
+ "Function use to do completing read."
+ :version "24.1"
+ :group 'gnus-meta
+ :type `(radio (function-item
+ :doc "Use Emacs standard `completing-read' function."
+ gnus-emacs-completing-read)
+ ;; iswitchb.el is very old and ido.el is unavailable
+ ;; in XEmacs, so we exclude those function items.
+ ,@(unless (featurep 'xemacs)
+ '((function-item
+ :doc "Use `ido-completing-read' function."
+ gnus-ido-completing-read)
+ (function-item
+ :doc "Use iswitchb based completing-read function."
+ gnus-iswitchb-completing-read)))))
+
+(defcustom gnus-completion-styles
+ (if (and (boundp 'completion-styles-alist)
+ (boundp 'completion-styles))
+ (append (when (and (assq 'substring completion-styles-alist)
+ (not (memq 'substring completion-styles)))
+ (list 'substring))
+ completion-styles)
+ nil)
+ "Value of `completion-styles' to use when completing."
+ :version "24.1"
+ :group 'gnus-meta
+ :type 'list)
;; Fixme: this should be a gnus variable, not nnmail-.
(defvar nnmail-pathname-coding-system)
@@ -53,10 +78,6 @@
(defvar gnus-original-article-buffer)
(defvar gnus-user-agent)
-(require 'time-date)
-(require 'netrc)
-
-(autoload 'message-fetch-field "message")
(autoload 'gnus-get-buffer-window "gnus-win")
(autoload 'nnheader-narrow-to-headers "nnheader")
(autoload 'nnheader-replace-chars-in-string "nnheader")
@@ -126,11 +147,9 @@ This is a compatibility function for different Emacsen."
;; XEmacs. In Emacs we don't need to call `make-local-hook' first.
;; It's harmless, though, so the main purpose of this alias is to shut
;; up the byte compiler.
-(defalias 'gnus-make-local-hook
- (if (eq (get 'make-local-hook 'byte-compile)
- 'byte-compile-obsolete)
- 'ignore ; Emacs
- 'make-local-hook)) ; XEmacs
+(defalias 'gnus-make-local-hook (if (featurep 'xemacs)
+ 'make-local-hook
+ 'ignore))
(defun gnus-delete-first (elt list)
"Delete by side effect the first occurrence of ELT as a member of LIST."
@@ -206,8 +225,11 @@ Uses `gnus-extract-address-components'."
Uses `gnus-extract-address-components'."
(nth 1 (gnus-extract-address-components from)))
+(declare-function message-fetch-field "message" (header &optional not-all))
+
(defun gnus-fetch-field (field)
"Return the value of the header FIELD of current article."
+ (require 'message)
(save-excursion
(save-restriction
(let ((inhibit-point-motion-hooks t))
@@ -228,13 +250,14 @@ Uses `gnus-extract-address-components'."
(point)))))
(declare-function gnus-find-method-for-group "gnus" (group &optional info))
-(autoload 'gnus-group-name-decode "gnus-group")
+(declare-function gnus-group-name-decode "gnus-group" (string charset))
(declare-function gnus-group-name-charset "gnus-group" (method group))
;; gnus-group requires gnus-int which requires message.
(declare-function message-tokenize-header "message"
(header &optional separator))
(defun gnus-decode-newsgroups (newsgroups group &optional method)
+ (require 'gnus-group)
(let ((method (or method (gnus-find-method-for-group group))))
(mapconcat (lambda (group)
(gnus-group-name-decode group (gnus-group-name-charset
@@ -254,6 +277,24 @@ Uses `gnus-extract-address-components'."
(setq start (when end
(next-single-property-change start prop))))))
+(defun gnus-find-text-property-region (start end prop)
+ "Return a list of text property regions that has property PROP."
+ (let (regions value)
+ (unless (get-text-property start prop)
+ (setq start (next-single-property-change start prop)))
+ (while start
+ (setq value (get-text-property start prop)
+ end (text-property-not-all start (point-max) prop value))
+ (if (not end)
+ (setq start nil)
+ (when value
+ (push (list (set-marker (make-marker) start)
+ (set-marker (make-marker) end)
+ value)
+ regions))
+ (setq start (next-single-property-change start prop))))
+ (nreverse regions)))
+
(defun gnus-newsgroup-directory-form (newsgroup)
"Make hierarchical directory name from NEWSGROUP name."
(let* ((newsgroup (gnus-newsgroup-savable-name newsgroup))
@@ -292,13 +333,14 @@ Symbols are also allowed; their print names are used instead."
(> (nth 1 fdate) (nth 1 date))))))
(eval-and-compile
- (if (and (fboundp 'float-time)
- (subrp (symbol-function 'float-time)))
+ (if (or (featurep 'emacs)
+ (and (fboundp 'float-time)
+ (subrp (symbol-function 'float-time))))
(defalias 'gnus-float-time 'float-time)
(defun gnus-float-time (&optional time)
"Convert time value TIME to a floating point number.
TIME defaults to the current time."
- (with-no-warnings (time-to-seconds (or time (current-time)))))))
+ (time-to-seconds (or time (current-time))))))
;;; Keymap macros.
@@ -344,16 +386,6 @@ TIME defaults to the current time."
(define-key keymap key (pop plist))
(pop plist)))))
-(defun gnus-completing-read-with-default (default prompt &rest args)
- ;; Like `completing-read', except that DEFAULT is the default argument.
- (let* ((prompt (if default
- (concat prompt " (default " default "): ")
- (concat prompt ": ")))
- (answer (apply 'completing-read prompt args)))
- (if (or (null answer) (zerop (length answer)))
- default
- answer)))
-
;; Two silly functions to ensure that all `y-or-n-p' questions clear
;; the echo area.
;;
@@ -429,6 +461,20 @@ TIME defaults to the current time."
(+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600)
(* (- (string-to-number days) 1) 3600 24))))
+(defmacro gnus-date-get-time (date)
+ "Convert DATE string to Emacs time.
+Cache the result as a text property stored in DATE."
+ ;; Either return the cached value...
+ `(let ((d ,date))
+ (if (equal "" d)
+ '(0 0)
+ (or (get-text-property 0 'gnus-time d)
+ ;; or compute the value...
+ (let ((time (safe-date-to-time d)))
+ ;; and store it back in the string.
+ (put-text-property 0 1 'gnus-time time d)
+ time)))))
+
(defvar gnus-user-date-format-alist
'(((gnus-seconds-today) . "%k:%M")
(604800 . "%a %k:%M") ;;that's one week
@@ -455,10 +501,10 @@ respectively.")
(defun gnus-user-date (messy-date)
"Format the messy-date according to gnus-user-date-format-alist.
-Returns \" ? \" if there's bad input or if an other error occurs.
+Returns \" ? \" if there's bad input or if another error occurs.
Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"."
(condition-case ()
- (let* ((messy-date (gnus-float-time (safe-date-to-time messy-date)))
+ (let* ((messy-date (gnus-float-time (gnus-date-get-time messy-date)))
(now (gnus-float-time))
;;If we don't find something suitable we'll use this one
(my-format "%b %d '%y"))
@@ -477,23 +523,9 @@ Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"."
(defun gnus-dd-mmm (messy-date)
"Return a string like DD-MMM from a big messy string."
(condition-case ()
- (format-time-string "%d-%b" (safe-date-to-time messy-date))
+ (format-time-string "%d-%b" (gnus-date-get-time messy-date))
(error " - ")))
-(defmacro gnus-date-get-time (date)
- "Convert DATE string to Emacs time.
-Cache the result as a text property stored in DATE."
- ;; Either return the cached value...
- `(let ((d ,date))
- (if (equal "" d)
- '(0 0)
- (or (get-text-property 0 'gnus-time d)
- ;; or compute the value...
- (let ((time (safe-date-to-time d)))
- ;; and store it back in the string.
- (put-text-property 0 1 'gnus-time time d)
- time)))))
-
(defsubst gnus-time-iso8601 (time)
"Return a string of TIME in YYYYMMDDTHHMMSS format."
(format-time-string "%Y%m%dT%H%M%S" time))
@@ -601,6 +633,8 @@ but also to the ones displayed in the echo area."
(t
(apply 'message ,format-string ,args))))))))
+(defvar gnus-action-message-log nil)
+
(defun gnus-message-with-timestamp (format-string &rest args)
"Display message with timestamp. Arguments are the same as `message'.
The `gnus-add-timestamp-to-message' variable controls how to add
@@ -615,14 +649,26 @@ Guideline for numbers:
that take a long time, 7 - not very important messages on stuff, 9 - messages
inside loops."
(if (<= level gnus-verbose)
- (if gnus-add-timestamp-to-message
- (apply 'gnus-message-with-timestamp args)
- (apply 'message args))
+ (let ((message
+ (if gnus-add-timestamp-to-message
+ (apply 'gnus-message-with-timestamp args)
+ (apply 'message args))))
+ (when (and (consp gnus-action-message-log)
+ (<= level 3))
+ (push message gnus-action-message-log))
+ message)
;; We have to do this format thingy here even if the result isn't
;; shown - the return value has to be the same as the return value
;; from `message'.
(apply 'format args)))
+(defun gnus-final-warning ()
+ (when (and (consp gnus-action-message-log)
+ (setq gnus-action-message-log
+ (delete nil gnus-action-message-log)))
+ (message "Warning: %s"
+ (mapconcat #'identity gnus-action-message-log "; "))))
+
(defun gnus-error (level &rest args)
"Beep an error if LEVEL is equal to or less than `gnus-verbose'.
ARGS are passed to `message'."
@@ -1070,23 +1116,15 @@ with potentially long computations."
;;; Functions for saving to babyl/mail files.
(eval-when-compile
- (condition-case nil
- (progn
- (require 'rmail)
- (autoload 'rmail-update-summary "rmailsum"))
- (error
- (define-compiler-macro rmail-select-summary (&rest body)
- ;; Rmail of the XEmacs version is supplied by the package, and
- ;; requires tm and apel packages. However, there may be those
- ;; who haven't installed those packages. This macro helps such
- ;; people even if they install those packages later.
- `(eval '(rmail-select-summary ,@body)))
- ;; If there's rmail but there's no tm (or there's apel of the
- ;; mainstream, not the XEmacs version), loading rmail of the XEmacs
- ;; version fails halfway, however it provides the rmail-select-summary
- ;; macro which uses the following functions:
- (autoload 'rmail-summary-displayed "rmail")
- (autoload 'rmail-maybe-display-summary "rmail"))))
+ (if (featurep 'xemacs)
+ ;; Don't load tm and apel XEmacs packages that provide some
+ ;; Emacs emulating functions and variables.
+ (let ((features features))
+ (provide 'tm-view)
+ (unless (fboundp 'set-alist) (defalias 'set-alist 'ignore))
+ (require 'rmail)) ;; It requires tm-view that loads apel.
+ (require 'rmail))
+ (autoload 'rmail-update-summary "rmailsum"))
(defvar mm-text-coding-system)
@@ -1123,8 +1161,7 @@ FILENAME exists and is Babyl format."
(gnus-yes-or-no-p
(concat "\"" filename "\" does not exist, create it? ")))
(let ((file-buffer (create-file-buffer filename)))
- (save-excursion
- (set-buffer file-buffer)
+ (with-current-buffer file-buffer
(if (fboundp 'rmail-insert-rmail-file-header)
(rmail-insert-rmail-file-header))
(let ((require-final-newline nil)
@@ -1202,8 +1239,7 @@ FILENAME exists and is Babyl format."
(gnus-y-or-n-p
(concat "\"" filename "\" does not exist, create it? ")))
(let ((file-buffer (create-file-buffer filename)))
- (save-excursion
- (set-buffer file-buffer)
+ (with-current-buffer file-buffer
(let ((require-final-newline nil)
(coding-system-for-write mm-text-coding-system))
(gnus-write-buffer filename)))
@@ -1268,6 +1304,11 @@ ARG is passed to the first function."
(save-current-buffer
(apply 'run-hooks funcs)))
+(defun gnus-run-hook-with-args (hook &rest args)
+ "Does the same as `run-hook-with-args', but saves the current buffer."
+ (save-current-buffer
+ (apply 'run-hook-with-args hook args)))
+
(defun gnus-run-mode-hooks (&rest funcs)
"Run `run-mode-hooks' if it is available, otherwise `run-hooks'.
This function saves the current buffer."
@@ -1282,17 +1323,43 @@ This function saves the current buffer."
"Say whether Gnus is running or not."
(and (boundp 'gnus-group-buffer)
(get-buffer gnus-group-buffer)
- (save-excursion
- (set-buffer gnus-group-buffer)
+ (with-current-buffer gnus-group-buffer
(eq major-mode 'gnus-group-mode))))
-(defun gnus-remove-if (predicate list)
- "Return a copy of LIST with all items satisfying PREDICATE removed."
+(defun gnus-remove-if (predicate sequence &optional hash-table-p)
+ "Return a copy of SEQUENCE with all items satisfying PREDICATE removed.
+SEQUENCE should be a list, a vector, or a string. Returns always a list.
+If HASH-TABLE-P is non-nil, regards SEQUENCE as a hash table."
(let (out)
- (while list
- (unless (funcall predicate (car list))
- (push (car list) out))
- (setq list (cdr list)))
+ (if hash-table-p
+ (mapatoms (lambda (symbol)
+ (unless (funcall predicate symbol)
+ (push symbol out)))
+ sequence)
+ (unless (listp sequence)
+ (setq sequence (append sequence nil)))
+ (while sequence
+ (unless (funcall predicate (car sequence))
+ (push (car sequence) out))
+ (setq sequence (cdr sequence))))
+ (nreverse out)))
+
+(defun gnus-remove-if-not (predicate sequence &optional hash-table-p)
+ "Return a copy of SEQUENCE with all items not satisfying PREDICATE removed.
+SEQUENCE should be a list, a vector, or a string. Returns always a list.
+If HASH-TABLE-P is non-nil, regards SEQUENCE as a hash table."
+ (let (out)
+ (if hash-table-p
+ (mapatoms (lambda (symbol)
+ (when (funcall predicate symbol)
+ (push symbol out)))
+ sequence)
+ (unless (listp sequence)
+ (setq sequence (append sequence nil)))
+ (while sequence
+ (when (funcall predicate (car sequence))
+ (push (car sequence) out))
+ (setq sequence (cdr sequence))))
(nreverse out)))
(if (fboundp 'assq-delete-all)
@@ -1305,7 +1372,15 @@ Return the modified alist."
(setq alist (delq entry alist)))
alist)))
-(defmacro gnus-pull (key alist &optional assoc-p)
+(defun gnus-grep-in-list (word list)
+ "Find if a WORD matches any regular expression in the given LIST."
+ (when (and word list)
+ (catch 'found
+ (dolist (r list)
+ (when (string-match r word)
+ (throw 'found r))))))
+
+(defmacro gnus-alist-pull (key alist &optional assoc-p)
"Modify ALIST to be without KEY."
(unless (symbolp alist)
(error "Not a symbol: %s" alist))
@@ -1563,28 +1638,65 @@ SPEC is a predicate specifier that contains stuff like `or', `and',
`(,(car spec) ,@(mapcar 'gnus-make-predicate-1 (cdr spec)))
(error "Invalid predicate specifier: %s" spec)))))
-(defun gnus-completing-read (prompt table &optional predicate require-match
- history)
- (when (and history
- (not (boundp history)))
- (set history nil))
- (completing-read
- (if (symbol-value history)
- (concat prompt " (" (car (symbol-value history)) "): ")
- (concat prompt ": "))
- table
- predicate
- require-match
- nil
- history
- (car (symbol-value history))))
+(defun gnus-completing-read (prompt collection &optional require-match
+ initial-input history def)
+ "Call `gnus-completing-read-function'."
+ (funcall gnus-completing-read-function
+ (concat prompt (when def
+ (concat " (default " def ")"))
+ ": ")
+ collection require-match initial-input history def))
+
+(defun gnus-emacs-completing-read (prompt collection &optional require-match
+ initial-input history def)
+ "Call standard `completing-read-function'."
+ (let ((completion-styles gnus-completion-styles))
+ (completing-read prompt
+ ;; Old XEmacs (at least 21.4) expect an alist for
+ ;; collection.
+ (mapcar 'list collection)
+ nil require-match initial-input history def)))
+
+(autoload 'ido-completing-read "ido")
+(defun gnus-ido-completing-read (prompt collection &optional require-match
+ initial-input history def)
+ "Call `ido-completing-read-function'."
+ (ido-completing-read prompt collection nil require-match
+ initial-input history def))
+
+
+(declare-function iswitchb-read-buffer "iswitchb"
+ (prompt &optional default require-match start matches-set))
+(defvar iswitchb-temp-buflist)
+
+(defun gnus-iswitchb-completing-read (prompt collection &optional require-match
+ initial-input history def)
+ "`iswitchb' based completing-read function."
+ ;; Make sure iswitchb is loaded before we let-bind its variables.
+ ;; If it is loaded inside the let, variables can become unbound afterwards.
+ (require 'iswitchb)
+ (let ((iswitchb-make-buflist-hook
+ (lambda ()
+ (setq iswitchb-temp-buflist
+ (let ((choices (append
+ (when initial-input (list initial-input))
+ (symbol-value history) collection))
+ filtered-choices)
+ (dolist (x choices)
+ (setq filtered-choices (adjoin x filtered-choices)))
+ (nreverse filtered-choices))))))
+ (unwind-protect
+ (progn
+ (or iswitchb-mode
+ (add-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup))
+ (iswitchb-read-buffer prompt def require-match))
+ (or iswitchb-mode
+ (remove-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup)))))
(defun gnus-graphic-display-p ()
- (or (and (fboundp 'display-graphic-p)
- (display-graphic-p))
- ;;;!!!This is bogus. Fixme!
- (and (featurep 'xemacs)
- t)))
+ (if (featurep 'xemacs)
+ (device-on-window-system-p)
+ (display-graphic-p)))
(put 'gnus-parse-without-error 'lisp-indent-function 0)
(put 'gnus-parse-without-error 'edebug-form-spec '(body))
@@ -1666,30 +1778,16 @@ CHOICE is a list of the choice char and help message at IDX."
(kill-buffer buf))
tchar))
-(declare-function x-focus-frame "xfns.c" (frame))
-(declare-function w32-focus-frame "../term/w32-win" (frame))
-
-(defun gnus-select-frame-set-input-focus (frame)
- "Select FRAME, raise it, and set input focus, if possible."
- (cond ((featurep 'xemacs)
- (if (fboundp 'select-frame-set-input-focus)
- (select-frame-set-input-focus frame)
- (raise-frame frame)
- (select-frame frame)
- (focus-frame frame)))
- ;; `select-frame-set-input-focus' defined in Emacs 21 will not
- ;; set the input focus.
- ((>= emacs-major-version 22)
- (select-frame-set-input-focus frame))
- (t
- (raise-frame frame)
- (select-frame frame)
- (cond ((memq window-system '(x ns mac))
- (x-focus-frame frame))
- ((eq window-system 'w32)
- (w32-focus-frame frame)))
- (when focus-follows-mouse
- (set-mouse-position frame (1- (frame-width frame)) 0)))))
+(if (featurep 'emacs)
+ (defalias 'gnus-select-frame-set-input-focus 'select-frame-set-input-focus)
+ (if (fboundp 'select-frame-set-input-focus)
+ (defalias 'gnus-select-frame-set-input-focus 'select-frame-set-input-focus)
+ ;; XEmacs 21.4, SXEmacs
+ (defun gnus-select-frame-set-input-focus (frame)
+ "Select FRAME, raise it, and set input focus, if possible."
+ (raise-frame frame)
+ (select-frame frame)
+ (focus-frame frame))))
(defun gnus-frame-or-window-display-name (object)
"Given a frame or window, return the associated display name.
@@ -1854,25 +1952,6 @@ empty directories from OLD-PATH."
(defalias 'gnus-set-process-query-on-exit-flag
'process-kill-without-query))
-(if (fboundp 'with-local-quit)
- (defalias 'gnus-with-local-quit 'with-local-quit)
- (defmacro gnus-with-local-quit (&rest body)
- "Execute BODY, allowing quits to terminate BODY but not escape further.
-When a quit terminates BODY, `gnus-with-local-quit' returns nil but
-requests another quit. That quit will be processed as soon as quitting
-is allowed once again. (Immediately, if `inhibit-quit' is nil.)"
- ;;(declare (debug t) (indent 0))
- `(condition-case nil
- (let ((inhibit-quit nil))
- ,@body)
- (quit (setq quit-flag t)
- ;; This call is to give a chance to handle quit-flag
- ;; in case inhibit-quit is nil.
- ;; Without this, it will not be handled until the next function
- ;; call, and that might allow it to exit thru a condition-case
- ;; that intends to handle the quit signal next time.
- (eval '(ignore nil))))))
-
(defalias 'gnus-read-shell-command
(if (fboundp 'read-shell-command) 'read-shell-command 'read-string))
@@ -1897,7 +1976,64 @@ is allowed once again. (Immediately, if `inhibit-quit' is nil.)"
(get-char-table ,character ,display-table)))
`(aref ,display-table ,character)))
+(defun gnus-rescale-image (image size)
+ "Rescale IMAGE to SIZE if possible.
+SIZE is in format (WIDTH . HEIGHT). Return a new image.
+Sizes are in pixels."
+ (if (or (not (fboundp 'imagemagick-types))
+ (not (get-buffer-window (current-buffer))))
+ image
+ (let ((new-width (car size))
+ (new-height (cdr size)))
+ (when (> (cdr (image-size image t)) new-height)
+ (setq image (or (create-image (plist-get (cdr image) :data) 'imagemagick t
+ :height new-height)
+ image)))
+ (when (> (car (image-size image t)) new-width)
+ (setq image (or
+ (create-image (plist-get (cdr image) :data) 'imagemagick t
+ :width new-width)
+ image)))
+ image)))
+
+(defun gnus-list-memq-of-list (elements list)
+ "Return non-nil if any of the members of ELEMENTS are in LIST."
+ (let ((found nil))
+ (dolist (elem elements)
+ (setq found (or found
+ (memq elem list))))
+ found))
+
+(eval-and-compile
+ (cond
+ ((fboundp 'match-substitute-replacement)
+ (defalias 'gnus-match-substitute-replacement 'match-substitute-replacement))
+ (t
+ (defun gnus-match-substitute-replacement (replacement &optional fixedcase literal string subexp)
+ "Return REPLACEMENT as it will be inserted by `replace-match'.
+In other words, all back-references in the form `\\&' and `\\N'
+are substituted with actual strings matched by the last search.
+Optional FIXEDCASE, LITERAL, STRING and SUBEXP have the same
+meaning as for `replace-match'.
+
+This is the definition of match-substitute-replacement in subr.el from GNU Emacs."
+ (let ((match (match-string 0 string)))
+ (save-match-data
+ (set-match-data (mapcar (lambda (x)
+ (if (numberp x)
+ (- x (match-beginning 0))
+ x))
+ (match-data t)))
+ (replace-match replacement fixedcase literal match subexp)))))))
+
+(if (fboundp 'string-match-p)
+ (defalias 'gnus-string-match-p 'string-match-p)
+ (defsubst gnus-string-match-p (regexp string &optional start)
+ "\
+Same as `string-match' except this function does not change the match data."
+ (save-match-data
+ (string-match regexp string start))))
+
(provide 'gnus-util)
-;; arch-tag: f94991af-d32b-4c97-8c26-ca12a934de49
;;; gnus-util.el ends here
diff --git a/lisp/gnus/gnus-uu.el b/lisp/gnus/gnus-uu.el
index 3cce1e6973a..d4f382a0c29 100644
--- a/lisp/gnus/gnus-uu.el
+++ b/lisp/gnus/gnus-uu.el
@@ -335,7 +335,6 @@ didn't work, and overwrite existing files. Otherwise, ask each time."
(defvar gnus-uu-shar-begin-string "^#! */bin/sh")
-(defvar gnus-uu-shar-file-name nil)
(defvar gnus-uu-shar-name-marker
"begin 0?[0-7][0-7][0-7][ \t]+\\(\\(\\w\\|[.\\:]\\)*\\b\\)")
@@ -827,8 +826,7 @@ When called interactively, prompt for REGEXP."
(defun gnus-uu-save-article (buffer in-state)
(cond
(gnus-uu-save-separate-articles
- (save-excursion
- (set-buffer buffer)
+ (with-current-buffer buffer
(let ((coding-system-for-write mm-text-coding-system))
(gnus-write-buffer
(concat gnus-uu-saved-article-name gnus-current-article)))
@@ -838,8 +836,7 @@ When called interactively, prompt for REGEXP."
((eq in-state 'last) (list 'end))
(t (list 'middle)))))
((not gnus-uu-save-in-digest)
- (save-excursion
- (set-buffer buffer)
+ (with-current-buffer buffer
(write-region (point-min) (point-max) gnus-uu-saved-article-name t)
(cond ((eq in-state 'first) (list gnus-uu-saved-article-name 'begin))
((eq in-state 'first-and-last) (list gnus-uu-saved-article-name
@@ -857,11 +854,9 @@ When called interactively, prompt for REGEXP."
(eq in-state 'first-and-last))
(progn
(setq state (list 'begin))
- (save-excursion
- (set-buffer (gnus-get-buffer-create "*gnus-uu-body*"))
+ (with-current-buffer (gnus-get-buffer-create "*gnus-uu-body*")
(erase-buffer))
- (save-excursion
- (set-buffer (gnus-get-buffer-create "*gnus-uu-pre*"))
+ (with-current-buffer (gnus-get-buffer-create "*gnus-uu-pre*")
(erase-buffer)
(insert (format
"Date: %s\nFrom: %s\nSubject: %s Digest\n\n"
@@ -873,8 +868,7 @@ When called interactively, prompt for REGEXP."
(insert "Topics:\n")))
(when (not (eq in-state 'end))
(setq state (list 'middle))))
- (save-excursion
- (set-buffer "*gnus-uu-body*")
+ (with-current-buffer "*gnus-uu-body*"
(goto-char (setq beg (point-max)))
(save-excursion
(save-restriction
@@ -940,8 +934,7 @@ When called interactively, prompt for REGEXP."
(when (re-search-forward "^Subject: \\(.*\\)$" nil t)
(setq subj (buffer-substring (match-beginning 1) (match-end 1))))
(when subj
- (save-excursion
- (set-buffer "*gnus-uu-pre*")
+ (with-current-buffer "*gnus-uu-pre*"
(insert (format " %s\n" subj)))))
(when (or (eq in-state 'last)
(eq in-state 'first-and-last))
@@ -951,8 +944,7 @@ When called interactively, prompt for REGEXP."
(insert-buffer-substring "*gnus-uu-pre*")
(goto-char (point-max))
(insert-buffer-substring "*gnus-uu-body*"))
- (save-excursion
- (set-buffer "*gnus-uu-pre*")
+ (with-current-buffer "*gnus-uu-pre*"
(insert (format "\n\n%s\n\n" (make-string 70 ?-)))
(if gnus-uu-digest-buffer
(with-current-buffer gnus-uu-digest-buffer
@@ -960,8 +952,7 @@ When called interactively, prompt for REGEXP."
(insert-buffer-substring "*gnus-uu-pre*"))
(let ((coding-system-for-write mm-text-coding-system))
(gnus-write-buffer gnus-uu-saved-article-name))))
- (save-excursion
- (set-buffer "*gnus-uu-body*")
+ (with-current-buffer "*gnus-uu-body*"
(goto-char (point-max))
(insert
(concat (setq end-string (format "End of %s Digest" name))
@@ -993,8 +984,7 @@ When called interactively, prompt for REGEXP."
(defun gnus-uu-binhex-article (buffer in-state)
(let (state start-char)
- (save-excursion
- (set-buffer buffer)
+ (with-current-buffer buffer
(widen)
(goto-char (point-min))
(when (not (re-search-forward gnus-uu-binhex-begin-line nil t))
@@ -1030,8 +1020,7 @@ When called interactively, prompt for REGEXP."
;; yEnc
(defun gnus-uu-yenc-article (buffer in-state)
- (save-excursion
- (set-buffer gnus-original-article-buffer)
+ (with-current-buffer gnus-original-article-buffer
(widen)
(let ((file-name (yenc-extract-filename))
state start-char)
@@ -1065,8 +1054,7 @@ When called interactively, prompt for REGEXP."
(defun gnus-uu-decode-postscript-article (process-buffer in-state)
(let ((state (list 'ok))
start-char end-char file-name)
- (save-excursion
- (set-buffer process-buffer)
+ (with-current-buffer process-buffer
(goto-char (point-min))
(if (not (re-search-forward gnus-uu-postscript-begin-string nil t))
(setq state (list 'wrong-type))
@@ -1128,8 +1116,7 @@ When called interactively, prompt for REGEXP."
;; replaces the last thing that looks like "2/3" with "[0-9]+/3"
;; or, if it can't find something like that, tries "2 of 3", then
;; finally just replaces the next to last number with "[0-9]+".
- (save-excursion
- (set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name))
+ (with-current-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name)
(buffer-disable-undo)
(erase-buffer)
(insert (regexp-quote string))
@@ -1228,8 +1215,7 @@ When called interactively, prompt for REGEXP."
;; decoded in. Returns the list of expanded strings.
(let ((out-list string-list)
string)
- (save-excursion
- (set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name))
+ (with-current-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name)
(buffer-disable-undo)
(while string-list
(erase-buffer)
@@ -1332,11 +1318,9 @@ When called interactively, prompt for REGEXP."
(gnus-summary-display-article article)
;; Push the article to the processing function.
- (save-excursion
- (set-buffer gnus-original-article-buffer)
+ (with-current-buffer gnus-original-article-buffer
(let ((buffer-read-only nil))
- (save-excursion
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
(setq process-state
(funcall process-function
gnus-original-article-buffer state)))))
@@ -1477,8 +1461,7 @@ When called interactively, prompt for REGEXP."
(defun gnus-uu-uustrip-article (process-buffer in-state)
;; Uudecodes a file asynchronously.
- (save-excursion
- (set-buffer process-buffer)
+ (with-current-buffer process-buffer
(let ((state (list 'wrong-type))
process-connection-type case-fold-search buffer-read-only
files start-char)
@@ -1488,7 +1471,7 @@ When called interactively, prompt for REGEXP."
(when gnus-uu-kill-carriage-return
(save-excursion
(while (search-forward "\r" nil t)
- (delete-backward-char 1))))
+ (delete-char -1))))
(while (or (re-search-forward gnus-uu-begin-string nil t)
(re-search-forward gnus-uu-body-line nil t))
@@ -1600,8 +1583,7 @@ Gnus might fail to display all of it.")
(defun gnus-uu-unshar-article (process-buffer in-state)
(let ((state (list 'ok))
start-char)
- (save-excursion
- (set-buffer process-buffer)
+ (with-current-buffer process-buffer
(goto-char (point-min))
(if (not (re-search-forward gnus-uu-shar-begin-string nil t))
(setq state (list 'wrong-type))
@@ -1688,8 +1670,7 @@ Gnus might fail to display all of it.")
(setq command (format "cd %s ; %s" dir (gnus-uu-command action file-path)))
- (save-excursion
- (set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name))
+ (with-current-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name)
(erase-buffer))
(gnus-message 5 "Unpacking: %s..." (gnus-uu-command action file-path))
@@ -2039,9 +2020,8 @@ If no file has been included, the user will be asked for a file."
(setq file-name file-path))
(unwind-protect
- (if (save-excursion
- (set-buffer (setq uubuf
- (gnus-get-buffer-create uuencode-buffer-name)))
+ (if (with-current-buffer
+ (setq uubuf (gnus-get-buffer-create uuencode-buffer-name))
(erase-buffer)
(funcall gnus-uu-post-encode-method file-path file-name))
(insert-buffer-substring uubuf)
@@ -2073,8 +2053,8 @@ If no file has been included, the user will be asked for a file."
(setq beg-binary (point))
(setq end-binary (point-max))
- (save-excursion
- (set-buffer (setq uubuf (gnus-get-buffer-create encoded-buffer-name)))
+ (with-current-buffer
+ (setq uubuf (gnus-get-buffer-create encoded-buffer-name))
(erase-buffer)
(insert-buffer-substring post-buf beg-binary end-binary)
(goto-char (point-min))
@@ -2129,8 +2109,7 @@ If no file has been included, the user will be asked for a file."
(insert (format " (%d/%d)" i parts)))
(goto-char (point-max))
- (save-excursion
- (set-buffer uubuf)
+ (with-current-buffer uubuf
(goto-char beg)
(if (= i parts)
(goto-char (point-max))
@@ -2170,5 +2149,4 @@ If no file has been included, the user will be asked for a file."
(provide 'gnus-uu)
-;; arch-tag: 05312384-0a83-4720-9a58-b3160b888853
;;; gnus-uu.el ends here
diff --git a/lisp/gnus/gnus-vm.el b/lisp/gnus/gnus-vm.el
index 2684ecc8c0e..9ca7813702c 100644
--- a/lisp/gnus/gnus-vm.el
+++ b/lisp/gnus/gnus-vm.el
@@ -103,5 +103,4 @@ save those articles instead."
(provide 'gnus-vm)
-;; arch-tag: 42ca7f88-a12f-461d-be3e-cac7efb44866
;;; gnus-vm.el ends here
diff --git a/lisp/gnus/gnus-win.el b/lisp/gnus/gnus-win.el
index 93f77634b7a..809e4c339be 100644
--- a/lisp/gnus/gnus-win.el
+++ b/lisp/gnus/gnus-win.el
@@ -68,12 +68,10 @@ used to display Gnus windows."
(defvar gnus-buffer-configuration
'((group
(vertical 1.0
- (group 1.0 point)
- (if gnus-carpal '(group-carpal 4))))
+ (group 1.0 point)))
(summary
(vertical 1.0
- (summary 1.0 point)
- (if gnus-carpal '(summary-carpal 4))))
+ (summary 1.0 point)))
(article
(cond
(gnus-use-trees
@@ -84,16 +82,13 @@ used to display Gnus windows."
(t
'(vertical 1.0
(summary 0.25 point)
- (if gnus-carpal '(summary-carpal 4))
(article 1.0)))))
(server
(vertical 1.0
- (server 1.0 point)
- (if gnus-carpal '(server-carpal 2))))
+ (server 1.0 point)))
(browse
(vertical 1.0
- (browse 1.0 point)
- (if gnus-carpal '(browse-carpal 2))))
+ (browse 1.0 point)))
(message
(vertical 1.0
(message 1.0 point)))
@@ -107,6 +102,9 @@ used to display Gnus windows."
(vertical 1.0
(summary 0.25)
(faq 1.0 point)))
+ (only-article
+ (vertical 1.0
+ (article 1.0 point)))
(edit-article
(vertical 1.0
(article 1.0 point)))
@@ -142,7 +140,6 @@ used to display Gnus windows."
(pipe
(vertical 1.0
(summary 0.25 point)
- (if gnus-carpal '(summary-carpal 4))
("*Shell Command Output*" 1.0)))
(bug
(vertical 1.0
@@ -186,10 +183,6 @@ See the Gnus manual for an explanation of the syntax used.")
(edit-group . gnus-group-edit-buffer)
(edit-form . gnus-edit-form-buffer)
(edit-server . gnus-server-edit-buffer)
- (group-carpal . gnus-carpal-group-buffer)
- (summary-carpal . gnus-carpal-summary-buffer)
- (server-carpal . gnus-carpal-server-buffer)
- (browse-carpal . gnus-carpal-browse-buffer)
(edit-score . gnus-score-edit-buffer)
(message . gnus-message-buffer)
(mail . gnus-message-buffer)
@@ -590,5 +583,4 @@ should have point."
(provide 'gnus-win)
-;; arch-tag: ccd5a394-2ddf-4397-b8f8-6d80d3e46e2b
;;; gnus-win.el ends here
diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el
index b07dfc648c0..20ce72d8855 100644
--- a/lisp/gnus/gnus.el
+++ b/lisp/gnus/gnus.el
@@ -1,12 +1,13 @@
;;; gnus.el --- a newsreader for GNU Emacs
-;; Copyright (C) 1987, 1988, 1989, 1990, 1993, 1994, 1995, 1996, 1997, 1998,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1987, 1988, 1989, 1990, 1993, 1994, 1995, 1996, 1997,
+;; 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+;; 2010 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news, mail
+;; Version: 5.13
;; This file is part of GNU Emacs.
@@ -29,7 +30,7 @@
(eval '(run-hooks 'gnus-load-hook))
-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
@@ -307,14 +308,6 @@ be set in `.emacs' instead."
:group 'gnus-start
:type 'boolean)
-(defcustom gnus-play-startup-jingle nil
- "If non-nil, play the Gnus jingle at startup."
- :group 'gnus-start
- :type 'boolean)
-
-(unless (fboundp 'gnus-group-remove-excess-properties)
- (defalias 'gnus-group-remove-excess-properties 'ignore))
-
(unless (featurep 'gnus-xmas)
(defalias 'gnus-make-overlay 'make-overlay)
(defalias 'gnus-delete-overlay 'delete-overlay)
@@ -357,7 +350,6 @@ be set in `.emacs' instead."
(list str))
line)))
(defalias 'gnus-mode-line-buffer-identification 'identity))
- (defalias 'gnus-characterp 'numberp)
(defalias 'gnus-deactivate-mark 'deactivate-mark)
(defalias 'gnus-window-edges 'window-edges)
(defalias 'gnus-key-press-event-p 'numberp)
@@ -925,7 +917,8 @@ be set in `.emacs' instead."
;;; Gnus buffers
;;;
-(defvar gnus-buffers nil)
+(defvar gnus-buffers nil
+ "List of buffers handled by Gnus.")
(defun gnus-get-buffer-create (name)
"Do the same as `get-buffer-create', but store the created buffer."
@@ -957,9 +950,8 @@ be set in `.emacs' instead."
;;; Splash screen.
-(defvar gnus-group-buffer "*Group*")
-
-(autoload 'gnus-play-jingle "gnus-audio")
+(defvar gnus-group-buffer "*Group*"
+ "Name of the Gnus group buffer.")
(defface gnus-splash
'((((class color)
@@ -983,9 +975,7 @@ be set in `.emacs' instead."
(erase-buffer)
(unless gnus-inhibit-startup-message
(gnus-group-startup-message)
- (sit-for 0)
- (when gnus-play-startup-jingle
- (gnus-play-jingle))))))
+ (sit-for 0)))))
(defun gnus-indent-rigidly (start end arg)
"Indent rigidly using only spaces and no tabs."
@@ -1000,8 +990,6 @@ be set in `.emacs' instead."
(while (search-forward "\t" nil t)
(replace-match " " t t))))))
-(defvar gnus-simple-splash nil)
-
;;(format "%02x%02x%02x" 114 66 20) "724214"
(defvar gnus-logo-color-alist
@@ -1041,50 +1029,47 @@ be set in `.emacs' instead."
"Insert startup message in current buffer."
;; Insert the message.
(erase-buffer)
- (cond
- ((and
- (fboundp 'find-image)
- (display-graphic-p)
- ;; Make sure the library defining `image-load-path' is loaded
- ;; (`find-image' is autoloaded) (and discard the result). Else, we may
- ;; get "defvar ignored because image-load-path is let-bound" when calling
- ;; `find-image' below.
- (or (find-image '(nil (:type xpm :file "gnus.xpm"))) t)
- (let* ((data-directory (nnheader-find-etc-directory "images/gnus"))
- (image-load-path (cond (data-directory
- (list data-directory))
- ((boundp 'image-load-path)
- (symbol-value 'image-load-path))
- (t load-path)))
- (image (find-image
- `((:type svg :file "gnus.svg")
- (:type png :file "gnus.png")
- (:type xpm :file "gnus.xpm"
- :color-symbols
- (("thing" . ,(car gnus-logo-colors))
- ("shadow" . ,(cadr gnus-logo-colors))
- ("oort" . "#eeeeee")
- ("background" . ,(face-background 'default))))
- (:type pbm :file "gnus.pbm"
- ;; Account for the pbm's blackground.
- :background ,(face-foreground 'gnus-splash)
- :foreground ,(face-background 'default))
- (:type xbm :file "gnus.xbm"
- ;; Account for the xbm's blackground.
- :background ,(face-foreground 'gnus-splash)
- :foreground ,(face-background 'default))))))
- (when image
- (let ((size (image-size image)))
- (insert-char ?\n (max 0 (round (- (window-height)
- (or y (cdr size)) 1) 2)))
- (insert-char ?\ (max 0 (round (- (window-width)
- (or x (car size))) 2)))
- (insert-image image))
- (setq gnus-simple-splash nil)
- t))))
- (t
+ (unless (and
+ (fboundp 'find-image)
+ (display-graphic-p)
+ ;; Make sure the library defining `image-load-path' is
+ ;; loaded (`find-image' is autoloaded) (and discard the
+ ;; result). Else, we may get "defvar ignored because
+ ;; image-load-path is let-bound" when calling `find-image'
+ ;; below.
+ (or (find-image '(nil (:type xpm :file "gnus.xpm"))) t)
+ (let* ((data-directory (nnheader-find-etc-directory "images/gnus"))
+ (image-load-path (cond (data-directory
+ (list data-directory))
+ ((boundp 'image-load-path)
+ (symbol-value 'image-load-path))
+ (t load-path)))
+ (image (find-image
+ `((:type xpm :file "gnus.xpm"
+ :color-symbols
+ (("thing" . ,(car gnus-logo-colors))
+ ("shadow" . ,(cadr gnus-logo-colors))))
+ (:type svg :file "gnus.svg")
+ (:type png :file "gnus.png")
+ (:type pbm :file "gnus.pbm"
+ ;; Account for the pbm's background.
+ :background ,(face-foreground 'gnus-splash)
+ :foreground ,(face-background 'default))
+ (:type xbm :file "gnus.xbm"
+ ;; Account for the xbm's background.
+ :background ,(face-foreground 'gnus-splash)
+ :foreground ,(face-background 'default))))))
+ (when image
+ (let ((size (image-size image)))
+ (insert-char ?\n (max 0 (round (- (window-height)
+ (or y (cdr size)) 1) 2)))
+ (insert-char ?\ (max 0 (round (- (window-width)
+ (or x (car size))) 2)))
+ (insert-image image))
+ (goto-char (point-min))
+ t)))
(insert
- (format " %s
+ (format "
_ ___ _ _
_ ___ __ ___ __ _ ___
__ _ ___ __ ___
@@ -1103,8 +1088,7 @@ be set in `.emacs' instead."
_
__
-"
- ""))
+"))
;; And then hack it.
(gnus-indent-rigidly (point-min) (point-max)
(/ (max (- (window-width) (or x 46)) 0) 2))
@@ -1116,10 +1100,9 @@ be set in `.emacs' instead."
(insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))
;; Fontify some.
(put-text-property (point-min) (point-max) 'face 'gnus-splash)
- (setq gnus-simple-splash t)))
- (goto-char (point-min))
- (setq mode-line-buffer-identification (concat " " gnus-version))
- (set-buffer-modified-p t))
+ (goto-char (point-min))
+ (setq mode-line-buffer-identification (concat " " gnus-version))
+ (set-buffer-modified-p t)))
(eval-when (load)
(let ((command (format "%s" this-command)))
@@ -1275,15 +1258,6 @@ by the user.
If you want to change servers, you should use `gnus-select-method'.
See the documentation to that variable.")
-;; Don't touch this variable.
-(defvar gnus-nntp-service "nntp"
- "NNTP service name (\"nntp\" or 119).
-This is an obsolete variable, which is scarcely used. If you use an
-nntp server for your newsgroup and want to change the port number
-used to 899, you would say something along these lines:
-
- (setq gnus-select-method '(nntp \"my.nntp.server\" (nntp-port-number 899)))")
-
(defcustom gnus-nntpserver-file "/etc/nntpserver"
"A file with only the name of the nntp server in it."
:group 'gnus-files
@@ -1307,20 +1281,11 @@ Check the NNTPSERVER environment variable and the
;;;###autoload (custom-autoload 'gnus-select-method "gnus"))
(defcustom gnus-select-method
- (condition-case nil
- (nconc
- (list 'nntp (or (condition-case nil
- (gnus-getenv-nntpserver)
- (error nil))
- (when (and gnus-default-nntp-server
- (not (string= gnus-default-nntp-server "")))
- gnus-default-nntp-server)
- "news"))
- (if (or (null gnus-nntp-service)
- (equal gnus-nntp-service "nntp"))
- nil
- (list gnus-nntp-service)))
- (error nil))
+ (list 'nntp (or (gnus-getenv-nntpserver)
+ (when (and gnus-default-nntp-server
+ (not (string= gnus-default-nntp-server "")))
+ gnus-default-nntp-server)
+ "news"))
"Default method for selecting a newsgroup.
This variable should be a list, where the first element is how the
news is to be fetched, the second is the address.
@@ -1364,12 +1329,12 @@ updated if the value of this variable is nil, even if you change the
value of `gnus-message-archive-method' afterward. If you want the
saved \"archive\" method to be updated whenever you change the value of
`gnus-message-archive-method', set this variable to a non-nil value."
- :version "23.1" ;; No Gnus
+ :version "23.1"
:group 'gnus-server
:group 'gnus-message
:type 'boolean)
-(defcustom gnus-message-archive-group nil
+(defcustom gnus-message-archive-group '((format-time-string "sent.%Y-%m"))
"*Name of the group in which to save the messages you've written.
This can either be a string; a list of strings; or an alist
of regexps/functions/forms to be evaluated to return a string (or a list
@@ -1389,8 +1354,12 @@ unprefixed -- which implicitly means \"store on the archive server\".
However, you may wish to store the message on some other server. In
that case, just return a fully prefixed name of the group --
\"nnml+private:mail.misc\", for instance."
+ :version "24.1"
:group 'gnus-message
:type '(choice (const :tag "none" nil)
+ (const :tag "Weekly" ((format-time-string "sent.%Yw%U")))
+ (const :tag "Monthly" ((format-time-string "sent.%Y-%m")))
+ (const :tag "Yearly" ((format-time-string "sent.%Y")))
function
sexp
string))
@@ -1401,14 +1370,14 @@ To make Gnus query you for a server, you have to give `gnus' a
non-numeric prefix - `C-u M-x gnus', in short."
:group 'gnus-server
:type '(repeat string))
+(make-obsolete-variable 'gnus-secondary-servers 'gnus-select-method "24.1")
(defcustom gnus-nntp-server nil
- "*The name of the host running the NNTP server.
-This variable is semi-obsolete. Use the `gnus-select-method'
-variable instead."
+ "The name of the host running the NNTP server."
:group 'gnus-server
:type '(choice (const :tag "disable" nil)
string))
+(make-obsolete-variable 'gnus-nntp-server 'gnus-select-method "24.1")
(defcustom gnus-secondary-select-methods nil
"A list of secondary methods that will be used for reading news.
@@ -1422,11 +1391,6 @@ you could set this variable:
:group 'gnus-server
:type '(repeat gnus-select-method))
-(defvar gnus-backup-default-subscribed-newsgroups
- '("news.announce.newusers" "news.groups.questions" "gnu.emacs.gnus")
- "Default default new newsgroups the first time Gnus is run.
-Should be set in paths.el, and shouldn't be touched by the user.")
-
(defcustom gnus-local-domain nil
"Local domain name without a host name.
The DOMAINNAME environment variable is used instead if it is defined.
@@ -1435,6 +1399,7 @@ no need to set this variable."
:group 'gnus-message
:type '(choice (const :tag "default" nil)
string))
+(make-obsolete-variable 'gnus-local-domain nil "Emacs 24.1")
(defvar gnus-local-organization nil
"String with a description of what organization (if any) the user belongs to.
@@ -1442,7 +1407,7 @@ Obsolete variable; use `message-user-organization' instead.")
;; Customization variables
-(defcustom gnus-refer-article-method nil
+(defcustom gnus-refer-article-method 'current
"Preferred method for fetching an article by Message-ID.
If you are reading news from the local spool (with nnspool), fetching
articles by Message-ID is painfully slow. By setting this method to an
@@ -1454,6 +1419,7 @@ in the documentation of `gnus-select-method'.
It can also be a list of select methods, as well as the special symbol
`current', which means to use the current select method. If it is a
list, Gnus will try all the methods in the list until it finds a match."
+ :version "24.1"
:group 'gnus-server
:type '(choice (const :tag "default" nil)
(const current)
@@ -1468,83 +1434,6 @@ list, Gnus will try all the methods in the list until it finds a match."
(nnweb "refer" (nnweb-type google)))
gnus-select-method))))
-(defcustom gnus-group-faq-directory
- '("/ftp@mirrors.aol.com:/pub/rtfm/usenet/"
- "/ftp@sunsite.doc.ic.ac.uk:/pub/usenet/news-faqs/"
- "/ftp@src.doc.ic.ac.uk:/usenet/news-FAQS/"
- "/ftp@ftp.seas.gwu.edu:/pub/rtfm/"
- "/ftp@ftp.pasteur.fr:/pub/FAQ/"
- "/ftp@rtfm.mit.edu:/pub/usenet/"
- "/ftp@ftp.uni-paderborn.de:/pub/FAQ/"
- "/ftp@ftp.sunet.se:/pub/usenet/"
- "/ftp@nctuccca.nctu.edu.tw:/pub/Documents/rtfm/usenet-by-group/"
- "/ftp@hwarang.postech.ac.kr:/pub/usenet/"
- "/ftp@ftp.hk.super.net:/mirror/faqs/")
- "*Directory where the group FAQs are stored.
-This will most commonly be on a remote machine, and the file will be
-fetched by ange-ftp.
-
-This variable can also be a list of directories. In that case, the
-first element in the list will be used by default. The others can
-be used when being prompted for a site.
-
-Note that Gnus uses an aol machine as the default directory. If this
-feels fundamentally unclean, just think of it as a way to finally get
-something of value back from them.
-
-If the default site is too slow, try one of these:
-
- North America: mirrors.aol.com /pub/rtfm/usenet
- ftp.seas.gwu.edu /pub/rtfm
- rtfm.mit.edu /pub/usenet
- Europe: ftp.uni-paderborn.de /pub/FAQ
- src.doc.ic.ac.uk /usenet/news-FAQS
- ftp.sunet.se /pub/usenet
- ftp.pasteur.fr /pub/FAQ
- Asia: nctuccca.nctu.edu.tw /pub/Documents/rtfm/usenet-by-group/
- hwarang.postech.ac.kr /pub/usenet
- ftp.hk.super.net /mirror/faqs"
- :group 'gnus-group-various
- :type '(choice directory
- (repeat directory)))
-
-(defcustom gnus-group-charter-alist
- '(("no" . (concat "http://no.news-admin.org/charter/" name ".txt"))
- ("de" . (concat "http://purl.net/charta/" name ".html"))
- ("dk" . (concat "http://www.usenet.dk/grupper.pl?get=" name))
- ("england" . (concat "http://england.news-admin.org/charters/" name))
- ("fr" . (concat "http://www.usenet-fr.net/fur/chartes/" name ".html"))
- ("europa" . (concat "http://www.europa.usenet.eu.org/chartas/charta-en-"
- (gnus-replace-in-string name "europa\\." "") ".html"))
- ("nl" . (concat "http://www.xs4all.nl/~sister/usenet/charters/" name))
- ("aus" . (concat "http://aus.news-admin.org/groupinfo.cgi/" name))
- ("pl" . (concat "http://www.usenet.pl/opisy/" name))
- ("ch" . (concat "http://www.use-net.ch/Usenet/charter.html#" name))
- ("at" . (concat "http://www.usenet.at/chartas/" name "/charta"))
- ("uk" . (concat "http://www.usenet.org.uk/" name ".html"))
- ("dfw" . (concat "http://www.cirr.com/dfw/charters/" name ".html"))
- ("se" . (concat "http://www.usenet-se.net/Reglementen/"
- (gnus-replace-in-string name "\\." "_") ".html"))
- ("milw" . (concat "http://usenet.mil.wi.us/"
- (gnus-replace-in-string name "milw\\." "") "-charter"))
- ("ca" . (concat "http://www.sbay.org/ca/charter-" name ".html"))
- ("netins" . (concat "http://www.netins.net/usenet/charter/"
- (gnus-replace-in-string name "\\." "-") "-charter.html")))
- "*An alist of (HIERARCHY . FORM) pairs used to construct the URL of a charter.
-When FORM is evaluated `name' is bound to the name of the group."
- :version "22.1"
- :group 'gnus-group-various
- :type '(repeat (cons (string :tag "Hierarchy") (sexp :tag "Form"))))
-(put 'gnus-group-charter-alist 'risky-local-variable t)
-
-(defcustom gnus-group-fetch-control-use-browse-url nil
- "*Non-nil means that control messages are displayed using `browse-url'.
-Otherwise they are fetched with ange-ftp and displayed in an ephemeral
-group."
- :version "22.1"
- :group 'gnus-group-various
- :type 'boolean)
-
(defcustom gnus-use-cross-reference t
"*Non-nil means that cross referenced articles will be marked as read.
If nil, ignore cross references. If t, mark articles as read in
@@ -1566,13 +1455,15 @@ newsgroups."
"*The number of articles which indicates a large newsgroup.
If the number of articles in a newsgroup is greater than this value,
confirmation is required for selecting the newsgroup.
-If it is nil, no confirmation is required."
+If it is nil, no confirmation is required.
+
+Also see `gnus-large-ephemeral-newsgroup'."
:group 'gnus-group-select
:type '(choice (const :tag "No limit" nil)
integer))
(defcustom gnus-use-long-file-name (not (memq system-type '(usg-unix-v)))
- "*Non-nil means that the default name of a file to save articles in is the group name.
+ "Non-nil means that the default name of a file to save articles in is the group name.
If it's nil, the directory form of the group name is used instead.
If this variable is a list, and the list contains the element
@@ -1582,8 +1473,8 @@ saving; and if it contains the element `not-kill', long file names
will not be used for kill files.
Note that the default for this variable varies according to what system
-type you're using. On `usg-unix-v' and `xenix' this variable defaults
-to nil while on all other systems it defaults to t."
+type you're using. On `usg-unix-v' this variable defaults to nil while
+on all other systems it defaults to t."
:group 'gnus-start
:type '(radio (sexp :format "Non-nil\n"
:match (lambda (widget value)
@@ -1647,25 +1538,6 @@ articles. This is not a good idea."
(sexp :format "all"
:value t)))
-(defcustom gnus-use-nocem nil
- "*If non-nil, Gnus will read NoCeM cancel messages.
-You can also set this variable to a positive number as a group level.
-In that case, Gnus scans NoCeM messages when checking new news if this
-value is not exceeding a group level that you specify as the prefix
-argument to some commands, e.g. `gnus', `gnus-group-get-new-news', etc.
-Otherwise, Gnus does not scan NoCeM messages if you specify a group
-level to those commands."
- :group 'gnus-meta
- :type '(choice
- (const :tag "off" nil)
- (const :tag "on" t)
- (list :convert-widget
- (lambda (widget)
- (list 'integer :tag "group level"
- :value (if (boundp 'gnus-level-default-subscribed)
- gnus-level-default-subscribed
- 3))))))
-
(defcustom gnus-suppress-duplicates nil
"*If non-nil, Gnus will mark duplicate copies of the same article as read."
:group 'gnus-meta
@@ -1718,11 +1590,6 @@ slower."
(function-item mail-extract-address-components)
(function :tag "Other")))
-(defcustom gnus-carpal nil
- "*If non-nil, display clickable icons."
- :group 'gnus-meta
- :type 'boolean)
-
(defcustom gnus-shell-command-separator ";"
"String used to separate shell commands."
:group 'gnus-files
@@ -1739,19 +1606,11 @@ slower."
("nneething" none address prompt-address physical-address)
("nndoc" none address prompt-address)
("nnbabyl" mail address respool)
- ("nnkiboze" post virtual)
- ("nnsoup" post-mail address)
("nndraft" post-mail)
("nnfolder" mail respool address)
("nngateway" post-mail address prompt-address physical-address)
("nnweb" none)
- ("nngoogle" post)
- ("nnslashdot" post)
- ("nnultimate" none)
("nnrss" none)
- ("nnwfm" none)
- ("nnwarchive" none)
- ("nnlistserv" none)
("nnagent" post-mail)
("nnimap" post-mail address prompt-address physical-address)
("nnmaildir" mail respool address)
@@ -1774,7 +1633,8 @@ this variable. I think."
(const :format "%v " prompt-address)
(const :format "%v " physical-address)
(const :format "%v " virtual)
- (const respool)))))
+ (const respool))))
+ :version "24.1")
(defun gnus-redefine-select-method-widget ()
"Recomputes the select-method widget based on the value of
@@ -1810,12 +1670,11 @@ If this variable is nil, screen refresh may be quicker."
(const summary)
(const tree)))
-;; Added by Keinonen Kari <kk85613@cs.tut.fi>.
-(defcustom gnus-mode-non-string-length nil
+(defcustom gnus-mode-non-string-length 30
"*Max length of mode-line non-string contents.
If this is nil, Gnus will take space as is needed, leaving the rest
-of the mode line intact. Note that the default of nil is unlikely
-to be desirable; see the manual for further details."
+of the mode line intact."
+ :version "24.1"
:group 'gnus-various
:type '(choice (const nil)
integer))
@@ -2688,6 +2547,12 @@ a string, be sure to use a valid format, see RFC 2616."
(defvar gnus-newsgroup-name nil)
(defvar gnus-ephemeral-servers nil)
(defvar gnus-server-method-cache nil)
+(defvar gnus-extended-servers nil)
+
+;; The carpal mode has been removed, but define the variable for
+;; backwards compatability.
+(defvar gnus-carpal nil)
+(make-obsolete-variable 'gnus-carpal nil "Emacs 24.1")
(defvar gnus-agent-fetching nil
"Whether Gnus agent is in fetching mode.")
@@ -2704,9 +2569,6 @@ a string, be sure to use a valid format, see RFC 2616."
(defvar gnus-tree-buffer "*Tree*"
"Buffer where Gnus thread trees are displayed.")
-;; Dummy variable.
-(defvar gnus-use-generic-from nil)
-
;; Variable holding the user answers to all method prompts.
(defvar gnus-method-history nil)
@@ -2734,8 +2596,6 @@ a string, be sure to use a valid format, see RFC 2616."
,(nnheader-concat gnus-cache-directory "active"))))
"List of predefined (convenience) servers.")
-(defvar gnus-topic-indentation "") ;; Obsolete variable.
-
(defconst gnus-article-mark-lists
'((marked . tick) (replied . reply)
(expirable . expire) (killed . killed)
@@ -2749,6 +2609,8 @@ a string, be sure to use a valid format, see RFC 2616."
'((seen range)
(killed range)
(bookmark tuple)
+ (uid tuple)
+ (active tuple)
(score tuple)))
;; Propagate flags to server, with the following exceptions:
@@ -2890,17 +2752,12 @@ gnus-registry.el will populate this if it's loaded.")
rmail-summary-exists rmail-select-summary)
;; Only used in gnus-util, which has an autoload.
("rmailsum" rmail-update-summary)
- ("gnus-audio" :interactive t gnus-audio-play)
("gnus-xmas" gnus-xmas-splash)
- ("gnus-soup" :interactive t
- gnus-group-brew-soup gnus-brew-soup gnus-soup-add-article
- gnus-soup-send-replies gnus-soup-save-areas gnus-soup-pack-packet)
- ("nnsoup" nnsoup-pack-replies)
("score-mode" :interactive t gnus-score-mode)
("gnus-mh" gnus-summary-save-article-folder
gnus-Folder-save-name gnus-folder-save-name)
("gnus-mh" :interactive t gnus-summary-save-in-folder)
- ("gnus-demon" gnus-demon-add-nocem gnus-demon-add-scanmail
+ ("gnus-demon" gnus-demon-add-scanmail
gnus-demon-add-rescan gnus-demon-add-scan-timestamps
gnus-demon-add-disconnection gnus-demon-add-handler
gnus-demon-remove-handler)
@@ -2910,16 +2767,15 @@ gnus-registry.el will populate this if it's loaded.")
gnus-convert-image-to-gray-x-face gnus-convert-face-to-png
gnus-face-from-file)
("gnus-salt" gnus-highlight-selected-tree gnus-possibly-generate-tree
- gnus-tree-open gnus-tree-close gnus-carpal-setup-buffer)
- ("gnus-nocem" gnus-nocem-scan-groups gnus-nocem-close
- gnus-nocem-unwanted-article-p)
+ gnus-tree-open gnus-tree-close)
("gnus-srvr" gnus-enter-server-buffer gnus-server-set-info
gnus-server-server-name)
("gnus-srvr" gnus-browse-foreign-server)
("gnus-cite" :interactive t
gnus-article-highlight-citation gnus-article-hide-citation-maybe
gnus-article-hide-citation gnus-article-fill-cited-article
- gnus-article-hide-citation-in-followups)
+ gnus-article-hide-citation-in-followups
+ gnus-article-fill-cited-long-lines)
("gnus-kill" gnus-kill gnus-apply-kill-file-internal
gnus-kill-file-edit-file gnus-kill-file-raise-followups-to-author
gnus-execute gnus-expunge gnus-batch-kill gnus-batch-score)
@@ -3027,8 +2883,6 @@ gnus-registry.el will populate this if it's loaded.")
gnus-dup-enter-articles)
("gnus-range" gnus-copy-sequence)
("gnus-eform" gnus-edit-form)
- ("gnus-move" :interactive t
- gnus-group-move-group-to-server gnus-change-server)
("gnus-logic" gnus-score-advanced)
("gnus-undo" gnus-undo-mode gnus-undo-register)
("gnus-async" gnus-async-request-fetched-article gnus-async-prefetch-next
@@ -3298,12 +3152,12 @@ with a `subscribed' parameter."
(defmacro gnus-string-or (&rest strings)
"Return the first element of STRINGS that is a non-blank string.
STRINGS will be evaluated in normal `or' order."
- `(gnus-string-or-1 ',strings))
+ `(gnus-string-or-1 (list ,@strings)))
(defun gnus-string-or-1 (strings)
(let (string)
(while strings
- (setq string (eval (pop strings)))
+ (setq string (pop strings))
(if (string-match "^[ \t]*$" string)
(setq string nil)
(setq strings nil)))
@@ -3319,7 +3173,6 @@ If ARG, insert string at point."
(defun gnus-continuum-version (&optional version)
"Return VERSION as a floating point number."
- (interactive)
(unless version
(setq version gnus-version))
(when (or (string-match "^\\([^ ]+\\)? ?Gnus v?\\([0-9.]+\\)$" version)
@@ -3503,14 +3356,14 @@ that that variable is buffer-local to the summary buffers."
(defun gnus-news-group-p (group &optional article)
"Return non-nil if GROUP (and ARTICLE) come from a news server."
(cond ((gnus-member-of-valid 'post group) ;Ordinary news group
- t) ;is news of course.
+ t) ;is news of course.
((not (gnus-member-of-valid 'post-mail group)) ;Non-combined.
nil) ;must be mail then.
((vectorp article) ;Has header info.
(eq (gnus-request-type group (mail-header-id article)) 'news))
- ((null article) ;Hasn't header info
+ ((null article) ;Hasn't header info
(eq (gnus-request-type group) 'news)) ;(unknown ==> mail)
- ((< article 0) ;Virtual message
+ ((< article 0) ;Virtual message
nil) ;we don't know, guess mail.
(t ;Has positive number
(eq (gnus-request-type group article) 'news)))) ;use it.
@@ -3575,7 +3428,7 @@ that that variable is buffer-local to the summary buffers."
(nth 1 method))))
method)))
-(defsubst gnus-method-to-server (method &optional nocache)
+(defsubst gnus-method-to-server (method &optional nocache no-enter-cache)
(catch 'server-name
(setq method (or method gnus-select-method))
@@ -3601,7 +3454,9 @@ that that variable is buffer-local to the summary buffers."
(format "%s" (car method))
(format "%s:%s" (car method) (cadr method))))
(name-method (cons name method)))
- (unless (member name-method gnus-server-method-cache)
+ (when (and (not (member name-method gnus-server-method-cache))
+ (not no-enter-cache)
+ (not (assoc (car name-method) gnus-server-method-cache)))
(push name-method gnus-server-method-cache))
name)))
@@ -3643,11 +3498,13 @@ that that variable is buffer-local to the summary buffers."
(while alist
(setq method (gnus-info-method (pop alist)))
(when (and (not (stringp method))
- (equal server (gnus-method-to-server method)))
+ (equal server
+ (gnus-method-to-server method nil t)))
(setq match method
alist nil)))
match))))
- (when result
+ (when (and result
+ (not (assoc server gnus-server-method-cache)))
(push (cons server result) gnus-server-method-cache))
result)))
@@ -3688,6 +3545,44 @@ that that variable is buffer-local to the summary buffers."
gnus-valid-select-methods)))
(equal (nth 1 m1) (nth 1 m2)))))))
+(defsubst gnus-sloppily-equal-method-parameters (m1 m2)
+ ;; Check parameters for sloppy equalness.
+ (let ((p1 (copy-sequence (cddr m1)))
+ (p2 (copy-sequence (cddr m2)))
+ e1 e2)
+ (block nil
+ (while (setq e1 (pop p1))
+ (unless (setq e2 (assq (car e1) p2))
+ ;; The parameter doesn't exist in p2.
+ (return nil))
+ (setq p2 (delq e2 p2))
+ (unless (equal e1 e2)
+ (if (not (and (stringp (cadr e1))
+ (stringp (cadr e2))))
+ (return nil)
+ ;; Special-case string parameter comparison so that we
+ ;; can uniquify them.
+ (let ((s1 (cadr e1))
+ (s2 (cadr e2)))
+ (when (string-match "/$" s1)
+ (setq s1 (directory-file-name s1)))
+ (when (string-match "/$" s2)
+ (setq s2 (directory-file-name s2)))
+ (unless (equal s1 s2)
+ (return nil))))))
+ ;; If p2 now is empty, they were equal.
+ (null p2))))
+
+(defun gnus-methods-sloppily-equal (m1 m2)
+ ;; Same method.
+ (or
+ (eq m1 m2)
+ ;; Type and name are equal.
+ (and
+ (eq (car m1) (car m2))
+ (equal (cadr m1) (cadr m2))
+ (gnus-sloppily-equal-method-parameters m1 m2))))
+
(defun gnus-server-equal (m1 m2)
"Say whether two methods are equal."
(let ((m1 (cond ((null m1) gnus-select-method)
@@ -3885,12 +3780,13 @@ You should probably use `gnus-find-method-for-group' instead."
(defun gnus-expand-group-parameter (match value group)
"Use MATCH to expand VALUE in GROUP."
- (with-temp-buffer
- (insert group)
- (goto-char (point-min))
- (while (re-search-forward match nil t)
- (replace-match value))
- (buffer-string)))
+ (let ((start (string-match match group)))
+ (if start
+ (let ((matched-string (substring group start (match-end 0))))
+ ;; Build match groups
+ (string-match match matched-string)
+ (replace-match value nil nil matched-string))
+ group)))
(defun gnus-expand-group-parameters (match parameters group)
"Go through PARAMETERS and expand them according to the match data."
@@ -3934,9 +3830,7 @@ The function `gnus-group-find-parameter' will do that for you."
;; Expand if necessary.
(if (and (stringp result) (string-match "\\\\[0-9&]" result))
(setq result (gnus-expand-group-parameter (car head)
- result group)))
- ;; Exit the loop early.
- (setq tail nil))))
+ result group))))))
;; Done.
result))))
@@ -3946,8 +3840,7 @@ If SYMBOL, return the value of that symbol in the group parameters.
If you call this function inside a loop, consider using the faster
`gnus-group-fast-parameter' instead."
- (save-excursion
- (set-buffer gnus-group-buffer)
+ (with-current-buffer gnus-group-buffer
(if symbol
(gnus-group-fast-parameter group symbol allow-list)
(nconc
@@ -3995,8 +3888,11 @@ If ALLOW-LIST, also allow list as a result."
group 'params))))
(defun gnus-group-set-parameter (group name value)
- "Set parameter NAME to VALUE in GROUP."
- (let ((info (gnus-get-info group)))
+ "Set parameter NAME to VALUE in GROUP.
+GROUP can also be an INFO structure."
+ (let ((info (if (listp group)
+ group
+ (gnus-get-info group))))
(when info
(gnus-group-remove-parameter group name)
(let ((old-params (gnus-info-params info))
@@ -4006,17 +3902,22 @@ If ALLOW-LIST, also allow list as a result."
(not (eq (caar old-params) name)))
(setq new-params (append new-params (list (car old-params)))))
(setq old-params (cdr old-params)))
- (gnus-group-set-info new-params group 'params)))))
+ (if (listp group)
+ (gnus-info-set-params info new-params t)
+ (gnus-group-set-info new-params (gnus-info-group info) 'params))))))
(defun gnus-group-remove-parameter (group name)
- "Remove parameter NAME from GROUP."
- (let ((info (gnus-get-info group)))
+ "Remove parameter NAME from GROUP.
+GROUP can also be an INFO structure."
+ (let ((info (if (listp group)
+ group
+ (gnus-get-info group))))
(when info
(let ((params (gnus-info-params info)))
(when params
(setq params (delq name params))
(while (assq name params)
- (gnus-pull name params))
+ (gnus-alist-pull name params))
(gnus-info-set-params info params))))))
(defun gnus-group-add-score (group &optional score)
@@ -4106,8 +4007,7 @@ Returns the number of articles marked as read."
(defun gnus-kill-save-kill-buffer ()
(let ((file (gnus-newsgroup-kill-file gnus-newsgroup-name)))
(when (get-file-buffer file)
- (save-excursion
- (set-buffer (get-file-buffer file))
+ (with-current-buffer (get-file-buffer file)
(when (buffer-modified-p)
(save-buffer))
(kill-buffer (current-buffer))))))
@@ -4154,13 +4054,19 @@ If NEWSGROUP is nil, return the global kill file name instead."
gnus-valid-select-methods)))
(defun gnus-similar-server-opened (method)
- (let ((opened gnus-opened-servers))
+ "Return non-nil if we have a similar server opened.
+This is defined as a server with the same name, but different
+parameters."
+ (let ((opened gnus-opened-servers)
+ open)
(while (and method opened)
- (when (and (equal (cadr method) (cadaar opened))
- (equal (car method) (caaar opened))
- (not (equal method (caar opened))))
- (setq method nil))
- (pop opened))
+ (setq open (car (pop opened)))
+ ;; Type and name are the same...
+ (when (and (equal (car method) (car open))
+ (equal (cadr method) (cadr open))
+ ;; ... but the rest of the parameters differ.
+ (not (gnus-methods-sloppily-equal method open)))
+ (setq method nil)))
(not method)))
(defun gnus-server-extend-method (group method)
@@ -4171,9 +4077,12 @@ If NEWSGROUP is nil, return the global kill file name instead."
(if (or (not (inline (gnus-similar-server-opened method)))
(not (cddr method)))
method
- `(,(car method) ,(concat (cadr method) "+" group)
- (,(intern (format "%s-address" (car method))) ,(cadr method))
- ,@(cddr method))))
+ (setq method
+ `(,(car method) ,(concat (cadr method) "+" group)
+ (,(intern (format "%s-address" (car method))) ,(cadr method))
+ ,@(cddr method)))
+ (push method gnus-extended-servers)
+ method))
(defun gnus-server-status (method)
"Return the status of METHOD."
@@ -4198,6 +4107,20 @@ If NEWSGROUP is nil, return the global kill file name instead."
(format "%s using %s" address (car server))
(format "%s" (car server)))))
+(defun gnus-same-method-different-name (method)
+ (let ((slot (intern (concat (symbol-name (car method)) "-address"))))
+ (unless (assq slot (cddr method))
+ (setq method
+ (append method (list (list slot (nth 1 method)))))))
+ (let ((methods gnus-extended-servers)
+ open found)
+ (while (and (not found)
+ (setq open (pop methods)))
+ (when (and (eq (car method) (car open))
+ (gnus-sloppily-equal-method-parameters method open))
+ (setq found open)))
+ found))
+
(defun gnus-find-method-for-group (group &optional info)
"Find the select method that GROUP uses."
(or gnus-override-method
@@ -4220,7 +4143,10 @@ If NEWSGROUP is nil, return the global kill file name instead."
(cond ((stringp method)
(inline (gnus-server-to-method method)))
((stringp (cadr method))
- (inline (gnus-server-extend-method group method)))
+ (or
+ (inline
+ (gnus-same-method-different-name method))
+ (inline (gnus-server-extend-method group method))))
(t
method)))
(cond ((equal (cadr method) "")
@@ -4291,9 +4217,9 @@ Allow completion over sensible values."
gnus-predefined-server-alist
gnus-server-alist))
(method
- (completing-read
- prompt servers
- nil t nil 'gnus-method-history)))
+ (gnus-completing-read
+ prompt (mapcar 'car servers)
+ t nil 'gnus-method-history)))
(cond
((equal method "")
(setq method gnus-select-method))
@@ -4409,10 +4335,16 @@ If ARG is non-nil and a positive number, Gnus will use that as the
startup level. If ARG is non-nil and not a positive number, Gnus will
prompt the user for the name of an NNTP server to use."
(interactive "P")
+ ;; When using the development version of Gnus, load the gnus-load
+ ;; file.
+ (unless (string-match "^Gnus" gnus-version)
+ (load "gnus-load" nil t))
(unless (byte-code-function-p (symbol-function 'gnus))
(message "You should byte-compile Gnus")
(sit-for 2))
- (gnus-1 arg dont-connect slave))
+ (let ((gnus-action-message-log (list nil)))
+ (gnus-1 arg dont-connect slave)
+ (gnus-final-warning)))
;; Allow redefinition of Gnus functions.
@@ -4420,5 +4352,4 @@ prompt the user for the name of an NNTP server to use."
(provide 'gnus)
-;; arch-tag: acebeeab-f331-4f8f-a7ea-89c58c84f636
;;; gnus.el ends here
diff --git a/lisp/gnus/gravatar.el b/lisp/gnus/gravatar.el
new file mode 100644
index 00000000000..50b0ba1d636
--- /dev/null
+++ b/lisp/gnus/gravatar.el
@@ -0,0 +1,133 @@
+;;; gravatar.el --- Get Gravatars
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Julien Danjou <julien@danjou.info>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'url)
+(require 'url-cache)
+
+(defgroup gravatar nil
+ "Gravatar."
+ :group 'comm)
+
+(defcustom gravatar-automatic-caching t
+ "Whether cache retrieved gravatar."
+ :group 'gravatar)
+
+(defcustom gravatar-cache-ttl (days-to-time 30)
+ "Time to live for gravatar cache entries."
+ :group 'gravatar)
+
+(defcustom gravatar-rating "g"
+ "Default rating for gravatar."
+ :group 'gravatar)
+
+(defcustom gravatar-size 32
+ "Default size in pixels for gravatars."
+ :group 'gravatar)
+
+(defconst gravatar-base-url
+ "http://www.gravatar.com/avatar"
+ "Base URL for getting gravatars.")
+
+(defun gravatar-hash (mail-address)
+ "Create an hash from MAIL-ADDRESS."
+ (md5 (downcase mail-address)))
+
+(defun gravatar-build-url (mail-address)
+ "Return an URL to retrieve MAIL-ADDRESS gravatar."
+ (format "%s/%s?d=404&r=%s&s=%d"
+ gravatar-base-url
+ (gravatar-hash mail-address)
+ gravatar-rating
+ gravatar-size))
+
+(defun gravatar-cache-expired (url)
+ "Check if URL is cached for more than `gravatar-cache-ttl'."
+ (cond (url-standalone-mode
+ (not (file-exists-p (url-cache-create-filename url))))
+ (t (let ((cache-time (url-is-cached url)))
+ (if cache-time
+ (time-less-p
+ (time-add
+ cache-time
+ gravatar-cache-ttl)
+ (current-time))
+ t)))))
+
+(defun gravatar-get-data ()
+ "Get data from current buffer."
+ (when (string-match "^HTTP/.+ 200 OK$"
+ (buffer-substring (point-min) (line-end-position)))
+ (when (search-forward "\n\n" nil t)
+ (buffer-substring (point) (point-max)))))
+
+(eval-and-compile
+ (cond ((featurep 'xemacs)
+ (require 'gnus-xmas)
+ (defalias 'gravatar-create-image 'gnus-xmas-create-image))
+ ((featurep 'gnus-ems)
+ (defalias 'gravatar-create-image 'gnus-create-image))
+ (t
+ (require 'image)
+ (defalias 'gravatar-create-image 'create-image))))
+
+(defun gravatar-data->image ()
+ "Get data of current buffer and return an image.
+If no image available, return 'error."
+ (let ((data (gravatar-get-data)))
+ (if data
+ (gravatar-create-image data nil t)
+ 'error)))
+
+;;;###autoload
+(defun gravatar-retrieve (mail-address cb &optional cbargs)
+ "Retrieve MAIL-ADDRESS gravatar and call CB on retrieval.
+You can provide a list of argument to pass to CB in CBARGS."
+ (let ((url (gravatar-build-url mail-address)))
+ (if (gravatar-cache-expired url)
+ (url-retrieve url
+ 'gravatar-retrieved
+ (list cb (when cbargs cbargs)))
+ (apply cb
+ (with-temp-buffer
+ (mm-disable-multibyte)
+ (url-cache-extract (url-cache-create-filename url))
+ (gravatar-data->image))
+ cbargs))))
+
+(defun gravatar-retrieved (status cb &optional cbargs)
+ "Callback function used by `gravatar-retrieve'."
+ ;; Store gravatar?
+ (when gravatar-automatic-caching
+ (url-store-in-cache (current-buffer)))
+ (if (plist-get status :error)
+ ;; Error happened.
+ (apply cb 'error cbargs)
+ (apply cb (gravatar-data->image) cbargs))
+ (kill-buffer (current-buffer)))
+
+(provide 'gravatar)
+
+;;; gravatar.el ends here
diff --git a/lisp/gnus/html2text.el b/lisp/gnus/html2text.el
index 1aec654faf8..6411eb62564 100644
--- a/lisp/gnus/html2text.el
+++ b/lisp/gnus/html2text.el
@@ -508,5 +508,5 @@ See the documentation for that variable."
;; </Interactive functions>
;;
(provide 'html2text)
-;; arch-tag: e9e57b79-35d4-4de1-a647-e7e01fe56d1e
+
;;; html2text.el ends here
diff --git a/lisp/gnus/ietf-drums.el b/lisp/gnus/ietf-drums.el
index 87012405ef9..f72b09c572c 100644
--- a/lisp/gnus/ietf-drums.el
+++ b/lisp/gnus/ietf-drums.el
@@ -39,7 +39,6 @@
;;; Code:
(eval-when-compile (require 'cl))
-(require 'time-date)
(require 'mm-util)
(defvar ietf-drums-no-ws-ctl-token "\001-\010\013\014\016-\037\177"
@@ -296,5 +295,4 @@ a list of address strings."
(provide 'ietf-drums)
-;; arch-tag: 379a0191-dbae-4ca6-a0f5-d4202c209ef9
;;; ietf-drums.el ends here
diff --git a/lisp/gnus/legacy-gnus-agent.el b/lisp/gnus/legacy-gnus-agent.el
index b13033b6352..3b55220ace5 100644
--- a/lisp/gnus/legacy-gnus-agent.el
+++ b/lisp/gnus/legacy-gnus-agent.el
@@ -250,5 +250,4 @@ possible that the hook was persistently saved."
(provide 'legacy-gnus-agent)
-;; arch-tag: 845c7b8a-88f7-4468-b8d7-94e8fc72cf1a
;;; legacy-gnus-agent.el ends here
diff --git a/lisp/gnus/mail-parse.el b/lisp/gnus/mail-parse.el
index a774f829632..53094960e18 100644
--- a/lisp/gnus/mail-parse.el
+++ b/lisp/gnus/mail-parse.el
@@ -45,8 +45,7 @@
(defalias 'mail-header-parse-content-type 'rfc2231-parse-qp-string)
(defalias 'mail-header-parse-content-disposition 'rfc2231-parse-qp-string)
(defalias 'mail-content-type-get 'rfc2231-get-value)
-;(defalias 'mail-header-encode-parameter 'rfc2045-encode-string)
-(defalias 'mail-header-encode-parameter 'rfc2231-encode-string)
+(defalias 'mail-header-encode-parameter 'rfc2047-encode-parameter)
(defalias 'mail-header-remove-comments 'ietf-drums-remove-comments)
(defalias 'mail-header-remove-whitespace 'ietf-drums-remove-whitespace)
@@ -74,5 +73,4 @@
(provide 'mail-parse)
-;; arch-tag: 3e63d75c-c962-4784-ab01-7ba07ca9d2d4
;;; mail-parse.el ends here
diff --git a/lisp/gnus/mail-prsvr.el b/lisp/gnus/mail-prsvr.el
index 5e386f94e29..fb63e58a04a 100644
--- a/lisp/gnus/mail-prsvr.el
+++ b/lisp/gnus/mail-prsvr.el
@@ -41,5 +41,4 @@ what the desired charsets is to be ignored.")
(provide 'mail-prsvr)
-;; arch-tag: 9ba878cc-8b43-4f7a-85b1-69b1a9a5d9f5
;;; mail-prsvr.el ends here
diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el
index 44edd703638..137a18f27eb 100644
--- a/lisp/gnus/mail-source.el
+++ b/lisp/gnus/mail-source.el
@@ -1,7 +1,7 @@
;;; mail-source.el --- functions for fetching mail
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news, mail
@@ -25,7 +25,7 @@
;;; Code:
-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
@@ -219,34 +219,6 @@ See Info node `(gnus)Mail Source Specifiers'."
(boolean :tag "Dontexpunge"))
(group :inline t
(const :format "" :value :plugged)
- (boolean :tag "Plugged"))))
- (cons :tag "Webmail server"
- (const :format "" webmail)
- (checklist :tag "Options" :greedy t
- (group :inline t
- (const :format "" :value :subtype)
- ;; Should be generated from
- ;; `webmail-type-definition', but we
- ;; can't require webmail without W3.
- (choice :tag "Subtype"
- :value hotmail
- (const hotmail)
- (const yahoo)
- (const netaddress)
- (const netscape)
- (const my-deja)))
- (group :inline t
- (const :format "" :value :user)
- (string :tag "User"))
- (group :inline t
- (const :format "" :value :password)
- (string :tag "Password"))
- (group :inline t
- (const :format ""
- :value :dontexpunge)
- (boolean :tag "Dontexpunge"))
- (group :inline t
- (const :format "" :value :plugged)
(boolean :tag "Plugged"))))))))
(defcustom mail-source-ignore-errors nil
@@ -387,13 +359,7 @@ Common keywords should be listed here.")
(:prescript)
(:prescript-delay)
(:postscript)
- (:dontexpunge))
- (webmail
- (:subtype hotmail)
- (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
- (:password)
- (:dontexpunge)
- (:authentication password)))
+ (:dontexpunge)))
"Mapping from keywords to default values.
All keywords that can be used must be listed here."))
@@ -402,8 +368,7 @@ All keywords that can be used must be listed here."))
(directory mail-source-fetch-directory)
(pop mail-source-fetch-pop)
(maildir mail-source-fetch-maildir)
- (imap mail-source-fetch-imap)
- (webmail mail-source-fetch-webmail))
+ (imap mail-source-fetch-imap))
"A mapping from source type to fetcher function.")
(defvar mail-source-password-cache nil)
@@ -466,10 +431,10 @@ the `mail-source-keyword-map' variable."
;; 1) the auth-sources user and password override everything
;; 2) it avoids macros, so it's cleaner
;; 3) it falls through to the mail-sources and then default values
- (cond
+ (cond
((and
(eq keyword :user)
- (setq user-auth
+ (setq user-auth
(nth 0 (auth-source-user-or-password
'("login" "password")
;; this is "host" in auth-sources
@@ -536,7 +501,9 @@ See `mail-source-bind'."
(t
value)))
-(defun mail-source-fetch (source callback)
+(autoload 'nnheader-message "nnheader")
+
+(defun mail-source-fetch (source callback &optional method)
"Fetch mail from SOURCE and call CALLBACK zero or more times.
CALLBACK will be called with the name of the file where (some of)
the mail from SOURCE is put.
@@ -544,6 +511,16 @@ Return the number of files that were found."
(mail-source-bind-common source
(if (or mail-source-plugged plugged)
(save-excursion
+ ;; Special-case the `file' handler since it's so common and
+ ;; just adds noise.
+ (when (or (not (eq (car source) 'file))
+ (mail-source-bind (file source)
+ (file-exists-p path)))
+ (nnheader-message 4 "%sReading incoming mail from %s..."
+ (if method
+ (format "%s: " method)
+ "")
+ (car source)))
(let ((function (cadr (assq (car source) mail-source-fetcher-alist)))
(found 0))
(unless function
@@ -574,10 +551,13 @@ Return the number of files that were found."
(error "Cannot get new mail"))
0)))))))))
+(declare-function gnus-message "gnus-util" (level &rest args))
+
(defun mail-source-delete-old-incoming (&optional age confirm)
"Remove incoming files older than AGE days.
If CONFIRM is non-nil, ask for confirmation before removing a file."
(interactive "P")
+ (require 'gnus-util)
(let* ((high2days (/ 65536.0 60 60 24));; convert high bits to days
(low2days (/ 1.0 65536.0)) ;; convert low bits to days
(diff (if (natnump age) age 30));; fallback, if no valid AGE given
@@ -616,6 +596,10 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
0)
(funcall callback mail-source-crash-box info)))
+(autoload 'gnus-float-time "gnus-util")
+
+(defvar mail-source-incoming-last-checked-time nil)
+
(defun mail-source-delete-crash-box ()
(when (file-exists-p mail-source-crash-box)
;; Delete or move the incoming mail out of the way.
@@ -631,9 +615,16 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
(rename-file mail-source-crash-box incoming t)
;; remove old incoming files?
(when (natnump mail-source-delete-incoming)
- (mail-source-delete-old-incoming
- mail-source-delete-incoming
- mail-source-delete-old-incoming-confirm))))))
+ ;; Don't check for old incoming files more than once per day to
+ ;; save a lot of file accesses.
+ (when (or (null mail-source-incoming-last-checked-time)
+ (> (gnus-float-time
+ (time-since mail-source-incoming-last-checked-time))
+ (* 24 60 60)))
+ (setq mail-source-incoming-last-checked-time (current-time))
+ (mail-source-delete-old-incoming
+ mail-source-delete-incoming
+ mail-source-delete-old-incoming-confirm)))))))
(defun mail-source-movemail (from to)
"Move FROM to TO using movemail."
@@ -971,7 +962,7 @@ This only works when `display-time' is enabled."
(if on
(progn
(require 'time)
- ;; display-time-mail-function is an Emacs 21 feature.
+ ;; display-time-mail-function is an Emacs feature.
(setq display-time-mail-function #'mail-source-new-mail-p)
;; Set up the main timer.
(setq mail-source-report-new-mail-timer
@@ -1116,31 +1107,6 @@ This only works when `display-time' is enabled."
?s server ?P port ?u user))
found)))
-(autoload 'webmail-fetch "webmail")
-
-(defun mail-source-fetch-webmail (source callback)
- "Fetch for webmail source."
- (mail-source-bind (webmail source)
- (let ((mail-source-string (format "webmail:%s:%s" subtype user))
- (webmail-newmail-only dontexpunge)
- (webmail-move-to-trash-can (not dontexpunge)))
- (when (eq authentication 'password)
- (setq password
- (or password
- (cdr (assoc (format "webmail:%s:%s" subtype user)
- mail-source-password-cache))
- (read-passwd
- (format "Password for %s at %s: " user subtype))))
- (when (and password
- (not (assoc (format "webmail:%s:%s" subtype user)
- mail-source-password-cache)))
- (push (cons (format "webmail:%s:%s" subtype user) password)
- mail-source-password-cache)))
- (webmail-fetch mail-source-crash-box subtype user password)
- (mail-source-callback callback (symbol-name subtype))
- (mail-source-delete-crash-box))))
-
(provide 'mail-source)
-;; arch-tag: 72948025-1d17-4d6c-bb12-ef1aa2c490fd
;;; mail-source.el ends here
diff --git a/lisp/gnus/mailcap.el b/lisp/gnus/mailcap.el
index e725dfcea88..36a710d58c9 100644
--- a/lisp/gnus/mailcap.el
+++ b/lisp/gnus/mailcap.el
@@ -335,7 +335,7 @@ nil means your home directory."
:group 'mailcap)
(defvar mailcap-poor-system-types
- '(ms-dos ms-windows windows-nt win32 w32 mswindows)
+ '(ms-dos windows-nt)
"Systems that don't have a Unix-like directory hierarchy.")
;;;
@@ -423,7 +423,7 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus
"/usr/local/etc/mailcap"))))
(let ((fnames (reverse
(if (stringp path)
- (delete "" (split-string path path-separator))
+ (split-string path path-separator t)
path)))
fname)
(while fnames
@@ -812,7 +812,10 @@ If NO-DECODE is non-nil, don't decode STRING."
;;;
(defvar mailcap-mime-extensions
- '(("" . "text/plain")
+ '(("" . "text/plain")
+ (".1" . "text/plain") ;; Manual pages
+ (".3" . "text/plain")
+ (".8" . "text/plain")
(".abs" . "audio/x-mpeg")
(".aif" . "audio/aiff")
(".aifc" . "audio/aiff")
@@ -828,6 +831,7 @@ If NO-DECODE is non-nil, don't decode STRING."
(".css" . "text/css")
(".dvi" . "application/x-dvi")
(".diff" . "text/x-patch")
+ (".dpatch". "test/x-patch")
(".el" . "application/emacs-lisp")
(".eps" . "application/postscript")
(".etx" . "text/x-setext")
@@ -869,6 +873,7 @@ If NO-DECODE is non-nil, don't decode STRING."
(".pict" . "image/pict")
(".png" . "image/png")
(".pnm" . "image/x-portable-anymap")
+ (".pod" . "text/plain")
(".ppm" . "image/portable-pixmap")
(".ps" . "application/postscript")
(".qt" . "video/quicktime")
@@ -941,7 +946,7 @@ If FORCE, re-parse even if already parsed."
"/usr/local/etc/mime-types"
"/usr/local/www/conf/mime-types"))))
(let ((fnames (reverse (if (stringp path)
- (delete "" (split-string path path-separator))
+ (split-string path path-separator t)
path)))
fname)
(while fnames
@@ -1069,5 +1074,4 @@ If FORCE, re-parse even if already parsed."
(provide 'mailcap)
-;; arch-tag: 1fd4f9c9-c305-4d2e-9747-3a4d45baa0bd
;;; mailcap.el ends here
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index 214ac0b3906..1ee07a2d5ee 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -29,16 +29,18 @@
;;; Code:
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
(eval-when-compile
(require 'cl))
-(require 'hashcash)
-(require 'canlock)
(require 'mailheader)
(require 'gmm-utils)
-(require 'nnheader)
+(require 'mail-utils)
+;; Only for the trivial macros mail-header-from, mail-header-date
+;; mail-header-references, mail-header-subject, mail-header-id
+(eval-when-compile (require 'nnheader))
;; This is apparently necessary even though things are autoloaded.
;; Because we dynamically bind mail-abbrev-mode-regexp, we'd better
;; require mailabbrev here.
@@ -48,7 +50,6 @@
(require 'mail-parse)
(require 'mml)
(require 'rfc822)
-(require 'ecomplete)
(autoload 'mailclient-send-it "mailclient") ;; Emacs 22 or contrib/
@@ -160,8 +161,6 @@ If this variable is nil, no such courtesy message will be added."
:type 'regexp)
(defcustom message-from-style mail-from-style
-;; Default to the value of `mail-from-style', available in all Emacsen
-;; that Gnus supports.
"*Specifies how \"From\" headers look.
If nil, they contain just the return address like:
@@ -249,6 +248,15 @@ included. Organization and User-Agent are optional."
:link '(custom-manual "(message)Message Headers")
:type '(repeat sexp))
+(defcustom message-prune-recipient-rules nil
+ "Rules for how to prune the list of recipients when doing wide replies.
+This is a list of regexps and regexp matches."
+ :version "24.1"
+ :group 'message-mail
+ :group 'message-headers
+ :link '(custom-manual "(message)Wide Reply")
+ :type '(repeat regexp))
+
(defcustom message-deletable-headers '(Message-ID Date Lines)
"Headers to be deleted if they already exist and were generated by message previously."
:group 'message-headers
@@ -276,7 +284,7 @@ included. Organization and User-Agent are optional."
:link '(custom-manual "(message)Mail Headers")
:type 'regexp)
-(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-ID:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:\\|^Cancel-Lock:\\|^Cancel-Key:\\|^X-Hashcash:\\|^X-Payment:\\|^Approved:"
+(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-ID:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:\\|^Cancel-Lock:\\|^Cancel-Key:\\|^X-Hashcash:\\|^X-Payment:\\|^Approved:\\|^Injection-Date:\\|^Injection-Info:"
"*Header lines matching this regexp will be deleted before posting.
It's best to delete old Path and Date headers before posting to avoid
any confusion."
@@ -298,7 +306,7 @@ any confusion."
;;; Start of variables adopted from `message-utils.el'.
-(defcustom message-subject-trailing-was-query 'ask
+(defcustom message-subject-trailing-was-query t
"*What to do with trailing \"(was: <old subject>)\" in subject lines.
If nil, leave the subject unchanged. If it is the symbol `ask', query
the user what do do. In this case, the subject is matched against
@@ -306,7 +314,7 @@ the user what do do. In this case, the subject is matched against
`message-subject-trailing-was-query' is t, always strip the trailing
old subject. In this case, `message-subject-trailing-was-regexp' is
used."
- :version "22.1"
+ :version "24.1"
:type '(choice (const :tag "never" nil)
(const :tag "always strip" t)
(const ask))
@@ -314,7 +322,7 @@ used."
:group 'message-various)
(defcustom message-subject-trailing-was-ask-regexp
- "[ \t]*\\([[(]+[Ww][Aa][Ss][ \t]*.*[\])]+\\)"
+ "[ \t]*\\([[(]+[Ww][Aa][Ss]:?[ \t]*.*[])]+\\)"
"*Regexp matching \"(was: <old subject>)\" in the subject line.
The function `message-strip-subject-trailing-was' uses this regexp if
@@ -437,8 +445,6 @@ whitespace)."
:group 'message-various)
(defcustom message-interactive mail-interactive
-;; Default to the value of `mail-interactive', available in all Emacsen
-;; that Gnus supports.
"Non-nil means when sending a message wait for and display errors.
A value of nil means let mailer mail back a message to report errors."
:version "23.2"
@@ -455,7 +461,7 @@ A value of nil means let mailer mail back a message to report errors."
:link '(custom-manual "(message)Sending Variables")
:type 'boolean)
-(defcustom message-generate-new-buffers 'unique
+(defcustom message-generate-new-buffers 'unsent
"*Say whether to create a new message buffer to compose a message.
Valid values include:
@@ -478,6 +484,7 @@ function
If this is a function, call that function with three parameters:
The type, the To address and the group name (any of these may be nil).
The function should return the new buffer name."
+ :version "24.1"
:group 'message-buffers
:link '(custom-manual "(message)Message Buffers")
:type '(choice (const nil)
@@ -615,30 +622,9 @@ Done before generating the new subject of a forward."
:link '(custom-manual "(message)Insertion Variables")
:type 'regexp)
-(defcustom message-cite-prefix-regexp
- ;; Default to the value of `mail-citation-prefix-regexp' if available.
- ;; Note: as for Emacs 21, XEmacs 21.4 and 21.5, it is unavailable
- ;; unless sendmail.el is loaded.
- (cond ((boundp 'mail-citation-prefix-regexp)
- mail-citation-prefix-regexp)
- ((string-match "[[:digit:]]" "1")
- ;; Support POSIX? XEmacs 21.5.27 doesn't.
- "\\([ \t]*[_.[:word:]]+>+\\|[ \t]*[]>|}]\\)+")
- (t
- ;; ?-, ?_ or ?. MUST NOT be in syntax entry w.
- (let (non-word-constituents)
- (with-syntax-table text-mode-syntax-table
- (setq non-word-constituents
- (concat
- (if (string-match "\\w" "_") "" "_")
- (if (string-match "\\w" ".") "" "."))))
- (if (equal non-word-constituents "")
- "\\([ \t]*\\(\\w\\)+>+\\|[ \t]*[]>|}]\\)+"
- (concat "\\([ \t]*\\(\\w\\|["
- non-word-constituents
- "]\\)+>+\\|[ \t]*[]>|}]\\)+")))))
+(defcustom message-cite-prefix-regexp mail-citation-prefix-regexp
"*Regexp matching the longest possible citation prefix on a line."
- :version "23.2"
+ :version "24.1"
:group 'message-insertion
:link '(custom-manual "(message)Insertion Variables")
:type 'regexp
@@ -655,8 +641,6 @@ Done before generating the new subject of a forward."
:link '(custom-manual "(message)Canceling News")
:type 'string)
-(defvar smtpmail-default-smtp-server)
-
(defun message-send-mail-function ()
"Return suitable value for the variable `message-send-mail-function'."
(cond ((and (require 'sendmail)
@@ -665,14 +649,13 @@ Done before generating the new subject of a forward."
(executable-find sendmail-program))
'message-send-mail-with-sendmail)
((and (locate-library "smtpmail")
- (require 'smtpmail)
+ (boundp 'smtpmail-default-smtp-server)
smtpmail-default-smtp-server)
'message-smtpmail-send-it)
((locate-library "mailclient")
'message-send-mail-with-mailclient)
(t
- (lambda ()
- (error "Don't know how to send mail. Please customize `message-send-mail-function'")))))
+ (error "Don't know how to send mail. Please customize `message-send-mail-function'"))))
;; Useful to set in site-init.el
(defcustom message-send-mail-function
@@ -833,9 +816,7 @@ Doing so would be even more evil than leaving it out."
:type 'boolean)
(defcustom message-sendmail-envelope-from
- ;; Default to the value of `mail-envelope-from' if available.
- ;; Note: as for Emacsen that Gnus supports, except for SXEmacs, it is
- ;; unavailable unless sendmail.el is loaded.
+ ;; `mail-envelope-from' is unavailable unless sendmail.el is loaded.
(if (boundp 'mail-envelope-from) mail-envelope-from)
"*Envelope-from when sending mail with sendmail.
If this is nil, use `user-mail-address'. If it is the symbol
@@ -1013,10 +994,7 @@ Please also read the note in the documentation of
:version "23.1" ;; No Gnus
:group 'message-insertion)
-(defcustom message-yank-prefix
- ;; Default to the value of `mail-yank-prefix' if available.
- ;; Note: as for Emacs 21, it is unavailable unless sendmail.el is loaded.
- (if (boundp 'mail-yank-prefix) mail-yank-prefix "> ")
+(defcustom message-yank-prefix mail-yank-prefix
"*Prefix inserted on the lines of yanked messages.
Fix `message-cite-prefix-regexp' if it is set to an abnormal value.
See also `message-yank-cited-prefix' and `message-yank-empty-prefix'."
@@ -1042,11 +1020,7 @@ See also `message-yank-prefix' and `message-yank-cited-prefix'."
:link '(custom-manual "(message)Insertion Variables")
:group 'message-insertion)
-(defcustom message-indentation-spaces
- ;; Default to the value of `mail-indentation-spaces' if available.
- ;; Note: as for Emacs 21, XEmacs 21.4 and 21.5, it is unavailable
- ;; unless sendmail.el is loaded.
- (if (boundp 'mail-indentation-spaces) mail-indentation-spaces 3)
+(defcustom message-indentation-spaces mail-indentation-spaces
"*Number of spaces to insert at the beginning of each cited line.
Used by `message-yank-original' via `message-yank-cite'."
:version "23.2"
@@ -1077,8 +1051,6 @@ point and mark around the citation text as modified."
:group 'message-insertion)
(defcustom message-signature mail-signature
- ;; Default to the value of `mail-signature', available in all Emacsen
- ;; that Gnus supports.
"*String to be inserted at the end of the message buffer.
If t, the `message-signature-file' file will be inserted instead.
If a function, the result from the function will be used instead.
@@ -1088,11 +1060,7 @@ If a form, the result from the form will be used instead."
:link '(custom-manual "(message)Insertion Variables")
:group 'message-insertion)
-(defcustom message-signature-file
- ;; Default to the value of `mail-signature-file' if available.
- ;; Note: as for Emacs 21, XEmacs 21.4 and 21.5, it is unavailable
- ;; unless sendmail.el is loaded.
- (if (boundp 'mail-signature-file) mail-signature-file "~/.signature")
+(defcustom message-signature-file mail-signature-file
"*Name of file containing the text inserted at end of message buffer.
Ignored if the named file doesn't exist.
If nil, don't insert a signature.
@@ -1171,13 +1139,17 @@ It is a vector of the following headers:
:error "All header lines must be newline terminated")
(defcustom message-default-headers ""
- "*A string containing header lines to be inserted in outgoing messages.
-It is inserted before you edit the message, so you can edit or delete
-these lines."
+ "Header lines to be inserted in outgoing messages.
+This can be set to a string containing or a function returning
+header lines to be inserted before you edit the message, so you
+can edit or delete these lines. If set to a function, it is
+called and its result is inserted."
:version "23.2"
:group 'message-headers
:link '(custom-manual "(message)Message Headers")
- :type 'message-header-lines)
+ :type '(choice
+ (message-header-lines :tag "String")
+ (function :tag "Function")))
(defcustom message-default-mail-headers
;; Ease the transition from mail-mode to message-mode. See bugs#4431, 5555.
@@ -1191,8 +1163,8 @@ these lines."
(stringp mail-archive-file-name))
(format "FCC: %s\n" mail-archive-file-name))
;; Use the value of `mail-default-headers' if available.
- ;; Note: as for Emacs 21, XEmacs 21.4 and 21.5, it is
- ;; unavailable unless sendmail.el is loaded.
+ ;; Note: as for XEmacs 21.4 and 21.5, it is unavailable
+ ;; unless sendmail.el is loaded.
(if (boundp 'mail-default-headers)
mail-default-headers))
"*A string of header lines to be inserted in outgoing mails."
@@ -1280,7 +1252,7 @@ text and it replaces `self-insert-command' with the other command, e.g.
:type '(repeat function))
(defcustom message-auto-save-directory
- (file-name-as-directory (nnheader-concat message-directory "drafts"))
+ (file-name-as-directory (expand-file-name "drafts" message-directory))
"*Directory where Message auto-saves buffers if Gnus isn't running.
If nil, Message won't auto-save."
:group 'message-buffers
@@ -1623,11 +1595,11 @@ If you'd like to make it possible to share draft files between XEmacs
and Emacs, you may use `iso-2022-7bit' for this value at your own risk.
Note that the coding-system `iso-2022-7bit' isn't suitable to all data.")
-(defcustom message-send-mail-partially-limit 1000000
+(defcustom message-send-mail-partially-limit nil
"The limitation of messages sent as message/partial.
The lower bound of message size in characters, beyond which the message
should be sent in several parts. If it is nil, the size is unlimited."
- :version "21.1"
+ :version "24.1"
:group 'message-buffers
:link '(custom-manual "(message)Mail Variables")
:type '(choice (const :tag "unlimited" nil)
@@ -1719,13 +1691,14 @@ functionality to work."
(const :tag "Never" nil)
(const :tag "Always" t)))
-(defcustom message-generate-hashcash (if (executable-find "hashcash") t)
+(defcustom message-generate-hashcash (if (executable-find "hashcash") 'opportunistic)
"*Whether to generate X-Hashcash: headers.
If t, always generate hashcash headers. If `opportunistic',
only generate hashcash headers if it can be done without the user
waiting (i.e., only asynchronously).
You must have the \"hashcash\" binary installed, see `hashcash-path'."
+ :version "24.1"
:group 'message-headers
:link '(custom-manual "(message)Mail Headers")
:type '(choice (const :tag "Always" t)
@@ -1742,6 +1715,7 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'."
(defvar message-mime-part nil)
(defvar message-posting-charset nil)
(defvar message-inserted-headers nil)
+(defvar message-inhibit-ecomplete nil)
;; Byte-compiler warning
(defvar gnus-active-hashtb)
@@ -1956,6 +1930,8 @@ is used by default."
(setq paren nil))))
(nreverse elems)))))
+(autoload 'nnheader-insert-file-contents "nnheader")
+
(defun message-mail-file-mbox-p (file)
"Say whether FILE looks like a Unix mbox file."
(when (and (file-exists-p file)
@@ -2180,7 +2156,6 @@ Leading \"Re: \" is not stripped by this function. Use the function
(defun message-change-subject (new-subject)
"Ask for NEW-SUBJECT header, append (was: <Old Subject>)."
- ;; <URL:http://www.landfield.com/usefor/drafts/draft-ietf-usefor-useage--1.02.unpaged>
(interactive
(list
(read-from-minibuffer "New subject: ")))
@@ -2668,7 +2643,6 @@ PGG manual, depending on the value of `mml2015-use'."
(define-key message-mode-map "\C-a" 'message-beginning-of-line)
(define-key message-mode-map "\t" 'message-tab)
- (define-key message-mode-map "\M-;" 'comment-region)
(define-key message-mode-map "\M-n" 'message-display-abbrev))
@@ -2849,6 +2823,8 @@ See also `message-forbidden-properties'."
(inhibit-read-only t))
(remove-text-properties begin end message-forbidden-properties))))
+(autoload 'ecomplete-setup "ecomplete") ;; for Emacs <23.
+
;;;###autoload
(define-derived-mode message-mode text-mode "Message"
"Major mode for editing mail and news to be sent.
@@ -3071,10 +3047,22 @@ M-RET `message-newline-and-reformat' (break the line and reformat)."
(interactive)
(message-position-on-field "Summary" "Subject"))
-(defun message-goto-body (&optional interactivep)
+(eval-when-compile
+ (defmacro message-called-interactively-p (kind)
+ (condition-case nil
+ (progn
+ (eval '(called-interactively-p 'any))
+ ;; Emacs >=23.2
+ `(called-interactively-p ,kind))
+ ;; Emacs <23.2
+ (wrong-number-of-arguments '(called-interactively-p))
+ ;; XEmacs
+ (void-function '(interactive-p)))))
+
+(defun message-goto-body ()
"Move point to the beginning of the message body."
- (interactive (list t))
- (when (and interactivep
+ (interactive)
+ (when (and (message-called-interactively-p 'any)
(looking-at "[ \t]*\n"))
(expand-abbrev))
(goto-char (point-min))
@@ -3083,7 +3071,7 @@ M-RET `message-newline-and-reformat' (break the line and reformat)."
(defun message-in-body-p ()
"Return t if point is in the message body."
- (let ((body (save-excursion (message-goto-body) (point))))
+ (let ((body (save-excursion (message-goto-body))))
(>= (point) body)))
(defun message-goto-eoh ()
@@ -3408,8 +3396,8 @@ Message buffers and is not meant to be called directly."
;; if message-signature-file contains a path.
(not (file-name-directory
message-signature-file)))
- (nnheader-concat message-signature-directory
- message-signature-file)
+ (expand-file-name message-signature-file
+ message-signature-directory)
message-signature-file))
(file-exists-p signature-file))))
(when signature
@@ -4090,7 +4078,8 @@ It should typically alter the sending method in some way or other."
(run-hooks 'message-sent-hook))
(message "Sending...done")
;; Do ecomplete address snarfing.
- (when (message-mail-alias-type-p 'ecomplete)
+ (when (and (message-mail-alias-type-p 'ecomplete)
+ (not message-inhibit-ecomplete))
(message-put-addresses-in-ecomplete))
;; Mark the buffer as unmodified and delete auto-save.
(set-buffer-modified-p nil)
@@ -4232,7 +4221,7 @@ conformance."
(?r ,(format
"Replace non-printable characters with \"%s\" and send"
message-replacement-char))
- (?i "Ignore non-printable characters and send")
+ (?s "Send as is without removing anything")
(?e "Continue editing"))))
(if (eq choice ?e)
(error "Non-printable characters"))
@@ -4412,6 +4401,8 @@ This function could be useful in `message-setup-hook'."
(erase-buffer)))
(kill-buffer tembuf))))
+(declare-function hashcash-wait-async "hashcash" (&optional buffer))
+
(defun message-send-mail (&optional arg)
(require 'mail-utils)
(let* ((tembuf (message-generate-new-buffer-clone-locals " message temp"))
@@ -4419,14 +4410,26 @@ This function could be useful in `message-setup-hook'."
(news (message-news-p))
(mailbuf (current-buffer))
(message-this-is-mail t)
+ ;; gnus-setup-posting-charset is autoloaded in mml.el (FIXME
+ ;; maybe it should not be), which this file requires. Hence
+ ;; the fboundp test is always true. Loading it from gnus-msg
+ ;; loads many Gnus files (Bug#5642). If
+ ;; gnus-group-posting-charset-alist hasn't been customized,
+ ;; this is just going to return nil anyway. FIXME it would
+ ;; be good to improve this further, because even if g-g-p-c-a
+ ;; has been customized, that is likely to just be for news.
+ ;; Eg either move the definition from gnus-msg, or separate out
+ ;; the mail and news parts.
(message-posting-charset
- (if (fboundp 'gnus-setup-posting-charset)
+ (if (and (fboundp 'gnus-setup-posting-charset)
+ (boundp 'gnus-group-posting-charset-alist))
(gnus-setup-posting-charset nil)
message-posting-charset))
(headers message-required-mail-headers))
(when (and message-generate-hashcash
(not (eq message-generate-hashcash 'opportunistic)))
(message "Generating hashcash...")
+ (require 'hashcash)
;; Wait for calculations already started to finish...
(hashcash-wait-async)
;; ...and do calculations not already done. mail-add-payment
@@ -4491,6 +4494,8 @@ This function could be useful in `message-setup-hook'."
(save-restriction
(message-narrow-to-headers)
(and news
+ (not (message-fetch-field "List-Post"))
+ (not (message-fetch-field "List-ID"))
(or (message-fetch-field "cc")
(message-fetch-field "bcc")
(message-fetch-field "to"))
@@ -4507,7 +4512,9 @@ This function could be useful in `message-setup-hook'."
(string= "base64"
(message-fetch-field
"content-transfer-encoding")))))))
- (message-insert-courtesy-copy))
+ (message-insert-courtesy-copy
+ (with-current-buffer mailbuf
+ message-courtesy-message)))
;; Let's make sure we encoded all the body.
(assert (save-excursion
(goto-char (point-min))
@@ -4548,6 +4555,7 @@ If you always want Gnus to send messages in one piece, set
(defun message-send-mail-with-sendmail ()
"Send off the prepared buffer with sendmail."
+ (require 'sendmail)
(let ((errbuf (if message-interactive
(message-generate-new-buffer-clone-locals
" sendmail errors")
@@ -4711,10 +4719,14 @@ Do not use this for anything important, it is cryptographically weak."
(prin1-to-string (recent-keys))
(prin1-to-string (garbage-collect))))))
+(defvar canlock-password)
+(defvar canlock-password-for-verify)
+
(defun message-canlock-password ()
"The password used by message for cancel locks.
This is the value of `canlock-password', if that option is non-nil.
Otherwise, generate and save a value for `canlock-password' first."
+ (require 'canlock)
(unless canlock-password
(customize-save-variable 'canlock-password (message-canlock-generate))
(setq canlock-password-for-verify canlock-password))
@@ -4725,7 +4737,12 @@ Otherwise, generate and save a value for `canlock-password' first."
(message-canlock-password)
(canlock-insert-header)))
+(autoload 'nnheader-get-report "nnheader")
+
+(declare-function gnus-setup-posting-charset "gnus-msg" (group))
+
(defun message-send-news (&optional arg)
+ (require 'gnus-msg)
(let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*"))
(case-fold-search nil)
(method (if (functionp message-post-method)
@@ -5412,7 +5429,7 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'."
(* 25 25)))
(let ((tm (current-time)))
(concat
- (if (or (memq system-type '(ms-dos emx))
+ (if (or (eq system-type 'ms-dos)
;; message-number-base36 doesn't handle bigints.
(floatp (user-uid)))
(let ((user (downcase (user-login-name))))
@@ -5470,7 +5487,7 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'."
(defun message-make-references ()
"Return the References header for this message."
(when message-reply-headers
- (let ((message-id (mail-header-message-id message-reply-headers))
+ (let ((message-id (mail-header-id message-reply-headers))
(references (mail-header-references message-reply-headers)))
(if (or references message-id)
(concat (or references "") (and references " ")
@@ -5482,7 +5499,7 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'."
(when message-reply-headers
(let ((from (mail-header-from message-reply-headers))
(date (mail-header-date message-reply-headers))
- (msg-id (mail-header-message-id message-reply-headers)))
+ (msg-id (mail-header-id message-reply-headers)))
(when from
(let ((name (mail-extract-address-components from)))
(concat
@@ -5738,7 +5755,9 @@ subscribed address (and not the additional To and Cc header contents)."
(mapcar (lambda (rhs) (or (cadr (split-string rhs "@")) ""))
(mapcar 'downcase
(mapcar
- 'cadr
+ (lambda (elem)
+ (or (cadr elem)
+ ""))
(mail-extract-address-components field t))))))
;; Note that `rhs' will be "" if the address does not have
;; the domain part, i.e., if it is a local user's address.
@@ -5936,7 +5955,7 @@ Headers already prepared in the buffer are not modified."
;; Check for IDNA
(message-idna-to-ascii-rhs))))
-(defun message-insert-courtesy-copy ()
+(defun message-insert-courtesy-copy (message)
"Insert a courtesy message in mail copies of combined messages."
(let (newsgroups)
(save-excursion
@@ -5946,12 +5965,12 @@ Headers already prepared in the buffer are not modified."
(goto-char (point-max))
(insert "Posted-To: " newsgroups "\n")))
(forward-line 1)
- (when message-courtesy-message
+ (when message
(cond
- ((string-match "%s" message-courtesy-message)
- (insert (format message-courtesy-message newsgroups)))
+ ((string-match "%s" message)
+ (insert (format message newsgroups)))
(t
- (insert message-courtesy-message)))))))
+ (insert message)))))))
;;;
;;; Setting up a message buffer
@@ -6051,6 +6070,7 @@ If the current line has `message-yank-prefix', insert it on the new line."
When sending via news, also check that the REFERENCES are less
than 988 characters long, and if they are not, trim them until
they are."
+ ;; 21 is the number suggested by USEAGE.
(let ((maxcount 21)
(count 0)
(cut 2)
@@ -6362,7 +6382,10 @@ are not included."
headers)
(delete-region (point) (progn (forward-line -1) (point)))
(when message-default-headers
- (insert message-default-headers)
+ (insert
+ (if (functionp message-default-headers)
+ (funcall message-default-headers)
+ message-default-headers))
(or (bolp) (insert ?\n)))
(insert mail-header-separator "\n")
(forward-line -1)
@@ -6430,9 +6453,7 @@ are not included."
(setq buffer-file-name (expand-file-name
(concat
(if (memq system-type
- '(ms-dos ms-windows windows-nt
- cygwin cygwin32 win32 w32
- mswindows))
+ '(ms-dos windows-nt cygwin))
"message"
"*message*")
(format-time-string "-%Y%m%d-%H%M%S"))
@@ -6532,7 +6553,7 @@ The function is called with one parameter, a cons cell ..."
(defun message-get-reply-headers (wide &optional to-address address-headers)
(let (follow-to mct never-mct to cc author mft recipients extra)
- ;; Find all relevant headers we need.
+ ;; Find all relevant headers we need.
(save-restriction
(message-narrow-to-headers-or-head)
;; Gmane renames "To". Look at "Original-To", too, if it is present in
@@ -6569,6 +6590,10 @@ The function is called with one parameter, a cons cell ..."
(save-match-data
;; Build (textual) list of new recipient addresses.
(cond
+ (to-address
+ (setq recipients (concat ", " to-address))
+ ;; If the author explicitly asked for a copy, we don't deny it to them.
+ (if mct (setq recipients (concat recipients ", " mct))))
((not wide)
(setq recipients (concat ", " author)))
(address-headers
@@ -6604,10 +6629,6 @@ responses here are directed to other addresses.
You may customize the variable `message-use-mail-followup-to', if you
want to get rid of this query permanently.")))
(setq recipients (concat ", " mft)))
- (to-address
- (setq recipients (concat ", " to-address))
- ;; If the author explicitly asked for a copy, we don't deny it to them.
- (if mct (setq recipients (concat recipients ", " mct))))
(t
(setq recipients (if never-mct "" (concat ", " author)))
(if to (setq recipients (concat recipients ", " to)))
@@ -6658,6 +6679,8 @@ want to get rid of this query permanently.")))
(if recip
(setq recipients (delq recip recipients))))))))
+ (setq recipients (message-prune-recipients recipients))
+
;; Build the header alist. Allow the user to be asked whether
;; or not to reply to all recipients in a wide reply.
(setq follow-to (list (cons 'To (cdr (pop recipients)))))
@@ -6671,6 +6694,22 @@ want to get rid of this query permanently.")))
(push (cons 'Cc recipients) follow-to)))
follow-to))
+(defun message-prune-recipients (recipients)
+ (dolist (rule message-prune-recipient-rules)
+ (let ((match (car rule))
+ dup-match
+ address)
+ (dolist (recipient recipients)
+ (setq address (car recipient))
+ (when (string-match match address)
+ (setq dup-match (replace-match (cadr rule) nil nil address))
+ (dolist (recipient recipients)
+ ;; Don't delete the address that triggered this.
+ (when (and (not (eq address (car recipient)))
+ (string-match dup-match (car recipient)))
+ (setq recipients (delq recipient recipients))))))))
+ recipients)
+
(defcustom message-simplify-subject-functions
'(message-strip-list-identifiers
message-strip-subject-re
@@ -7142,22 +7181,28 @@ Optional DIGEST will use digest to forward."
(defun message-forward-make-body-plain (forward-buffer)
(insert
"\n-------------------- Start of forwarded message --------------------\n")
- (let ((b (point)) e)
- (insert
- (with-temp-buffer
- (mm-disable-multibyte)
- (insert
- (with-current-buffer forward-buffer
- (mm-with-unibyte-current-buffer (buffer-string))))
- (mm-enable-multibyte)
- (mime-to-mml)
- (goto-char (point-min))
- (when (looking-at "From ")
- (replace-match "X-From-Line: "))
- (buffer-string)))
+ (let ((b (point))
+ (contents (with-current-buffer forward-buffer (buffer-string)))
+ e)
+ (unless (featurep 'xemacs)
+ (unless (mm-multibyte-string-p contents)
+ (error "Attempt to insert unibyte string from the buffer \"%s\"\
+ to the multibyte buffer \"%s\""
+ (if (bufferp forward-buffer)
+ (buffer-name forward-buffer)
+ forward-buffer)
+ (buffer-name))))
+ (insert (mm-with-multibyte-buffer
+ (insert contents)
+ (mime-to-mml)
+ (goto-char (point-min))
+ (when (looking-at "From ")
+ (replace-match "X-From-Line: "))
+ (buffer-string)))
+ (unless (bolp) (insert "\n"))
(setq e (point))
(insert
- "\n-------------------- End of forwarded message --------------------\n")
+ "-------------------- End of forwarded message --------------------\n")
(message-remove-ignored-headers b e)))
(defun message-remove-ignored-headers (b e)
@@ -7193,18 +7238,22 @@ Optional DIGEST will use digest to forward."
(insert "\n\n<#mml type=message/rfc822 disposition=inline>\n")
(let ((b (point)) e)
(if (not message-forward-decoded-p)
- (insert
- (with-temp-buffer
- (mm-disable-multibyte)
- (insert
- (with-current-buffer forward-buffer
- (mm-with-unibyte-current-buffer (buffer-string))))
- (mm-enable-multibyte)
- (mime-to-mml)
- (goto-char (point-min))
- (when (looking-at "From ")
- (replace-match "X-From-Line: "))
- (buffer-string)))
+ (let ((contents (with-current-buffer forward-buffer (buffer-string))))
+ (unless (featurep 'xemacs)
+ (unless (mm-multibyte-string-p contents)
+ (error "Attempt to insert unibyte string from the buffer \"%s\"\
+ to the multibyte buffer \"%s\""
+ (if (bufferp forward-buffer)
+ (buffer-name forward-buffer)
+ forward-buffer)
+ (buffer-name))))
+ (insert (mm-with-multibyte-buffer
+ (insert contents)
+ (mime-to-mml)
+ (goto-char (point-min))
+ (when (looking-at "From ")
+ (replace-match "X-From-Line: "))
+ (buffer-string))))
(save-restriction
(narrow-to-region (point) (point))
(mml-insert-buffer forward-buffer)
@@ -7395,7 +7444,12 @@ is for the internal use."
(when (looking-at "From ")
(replace-match "X-From-Line: "))
;; Send it.
- (let ((message-inhibit-body-encoding t)
+ (let ((message-inhibit-body-encoding
+ ;; Don't do any further encoding if it looks like the
+ ;; message has already been encoded.
+ (let ((case-fold-search t))
+ (re-search-forward "^mime-version:" nil t)))
+ (message-inhibit-ecomplete t)
message-required-mail-headers
message-generate-hashcash
rfc2047-encode-encoded-words)
@@ -8008,7 +8062,11 @@ From headers in the original article."
(not result)
result)))
+(declare-function ecomplete-add-item "ecomplete" (type key text))
+(declare-function ecomplete-save "ecomplete" ())
+
(defun message-put-addresses-in-ecomplete ()
+ (require 'ecomplete)
(dolist (header '("to" "cc" "from" "reply-to"))
(let ((value (message-field-value header)))
(dolist (string (mail-header-parse-addresses value 'raw))
@@ -8019,6 +8077,8 @@ From headers in the original article."
string))))
(ecomplete-save))
+(autoload 'ecomplete-display-matches "ecomplete")
+
(defun message-display-abbrev (&optional choose)
"Display the next possible abbrev for the text before point."
(interactive (list t))
@@ -8195,5 +8255,4 @@ Used in `message-simplify-recipients'."
;; coding: iso-8859-1
;; End:
-;; arch-tag: 94b32cac-4504-4b6c-8181-030ebf380ee0
;;; message.el ends here
diff --git a/lisp/gnus/messcompat.el b/lisp/gnus/messcompat.el
index 1ad63627bb0..de67d8ce7ed 100644
--- a/lisp/gnus/messcompat.el
+++ b/lisp/gnus/messcompat.el
@@ -89,5 +89,4 @@ variable `mail-header-separator'.")
(provide 'messcompat)
-;; arch-tag: a76673be-905e-4bbd-8966-615370494a7b
;;; messcompat.el ends here
diff --git a/lisp/gnus/mm-bodies.el b/lisp/gnus/mm-bodies.el
index fd42abc0ab8..5a70f33d95f 100644
--- a/lisp/gnus/mm-bodies.el
+++ b/lisp/gnus/mm-bodies.el
@@ -24,7 +24,7 @@
;;; Code:
-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
@@ -302,5 +302,4 @@ decoding. If it is nil, default to `mail-parse-charset'."
(provide 'mm-bodies)
-;; arch-tag: 41104bb6-4443-4ca9-8d5c-ff87ecf27d8d
;;; mm-bodies.el ends here
diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el
index ac05362ec0c..bd9e704144e 100644
--- a/lisp/gnus/mm-decode.el
+++ b/lisp/gnus/mm-decode.el
@@ -1,7 +1,7 @@
;;; mm-decode.el --- Functions for decoding MIME things
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
@@ -24,17 +24,19 @@
;;; Code:
-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
(require 'mail-parse)
-(require 'mailcap)
(require 'mm-bodies)
-(require 'gnus-util)
(eval-when-compile (require 'cl)
(require 'term))
+(autoload 'gnus-map-function "gnus-util")
+(autoload 'gnus-replace-in-string "gnus-util")
+(autoload 'gnus-read-shell-command "gnus-util")
+
(autoload 'mm-inline-partial "mm-partial")
(autoload 'mm-inline-external-body "mm-extern")
(autoload 'mm-extern-cache-contents "mm-extern")
@@ -103,10 +105,8 @@
,disposition ,description ,cache ,id))
(defcustom mm-text-html-renderer
- (cond ((executable-find "w3m")
- (if (locate-library "w3m")
- 'w3m
- 'w3m-standalone))
+ (cond ((fboundp 'libxml-parse-html-region) 'shr)
+ ((executable-find "w3m") 'gnus-w3m)
((executable-find "links") 'links)
((executable-find "lynx") 'lynx)
((locate-library "w3") 'w3)
@@ -115,6 +115,8 @@
"Render of HTML contents.
It is one of defined renderer types, or a rendering function.
The defined renderer types are:
+`shr': use Gnus simple HTML renderer;
+`gnus-w3m' : use Gnus renderer based on w3m;
`w3m' : use emacs-w3m;
`w3m-standalone': use w3m;
`links': use links;
@@ -122,9 +124,11 @@ The defined renderer types are:
`w3' : use Emacs/W3;
`html2text' : use html2text;
nil : use external viewer (default web browser)."
- :version "23.0" ;; No Gnus
- :type '(choice (const w3)
- (const w3m :tag "emacs-w3m")
+ :version "24.1"
+ :type '(choice (const shr)
+ (const gnus-w3m)
+ (const w3)
+ (const w3m :tag "emacs-w3m")
(const w3m-standalone :tag "standalone w3m" )
(const links)
(const lynx)
@@ -133,10 +137,6 @@ nil : use external viewer (default web browser)."
(function))
:group 'mime-display)
-(defvar mm-inline-text-html-renderer nil
- "Function used for rendering inline HTML contents.
-It is suggested to customize `mm-text-html-renderer' instead.")
-
(defcustom mm-inline-text-html-with-images nil
"If non-nil, Gnus will allow retrieving images in HTML contents with
the <img> tags. It has no effect on Emacs/w3. See also the
@@ -241,8 +241,7 @@ before the external MIME handler is invoked."
("text/html"
mm-inline-text-html
(lambda (handle)
- (or mm-inline-text-html-renderer
- mm-text-html-renderer)))
+ mm-text-html-renderer))
("text/x-vcard"
mm-inline-text-vcard
(lambda (handle)
@@ -367,8 +366,12 @@ enables you to choose manually one of two types those mails include."
:group 'mime-display)
(defcustom mm-inline-large-images nil
- "If non-nil, then all images fit in the buffer."
- :type 'boolean
+ "If t, then all images fit in the buffer.
+If 'resize, try to resize the images so they fit."
+ :type '(radio
+ (const :tag "Inline large images as they are." t)
+ (const :tag "Resize large images." resize)
+ (const :tag "Do not inline large images." nil))
:group 'mime-display)
(defcustom mm-file-name-rewrite-functions
@@ -550,6 +553,8 @@ Postpone undisplaying of viewers for types in
(message "Destroying external MIME viewers")
(mm-destroy-parts mm-postponed-undisplay-list)))
+(autoload 'message-fetch-field "message")
+
(defun mm-dissect-buffer (&optional no-strict-mime loose-mime from)
"Dissect the current buffer and return a list of MIME handles."
(save-excursion
@@ -619,7 +624,7 @@ Postpone undisplaying of viewers for types in
no-strict-mime
(and cd (mail-header-parse-content-disposition cd))
description id)
- ctl))))
+ ctl from))))
(when id
(when (string-match " *<\\(.*\\)> *" id)
(setq id (match-string 1 id)))
@@ -661,7 +666,7 @@ Postpone undisplaying of viewers for types in
(save-restriction
(narrow-to-region start end)
(setq parts (nconc (list (mm-dissect-buffer t nil from)) parts)))))
- (mm-possibly-verify-or-decrypt (nreverse parts) ctl)))
+ (mm-possibly-verify-or-decrypt (nreverse parts) ctl from)))
(defun mm-copy-to-buffer ()
"Copy the contents of the current buffer to a fresh buffer."
@@ -688,13 +693,17 @@ Postpone undisplaying of viewers for types in
(goto-char (point-max)))
(mapcar 'mm-display-parts handle))))
-(defun mm-display-part (handle &optional no-default)
+(autoload 'mailcap-parse-mailcaps "mailcap")
+(autoload 'mailcap-mime-info "mailcap")
+
+(defun mm-display-part (handle &optional no-default force)
"Display the MIME part represented by HANDLE.
Returns nil if the part is removed; inline if displayed inline;
external if displayed external."
(save-excursion
(mailcap-parse-mailcaps)
- (if (mm-handle-displayed-p handle)
+ (if (and (not force)
+ (mm-handle-displayed-p handle))
(mm-remove-part handle)
(let* ((ehandle (if (equal (mm-handle-media-type handle)
"message/external-body")
@@ -747,6 +756,7 @@ external if displayed external."
handle 'mailcap-save-binary-file)))))))))
(declare-function gnus-configure-windows "gnus-win" (setting &optional force))
+(defvar mailcap-mime-extensions) ; mailcap-mime-info autoloads
(defun mm-display-external (handle method)
"Display HANDLE using METHOD."
@@ -1140,13 +1150,15 @@ in HANDLE."
;; time to adjust it, since we know at this point that it should
;; be unibyte.
`(let* ((handle ,handle))
- (with-temp-buffer
- (mm-disable-multibyte)
- (insert-buffer-substring (mm-handle-buffer handle))
- (mm-decode-content-transfer-encoding
- (mm-handle-encoding handle)
- (mm-handle-media-type handle))
- ,@forms)))
+ (when (and (mm-handle-buffer handle)
+ (buffer-name (mm-handle-buffer handle)))
+ (with-temp-buffer
+ (mm-disable-multibyte)
+ (insert-buffer-substring (mm-handle-buffer handle))
+ (mm-decode-content-transfer-encoding
+ (mm-handle-encoding handle)
+ (mm-handle-media-type handle))
+ ,@forms))))
(put 'mm-with-part 'lisp-indent-function 1)
(put 'mm-with-part 'edebug-form-spec '(body))
@@ -1239,9 +1251,17 @@ PROMPT overrides the default one used to ask user for a file name."
(setq filename (gnus-map-function mm-file-name-rewrite-functions
(file-name-nondirectory filename))))
(setq file
- (read-file-name (or prompt "Save MIME part to: ")
- (or mm-default-directory default-directory)
- nil nil (or filename "")))
+ (read-file-name
+ (or prompt
+ (format "Save MIME part to (default %s): "
+ (or filename "")))
+ (or mm-default-directory default-directory)
+ (expand-file-name (or filename "")
+ (or mm-default-directory default-directory))))
+ (if (file-directory-p file)
+ (setq file (expand-file-name filename file))
+ (setq file (expand-file-name
+ file (or mm-default-directory default-directory))))
(setq mm-default-directory (file-name-directory file))
(and (or (not (file-exists-p file))
(yes-or-no-p (format "File %s already exists; overwrite? "
@@ -1250,11 +1270,11 @@ PROMPT overrides the default one used to ask user for a file name."
(mm-save-part-to-file handle file)
file))))
-(defun mm-add-meta-html-tag (handle &optional charset)
+(defun mm-add-meta-html-tag (handle &optional charset force-charset)
"Add meta html tag to specify CHARSET of HANDLE in the current buffer.
CHARSET defaults to the one HANDLE specifies. Existing meta tag that
-specifies charset will not be modified. Return t if meta tag is added
-or replaced."
+specifies charset will not be modified unless FORCE-CHARSET is non-nil.
+Return t if meta tag is added or replaced."
(when (equal (mm-handle-media-type handle) "text/html")
(when (or charset
(setq charset (mail-content-type-get (mm-handle-type handle)
@@ -1266,7 +1286,8 @@ or replaced."
(if (re-search-forward "\
<meta\\s-+http-equiv=[\"']?content-type[\"']?\\s-+content=[\"']\
text/\\(\\sw+\\)\\(?:\;\\s-*charset=\\(.+\\)\\)?[\"'][^>]*>" nil t)
- (if (and (match-beginning 2)
+ (if (and (not force-charset)
+ (match-beginning 2)
(string-match "\\`html\\'" (match-string 1)))
;; Don't modify existing meta tag.
nil
@@ -1292,27 +1313,30 @@ text/\\(\\sw+\\)\\(?:\;\\s-*charset=\\(.+\\)\\)?[\"'][^>]*>" nil t)
(mm-write-region (point-min) (point-max) file nil nil nil 'binary t)
(set-default-file-modes current-file-modes)))))
-(defun mm-pipe-part (handle)
- "Pipe HANDLE to a process."
- (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
- (command
- (gnus-read-shell-command
- "Shell command on MIME part: " mm-last-shell-command)))
+(defun mm-pipe-part (handle &optional cmd)
+ "Pipe HANDLE to a process.
+Use CMD as the process."
+ (let ((name (mail-content-type-get (mm-handle-type handle) 'name))
+ (command (or cmd
+ (gnus-read-shell-command
+ "Shell command on MIME part: " mm-last-shell-command))))
(mm-with-unibyte-buffer
(mm-insert-part handle)
(mm-add-meta-html-tag handle)
(let ((coding-system-for-write 'binary))
(shell-command-on-region (point-min) (point-max) command nil)))))
+(autoload 'gnus-completing-read "gnus-util")
+
(defun mm-interactively-view-part (handle)
"Display HANDLE using METHOD."
(let* ((type (mm-handle-media-type handle))
(methods
- (mapcar (lambda (i) (list (cdr (assoc 'viewer i))))
+ (mapcar (lambda (i) (cdr (assoc 'viewer i)))
(mailcap-mime-info type 'all)))
(method (let ((minibuffer-local-completion-map
mm-viewer-completion-map))
- (completing-read "Viewer: " methods))))
+ (gnus-completing-read "Viewer" methods))))
(when (string= method "")
(error "No method given"))
(if (string-match "^[^% \t]+$" method)
@@ -1464,7 +1488,7 @@ be determined."
;; Handle XEmacs
((fboundp 'valid-image-instantiator-format-p)
(valid-image-instantiator-format-p format))
- ;; Handle Emacs 21
+ ;; Handle Emacs
((fboundp 'image-type-available-p)
(and (display-graphic-p)
(image-type-available-p format)))
@@ -1545,7 +1569,7 @@ If RECURSIVE, search recursively."
(autoload 'mm-view-pkcs7 "mm-view")
-(defun mm-possibly-verify-or-decrypt (parts ctl)
+(defun mm-possibly-verify-or-decrypt (parts ctl &optional from)
(let ((type (car ctl))
(subtype (cadr (split-string (car ctl) "/")))
(mm-security-handle ctl) ;; (car CTL) is the type.
@@ -1560,7 +1584,7 @@ If RECURSIVE, search recursively."
((eq mm-decrypt-option 'known) t)
(t (y-or-n-p
(format "Decrypt (S/MIME) part? "))))
- (mm-view-pkcs7 parts))
+ (mm-view-pkcs7 parts from))
(setq parts (mm-dissect-buffer t)))))
((equal subtype "signed")
(unless (and (setq protocol
@@ -1659,7 +1683,52 @@ If RECURSIVE, search recursively."
(and (eq (mm-body-7-or-8) '7bit)
(not (mm-long-lines-p 76))))))
+(declare-function libxml-parse-html-region "xml.c"
+ (start end &optional base-url))
+(declare-function shr-insert-document "shr" (dom))
+(defvar shr-blocked-images)
+(defvar gnus-inhibit-images)
+(autoload 'gnus-blocked-images "gnus-art")
+
+(defun mm-shr (handle)
+ ;; Require since we bind its variables.
+ (require 'shr)
+ (let ((article-buffer (current-buffer))
+ (shr-content-function (lambda (id)
+ (let ((handle (mm-get-content-id id)))
+ (when handle
+ (mm-with-part handle
+ (buffer-string))))))
+ shr-inhibit-images shr-blocked-images charset)
+ (if (and (boundp 'gnus-summary-buffer)
+ (buffer-name gnus-summary-buffer))
+ (with-current-buffer gnus-summary-buffer
+ (setq shr-inhibit-images gnus-inhibit-images
+ shr-blocked-images (gnus-blocked-images)))
+ (setq shr-inhibit-images gnus-inhibit-images
+ shr-blocked-images (gnus-blocked-images)))
+ (unless handle
+ (setq handle (mm-dissect-buffer t)))
+ (setq charset (mail-content-type-get (mm-handle-type handle) 'charset))
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (shr-insert-document
+ (mm-with-part handle
+ (when (and charset
+ (setq charset (mm-charset-to-coding-system charset))
+ (not (eq charset 'ascii)))
+ (insert (prog1
+ (mm-decode-coding-string (buffer-string) charset)
+ (erase-buffer)
+ (mm-enable-multibyte))))
+ (libxml-parse-html-region (point-min) (point-max))))
+ (mm-handle-set-undisplayer
+ handle
+ `(lambda ()
+ (let ((inhibit-read-only t))
+ (delete-region ,(point-min-marker)
+ ,(point-max-marker))))))))
+
(provide 'mm-decode)
-;; arch-tag: 4f35d360-56b8-4030-9388-3ed82d359b9b
;;; mm-decode.el ends here
diff --git a/lisp/gnus/mm-encode.el b/lisp/gnus/mm-encode.el
index a32927b8ae3..296a24351bb 100644
--- a/lisp/gnus/mm-encode.el
+++ b/lisp/gnus/mm-encode.el
@@ -26,7 +26,7 @@
(eval-when-compile (require 'cl))
(require 'mail-parse)
-(require 'mailcap)
+(autoload 'mailcap-extension-to-mime "mailcap")
(autoload 'mm-body-7-or-8 "mm-bodies")
(autoload 'mm-long-lines-p "mm-bodies")
@@ -42,15 +42,8 @@
If the encoding is `qp-or-base64', then either quoted-printable
or base64 will be used, depending on what is more efficient.
-`qp-or-base64' has another effect. It will fold long lines so that
-MIME parts may not be broken by MTA. So do `quoted-printable' and
-`base64'.
-
-Note: It affects body encoding only when a part is a raw forwarded
-message (which will be made by `gnus-summary-mail-forward' with the
-arg 2 for example) or is neither the text/* type nor the message/*
-type. Even though in those cases, you can use the `encoding' MML tag
-to specify encoding of non-ASCII MIME parts."
+This list is only consulted when encoding MIME parts in the
+bodies -- not for the regular non-MIME-ish messages."
:type '(repeat (list (regexp :tag "MIME type")
(choice :tag "encoding"
(const 7bit)
@@ -223,5 +216,4 @@ This is either `base64' or `quoted-printable'."
(provide 'mm-encode)
-;; arch-tag: 7d01bba4-d469-4851-952b-dc863f84ed66
;;; mm-encode.el ends here
diff --git a/lisp/gnus/mm-extern.el b/lisp/gnus/mm-extern.el
index 1e3df3c4cff..8363fe07c73 100644
--- a/lisp/gnus/mm-extern.el
+++ b/lisp/gnus/mm-extern.el
@@ -25,7 +25,7 @@
;;; Code:
-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
@@ -67,9 +67,8 @@
(coding-system-for-read mm-binary-coding-system))
(unless url
(error "URL is not specified"))
- (mm-with-unibyte-current-buffer
- (mm-url-insert-file-contents url))
(mm-disable-multibyte)
+ (mm-url-insert-file-contents url)
(setq buffer-file-name name)))
(defun mm-extern-anon-ftp (handle)
@@ -125,7 +124,7 @@
(or access-type
(error "Couldn't find access type"))))
mm-extern-function-alist)))
- buf handles)
+ handles)
(unless func
(error "Access type (%s) is not supported" access-type))
(mm-with-part handle
@@ -136,8 +135,7 @@
(unless (bufferp (car handles))
(mm-destroy-parts handles)
(error "Multipart external body is not supported"))
- (save-excursion
- (set-buffer (setq buf (mm-handle-buffer handles)))
+ (with-current-buffer (mm-handle-buffer handles)
(let (good)
(unwind-protect
(progn
@@ -169,5 +167,4 @@ If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing."
(provide 'mm-extern)
-;; arch-tag: 9653808e-14d9-4172-86e6-adceaa05378e
;;; mm-extern.el ends here
diff --git a/lisp/gnus/mm-partial.el b/lisp/gnus/mm-partial.el
index f9ee64da10b..6509b648fe7 100644
--- a/lisp/gnus/mm-partial.el
+++ b/lisp/gnus/mm-partial.el
@@ -70,8 +70,7 @@ If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing."
(sort (cons handle
(mm-partial-find-parts
id
- (save-excursion
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
(gnus-summary-article-number))))
#'(lambda (a b)
(let ((anumber (string-to-number
@@ -83,8 +82,7 @@ If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing."
(< anumber bnumber)))))
(setq gnus-article-mime-handles
(mm-merge-handles gnus-article-mime-handles phandles))
- (save-excursion
- (set-buffer (generate-new-buffer " *mm*"))
+ (with-current-buffer (generate-new-buffer " *mm*")
(while (setq phandle (pop phandles))
(setq nn (string-to-number
(cdr (assq 'number
@@ -150,5 +148,4 @@ If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing."
(provide 'mm-partial)
-;; arch-tag: 460e7424-05f2-4a1d-a0f2-70ec081eff7d
;;; mm-partial.el ends here
diff --git a/lisp/gnus/mm-url.el b/lisp/gnus/mm-url.el
index 35a43f5bd27..0da136e1efc 100644
--- a/lisp/gnus/mm-url.el
+++ b/lisp/gnus/mm-url.el
@@ -365,15 +365,20 @@ If FOLLOW-REFRESH is non-nil, redirect refresh url in META."
(defun mm-url-decode-entities ()
"Decode all HTML entities."
(goto-char (point-min))
- (while (re-search-forward "&\\(#[0-9]+\\|[a-z]+[0-9]*\\);" nil t)
- (let ((elem (if (eq (aref (match-string 1) 0) ?\#)
- (let ((c (mm-ucs-to-char
- (string-to-number
- (substring (match-string 1) 1)))))
- (if (mm-char-or-char-int-p c) c ?#))
- (or (cdr (assq (intern (match-string 1))
- mm-url-html-entities))
- ?#))))
+ (while (re-search-forward "&\\(#[0-9]+\\|#x[0-9a-f]+\\|[a-z]+[0-9]*\\);" nil t)
+ (let* ((entity (match-string 1))
+ (elem (if (eq (aref entity 0) ?\#)
+ (let ((c (mm-ucs-to-char
+ ;; Hex number: &#x3212
+ (if (eq (aref entity 1) ?x)
+ (string-to-number (substring entity 2)
+ 16)
+ ;; Decimal number: &#23
+ (string-to-number (substring entity 1))))))
+ (if (mm-char-or-char-int-p c) c ?#))
+ (or (cdr (assq (intern entity)
+ mm-url-html-entities))
+ ?#))))
(unless (stringp elem)
(setq elem (char-to-string elem)))
(replace-match elem t t))))
@@ -404,14 +409,10 @@ spaces. Die Die Die."
((= char ? ) "+")
((memq char mm-url-unreserved-chars) (char-to-string char))
(t (upcase (format "%%%02x" char)))))
- ;; Fixme: Should this actually be accepting multibyte? Is there a
- ;; better way in XEmacs?
- (if (featurep 'mule)
- (encode-coding-string chunk
- (if (fboundp 'find-coding-systems-string)
- (car (find-coding-systems-string chunk))
- buffer-file-coding-system))
- chunk)
+ (mm-encode-coding-string chunk
+ (if (fboundp 'find-coding-systems-string)
+ (car (find-coding-systems-string chunk))
+ buffer-file-coding-system))
""))
(defun mm-url-encode-www-form-urlencoded (pairs)
@@ -422,6 +423,50 @@ spaces. Die Die Die."
(mm-url-form-encode-xwfu (cdr data))))
pairs "&"))
+(autoload 'mml-compute-boundary "mml")
+
+(defun mm-url-encode-multipart-form-data (pairs &optional boundary)
+ "Return PAIRS encoded in multipart/form-data."
+ ;; RFC1867
+
+ ;; Get a good boundary
+ (unless boundary
+ (setq boundary (mml-compute-boundary '())))
+
+ (concat
+
+ ;; Start with the boundary
+ "--" boundary "\r\n"
+
+ ;; Create name value pairs
+ (mapconcat
+ 'identity
+ ;; Delete any returned items that are empty
+ (delq nil
+ (mapcar (lambda (data)
+ (when (car data)
+ ;; For each pair
+ (concat
+
+ ;; Encode the name
+ "Content-Disposition: form-data; name=\""
+ (car data) "\"\r\n"
+ "Content-Type: text/plain; charset=utf-8\r\n"
+ "Content-Transfer-Encoding: binary\r\n\r\n"
+
+ (cond ((stringp (cdr data))
+ (cdr data))
+ ((integerp (cdr data))
+ (int-to-string (cdr data))))
+
+ "\r\n")))
+ pairs))
+ ;; use the boundary as a separator
+ (concat "--" boundary "\r\n"))
+
+ ;; put a boundary at the end.
+ "--" boundary "--\r\n"))
+
(defun mm-url-fetch-form (url pairs)
"Fetch a form from URL with PAIRS as the data using the POST method."
(mm-url-load-url)
@@ -456,5 +501,4 @@ spaces. Die Die Die."
(provide 'mm-url)
-;; arch-tag: 0594f9b3-417c-48b0-adc2-5082e1e7917f
;;; mm-url.el ends here
diff --git a/lisp/gnus/mm-util.el b/lisp/gnus/mm-util.el
index 8dc232e7572..700c1a6bb64 100644
--- a/lisp/gnus/mm-util.el
+++ b/lisp/gnus/mm-util.el
@@ -24,7 +24,7 @@
;;; Code:
-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
@@ -39,6 +39,10 @@
(require 'timer)))
(defvar mm-mime-mule-charset-alist )
+;; Note this is not presently used on Emacs >= 23, which is good,
+;; since it means standalone message-mode (which requires mml and
+;; hence mml-util) does not load gnus-util.
+(autoload 'gnus-completing-read "gnus-util")
;; Emulate functions that are not available in every (X)Emacs version.
;; The name of a function is prefixed with mm-, like `mm-char-int' for
@@ -68,11 +72,11 @@
. ,(lambda (prompt)
"Return a charset."
(intern
- (completing-read
+ (gnus-completing-read
prompt
- (mapcar (lambda (e) (list (symbol-name (car e))))
+ (mapcar (lambda (e) (symbol-name (car e)))
mm-mime-mule-charset-alist)
- nil t))))
+ t))))
;; `subst-char-in-string' is not available in XEmacs 21.4.
(subst-char-in-string
. ,(lambda (from to string &optional inplace)
@@ -202,19 +206,10 @@ to the contents of the accessible portion of the buffer."
(defalias 'mm-decode-coding-region 'decode-coding-region)
(defalias 'mm-encode-coding-region 'encode-coding-region)))
-;; `string-to-multibyte' is available only in Emacs 22.1 or greater.
-(defalias 'mm-string-to-multibyte
- (cond
- ((featurep 'xemacs)
- 'identity)
- ((fboundp 'string-to-multibyte)
- 'string-to-multibyte)
- (t
- (lambda (string)
- "Return a multibyte string with the same individual chars as STRING."
- (mapconcat
- (lambda (ch) (mm-string-as-multibyte (char-to-string ch)))
- string "")))))
+;; `string-to-multibyte' is available only in Emacs.
+(defalias 'mm-string-to-multibyte (if (featurep 'xemacs)
+ 'identity
+ 'string-to-multibyte))
;; `char-or-char-int-p' is an XEmacs function, not available in Emacs.
(eval-and-compile
@@ -272,18 +267,19 @@ to the contents of the accessible portion of the buffer."
;; Actually, there should be an `mm-coding-system-mime-charset'.
(eval-and-compile
(defalias 'mm-read-coding-system
- (cond
- ((fboundp 'read-coding-system)
- (if (and (featurep 'xemacs)
- (<= (string-to-number emacs-version) 21.1))
- (lambda (prompt &optional default-coding-system)
- (read-coding-system prompt))
- 'read-coding-system))
- (t (lambda (prompt &optional default-coding-system)
- "Prompt the user for a coding system."
- (completing-read
- prompt (mapcar (lambda (s) (list (symbol-name (car s))))
- mm-mime-mule-charset-alist)))))))
+ (if (featurep 'emacs) 'read-coding-system
+ (cond
+ ((fboundp 'read-coding-system)
+ (if (and (featurep 'xemacs)
+ (<= (string-to-number emacs-version) 21.1))
+ (lambda (prompt &optional default-coding-system)
+ (read-coding-system prompt))
+ 'read-coding-system))
+ (t (lambda (prompt &optional default-coding-system)
+ "Prompt the user for a coding system."
+ (gnus-completing-read
+ prompt (mapcar (lambda (s) (symbol-name (car s)))
+ mm-mime-mule-charset-alist))))))))
(defvar mm-coding-system-list nil)
(defun mm-get-coding-system-list ()
@@ -316,8 +312,8 @@ the alias. Else windows-NUMBER is used."
(cp-supported-codepages)
;; Removed in Emacs 23 (unicode), so signal an error:
(error "`codepage-setup' not present in this Emacs version"))))
- (list (completing-read "Setup DOS Codepage: (default 437) " candidates
- nil t nil nil "437"))))
+ (list (gnus-completing-read "Setup DOS Codepage" candidates
+ t nil nil "437"))))
(when alias
(setq alias (if (stringp alias)
(intern alias)
@@ -383,8 +379,7 @@ See `mm-codepage-iso-8859-list' and `mm-codepage-ibm-list'.")
(defcustom mm-codepage-iso-8859-list
(list 1250 ;; Windows-1250 is a variant of Latin-2 heavily used by Microsoft
;; Outlook users in Czech republic. Use this to allow reading of
- ;; their e-mails. cp1250 should be defined by M-x codepage-setup
- ;; (Emacs 21).
+ ;; their e-mails.
'(1252 . 1) ;; Windows-1252 is a superset of iso-8859-1 (West
;; Europe). See also `gnus-article-dumbquotes-map'.
'(1254 . 9) ;; Windows-1254 is a superset of iso-8859-9 (Turkish).
@@ -494,8 +489,8 @@ Unless LIST is given, `mm-codepage-ibm-list' is used."
(defcustom mm-charset-eval-alist
(if (featurep 'xemacs)
nil ;; I don't know what would be useful for XEmacs.
- '(;; Emacs 21 offers 1250 1251 1253 1257. Emacs 22 provides autoloads for
- ;; 1250-1258 (i.e. `mm-codepage-setup' does nothing).
+ '(;; Emacs 22 provides autoloads for 1250-1258
+ ;; (i.e. `mm-codepage-setup' does nothing).
(windows-1250 . (mm-codepage-setup 1250 t))
(windows-1251 . (mm-codepage-setup 1251 t))
(windows-1253 . (mm-codepage-setup 1253 t))
@@ -566,6 +561,9 @@ is not available."
;;; (eq charset (coding-system-get charset 'mime-charset))
)
charset)
+ ;; Use coding system Emacs knows.
+ ((and (fboundp 'coding-system-from-name)
+ (coding-system-from-name charset)))
;; Eval expressions from `mm-charset-eval-alist'
((let* ((el (assq charset mm-charset-eval-alist))
(cs (car el))
@@ -677,7 +675,7 @@ superset of iso-8859-1."
"100% binary coding system.")
(defvar mm-text-coding-system
- (or (if (memq system-type '(windows-nt ms-dos ms-windows))
+ (or (if (memq system-type '(windows-nt ms-dos))
(and (mm-coding-system-p 'raw-text-dos) 'raw-text-dos)
(and (mm-coding-system-p 'raw-text) 'raw-text))
mm-binary-coding-system)
@@ -689,12 +687,12 @@ superset of iso-8859-1."
(defvar mm-auto-save-coding-system
(cond
((mm-coding-system-p 'utf-8-emacs) ; Mule 7
- (if (memq system-type '(windows-nt ms-dos ms-windows))
+ (if (memq system-type '(windows-nt ms-dos))
(if (mm-coding-system-p 'utf-8-emacs-dos)
'utf-8-emacs-dos mm-binary-coding-system)
'utf-8-emacs))
((mm-coding-system-p 'emacs-mule)
- (if (memq system-type '(windows-nt ms-dos ms-windows))
+ (if (memq system-type '(windows-nt ms-dos))
(if (mm-coding-system-p 'emacs-mule-dos)
'emacs-mule-dos mm-binary-coding-system)
'emacs-mule))
@@ -899,26 +897,20 @@ mail with multiple parts is preferred to sending a Unicode one.")
out)))
(eval-and-compile
- (defvar mm-emacs-mule (and (not (featurep 'xemacs))
- (boundp 'enable-multibyte-characters)
- (default-value 'enable-multibyte-characters)
- (fboundp 'set-buffer-multibyte))
- "True in Emacs with Mule.")
-
- (if mm-emacs-mule
- (defun mm-enable-multibyte ()
- "Set the multibyte flag of the current buffer.
+ (if (featurep 'xemacs)
+ (defalias 'mm-enable-multibyte 'ignore)
+ (defun mm-enable-multibyte ()
+ "Set the multibyte flag of the current buffer.
Only do this if the default value of `enable-multibyte-characters' is
non-nil. This is a no-op in XEmacs."
- (set-buffer-multibyte 'to))
- (defalias 'mm-enable-multibyte 'ignore))
+ (set-buffer-multibyte 'to)))
- (if mm-emacs-mule
- (defun mm-disable-multibyte ()
- "Unset the multibyte flag of in the current buffer.
+ (if (featurep 'xemacs)
+ (defalias 'mm-disable-multibyte 'ignore)
+ (defun mm-disable-multibyte ()
+ "Unset the multibyte flag of in the current buffer.
This is a no-op in XEmacs."
- (set-buffer-multibyte nil))
- (defalias 'mm-disable-multibyte 'ignore)))
+ (set-buffer-multibyte nil))))
(defun mm-preferred-coding-system (charset)
;; A typo in some Emacs versions.
@@ -969,7 +961,6 @@ If the charset is `composition', return the actual one."
(if (eq charset 'unknown)
(error "The message contains non-printable characters, please use attachment"))
(if (and (fboundp 'coding-system-get) (fboundp 'get-charset-property))
- ;; This exists in Emacs 20.
(or
(and (mm-preferred-coding-system charset)
(or (coding-system-get
@@ -1227,28 +1218,23 @@ Use multibyte mode for this."
(defmacro mm-with-unibyte-current-buffer (&rest forms)
"Evaluate FORMS with current buffer temporarily made unibyte.
-Also bind the default-value of `enable-multibyte-characters' to nil.
-Equivalent to `progn' in XEmacs
-
-NOTE: Use this macro with caution in multibyte buffers (it is not
-worth using this macro in unibyte buffers of course). Use of
-`(set-buffer-multibyte t)', which is run finally, is generally
-harmful since it is likely to modify existing data in the buffer.
-For instance, it converts \"\\300\\255\" into \"\\255\" in
-Emacs 23 (unicode)."
- (let ((multibyte (make-symbol "multibyte"))
- (buffer (make-symbol "buffer")))
- `(if mm-emacs-mule
- (let ((,multibyte enable-multibyte-characters)
- (,buffer (current-buffer)))
- (unwind-protect
- (letf (((default-value 'enable-multibyte-characters) nil))
- (set-buffer-multibyte nil)
- ,@forms)
- (set-buffer ,buffer)
- (set-buffer-multibyte ,multibyte)))
- (letf (((default-value 'enable-multibyte-characters) nil))
- ,@forms))))
+Equivalent to `progn' in XEmacs.
+
+Note: We recommend not using this macro any more; there should be
+better ways to do a similar thing. The previous version of this macro
+bound the default value of `enable-multibyte-characters' to nil while
+evaluating FORMS but it is no longer done. So, some programs assuming
+it if any may malfunction."
+ (if (featurep 'xemacs)
+ `(progn ,@forms)
+ (let ((multibyte (make-symbol "multibyte")))
+ `(let ((,multibyte enable-multibyte-characters))
+ (when ,multibyte
+ (set-buffer-multibyte nil))
+ (prog1
+ (progn ,@forms)
+ (when ,multibyte
+ (set-buffer-multibyte t)))))))
(put 'mm-with-unibyte-current-buffer 'lisp-indent-function 0)
(put 'mm-with-unibyte-current-buffer 'edebug-form-spec '(body))
@@ -1437,16 +1423,23 @@ If SUFFIX is non-nil, add that at the end of the file name."
;; Reset the umask.
(set-default-file-modes umask)))))
+(defvar mm-image-load-path-cache nil)
+
(defun mm-image-load-path (&optional package)
- (let (dir result)
- (dolist (path load-path (nreverse result))
- (when (and path
- (file-directory-p
- (setq dir (concat (file-name-directory
- (directory-file-name path))
- "etc/images/" (or package "gnus/")))))
- (push dir result))
- (push path result))))
+ (if (and mm-image-load-path-cache
+ (equal load-path (car mm-image-load-path-cache)))
+ (cdr mm-image-load-path-cache)
+ (let (dir result)
+ (dolist (path load-path)
+ (when (and path
+ (file-directory-p
+ (setq dir (concat (file-name-directory
+ (directory-file-name path))
+ "etc/images/" (or package "gnus/")))))
+ (push dir result)))
+ (setq result (nreverse result)
+ mm-image-load-path-cache (cons load-path result))
+ result)))
;; Fixme: This doesn't look useful where it's used.
(if (fboundp 'detect-coding-region)
@@ -1540,14 +1533,13 @@ decompressed data. The buffer's multibyteness must be turned off."
prog t (list t err-file) nil args)
jka-compr-acceptable-retval-list)
(erase-buffer)
- (insert (mapconcat
- 'identity
- (delete "" (split-string
- (prog2
- (insert-file-contents err-file)
- (buffer-string)
- (erase-buffer))))
- " ")
+ (insert (mapconcat 'identity
+ (split-string
+ (prog2
+ (insert-file-contents err-file)
+ (buffer-string)
+ (erase-buffer)) t)
+ " ")
"\n")
(setq err-msg
(format "Error while executing \"%s %s < %s\""
@@ -1557,7 +1549,7 @@ decompressed data. The buffer's multibyteness must be turned off."
(error
(setq err-msg (error-message-string err)))))
(when (file-exists-p err-file)
- (ignore-errors (jka-compr-delete-temp-file err-file)))
+ (ignore-errors (delete-file err-file)))
(when inplace
(unless err-msg
(delete-region (point-min) (point-max))
@@ -1590,8 +1582,8 @@ gzip, bzip2, etc. are allowed."
filename))
(mm-decompress-buffer filename nil t))))
(when decomp
- (set-buffer (letf (((default-value 'enable-multibyte-characters) nil))
- (generate-new-buffer " *temp*")))
+ (set-buffer (generate-new-buffer " *temp*"))
+ (mm-disable-multibyte)
(insert decomp)
(setq filename (file-name-sans-extension filename)))
(goto-char (point-min))
@@ -1661,5 +1653,4 @@ gzip, bzip2, etc. are allowed."
(provide 'mm-util)
-;; arch-tag: 94dc5388-825d-4fd1-bfa5-2100aa351238
;;; mm-util.el ends here
diff --git a/lisp/gnus/mm-uu.el b/lisp/gnus/mm-uu.el
index 5ae9205e2f0..a10700ee3d9 100644
--- a/lisp/gnus/mm-uu.el
+++ b/lisp/gnus/mm-uu.el
@@ -165,7 +165,7 @@ This can be either \"inline\" or \"attachment\".")
;; dependency on `message.el'.
"^-+[8<>]*-\\{9,\\}[a-z ]+-\\{9,\\}[a-z ]+-\\{9,\\}[8<>]*-+$"
"^-+[8<>]*-\\{9,\\}[a-z ]+-\\{9,\\}[a-z ]+-\\{9,\\}[8<>]*-+$"
- (lambda () (mm-uu-verbatim-marks-extract -1 0 1 -1))
+ (lambda () (mm-uu-verbatim-marks-extract 0 0 1 -1))
nil)
;; Omitting [a-z8<] leads to false positives (bogus signature separators
;; and mailing list banners).
@@ -441,7 +441,7 @@ apply the face `mm-uu-extract'."
(defun mm-uu-yenc-extract ()
;; This might not be exactly correct, but we sure can't get the
;; binary data from the article buffer, since that's already in a
- ;; non-binary charset. So get it from the original article buffer.
+ ;; non-binary charset. So get it from the original article buffer.
(mm-make-handle (with-current-buffer gnus-original-article-buffer
(mm-uu-copy-to-buffer start-point end-point))
(list (or (and file-name
@@ -729,5 +729,4 @@ Assume text has been decoded if DECODED is non-nil."
(provide 'mm-uu)
-;; arch-tag: 7db076bf-53db-4320-aa19-ca76a1d2ab2c
;;; mm-uu.el ends here
diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el
index 42e21cad514..083781b0f9d 100644
--- a/lisp/gnus/mm-view.el
+++ b/lisp/gnus/mm-view.el
@@ -22,6 +22,8 @@
;;; Commentary:
;;; Code:
+
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
(eval-when-compile (require 'cl))
@@ -31,6 +33,8 @@
(require 'mm-decode)
(require 'smime)
+(autoload 'gnus-completing-read "gnus-util")
+(autoload 'gnus-window-inside-pixel-edges "gnus-ems")
(autoload 'gnus-article-prepare-display "gnus-art")
(autoload 'vcard-parse-string "vcard")
(autoload 'vcard-format-string "vcard")
@@ -46,45 +50,55 @@
(defvar w3m-minor-mode-map)
(defvar mm-text-html-renderer-alist
- '((w3 . mm-inline-text-html-render-with-w3)
+ '((shr . mm-shr)
+ (w3 . mm-inline-text-html-render-with-w3)
(w3m . mm-inline-text-html-render-with-w3m)
(w3m-standalone . mm-inline-text-html-render-with-w3m-standalone)
+ (gnus-w3m . gnus-article-html)
(links mm-inline-render-with-file
mm-links-remove-leading-blank
"links" "-dump" file)
- (lynx mm-inline-render-with-stdin nil
- "lynx" "-dump" "-force_html" "-stdin" "-nolist")
- (html2text mm-inline-render-with-function html2text))
+ (lynx mm-inline-render-with-stdin nil
+ "lynx" "-dump" "-force_html" "-stdin" "-nolist")
+ (html2text mm-inline-render-with-function html2text))
"The attributes of renderer types for text/html.")
-(defvar mm-text-html-washer-alist
- '((w3 . gnus-article-wash-html-with-w3)
- (w3m . gnus-article-wash-html-with-w3m)
- (w3m-standalone . gnus-article-wash-html-with-w3m-standalone)
- (links mm-inline-wash-with-file
- mm-links-remove-leading-blank
- "links" "-dump" file)
- (lynx mm-inline-wash-with-stdin nil
- "lynx" "-dump" "-force_html" "-stdin" "-nolist")
- (html2text html2text))
- "The attributes of washer types for text/html.")
-
(defcustom mm-fill-flowed t
"If non-nil a format=flowed article will be displayed flowed."
:type 'boolean
:version "22.1"
:group 'mime-display)
+(defcustom mm-inline-large-images-proportion 0.9
+ "Maximum proportion of large image resized when
+`mm-inline-large-images' is set to resize."
+ :type 'float
+ :version "24.1"
+ :group 'mime-display)
+
;;; Internal variables.
;;;
;;; Functions for displaying various formats inline
;;;
+(autoload 'gnus-rescale-image "gnus-util")
+
(defun mm-inline-image-emacs (handle)
(let ((b (point-marker))
(inhibit-read-only t))
- (put-image (mm-get-image handle) b)
+ (put-image
+ (let ((image (mm-get-image handle)))
+ (if (eq mm-inline-large-images 'resize)
+ (gnus-rescale-image image
+ (let ((edges (gnus-window-inside-pixel-edges
+ (get-buffer-window (current-buffer)))))
+ (cons (truncate (* mm-inline-large-images-proportion
+ (- (nth 2 edges) (nth 0 edges))))
+ (truncate (* mm-inline-large-images-proportion
+ (- (nth 3 edges) (nth 1 edges)))))))
+ image))
+ b)
(insert "\n\n")
(mm-handle-set-undisplayer
handle
@@ -404,7 +418,7 @@
(buffer-string)))))
(defun mm-inline-text-html (handle)
- (let* ((func (or mm-inline-text-html-renderer mm-text-html-renderer))
+ (let* ((func mm-text-html-renderer)
(entry (assq func mm-text-html-renderer-alist))
(inhibit-read-only t))
(if entry
@@ -639,9 +653,9 @@
(t
(error "Could not identify PKCS#7 type")))))
-(defun mm-view-pkcs7 (handle)
+(defun mm-view-pkcs7 (handle &optional from)
(case (mm-view-pkcs7-get-type handle)
- (enveloped (mm-view-pkcs7-decrypt handle))
+ (enveloped (mm-view-pkcs7-decrypt handle from))
(signed (mm-view-pkcs7-verify handle))
(otherwise (error "Unknown or unimplemented PKCS#7 type"))))
@@ -666,7 +680,7 @@
(replace-match "\n"))
t)
-(defun mm-view-pkcs7-decrypt (handle)
+(defun mm-view-pkcs7-decrypt (handle &optional from)
(insert-buffer-substring (mm-handle-buffer handle))
(goto-char (point-min))
(insert "MIME-Version: 1.0\n")
@@ -676,11 +690,10 @@
(if (= (length smime-keys) 1)
(cadar smime-keys)
(smime-get-key-by-email
- (completing-read
- (concat "Decipher using key"
- (if smime-keys (concat "(default " (caar smime-keys) "): ")
- ": "))
- smime-keys nil nil nil nil (car-safe (car-safe smime-keys))))))
+ (gnus-completing-read
+ "Decipher using key"
+ smime-keys nil nil nil (car-safe (car-safe smime-keys)))))
+ from)
(goto-char (point-min))
(while (search-forward "\r\n" nil t)
(replace-match "\n"))
@@ -688,5 +701,4 @@
(provide 'mm-view)
-;; arch-tag: b60e749a-d05c-47f2-bccd-bdaa59327cb2
;;; mm-view.el ends here
diff --git a/lisp/gnus/mml-sec.el b/lisp/gnus/mml-sec.el
index 98142298c04..267f6483d24 100644
--- a/lisp/gnus/mml-sec.el
+++ b/lisp/gnus/mml-sec.el
@@ -26,10 +26,6 @@
(eval-when-compile (require 'cl))
-(if (locate-library "password-cache")
- (require 'password-cache)
- (require 'password))
-
(autoload 'mml2015-sign "mml2015")
(autoload 'mml2015-encrypt "mml2015")
(autoload 'mml1991-sign "mml1991")
@@ -109,12 +105,18 @@ details."
:group 'message
:type 'boolean)
-(defcustom mml-secure-cache-passphrase password-cache
+(defcustom mml-secure-cache-passphrase
+ (if (boundp 'password-cache)
+ password-cache
+ t)
"If t, cache passphrase."
:group 'message
:type 'boolean)
-(defcustom mml-secure-passphrase-cache-expiry password-cache-expiry
+(defcustom mml-secure-passphrase-cache-expiry
+ (if (boundp 'password-cache-expiry)
+ password-cache-expiry
+ 16)
"How many seconds the passphrase is cached.
Whether the passphrase is cached at all is controlled by
`mml-secure-cache-passphrase'."
@@ -306,11 +308,11 @@ Use METHOD if given. Else use `mml-secure-method' or
(defun mml-secure-message-sign (&optional method)
- "Add MML tags to sign this MML part.
+ "Add MML tags to sign the entire message.
Use METHOD if given. Else use `mml-secure-method' or
`mml-default-sign-method'."
(interactive)
- (mml-secure-part
+ (mml-secure-message
(or method mml-secure-method mml-default-sign-method)
'sign))
@@ -378,5 +380,4 @@ If called with a prefix argument, only encrypt (do NOT sign)."
(provide 'mml-sec)
-;; arch-tag: 111c56e7-df5e-4287-87d7-93ed2911ec6c
;;; mml-sec.el ends here
diff --git a/lisp/gnus/mml-smime.el b/lisp/gnus/mml-smime.el
index a4541ac5dec..33050fecaee 100644
--- a/lisp/gnus/mml-smime.el
+++ b/lisp/gnus/mml-smime.el
@@ -25,7 +25,7 @@
;;; Code:
-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
@@ -53,11 +53,6 @@
mml-smime-epg-verify
mml-smime-epg-verify-test)))
-(defcustom mml-smime-verbose mml-secure-verbose
- "If non-nil, ask the user about the current operation more verbosely."
- :group 'mime-security
- :type 'boolean)
-
(defcustom mml-smime-cache-passphrase mml-secure-cache-passphrase
"If t, cache passphrase."
:group 'mime-security
@@ -166,10 +161,10 @@ Whether the passphrase is cached at all is controlled by
"")))))
(and from (smime-get-key-by-email from)))
(smime-get-key-by-email
- (completing-read "Sign this part with what signature? "
- smime-keys nil nil
- (and (listp (car-safe smime-keys))
- (caar smime-keys))))))))
+ (gnus-completing-read "Sign this part with what signature"
+ (mapcar 'car smime-keys) nil nil nil
+ (and (listp (car-safe smime-keys))
+ (caar smime-keys))))))))
(defun mml-smime-get-file-cert ()
(ignore-errors
@@ -218,15 +213,16 @@ Whether the passphrase is cached at all is controlled by
(quit))
result))
-(autoload 'gnus-completing-read-with-default "gnus-util")
+(autoload 'gnus-completing-read "gnus-util")
(defun mml-smime-openssl-encrypt-query ()
;; todo: try dns/ldap automatically first, before prompting user
(let (certs done)
(while (not done)
- (ecase (read (gnus-completing-read-with-default
- "ldap" "Fetch certificate from"
- '(("dns") ("ldap") ("file")) nil t))
+ (ecase (read (gnus-completing-read
+ "Fetch certificate from"
+ '("dns" "ldap" "file") t nil nil
+ "ldap"))
(dns (setq certs (append certs
(mml-smime-get-dns-cert))))
(ldap (setq certs (append certs
@@ -520,10 +516,14 @@ Content-Disposition: attachment; filename=smime.p7m
ctl 'protocol)
"application/pkcs7-signature")
t)))
- (null (setq signature (mm-find-part-by-type
- (cdr handle)
- "application/pkcs7-signature"
- nil t))))
+ (null (setq signature (or (mm-find-part-by-type
+ (cdr handle)
+ "application/pkcs7-signature"
+ nil t)
+ (mm-find-part-by-type
+ (cdr handle)
+ "application/x-pkcs7-signature"
+ nil t)))))
(mm-set-handle-multipart-parameter
mm-security-handle 'gnus-info "Corrupted")
(throw 'error handle))
@@ -550,5 +550,4 @@ Content-Disposition: attachment; filename=smime.p7m
(provide 'mml-smime)
-;; arch-tag: f1bf94d4-f2cd-4c6f-b059-ad69492817e2
;;; mml-smime.el ends here
diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el
index 091a0ed90bd..7dc6b76afae 100644
--- a/lisp/gnus/mml.el
+++ b/lisp/gnus/mml.el
@@ -23,7 +23,7 @@
;;; Code:
-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
@@ -33,10 +33,14 @@
(require 'mm-decode)
(require 'mml-sec)
(eval-when-compile (require 'cl))
+(eval-when-compile
+ (when (featurep 'xemacs)
+ (require 'easy-mmode))) ; for `define-minor-mode'
(autoload 'message-make-message-id "message")
-(autoload 'gnus-setup-posting-charset "gnus-msg")
+(declare-function gnus-setup-posting-charset "gnus-msg" (group))
(autoload 'gnus-make-local-hook "gnus-util")
+(autoload 'gnus-completing-read "gnus-util")
(autoload 'message-fetch-field "message")
(autoload 'message-mark-active-p "message")
(autoload 'message-info "message")
@@ -117,10 +121,18 @@ match found will be used."
,dispositions))))
:group 'message)
-(defcustom mml-insert-mime-headers-always nil
+(defcustom mml-insert-mime-headers-always t
"If non-nil, always put Content-Type: text/plain at top of empty parts.
It is necessary to work against a bug in certain clients."
- :version "22.1"
+ :version "24.1"
+ :type 'boolean
+ :group 'message)
+
+(defcustom mml-enable-flowed t
+ "If non-nil, enable format=flowed usage when encoding a message.
+This is only performed when filling on text/plain with hard
+newlines in the text."
+ :version "24.1"
:type 'boolean
:group 'message)
@@ -225,7 +237,10 @@ part. This is for the internal use, you should never modify the value.")
(let* (secure-mode
(taginfo (mml-read-tag))
(keyfile (cdr (assq 'keyfile taginfo)))
- (certfile (cdr (assq 'certfile taginfo)))
+ (certfiles (delq nil (mapcar (lambda (tag)
+ (if (eq (car-safe tag) 'certfile)
+ (cdr tag)))
+ taginfo)))
(recipients (cdr (assq 'recipients taginfo)))
(sender (cdr (assq 'sender taginfo)))
(location (cdr (assq 'tag-location taginfo)))
@@ -251,8 +266,10 @@ part. This is for the internal use, you should never modify the value.")
,@tags
,(if keyfile "keyfile")
,keyfile
- ,(if certfile "certfile")
- ,certfile
+ ,@(apply #'append
+ (mapcar (lambda (certfile)
+ (list "certfile" certfile))
+ certfiles))
,(if recipients "recipients")
,recipients
,(if sender "sender")
@@ -392,8 +409,8 @@ A message part needs to be split into %d charset parts. Really send? "
(skip-chars-forward "= \t\n")
(setq val (buffer-substring-no-properties
(point) (progn (forward-sexp 1) (point))))
- (when (string-match "^\"\\(.*\\)\"$" val)
- (setq val (match-string 1 val)))
+ (when (string-match "\\`\"" val)
+ (setq val (read val))) ;; inverse of prin1 in mml-insert-tag
(push (cons (intern elem) val) contents)
(skip-chars-forward " \t\n"))
(goto-char (match-end 0))
@@ -520,7 +537,10 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
;; `m-g-d-t' will be bound to "message/rfc822"
;; when encoding an article to be forwarded.
(mml-generate-default-type "text/plain"))
- (mml-to-mime))
+ (mml-to-mime)
+ ;; Update handle so mml-compute-boundary can
+ ;; detect collisions with the nested parts.
+ (setcdr (assoc 'contents cont) (buffer-string)))
(let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
;; ignore 0x1b, it is part of iso-2022-jp
(setq encoding (mm-body-7-or-8))))
@@ -534,7 +554,8 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
;; in the mml tag or it says "flowed" and there
;; actually are hard newlines in the text.
(let (use-hard-newlines)
- (when (and (string= type "text/plain")
+ (when (and mml-enable-flowed
+ (string= type "text/plain")
(not (string= (cdr (assq 'sign cont)) "pgp"))
(or (null (assq 'format cont))
(string= (cdr (assq 'format cont))
@@ -699,7 +720,7 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
(defun mml-compute-boundary-1 (cont)
(let (filename)
(cond
- ((eq (car cont) 'part)
+ ((member (car cont) '(part mml))
(with-temp-buffer
(cond
((cdr (assq 'buffer cont))
@@ -898,8 +919,7 @@ If HANDLES is non-nil, use it instead reparsing the buffer."
;; Determine type and stuff.
(unless (stringp (car handle))
(unless (setq textp (equal (mm-handle-media-supertype handle) "text"))
- (save-excursion
- (set-buffer (setq buffer (mml-generate-new-buffer " *mml*")))
+ (with-current-buffer (setq buffer (mml-generate-new-buffer " *mml*"))
(if (eq (mail-content-type-get (mm-handle-type handle) 'charset)
'gnus-decoded)
;; A part that mm-uu dissected from a non-MIME message
@@ -1126,25 +1146,18 @@ If HANDLES is non-nil, use it instead reparsing the buffer."
,@(if (featurep 'xemacs) '(t)
'(:help "Display the EasyPG manual"))]))
-(defvar mml-mode nil
- "Minor mode for editing MML.")
-
-(defun mml-mode (&optional arg)
+(define-minor-mode mml-mode
"Minor mode for editing MML.
MML is the MIME Meta Language, a minor mode for composing MIME articles.
See Info node `(emacs-mime)Composing'.
\\{mml-mode-map}"
- (interactive "P")
- (when (set (make-local-variable 'mml-mode)
- (if (null arg) (not mml-mode)
- (> (prefix-numeric-value arg) 0)))
- (add-minor-mode 'mml-mode " MML" mml-mode-map)
+ :lighter " MML" :keymap mml-mode-map
+ (when mml-mode
(easy-menu-add mml-menu mml-mode-map)
(when (boundp 'dnd-protocol-alist)
(set (make-local-variable 'dnd-protocol-alist)
- (append mml-dnd-protocol-alist dnd-protocol-alist)))
- (run-hooks 'mml-mode-hook)))
+ (append mml-dnd-protocol-alist dnd-protocol-alist)))))
;;;
;;; Helper functions for reading MIME stuff from the minibuffer and
@@ -1173,7 +1186,11 @@ If not set, `default-directory' will be used."
(error "Permission denied: %s" file))
file))
+(declare-function mailcap-parse-mimetypes "mailcap" (&optional path force))
+(declare-function mailcap-mime-types "mailcap" ())
+
(defun mml-minibuffer-read-type (name &optional default)
+ (require 'mailcap)
(mailcap-parse-mimetypes)
(let* ((default (or default
(mm-default-file-encoding name)
@@ -1181,9 +1198,10 @@ If not set, `default-directory' will be used."
;; looks like, and offer text/plain if it looks
;; like text/plain.
"application/octet-stream"))
- (string (completing-read
- (format "Content type (default %s): " default)
- (mapcar 'list (mailcap-mime-types)))))
+ (string (gnus-completing-read
+ "Content type"
+ (mailcap-mime-types)
+ nil nil nil default)))
(if (not (equal string ""))
string
default)))
@@ -1197,10 +1215,10 @@ If not set, `default-directory' will be used."
(defun mml-minibuffer-read-disposition (type &optional default filename)
(unless default
(setq default (mml-content-disposition type filename)))
- (let ((disposition (completing-read
- (format "Disposition (default %s): " default)
- '(("attachment") ("inline") (""))
- nil t nil nil default)))
+ (let ((disposition (gnus-completing-read
+ "Disposition"
+ '("attachment" "inline")
+ t nil nil default)))
(if (not (equal disposition ""))
disposition
default)))
@@ -1388,11 +1406,11 @@ TYPE is the MIME type to use."
(defun mml-insert-multipart (&optional type)
(interactive (if (message-in-body-p)
- (list (completing-read "Multipart type (default mixed): "
- '(("mixed") ("alternative")
- ("digest") ("parallel")
- ("signed") ("encrypted"))
- nil nil "mixed"))
+ (list (gnus-completing-read "Multipart type"
+ '("mixed" "alternative"
+ "digest" "parallel"
+ "signed" "encrypted")
+ nil "mixed"))
(error "Use this command in the message body")))
(or type
(setq type "mixed"))
@@ -1445,8 +1463,10 @@ or the `pop-to-buffer' function."
(setq mml-preview-buffer (generate-new-buffer
(concat (if raw "*Raw MIME preview of "
"*MIME preview of ") (buffer-name))))
+ (require 'gnus-msg) ; for gnus-setup-posting-charset
(save-excursion
(let* ((buf (current-buffer))
+ (article-editing (eq major-mode 'gnus-article-edit-mode))
(message-options message-options)
(message-this-is-mail (message-mail-p))
(message-this-is-news (message-news-p))
@@ -1466,15 +1486,19 @@ or the `pop-to-buffer' function."
(mml-preview-insert-mail-followup-to)
(let ((message-deletable-headers (if (message-news-p)
nil
- message-deletable-headers)))
+ message-deletable-headers))
+ (mail-header-separator (if article-editing
+ ""
+ mail-header-separator)))
(message-generate-headers
(copy-sequence (if (message-news-p)
message-required-news-headers
- message-required-mail-headers))))
- (if (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
- (replace-match "\n"))
- (let ((mail-header-separator ""));; mail-header-separator is removed.
+ message-required-mail-headers)))
+ (unless article-editing
+ (if (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
+ (replace-match "\n"))
+ (setq mail-header-separator ""))
(message-sort-headers)
(mml-to-mime))
(if raw
@@ -1485,7 +1509,8 @@ or the `pop-to-buffer' function."
(mm-disable-multibyte)
(insert s)))
(let ((gnus-newsgroup-charset (car message-posting-charset))
- gnus-article-prepare-hook gnus-original-article-buffer)
+ gnus-article-prepare-hook gnus-original-article-buffer
+ gnus-displaying-mime)
(run-hooks 'gnus-article-decode-hook)
(let ((gnus-newsgroup-name "dummy")
(gnus-newsrc-hashtb (or gnus-newsrc-hashtb
@@ -1562,5 +1587,4 @@ or the `pop-to-buffer' function."
(provide 'mml)
-;; arch-tag: 583c96cf-1ffe-451b-a5e5-4733ae9ddd12
;;; mml.el ends here
diff --git a/lisp/gnus/mml1991.el b/lisp/gnus/mml1991.el
index c523dccc055..98e7903b015 100644
--- a/lisp/gnus/mml1991.el
+++ b/lisp/gnus/mml1991.el
@@ -26,9 +26,13 @@
;;; Code:
-;; For Emacs < 22.2.
(eval-and-compile
- (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
+ ;; For Emacs <22.2 and XEmacs.
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
+
+ (if (locate-library "password-cache")
+ (require 'password-cache)
+ (require 'password)))
(eval-when-compile
(require 'cl)
@@ -53,17 +57,12 @@
(defvar mml1991-function-alist
'((mailcrypt mml1991-mailcrypt-sign
mml1991-mailcrypt-encrypt)
- (gpg mml1991-gpg-sign
- mml1991-gpg-encrypt)
(pgg mml1991-pgg-sign
mml1991-pgg-encrypt)
(epg mml1991-epg-sign
mml1991-epg-encrypt))
"Alist of PGP functions.")
-(defvar mml1991-verbose mml-secure-verbose
- "If non-nil, ask the user about the current operation more verbosely.")
-
(defvar mml1991-cache-passphrase mml-secure-cache-passphrase
"If t, cache passphrase.")
@@ -141,6 +140,7 @@ Whether the passphrase is cached at all is controlled by
(delete-region (point-min) (point)))
(mm-with-unibyte-current-buffer
(with-temp-buffer
+ (inline (mm-disable-multibyte))
(setq cipher (current-buffer))
(insert-buffer-substring text)
(unless (mc-encrypt-generic
@@ -166,98 +166,6 @@ Whether the passphrase is cached at all is controlled by
(insert-buffer-substring cipher)
(goto-char (point-max))))))
-;;; gpg wrapper
-
-(autoload 'gpg-sign-cleartext "gpg")
-
-(declare-function gpg-sign-encrypt "ext:gpg"
- (plaintext ciphertext result recipients &optional
- passphrase sign-with-key armor textmode))
-(declare-function gpg-encrypt "ext:gpg"
- (plaintext ciphertext result recipients &optional
- passphrase armor textmode))
-
-(defun mml1991-gpg-sign (cont)
- (let ((text (current-buffer))
- headers signature
- (result-buffer (get-buffer-create "*GPG Result*")))
- ;; Save MIME Content[^ ]+: headers from signing
- (goto-char (point-min))
- (while (looking-at "^Content[^ ]+:") (forward-line))
- (unless (bobp)
- (setq headers (buffer-string))
- (delete-region (point-min) (point)))
- (goto-char (point-max))
- (unless (bolp)
- (insert "\n"))
- (quoted-printable-decode-region (point-min) (point-max))
- (with-temp-buffer
- (unless (gpg-sign-cleartext text (setq signature (current-buffer))
- result-buffer
- nil
- (message-options-get 'message-sender))
- (unless (> (point-max) (point-min))
- (pop-to-buffer result-buffer)
- (error "Sign error")))
- (goto-char (point-min))
- (while (re-search-forward "\r+$" nil t)
- (replace-match "" t t))
- (quoted-printable-encode-region (point-min) (point-max))
- (set-buffer text)
- (delete-region (point-min) (point-max))
- (if headers (insert headers))
- (insert "\n")
- (insert-buffer-substring signature)
- (goto-char (point-max)))))
-
-(defun mml1991-gpg-encrypt (cont &optional sign)
- (let ((text (current-buffer))
- cipher
- (result-buffer (get-buffer-create "*GPG Result*")))
- ;; Strip MIME Content[^ ]: headers since it will be ASCII ARMORED
- (goto-char (point-min))
- (while (looking-at "^Content[^ ]+:") (forward-line))
- (unless (bobp)
- (delete-region (point-min) (point)))
- (mm-with-unibyte-current-buffer
- (with-temp-buffer
- (flet ((gpg-encrypt-func
- (sign plaintext ciphertext result recipients &optional
- passphrase sign-with-key armor textmode)
- (if sign
- (gpg-sign-encrypt
- plaintext ciphertext result recipients passphrase
- sign-with-key armor textmode)
- (gpg-encrypt
- plaintext ciphertext result recipients passphrase
- armor textmode))))
- (unless (gpg-encrypt-func
- sign
- text (setq cipher (current-buffer))
- result-buffer
- (split-string
- (or
- (message-options-get 'message-recipients)
- (message-options-set 'message-recipients
- (read-string "Recipients: ")))
- "[ \f\t\n\r\v,]+")
- nil
- (message-options-get 'message-sender)
- t t) ; armor & textmode
- (unless (> (point-max) (point-min))
- (pop-to-buffer result-buffer)
- (error "Encrypt error"))))
- (goto-char (point-min))
- (while (re-search-forward "\r+$" nil t)
- (replace-match "" t t))
- (set-buffer text)
- (delete-region (point-min) (point-max))
- ;;(insert "Content-Type: application/pgp-encrypted\n\n")
- ;;(insert "Version: 1\n\n")
- (insert "\n")
- (insert-buffer-substring cipher)
- (goto-char (point-max))))))
-
;; pgg wrapper
(defvar pgg-default-user-id)
@@ -329,7 +237,6 @@ Whether the passphrase is cached at all is controlled by
;; epg wrapper
(defvar epg-user-id-alist)
-(defvar password-cache-expiry)
(autoload 'epg-make-context "epg")
(autoload 'epg-passphrase-callback-function "epg")
@@ -516,5 +423,4 @@ If no one is selected, default secret key is used. "
;; coding: iso-8859-1
;; End:
-;; arch-tag: e542be18-ab28-4393-9b33-97fe9cf30706
;;; mml1991.el ends here
diff --git a/lisp/gnus/mml2015.el b/lisp/gnus/mml2015.el
index 65cf1a8f426..e247abbb476 100644
--- a/lisp/gnus/mml2015.el
+++ b/lisp/gnus/mml2015.el
@@ -28,9 +28,13 @@
;;; Code:
-;; For Emacs < 22.2.
(eval-and-compile
- (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
+ ;; For Emacs <22.2 and XEmacs.
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
+
+ (if (locate-library "password-cache")
+ (require 'password-cache)
+ (require 'password)))
(eval-when-compile (require 'cl))
(require 'mm-decode)
@@ -52,18 +56,9 @@
'epg)
(error))
(progn
- (ignore-errors
- ;; Avoid the "Recursive load suspected" error
- ;; in Emacs 21.1.
- (let ((recursive-load-depth-limit 100))
- (require 'pgg)))
+ (ignore-errors (require 'pgg))
(and (fboundp 'pgg-sign-region)
'pgg))
- (progn
- (ignore-errors
- (require 'gpg))
- (and (fboundp 'gpg-sign-detached)
- 'gpg))
(progn (ignore-errors
(load "mc-toplev"))
(and (fboundp 'mc-encrypt-generic)
@@ -71,7 +66,7 @@
(fboundp 'mc-cleanup-recipient-headers)
'mailcrypt)))
"The package used for PGP/MIME.
-Valid packages include `epg', `pgg', `gpg' and `mailcrypt'.")
+Valid packages include `epg', `pgg' and `mailcrypt'.")
;; Something is not RFC2015.
(defvar mml2015-function-alist
@@ -81,24 +76,18 @@ Valid packages include `epg', `pgg', `gpg' and `mailcrypt'.")
mml2015-mailcrypt-decrypt
mml2015-mailcrypt-clear-verify
mml2015-mailcrypt-clear-decrypt)
- (gpg mml2015-gpg-sign
- mml2015-gpg-encrypt
- mml2015-gpg-verify
- mml2015-gpg-decrypt
- mml2015-gpg-clear-verify
- mml2015-gpg-clear-decrypt)
- (pgg mml2015-pgg-sign
- mml2015-pgg-encrypt
- mml2015-pgg-verify
- mml2015-pgg-decrypt
- mml2015-pgg-clear-verify
- mml2015-pgg-clear-decrypt)
- (epg mml2015-epg-sign
- mml2015-epg-encrypt
- mml2015-epg-verify
- mml2015-epg-decrypt
- mml2015-epg-clear-verify
- mml2015-epg-clear-decrypt))
+ (pgg mml2015-pgg-sign
+ mml2015-pgg-encrypt
+ mml2015-pgg-verify
+ mml2015-pgg-decrypt
+ mml2015-pgg-clear-verify
+ mml2015-pgg-clear-decrypt)
+ (epg mml2015-epg-sign
+ mml2015-epg-encrypt
+ mml2015-epg-verify
+ mml2015-epg-decrypt
+ mml2015-epg-clear-verify
+ mml2015-epg-clear-decrypt))
"Alist of PGP/MIME functions.")
(defvar mml2015-result-buffer nil)
@@ -115,11 +104,6 @@ Valid packages include `epg', `pgg', `gpg' and `mailcrypt'.")
:type '(repeat (cons (regexp :tag "GnuPG output regexp")
(boolean :tag "Trust key"))))
-(defcustom mml2015-verbose mml-secure-verbose
- "If non-nil, ask the user about the current operation more verbosely."
- :group 'mime-security
- :type 'boolean)
-
(defcustom mml2015-cache-passphrase mml-secure-cache-passphrase
"If t, cache passphrase."
:group 'mime-security
@@ -149,7 +133,7 @@ Whether the passphrase is cached at all is controlled by
;; Extract plaintext from cleartext signature. IMO, this kind of task
;; should be done by GnuPG rather than Elisp, but older PGP backends
-;; (such as Mailcrypt, PGG, and gpg.el) discard the output from GnuPG.
+;; (such as Mailcrypt, and PGG) discard the output from GnuPG.
(defun mml2015-extract-cleartext-signature ()
;; Daiki Ueno in
;; <54a15d860801080142l70b95d7dkac4bf51a86196011@mail.gmail.com>: ``I still
@@ -189,9 +173,6 @@ Whether the passphrase is cached at all is controlled by
(autoload 'mc-cleanup-recipient-headers "mc-toplev")
(autoload 'mc-sign-generic "mc-toplev")
-(defvar mc-default-scheme)
-(defvar mc-schemes)
-
(defvar mml2015-decrypt-function 'mailcrypt-decrypt)
(defvar mml2015-verify-function 'mailcrypt-verify)
@@ -238,6 +219,58 @@ Whether the passphrase is cached at all is controlled by
handles
(list handles)))))
+(defun mml2015-gpg-pretty-print-fpr (fingerprint)
+ (let* ((result "")
+ (fpr-length (string-width fingerprint))
+ (n-slice 0)
+ slice)
+ (setq fingerprint (string-to-list fingerprint))
+ (while fingerprint
+ (setq fpr-length (- fpr-length 4))
+ (setq slice (butlast fingerprint fpr-length))
+ (setq fingerprint (nthcdr 4 fingerprint))
+ (setq n-slice (1+ n-slice))
+ (setq result
+ (concat
+ result
+ (case n-slice
+ (1 slice)
+ (otherwise (concat " " slice))))))
+ result))
+
+(defun mml2015-gpg-extract-signature-details ()
+ (goto-char (point-min))
+ (let* ((expired (re-search-forward
+ "^\\[GNUPG:\\] SIGEXPIRED$"
+ nil t))
+ (signer (and (re-search-forward
+ "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
+ nil t)
+ (cons (match-string 1) (match-string 2))))
+ (fprint (and (re-search-forward
+ "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
+ nil t)
+ (match-string 1)))
+ (trust (and (re-search-forward
+ "^\\[GNUPG:\\] \\(TRUST_.*\\)$"
+ nil t)
+ (match-string 1)))
+ (trust-good-enough-p
+ (cdr (assoc trust mml2015-unabbrev-trust-alist))))
+ (cond ((and signer fprint)
+ (concat (cdr signer)
+ (unless trust-good-enough-p
+ (concat "\nUntrusted, Fingerprint: "
+ (mml2015-gpg-pretty-print-fpr fprint)))
+ (when expired
+ (format "\nWARNING: Signature from expired key (%s)"
+ (car signer)))))
+ ((re-search-forward
+ "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t)
+ (match-string 2))
+ (t
+ "From unknown user"))))
+
(defun mml2015-mailcrypt-clear-decrypt ()
(let (result)
(setq result
@@ -450,279 +483,6 @@ Whether the passphrase is cached at all is controlled by
(insert (format "--%s--\n" boundary))
(goto-char (point-max))))
-;;; gpg wrapper
-
-(autoload 'gpg-decrypt "gpg")
-(autoload 'gpg-verify "gpg")
-(autoload 'gpg-verify-cleartext "gpg")
-(autoload 'gpg-sign-detached "gpg")
-(autoload 'gpg-sign-encrypt "gpg")
-(autoload 'gpg-encrypt "gpg")
-(autoload 'gpg-passphrase-read "gpg")
-
-(defun mml2015-gpg-passphrase ()
- (or (message-options-get 'gpg-passphrase)
- (message-options-set 'gpg-passphrase (gpg-passphrase-read))))
-
-(defun mml2015-gpg-decrypt-1 ()
- (let ((cipher (current-buffer)) plain result)
- (if (with-temp-buffer
- (prog1
- (gpg-decrypt cipher (setq plain (current-buffer))
- mml2015-result-buffer nil)
- (mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-details
- (with-current-buffer mml2015-result-buffer
- (buffer-string)))
- (set-buffer cipher)
- (erase-buffer)
- (insert-buffer-substring plain)
- (goto-char (point-min))
- (while (search-forward "\r\n" nil t)
- (replace-match "\n" t t))))
- '(t)
- ;; Some wrong with the return value, check plain text buffer.
- (if (> (point-max) (point-min))
- '(t)
- nil))))
-
-(defun mml2015-gpg-decrypt (handle ctl)
- (let ((mml2015-decrypt-function 'mml2015-gpg-decrypt-1))
- (mml2015-mailcrypt-decrypt handle ctl)))
-
-(defun mml2015-gpg-clear-decrypt ()
- (let (result)
- (setq result (mml2015-gpg-decrypt-1))
- (if (car result)
- (mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-info "OK")
- (mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-info "Failed"))))
-
-(defun mml2015-gpg-pretty-print-fpr (fingerprint)
- (let* ((result "")
- (fpr-length (string-width fingerprint))
- (n-slice 0)
- slice)
- (setq fingerprint (string-to-list fingerprint))
- (while fingerprint
- (setq fpr-length (- fpr-length 4))
- (setq slice (butlast fingerprint fpr-length))
- (setq fingerprint (nthcdr 4 fingerprint))
- (setq n-slice (1+ n-slice))
- (setq result
- (concat
- result
- (case n-slice
- (1 slice)
- (otherwise (concat " " slice))))))
- result))
-
-(defun mml2015-gpg-extract-signature-details ()
- (goto-char (point-min))
- (let* ((expired (re-search-forward
- "^\\[GNUPG:\\] SIGEXPIRED$"
- nil t))
- (signer (and (re-search-forward
- "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
- nil t)
- (cons (match-string 1) (match-string 2))))
- (fprint (and (re-search-forward
- "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
- nil t)
- (match-string 1)))
- (trust (and (re-search-forward
- "^\\[GNUPG:\\] \\(TRUST_.*\\)$"
- nil t)
- (match-string 1)))
- (trust-good-enough-p
- (cdr (assoc trust mml2015-unabbrev-trust-alist))))
- (cond ((and signer fprint)
- (concat (cdr signer)
- (unless trust-good-enough-p
- (concat "\nUntrusted, Fingerprint: "
- (mml2015-gpg-pretty-print-fpr fprint)))
- (when expired
- (format "\nWARNING: Signature from expired key (%s)"
- (car signer)))))
- ((re-search-forward
- "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t)
- (match-string 2))
- (t
- "From unknown user"))))
-
-(defun mml2015-gpg-verify (handle ctl)
- (catch 'error
- (let (part message signature info-is-set-p)
- (unless (setq part (mm-find-raw-part-by-type
- ctl (or (mm-handle-multipart-ctl-parameter
- ctl 'protocol)
- "application/pgp-signature")
- t))
- (mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-info "Corrupted")
- (throw 'error handle))
- (with-temp-buffer
- (setq message (current-buffer))
- (insert part)
- ;; Convert <LF> to <CR><LF> in signed text. If --textmode is
- ;; specified when signing, the conversion is not necessary.
- (goto-char (point-min))
- (end-of-line)
- (while (not (eobp))
- (unless (eq (char-before) ?\r)
- (insert "\r"))
- (forward-line)
- (end-of-line))
- (with-temp-buffer
- (setq signature (current-buffer))
- (unless (setq part (mm-find-part-by-type
- (cdr handle) "application/pgp-signature" nil t))
- (mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-info "Corrupted")
- (throw 'error handle))
- (mm-insert-part part)
- (unless (condition-case err
- (prog1
- (gpg-verify message signature mml2015-result-buffer)
- (mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-details
- (with-current-buffer mml2015-result-buffer
- (buffer-string))))
- (error
- (mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-details (mml2015-format-error err))
- (mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-info "Error.")
- (setq info-is-set-p t)
- nil)
- (quit
- (mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-details "Quit.")
- (mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-info "Quit.")
- (setq info-is-set-p t)
- nil))
- (unless info-is-set-p
- (mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-info "Failed"))
- (throw 'error handle)))
- (mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-info
- (with-current-buffer mml2015-result-buffer
- (mml2015-gpg-extract-signature-details))))
- handle)))
-
-(defun mml2015-gpg-clear-verify ()
- (if (condition-case err
- (prog1
- (gpg-verify-cleartext (current-buffer) mml2015-result-buffer)
- (mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-details
- (with-current-buffer mml2015-result-buffer
- (buffer-string))))
- (error
- (mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-details (mml2015-format-error err))
- nil)
- (quit
- (mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-details "Quit.")
- nil))
- (mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-info
- (with-current-buffer mml2015-result-buffer
- (mml2015-gpg-extract-signature-details)))
- (mm-set-handle-multipart-parameter
- mm-security-handle 'gnus-info "Failed"))
- (mml2015-extract-cleartext-signature))
-
-(defun mml2015-gpg-sign (cont)
- (let ((boundary (mml-compute-boundary cont))
- (text (current-buffer)) signature)
- (goto-char (point-max))
- (unless (bolp)
- (insert "\n"))
- (with-temp-buffer
- (unless (gpg-sign-detached text (setq signature (current-buffer))
- mml2015-result-buffer
- nil
- (message-options-get 'message-sender)
- t t) ; armor & textmode
- (unless (> (point-max) (point-min))
- (pop-to-buffer mml2015-result-buffer)
- (error "Sign error")))
- (goto-char (point-min))
- (while (re-search-forward "\r+$" nil t)
- (replace-match "" t t))
- (set-buffer text)
- (goto-char (point-min))
- (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
- boundary))
- ;;; FIXME: what is the micalg?
- (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n")
- (insert (format "\n--%s\n" boundary))
- (goto-char (point-max))
- (insert (format "\n--%s\n" boundary))
- (insert "Content-Type: application/pgp-signature\n\n")
- (insert-buffer-substring signature)
- (goto-char (point-max))
- (insert (format "--%s--\n" boundary))
- (goto-char (point-max)))))
-
-(defun mml2015-gpg-encrypt (cont &optional sign)
- (let ((boundary (mml-compute-boundary cont))
- (text (current-buffer))
- cipher)
- (mm-with-unibyte-current-buffer
- (with-temp-buffer
- ;; set up a function to call the correct gpg encrypt routine
- ;; with the right arguments. (FIXME: this should be done
- ;; differently.)
- (flet ((gpg-encrypt-func
- (sign plaintext ciphertext result recipients &optional
- passphrase sign-with-key armor textmode)
- (if sign
- (gpg-sign-encrypt
- plaintext ciphertext result recipients passphrase
- sign-with-key armor textmode)
- (gpg-encrypt
- plaintext ciphertext result recipients passphrase
- armor textmode))))
- (unless (gpg-encrypt-func
- sign ; passed in when using signencrypt
- text (setq cipher (current-buffer))
- mml2015-result-buffer
- (split-string
- (or
- (message-options-get 'message-recipients)
- (message-options-set 'message-recipients
- (read-string "Recipients: ")))
- "[ \f\t\n\r\v,]+")
- nil
- (message-options-get 'message-sender)
- t t) ; armor & textmode
- (unless (> (point-max) (point-min))
- (pop-to-buffer mml2015-result-buffer)
- (error "Encrypt error"))))
- (goto-char (point-min))
- (while (re-search-forward "\r+$" nil t)
- (replace-match "" t t))
- (set-buffer text)
- (delete-region (point-min) (point-max))
- (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
- boundary))
- (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
- (insert (format "--%s\n" boundary))
- (insert "Content-Type: application/pgp-encrypted\n\n")
- (insert "Version: 1\n\n")
- (insert (format "--%s\n" boundary))
- (insert "Content-Type: application/octet-stream\n\n")
- (insert-buffer-substring cipher)
- (goto-char (point-max))
- (insert (format "--%s--\n" boundary))
- (goto-char (point-max))))))
-
;;; pgg wrapper
(defvar pgg-default-user-id)
@@ -986,8 +746,6 @@ Whether the passphrase is cached at all is controlled by
(autoload 'epg-expand-group "epg-config")
(autoload 'epa-select-keys "epa")
-(defvar password-cache-expiry)
-
(defvar mml2015-epg-secret-key-id-list nil)
(defun mml2015-epg-passphrase-callback (context key-id ignore)
@@ -1019,6 +777,7 @@ Whether the passphrase is cached at all is controlled by
(let ((pointer (epg-key-sub-key-list (car keys))))
(while pointer
(if (and (memq usage (epg-sub-key-capability (car pointer)))
+ (not (memq 'disabled (epg-sub-key-capability (car pointer))))
(not (memq (epg-sub-key-validity (car pointer))
'(revoked expired))))
(throw 'found (car keys)))
@@ -1182,6 +941,7 @@ Whether the passphrase is cached at all is controlled by
(let* ((inhibit-redisplay t)
(context (epg-make-context))
(boundary (mml-compute-boundary cont))
+ (sender (message-options-get 'message-sender))
signer-key
(signers
(or (message-options-get 'mml2015-epg-signers)
@@ -1191,8 +951,8 @@ Whether the passphrase is cached at all is controlled by
(epa-select-keys context "\
Select keys for signing.
If no one is selected, default secret key is used. "
- mml2015-signers t)
- (if mml2015-signers
+ (cons sender mml2015-signers) t)
+ (if (or sender mml2015-signers)
(delq nil
(mapcar
(lambda (signer)
@@ -1206,7 +966,7 @@ If no one is selected, default secret key is used. "
signer)))
(error "No secret key for %s" signer))
signer-key)
- mml2015-signers)))))))
+ (cons sender mml2015-signers))))))))
signature micalg)
(epg-context-set-armor context t)
(epg-context-set-textmode context t)
@@ -1249,6 +1009,7 @@ If no one is selected, default secret key is used. "
(let ((inhibit-redisplay t)
(context (epg-make-context))
(config (epg-configuration))
+ (sender (message-options-get 'message-sender))
(recipients (message-options-get 'mml2015-epg-recipients))
cipher signers
(boundary (mml-compute-boundary cont))
@@ -1266,9 +1027,9 @@ If no one is selected, default secret key is used. "
(read-string "Recipients: ")))
"[ \f\t\n\r\v,]+"))))
(when mml2015-encrypt-to-self
- (unless mml2015-signers
- (error "mml2015-signers not set"))
- (setq recipients (nconc recipients mml2015-signers)))
+ (unless (or sender mml2015-signers)
+ (error "Message sender and mml2015-signers not set"))
+ (setq recipients (nconc recipients (cons sender mml2015-signers))))
(if (eq mm-encrypt-option 'guided)
(setq recipients
(epa-select-keys context "\
@@ -1301,8 +1062,8 @@ If no one is selected, symmetric encryption will be performed. "
(epa-select-keys context "\
Select keys for signing.
If no one is selected, default secret key is used. "
- mml2015-signers t)
- (if mml2015-signers
+ (cons sender mml2015-signers) t)
+ (if (or sender mml2015-signers)
(delq nil
(mapcar
(lambda (signer)
@@ -1316,7 +1077,7 @@ If no one is selected, default secret key is used. "
signer)))
(error "No secret key for %s" signer))
signer-key)
- mml2015-signers)))))))
+ (cons sender mml2015-signers))))))))
(epg-context-set-signers context signers))
(epg-context-set-armor context t)
(epg-context-set-textmode context t)
@@ -1416,5 +1177,4 @@ If no one is selected, default secret key is used. "
(provide 'mml2015)
-;; arch-tag: b04701d5-0b09-44d8-bed8-de901bf435f2
;;; mml2015.el ends here
diff --git a/lisp/gnus/nnagent.el b/lisp/gnus/nnagent.el
index afacb61c3b9..9f75b00bbca 100644
--- a/lisp/gnus/nnagent.el
+++ b/lisp/gnus/nnagent.el
@@ -121,7 +121,7 @@
(deffoo nnagent-request-set-mark (group action server)
(mm-with-unibyte-buffer
(insert "(gnus-agent-synchronize-group-flags \""
- group
+ group
"\" '")
(gnus-pp action)
(insert " \""
@@ -151,7 +151,7 @@
;; Assume that articles with smaller numbers than the first one
;; Agent knows are gone.
(setq first (caar gnus-agent-article-alist))
- (when first
+ (when first
(while (and arts (< (car arts) first))
(pop arts)))
(set-buffer nntp-server-buffer)
@@ -190,9 +190,9 @@
(deffoo nnagent-request-expire-articles (articles group &optional server force)
articles)
-(deffoo nnagent-request-group (group &optional server dont-check)
+(deffoo nnagent-request-group (group &optional server dont-check info)
(nnoo-parent-function 'nnagent 'nnml-request-group
- (list group (nnagent-server server) dont-check)))
+ (list group (nnagent-server server) dont-check info)))
(deffoo nnagent-close-group (group &optional server)
(nnoo-parent-function 'nnagent 'nnml-close-group
@@ -252,6 +252,9 @@
(nnoo-parent-function 'nnagent 'nnml-request-regenerate
(list (nnagent-server server))))
+(deffoo nnagent-retrieve-group-data-early (server infos)
+ nil)
+
;; Use nnml functions for just about everything.
(nnoo-import nnagent
(nnml))
@@ -261,5 +264,4 @@
(provide 'nnagent)
-;; arch-tag: af710b77-f816-4969-af31-6fd94fb42245
;;; nnagent.el ends here
diff --git a/lisp/gnus/nnbabyl.el b/lisp/gnus/nnbabyl.el
index 121dbbda787..6e91517baab 100644
--- a/lisp/gnus/nnbabyl.el
+++ b/lisp/gnus/nnbabyl.el
@@ -1,7 +1,8 @@
;;; nnbabyl.el --- rmail mbox access for Gnus
;; Copyright (C) 1995, 1996, 1997, 1998, 1099, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
@@ -75,8 +76,7 @@
(nnoo-define-basics nnbabyl)
(deffoo nnbabyl-retrieve-headers (articles &optional group server fetch-old)
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(erase-buffer)
(let ((number (length articles))
(count 0)
@@ -136,8 +136,7 @@
;; Restore buffer mode.
(when (and (nnbabyl-server-opened)
nnbabyl-previous-buffer-mode)
- (save-excursion
- (set-buffer nnbabyl-mbox-buffer)
+ (with-current-buffer nnbabyl-mbox-buffer
(narrow-to-region
(caar nnbabyl-previous-buffer-mode)
(cdar nnbabyl-previous-buffer-mode))
@@ -155,8 +154,7 @@
(deffoo nnbabyl-request-article (article &optional newsgroup server buffer)
(nnbabyl-possibly-change-newsgroup newsgroup server)
- (save-excursion
- (set-buffer nnbabyl-mbox-buffer)
+ (with-current-buffer nnbabyl-mbox-buffer
(goto-char (point-min))
(when (search-forward (nnbabyl-article-string article) nil t)
(let (start stop summary-line)
@@ -194,7 +192,7 @@
(cons nnbabyl-current-group article)
(nnbabyl-article-group-number)))))))
-(deffoo nnbabyl-request-group (group &optional server dont-check)
+(deffoo nnbabyl-request-group (group &optional server dont-check info)
(let ((active (cadr (assoc group nnbabyl-group-alist))))
(save-excursion
(cond
@@ -216,8 +214,7 @@
(nnmail-get-new-mail
'nnbabyl
(lambda ()
- (save-excursion
- (set-buffer nnbabyl-mbox-buffer)
+ (with-current-buffer nnbabyl-mbox-buffer
(save-buffer)))
(file-name-directory nnbabyl-mbox-file)
group
@@ -264,8 +261,7 @@
rest)
(nnmail-activate 'nnbabyl)
- (save-excursion
- (set-buffer nnbabyl-mbox-buffer)
+ (with-current-buffer nnbabyl-mbox-buffer
(set-text-properties (point-min) (point-max) nil)
(while (and articles is-old)
(goto-char (point-min))
@@ -308,15 +304,13 @@
result)
(and
(nnbabyl-request-article article group server)
- (save-excursion
- (set-buffer buf)
+ (with-current-buffer buf
(insert-buffer-substring nntp-server-buffer)
(goto-char (point-min))
(while (re-search-forward
"^X-Gnus-Newsgroup:"
(save-excursion (search-forward "\n\n" nil t) (point)) t)
- (delete-region (progn (beginning-of-line) (point))
- (progn (forward-line 1) (point))))
+ (delete-region (point-at-bol) (progn (forward-line 1) (point))))
(setq result (eval accept-form))
(kill-buffer (current-buffer))
result)
@@ -344,7 +338,7 @@
(while (re-search-backward "^X-Gnus-Newsgroup: " beg t)
(delete-region (point) (progn (forward-line 1) (point)))))
(when nnmail-cache-accepted-message-ids
- (nnmail-cache-insert (nnmail-fetch-field "message-id")
+ (nnmail-cache-insert (nnmail-fetch-field "message-id")
group
(nnmail-fetch-field "subject")
(nnmail-fetch-field "from")))
@@ -363,7 +357,7 @@
(insert-buffer-substring buf)
(when last
(when nnmail-cache-accepted-message-ids
- (nnmail-cache-insert (nnmail-fetch-field "message-id")
+ (nnmail-cache-insert (nnmail-fetch-field "message-id")
group
(nnmail-fetch-field "subject")
(nnmail-fetch-field "from")))
@@ -373,8 +367,7 @@
(deffoo nnbabyl-request-replace-article (article group buffer)
(nnbabyl-possibly-change-newsgroup group)
- (save-excursion
- (set-buffer nnbabyl-mbox-buffer)
+ (with-current-buffer nnbabyl-mbox-buffer
(goto-char (point-min))
(if (not (search-forward (nnbabyl-article-string article) nil t))
nil
@@ -388,8 +381,7 @@
;; Delete all articles in GROUP.
(if (not force)
() ; Don't delete the articles.
- (save-excursion
- (set-buffer nnbabyl-mbox-buffer)
+ (with-current-buffer nnbabyl-mbox-buffer
(goto-char (point-min))
;; Delete all articles in this group.
(let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":"))
@@ -409,8 +401,7 @@
(deffoo nnbabyl-request-rename-group (group new-name &optional server)
(nnbabyl-possibly-change-newsgroup group server)
- (save-excursion
- (set-buffer nnbabyl-mbox-buffer)
+ (with-current-buffer nnbabyl-mbox-buffer
(goto-char (point-min))
(let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":"))
(new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":"))
@@ -436,9 +427,7 @@
(defun nnbabyl-delete-mail (&optional force leave-delim)
;; Delete the current X-Gnus-Newsgroup line.
(unless force
- (delete-region
- (progn (beginning-of-line) (point))
- (progn (forward-line 1) (point))))
+ (delete-region (point-at-bol) (progn (forward-line 1) (point))))
;; Beginning of the article.
(save-excursion
(save-restriction
@@ -558,9 +547,8 @@
(defun nnbabyl-create-mbox ()
(unless (file-exists-p nnbabyl-mbox-file)
;; Create a new, empty RMAIL mbox file.
- (save-excursion
- (set-buffer (setq nnbabyl-mbox-buffer
- (create-file-buffer nnbabyl-mbox-file)))
+ (with-current-buffer (setq nnbabyl-mbox-buffer
+ (create-file-buffer nnbabyl-mbox-file))
(setq buffer-file-name nnbabyl-mbox-file)
(insert "BABYL OPTIONS:\n\n\^_")
(nnmail-write-region
@@ -572,8 +560,7 @@
(unless (and nnbabyl-mbox-buffer
(buffer-name nnbabyl-mbox-buffer)
- (save-excursion
- (set-buffer nnbabyl-mbox-buffer)
+ (with-current-buffer nnbabyl-mbox-buffer
(= (buffer-size) (nnheader-file-size nnbabyl-mbox-file))))
;; This buffer has changed since we read it last. Possibly.
(save-excursion
@@ -650,8 +637,7 @@
(while (re-search-forward "^X-Gnus-Newsgroup: \\([^ ]+\\) " nil t)
(if (intern-soft (setq id (match-string 1)) idents)
(progn
- (delete-region (progn (beginning-of-line) (point))
- (progn (forward-line 1) (point)))
+ (delete-region (point-at-bol) (progn (forward-line 1) (point)))
(nnheader-message 7 "Moving %s..." id)
(nnbabyl-save-mail
(nnmail-article-group 'nnbabyl-active-number)))
@@ -663,5 +649,4 @@
(provide 'nnbabyl)
-;; arch-tag: aa7ddedb-8c07-4c0e-beb0-58e795c2b81b
;;; nnbabyl.el ends here
diff --git a/lisp/gnus/nndb.el b/lisp/gnus/nndb.el
deleted file mode 100644
index 2ba7f2901a6..00000000000
--- a/lisp/gnus/nndb.el
+++ /dev/null
@@ -1,325 +0,0 @@
-;;; nndb.el --- nndb access for Gnus
-
-;; Copyright (C) 1997, 1998, 2000, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
-;; Kai Grossjohann <grossjohann@ls6.informatik.uni-dortmund.de>
-;; Joe Hildebrand <joe.hildebrand@ilg.com>
-;; David Blacka <davidb@rwhois.net>
-;; Keywords: news
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; This was based upon Kai Grossjohan's shamessly snarfed code and
-;;; further modified by Joe Hildebrand. It has been updated for Red
-;;; Gnus.
-
-;; TODO:
-;;
-;; * Fix bug where server connection can be lost and impossible to regain
-;; This hasn't happened to me in a while; think it was fixed in Rgnus
-;;
-;; * make it handle different nndb servers seemlessly
-;;
-;; * Optimize expire if FORCE
-;;
-;; * Optimize move (only expire once)
-;;
-;; * Deal with add/deletion of groups
-;;
-;; * make the backend TOUCH an article when marked as expireable (will
-;; make article expire 'expiry' days after that moment).
-
-;;; Code:
-
-;; For Emacs < 22.2.
-(eval-and-compile
- (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
-
-;;-
-;; Register nndb with known select methods.
-
-(require 'gnus-start)
-(unless (assoc "nndb" gnus-valid-select-methods)
- (gnus-declare-backend "nndb" 'mail 'respool 'address 'prompt-address))
-
-(require 'nnmail)
-(require 'nnheader)
-(require 'nntp)
-(eval-when-compile (require 'cl))
-
-;; Declare nndb as derived from nntp
-
-(nnoo-declare nndb nntp)
-
-;; Variables specific to nndb
-
-;;- currently not used but just in case...
-(defvoo nndb-deliver-program "nndel"
- "*The program used to put a message in an NNDB group.")
-
-(defvoo nndb-server-side-expiry nil
- "If t, expiry calculation will occur on the server side.")
-
-(defvoo nndb-set-expire-date-on-mark nil
- "If t, the expiry date for a given article will be set to the time
-it was marked as expireable; otherwise the date will be the time the
-article was posted to nndb")
-
-;; Variables copied from nntp
-
-(defvoo nndb-server-opened-hook '(nntp-send-authinfo-from-file)
- "Like nntp-server-opened-hook."
- nntp-server-opened-hook)
-
-(defvoo nndb-address "localhost"
- "*The name of the NNDB server."
- nntp-address)
-
-(defvoo nndb-port-number 9000
- "*Port number to connect to."
- nntp-port-number)
-
-;; change to 'news if you are actually using nndb for news
-(defvoo nndb-article-type 'mail)
-
-(defvoo nndb-status-string nil "" nntp-status-string)
-
-
-
-(defconst nndb-version "nndb 0.7"
- "Version numbers of this version of NNDB.")
-
-
-;;; Interface functions.
-
-(nnoo-define-basics nndb)
-
-;;------------------------------------------------------------------
-
-;; this function turns the lisp list into a string list. There is
-;; probably a more efficient way to do this.
-(defun nndb-build-article-string (articles)
- (let (art-string art)
- (while articles
- (setq art (pop articles))
- (setq art-string (concat art-string art " ")))
- art-string))
-
-(defun nndb-build-expire-rest-list (total expire)
- (let (art rest)
- (while total
- (setq art (pop total))
- (if (memq art expire)
- ()
- (push art rest)))
- rest))
-
-
-;;
-(deffoo nndb-request-type (group &optional article)
- nndb-article-type)
-
-;; nndb-request-update-info does not exist and is not needed
-
-;; nndb-request-update-mark does not exist; it should be used to TOUCH
-;; articles as they are marked exipirable
-(defun nndb-touch-article (group article)
- (nntp-send-command nil "X-TOUCH" article))
-
-(deffoo nndb-request-update-mark
- (group article mark)
- "Sets the expiry date for ARTICLE in GROUP to now, if the mark is 'E'"
- (if (and nndb-set-expire-date-on-mark (string-equal mark "E"))
- (nndb-touch-article group article))
- mark)
-
-;; nndb-request-create-group -- currently this isn't necessary; nndb
-;; creates groups on demand.
-
-;; todo -- use some other time than the creation time of the article
-;; best is time since article has been marked as expirable
-
-(defun nndb-request-expire-articles-local
- (articles &optional group server force)
- "Let gnus do the date check and issue the delete commands."
- (let (msg art delete-list (num-delete 0) rest)
- (nntp-possibly-change-group group server)
- (while articles
- (setq art (pop articles))
- (nntp-send-command "^\\([23]\\|^423\\).*\n" "X-DATE" art)
- (setq msg (nndb-status-message))
- (if (string-match "^423" msg)
- ()
- (or (string-match "'\\(.+\\)'" msg)
- (error "Not a valid response for X-DATE command: %s"
- msg))
- (if (nnmail-expired-article-p
- group
- (date-to-time (substring msg (match-beginning 1) (match-end 1)))
- force)
- (progn
- (setq delete-list (concat delete-list " " (int-to-string art)))
- (setq num-delete (1+ num-delete)))
- (push art rest))))
- (if (> (length delete-list) 0)
- (progn
- (nnheader-message 5 "Deleting %s article(s) from %s"
- (int-to-string num-delete) group)
- (nntp-send-command "^[23].*\n" "X-DELETE" delete-list))
- )
-
- (nnheader-message 5 "")
- (nconc rest articles)))
-
-(defun nndb-get-remote-expire-response ()
- (let (list)
- (set-buffer nntp-server-buffer)
- (goto-char (point-min))
- (if (looking-at "^[34]")
- ;; x-expire returned error--presume no articles were expirable)
- (setq list nil)
- ;; otherwise, pull all of the following numbers into the list
- (re-search-forward "follows\r?\n?" nil t)
- (while (re-search-forward "^[0-9]+$" nil t)
- (push (string-to-number (match-string 0)) list)))
- list))
-
-(defun nndb-request-expire-articles-remote
- (articles &optional group server force)
- "Let the nndb backend expire articles"
- (let (days art-string delete-list (num-delete 0))
- (nntp-possibly-change-group group server)
-
- ;; first calculate the wait period in days
- (setq days (or (and nnmail-expiry-wait-function
- (funcall nnmail-expiry-wait-function group))
- nnmail-expiry-wait))
- ;; now handle the special cases
- (cond (force
- (setq days 0))
- ((eq days 'never)
- ;; This isn't an expirable group.
- (setq days -1))
- ((eq days 'immediate)
- (setq days 0)))
-
-
- ;; build article string
- (setq art-string (concat days " " (nndb-build-article-string articles)))
- (nntp-send-command "^\.\r?\n\\|^[345].*\n" "X-EXPIRE" art-string)
-
- (setq delete-list (nndb-get-remote-expire-response))
- (setq num-delete (length delete-list))
- (if (> num-delete 0)
- (nnheader-message 5 "Deleting %s article(s) from %s"
- (int-to-string num-delete) group))
-
- (nndb-build-expire-rest-list articles delete-list)))
-
-(deffoo nndb-request-expire-articles
- (articles &optional group server force)
- "Expires ARTICLES from GROUP on SERVER.
-If FORCE, delete regardless of exiration date, otherwise use normal
-expiry mechanism."
- (if nndb-server-side-expiry
- (nndb-request-expire-articles-remote articles group server force)
- (nndb-request-expire-articles-local articles group server force)))
-
-;; _Something_ defines it...
-(declare-function nndb-request-article "nndb" t t)
-
-(deffoo nndb-request-move-article
- (article group server accept-form &optional last move-is-internal)
- "Move ARTICLE (a number) from GROUP on SERVER.
-Evals ACCEPT-FORM in current buffer, where the article is.
-Optional LAST is ignored."
- ;; we guess that the second arg in accept-form is the new group,
- ;; which it will be for nndb, which is all that matters anyway
- (let ((new-group (nth 1 accept-form)) result)
- (nntp-possibly-change-group group server)
-
- ;; use the move command for nndb-to-nndb moves
- (if (string-match "^nndb" new-group)
- (let ((new-group-name (gnus-group-real-name new-group)))
- (nntp-send-command "^[23].*\n" "X-MOVE" article new-group-name)
- (cons new-group article))
- ;; else move normally
- (let ((artbuf (get-buffer-create " *nndb move*")))
- (and
- (nndb-request-article article group server artbuf)
- (save-excursion
- (set-buffer artbuf)
- (insert-buffer-substring nntp-server-buffer)
- (setq result (eval accept-form))
- (kill-buffer (current-buffer))
- result)
- (nndb-request-expire-articles (list article)
- group
- server
- t))
- result)
- )))
-
-(deffoo nndb-request-accept-article (group server &optional last)
- "The article in the current buffer is put into GROUP."
- (nntp-possibly-change-group group server)
- (let (art msg)
- (when (nntp-send-command "^[23].*\r?\n" "ACCEPT" group)
- (nnheader-insert "")
- (nntp-send-buffer "^[23].*\n"))
-
- (set-buffer nntp-server-buffer)
- (setq msg (buffer-string))
- (or (string-match "^\\([0-9]+\\)" msg)
- (error "nndb: %s" msg))
- (setq art (substring msg (match-beginning 1) (match-end 1)))
- (nnheader-message 5 "nndb: accepted %s" art)
- (list art)))
-
-(deffoo nndb-request-replace-article (article group buffer)
- "ARTICLE is the number of the article in GROUP to be replaced with the contents of the BUFFER."
- (set-buffer buffer)
- (when (nntp-send-command "^[23].*\r?\n" "X-REPLACE" (int-to-string article))
- (nnheader-insert "")
- (nntp-send-buffer "^[23.*\n")
- (list (int-to-string article))))
-
- ; nndb-request-delete-group does not exist
- ; todo -- maybe later
-
- ; nndb-request-rename-group does not exist
- ; todo -- maybe later
-
-;; -- standard compatibility functions
-
-(deffoo nndb-status-message (&optional server)
- "Return server status as a string."
- (set-buffer nntp-server-buffer)
- (buffer-string))
-
-;; Import stuff from nntp
-
-(nnoo-import nndb
- (nntp))
-
-(provide 'nndb)
-
-;; arch-tag: 83bd6fb4-58d9-4fed-a901-c6c625ad5f8a
-;;; nndb.el ends here
diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el
index 62a5db6ea3e..e634b9cada3 100644
--- a/lisp/gnus/nndiary.el
+++ b/lisp/gnus/nndiary.el
@@ -380,8 +380,7 @@ all. This may very well take some time.")
(deffoo nndiary-retrieve-headers (sequence &optional group server fetch-old)
(when (nndiary-possibly-change-directory group server)
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(erase-buffer)
(let* ((file nil)
(number (length sequence))
@@ -483,7 +482,7 @@ all. This may very well take some time.")
(cons (if group-num (car group-num) group)
(string-to-number (file-name-nondirectory path)))))))
-(deffoo nndiary-request-group (group &optional server dont-check)
+(deffoo nndiary-request-group (group &optional server dont-check info)
(let ((file-name-coding-system nnmail-pathname-coding-system))
(cond
((not (nndiary-possibly-change-directory group server))
@@ -615,8 +614,7 @@ all. This may very well take some time.")
(let (nndiary-current-directory
nndiary-current-group
nndiary-article-file-alist)
- (save-excursion
- (set-buffer buf)
+ (with-current-buffer buf
(insert-buffer-substring nntp-server-buffer)
(setq result (eval accept-form))
(kill-buffer (current-buffer))
@@ -672,8 +670,7 @@ all. This may very well take some time.")
(deffoo nndiary-request-replace-article (article group buffer)
(nndiary-possibly-change-directory group)
- (save-excursion
- (set-buffer buffer)
+ (with-current-buffer buffer
(nndiary-possibly-create-directory group)
(let ((chars (nnmail-insert-lines))
(art (concat (int-to-string article) "\t"))
@@ -688,8 +685,7 @@ all. This may very well take some time.")
t)
(setq headers (nndiary-parse-head chars article))
;; Replace the NOV line in the NOV file.
- (save-excursion
- (set-buffer (nndiary-open-nov group))
+ (with-current-buffer (nndiary-open-nov group)
(goto-char (point-min))
(if (or (looking-at art)
(search-forward (concat "\n" art) nil t))
@@ -842,8 +838,7 @@ all. This may very well take some time.")
;; Find an article number in the current group given the Message-ID.
(defun nndiary-find-group-number (id)
- (save-excursion
- (set-buffer (get-buffer-create " *nndiary id*"))
+ (with-current-buffer (get-buffer-create " *nndiary id*")
(let ((alist nndiary-group-alist)
number)
;; We want to look through all .overview files, but we want to
@@ -888,8 +883,7 @@ all. This may very well take some time.")
(let ((nov (expand-file-name nndiary-nov-file-name
nndiary-current-directory)))
(when (file-exists-p nov)
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(erase-buffer)
(nnheader-insert-file-contents nov)
(if (and fetch-old
@@ -989,8 +983,7 @@ all. This may very well take some time.")
(defun nndiary-add-nov (group article headers)
"Add a nov line for the GROUP base."
- (save-excursion
- (set-buffer (nndiary-open-nov group))
+ (with-current-buffer (nndiary-open-nov group)
(goto-char (point-max))
(mail-header-set-number headers article)
(nnheader-insert-nov headers)))
@@ -1015,8 +1008,7 @@ all. This may very well take some time.")
(or (cdr (assoc group nndiary-nov-buffer-alist))
(let ((buffer (get-buffer-create (format " *nndiary overview %s*"
group))))
- (save-excursion
- (set-buffer buffer)
+ (with-current-buffer buffer
(set (make-local-variable 'nndiary-nov-buffer-file-name)
(expand-file-name
nndiary-nov-file-name
@@ -1069,9 +1061,9 @@ all. This may very well take some time.")
(file-directory-p dir))
(nndiary-generate-nov-databases-1 dir seen))))
;; Do this directory.
- (let ((files (sort (nnheader-article-to-file-alist dir)
+ (let ((nndiary-files (sort (nnheader-article-to-file-alist dir)
'car-less-than-car)))
- (if (not files)
+ (if (not nndiary-files)
(let* ((group (nnheader-file-to-group
(directory-file-name dir) nndiary-directory))
(info (cadr (assoc group nndiary-group-alist))))
@@ -1079,11 +1071,11 @@ all. This may very well take some time.")
(setcar info (1+ (cdr info)))))
(funcall nndiary-generate-active-function dir)
;; Generate the nov file.
- (nndiary-generate-nov-file dir files)
+ (nndiary-generate-nov-file dir nndiary-files)
(unless no-active
(nnmail-save-active nndiary-group-alist nndiary-active-file))))))
-(defvar files)
+(defvar nndiary-files) ; dynamically bound in nndiary-generate-nov-databases-1
(defun nndiary-generate-active-info (dir)
;; Update the active info for this group.
(let* ((group (nnheader-file-to-group
@@ -1092,9 +1084,9 @@ all. This may very well take some time.")
(last (or (caadr entry) 0)))
(setq nndiary-group-alist (delq entry nndiary-group-alist))
(push (list group
- (cons (or (caar files) (1+ last))
+ (cons (or (caar nndiary-files) (1+ last))
(max last
- (or (caar (last files))
+ (or (caar (last nndiary-files))
0))))
nndiary-group-alist)))
@@ -1103,9 +1095,8 @@ all. This may very well take some time.")
(nov (concat dir nndiary-nov-file-name))
(nov-buffer (get-buffer-create " *nov*"))
chars file headers)
- (save-excursion
- ;; Init the nov buffer.
- (set-buffer nov-buffer)
+ ;; Init the nov buffer.
+ (with-current-buffer nov-buffer
(buffer-disable-undo)
(erase-buffer)
(set-buffer nntp-server-buffer)
@@ -1125,20 +1116,17 @@ all. This may very well take some time.")
(unless (zerop (buffer-size))
(goto-char (point-min))
(setq headers (nndiary-parse-head chars (caar files)))
- (save-excursion
- (set-buffer nov-buffer)
+ (with-current-buffer nov-buffer
(goto-char (point-max))
(nnheader-insert-nov headers)))
(widen))
(setq files (cdr files)))
- (save-excursion
- (set-buffer nov-buffer)
+ (with-current-buffer nov-buffer
(nnmail-write-region 1 (point-max) nov nil 'nomesg)
(kill-buffer (current-buffer))))))
(defun nndiary-nov-delete-article (group article)
- (save-excursion
- (set-buffer (nndiary-open-nov group))
+ (with-current-buffer (nndiary-open-nov group)
(when (nnheader-find-nov-line article)
(delete-region (point) (progn (forward-line 1) (point)))
(when (bobp)
@@ -1584,6 +1572,4 @@ all. This may very well take some time.")
(provide 'nndiary)
-
-;; arch-tag: 9c542b95-92e7-4ace-a038-330ab296e203
;;; nndiary.el ends here
diff --git a/lisp/gnus/nndir.el b/lisp/gnus/nndir.el
index dd86fba6930..b6de7afa019 100644
--- a/lisp/gnus/nndir.el
+++ b/lisp/gnus/nndir.el
@@ -96,5 +96,4 @@
(provide 'nndir)
-;; arch-tag: 56f09f68-0e4e-4816-818a-df80b4a394c8
;;; nndir.el ends here
diff --git a/lisp/gnus/nndoc.el b/lisp/gnus/nndoc.el
index 981570cc83f..0dee06d2937 100644
--- a/lisp/gnus/nndoc.el
+++ b/lisp/gnus/nndoc.el
@@ -64,9 +64,6 @@ from the document.")
(body-end . "")
(file-end . "")
(subtype digest guess))
- (mime-parts
- (generate-head-function . nndoc-generate-mime-parts-head)
- (article-transform-function . nndoc-transform-mime-parts))
(nsmail
(article-begin . "^From - "))
(news
@@ -82,6 +79,9 @@ from the document.")
(body-end . "\^_")
(body-begin-function . nndoc-babyl-body-begin)
(head-begin-function . nndoc-babyl-head-begin))
+ (mime-parts
+ (generate-head-function . nndoc-generate-mime-parts-head)
+ (article-transform-function . nndoc-transform-mime-parts))
(exim-bounce
(article-begin . "^------ This is a copy of the message, including all the headers. ------\n\n")
(body-end-function . nndoc-exim-bounce-body-end-function))
@@ -100,7 +100,7 @@ from the document.")
(head-end . "^\t")
(generate-head-function . nndoc-generate-clari-briefs-head)
(article-transform-function . nndoc-transform-clari-briefs))
-
+
(standard-digest
(first-article . ,(concat "^" (make-string 70 ?-) "\n *\n+"))
(article-begin . ,(concat "^\n" (make-string 30 ?-) "\n *\n+"))
@@ -118,6 +118,16 @@ from the document.")
(file-end . "^End of")
(prepare-body-function . nndoc-unquote-dashes)
(subtype digest guess))
+ (google
+ (pre-dissection-function . nndoc-decode-content-transfer-encoding)
+ (article-begin . "^== [0-9]+ of [0-9]+ ==$")
+ (head-begin . "^Date:")
+ (head-end . "^$")
+ (body-end-function . nndoc-digest-body-end)
+ (body-begin . "^$")
+ (file-end . "^==============================================================================$")
+ (prepare-body-function . nndoc-unquote-dashes)
+ (subtype digest guess))
(lanl-gov-announce
(article-begin . "^\\\\\\\\\n")
(head-begin . "^\\(Paper.*:\\|arXiv:\\)")
@@ -128,6 +138,14 @@ from the document.")
(generate-head-function . nndoc-generate-lanl-gov-head)
(article-transform-function . nndoc-transform-lanl-gov-announce)
(subtype preprints guess))
+ (git
+ (file-begin . "\n- Log ---.*")
+ (article-begin . "^commit ")
+ (head-begin . "^Author: ")
+ (body-begin . "^$")
+ (file-end . "\n-----------------------------------------------------------------------")
+ (article-transform-function . nndoc-transform-git-article)
+ (header-transform-function . nndoc-transform-git-headers))
(rfc822-forward
(article-begin . "^\n+")
(body-end-function . nndoc-rfc822-forward-body-end-function)
@@ -183,9 +201,11 @@ from the document.")
(defvoo nndoc-prepare-body-function nil)
(defvoo nndoc-generate-head-function nil)
(defvoo nndoc-article-transform-function nil)
+(defvoo nndoc-header-transform-function nil)
(defvoo nndoc-article-begin-function nil)
(defvoo nndoc-generate-article-function nil)
(defvoo nndoc-dissection-function nil)
+(defvoo nndoc-pre-dissection-function nil)
(defvoo nndoc-status-string "")
(defvoo nndoc-group-alist nil)
@@ -204,8 +224,7 @@ from the document.")
(deffoo nndoc-retrieve-headers (articles &optional newsgroup server fetch-old)
(when (nndoc-possibly-change-buffer newsgroup server)
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(erase-buffer)
(let (article entry)
(if (stringp (car articles))
@@ -213,17 +232,22 @@ from the document.")
(while articles
(when (setq entry (cdr (assq (setq article (pop articles))
nndoc-dissection-alist)))
- (insert (format "221 %d Article retrieved.\n" article))
- (if nndoc-generate-head-function
- (funcall nndoc-generate-head-function article)
- (insert-buffer-substring
- nndoc-current-buffer (car entry) (nth 1 entry)))
- (goto-char (point-max))
- (unless (eq (char-after (1- (point))) ?\n)
- (insert "\n"))
- (insert (format "Lines: %d\n" (nth 4 entry)))
- (insert ".\n")))
-
+ (let ((start (point)))
+ (insert (format "221 %d Article retrieved.\n" article))
+ (if nndoc-generate-head-function
+ (funcall nndoc-generate-head-function article)
+ (insert-buffer-substring
+ nndoc-current-buffer (car entry) (nth 1 entry)))
+ (goto-char (point-max))
+ (unless (eq (char-after (1- (point))) ?\n)
+ (insert "\n"))
+ (insert (format "Lines: %d\n" (nth 4 entry)))
+ (insert ".\n")
+ (when nndoc-header-transform-function
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start (point))
+ (funcall nndoc-header-transform-function entry)))))))
(nnheader-fold-continuation-lines)
'headers)))))
@@ -254,7 +278,7 @@ from the document.")
(funcall nndoc-article-transform-function article))
t))))))
-(deffoo nndoc-request-group (group &optional server dont-check)
+(deffoo nndoc-request-group (group &optional server dont-check info)
"Select news GROUP."
(let (number)
(cond
@@ -270,6 +294,11 @@ from the document.")
(t
(nnheader-insert "211 %d %d %d %s\n" number 1 number group)))))
+(deffoo nndoc-retrieve-groups (groups &optional server)
+ (dolist (group groups)
+ (nndoc-request-group group server))
+ t)
+
(deffoo nndoc-request-type (group &optional article)
(cond ((not article) 'unknown)
(nndoc-post-type nndoc-post-type)
@@ -288,7 +317,7 @@ from the document.")
t)
(deffoo nndoc-request-list (&optional server)
- nil)
+ t)
(deffoo nndoc-request-newgroups (date &optional server)
nil)
@@ -322,8 +351,7 @@ from the document.")
(concat " *nndoc " group "*"))))
nndoc-group-alist)
(setq nndoc-dissection-alist nil)
- (save-excursion
- (set-buffer nndoc-current-buffer)
+ (with-current-buffer nndoc-current-buffer
(erase-buffer)
(if (and (stringp nndoc-address)
(string-match nndoc-binary-file-names nndoc-address))
@@ -336,8 +364,7 @@ from the document.")
;; Initialize the nndoc structures according to this new document.
(when (and nndoc-current-buffer
(not nndoc-dissection-alist))
- (save-excursion
- (set-buffer nndoc-current-buffer)
+ (with-current-buffer nndoc-current-buffer
(nndoc-set-delims)
(if (eq nndoc-article-type 'mime-parts)
(nndoc-dissect-mime-parts)
@@ -360,10 +387,12 @@ from the document.")
nndoc-file-end nndoc-article-begin
nndoc-body-begin nndoc-body-end-function nndoc-body-end
nndoc-prepare-body-function nndoc-article-transform-function
+ nndoc-header-transform-function
nndoc-generate-head-function nndoc-body-begin-function
nndoc-head-begin-function
nndoc-generate-article-function
- nndoc-dissection-function)))
+ nndoc-dissection-function
+ nndoc-pre-dissection-function)))
(while vars
(set (pop vars) nil)))
(let (defs)
@@ -445,6 +474,22 @@ from the document.")
(forward-line 1)
(goto-char (+ (point) (string-to-number (match-string 1))))))
+(defun nndoc-google-type-p ()
+ (when (re-search-forward "^=3D=3D 1 of [0-9]+ =3D=3D$" nil t)
+ t))
+
+(defun nndoc-decode-content-transfer-encoding ()
+ (let ((encoding
+ (save-restriction
+ (message-narrow-to-head)
+ (message-fetch-field "content-transfer-encoding"))))
+ (when (and encoding
+ (search-forward "\n\n" nil t))
+ (save-restriction
+ (narrow-to-region (point) (point-max))
+ (mm-decode-content-transfer-encoding
+ (intern (downcase (mail-header-strip encoding))))))))
+
(defun nndoc-babyl-type-p ()
(when (re-search-forward "\^_\^L *\n" nil t)
t))
@@ -560,8 +605,7 @@ from the document.")
(defun nndoc-generate-clari-briefs-head (article)
(let ((entry (cdr (assq article nndoc-dissection-alist)))
subject from)
- (save-excursion
- (set-buffer nndoc-current-buffer)
+ (with-current-buffer nndoc-current-buffer
(save-restriction
(narrow-to-region (car entry) (nth 3 entry))
(goto-char (point-min))
@@ -620,6 +664,30 @@ from the document.")
(defun nndoc-slack-digest-type-p ()
0)
+(defun nndoc-git-type-p ()
+ (and (search-forward "\n- Log ---" nil t)
+ (search-forward "\ncommit " nil t)
+ (search-forward "\nAuthor: " nil t)))
+
+(defun nndoc-transform-git-article (article)
+ (goto-char (point-min))
+ (when (re-search-forward "^Author: " nil t)
+ (replace-match "From: " t t)))
+
+(defun nndoc-transform-git-headers (entry)
+ (goto-char (point-min))
+ (when (re-search-forward "^Author: " nil t)
+ (replace-match "From: " t t))
+ (let (subject)
+ (with-current-buffer nndoc-current-buffer
+ (goto-char (car entry))
+ (when (search-forward "\n\n" nil t)
+ (setq subject (buffer-substring (point) (line-end-position)))))
+ (when subject
+ (goto-char (point-min))
+ (forward-line 1)
+ (insert (format "Subject: %s\n" subject)))))
+
(defun nndoc-lanl-gov-announce-type-p ()
(when (let ((case-fold-search nil))
(re-search-forward "^\\\\\\\\\n\\(Paper\\( (\\*cross-listing\\*)\\)?: [a-zA-Z-\\.]+/[0-9]+\\|arXiv:\\)" nil t))
@@ -649,8 +717,7 @@ from the document.")
(let ((entry (cdr (assq article nndoc-dissection-alist)))
(from "<no address given>")
subject date)
- (save-excursion
- (set-buffer nndoc-current-buffer)
+ (with-current-buffer nndoc-current-buffer
(save-restriction
(narrow-to-region (car entry) (nth 1 entry))
(goto-char (point-min))
@@ -741,7 +808,7 @@ from the document.")
(setq p (1+ (nth 3 blk)))))
(goto-char begin)
(while (re-search-forward "\r$" nil t)
- (delete-backward-char 1))
+ (delete-char -1))
(when head
(goto-char begin)
(when (search-forward "\n\n" nil t)
@@ -801,12 +868,14 @@ from the document.")
(first t)
art-begin head-begin head-end body-begin body-end)
(setq nndoc-dissection-alist nil)
- (save-excursion
- (set-buffer nndoc-current-buffer)
+ (with-current-buffer nndoc-current-buffer
(goto-char (point-min))
;; Remove blank lines.
(while (eq (following-char) ?\n)
(delete-char 1))
+ (when nndoc-pre-dissection-function
+ (save-excursion
+ (funcall nndoc-pre-dissection-function)))
(if nndoc-dissection-function
(funcall nndoc-dissection-function)
;; Find the beginning of the file.
@@ -849,7 +918,8 @@ from the document.")
(setq body-end (point))
(push (list (incf i) head-begin head-end body-begin body-end
(count-lines body-begin body-end))
- nndoc-dissection-alist)))))))
+ nndoc-dissection-alist)))))
+ (setq nndoc-dissection-alist (nreverse nndoc-dissection-alist))))
(defun nndoc-article-begin ()
(if nndoc-article-begin-function
@@ -871,8 +941,7 @@ When a MIME entity contains sub-entities, dissection produces one article for
the header of this entity, and one article per sub-entity."
(setq nndoc-dissection-alist nil
nndoc-mime-split-ordinal 0)
- (save-excursion
- (set-buffer nndoc-current-buffer)
+ (with-current-buffer nndoc-current-buffer
(nndoc-dissect-mime-parts-sub (point-min) (point-max) nil nil nil)))
(defun nndoc-dissect-mime-parts-sub (head-begin body-end article-insert
@@ -1009,7 +1078,7 @@ as the last checked definition, if t or `first', add as the
first definition, and if any other symbol, add after that
symbol in the alist."
;; First remove any old instances.
- (gnus-pull (car definition) nndoc-type-alist)
+ (gnus-alist-pull (car definition) nndoc-type-alist)
;; Then enter the new definition in the proper place.
(cond
((or (null position) (eq position 'last))
@@ -1025,5 +1094,4 @@ symbol in the alist."
(provide 'nndoc)
-;; arch-tag: f5c2970e-0387-47ac-a0b3-6cc317dffabe
;;; nndoc.el ends here
diff --git a/lisp/gnus/nndraft.el b/lisp/gnus/nndraft.el
index 7afded2abf0..98c14d4cab2 100644
--- a/lisp/gnus/nndraft.el
+++ b/lisp/gnus/nndraft.el
@@ -77,10 +77,9 @@ are generated if and only if they are also in `message-draft-headers'.")
(deffoo nndraft-retrieve-headers (articles &optional group server fetch-old)
(nndraft-possibly-change-group group)
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(erase-buffer)
- (let* (article)
+ (let (article lines chars)
;; We don't support fetching by Message-ID.
(if (stringp (car articles))
'headers
@@ -92,9 +91,12 @@ are generated if and only if they are also in `message-draft-headers'.")
(if (search-forward "\n\n" nil t)
(forward-line -1)
(goto-char (point-max)))
+ (setq lines (count-lines (point) (point-max))
+ chars (- (point-max) (point)))
(delete-region (point) (point-max))
(goto-char (point-min))
(insert (format "221 %d Article retrieved.\n" article))
+ (insert (format "Lines: %d\nChars: %d\n" lines chars))
(widen)
(goto-char (point-max))
(insert ".\n")))
@@ -119,8 +121,7 @@ are generated if and only if they are also in `message-draft-headers'.")
mm-text-coding-system)
mm-auto-save-coding-system)))
(nnmail-find-file newest)))
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(goto-char (point-min))
;; If there's a mail header separator in this file,
;; we remove it.
@@ -184,7 +185,7 @@ are generated if and only if they are also in `message-draft-headers'.")
(add-hook hook 'nndraft-generate-headers nil t))
article))
-(deffoo nndraft-request-group (group &optional server dont-check)
+(deffoo nndraft-request-group (group &optional server dont-check info)
(nndraft-possibly-change-group group)
(unless dont-check
(let* ((pathname (nnmail-group-pathname group nndraft-directory))
@@ -202,15 +203,14 @@ are generated if and only if they are also in `message-draft-headers'.")
'nnmh-request-group
(list group server dont-check)))
-(deffoo nndraft-request-move-article (article group server accept-form
+(deffoo nndraft-request-move-article (article group server accept-form
&optional last move-is-internal)
(nndraft-possibly-change-group group)
(let ((buf (get-buffer-create " *nndraft move*"))
result)
(and
(nndraft-request-article article group server)
- (save-excursion
- (set-buffer buf)
+ (with-current-buffer buf
(erase-buffer)
(insert-buffer-substring nntp-server-buffer)
(setq result (eval accept-form))
@@ -222,6 +222,11 @@ are generated if and only if they are also in `message-draft-headers'.")
(deffoo nndraft-request-expire-articles (articles group &optional server force)
(nndraft-possibly-change-group group)
(let* ((nnmh-allow-delete-final t)
+ (nnmail-expiry-target
+ (or (gnus-group-find-parameter
+ (gnus-group-prefixed-name group (list 'nndraft server))
+ 'expiry-target t)
+ nnmail-expiry-target))
(res (nnoo-parent-function 'nndraft
'nnmh-request-expire-articles
(list articles group server force)))
@@ -313,5 +318,4 @@ are generated if and only if they are also in `message-draft-headers'.")
(provide 'nndraft)
-;; arch-tag: 3ce26ca0-41cb-48b1-8703-4dad35e188aa
;;; nndraft.el ends here
diff --git a/lisp/gnus/nneething.el b/lisp/gnus/nneething.el
index f92c47eba04..2de2dca82b9 100644
--- a/lisp/gnus/nneething.el
+++ b/lisp/gnus/nneething.el
@@ -28,6 +28,7 @@
(eval-when-compile (require 'cl))
+(require 'mailcap)
(require 'nnheader)
(require 'nnmail)
(require 'nnoo)
@@ -80,8 +81,7 @@ included.")
(deffoo nneething-retrieve-headers (articles &optional group server fetch-old)
(nneething-possibly-change-directory group)
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(erase-buffer)
(let* ((number (length articles))
(count 0)
@@ -144,7 +144,7 @@ included.")
(insert "\n"))
t))))
-(deffoo nneething-request-group (group &optional server dont-check)
+(deffoo nneething-request-group (group &optional server dont-check info)
(nneething-possibly-change-directory group server)
(unless dont-check
(nneething-create-mapping)
@@ -322,8 +322,7 @@ included.")
(if (equal '(0 0) (nth 5 atts)) ""
(concat "Date: " (current-time-string (nth 5 atts)) "\n"))
(or (when buffer
- (save-excursion
- (set-buffer buffer)
+ (with-current-buffer buffer
(when (re-search-forward "<[a-zA-Z0-9_]@[-a-zA-Z0-9_]>" 1000 t)
(concat "From: " (match-string 0) "\n"))))
(nneething-from-line (nth 2 atts) file))
@@ -331,8 +330,7 @@ included.")
(concat "Chars: " (int-to-string (nth 7 atts)) "\n")
"")
(if buffer
- (save-excursion
- (set-buffer buffer)
+ (with-current-buffer buffer
(concat "Lines: " (int-to-string
(count-lines (point-min) (point-max)))
"\n"))
@@ -381,8 +379,7 @@ included.")
(defun nneething-get-head (file)
"Either find the head in FILE or make a head for FILE."
- (save-excursion
- (set-buffer (get-buffer-create nneething-work-buffer))
+ (with-current-buffer (get-buffer-create nneething-work-buffer)
(setq case-fold-search nil)
(buffer-disable-undo)
(erase-buffer)
@@ -426,5 +423,4 @@ included.")
(provide 'nneething)
-;; arch-tag: 1277f386-88f2-4459-bb24-f3f45962a6c5
;;; nneething.el ends here
diff --git a/lisp/gnus/nnfolder.el b/lisp/gnus/nnfolder.el
index 19fe8c61b7d..5de8653948f 100644
--- a/lisp/gnus/nnfolder.el
+++ b/lisp/gnus/nnfolder.el
@@ -29,7 +29,7 @@
;;; Code:
-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
@@ -157,8 +157,7 @@ the group. Then the marks file will be regenerated properly by Gnus.")
(nnoo-define-basics nnfolder)
(deffoo nnfolder-retrieve-headers (articles &optional group server fetch-old)
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(erase-buffer)
(let (article start stop num)
(nnfolder-possibly-change-group group server)
@@ -261,8 +260,7 @@ the group. Then the marks file will be regenerated properly by Gnus.")
(deffoo nnfolder-request-article (article &optional group server buffer)
(nnfolder-possibly-change-group group server)
- (save-excursion
- (set-buffer nnfolder-current-buffer)
+ (with-current-buffer nnfolder-current-buffer
(goto-char (point-min))
(when (nnfolder-goto-article article)
(let (start stop)
@@ -291,7 +289,7 @@ the group. Then the marks file will be regenerated properly by Gnus.")
(point) (point-at-eol)))
-1))))))))
-(deffoo nnfolder-request-group (group &optional server dont-check)
+(deffoo nnfolder-request-group (group &optional server dont-check info)
(nnfolder-possibly-change-group group server t)
(save-excursion
(cond ((not (assoc group nnfolder-group-alist))
@@ -360,8 +358,7 @@ the group. Then the marks file will be regenerated properly by Gnus.")
nnfolder-current-group (car inf))))
(when (and nnfolder-current-buffer
(buffer-name nnfolder-current-buffer))
- (save-excursion
- (set-buffer nnfolder-current-buffer)
+ (with-current-buffer nnfolder-current-buffer
;; If the buffer was modified, write the file out now.
(nnfolder-save-buffer)
;; If we're shutting the server down, we need to kill the
@@ -447,8 +444,7 @@ the group. Then the marks file will be regenerated properly by Gnus.")
target)
(nnmail-activate 'nnfolder)
- (save-excursion
- (set-buffer nnfolder-current-buffer)
+ (with-current-buffer nnfolder-current-buffer
;; Since messages are sorted in arrival order and expired in the
;; same order, we can stop as soon as we find a message that is
;; too old.
@@ -494,15 +490,14 @@ the group. Then the marks file will be regenerated properly by Gnus.")
(nnfolder-save-active nnfolder-group-alist nnfolder-active-file)
(gnus-sorted-difference articles (nreverse deleted-articles)))))
-(deffoo nnfolder-request-move-article (article group server accept-form
+(deffoo nnfolder-request-move-article (article group server accept-form
&optional last move-is-internal)
(save-excursion
(let ((buf (get-buffer-create " *nnfolder move*"))
result)
(and
(nnfolder-request-article article group server)
- (save-excursion
- (set-buffer buf)
+ (with-current-buffer buf
(erase-buffer)
(insert-buffer-substring nntp-server-buffer)
(goto-char (point-min))
@@ -552,7 +547,7 @@ the group. Then the marks file will be regenerated properly by Gnus.")
(while (re-search-backward (concat "^" nnfolder-article-marker) nil t)
(delete-region (point) (progn (forward-line 1) (point))))
(when nnmail-cache-accepted-message-ids
- (nnmail-cache-insert (nnmail-fetch-field "message-id")
+ (nnmail-cache-insert (nnmail-fetch-field "message-id")
group
(nnmail-fetch-field "subject")
(nnmail-fetch-field "from")))
@@ -578,8 +573,7 @@ the group. Then the marks file will be regenerated properly by Gnus.")
(deffoo nnfolder-request-replace-article (article group buffer)
(nnfolder-possibly-change-group group)
- (save-excursion
- (set-buffer buffer)
+ (with-current-buffer buffer
(goto-char (point-min))
(if (not (looking-at "X-From-Line: "))
(insert "From nobody " (current-time-string) "\n")
@@ -596,8 +590,7 @@ the group. Then the marks file will be regenerated properly by Gnus.")
(nnfolder-delete-mail)
(insert-buffer-substring buffer)
(unless (or gnus-nov-is-evil nnfolder-nov-is-evil)
- (save-excursion
- (set-buffer buffer)
+ (with-current-buffer buffer
(let ((headers (nnfolder-parse-head article
(point-min) (point-max))))
(with-current-buffer (nnfolder-open-nov group)
@@ -630,8 +623,7 @@ the group. Then the marks file will be regenerated properly by Gnus.")
(deffoo nnfolder-request-rename-group (group new-name &optional server)
(nnfolder-possibly-change-group group server)
- (save-excursion
- (set-buffer nnfolder-current-buffer)
+ (with-current-buffer nnfolder-current-buffer
(and (file-writable-p buffer-file-name)
(ignore-errors
(let ((new-file (nnfolder-group-pathname new-name)))
@@ -671,8 +663,7 @@ the group. Then the marks file will be regenerated properly by Gnus.")
(marker (concat "\n" nnfolder-article-marker))
(number "[0-9]+")
(activemin (cdr active)))
- (save-excursion
- (set-buffer nnfolder-current-buffer)
+ (with-current-buffer nnfolder-current-buffer
(goto-char (point-min))
(while (and (search-forward marker nil t)
(re-search-forward number nil t))
@@ -1114,8 +1105,7 @@ This command does not work if you use short group names."
(defun nnfolder-open-nov (group)
(or (cdr (assoc group nnfolder-nov-buffer-alist))
(let ((buffer (get-buffer-create (format " *nnfolder overview %s*" group))))
- (save-excursion
- (set-buffer buffer)
+ (with-current-buffer buffer
(set (make-local-variable 'nnfolder-nov-buffer-file-name)
(nnfolder-group-nov-pathname group))
(erase-buffer)
@@ -1139,8 +1129,7 @@ This command does not work if you use short group names."
(setq nnfolder-nov-buffer-alist (cdr nnfolder-nov-buffer-alist)))))
(defun nnfolder-nov-delete-article (group article)
- (save-excursion
- (set-buffer (nnfolder-open-nov group))
+ (with-current-buffer (nnfolder-open-nov group)
(when (nnheader-find-nov-line article)
(delete-region (point) (progn (forward-line 1) (point))))
t))
@@ -1150,8 +1139,7 @@ This command does not work if you use short group names."
nil
(let ((nov (nnfolder-group-nov-pathname nnfolder-current-group)))
(when (file-exists-p nov)
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(erase-buffer)
(nnheader-insert-file-contents nov)
(if (and fetch-old
@@ -1187,8 +1175,7 @@ This command does not work if you use short group names."
(defun nnfolder-add-nov (group article headers)
"Add a nov line for the GROUP base."
- (save-excursion
- (set-buffer (nnfolder-open-nov group))
+ (with-current-buffer (nnfolder-open-nov group)
(goto-char (point-max))
(mail-header-set-number headers article)
(nnheader-insert-nov headers)))
@@ -1199,23 +1186,11 @@ This command does not work if you use short group names."
(nnfolder-open-server server))
(unless nnfolder-marks-is-evil
(nnfolder-open-marks group server)
- (dolist (action actions)
- (let ((range (nth 0 action))
- (what (nth 1 action))
- (marks (nth 2 action)))
- (assert (or (eq what 'add) (eq what 'del)) nil
- "Unknown request-set-mark action: %s" what)
- (dolist (mark marks)
- (setq nnfolder-marks (gnus-update-alist-soft
- mark
- (funcall (if (eq what 'add) 'gnus-range-add
- 'gnus-remove-from-range)
- (cdr (assoc mark nnfolder-marks)) range)
- nnfolder-marks)))))
+ (setq nnfolder-marks (nnheader-update-marks-actions nnfolder-marks actions))
(nnfolder-save-marks group server))
nil)
-(deffoo nnfolder-request-update-info (group info &optional server)
+(deffoo nnfolder-request-marks (group info &optional server)
;; Change servers.
(when (and server
(not (nnfolder-server-opened server)))
@@ -1301,5 +1276,4 @@ This command does not work if you use short group names."
(provide 'nnfolder)
-;; arch-tag: a040d0f4-4f4e-445f-8972-839575c5f7e6
;;; nnfolder.el ends here
diff --git a/lisp/gnus/nngateway.el b/lisp/gnus/nngateway.el
index 163aa357b2b..1c0d7753eff 100644
--- a/lisp/gnus/nngateway.el
+++ b/lisp/gnus/nngateway.el
@@ -89,5 +89,4 @@ parameter -- the gateway address.")
(provide 'nngateway)
-;; arch-tag: f7ecb92e-b10c-43d5-9a9b-1314233341fc
;;; nngateway.el ends here
diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el
index f3283022db9..cc2706eaf2a 100644
--- a/lisp/gnus/nnheader.el
+++ b/lisp/gnus/nnheader.el
@@ -27,6 +27,9 @@
;;; Code:
+;; For Emacs <22.2 and XEmacs.
+(eval-and-compile
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
(eval-when-compile (require 'cl))
(defvar nnmail-extra-headers)
@@ -75,7 +78,7 @@ Integer values will in effect be rounded up to the nearest multiple of
"*Length of each read operation when trying to fetch HEAD headers.")
(defvar nnheader-read-timeout
- (if (string-match "windows-nt\\|os/2\\|emx\\|cygwin"
+ (if (string-match "windows-nt\\|os/2\\|cygwin"
(symbol-name system-type))
;; http://thread.gmane.org/v9655t3pjo.fsf@marauder.physik.uni-ulm.de
;;
@@ -100,7 +103,7 @@ Shorter values mean quicker response, but are more CPU intensive.")
(defvar nnheader-file-name-translation-alist
(let ((case-fold-search t))
(cond
- ((string-match "windows-nt\\|os/2\\|emx\\|cygwin"
+ ((string-match "windows-nt\\|os/2\\|cygwin"
(symbol-name system-type))
(append (mapcar (lambda (c) (cons c ?_))
'(?: ?* ?\" ?< ?> ??))
@@ -121,7 +124,6 @@ on your system, you could say something like:
(autoload 'nnmail-message-id "nnmail")
(autoload 'mail-position-on-field "sendmail")
-(autoload 'message-remove-header "message")
(autoload 'gnus-buffer-live-p "gnus-util")
;;; Header access macros.
@@ -364,15 +366,13 @@ on your system, you could say something like:
(setq num 0
beg (point-min)
end (point-max))
- (goto-char (point-min))
;; Search to the beginning of the next header. Error
;; messages do not begin with 2 or 3.
(when (re-search-forward "^[23][0-9]+ " nil t)
- (end-of-line)
(setq num (read cur)
beg (point)
end (if (search-forward "\n.\n" nil t)
- (- (point) 2)
+ (goto-char (- (point) 2))
(point)))))
(with-temp-buffer
(insert-buffer-substring cur beg end)
@@ -462,7 +462,7 @@ on your system, you could say something like:
(let ((extra (mail-header-extra header)))
(while extra
(insert (symbol-name (caar extra))
- ": " (cdar extra) "\t")
+ ": " (if (stringp (cdar extra)) (cdar extra) "") "\t")
(pop extra))))
(insert "\n")
(backward-char 1)
@@ -569,8 +569,6 @@ the line could be found."
(defvar nntp-server-buffer nil)
(defvar nntp-process-response nil)
-(defvar news-reply-yank-from nil)
-(defvar news-reply-yank-message-id nil)
(defvar nnheader-callback-function nil)
@@ -662,8 +660,12 @@ the line could be found."
;; without inserting extra newline.
(fill-region-as-paragraph begin (1+ (point))))))
+(declare-function message-remove-header "message"
+ (header &optional is-regexp first reverse))
+
(defun nnheader-replace-header (header new-value)
"Remove HEADER and insert the NEW-VALUE."
+ (require 'message)
(save-excursion
(save-restriction
(nnheader-narrow-to-headers)
@@ -781,8 +783,7 @@ If FULL, translate everything."
;; We translate -- but only the file name. We leave the directory
;; alone.
(if (and (featurep 'xemacs)
- (memq system-type '(cygwin32 win32 w32 mswindows windows-nt
- cygwin)))
+ (memq system-type '(windows-nt cygwin)))
;; This is needed on NT and stuff, because
;; file-name-nondirectory is not enough to split
;; file names, containing ':', e.g.
@@ -820,19 +821,22 @@ The first string in ARGS can be a format string."
(apply 'format args)))
nil)
-(defun nnheader-get-report (backend)
+(defun nnheader-get-report-string (backend)
"Get the most recent report from BACKEND."
(condition-case ()
- (nnheader-message 5 "%s" (symbol-value (intern (format "%s-status-string"
- backend))))
- (error (nnheader-message 5 ""))))
+ (format "%s" (symbol-value (intern (format "%s-status-string"
+ backend))))
+ (error "")))
+
+(defun nnheader-get-report (backend)
+ "Get the most recent report from BACKEND."
+ (nnheader-message 5 (nnheader-get-report-string backend)))
(defun nnheader-insert (format &rest args)
"Clear the communication buffer and insert FORMAT and ARGS into the buffer.
If FORMAT isn't a format string, it and all ARGS will be inserted
without formatting."
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(erase-buffer)
(if (string-match "%" format)
(insert (apply 'format format args))
@@ -1074,6 +1078,26 @@ See `find-file-noselect' for the arguments."
(truncate nnheader-read-timeout))
1000))))
+(defun nnheader-update-marks-actions (backend-marks actions)
+ (dolist (action actions)
+ (let ((range (nth 0 action))
+ (what (nth 1 action))
+ (marks (nth 2 action)))
+ (dolist (mark marks)
+ (setq backend-marks
+ (gnus-update-alist-soft
+ mark
+ (cond
+ ((eq what 'add)
+ (gnus-range-add (cdr (assoc mark backend-marks)) range))
+ ((eq what 'del)
+ (gnus-remove-from-range
+ (cdr (assoc mark backend-marks)) range))
+ ((eq what 'set)
+ range))
+ backend-marks)))))
+ backend-marks)
+
(when (featurep 'xemacs)
(require 'nnheaderxm))
@@ -1081,5 +1105,4 @@ See `find-file-noselect' for the arguments."
(provide 'nnheader)
-;; arch-tag: a9c4b7d9-52ae-4ec9-b196-dfd93124d202
;;; nnheader.el ends here
diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el
index 6d97c060a96..cb4c9f0108c 100644
--- a/lisp/gnus/nnimap.el
+++ b/lisp/gnus/nnimap.el
@@ -1,11 +1,9 @@
-;;; nnimap.el --- imap backend for Gnus
+;;; nnimap.el --- IMAP interface for Gnus
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010 Free Software Foundation, Inc.
-;; Author: Simon Josefsson <simon@josefsson.org>
-;; Jim Radford <radford@robby.caltech.edu>
-;; Keywords: mail
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Simon Josefsson <simon@josefsson.org>
;; This file is part of GNU Emacs.
@@ -24,1784 +22,1803 @@
;;; Commentary:
-;; Todo, major things:
-;;
-;; o Fix Gnus to view correct number of unread/total articles in group buffer
-;; o Fix Gnus to handle leading '.' in group names (fixed?)
-;; o Finish disconnected mode (moving articles between mailboxes unplugged)
-;; o Sieve
-;; o MIME (partial article fetches)
-;; o Split to other backends, different split rules for different
-;; servers/inboxes
-;;
-;; Todo, minor things:
-;;
-;; o Don't require half of Gnus -- backends should be standalone
-;; o Verify that we don't use IMAP4rev1 specific things (RFC2060 App B)
-;; o Dont uid fetch 1,* in nnimap-retrive-groups (slow)
-;; o Split up big fetches (1,* header especially) in smaller chunks
-;; o What do I do with gnus-newsgroup-*?
-;; o Tell Gnus about new groups (how can we tell?)
-;; o Respooling (fix Gnus?) (unnecessary?)
-;; o Add support for the following: (if applicable)
-;; request-list-newsgroups, request-regenerate
-;; list-active-group,
-;; request-associate-buffer, request-restore-buffer,
-;; o Do The Right Thing when UIDVALIDITY changes (what's the right thing?)
-;; o Support RFC2221 (Login referrals)
-;; o IMAP2BIS compatibility? (RFC2061)
-;; o ACAP stuff (perhaps a different project, would be nice to ACAPify
-;; .newsrc.eld)
-;; o What about Gnus's article editing, can we support it? NO!
-;; o Use \Draft to support the draft group??
-;; o Duplicate suppression
-;; o Rewrite UID SEARCH UID X as UID FETCH X (UID) for those with slow servers
+;; nnimap interfaces Gnus with IMAP servers.
;;; Code:
-(require 'imap)
-(require 'nnoo)
-(require 'nnmail)
+;; For Emacs <22.2 and XEmacs.
+(eval-and-compile
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
+
+(eval-and-compile
+ (require 'nnheader))
+
+(eval-when-compile
+ (require 'cl))
+
(require 'nnheader)
-(require 'mm-util)
+(require 'gnus-util)
(require 'gnus)
-(require 'gnus-range)
-(require 'gnus-start)
-(require 'gnus-int)
+(require 'nnoo)
+(require 'netrc)
+(require 'utf7)
+(require 'tls)
+(require 'parse-time)
+(require 'nnmail)
-(eval-when-compile (require 'cl))
+(eval-when-compile
+ (require 'gnus-sum))
+(autoload 'auth-source-forget-user-or-password "auth-source")
(autoload 'auth-source-user-or-password "auth-source")
(nnoo-declare nnimap)
-(defconst nnimap-version "nnimap 1.0")
-
-(defgroup nnimap nil
- "Reading IMAP mail with Gnus."
- :group 'gnus)
-
(defvoo nnimap-address nil
- "Address of physical IMAP server. If nil, use the virtual server's name.")
+ "The address of the IMAP server.")
(defvoo nnimap-server-port nil
- "Port number on physical IMAP server.
-If nil, defaults to 993 for TLS/SSL connections and 143 otherwise.")
-
-;; Splitting variables
-
-(defcustom nnimap-split-crosspost t
- "If non-nil, do crossposting if several split methods match the mail.
-If nil, the first match found will be used."
- :group 'nnimap
- :type 'boolean)
-
-(defcustom nnimap-split-inbox nil
- "Name of mailbox to split mail from.
-
-Mail is read from this mailbox and split according to rules in
-`nnimap-split-rule'.
-
-This can be a string or a list of strings."
- :group 'nnimap
- :type '(choice (string)
- (repeat string)))
-
-(define-widget 'nnimap-strict-function 'function
- "This widget only matches values that are functionp.
-
-Warning: This means that a value that is the symbol of a not yet
-loaded function will not match. Use with care."
- :match 'nnimap-strict-function-match)
-
-(defun nnimap-strict-function-match (widget value)
- "Ignoring WIDGET, match if VALUE is a function."
- (functionp value))
-
-(defcustom nnimap-split-rule nil
- "Mail will be split according to these rules.
-
-Mail is read from mailbox(es) specified in `nnimap-split-inbox'.
-
-If you'd like, for instance, one mail group for mail from the
-\"gnus-imap\" mailing list, one group for junk mail and leave
-everything else in the incoming mailbox, you could do something like
-this:
-
-\(setq nnimap-split-rule '((\"INBOX.gnus-imap\" \"From:.*gnus-imap\")
- (\"INBOX.junk\" \"Subject:.*buy\")))
-
-As you can see, `nnimap-split-rule' is a list of lists, where the
-first element in each \"rule\" is the name of the IMAP mailbox (or the
-symbol `junk' if you want to remove the mail), and the second is a
-regexp that nnimap will try to match on the header to find a fit.
-
-The second element can also be a function. In that case, it will be
-called narrowed to the headers with the first element of the rule as
-the argument. It should return a non-nil value if it thinks that the
-mail belongs in that group.
-
-This variable can also have a function as its value, the function will
-be called with the headers narrowed and should return a group where it
-thinks the article should be splitted to. See `nnimap-split-fancy'.
-
-To allow for different split rules on different virtual servers, and
-even different split rules in different inboxes on the same server,
-the syntax of this variable have been extended along the lines of:
-
-\(setq nnimap-split-rule
- '((\"my1server\" (\".*\" ((\"ding\" \"ding@gnus.org\")
- (\"junk\" \"From:.*Simon\")))
- (\"my2server\" (\"INBOX\" nnimap-split-fancy))
- (\"my[34]server\" (\".*\" ((\"private\" \"To:.*Simon\")
- (\"junk\" my-junk-func)))))
-
-The virtual server name is in fact a regexp, so that the same rules
-may apply to several servers. In the example, the servers
-\"my3server\" and \"my4server\" both use the same rules. Similarly,
-the inbox string is also a regexp. The actual splitting rules are as
-before, either a function, or a list with group/regexp or
-group/function elements."
- :group 'nnimap
- ;; FIXME: Doesn't allow `("my2server" ("INBOX" nnimap-split-fancy))'
- ;; per example above. -- fx
- :type '(choice :tag "Rule type"
- (repeat :menu-tag "Single-server"
- :tag "Single-server list"
- (list (string :tag "Mailbox")
- (choice :tag "Predicate"
- (regexp :tag "A regexp")
- (nnimap-strict-function :tag "A function"))))
- (choice :menu-tag "A function"
- :tag "A function"
- (function-item nnimap-split-fancy)
- (function-item nnmail-split-fancy)
- (nnimap-strict-function :tag "User-defined function"))
- (repeat :menu-tag "Multi-server (extended)"
- :tag "Multi-server list"
- (list (regexp :tag "Server regexp")
- (list (regexp :tag "Incoming Mailbox regexp")
- (repeat :tag "Rules for matching server(s) and mailbox(es)"
- (list (string :tag "Destination mailbox")
- (choice :tag "Predicate"
- (regexp :tag "A Regexp")
- (nnimap-strict-function :tag "A Function")))))))))
-
-(defcustom nnimap-split-predicate "UNSEEN UNDELETED"
- "The predicate used to find articles to split.
-If you use another IMAP client to peek on articles but always would
-like nnimap to split them once it's started, you could change this to
-\"UNDELETED\". Other available predicates are available in
-RFC2060 section 6.4.4."
- :group 'nnimap
- :type 'string)
-
-(defcustom nnimap-split-fancy nil
- "Like the variable `nnmail-split-fancy'."
- :group 'nnimap
- :type 'sexp)
+ "The IMAP port used.
+If nnimap-stream is `ssl', this will default to `imaps'. If not,
+it will default to `imap'.")
-(defvar nnimap-split-download-body-default nil
- "Internal variable with default value for `nnimap-split-download-body'.")
+(defvoo nnimap-stream 'ssl
+ "How nnimap will talk to the IMAP server.
+Values are `ssl', `network', `starttls' or `shell'.")
+
+(defvoo nnimap-shell-program (if (boundp 'imap-shell-program)
+ (if (listp imap-shell-program)
+ (car imap-shell-program)
+ imap-shell-program)
+ "ssh %s imapd"))
+
+(defvoo nnimap-inbox nil
+ "The mail box where incoming mail arrives and should be split out of.")
+
+(defvoo nnimap-split-methods nil
+ "How mail is split.
+Uses the same syntax as nnmail-split-methods")
-(defcustom nnimap-split-download-body 'default
- "Whether to download entire articles during splitting.
-This is generally not required, and will slow things down considerably.
-You may need it if you want to use an advanced splitting function that
-analyzes the body before splitting the article.
-If this variable is nil, bodies will not be downloaded; if this
-variable is the symbol `default' the default behavior is
-used (which currently is nil, unless you use a statistical
-spam.el test); if this variable is another non-nil value bodies
-will be downloaded."
- :version "22.1"
- :group 'nnimap
- :type '(choice (const :tag "Let system decide" deault)
- boolean))
-
-;; Performance / bug workaround variables
-
-(defcustom nnimap-close-asynchronous t
- "Close mailboxes asynchronously in `nnimap-close-group'.
-This means that errors caught by nnimap when closing the mailbox will
-not prevent Gnus from updating the group status, which may be harmful.
-However, it increases speed."
- :version "22.1"
- :type 'boolean
- :group 'nnimap)
-
-(defcustom nnimap-dont-close t
- "Never close mailboxes.
-This increases the speed of closing mailboxes (quiting group) but may
-decrease the speed of selecting another mailbox later. Re-selecting
-the same mailbox will be faster though."
- :version "22.1"
- :type 'boolean
- :group 'nnimap)
-
-(defcustom nnimap-retrieve-groups-asynchronous t
- "Send asynchronous STATUS commands for each mailbox before checking mail.
-If you have mailboxes that rarely receives mail, this speeds up new
-mail checking. It works by first sending STATUS commands for each
-mailbox, and then only checking groups which has a modified UIDNEXT
-more carefully for new mail.
-
-In summary, the default is O((1-p)*k+p*n) and changing it to nil makes
-it O(n). If p is small, then the default is probably faster."
- :version "22.1"
- :type 'boolean
- :group 'nnimap)
-
-(defvoo nnimap-need-unselect-to-notice-new-mail t
- "Unselect mailboxes before looking for new mail in them.
-Some servers seem to need this under some circumstances.")
-
-(defvoo nnimap-logout-timeout nil
- "Close server immediately if it can't logout in this number of seconds.
-If it is nil, never close server until logout completes. This variable
-overrides `imap-logout-timeout' on a per-server basis.")
-
-;; Authorization / Privacy variables
-
-(defvoo nnimap-auth-method nil
- "Obsolete.")
-
-(defvoo nnimap-stream nil
- "How nnimap will connect to the server.
-
-The default, nil, will try to use the \"best\" method the server can
-handle.
-
-Change this if
-
-1) you want to connect with TLS/SSL. The TLS/SSL integration
- with IMAP is suboptimal so you'll have to tell it
- specifically.
-
-2) your server is more capable than your environment -- i.e. your
- server accept Kerberos login's but you haven't installed the
- `imtest' program or your machine isn't configured for Kerberos.
-
-Possible choices: gssapi, kerberos4, starttls, tls, ssl, network, shell.
-See also `imap-streams' and `imap-stream-alist'.")
+(defvoo nnimap-split-fancy nil
+ "Uses the same syntax as nnmail-split-fancy.")
+
+(defvoo nnimap-unsplittable-articles '(%Deleted %Seen)
+ "Articles with the flags in the list will not be considered when splitting.")
+
+(make-obsolete-variable 'nnimap-split-rule "see `nnimap-split-methods'"
+ "Emacs 24.1")
(defvoo nnimap-authenticator nil
"How nnimap authenticate itself to the server.
+Possible choices are nil (use default methods) or `anonymous'.")
-The default, nil, will try to use the \"best\" method the server can
-handle.
-
-There is only one reason for fiddling with this variable, and that is
-if your server is more capable than your environment -- i.e. you
-connect to a server that accept Kerberos login's but you haven't
-installed the `imtest' program or your machine isn't configured for
-Kerberos.
-
-Possible choices: gssapi, kerberos4, digest-md5, cram-md5, login, anonymous.
-See also `imap-authenticators' and `imap-authenticator-alist'")
-
-(defvoo nnimap-directory (nnheader-concat gnus-directory "overview/")
- "Directory to keep NOV cache files for nnimap groups.
-See also `nnimap-nov-file-name'.")
-
-(defvoo nnimap-nov-file-name "nnimap."
- "NOV cache base filename.
-The group name and `nnimap-nov-file-name-suffix' will be appended. A
-typical complete file name would be
-~/News/overview/nnimap.pdc.INBOX.ding.nov, or
-~/News/overview/nnimap/pdc/INBOX/ding/nov if
-`nnmail-use-long-file-names' is nil")
-
-(defvoo nnimap-nov-file-name-suffix ".novcache"
- "Suffix for NOV cache base filename.")
-
-(defvoo nnimap-nov-is-evil gnus-agent
- "If non-nil, never generate or use a local nov database for this backend.
-Using nov databases should speed up header fetching considerably.
-However, it will invoke a UID SEARCH UID command on the server, and
-some servers implement this command inefficiently by opening each and
-every message in the group, thus making it quite slow.
-Unlike other backends, you do not need to take special care if you
-flip this variable.")
-
-(defvoo nnimap-search-uids-not-since-is-evil nil
- "If non-nil, avoid \"UID SEARCH UID ... NOT SINCE\" queries when expiring.
-Instead, use \"UID SEARCH SINCE\" to prune the list of expirable
-articles within Gnus. This seems to be faster on Courier in some cases.")
-
-(defvoo nnimap-expunge-on-close 'always ; 'ask, 'never
- "Whether to expunge a group when it is closed.
-When a IMAP group with articles marked for deletion is closed, this
-variable determine if nnimap should actually remove the articles or
-not.
-
-If always, nnimap always perform a expunge when closing the group.
-If never, nnimap never expunges articles marked for deletion.
-If ask, nnimap will ask you if you wish to expunge marked articles.
-
-When setting this variable to `never', you can only expunge articles
-by using `G x' (gnus-group-nnimap-expunge) from the Group buffer.")
-
-(defvoo nnimap-list-pattern "*"
- "A string LIMIT or list of strings with mailbox wildcards used to limit available groups.
-See below for available wildcards.
-
-The LIMIT string can be a cons cell (REFERENCE . LIMIT), where
-REFERENCE will be passed as the first parameter to LIST/LSUB. The
-semantics of this are server specific, on the University of Washington
-server you can specify a directory.
-
-Example:
- '(\"INBOX\" \"mail/*\" (\"~friend/mail/\" . \"list/*\"))
-
-There are two wildcards * and %. * matches everything, % matches
-everything in the current hierarchy.")
-
-(defvoo nnimap-news-groups nil
- "IMAP support a news-like mode, also known as bulletin board mode,
-where replies is sent via IMAP instead of SMTP.
-
-This variable should contain a regexp matching groups where you wish
-replies to be stored to the mailbox directly.
-
-Example:
- '(\"^[^I][^N][^B][^O][^X].*$\")
-
-This will match all groups not beginning with \"INBOX\".
-
-Note that there is nothing technically different between mail-like and
-news-like mailboxes. If you wish to have a group with todo items or
-similar which you wouldn't want to set up a mailing list for, you can
-use this to make replies go directly to the group.")
-
-(defvoo nnimap-expunge-search-string "UID %s NOT SINCE %s"
- "IMAP search command to use for articles that are to be expired.
-The first %s is replaced by a UID set of articles to search on,
-and the second %s is replaced by a date criterium.
-
-One useful (and perhaps the only useful) value to change this to would
-be `UID %s NOT SENTSINCE %s' to make nnimap use the Date: header
-instead of the internal date of messages. See section 6.4.4 of RFC
-2060 for more information on valid strings.
-
-However, if `nnimap-search-uids-not-since-is-evil' is true, this
-variable has no effect since the search logic is reversed.")
-
-(defvoo nnimap-importantize-dormant t
- "If non-nil, mark \"dormant\" articles as \"ticked\" for other IMAP clients.
-Note that within Gnus, dormant articles will still (only) be
-marked as ticked. This is to make \"dormant\" articles stand out,
-just like \"ticked\" articles, in other IMAP clients.")
-
-(defvoo nnimap-server-address nil
- "Obsolete. Use `nnimap-address'.")
-
-(defcustom nnimap-authinfo-file "~/.authinfo"
- "Authorization information for IMAP servers. In .netrc format."
- :type
- '(choice file
- (repeat :tag "Entries"
- :menu-tag "Inline"
- (list :format "%v"
- :value ("" ("login" . "") ("password" . ""))
- (string :tag "Host")
- (checklist :inline t
- (cons :format "%v"
- (const :format "" "login")
- (string :format "Login: %v"))
- (cons :format "%v"
- (const :format "" "password")
- (string :format "Password: %v"))))))
- :group 'nnimap)
-
-(defcustom nnimap-prune-cache t
- "If non-nil, nnimap check whether articles still exist on server before using data stored in NOV cache."
- :type 'boolean
- :group 'nnimap)
-
-(defvar nnimap-request-list-method 'imap-mailbox-list
- "Method to use to request a list of all folders from the server.
-If this is 'imap-mailbox-lsub, then use a server-side subscription list to
-restrict visible folders.")
-
-(defcustom nnimap-id nil
- "Plist with client identity to send to server upon login.
-A nil value means no information is sent, symbol `no' to disable ID query
-altogether, or plist with identifier-value pairs to send to
-server. RFC 2971 describes the list as follows:
-
- Any string may be sent as a field, but the following are defined to
- describe certain values that might be sent. Implementations are free
- to send none, any, or all of these. Strings are not case-sensitive.
- Field strings MUST NOT be longer than 30 octets. Value strings MUST
- NOT be longer than 1024 octets. Implementations MUST NOT send more
- than 30 field-value pairs.
-
- name Name of the program
- version Version number of the program
- os Name of the operating system
- os-version Version of the operating system
- vendor Vendor of the client/server
- support-url URL to contact for support
- address Postal address of contact/vendor
- date Date program was released, specified as a date-time
- in IMAP4rev1
- command Command used to start the program
- arguments Arguments supplied on the command line, if any
- if any
- environment Description of environment, i.e., UNIX environment
- variables or Windows registry settings
-
- Implementations MUST NOT send the same field name more than once.
-
-An example plist would be '(\"name\" \"Gnus\" \"version\" gnus-version-number
-\"os\" system-configuration \"vendor\" \"GNU\")."
- :group 'nnimap
- :type '(choice (const :tag "No information" nil)
- (const :tag "Disable ID query" no)
- (plist :key-type string :value-type string)))
-
-(defcustom nnimap-debug nil
- "If non-nil, trace nnimap- functions into `nnimap-debug-buffer'.
-Uses `trace-function-background', so you can turn it off with,
-say, `untrace-all'.
-
-Note that username, passwords and other privacy sensitive
-information (such as e-mail) may be stored in the buffer.
-It is not written to disk, however. Do not enable this
-variable unless you are comfortable with that.
-
-This variable only takes effect when loading the `nnimap' library.
-See also `nnimap-log'."
- :group 'nnimap
- :type 'boolean)
-
-;; Internal variables:
-
-(defvar nnimap-debug-buffer "*nnimap-debug*")
-(defvar nnimap-mailbox-info (gnus-make-hashtable 997))
-(defvar nnimap-current-move-server nil)
-(defvar nnimap-current-move-group nil)
-(defvar nnimap-current-move-article nil)
-(defvar nnimap-length)
-(defvar nnimap-progress-chars '(?| ?/ ?- ?\\))
-(defvar nnimap-progress-how-often 20)
-(defvar nnimap-counter)
-(defvar nnimap-server-buffer-alist nil) ;; Map server name to buffers.
-(defvar nnimap-current-server nil) ;; Current server
-(defvar nnimap-server-buffer nil) ;; Current servers' buffer
-
-
-
-(nnoo-define-basics nnimap)
-
-;; Utility functions:
-
-(defsubst nnimap-get-server-buffer (server)
- "Return buffer for SERVER, if nil use current server."
- (cadr (assoc (or server nnimap-current-server) nnimap-server-buffer-alist)))
-
-(defun nnimap-remove-server-from-buffer-alist (server list)
- "Remove SERVER from LIST."
- (let (l)
- (dolist (e list)
- (unless (equal server (car-safe e))
- (push e l)))
- l))
-
-(defun nnimap-possibly-change-server (server)
- "Return buffer for SERVER, changing the current server as a side-effect.
-If SERVER is nil, uses the current server."
- (setq nnimap-current-server (or server nnimap-current-server)
- nnimap-server-buffer (nnimap-get-server-buffer nnimap-current-server)))
-
-(defun nnimap-verify-uidvalidity (group server)
- "Verify stored uidvalidity match current one in GROUP on SERVER."
- (let* ((gnusgroup (gnus-group-prefixed-name
- group (gnus-server-to-method
- (format "nnimap:%s" server))))
- (new-uidvalidity (imap-mailbox-get 'uidvalidity))
- (old-uidvalidity (gnus-group-get-parameter gnusgroup 'uidvalidity))
- (dir (file-name-as-directory (expand-file-name nnimap-directory)))
- (nameuid (nnheader-translate-file-chars
- (concat nnimap-nov-file-name
- (if (equal server "")
- "unnamed"
- server) "." group "." old-uidvalidity
- nnimap-nov-file-name-suffix) t))
- (file (if (or nnmail-use-long-file-names
- (file-exists-p (expand-file-name nameuid dir)))
- (expand-file-name nameuid dir)
- (expand-file-name
- (mm-encode-coding-string
- (nnheader-replace-chars-in-string nameuid ?. ?/)
- nnmail-pathname-coding-system)
- dir))))
- (if old-uidvalidity
- (if (not (equal old-uidvalidity new-uidvalidity))
- ;; uidvalidity clash
- (gnus-delete-file file)
- (gnus-group-set-parameter gnusgroup 'uidvalidity new-uidvalidity)
- t)
- (gnus-group-add-parameter gnusgroup (cons 'uidvalidity new-uidvalidity))
- t)))
+(defvoo nnimap-expunge t
+ "If non-nil, expunge articles after deleting them.
+This is always done if the server supports UID EXPUNGE, but it's
+not done by default on servers that doesn't support that command.")
-(defun nnimap-before-find-minmax-bugworkaround ()
- "Function called before iterating through mailboxes with
-`nnimap-find-minmax-uid'."
- (when nnimap-need-unselect-to-notice-new-mail
- ;; XXX this is for UoW imapd problem, it doesn't notice new mail in
- ;; currently selected mailbox without a re-select/examine.
- (or (null (imap-current-mailbox nnimap-server-buffer))
- (imap-mailbox-unselect nnimap-server-buffer))))
-
-(defun nnimap-find-minmax-uid (group &optional examine)
- "Find lowest and highest active article number in GROUP.
-If EXAMINE is non-nil the group is selected read-only."
- (with-current-buffer nnimap-server-buffer
- (when (or (string= group (imap-current-mailbox))
- (imap-mailbox-select group examine))
- (let (minuid maxuid)
- (when (> (imap-mailbox-get 'exists) 0)
- (imap-fetch-safe '("1,*" . "1,*:*") "UID" nil 'nouidfetch)
- (imap-message-map (lambda (uid Uid)
- (setq minuid (if minuid (min minuid uid) uid)
- maxuid (if maxuid (max maxuid uid) uid)))
- 'UID))
- (list (imap-mailbox-get 'exists) minuid maxuid)))))
-
-(defun nnimap-possibly-change-group (group &optional server)
- "Make GROUP the current group, and SERVER the current server."
- (when (nnimap-possibly-change-server server)
- (with-current-buffer nnimap-server-buffer
- (if (or (null group) (imap-current-mailbox-p group))
- imap-current-mailbox
- (if (imap-mailbox-select group)
- (if (or (nnimap-verify-uidvalidity
- group (or server nnimap-current-server))
- (zerop (imap-mailbox-get 'exists group))
- t ;; for OGnus to see if ignoring uidvalidity
- ;; changes has any bad effects.
- (yes-or-no-p
- (format
- "nnimap: Group %s is not uidvalid. Continue? " group)))
- imap-current-mailbox
- (imap-mailbox-unselect)
- (error "nnimap: Group %s is not uid-valid" group))
- (nnheader-report 'nnimap (imap-error-text)))))))
-
-(defun nnimap-replace-whitespace (string)
- "Return STRING with all whitespace replaced with space."
- (when string
- (while (string-match "[\r\n\t]+" string)
- (setq string (replace-match " " t t string)))
- string))
-
-;; Required backend functions
-
-(defun nnimap-retrieve-headers-progress ()
- "Hook to insert NOV line for current article into `nntp-server-buffer'."
- (and (numberp nnmail-large-newsgroup)
- (zerop (% (incf nnimap-counter) nnimap-progress-how-often))
- (> nnimap-length nnmail-large-newsgroup)
- (nnheader-message 6 "nnimap: Retrieving headers... %c"
- (nth (/ (% nnimap-counter
- (* (length nnimap-progress-chars)
- nnimap-progress-how-often))
- nnimap-progress-how-often)
- nnimap-progress-chars)))
- (with-current-buffer nntp-server-buffer
- (let (headers lines chars uid mbx)
- (with-current-buffer nnimap-server-buffer
- (setq uid imap-current-message
- mbx imap-current-mailbox
- headers (if (imap-capability 'IMAP4rev1)
- ;; xxx don't just use car? alist doesn't contain
- ;; anything else now, but it might...
- (nth 2 (car (imap-message-get uid 'BODYDETAIL)))
- (imap-message-get uid 'RFC822.HEADER))
- lines (imap-body-lines (imap-message-body imap-current-message))
- chars (imap-message-get imap-current-message 'RFC822.SIZE)))
- (nnheader-insert-nov
- ;; At this stage, we only have bytes, so let's use unibyte buffers
- ;; to make it more clear.
- (mm-with-unibyte-buffer
- (buffer-disable-undo)
- ;; headers can be nil if article is write-only
- (when headers (insert headers))
- (let ((head (nnheader-parse-naked-head uid)))
- (mail-header-set-number head uid)
- (mail-header-set-chars head chars)
- (mail-header-set-lines head lines)
- (mail-header-set-xref
- head (format "%s %s:%d" (system-name) mbx uid))
- head))))))
-
-(defun nnimap-retrieve-which-headers (articles fetch-old)
- "Get a range of articles to fetch based on ARTICLES and FETCH-OLD."
- (with-current-buffer nnimap-server-buffer
- (if (numberp (car-safe articles))
- (imap-search
- (concat "UID "
- (imap-range-to-message-set
- (gnus-compress-sequence
- (append (gnus-uncompress-sequence
- (and fetch-old
- (cons (if (numberp fetch-old)
- (max 1 (- (car articles) fetch-old))
- 1)
- (1- (car articles)))))
- articles)))))
- (mapcar (lambda (msgid)
- (imap-search
- (format "HEADER Message-Id \"%s\"" msgid)))
- articles))))
-
-(defun nnimap-group-overview-filename (group server)
- "Make file name for GROUP on SERVER."
- (let* ((dir (file-name-as-directory (expand-file-name nnimap-directory)))
- (uidvalidity (gnus-group-get-parameter
- (gnus-group-prefixed-name
- group (gnus-server-to-method
- (format "nnimap:%s" server)))
- 'uidvalidity))
- (name (nnheader-translate-file-chars
- (concat nnimap-nov-file-name
- (if (equal server "")
- "unnamed"
- server) "." group nnimap-nov-file-name-suffix) t))
- (nameuid (nnheader-translate-file-chars
- (concat nnimap-nov-file-name
- (if (equal server "")
- "unnamed"
- server) "." group "." uidvalidity
- nnimap-nov-file-name-suffix) t))
- (oldfile (if (or nnmail-use-long-file-names
- (file-exists-p (expand-file-name name dir)))
- (expand-file-name name dir)
- (expand-file-name
- (mm-encode-coding-string
- (nnheader-replace-chars-in-string name ?. ?/)
- nnmail-pathname-coding-system)
- dir)))
- (newfile (if (or nnmail-use-long-file-names
- (file-exists-p (expand-file-name nameuid dir)))
- (expand-file-name nameuid dir)
- (expand-file-name
- (mm-encode-coding-string
- (nnheader-replace-chars-in-string nameuid ?. ?/)
- nnmail-pathname-coding-system)
- dir))))
- (when (and (file-exists-p oldfile) (not (file-exists-p newfile)))
- (message "nnimap: Upgrading novcache filename...")
- (sit-for 1)
- (gnus-make-directory (file-name-directory newfile))
- (unless (ignore-errors (rename-file oldfile newfile) t)
- (if (ignore-errors (copy-file oldfile newfile) t)
- (delete-file oldfile)
- (error "Can't rename `%s' to `%s'" oldfile newfile))))
- newfile))
-
-(defun nnimap-retrieve-headers-from-file (group server)
- (with-current-buffer nntp-server-buffer
- (let ((nov (nnimap-group-overview-filename group server)))
- (when (file-exists-p nov)
- (mm-insert-file-contents nov)
- (set-buffer-modified-p nil)
- (let ((min (ignore-errors (goto-char (point-min))
- (read (current-buffer))))
- (max (ignore-errors (goto-char (point-max))
- (forward-line -1)
- (read (current-buffer)))))
- (if (and (numberp min) (numberp max))
- (cons min max)
- ;; junk, remove it, it's saved later
- (erase-buffer)
- nil))))))
-
-(defun nnimap-retrieve-headers-from-server (articles group server)
- (with-current-buffer nnimap-server-buffer
- (let ((imap-fetch-data-hook '(nnimap-retrieve-headers-progress))
- (nnimap-length (gnus-range-length articles))
- (nnimap-counter 0))
- (imap-fetch (imap-range-to-message-set articles)
- (concat "(UID RFC822.SIZE BODY "
- (let ((headers
- (append '(Subject From Date Message-Id
- References In-Reply-To Xref)
- (copy-sequence
- nnmail-extra-headers))))
- (if (imap-capability 'IMAP4rev1)
- (format "BODY.PEEK[HEADER.FIELDS %s])" headers)
- (format "RFC822.HEADER.LINES %s)" headers)))))
- (with-current-buffer nntp-server-buffer
- (sort-numeric-fields 1 (point-min) (point-max)))
- (and (numberp nnmail-large-newsgroup)
- (> nnimap-length nnmail-large-newsgroup)
- (nnheader-message 6 "nnimap: Retrieving headers...done")))))
-
-(defun nnimap-dont-use-nov-p (group server)
- (or gnus-nov-is-evil nnimap-nov-is-evil
- (unless (and (gnus-make-directory
- (file-name-directory
- (nnimap-group-overview-filename group server)))
- (file-writable-p
- (nnimap-group-overview-filename group server)))
- (message "nnimap: Nov cache not writable, %s"
- (nnimap-group-overview-filename group server)))))
+(defvoo nnimap-streaming t
+ "If non-nil, try to use streaming commands with IMAP servers.
+Switching this off will make nnimap slower, but it helps with
+some servers.")
+
+(defvoo nnimap-connection-alist nil)
+
+(defvoo nnimap-current-infos nil)
+
+(defvoo nnimap-fetch-partial-articles nil
+ "If non-nil, Gnus will fetch partial articles.
+If t, nnimap will fetch only the first part. If a string, it
+will fetch all parts that have types that match that string. A
+likely value would be \"text/\" to automatically fetch all
+textual parts.")
+
+(defvar nnimap-process nil)
+
+(defvar nnimap-status-string "")
+
+(defvar nnimap-split-download-body-default nil
+ "Internal variable with default value for `nnimap-split-download-body'.")
+
+(defvar nnimap-keepalive-timer nil)
+(defvar nnimap-process-buffers nil)
+
+(defstruct nnimap
+ group process commands capabilities select-result newlinep server
+ last-command-time greeting examined)
+
+(defvar nnimap-object nil)
+
+(defvar nnimap-mark-alist
+ '((read "\\Seen" %Seen)
+ (tick "\\Flagged" %Flagged)
+ (reply "\\Answered" %Answered)
+ (expire "gnus-expire")
+ (dormant "gnus-dormant")
+ (score "gnus-score")
+ (save "gnus-save")
+ (download "gnus-download")
+ (forward "gnus-forward")))
+
+(defun nnimap-buffer ()
+ (nnimap-find-process-buffer nntp-server-buffer))
+
+(defun nnimap-header-parameters ()
+ (format "(UID RFC822.SIZE BODYSTRUCTURE %s)"
+ (format
+ (if (nnimap-ver4-p)
+ "BODY.PEEK[HEADER.FIELDS %s]"
+ "RFC822.HEADER.LINES %s")
+ (append '(Subject From Date Message-Id
+ References In-Reply-To Xref)
+ nnmail-extra-headers))))
(deffoo nnimap-retrieve-headers (articles &optional group server fetch-old)
- (when (nnimap-possibly-change-group group server)
- (with-current-buffer nntp-server-buffer
- (erase-buffer)
- (if (nnimap-dont-use-nov-p group server)
- (nnimap-retrieve-headers-from-server
- (gnus-compress-sequence articles) group server)
- (let (uids cached low high)
- (when (setq uids (nnimap-retrieve-which-headers articles fetch-old)
- low (car uids)
- high (car (last uids)))
- (if (setq cached (nnimap-retrieve-headers-from-file group server))
- (progn
- ;; fetch articles with uids before cache block
- (when (< low (car cached))
- (goto-char (point-min))
- (nnimap-retrieve-headers-from-server
- (cons low (1- (car cached))) group server))
- ;; fetch articles with uids after cache block
- (when (> high (cdr cached))
- (goto-char (point-max))
- (nnimap-retrieve-headers-from-server
- (cons (1+ (cdr cached)) high) group server))
- (when nnimap-prune-cache
- ;; remove nov's for articles which has expired on server
- (goto-char (point-min))
- (dolist (uid (gnus-set-difference articles uids))
- (when (re-search-forward (format "^%d\t" uid) nil t)
- (gnus-delete-line)))))
- ;; nothing cached, fetch whole range from server
- (nnimap-retrieve-headers-from-server
- (cons low high) group server))
- (when (buffer-modified-p)
- (nnmail-write-region
- (point-min) (point-max)
- (nnimap-group-overview-filename group server) nil 'nomesg))
- (nnheader-nov-delete-outside-range low high))))
- 'nov)))
-
-(defun nnimap-open-connection (server)
- ;; Note: `nnimap-open-server' that calls this function binds
- ;; `imap-logout-timeout' to `nnimap-logout-timeout'.
- (if (not (imap-open nnimap-address nnimap-server-port nnimap-stream
- nnimap-authenticator nnimap-server-buffer))
- (nnheader-report 'nnimap "Can't open connection to server %s" server)
- (unless (or (imap-capability 'IMAP4 nnimap-server-buffer)
- (imap-capability 'IMAP4rev1 nnimap-server-buffer))
- (imap-close nnimap-server-buffer)
- (nnheader-report 'nnimap "Server %s is not IMAP4 compliant" server))
- (let* ((list (progn (gnus-message 7 "Parsing authinfo file `%s'."
- nnimap-authinfo-file)
- (netrc-parse nnimap-authinfo-file)))
- (port (if nnimap-server-port
- (int-to-string nnimap-server-port)
- "imap"))
- (auth-info
- (auth-source-user-or-password '("login" "password") server port))
- (auth-user (nth 0 auth-info))
- (auth-passwd (nth 1 auth-info))
- (user (or
- auth-user ; this is preferred to netrc-*
- (netrc-machine-user-or-password
- "login"
- list
- (list server
- (or nnimap-server-address
- nnimap-address))
- (list port)
- (list "imap" "imaps" "143" "993"))))
- (passwd (or
- auth-passwd ; this is preferred to netrc-*
- (netrc-machine-user-or-password
- "password"
- list
- (list server
- (or nnimap-server-address
- nnimap-address))
- (list port)
- (list "imap" "imaps" "143" "993")))))
- (if (imap-authenticate user passwd nnimap-server-buffer)
- (prog2
- (setq nnimap-server-buffer-alist
- (nnimap-remove-server-from-buffer-alist
- server
- nnimap-server-buffer-alist))
- (push (list server nnimap-server-buffer)
- nnimap-server-buffer-alist)
- (imap-id nnimap-id nnimap-server-buffer)
- (nnimap-possibly-change-server server))
- (imap-close nnimap-server-buffer)
- (kill-buffer nnimap-server-buffer)
- (nnheader-report 'nnimap "Could not authenticate to %s" server)))))
+ (with-current-buffer nntp-server-buffer
+ (erase-buffer)
+ (when (nnimap-possibly-change-group group server)
+ (with-current-buffer (nnimap-buffer)
+ (erase-buffer)
+ (nnimap-wait-for-response
+ (nnimap-send-command
+ "UID FETCH %s %s"
+ (nnimap-article-ranges (gnus-compress-sequence articles))
+ (nnimap-header-parameters))
+ t)
+ (nnimap-transform-headers))
+ (insert-buffer-substring
+ (nnimap-find-process-buffer (current-buffer))))
+ 'headers))
+
+(defun nnimap-transform-headers ()
+ (goto-char (point-min))
+ (let (article bytes lines size string)
+ (block nil
+ (while (not (eobp))
+ (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)"))
+ (delete-region (point) (progn (forward-line 1) (point)))
+ (when (eobp)
+ (return)))
+ (setq article (match-string 1))
+ ;; Unfold quoted {number} strings.
+ (while (re-search-forward "[^]][ (]{\\([0-9]+\\)}\r?\n"
+ (1+ (line-end-position)) t)
+ (setq size (string-to-number (match-string 1)))
+ (delete-region (+ (match-beginning 0) 2) (point))
+ (setq string (buffer-substring (point) (+ (point) size)))
+ (delete-region (point) (+ (point) size))
+ (insert (format "%S" string)))
+ (setq bytes (nnimap-get-length)
+ lines nil)
+ (beginning-of-line)
+ (setq size
+ (and (re-search-forward "RFC822.SIZE \\([0-9]+\\)"
+ (line-end-position)
+ t)
+ (match-string 1)))
+ (beginning-of-line)
+ (when (search-forward "BODYSTRUCTURE" (line-end-position) t)
+ (let ((structure (ignore-errors
+ (read (current-buffer)))))
+ (while (and (consp structure)
+ (not (stringp (car structure))))
+ (setq structure (car structure)))
+ (setq lines (nth 7 structure))))
+ (delete-region (line-beginning-position) (line-end-position))
+ (insert (format "211 %s Article retrieved." article))
+ (forward-line 1)
+ (when size
+ (insert (format "Chars: %s\n" size)))
+ (when lines
+ (insert (format "Lines: %s\n" lines)))
+ (unless (re-search-forward "^\r$" nil t)
+ (goto-char (point-max)))
+ (delete-region (line-beginning-position) (line-end-position))
+ (insert ".")
+ (forward-line 1)))))
+
+(defun nnimap-unfold-quoted-lines ()
+ ;; Unfold quoted {number} strings.
+ (let (size string)
+ (while (re-search-forward " {\\([0-9]+\\)}\r?\n" nil t)
+ (setq size (string-to-number (match-string 1)))
+ (delete-region (1+ (match-beginning 0)) (point))
+ (setq string (buffer-substring (point) (+ (point) size)))
+ (delete-region (point) (+ (point) size))
+ (insert (format "%S" string)))))
+
+(defun nnimap-get-length ()
+ (and (re-search-forward "{\\([0-9]+\\)}" (line-end-position) t)
+ (string-to-number (match-string 1))))
+
+(defun nnimap-article-ranges (ranges)
+ (let (result)
+ (cond
+ ((numberp ranges)
+ (number-to-string ranges))
+ ((numberp (cdr ranges))
+ (format "%d:%d" (car ranges) (cdr ranges)))
+ (t
+ (dolist (elem ranges)
+ (push
+ (if (consp elem)
+ (format "%d:%d" (car elem) (cdr elem))
+ (number-to-string elem))
+ result))
+ (mapconcat #'identity (nreverse result) ",")))))
(deffoo nnimap-open-server (server &optional defs)
- (nnheader-init-server-buffer)
(if (nnimap-server-opened server)
t
- (unless (assq 'nnimap-server-buffer defs)
- (push (list 'nnimap-server-buffer (concat " *nnimap* " server)) defs))
- ;; translate `nnimap-server-address' to `nnimap-address' in defs
- ;; for people that configured nnimap with a very old version
(unless (assq 'nnimap-address defs)
- (if (assq 'nnimap-server-address defs)
- (push (list 'nnimap-address
- (cadr (assq 'nnimap-server-address defs))) defs)
- (push (list 'nnimap-address server) defs)))
+ (setq defs (append defs (list (list 'nnimap-address server)))))
(nnoo-change-server 'nnimap server defs)
- (or nnimap-server-buffer
- (setq nnimap-server-buffer (cadr (assq 'nnimap-server-buffer defs))))
- (with-current-buffer (get-buffer-create nnimap-server-buffer)
- (nnoo-change-server 'nnimap server defs))
- (let ((imap-logout-timeout nnimap-logout-timeout))
- (or (and nnimap-server-buffer
- (imap-opened nnimap-server-buffer)
- (if (with-current-buffer nnimap-server-buffer
- (memq imap-state '(auth selected examine)))
- t
- (imap-close nnimap-server-buffer)
- (nnimap-open-connection server)))
- (nnimap-open-connection server)))))
-
-(deffoo nnimap-server-opened (&optional server)
- "Whether SERVER is opened.
-If SERVER is the current virtual server, and the connection to the
-physical server is alive, this function return a non-nil value. If
-SERVER is nil, it is treated as the current server."
- ;; clean up autologouts??
- (and (or server nnimap-current-server)
- (nnoo-server-opened 'nnimap (or server nnimap-current-server))
- (imap-opened (nnimap-get-server-buffer server))))
+ (or (nnimap-find-connection nntp-server-buffer)
+ (nnimap-open-connection nntp-server-buffer))))
+
+(defun nnimap-make-process-buffer (buffer)
+ (with-current-buffer
+ (generate-new-buffer (format "*nnimap %s %s %s*"
+ nnimap-address nnimap-server-port
+ (gnus-buffer-exists-p buffer)))
+ (mm-disable-multibyte)
+ (buffer-disable-undo)
+ (gnus-add-buffer)
+ (set (make-local-variable 'after-change-functions) nil)
+ (set (make-local-variable 'nnimap-object)
+ (make-nnimap :server (nnoo-current-server 'nnimap)))
+ (push (list buffer (current-buffer)) nnimap-connection-alist)
+ (push (current-buffer) nnimap-process-buffers)
+ (current-buffer)))
+
+(defun nnimap-open-shell-stream (name buffer host port)
+ (let ((process-connection-type nil))
+ (start-process name buffer shell-file-name
+ shell-command-switch
+ (format-spec
+ nnimap-shell-program
+ (format-spec-make
+ ?s host
+ ?p port)))))
+
+(defun nnimap-credentials (address ports &optional inhibit-create)
+ (let (port credentials)
+ ;; Request the credentials from all ports, but only query on the
+ ;; last port if all the previous ones have failed.
+ (while (and (null credentials)
+ (setq port (pop ports)))
+ (setq credentials
+ (auth-source-user-or-password
+ '("login" "password") address port nil
+ (if inhibit-create
+ nil
+ (null ports)))))
+ credentials))
+
+(defun nnimap-keepalive ()
+ (let ((now (current-time)))
+ (dolist (buffer nnimap-process-buffers)
+ (when (buffer-name buffer)
+ (with-current-buffer buffer
+ (when (and nnimap-object
+ (nnimap-last-command-time nnimap-object)
+ (> (gnus-float-time
+ (time-subtract
+ now
+ (nnimap-last-command-time nnimap-object)))
+ ;; More than five minutes since the last command.
+ (* 5 60)))
+ (nnimap-send-command "NOOP")))))))
+
+(declare-function gnutls-negotiate "gnutls"
+ (proc type &optional priority-string trustfiles keyfiles))
+
+(defun nnimap-open-connection (buffer)
+ (unless nnimap-keepalive-timer
+ (setq nnimap-keepalive-timer (run-at-time (* 60 15) (* 60 15)
+ 'nnimap-keepalive)))
+ (block nil
+ (with-current-buffer (nnimap-make-process-buffer buffer)
+ (let* ((coding-system-for-read 'binary)
+ (coding-system-for-write 'binary)
+ (port nil)
+ (ports
+ (cond
+ ((or (eq nnimap-stream 'network)
+ (and (eq nnimap-stream 'starttls)
+ (fboundp 'open-gnutls-stream)))
+ (nnheader-message 7 "Opening connection to %s..."
+ nnimap-address)
+ (open-network-stream
+ "*nnimap*" (current-buffer) nnimap-address
+ (setq port
+ (or nnimap-server-port
+ (if (netrc-find-service-number "imap")
+ "imap"
+ "143"))))
+ '("143" "imap"))
+ ((eq nnimap-stream 'shell)
+ (nnheader-message 7 "Opening connection to %s via shell..."
+ nnimap-address)
+ (nnimap-open-shell-stream
+ "*nnimap*" (current-buffer) nnimap-address
+ (setq port (or nnimap-server-port "imap")))
+ '("imap"))
+ ((eq nnimap-stream 'starttls)
+ (nnheader-message 7 "Opening connection to %s via starttls..."
+ nnimap-address)
+ (let ((tls-program
+ '("openssl s_client -connect %h:%p -no_ssl2 -ign_eof -starttls imap")))
+ (open-tls-stream
+ "*nnimap*" (current-buffer) nnimap-address
+ (setq port (or nnimap-server-port "imap"))))
+ '("imap"))
+ ((memq nnimap-stream '(ssl tls))
+ (nnheader-message 7 "Opening connection to %s via tls..."
+ nnimap-address)
+ (funcall (if (fboundp 'open-gnutls-stream)
+ 'open-gnutls-stream
+ 'open-tls-stream)
+ "*nnimap*" (current-buffer) nnimap-address
+ (setq port
+ (or nnimap-server-port
+ (if (netrc-find-service-number "imaps")
+ "imaps"
+ "993"))))
+ '("143" "993" "imap" "imaps"))
+ (t
+ (error "Unknown stream type: %s" nnimap-stream))))
+ connection-result login-result credentials)
+ (setf (nnimap-process nnimap-object)
+ (get-buffer-process (current-buffer)))
+ (if (not (and (nnimap-process nnimap-object)
+ (memq (process-status (nnimap-process nnimap-object))
+ '(open run))))
+ (nnheader-report 'nnimap "Unable to contact %s:%s via %s"
+ nnimap-address port nnimap-stream)
+ (gnus-set-process-query-on-exit-flag
+ (nnimap-process nnimap-object) nil)
+ (if (not (setq connection-result (nnimap-wait-for-connection)))
+ (nnheader-report 'nnimap
+ "%s" (buffer-substring
+ (point) (line-end-position)))
+ ;; Store the greeting (for debugging purposes).
+ (setf (nnimap-greeting nnimap-object)
+ (buffer-substring (line-beginning-position)
+ (line-end-position)))
+ (nnimap-get-capabilities)
+ (when nnimap-server-port
+ (push (format "%s" nnimap-server-port) ports))
+ ;; If this is a STARTTLS-capable server, then sever the
+ ;; connection and start a STARTTLS connection instead.
+ (cond
+ ((and (or (and (eq nnimap-stream 'network)
+ (nnimap-capability "STARTTLS"))
+ (eq nnimap-stream 'starttls))
+ (fboundp 'open-gnutls-stream))
+ (nnimap-command "STARTTLS")
+ (gnutls-negotiate (nnimap-process nnimap-object) nil)
+ ;; Get the capabilities again -- they may have changed
+ ;; after doing STARTTLS.
+ (nnimap-get-capabilities))
+ ((and (eq nnimap-stream 'network)
+ (nnimap-capability "STARTTLS"))
+ (let ((nnimap-stream 'starttls))
+ (let ((tls-process
+ (nnimap-open-connection buffer)))
+ ;; If the STARTTLS connection was successful, we
+ ;; kill our first non-encrypted connection. If it
+ ;; wasn't successful, we just use our unencrypted
+ ;; connection.
+ (when (memq (process-status tls-process) '(open run))
+ (delete-process (nnimap-process nnimap-object))
+ (kill-buffer (current-buffer))
+ (return tls-process))))))
+ (unless (equal connection-result "PREAUTH")
+ (if (not (setq credentials
+ (if (eq nnimap-authenticator 'anonymous)
+ (list "anonymous"
+ (message-make-address))
+ (or
+ ;; First look for the credentials based
+ ;; on the virtual server name.
+ (nnimap-credentials
+ (nnoo-current-server 'nnimap) ports t)
+ ;; Then look them up based on the
+ ;; physical address.
+ (nnimap-credentials nnimap-address ports)))))
+ (setq nnimap-object nil)
+ (setq login-result
+ (if (and (nnimap-capability "AUTH=PLAIN")
+ (nnimap-capability "LOGINDISABLED"))
+ (nnimap-command
+ "AUTHENTICATE PLAIN %s"
+ (base64-encode-string
+ (format "\000%s\000%s"
+ (nnimap-quote-specials (car credentials))
+ (nnimap-quote-specials (cadr credentials)))))
+ (nnimap-command "LOGIN %S %S"
+ (car credentials)
+ (cadr credentials))))
+ (unless (car login-result)
+ ;; If the login failed, then forget the credentials
+ ;; that are now possibly cached.
+ (dolist (host (list (nnoo-current-server 'nnimap)
+ nnimap-address))
+ (dolist (port ports)
+ (dolist (element '("login" "password"))
+ (auth-source-forget-user-or-password
+ element host port))))
+ (delete-process (nnimap-process nnimap-object))
+ (setq nnimap-object nil))))
+ (when nnimap-object
+ (when (nnimap-capability "QRESYNC")
+ (nnimap-command "ENABLE QRESYNC"))
+ (nnimap-process nnimap-object))))))))
+
+(defun nnimap-get-capabilities ()
+ (setf (nnimap-capabilities nnimap-object)
+ (mapcar
+ #'upcase
+ (nnimap-find-parameter
+ "CAPABILITY" (cdr (nnimap-command "CAPABILITY"))))))
+
+(defun nnimap-quote-specials (string)
+ (with-temp-buffer
+ (insert string)
+ (goto-char (point-min))
+ (while (re-search-forward "[\\\"]" nil t)
+ (forward-char -1)
+ (insert "\\")
+ (forward-char 1))
+ (buffer-string)))
+
+(defun nnimap-find-parameter (parameter elems)
+ (let (result)
+ (dolist (elem elems)
+ (cond
+ ((equal (car elem) parameter)
+ (setq result (cdr elem)))
+ ((and (equal (car elem) "OK")
+ (consp (cadr elem))
+ (equal (caadr elem) parameter))
+ (setq result (cdr (cadr elem))))))
+ result))
(deffoo nnimap-close-server (&optional server)
- "Close connection to server and free all resources connected to it.
-Return nil if the server couldn't be closed for some reason."
- (let ((server (or server nnimap-current-server))
- (imap-logout-timeout nnimap-logout-timeout))
- (when (or (nnimap-server-opened server)
- (imap-opened (nnimap-get-server-buffer server)))
- (imap-close (nnimap-get-server-buffer server))
- (kill-buffer (nnimap-get-server-buffer server))
- (setq nnimap-server-buffer nil
- nnimap-current-server nil
- nnimap-server-buffer-alist
- (nnimap-remove-server-from-buffer-alist
- server
- nnimap-server-buffer-alist)))
- (nnoo-close-server 'nnimap server)))
+ (when (nnoo-change-server 'nnimap server nil)
+ (ignore-errors
+ (delete-process (get-buffer-process (nnimap-buffer))))
+ (nnoo-close-server 'nnimap server)
+ t))
(deffoo nnimap-request-close ()
- "Close connection to all servers and free all resources that the backend have reserved.
-All buffers that have been created by that
-backend should be killed. (Not the nntp-server-buffer, though.) This
-function is generally only called when Gnus is shutting down."
- (mapc (lambda (server) (nnimap-close-server (car server)))
- nnimap-server-buffer-alist)
- (setq nnimap-server-buffer-alist nil))
+ t)
-(deffoo nnimap-status-message (&optional server)
- "This function returns the last error message from server."
- (when (nnimap-possibly-change-server server)
- (nnoo-status-message 'nnimap server)))
-
-;; We used to use a string-as-multibyte here, but it is really incorrect.
-;; This function is used when we're about to insert a unibyte string
-;; into a potentially multibyte buffer. The string is either an article
-;; header or body (or both?), undecoded. When Emacs is asked to convert
-;; a unibyte string to multibyte, it may either use the equivalent of
-;; nothing (e.g. non-Mule XEmacs), string-make-unibyte (i.e. decode using
-;; locale), string-as-multibyte (decode using emacs-internal coding system)
-;; or string-to-multibyte (keep the data undecoded as a sequence of bytes).
-;; Only the last one preserves the data such that we can reliably later on
-;; decode the text using the mime info.
-(defalias 'nnimap-demule 'mm-string-to-multibyte)
-
-(defun nnimap-make-callback (article gnus-callback buffer)
- "Return a callback function."
- `(lambda ()
- (nnimap-callback ,article ,gnus-callback ,buffer)))
-
-(defun nnimap-callback (article gnus-callback buffer)
- (when (eq article (imap-current-message))
- (remove-hook 'imap-fetch-data-hook
- (nnimap-make-callback article gnus-callback buffer))
- (with-current-buffer buffer
- (insert
- (with-current-buffer nnimap-server-buffer
- (nnimap-demule
- (if (imap-capability 'IMAP4rev1)
- ;; xxx don't just use car? alist doesn't contain
- ;; anything else now, but it might...
- (nth 2 (car (imap-message-get article 'BODYDETAIL)))
- (imap-message-get article 'RFC822)))))
- (nnheader-ms-strip-cr)
- (funcall gnus-callback t))))
-
-(defun nnimap-request-article-part (article part prop &optional
- group server to-buffer detail)
- (when (nnimap-possibly-change-group group server)
- (let ((article (if (stringp article)
- (car-safe (imap-search
- (format "HEADER Message-Id \"%s\"" article)
- nnimap-server-buffer))
- article)))
- (when article
- (gnus-message 10 "nnimap: Fetching (part of) article %d from %s..."
- article (or group imap-current-mailbox
- gnus-newsgroup-name))
- (if (not nnheader-callback-function)
- (with-current-buffer (or to-buffer nntp-server-buffer)
- (erase-buffer)
- (let ((data (imap-fetch article part prop nil
- nnimap-server-buffer)))
- ;; data can be nil if article is write-only
- (when data
- (insert (nnimap-demule (if detail
- (nth 2 (car data))
- data)))))
- (nnheader-ms-strip-cr)
- (gnus-message
- 10 "nnimap: Fetching (part of) article %d from %s...done"
- article (or group imap-current-mailbox gnus-newsgroup-name))
- (if (bobp)
- (nnheader-report 'nnimap "No such article %d in %s: %s"
- article (or group imap-current-mailbox
- gnus-newsgroup-name)
- (imap-error-text nnimap-server-buffer))
- (cons group article)))
- (add-hook 'imap-fetch-data-hook
- (nnimap-make-callback article
- nnheader-callback-function
- nntp-server-buffer))
- (imap-fetch-asynch article part nil nnimap-server-buffer)
- (cons group article))))))
+(deffoo nnimap-server-opened (&optional server)
+ (and (nnoo-current-server-p 'nnimap server)
+ nntp-server-buffer
+ (gnus-buffer-live-p nntp-server-buffer)
+ (nnimap-find-connection nntp-server-buffer)))
-(deffoo nnimap-asynchronous-p ()
- t)
+(deffoo nnimap-status-message (&optional server)
+ nnimap-status-string)
(deffoo nnimap-request-article (article &optional group server to-buffer)
- (if (imap-capability 'IMAP4rev1 nnimap-server-buffer)
- (nnimap-request-article-part
- article "BODY.PEEK[]" 'BODYDETAIL group server to-buffer 'detail)
- (nnimap-request-article-part
- article "RFC822.PEEK" 'RFC822 group server to-buffer)))
+ (with-current-buffer nntp-server-buffer
+ (let ((result (nnimap-possibly-change-group group server))
+ parts structure)
+ (when (stringp article)
+ (setq article (nnimap-find-article-by-message-id group article)))
+ (when (and result
+ article)
+ (erase-buffer)
+ (with-current-buffer (nnimap-buffer)
+ (erase-buffer)
+ (when nnimap-fetch-partial-articles
+ (nnimap-command "UID FETCH %d (BODYSTRUCTURE)" article)
+ (goto-char (point-min))
+ (when (re-search-forward "FETCH.*BODYSTRUCTURE" nil t)
+ (setq structure (ignore-errors
+ (let ((start (point)))
+ (forward-sexp 1)
+ (downcase-region start (point))
+ (goto-char start)
+ (read (current-buffer))))
+ parts (nnimap-find-wanted-parts structure))))
+ (when (if parts
+ (nnimap-get-partial-article article parts structure)
+ (nnimap-get-whole-article article))
+ (let ((buffer (current-buffer)))
+ (with-current-buffer (or to-buffer nntp-server-buffer)
+ (erase-buffer)
+ (insert-buffer-substring buffer)
+ (nnheader-ms-strip-cr)
+ (cons group article)))))))))
(deffoo nnimap-request-head (article &optional group server to-buffer)
- (if (imap-capability 'IMAP4rev1 nnimap-server-buffer)
- (nnimap-request-article-part
- article "BODY.PEEK[HEADER]" 'BODYDETAIL group server to-buffer 'detail)
- (nnimap-request-article-part
- article "RFC822.HEADER" 'RFC822.HEADER group server to-buffer)))
-
-(deffoo nnimap-request-body (article &optional group server to-buffer)
- (if (imap-capability 'IMAP4rev1 nnimap-server-buffer)
- (nnimap-request-article-part
- article "BODY.PEEK[TEXT]" 'BODYDETAIL group server to-buffer 'detail)
- (nnimap-request-article-part
- article "RFC822.TEXT.PEEK" 'RFC822.TEXT group server to-buffer)))
-
-(deffoo nnimap-request-group (group &optional server fast)
- (nnimap-request-update-info-internal
- group
- (gnus-get-info (gnus-group-prefixed-name
- group (gnus-server-to-method (format "nnimap:%s" server))))
- server)
(when (nnimap-possibly-change-group group server)
- (nnimap-before-find-minmax-bugworkaround)
- (let (info)
- (cond (fast group)
- ((null (setq info (nnimap-find-minmax-uid group t)))
- (nnheader-report 'nnimap "Could not get active info for %s"
- group))
- (t
- (nnheader-insert "211 %d %d %d %s\n" (or (nth 0 info) 0)
- (max 1 (or (nth 1 info) 1))
- (or (nth 2 info) 0) group)
- (nnheader-report 'nnimap "Group %s selected" group)
- t)))))
-
-(defun nnimap-update-unseen (group &optional server)
- "Update the unseen count in `nnimap-mailbox-info'."
- (gnus-sethash
- (gnus-group-prefixed-name group server)
- (let ((old (gnus-gethash-safe (gnus-group-prefixed-name group server)
- nnimap-mailbox-info)))
- (list (nth 0 old) (nth 1 old)
- (imap-mailbox-status group 'unseen nnimap-server-buffer)
- (nth 3 old)))
- nnimap-mailbox-info))
-
-(defun nnimap-close-group (group &optional server)
- (with-current-buffer nnimap-server-buffer
- (when (and (imap-opened)
- (nnimap-possibly-change-group group server))
- (nnimap-update-unseen group server)
- (case nnimap-expunge-on-close
- (always (progn
- (imap-mailbox-expunge nnimap-close-asynchronous)
- (unless nnimap-dont-close
- (imap-mailbox-close nnimap-close-asynchronous))))
- (ask (if (and (imap-search "DELETED")
- (gnus-y-or-n-p (format "Expunge articles in group `%s'? "
- imap-current-mailbox)))
- (progn
- (imap-mailbox-expunge nnimap-close-asynchronous)
- (unless nnimap-dont-close
- (imap-mailbox-close nnimap-close-asynchronous)))
- (imap-mailbox-unselect)))
- (t (imap-mailbox-unselect)))
- (not imap-current-mailbox))))
-
-(defun nnimap-pattern-to-list-arguments (pattern)
- (mapcar (lambda (p)
- (cons (car-safe p) (or (cdr-safe p) p)))
- (if (and (listp pattern)
- (listp (cdr pattern)))
- pattern
- (list pattern))))
+ (with-current-buffer (nnimap-buffer)
+ (when (stringp article)
+ (setq article (nnimap-find-article-by-message-id group article)))
+ (nnimap-get-whole-article
+ article (format "UID FETCH %%d %s"
+ (nnimap-header-parameters)))
+ (let ((buffer (current-buffer)))
+ (with-current-buffer (or to-buffer nntp-server-buffer)
+ (erase-buffer)
+ (insert-buffer-substring buffer)
+ (nnheader-ms-strip-cr)
+ (cons group article))))))
-(deffoo nnimap-request-list (&optional server)
- (when (nnimap-possibly-change-server server)
- (with-current-buffer nntp-server-buffer
- (erase-buffer))
- (gnus-message 5 "nnimap: Generating active list%s..."
- (if (> (length server) 0) (concat " for " server) ""))
- (nnimap-before-find-minmax-bugworkaround)
- (with-current-buffer nnimap-server-buffer
- (dolist (pattern (nnimap-pattern-to-list-arguments nnimap-list-pattern))
- (dolist (mbx (funcall nnimap-request-list-method
- (cdr pattern) (car pattern)))
- (or (member "\\NoSelect" (imap-mailbox-get 'list-flags mbx))
- (let ((info (nnimap-find-minmax-uid mbx 'examine)))
- (when info
- (with-current-buffer nntp-server-buffer
- (insert (format "\"%s\" %d %d y\n"
- mbx (or (nth 2 info) 0)
- (max 1 (or (nth 1 info) 1)))))))))))
- (gnus-message 5 "nnimap: Generating active list%s...done"
- (if (> (length server) 0) (concat " for " server) ""))
+(defun nnimap-get-whole-article (article &optional command)
+ (let ((result
+ (nnimap-command
+ (or command
+ (if (nnimap-ver4-p)
+ "UID FETCH %d BODY.PEEK[]"
+ "UID FETCH %d RFC822.PEEK"))
+ article)))
+ ;; Check that we really got an article.
+ (goto-char (point-min))
+ (unless (re-search-forward "\\* [0-9]+ FETCH" nil t)
+ (setq result nil))
+ (when result
+ ;; Remove any data that may have arrived before the FETCH data.
+ (beginning-of-line)
+ (unless (bobp)
+ (delete-region (point-min) (point)))
+ (let ((bytes (nnimap-get-length)))
+ (delete-region (line-beginning-position)
+ (progn (forward-line 1) (point)))
+ (goto-char (+ (point) bytes))
+ (delete-region (point) (point-max)))
+ t)))
+
+(defun nnimap-capability (capability)
+ (member capability (nnimap-capabilities nnimap-object)))
+
+(defun nnimap-ver4-p ()
+ (nnimap-capability "IMAP4REV1"))
+
+(defun nnimap-get-partial-article (article parts structure)
+ (let ((result
+ (nnimap-command
+ "UID FETCH %d (%s %s)"
+ article
+ (if (nnimap-ver4-p)
+ "BODY.PEEK[HEADER]"
+ "RFC822.HEADER")
+ (if (nnimap-ver4-p)
+ (mapconcat (lambda (part)
+ (format "BODY.PEEK[%s]" part))
+ parts " ")
+ (mapconcat (lambda (part)
+ (format "RFC822.PEEK[%s]" part))
+ parts " ")))))
+ (when result
+ (nnimap-convert-partial-article structure))))
+
+(defun nnimap-convert-partial-article (structure)
+ ;; First just skip past the headers.
+ (goto-char (point-min))
+ (let ((bytes (nnimap-get-length))
+ id parts)
+ ;; Delete "FETCH" line.
+ (delete-region (line-beginning-position)
+ (progn (forward-line 1) (point)))
+ (goto-char (+ (point) bytes))
+ ;; Collect all the body parts.
+ (while (looking-at ".*BODY\\[\\([.0-9]+\\)\\]")
+ (setq id (match-string 1)
+ bytes (nnimap-get-length))
+ (beginning-of-line)
+ (delete-region (point) (progn (forward-line 1) (point)))
+ (push (list id (buffer-substring (point) (+ (point) bytes)))
+ parts)
+ (delete-region (point) (+ (point) bytes)))
+ ;; Delete trailing junk.
+ (delete-region (point) (point-max))
+ ;; Now insert all the parts again where they fit in the structure.
+ (nnimap-insert-partial-structure structure parts)
t))
-(deffoo nnimap-request-post (&optional server)
- (let ((success t))
- (dolist (mbx (message-unquote-tokens
- (message-tokenize-header
- (message-fetch-field "Newsgroups") ", ")) success)
- (let ((to-newsgroup (gnus-group-prefixed-name mbx gnus-command-method)))
- (or (gnus-active to-newsgroup)
- (gnus-activate-group to-newsgroup)
- (if (gnus-y-or-n-p (format "No such group: %s. Create it? "
- to-newsgroup))
- (or (and (gnus-request-create-group
- to-newsgroup gnus-command-method)
- (gnus-activate-group to-newsgroup nil nil
- gnus-command-method))
- (error "Couldn't create group %s" to-newsgroup)))
- (error "No such group: %s" to-newsgroup))
- (unless (nnimap-request-accept-article mbx (nth 1 gnus-command-method))
- (setq success nil))))))
-
-;; Optional backend functions
-
-(defun nnimap-string-lessp-numerical (s1 s2)
- "Return t if first arg string is less than second in numerical order."
- (cond ((string= s1 s2)
- nil)
- ((> (length s1) (length s2))
- nil)
- ((< (length s1) (length s2))
- t)
- ((< (string-to-number (substring s1 0 1))
- (string-to-number (substring s2 0 1)))
- t)
- ((> (string-to-number (substring s1 0 1))
- (string-to-number (substring s2 0 1)))
- nil)
- (t
- (nnimap-string-lessp-numerical (substring s1 1) (substring s2 1)))))
-
-(deffoo nnimap-retrieve-groups (groups &optional server)
- (when (nnimap-possibly-change-server server)
- (gnus-message 5 "nnimap: Checking mailboxes...")
+(defun nnimap-insert-partial-structure (structure parts &optional subp)
+ (let (type boundary)
+ (let ((bstruc structure))
+ (while (consp (car bstruc))
+ (pop bstruc))
+ (setq type (car bstruc))
+ (setq bstruc (car (cdr bstruc)))
+ (let ((has-boundary (member "boundary" bstruc)))
+ (when has-boundary
+ (setq boundary (cadr has-boundary)))))
+ (when subp
+ (insert (format "Content-type: multipart/%s; boundary=%S\n\n"
+ (downcase type) boundary)))
+ (while (not (stringp (car structure)))
+ (insert "\n--" boundary "\n")
+ (if (consp (caar structure))
+ (nnimap-insert-partial-structure (pop structure) parts t)
+ (let ((bit (pop structure)))
+ (insert (format "Content-type: %s/%s"
+ (downcase (nth 0 bit))
+ (downcase (nth 1 bit))))
+ (if (member "CHARSET" (nth 2 bit))
+ (insert (format
+ "; charset=%S\n" (cadr (member "CHARSET" (nth 2 bit)))))
+ (insert "\n"))
+ (insert (format "Content-transfer-encoding: %s\n"
+ (nth 5 bit)))
+ (insert "\n")
+ (when (assoc (nth 9 bit) parts)
+ (insert (cadr (assoc (nth 9 bit) parts)))))))
+ (insert "\n--" boundary "--\n")))
+
+(defun nnimap-find-wanted-parts (structure)
+ (message-flatten-list (nnimap-find-wanted-parts-1 structure "")))
+
+(defun nnimap-find-wanted-parts-1 (structure prefix)
+ (let ((num 1)
+ parts)
+ (while (consp (car structure))
+ (let ((sub (pop structure)))
+ (if (consp (car sub))
+ (push (nnimap-find-wanted-parts-1
+ sub (if (string= prefix "")
+ (number-to-string num)
+ (format "%s.%s" prefix num)))
+ parts)
+ (let ((type (format "%s/%s" (nth 0 sub) (nth 1 sub)))
+ (id (if (string= prefix "")
+ (number-to-string num)
+ (format "%s.%s" prefix num))))
+ (setcar (nthcdr 9 sub) id)
+ (when (if (eq nnimap-fetch-partial-articles t)
+ (equal id "1")
+ (string-match nnimap-fetch-partial-articles type))
+ (push id parts))))
+ (incf num)))
+ (nreverse parts)))
+
+(deffoo nnimap-request-group (group &optional server dont-check info)
+ (let ((result (nnimap-possibly-change-group
+ ;; Don't SELECT the group if we're going to select it
+ ;; later, anyway.
+ (if (and dont-check
+ (assoc group nnimap-current-infos))
+ nil
+ group)
+ server))
+ articles active marks high low)
(with-current-buffer nntp-server-buffer
- (erase-buffer)
- (nnimap-before-find-minmax-bugworkaround)
- (let (asyncgroups slowgroups)
- (if (null nnimap-retrieve-groups-asynchronous)
- (setq slowgroups groups)
- (dolist (group groups)
- (gnus-message 9 "nnimap: Quickly checking mailbox %s" group)
- (add-to-list (if (gnus-gethash-safe
- (gnus-group-prefixed-name group server)
- nnimap-mailbox-info)
- 'asyncgroups
- 'slowgroups)
- (list group (imap-mailbox-status-asynch
- group '(uidvalidity uidnext unseen)
- nnimap-server-buffer))))
- (dolist (asyncgroup asyncgroups)
- (let ((group (nth 0 asyncgroup))
- (tag (nth 1 asyncgroup))
- new old)
- (when (imap-ok-p (imap-wait-for-tag tag nnimap-server-buffer))
- (if (or (not (string=
- (nth 0 (gnus-gethash (gnus-group-prefixed-name
- group server)
- nnimap-mailbox-info))
- (imap-mailbox-get 'uidvalidity group
- nnimap-server-buffer)))
- (not (string=
- (nth 1 (gnus-gethash (gnus-group-prefixed-name
- group server)
- nnimap-mailbox-info))
- (imap-mailbox-get 'uidnext group
- nnimap-server-buffer))))
- (push (list group) slowgroups)
- (insert (nth 3 (gnus-gethash (gnus-group-prefixed-name
- group server)
- nnimap-mailbox-info))))))))
- (dolist (group slowgroups)
- (if nnimap-retrieve-groups-asynchronous
- (setq group (car group)))
- (gnus-message 7 "nnimap: Mailbox %s modified" group)
- (imap-mailbox-put 'uidnext nil group nnimap-server-buffer)
- (or (member "\\NoSelect" (imap-mailbox-get 'list-flags group
- nnimap-server-buffer))
- (let* ((info (nnimap-find-minmax-uid group 'examine))
- (str (format "\"%s\" %d %d y\n" group
- (or (nth 2 info) 0)
- (max 1 (or (nth 1 info) 1)))))
- (when (> (or (imap-mailbox-get 'recent group
- nnimap-server-buffer) 0)
- 0)
- (push (list (cons group 0)) nnmail-split-history))
- (insert str)
- (when nnimap-retrieve-groups-asynchronous
- (gnus-sethash
- (gnus-group-prefixed-name group server)
- (list (or (imap-mailbox-get
- 'uidvalidity group nnimap-server-buffer)
- (imap-mailbox-status
- group 'uidvalidity nnimap-server-buffer))
- (or (imap-mailbox-get
- 'uidnext group nnimap-server-buffer)
- (imap-mailbox-status
- group 'uidnext nnimap-server-buffer))
- (or (imap-mailbox-get
- 'unseen group nnimap-server-buffer)
- (imap-mailbox-status
- group 'unseen nnimap-server-buffer))
- str)
- nnimap-mailbox-info)))))))
- (gnus-message 5 "nnimap: Checking mailboxes...done")
- 'active))
-
-(deffoo nnimap-request-update-info-internal (group info &optional server)
+ (when result
+ (if (and dont-check
+ (setq active (nth 2 (assoc group nnimap-current-infos))))
+ (insert (format "211 %d %d %d %S\n"
+ (- (cdr active) (car active))
+ (car active)
+ (cdr active)
+ group))
+ (with-current-buffer (nnimap-buffer)
+ (erase-buffer)
+ (let ((group-sequence
+ (nnimap-send-command "SELECT %S" (utf7-encode group t)))
+ (flag-sequence
+ (nnimap-send-command "UID FETCH 1:* FLAGS")))
+ (setf (nnimap-group nnimap-object) group)
+ (nnimap-wait-for-response flag-sequence)
+ (setq marks
+ (nnimap-flags-to-marks
+ (nnimap-parse-flags
+ (list (list group-sequence flag-sequence
+ 1 group "SELECT")))))
+ (when (and info
+ marks)
+ (nnimap-update-infos marks (list info))
+ (nnimap-store-info info (gnus-active (gnus-info-group info))))
+ (goto-char (point-max))
+ (let ((uidnext (nth 5 (car marks))))
+ (setq high (or (if uidnext
+ (1- uidnext)
+ (nth 3 (car marks)))
+ 0)
+ low (or (nth 4 (car marks)) uidnext 1)))))
+ (erase-buffer)
+ (insert
+ (format
+ "211 %d %d %d %S\n" (1+ (- high low)) low high group)))
+ t))))
+
+(deffoo nnimap-request-create-group (group &optional server args)
+ (when (nnimap-possibly-change-group nil server)
+ (with-current-buffer (nnimap-buffer)
+ (car (nnimap-command "CREATE %S" (utf7-encode group t))))))
+
+(deffoo nnimap-request-delete-group (group &optional force server)
+ (when (nnimap-possibly-change-group nil server)
+ (with-current-buffer (nnimap-buffer)
+ (car (nnimap-command "DELETE %S" (utf7-encode group t))))))
+
+(deffoo nnimap-request-rename-group (group new-name &optional server)
+ (when (nnimap-possibly-change-group nil server)
+ (with-current-buffer (nnimap-buffer)
+ (nnimap-unselect-group)
+ (car (nnimap-command "RENAME %S %S"
+ (utf7-encode group t) (utf7-encode new-name t))))))
+
+(defun nnimap-unselect-group ()
+ ;; Make sure we don't have this group open read/write by asking
+ ;; to examine a mailbox that doesn't exist. This seems to be
+ ;; the only way that allows us to reliably go back to unselected
+ ;; state on Courier.
+ (nnimap-command "EXAMINE DOES.NOT.EXIST"))
+
+(deffoo nnimap-request-expunge-group (group &optional server)
(when (nnimap-possibly-change-group group server)
- (when info ;; xxx what does this mean? should we create a info?
- (with-current-buffer nnimap-server-buffer
- (gnus-message 5 "nnimap: Updating info for %s..."
- (gnus-info-group info))
-
- (when (nnimap-mark-permanent-p 'read)
- (let (seen unseen)
- ;; read info could contain articles marked unread by other
- ;; imap clients! we correct this
- (setq unseen (gnus-compress-sequence
- (imap-search "UNSEEN UNDELETED"))
- seen (gnus-range-difference (gnus-info-read info) unseen)
- seen (gnus-range-add seen
- (gnus-compress-sequence
- (imap-search "SEEN")))
- seen (if (and (integerp (car seen))
- (null (cdr seen)))
- (list (cons (car seen) (car seen)))
- seen))
- (gnus-info-set-read info seen)))
-
- (dolist (pred gnus-article-mark-lists)
- (when (or (eq (cdr pred) 'recent)
- (and (nnimap-mark-permanent-p (cdr pred))
- (member (nnimap-mark-to-flag (cdr pred))
- (imap-mailbox-get 'flags))))
- (gnus-info-set-marks
- info
- (gnus-update-alist-soft
- (cdr pred)
- (gnus-compress-sequence
- (imap-search (nnimap-mark-to-predicate (cdr pred))))
- (gnus-info-marks info))
- t)))
-
- (when nnimap-importantize-dormant
- ;; nnimap mark dormant article as ticked too (for other clients)
- ;; so we remove that mark for gnus since we support dormant
- (gnus-info-set-marks
- info
- (gnus-update-alist-soft
- 'tick
- (gnus-remove-from-range
- (cdr-safe (assoc 'tick (gnus-info-marks info)))
- (cdr-safe (assoc 'dormant (gnus-info-marks info))))
- (gnus-info-marks info))
- t))
-
- (gnus-message 5 "nnimap: Updating info for %s...done"
- (gnus-info-group info))
-
- info))))
-
-(deffoo nnimap-request-type (group &optional article)
- (if (and nnimap-news-groups (string-match nnimap-news-groups group))
- 'news
- 'mail))
+ (with-current-buffer (nnimap-buffer)
+ (car (nnimap-command "EXPUNGE")))))
+
+(defun nnimap-get-flags (spec)
+ (let ((articles nil)
+ elems end)
+ (with-current-buffer (nnimap-buffer)
+ (erase-buffer)
+ (nnimap-wait-for-response (nnimap-send-command
+ "UID FETCH %s FLAGS" spec))
+ (setq end (point))
+ (subst-char-in-region (point-min) (point-max)
+ ?\\ ?% t)
+ (goto-char (point-min))
+ (while (search-forward " FETCH " end t)
+ (setq elems (read (current-buffer)))
+ (push (cons (cadr (memq 'UID elems))
+ (cadr (memq 'FLAGS elems)))
+ articles)))
+ (nreverse articles)))
+
+(deffoo nnimap-close-group (group &optional server)
+ t)
+
+(deffoo nnimap-request-move-article (article group server accept-form
+ &optional last internal-move-group)
+ (with-temp-buffer
+ (mm-disable-multibyte)
+ (when (funcall (if internal-move-group
+ 'nnimap-request-head
+ 'nnimap-request-article)
+ article group server (current-buffer))
+ ;; If the move is internal (on the same server), just do it the easy
+ ;; way.
+ (let ((message-id (message-field-value "message-id")))
+ (if internal-move-group
+ (let ((result
+ (with-current-buffer (nnimap-buffer)
+ (nnimap-command "UID COPY %d %S"
+ article
+ (utf7-encode internal-move-group t)))))
+ (when (car result)
+ (nnimap-delete-article article)
+ (cons internal-move-group
+ (or (nnimap-find-uid-response "COPYUID" (cadr result))
+ (nnimap-find-article-by-message-id
+ internal-move-group message-id)))))
+ ;; Move the article to a different method.
+ (let ((result (eval accept-form)))
+ (when result
+ (nnimap-delete-article article)
+ result)))))))
+
+(deffoo nnimap-request-expire-articles (articles group &optional server force)
+ (cond
+ ((null articles)
+ nil)
+ ((not (nnimap-possibly-change-group group server))
+ articles)
+ ((and force
+ (eq nnmail-expiry-target 'delete))
+ (unless (nnimap-delete-article (gnus-compress-sequence articles))
+ (nnheader-message 7 "Article marked for deletion, but not expunged."))
+ nil)
+ (t
+ (let ((deletable-articles
+ (if (or force
+ (eq nnmail-expiry-wait 'immediate))
+ articles
+ (gnus-sorted-intersection
+ articles
+ (nnimap-find-expired-articles group)))))
+ (if (null deletable-articles)
+ articles
+ (if (eq nnmail-expiry-target 'delete)
+ (nnimap-delete-article (gnus-compress-sequence deletable-articles))
+ (setq deletable-articles
+ (nnimap-process-expiry-targets
+ deletable-articles group server)))
+ ;; Return the articles we didn't delete.
+ (gnus-sorted-complement articles deletable-articles))))))
+
+(defun nnimap-process-expiry-targets (articles group server)
+ (let ((deleted-articles nil))
+ (dolist (article articles)
+ (let ((target nnmail-expiry-target))
+ (with-temp-buffer
+ (mm-disable-multibyte)
+ (when (nnimap-request-article article group server (current-buffer))
+ (nnheader-message 7 "Expiring article %s:%d" group article)
+ (when (functionp target)
+ (setq target (funcall target group)))
+ (when (and target
+ (not (eq target 'delete)))
+ (if (or (gnus-request-group target t)
+ (gnus-request-create-group target))
+ (nnmail-expiry-target-group target group)
+ (setq target nil)))
+ (when target
+ (push article deleted-articles))))))
+ ;; Change back to the current group again.
+ (nnimap-possibly-change-group group server)
+ (setq deleted-articles (nreverse deleted-articles))
+ (nnimap-delete-article (gnus-compress-sequence deleted-articles))
+ deleted-articles))
+
+(defun nnimap-find-expired-articles (group)
+ (let ((cutoff (nnmail-expired-article-p group nil nil)))
+ (with-current-buffer (nnimap-buffer)
+ (let ((result
+ (nnimap-command
+ "UID SEARCH SENTBEFORE %s"
+ (format-time-string
+ (format "%%d-%s-%%Y"
+ (upcase
+ (car (rassoc (nth 4 (decode-time cutoff))
+ parse-time-months))))
+ cutoff))))
+ (and (car result)
+ (delete 0 (mapcar #'string-to-number
+ (cdr (assoc "SEARCH" (cdr result))))))))))
+
+
+(defun nnimap-find-article-by-message-id (group message-id)
+ (with-current-buffer (nnimap-buffer)
+ (erase-buffer)
+ (unless (equal group (nnimap-group nnimap-object))
+ (setf (nnimap-group nnimap-object) nil)
+ (setf (nnimap-examined nnimap-object) group)
+ (nnimap-send-command "EXAMINE %S" (utf7-encode group t)))
+ (let ((sequence
+ (nnimap-send-command "UID SEARCH HEADER Message-Id %S" message-id))
+ article result)
+ (setq result (nnimap-wait-for-response sequence))
+ (when (and result
+ (car (setq result (nnimap-parse-response))))
+ ;; Select the last instance of the message in the group.
+ (and (setq article
+ (car (last (assoc "SEARCH" (cdr result)))))
+ (string-to-number article))))))
+
+(defun nnimap-delete-article (articles)
+ (with-current-buffer (nnimap-buffer)
+ (nnimap-command "UID STORE %s +FLAGS.SILENT (\\Deleted)"
+ (nnimap-article-ranges articles))
+ (cond
+ ((nnimap-capability "UIDPLUS")
+ (nnimap-command "UID EXPUNGE %s"
+ (nnimap-article-ranges articles))
+ t)
+ (nnimap-expunge
+ (nnimap-command "EXPUNGE")
+ t)
+ (t (gnus-message 7 (concat "nnimap: nnimap-expunge is not set and the "
+ "server doesn't support UIDPLUS, so we won't "
+ "delete this article now"))))))
+
+(deffoo nnimap-request-scan (&optional group server)
+ (when (and (nnimap-possibly-change-group nil server)
+ nnimap-inbox
+ nnimap-split-methods)
+ (nnheader-message 7 "nnimap %s splitting mail..." server)
+ (nnimap-split-incoming-mail)))
+
+(defun nnimap-marks-to-flags (marks)
+ (let (flags flag)
+ (dolist (mark marks)
+ (when (setq flag (cadr (assq mark nnimap-mark-alist)))
+ (push flag flags)))
+ flags))
(deffoo nnimap-request-set-mark (group actions &optional server)
(when (nnimap-possibly-change-group group server)
- (with-current-buffer nnimap-server-buffer
- (let (action)
- (gnus-message 7 "nnimap: Setting marks in %s..." group)
- (while (setq action (pop actions))
- (let ((range (nth 0 action))
- (what (nth 1 action))
- (cmdmarks (nth 2 action))
- marks)
- ;; bookmark can't be stored (not list/range
- (setq cmdmarks (delq 'bookmark cmdmarks))
- ;; killed can't be stored (not list/range
- (setq cmdmarks (delq 'killed cmdmarks))
- ;; unsent are for nndraft groups only
- (setq cmdmarks (delq 'unsent cmdmarks))
- ;; cache flags are pointless on the server
- (setq cmdmarks (delq 'cache cmdmarks))
- ;; seen flags are local to each gnus
- (setq cmdmarks (delq 'seen cmdmarks))
- ;; recent marks can't be set
- (setq cmdmarks (delq 'recent cmdmarks))
- (when nnimap-importantize-dormant
- ;; flag dormant articles as ticked
- (if (memq 'dormant cmdmarks)
- (setq cmdmarks (cons 'tick cmdmarks))))
- ;; remove stuff we are forbidden to store
- (mapc (lambda (mark)
- (if (imap-message-flag-permanent-p
- (nnimap-mark-to-flag mark))
- (setq marks (cons mark marks))))
- cmdmarks)
- (when (and range marks)
- (cond ((eq what 'del)
- (imap-message-flags-del
- (imap-range-to-message-set range)
- (nnimap-mark-to-flag marks nil t)))
- ((eq what 'add)
- (imap-message-flags-add
- (imap-range-to-message-set range)
- (nnimap-mark-to-flag marks nil t)))
- ((eq what 'set)
- (imap-message-flags-set
- (imap-range-to-message-set range)
- (nnimap-mark-to-flag marks nil t)))))))
- (gnus-message 7 "nnimap: Setting marks in %s...done" group))))
- nil)
+ (let (sequence)
+ (with-current-buffer (nnimap-buffer)
+ (erase-buffer)
+ ;; Just send all the STORE commands without waiting for
+ ;; response. If they're successful, they're successful.
+ (dolist (action actions)
+ (destructuring-bind (range action marks) action
+ (let ((flags (nnimap-marks-to-flags marks)))
+ (when flags
+ (setq sequence (nnimap-send-command
+ "UID STORE %s %sFLAGS.SILENT (%s)"
+ (nnimap-article-ranges range)
+ (cond
+ ((eq action 'del) "-")
+ ((eq action 'add) "+")
+ ((eq action 'set) ""))
+ (mapconcat #'identity flags " ")))))))
+ ;; Wait for the last command to complete to avoid later
+ ;; syncronisation problems with the stream.
+ (when sequence
+ (nnimap-wait-for-response sequence))))))
-(defun nnimap-split-fancy ()
- "Like the function `nnmail-split-fancy', but uses `nnimap-split-fancy'."
- (let ((nnmail-split-fancy nnimap-split-fancy))
- (nnmail-split-fancy)))
+(deffoo nnimap-request-accept-article (group &optional server last)
+ (when (nnimap-possibly-change-group nil server)
+ (nnmail-check-syntax)
+ (let ((message-id (message-field-value "message-id"))
+ sequence message)
+ (nnimap-add-cr)
+ (setq message (buffer-substring-no-properties (point-min) (point-max)))
+ (with-current-buffer (nnimap-buffer)
+ ;; If we have this group open read-only, then unselect it
+ ;; before appending to it.
+ (when (equal (nnimap-examined nnimap-object) group)
+ (nnimap-unselect-group))
+ (erase-buffer)
+ (setq sequence (nnimap-send-command
+ "APPEND %S {%d}" (utf7-encode group t)
+ (length message)))
+ (unless nnimap-streaming
+ (nnimap-wait-for-connection "^[+]"))
+ (process-send-string (get-buffer-process (current-buffer)) message)
+ (process-send-string (get-buffer-process (current-buffer))
+ (if (nnimap-newlinep nnimap-object)
+ "\n"
+ "\r\n"))
+ (let ((result (nnimap-get-response sequence)))
+ (if (not (car result))
+ (progn
+ (nnheader-message 7 "%s" (nnheader-get-report-string 'nnimap))
+ nil)
+ (cons group
+ (or (nnimap-find-uid-response "APPENDUID" (car result))
+ (nnimap-find-article-by-message-id
+ group message-id)))))))))
+
+(defun nnimap-find-uid-response (name list)
+ (let ((result (car (last (nnimap-find-response-element name list)))))
+ (and result
+ (string-to-number result))))
+
+(defun nnimap-find-response-element (name list)
+ (let (result)
+ (dolist (elem list)
+ (when (and (consp elem)
+ (equal name (car elem)))
+ (setq result elem)))
+ result))
+
+(deffoo nnimap-request-replace-article (article group buffer)
+ (let (group-art)
+ (when (and (nnimap-possibly-change-group group nil)
+ ;; Put the article into the group.
+ (with-current-buffer buffer
+ (setq group-art
+ (nnimap-request-accept-article group nil t))))
+ (nnimap-delete-article (list article))
+ ;; Return the new article number.
+ (cdr group-art))))
+
+(defun nnimap-add-cr ()
+ (goto-char (point-min))
+ (while (re-search-forward "\r?\n" nil t)
+ (replace-match "\r\n" t t)))
+
+(defun nnimap-get-groups ()
+ (erase-buffer)
+ (let ((sequence (nnimap-send-command "LIST \"\" \"*\""))
+ groups)
+ (nnimap-wait-for-response sequence)
+ (subst-char-in-region (point-min) (point-max)
+ ?\\ ?% t)
+ (goto-char (point-min))
+ (nnimap-unfold-quoted-lines)
+ (goto-char (point-min))
+ (while (search-forward "* LIST " nil t)
+ (let ((flags (read (current-buffer)))
+ (separator (read (current-buffer)))
+ (group (read (current-buffer))))
+ (unless (member '%NoSelect flags)
+ (push (if (stringp group)
+ group
+ (format "%s" group))
+ groups))))
+ (nreverse groups)))
-(defun nnimap-split-to-groups (rules)
- ;; tries to match all rules in nnimap-split-rule against content of
- ;; nntp-server-buffer, returns a list of groups that matched.
+(deffoo nnimap-request-list (&optional server)
+ (nnimap-possibly-change-group nil server)
(with-current-buffer nntp-server-buffer
- ;; Fold continuation lines.
- (goto-char (point-min))
- (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
- (replace-match " " t t))
- (if (functionp rules)
- (funcall rules)
- (let (to-groups regrepp)
- (catch 'split-done
- (dolist (rule rules to-groups)
- (let ((group (car rule))
- (regexp (cadr rule)))
- (goto-char (point-min))
- (when (and (if (stringp regexp)
- (progn
- (if (not (stringp group))
- (setq group (eval group))
- (setq regrepp
- (string-match "\\\\[0-9&]" group)))
- (re-search-forward regexp nil t))
- (funcall regexp group))
- ;; Don't enter the article into the same group twice.
- (not (assoc group to-groups)))
- (push (if regrepp
- (nnmail-expand-newtext group)
+ (erase-buffer)
+ (let ((groups
+ (with-current-buffer (nnimap-buffer)
+ (nnimap-get-groups)))
+ sequences responses)
+ (when groups
+ (with-current-buffer (nnimap-buffer)
+ (setf (nnimap-group nnimap-object) nil)
+ (dolist (group groups)
+ (setf (nnimap-examined nnimap-object) group)
+ (push (list (nnimap-send-command "EXAMINE %S" (utf7-encode group t))
group)
- to-groups)
- (or nnimap-split-crosspost
- (throw 'split-done to-groups))))))))))
-
-(defun nnimap-assoc-match (key alist)
- (let (element)
- (while (and alist (not element))
- (if (string-match (car (car alist)) key)
- (setq element (car alist)))
- (setq alist (cdr alist)))
- element))
-
-(defun nnimap-split-find-rule (server inbox)
- (if (and (listp nnimap-split-rule) (listp (car nnimap-split-rule))
- (list (cdar nnimap-split-rule)) (listp (cadar nnimap-split-rule)))
- ;; extended format
- (cadr (nnimap-assoc-match inbox (cdr (nnimap-assoc-match
- server nnimap-split-rule))))
- nnimap-split-rule))
-
-(defun nnimap-split-find-inbox (server)
- (if (listp nnimap-split-inbox)
- nnimap-split-inbox
- (list nnimap-split-inbox)))
-
-(defun nnimap-split-articles (&optional group server)
- (when (nnimap-possibly-change-server server)
- (with-current-buffer nnimap-server-buffer
- (let (rule inbox removeorig (inboxes (nnimap-split-find-inbox server)))
- ;; iterate over inboxes
- (while (and (setq inbox (pop inboxes))
- (nnimap-possibly-change-group inbox)) ;; SELECT
- ;; find split rule for this server / inbox
- (when (setq rule (nnimap-split-find-rule server inbox))
- ;; iterate over articles
- (dolist (article (imap-search nnimap-split-predicate))
- (when (if (if (eq nnimap-split-download-body 'default)
- nnimap-split-download-body-default
- nnimap-split-download-body)
- (and (nnimap-request-article article)
- (with-current-buffer nntp-server-buffer (mail-narrow-to-head)))
- (nnimap-request-head article))
- ;; copy article to right group(s)
- (setq removeorig nil)
- (dolist (to-group (nnimap-split-to-groups rule))
- (cond ((eq to-group 'junk)
- (message "IMAP split removed %s:%s:%d" server inbox
- article)
- (setq removeorig t))
- ((imap-message-copy (number-to-string article)
- to-group nil 'nocopyuid)
- (message "IMAP split moved %s:%s:%d to %s" server
- inbox article to-group)
- (setq removeorig t)
- (when nnmail-cache-accepted-message-ids
- (with-current-buffer nntp-server-buffer
- (let (msgid)
- (and (setq msgid
- (nnmail-fetch-field "message-id"))
- (nnmail-cache-insert msgid
- to-group
- (nnmail-fetch-field "subject"))))))
- ;; Add the group-art list to the history list.
- (push (list (cons to-group 0)) nnmail-split-history))
- (t
- (message "IMAP split failed to move %s:%s:%d to %s"
- server inbox article to-group))))
- (if (if (eq nnimap-split-download-body 'default)
- nnimap-split-download-body-default
- nnimap-split-download-body)
- (widen))
- ;; remove article if it was successfully copied somewhere
- (and removeorig
- (imap-message-flags-add (format "%d" article)
- "\\Seen \\Deleted")))))
- (when (imap-mailbox-select inbox) ;; just in case
- ;; todo: UID EXPUNGE (if available) to remove splitted articles
- (imap-mailbox-expunge)
- (imap-mailbox-close)))
- (when nnmail-cache-accepted-message-ids
- (nnmail-cache-close))
+ sequences))
+ (nnimap-wait-for-response (caar sequences))
+ (setq responses
+ (nnimap-get-responses (mapcar #'car sequences))))
+ (dolist (response responses)
+ (let* ((sequence (car response))
+ (response (cadr response))
+ (group (cadr (assoc sequence sequences))))
+ (when (and group
+ (equal (caar response) "OK"))
+ (let ((uidnext (nnimap-find-parameter "UIDNEXT" response))
+ highest exists)
+ (dolist (elem response)
+ (when (equal (cadr elem) "EXISTS")
+ (setq exists (string-to-number (car elem)))))
+ (when uidnext
+ (setq highest (1- (string-to-number (car uidnext)))))
+ (cond
+ ((null highest)
+ (insert (format "%S 0 1 y\n" (utf7-decode group t))))
+ ((zerop exists)
+ ;; Empty group.
+ (insert (format "%S %d %d y\n"
+ (utf7-decode group t) highest (1+ highest))))
+ (t
+ ;; Return the widest possible range.
+ (insert (format "%S %d 1 y\n" (utf7-decode group t)
+ (or highest exists)))))))))
t))))
-(deffoo nnimap-request-scan (&optional group server)
- (nnimap-split-articles group server))
-
(deffoo nnimap-request-newgroups (date &optional server)
- (when (nnimap-possibly-change-server server)
- (with-current-buffer nntp-server-buffer
- (gnus-message 5 "nnimap: Listing subscribed mailboxes%s%s..."
- (if (> (length server) 0) " on " "") server)
- (erase-buffer)
- (nnimap-before-find-minmax-bugworkaround)
- (dolist (pattern (nnimap-pattern-to-list-arguments
- nnimap-list-pattern))
- (dolist (mbx (imap-mailbox-lsub (cdr pattern) (car pattern) nil
- nnimap-server-buffer))
- (or (catch 'found
- (dolist (mailbox (imap-mailbox-get 'list-flags mbx
- nnimap-server-buffer))
- (if (string= (downcase mailbox) "\\noselect")
- (throw 'found t)))
- nil)
- (let ((info (nnimap-find-minmax-uid mbx 'examine)))
- (when info
- (insert (format "\"%s\" %d %d y\n"
- mbx (or (nth 2 info) 0)
- (max 1 (or (nth 1 info) 1)))))))))
- (gnus-message 5 "nnimap: Listing subscribed mailboxes%s%s...done"
- (if (> (length server) 0) " on " "") server))
+ (nnimap-possibly-change-group nil server)
+ (with-current-buffer nntp-server-buffer
+ (erase-buffer)
+ (dolist (group (with-current-buffer (nnimap-buffer)
+ (nnimap-get-groups)))
+ (unless (assoc group nnimap-current-infos)
+ ;; Insert dummy numbers here -- they don't matter.
+ (insert (format "%S 0 1 y\n" group))))
t))
-(deffoo nnimap-request-create-group (group &optional server args)
- (when (nnimap-possibly-change-server server)
- (or (imap-mailbox-status group 'uidvalidity nnimap-server-buffer)
- (imap-mailbox-create group nnimap-server-buffer)
- (nnheader-report 'nnimap "%S"
- (imap-error-text nnimap-server-buffer)))))
-
-(defun nnimap-time-substract (time1 time2)
- "Return TIME for TIME1 - TIME2."
- (let* ((ms (- (car time1) (car time2)))
- (ls (- (nth 1 time1) (nth 1 time2))))
- (if (< ls 0)
- (list (- ms 1) (+ (expt 2 16) ls))
- (list ms ls))))
-
-(eval-when-compile (require 'parse-time))
-(defun nnimap-date-days-ago (daysago)
- "Return date, in format \"3-Aug-1998\", for DAYSAGO days ago."
- (require 'parse-time)
- (let* ((time (nnimap-time-substract (current-time) (days-to-time daysago)))
- (date (format-time-string
- (format "%%d-%s-%%Y"
- (capitalize (car (rassoc (nth 4 (decode-time time))
- parse-time-months))))
- time)))
- (if (eq ?0 (string-to-char date))
- (substring date 1)
- date)))
-
-(defun nnimap-request-expire-articles-progress ()
- (gnus-message 5 "nnimap: Marking article %d for deletion..."
- imap-current-message))
-
-(defun nnimap-expiry-target (arts group server)
- (unless (eq nnmail-expiry-target 'delete)
- (with-temp-buffer
- (dolist (art arts)
- (nnimap-request-article art group server (current-buffer))
- ;; hints for optimization in `nnimap-request-accept-article'
- (let ((nnimap-current-move-article art)
- (nnimap-current-move-group group)
- (nnimap-current-move-server server))
- (nnmail-expiry-target-group nnmail-expiry-target group))))
- ;; It is not clear if `nnmail-expiry-target' somehow cause the
- ;; current group to be changed or not, so we make sure here.
- (nnimap-possibly-change-group group server)))
-
-;; Notice that we don't actually delete anything, we just mark them deleted.
-(deffoo nnimap-request-expire-articles (articles group &optional server force)
- (let ((artseq (gnus-compress-sequence articles)))
- (when (and artseq (nnimap-possibly-change-group group server))
- (with-current-buffer nnimap-server-buffer
- (let ((days (or (and nnmail-expiry-wait-function
- (funcall nnmail-expiry-wait-function group))
- nnmail-expiry-wait)))
- (cond ((or force (eq days 'immediate))
- (let ((oldarts (imap-search
- (concat "UID "
- (imap-range-to-message-set artseq)))))
- (when oldarts
- (nnimap-expiry-target oldarts group server)
- (when (imap-message-flags-add
- (imap-range-to-message-set
- (gnus-compress-sequence oldarts)) "\\Deleted")
- (setq articles (gnus-set-difference
- articles oldarts))))))
- ((and nnimap-search-uids-not-since-is-evil (numberp days))
- (let* ((all-new-articles
+(deffoo nnimap-retrieve-group-data-early (server infos)
+ (when (nnimap-possibly-change-group nil server)
+ (with-current-buffer (nnimap-buffer)
+ (erase-buffer)
+ (setf (nnimap-group nnimap-object) nil)
+ (let ((qresyncp (nnimap-capability "QRESYNC"))
+ params groups sequences active uidvalidity modseq group)
+ ;; Go through the infos and gather the data needed to know
+ ;; what and how to request the data.
+ (dolist (info infos)
+ (setq params (gnus-info-params info)
+ group (gnus-group-real-name (gnus-info-group info))
+ active (cdr (assq 'active params))
+ uidvalidity (cdr (assq 'uidvalidity params))
+ modseq (cdr (assq 'modseq params)))
+ (setf (nnimap-examined nnimap-object) group)
+ (if (and qresyncp
+ uidvalidity
+ modseq)
+ (push
+ (list (nnimap-send-command "EXAMINE %S (QRESYNC (%s %s))"
+ (utf7-encode group t)
+ uidvalidity modseq)
+ 'qresync
+ nil group 'qresync)
+ sequences)
+ (let ((start
+ (if (and active uidvalidity)
+ ;; Fetch the last 100 flags.
+ (max 1 (- (cdr active) 100))
+ 1))
+ (command
+ (if uidvalidity
+ "EXAMINE"
+ ;; If we don't have a UIDVALIDITY, then this is
+ ;; the first time we've seen the group, so we
+ ;; have to do a SELECT (which is slower than an
+ ;; examine), but will tell us whether the group
+ ;; is read-only or not.
+ "SELECT")))
+ (push (list (nnimap-send-command "%s %S" command
+ (utf7-encode group t))
+ (nnimap-send-command "UID FETCH %d:* FLAGS" start)
+ start group command)
+ sequences))))
+ sequences))))
+
+(deffoo nnimap-finish-retrieve-group-infos (server infos sequences)
+ (when (and sequences
+ (nnimap-possibly-change-group nil server))
+ (with-current-buffer (nnimap-buffer)
+ ;; Wait for the final data to trickle in.
+ (when (nnimap-wait-for-response (if (eq (cadar sequences) 'qresync)
+ (caar sequences)
+ (cadar sequences))
+ t)
+ ;; Now we should have most of the data we need, no matter
+ ;; whether we're QRESYNCING, fetching all the flags from
+ ;; scratch, or just fetching the last 100 flags per group.
+ (nnimap-update-infos (nnimap-flags-to-marks
+ (nnimap-parse-flags
+ (nreverse sequences)))
+ infos)
+ ;; Finally, just return something resembling an active file in
+ ;; the nntp buffer, so that the agent can save the info, too.
+ (with-current-buffer nntp-server-buffer
+ (erase-buffer)
+ (dolist (info infos)
+ (let* ((group (gnus-info-group info))
+ (active (gnus-active group)))
+ (when active
+ (insert (format "%S %d %d y\n"
+ (gnus-group-real-name group)
+ (cdr active)
+ (car active)))))))))))
+
+(defun nnimap-update-infos (flags infos)
+ (dolist (info infos)
+ (let* ((group (gnus-group-real-name (gnus-info-group info)))
+ (marks (cdr (assoc group flags))))
+ (when marks
+ (nnimap-update-info info marks)))))
+
+(defun nnimap-update-info (info marks)
+ (destructuring-bind (existing flags high low uidnext start-article
+ permanent-flags uidvalidity
+ vanished highestmodseq) marks
+ (cond
+ ;; Ignore groups with no UIDNEXT/marks. This happens for
+ ;; completely empty groups.
+ ((and (not existing)
+ (not uidnext))
+ (let ((active (cdr (assq 'active (gnus-info-params info)))))
+ (when active
+ (gnus-set-active (gnus-info-group info) active))))
+ ;; We have a mismatch between the old and new UIDVALIDITY
+ ;; identifiers, so we have to re-request the group info (the next
+ ;; time). This virtually never happens.
+ ((let ((old-uidvalidity
+ (cdr (assq 'uidvalidity (gnus-info-params info)))))
+ (and old-uidvalidity
+ (not (equal old-uidvalidity uidvalidity))
+ (> start-article 1)))
+ (gnus-group-remove-parameter info 'uidvalidity)
+ (gnus-group-remove-parameter info 'modseq))
+ ;; We have the data needed to update.
+ (t
+ (let* ((group (gnus-info-group info))
+ (completep (and start-article
+ (= start-article 1)))
+ (active (or (gnus-active group)
+ (cdr (assq 'active (gnus-info-params info))))))
+ (when uidnext
+ (setq high (1- uidnext)))
+ ;; First set the active ranges based on high/low.
+ (if (or completep
+ (not (gnus-active group)))
+ (gnus-set-active group
+ (cond
+ (active
+ (cons (min (or low (car active))
+ (car active))
+ (max (or high (cdr active))
+ (cdr active))))
+ ((and low high)
+ (cons low high))
+ (uidnext
+ ;; No articles in this group.
+ (cons uidnext (1- uidnext)))
+ (start-article
+ (cons start-article (1- start-article)))
+ (t
+ ;; No articles and no uidnext.
+ nil)))
+ (gnus-set-active
+ group
+ (cons (car active)
+ (or high (1- uidnext)))))
+ ;; See whether this is a read-only group.
+ (unless (eq permanent-flags 'not-scanned)
+ (gnus-group-set-parameter
+ info 'permanent-flags
+ (and (or (memq '%* permanent-flags)
+ (memq '%Seen permanent-flags))
+ permanent-flags)))
+ ;; Update marks and read articles if this isn't a
+ ;; read-only IMAP group.
+ (when (setq permanent-flags
+ (cdr (assq 'permanent-flags (gnus-info-params info))))
+ (if (and highestmodseq
+ (not start-article))
+ ;; We've gotten the data by QRESYNCing.
+ (nnimap-update-qresync-info
+ info existing (nnimap-imap-ranges-to-gnus-ranges vanished) flags)
+ ;; Do normal non-QRESYNC flag updates.
+ ;; Update the list of read articles.
+ (let* ((unread
+ (gnus-compress-sequence
+ (gnus-set-difference
+ (gnus-set-difference
+ existing
+ (cdr (assoc '%Seen flags)))
+ (cdr (assoc '%Flagged flags)))))
+ (read (gnus-range-difference
+ (cons start-article high) unread)))
+ (when (> start-article 1)
+ (setq read
+ (gnus-range-nconcat
+ (if (> start-article 1)
+ (gnus-sorted-range-intersection
+ (cons 1 (1- start-article))
+ (gnus-info-read info))
+ (gnus-info-read info))
+ read)))
+ (when (or (not (listp permanent-flags))
+ (memq '%Seen permanent-flags))
+ (gnus-info-set-read info read))
+ ;; Update the marks.
+ (setq marks (gnus-info-marks info))
+ (dolist (type (cdr nnimap-mark-alist))
+ (when (or (not (listp permanent-flags))
+ (memq (car (assoc (caddr type) flags))
+ permanent-flags)
+ (memq '%* permanent-flags))
+ (let ((old-marks (assoc (car type) marks))
+ (new-marks
(gnus-compress-sequence
- (imap-search (format "SINCE %s"
- (nnimap-date-days-ago days)))))
- (oldartseq
- (gnus-range-difference artseq all-new-articles))
- (oldarts (gnus-uncompress-range oldartseq)))
- (when oldarts
- (nnimap-expiry-target oldarts group server)
- (when (imap-message-flags-add
- (imap-range-to-message-set oldartseq)
- "\\Deleted")
- (setq articles (gnus-set-difference
- articles oldarts))))))
- ((numberp days)
- (let ((oldarts (imap-search
- (format nnimap-expunge-search-string
- (imap-range-to-message-set artseq)
- (nnimap-date-days-ago days))))
- (imap-fetch-data-hook
- '(nnimap-request-expire-articles-progress)))
- (when oldarts
- (nnimap-expiry-target oldarts group server)
- (when (imap-message-flags-add
- (imap-range-to-message-set
- (gnus-compress-sequence oldarts)) "\\Deleted")
- (setq articles (gnus-set-difference
- articles oldarts)))))))))))
- ;; return articles not deleted
- articles)
-
-(deffoo nnimap-request-move-article (article group server accept-form
- &optional last move-is-internal)
- (when (nnimap-possibly-change-server server)
- (save-excursion
- (let ((buf (get-buffer-create " *nnimap move*"))
- (nnimap-current-move-article article)
- (nnimap-current-move-group group)
- (nnimap-current-move-server nnimap-current-server)
- result)
- (gnus-message 10 "nnimap-request-move-article: this is an %s move"
- (if move-is-internal
- "internal"
- "external"))
- ;; request the article only when the move is NOT internal
- (and (or move-is-internal
- (nnimap-request-article article group server))
- (with-current-buffer buf
- (buffer-disable-undo (current-buffer))
- (insert-buffer-substring nntp-server-buffer)
- (setq result (eval accept-form))
- (kill-buffer buf)
- result)
- (nnimap-possibly-change-group group server)
- (imap-message-flags-add
- (imap-range-to-message-set (list article))
- "\\Deleted" 'silent nnimap-server-buffer))
- result))))
-
-(deffoo nnimap-request-accept-article (group &optional server last)
- (when (nnimap-possibly-change-server server)
- (let (uid)
- (if (setq uid
- (if (string= nnimap-current-server nnimap-current-move-server)
- ;; moving article within same server, speed it up...
- (and (nnimap-possibly-change-group
- nnimap-current-move-group)
- (imap-message-copy (number-to-string
- nnimap-current-move-article)
- group 'dontcreate nil
- nnimap-server-buffer))
- (with-current-buffer (current-buffer)
- (goto-char (point-min))
- ;; remove any 'From blabla' lines, some IMAP servers
- ;; reject the entire message otherwise.
- (when (looking-at "^From[^:]")
- (delete-region (point) (progn (forward-line) (point))))
- ;; turn into rfc822 format (\r\n eol's)
- (while (search-forward "\n" nil t)
- (replace-match "\r\n"))
- (when nnmail-cache-accepted-message-ids
- (nnmail-cache-insert (nnmail-fetch-field "message-id")
- group
- (nnmail-fetch-field "subject"))))
- (when (and last nnmail-cache-accepted-message-ids)
- (nnmail-cache-close))
- ;; this 'or' is for Cyrus server bug
- (or (null (imap-current-mailbox nnimap-server-buffer))
- (imap-mailbox-unselect nnimap-server-buffer))
- (imap-message-append group (current-buffer) nil nil
- nnimap-server-buffer)))
- (cons group (nth 1 uid))
- (nnheader-report 'nnimap (imap-error-text nnimap-server-buffer))))))
-
-(deffoo nnimap-request-delete-group (group force &optional server)
- (when (nnimap-possibly-change-server server)
- (when (string= group (imap-current-mailbox nnimap-server-buffer))
- (imap-mailbox-unselect nnimap-server-buffer))
- (with-current-buffer nnimap-server-buffer
- (if force
- (or (null (imap-mailbox-status group 'uidvalidity))
- (imap-mailbox-delete group))
- ;; UNSUBSCRIBE?
- t))))
+ (cdr (or (assoc (caddr type) flags) ; %Flagged
+ (assoc (intern (cadr type) obarray) flags)
+ (assoc (cadr type) flags)))))) ; "\Flagged"
+ (setq marks (delq old-marks marks))
+ (pop old-marks)
+ (when (and old-marks
+ (> start-article 1))
+ (setq old-marks (gnus-range-difference
+ old-marks
+ (cons start-article high)))
+ (setq new-marks (gnus-range-nconcat old-marks new-marks)))
+ (when new-marks
+ (push (cons (car type) new-marks) marks)))))
+ (gnus-info-set-marks info marks t))))
+ ;; Note the active level for the next run-through.
+ (gnus-group-set-parameter info 'active (gnus-active group))
+ (gnus-group-set-parameter info 'uidvalidity uidvalidity)
+ (gnus-group-set-parameter info 'modseq highestmodseq)
+ (nnimap-store-info info (gnus-active group)))))))
+
+(defun nnimap-update-qresync-info (info existing vanished flags)
+ ;; Add all the vanished articles to the list of read articles.
+ (gnus-info-set-read
+ info
+ (gnus-add-to-range
+ (gnus-add-to-range
+ (gnus-range-add (gnus-info-read info)
+ vanished)
+ (cdr (assq '%Flagged flags)))
+ (cdr (assq '%Seen flags))))
+ (let ((marks (gnus-info-marks info)))
+ (dolist (type (cdr nnimap-mark-alist))
+ (let ((ticks (assoc (car type) marks))
+ (new-marks
+ (cdr (or (assoc (caddr type) flags) ; %Flagged
+ (assoc (intern (cadr type) obarray) flags)
+ (assoc (cadr type) flags))))) ; "\Flagged"
+ (setq marks (delq ticks marks))
+ (pop ticks)
+ ;; Add the new marks we got.
+ (setq ticks (gnus-add-to-range ticks new-marks))
+ ;; Remove the marks from messages that don't have them.
+ (setq ticks (gnus-remove-from-range
+ ticks
+ (gnus-compress-sequence
+ (gnus-sorted-complement existing new-marks))))
+ (when ticks
+ (push (cons (car type) ticks) marks)))
+ (gnus-info-set-marks info marks t))))
+
+(defun nnimap-imap-ranges-to-gnus-ranges (irange)
+ (if (zerop (length irange))
+ nil
+ (let ((result nil))
+ (dolist (elem (split-string irange ","))
+ (push
+ (if (string-match ":" elem)
+ (let ((numbers (split-string elem ":")))
+ (cons (string-to-number (car numbers))
+ (string-to-number (cadr numbers))))
+ (string-to-number elem))
+ result))
+ (nreverse result))))
+
+(defun nnimap-store-info (info active)
+ (let* ((group (gnus-group-real-name (gnus-info-group info)))
+ (entry (assoc group nnimap-current-infos)))
+ (if entry
+ (setcdr entry (list info active))
+ (push (list group info active) nnimap-current-infos))))
+
+(defun nnimap-flags-to-marks (groups)
+ (let (data group totalp uidnext articles start-article mark permanent-flags
+ uidvalidity vanished highestmodseq)
+ (dolist (elem groups)
+ (setq group (car elem)
+ uidnext (nth 1 elem)
+ start-article (nth 2 elem)
+ permanent-flags (nth 3 elem)
+ uidvalidity (nth 4 elem)
+ vanished (nth 5 elem)
+ highestmodseq (nth 6 elem)
+ articles (nthcdr 7 elem))
+ (let ((high (caar articles))
+ marks low existing)
+ (dolist (article articles)
+ (setq low (car article))
+ (push (car article) existing)
+ (dolist (flag (cdr article))
+ (setq mark (assoc flag marks))
+ (if (not mark)
+ (push (list flag (car article)) marks)
+ (setcdr mark (cons (car article) (cdr mark))))))
+ (push (list group existing marks high low uidnext start-article
+ permanent-flags uidvalidity vanished highestmodseq)
+ data)))
+ data))
+
+(defun nnimap-parse-flags (sequences)
+ (goto-char (point-min))
+ ;; Change \Delete etc to %Delete, so that the reader can read it.
+ (subst-char-in-region (point-min) (point-max)
+ ?\\ ?% t)
+ (let (start end articles groups uidnext elems permanent-flags
+ uidvalidity vanished highestmodseq)
+ (dolist (elem sequences)
+ (destructuring-bind (group-sequence flag-sequence totalp group command)
+ elem
+ (setq start (point))
+ (when (and
+ ;; The EXAMINE was successful.
+ (search-forward (format "\n%d OK " group-sequence) nil t)
+ (progn
+ (forward-line 1)
+ (setq end (point))
+ (goto-char start)
+ (setq permanent-flags
+ (if (equal command "SELECT")
+ (and (search-forward "PERMANENTFLAGS "
+ (or end (point-min)) t)
+ (read (current-buffer)))
+ 'not-scanned))
+ (goto-char start)
+ (setq uidnext
+ (and (search-forward "UIDNEXT "
+ (or end (point-min)) t)
+ (read (current-buffer))))
+ (goto-char start)
+ (setq uidvalidity
+ (and (re-search-forward "UIDVALIDITY \\([0-9]+\\)"
+ (or end (point-min)) t)
+ ;; Store UIDVALIDITY as a string, as it's
+ ;; too big for 32-bit Emacsen, usually.
+ (match-string 1)))
+ (goto-char start)
+ (setq vanished
+ (and (eq flag-sequence 'qresync)
+ (re-search-forward "VANISHED.* \\([0-9:,]+\\)"
+ (or end (point-min)) t)
+ (match-string 1)))
+ (goto-char start)
+ (setq highestmodseq
+ (and (search-forward "HIGHESTMODSEQ "
+ (or end (point-min)) t)
+ (read (current-buffer))))
+ (goto-char end)
+ (forward-line -1))
+ ;; The UID FETCH FLAGS was successful.
+ (or (eq flag-sequence 'qresync)
+ (search-forward (format "\n%d OK " flag-sequence) nil t)))
+ (if (eq flag-sequence 'qresync)
+ (progn
+ (goto-char start)
+ (setq start end))
+ (setq start (point))
+ (goto-char end))
+ (while (re-search-forward "^\\* [0-9]+ FETCH " start t)
+ (setq elems (read (current-buffer)))
+ (push (cons (cadr (memq 'UID elems))
+ (cadr (memq 'FLAGS elems)))
+ articles))
+ (push (nconc (list group uidnext totalp permanent-flags uidvalidity
+ vanished highestmodseq)
+ articles)
+ groups)
+ (goto-char end)
+ (setq articles nil))))
+ groups))
+
+(defun nnimap-find-process-buffer (buffer)
+ (cadr (assoc buffer nnimap-connection-alist)))
-(deffoo nnimap-request-rename-group (group new-name &optional server)
- (when (nnimap-possibly-change-server server)
- (imap-mailbox-rename group new-name nnimap-server-buffer)))
-
-(defun nnimap-expunge (mailbox server)
- (when (nnimap-possibly-change-group mailbox server)
- (imap-mailbox-expunge nil nnimap-server-buffer)))
-
-(defun nnimap-acl-get (mailbox server)
- (when (nnimap-possibly-change-server server)
- (and (imap-capability 'ACL nnimap-server-buffer)
- (imap-mailbox-acl-get mailbox nnimap-server-buffer))))
-
-(defun nnimap-acl-edit (mailbox method old-acls new-acls)
- (when (nnimap-possibly-change-server (cadr method))
- (unless (imap-capability 'ACL nnimap-server-buffer)
- (error "Your server does not support ACL editing"))
- (with-current-buffer nnimap-server-buffer
- ;; delete all removed identifiers
- (mapc (lambda (old-acl)
- (unless (assoc (car old-acl) new-acls)
- (or (imap-mailbox-acl-delete (car old-acl) mailbox)
- (error "Can't delete ACL for %s" (car old-acl)))))
- old-acls)
- ;; set all changed acl's
- (mapc (lambda (new-acl)
- (let ((new-rights (cdr new-acl))
- (old-rights (cdr (assoc (car new-acl) old-acls))))
- (unless (and old-rights new-rights
- (string= old-rights new-rights))
- (or (imap-mailbox-acl-set (car new-acl) new-rights mailbox)
- (error "Can't set ACL for %s to %s" (car new-acl)
- new-rights)))))
- new-acls)
- t)))
+(deffoo nnimap-request-post (&optional server)
+ (setq nnimap-status-string "Read-only server")
+ nil)
-
-;;; Internal functions
-
-;;
-;; This is confusing.
-;;
-;; mark => read, tick, draft, reply etc
-;; flag => "\\Seen", "\\Flagged", "\\Draft", "gnus-expire" etc
-;; predicate => "SEEN", "FLAGGED", "DRAFT", "KEYWORD gnus-expire" etc
-;;
-;; Mark should not really contain 'read since it's not a "mark" in the Gnus
-;; world, but we cheat. Mark == gnus-article-mark-lists + '(read . read).
-;;
-
-(defconst nnimap-mark-to-predicate-alist
- (mapcar
- (lambda (pair) ; cdr is the mark
- (or (assoc (cdr pair)
- '((read . "SEEN")
- (tick . "FLAGGED")
- (draft . "DRAFT")
- (recent . "RECENT")
- (reply . "ANSWERED")))
- (cons (cdr pair)
- (format "KEYWORD gnus-%s" (symbol-name (cdr pair))))))
- (cons '(read . read) gnus-article-mark-lists)))
-
-(defun nnimap-mark-to-predicate (pred)
- "Convert a Gnus mark (a symbol such as read, tick, expire) to a IMAP predicate.
-This is a string such as \"SEEN\", \"FLAGGED\", \"KEYWORD gnus-expire\",
-to be used within a IMAP SEARCH query."
- (cdr (assq pred nnimap-mark-to-predicate-alist)))
-
-(defconst nnimap-mark-to-flag-alist
- (mapcar
- (lambda (pair)
- (or (assoc (cdr pair)
- '((read . "\\Seen")
- (tick . "\\Flagged")
- (draft . "\\Draft")
- (recent . "\\Recent")
- (reply . "\\Answered")))
- (cons (cdr pair)
- (format "gnus-%s" (symbol-name (cdr pair))))))
- (cons '(read . read) gnus-article-mark-lists)))
-
-(defun nnimap-mark-to-flag-1 (preds)
- (if (and (not (null preds)) (listp preds))
- (cons (nnimap-mark-to-flag (car preds))
- (nnimap-mark-to-flag (cdr preds)))
- (cdr (assoc preds nnimap-mark-to-flag-alist))))
-
-(defun nnimap-mark-to-flag (preds &optional always-list make-string)
- "Convert a Gnus mark (a symbol such as read, tick, expire) to a IMAP flag.
-This is a string such as \"\\Seen\", \"\\Flagged\", \"gnus-expire\", to
-be used in a STORE FLAGS command."
- (let ((result (nnimap-mark-to-flag-1 preds)))
- (setq result (if (and (or make-string always-list)
- (not (listp result)))
- (list result)
- result))
- (if make-string
- (mapconcat (lambda (flag)
- (if (listp flag)
- (mapconcat 'identity flag " ")
- flag))
- result " ")
- result)))
-
-(defun nnimap-mark-permanent-p (mark &optional group)
- "Return t if MARK can be permanently (between IMAP sessions) saved on articles, in GROUP."
- (imap-message-flag-permanent-p (nnimap-mark-to-flag mark)))
-
-(when nnimap-debug
- (require 'trace)
- (buffer-disable-undo (get-buffer-create nnimap-debug-buffer))
- (mapc (lambda (f) (trace-function-background f nnimap-debug-buffer))
- '(
- nnimap-possibly-change-server
- nnimap-verify-uidvalidity
- nnimap-find-minmax-uid
- nnimap-before-find-minmax-bugworkaround
- nnimap-possibly-change-group
- ;;nnimap-replace-whitespace
- nnimap-retrieve-headers-progress
- nnimap-retrieve-which-headers
- nnimap-group-overview-filename
- nnimap-retrieve-headers-from-file
- nnimap-retrieve-headers-from-server
- nnimap-retrieve-headers
- nnimap-open-connection
- nnimap-open-server
- nnimap-server-opened
- nnimap-close-server
- nnimap-request-close
- nnimap-status-message
- ;;nnimap-demule
- nnimap-request-article-part
- nnimap-request-article
- nnimap-request-head
- nnimap-request-body
- nnimap-request-group
- nnimap-close-group
- nnimap-pattern-to-list-arguments
- nnimap-request-list
- nnimap-request-post
- nnimap-retrieve-groups
- nnimap-request-update-info-internal
- nnimap-request-type
- nnimap-request-set-mark
- nnimap-split-to-groups
- nnimap-split-find-rule
- nnimap-split-find-inbox
- nnimap-split-articles
- nnimap-request-scan
- nnimap-request-newgroups
- nnimap-request-create-group
- nnimap-time-substract
- nnimap-date-days-ago
- nnimap-request-expire-articles-progress
- nnimap-request-expire-articles
- nnimap-request-move-article
- nnimap-request-accept-article
- nnimap-request-delete-group
- nnimap-request-rename-group
- gnus-group-nnimap-expunge
- gnus-group-nnimap-edit-acl
- gnus-group-nnimap-edit-acl-done
- nnimap-group-mode-hook
- nnimap-mark-to-predicate
- nnimap-mark-to-flag-1
- nnimap-mark-to-flag
- nnimap-mark-permanent-p
- )))
+(deffoo nnimap-request-thread (id)
+ (let* ((refs (split-string
+ (or (mail-header-references (gnus-summary-article-header))
+ "")))
+ (cmd (let ((value
+ (format
+ "(OR HEADER REFERENCES %s HEADER Message-Id %s)"
+ id id)))
+ (dolist (refid refs value)
+ (setq value (format
+ "(OR (OR HEADER Message-Id %s HEADER REFERENCES %s) %s)"
+ refid refid value)))))
+ (result (with-current-buffer (nnimap-buffer)
+ (nnimap-command "UID SEARCH %s" cmd))))
+ (gnus-fetch-headers
+ (and (car result) (delete 0 (mapcar #'string-to-number
+ (cdr (assoc "SEARCH" (cdr result))))))
+ nil t)))
+
+(defun nnimap-possibly-change-group (group server)
+ (let ((open-result t))
+ (when (and server
+ (not (nnimap-server-opened server)))
+ (setq open-result (nnimap-open-server server)))
+ (cond
+ ((not open-result)
+ nil)
+ ((not group)
+ t)
+ (t
+ (with-current-buffer (nnimap-buffer)
+ (if (equal group (nnimap-group nnimap-object))
+ t
+ (let ((result (nnimap-command "SELECT %S" (utf7-encode group t))))
+ (when (car result)
+ (setf (nnimap-group nnimap-object) group
+ (nnimap-select-result nnimap-object) result)
+ result))))))))
+
+(defun nnimap-find-connection (buffer)
+ "Find the connection delivering to BUFFER."
+ (let ((entry (assoc buffer nnimap-connection-alist)))
+ (when entry
+ (if (and (buffer-name (cadr entry))
+ (get-buffer-process (cadr entry))
+ (memq (process-status (get-buffer-process (cadr entry)))
+ '(open run)))
+ (get-buffer-process (cadr entry))
+ (setq nnimap-connection-alist (delq entry nnimap-connection-alist))
+ nil))))
+
+(defvar nnimap-sequence 0)
+
+(defun nnimap-send-command (&rest args)
+ (process-send-string
+ (get-buffer-process (current-buffer))
+ (nnimap-log-command
+ (format "%d %s%s\n"
+ (incf nnimap-sequence)
+ (apply #'format args)
+ (if (nnimap-newlinep nnimap-object)
+ ""
+ "\r"))))
+ ;; Some servers apparently can't have many outstanding
+ ;; commands, so throttle them.
+ (unless nnimap-streaming
+ (nnimap-wait-for-response nnimap-sequence))
+ nnimap-sequence)
+
+(defun nnimap-log-command (command)
+ (with-current-buffer (get-buffer-create "*imap log*")
+ (goto-char (point-max))
+ (insert (format-time-string "%H:%M:%S") " " command))
+ command)
+
+(defun nnimap-command (&rest args)
+ (erase-buffer)
+ (setf (nnimap-last-command-time nnimap-object) (current-time))
+ (let* ((sequence (apply #'nnimap-send-command args))
+ (response (nnimap-get-response sequence)))
+ (if (equal (caar response) "OK")
+ (cons t response)
+ (nnheader-report 'nnimap "%s"
+ (mapconcat (lambda (a)
+ (format "%s" a))
+ (car response) " "))
+ nil)))
+
+(defun nnimap-get-response (sequence)
+ (nnimap-wait-for-response sequence)
+ (nnimap-parse-response))
+
+(defun nnimap-wait-for-connection (&optional regexp)
+ (unless regexp
+ (setq regexp "^[*.] .*\n"))
+ (let ((process (get-buffer-process (current-buffer))))
+ (goto-char (point-min))
+ (while (and (memq (process-status process)
+ '(open run))
+ (not (re-search-forward regexp nil t)))
+ (nnheader-accept-process-output process)
+ (goto-char (point-min)))
+ (forward-line -1)
+ (and (looking-at "[*.] \\([A-Z0-9]+\\)")
+ (match-string 1))))
+
+(defun nnimap-wait-for-response (sequence &optional messagep)
+ (let ((process (get-buffer-process (current-buffer)))
+ openp)
+ (condition-case nil
+ (progn
+ (goto-char (point-max))
+ (while (and (setq openp (memq (process-status process)
+ '(open run)))
+ (not (re-search-backward
+ (format "^%d .*\n" sequence)
+ (if nnimap-streaming
+ (max (point-min) (- (point) 500))
+ (point-min))
+ t)))
+ (when messagep
+ (nnheader-message 7 "nnimap read %dk" (/ (buffer-size) 1000)))
+ (nnheader-accept-process-output process)
+ (goto-char (point-max)))
+ openp)
+ (quit
+ ;; The user hit C-g while we were waiting: kill the process, in case
+ ;; it's a gnutls-cli process that's stuck (tends to happen a lot behind
+ ;; NAT routers).
+ (delete-process process)
+ nil))))
+
+(defun nnimap-parse-response ()
+ (let ((lines (split-string (nnimap-last-response-string) "\r\n" t))
+ result)
+ (dolist (line lines)
+ (push (cdr (nnimap-parse-line line)) result))
+ ;; Return the OK/error code first, and then all the "continuation
+ ;; lines" afterwards.
+ (cons (pop result)
+ (nreverse result))))
+
+;; Parse an IMAP response line lightly. They look like
+;; "* OK [UIDVALIDITY 1164213559] UIDs valid", typically, so parse
+;; the lines into a list of strings and lists of string.
+(defun nnimap-parse-line (line)
+ (let (char result)
+ (with-temp-buffer
+ (mm-disable-multibyte)
+ (insert line)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (eql (setq char (following-char)) ? )
+ (forward-char 1)
+ (push
+ (cond
+ ((eql char ?\[)
+ (split-string
+ (buffer-substring
+ (1+ (point))
+ (if (search-forward "]" (line-end-position) 'move)
+ (1- (point))
+ (point)))))
+ ((eql char ?\()
+ (split-string
+ (buffer-substring
+ (1+ (point))
+ (if (search-forward ")" (line-end-position) 'move)
+ (1- (point))
+ (point)))))
+ ((eql char ?\")
+ (forward-char 1)
+ (buffer-substring
+ (point)
+ (1- (or (search-forward "\"" (line-end-position) 'move)
+ (point)))))
+ (t
+ (buffer-substring (point) (if (search-forward " " nil t)
+ (1- (point))
+ (goto-char (point-max))))))
+ result)))
+ (nreverse result))))
+
+(defun nnimap-last-response-string ()
+ (save-excursion
+ (forward-line 1)
+ (let ((end (point)))
+ (forward-line -1)
+ (when (not (bobp))
+ (forward-line -1)
+ (while (and (not (bobp))
+ (eql (following-char) ?*))
+ (forward-line -1))
+ (unless (eql (following-char) ?*)
+ (forward-line 1)))
+ (buffer-substring (point) end))))
+
+(defun nnimap-get-responses (sequences)
+ (let (responses)
+ (dolist (sequence sequences)
+ (goto-char (point-min))
+ (when (re-search-forward (format "^%d " sequence) nil t)
+ (push (list sequence (nnimap-parse-response))
+ responses)))
+ responses))
+
+(defvar nnimap-incoming-split-list nil)
+
+(defun nnimap-fetch-inbox (articles)
+ (erase-buffer)
+ (nnimap-wait-for-response
+ (nnimap-send-command
+ "UID FETCH %s %s"
+ (nnimap-article-ranges articles)
+ (format "(UID %s%s)"
+ (format
+ (if (nnimap-ver4-p)
+ "BODY.PEEK[HEADER] BODY.PEEK"
+ "RFC822.PEEK"))
+ (if nnimap-split-download-body-default
+ "[]"
+ "[1]")))
+ t))
+
+(defun nnimap-split-incoming-mail ()
+ (with-current-buffer (nnimap-buffer)
+ (let ((nnimap-incoming-split-list nil)
+ (nnmail-split-methods (if (eq nnimap-split-methods 'default)
+ nnmail-split-methods
+ nnimap-split-methods))
+ (nnmail-split-fancy (or nnimap-split-fancy
+ nnmail-split-fancy))
+ (nnmail-inhibit-default-split-group t)
+ (groups (nnimap-get-groups))
+ new-articles)
+ (erase-buffer)
+ (nnimap-command "SELECT %S" nnimap-inbox)
+ (setf (nnimap-group nnimap-object) nnimap-inbox)
+ (setq new-articles (nnimap-new-articles (nnimap-get-flags "1:*")))
+ (when new-articles
+ (nnimap-fetch-inbox new-articles)
+ (nnimap-transform-split-mail)
+ (nnheader-ms-strip-cr)
+ (nnmail-cache-open)
+ (nnmail-split-incoming (current-buffer)
+ #'nnimap-save-mail-spec
+ nil nil
+ #'nnimap-dummy-active-number
+ #'nnimap-save-mail-spec)
+ (when nnimap-incoming-split-list
+ (let ((specs (nnimap-make-split-specs nnimap-incoming-split-list))
+ sequences junk-articles)
+ ;; Create any groups that doesn't already exist on the
+ ;; server first.
+ (dolist (spec specs)
+ (when (and (not (member (car spec) groups))
+ (not (eq (car spec) 'junk)))
+ (nnimap-command "CREATE %S" (utf7-encode (car spec) t))))
+ ;; Then copy over all the messages.
+ (erase-buffer)
+ (dolist (spec specs)
+ (let ((group (car spec))
+ (ranges (cdr spec)))
+ (if (eq group 'junk)
+ (setq junk-articles ranges)
+ (push (list (nnimap-send-command
+ "UID COPY %s %S"
+ (nnimap-article-ranges ranges)
+ (utf7-encode group t))
+ ranges)
+ sequences))))
+ ;; Wait for the last COPY response...
+ (when sequences
+ (nnimap-wait-for-response (caar sequences))
+ ;; And then mark the successful copy actions as deleted,
+ ;; and possibly expunge them.
+ (nnimap-mark-and-expunge-incoming
+ (nnimap-parse-copied-articles sequences)))
+ (nnimap-mark-and-expunge-incoming junk-articles)))))))
+
+(defun nnimap-mark-and-expunge-incoming (range)
+ (when range
+ (setq range (nnimap-article-ranges range))
+ (erase-buffer)
+ (let ((sequence
+ (nnimap-send-command
+ "UID STORE %s +FLAGS.SILENT (\\Deleted)" range)))
+ (cond
+ ;; If the server supports it, we now delete the message we have
+ ;; just copied over.
+ ((nnimap-capability "UIDPLUS")
+ (setq sequence (nnimap-send-command "UID EXPUNGE %s" range)))
+ ;; If it doesn't support UID EXPUNGE, then we only expunge if the
+ ;; user has configured it.
+ (nnimap-expunge
+ (setq sequence (nnimap-send-command "EXPUNGE"))))
+ (nnimap-wait-for-response sequence))))
+
+(defun nnimap-parse-copied-articles (sequences)
+ (let (sequence copied range)
+ (goto-char (point-min))
+ (while (re-search-forward "^\\([0-9]+\\) OK " nil t)
+ (setq sequence (string-to-number (match-string 1)))
+ (when (setq range (cadr (assq sequence sequences)))
+ (push (gnus-uncompress-range range) copied)))
+ (gnus-compress-sequence (sort (apply #'nconc copied) #'<))))
+
+(defun nnimap-new-articles (flags)
+ (let (new)
+ (dolist (elem flags)
+ (unless (gnus-list-memq-of-list nnimap-unsplittable-articles
+ (cdr elem))
+ (push (car elem) new)))
+ (gnus-compress-sequence (nreverse new))))
+
+(defun nnimap-make-split-specs (list)
+ (let ((specs nil)
+ entry)
+ (dolist (elem list)
+ (destructuring-bind (article spec) elem
+ (dolist (group (delete nil (mapcar #'car spec)))
+ (unless (setq entry (assoc group specs))
+ (push (setq entry (list group)) specs))
+ (setcdr entry (cons article (cdr entry))))))
+ (dolist (entry specs)
+ (setcdr entry (gnus-compress-sequence (sort (cdr entry) #'<))))
+ specs))
+
+(defun nnimap-transform-split-mail ()
+ (goto-char (point-min))
+ (let (article bytes)
+ (block nil
+ (while (not (eobp))
+ (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)"))
+ (delete-region (point) (progn (forward-line 1) (point)))
+ (when (eobp)
+ (return)))
+ (setq article (match-string 1)
+ bytes (nnimap-get-length))
+ (delete-region (line-beginning-position) (line-end-position))
+ ;; Insert MMDF separator, and a way to remember what this
+ ;; article UID is.
+ (insert (format "\^A\^A\^A\^A\n\nX-nnimap-article: %s" article))
+ (forward-char (1+ bytes))
+ (setq bytes (nnimap-get-length))
+ (delete-region (line-beginning-position) (line-end-position))
+ ;; There's a body; skip past that.
+ (when bytes
+ (forward-char (1+ bytes))
+ (delete-region (line-beginning-position) (line-end-position)))))))
+
+(defun nnimap-dummy-active-number (group &optional server)
+ 1)
+
+(defun nnimap-save-mail-spec (group-art &optional server full-nov)
+ (let (article)
+ (goto-char (point-min))
+ (if (not (re-search-forward "X-nnimap-article: \\([0-9]+\\)" nil t))
+ (error "Invalid nnimap mail")
+ (setq article (string-to-number (match-string 1))))
+ (push (list article
+ (if (eq group-art 'junk)
+ (list (cons 'junk 1))
+ group-art))
+ nnimap-incoming-split-list)))
(provide 'nnimap)
-;; arch-tag: 2b001f20-3ff9-4094-a0ad-46807c1ba70b
;;; nnimap.el ends here
diff --git a/lisp/gnus/nnir.el b/lisp/gnus/nnir.el
index 73f56da7a9f..e5ba3c60620 100644
--- a/lisp/gnus/nnir.el
+++ b/lisp/gnus/nnir.el
@@ -32,163 +32,41 @@
;; TODO: Documentation in the Gnus manual
-;; From: Reiner Steib
-;; Subject: Re: Including nnir.el
-;; Newsgroups: gmane.emacs.gnus.general
-;; Message-ID: <v9d5dnp6aq.fsf@marauder.physik.uni-ulm.de>
-;; Date: 2006-06-05 22:49:01 GMT
-;;
-;; On Sun, Jun 04 2006, Sascha Wilde wrote:
-;;
-;; > The one thing most hackers like to forget: Documentation. By now the
-;; > documentation is only in the comments at the head of the source, I
-;; > would use it as basis to cook up some minimal texinfo docs.
-;; >
-;; > Where in the existing gnus manual would this fit best?
-
-;; Maybe (info "(gnus)Combined Groups") for a general description.
-;; `gnus-group-make-nnir-group' might be described in (info
-;; "(gnus)Foreign Groups") as well.
-
-
-;; The most recent version of this can always be fetched from the Gnus
-;; repository. See http://www.gnus.org/ for more information.
+;; Where in the existing gnus manual would this fit best?
-;; This code is still in the development stage but I'd like other
-;; people to have a look at it. Please do not hesitate to contact me
-;; with your ideas.
-
-;; What does it do? Well, it allows you to index your mail using some
-;; search engine (freeWAIS-sf, swish-e and others -- see later),
-;; then type `G G' in the Group buffer and issue a query to the search
-;; engine. You will then get a buffer which shows all articles
-;; matching the query, sorted by Retrieval Status Value (score).
+;; What does it do? Well, it allows you to search your mail using
+;; some search engine (imap, namazu, swish-e, gmane and others -- see
+;; later) by typing `G G' in the Group buffer. You will then get a
+;; buffer which shows all articles matching the query, sorted by
+;; Retrieval Status Value (score).
;; When looking at the retrieval result (in the Summary buffer) you
-;; can type `G T' (aka M-x gnus-summary-nnir-goto-thread RET) on an
-;; article. You will be teleported into the group this article came
-;; from, showing the thread this article is part of. (See below for
-;; restrictions.)
-
-;; The Lisp installation is simple: just put this file on your
-;; load-path, byte-compile it, and load it from ~/.gnus or something.
-;; This will install a new command `G G' in your Group buffer for
-;; searching your mail. Note that you also need to configure a number
-;; of variables, as described below.
-
-;; Restrictions:
-;;
-;; * If you don't use HyREX as your search engine, this expects that
-;; you use nnml or another one-file-per-message backend, because the
-;; others doesn't support nnfolder.
-;; * It can only search the mail backend's which are supported by one
-;; search engine, because of different query languages.
-;; * There are restrictions to the Wais setup.
-;; * There are restrictions to the imap setup.
-;; * gnus-summary-nnir-goto-thread: Fetches whole group first, before
-;; limiting to the right articles. This is much too slow, of
-;; course. May issue a query for number of articles to fetch; you
-;; must accept the default of all articles at this point or things
-;; may break.
-
-;; The Lisp setup involves setting a few variables and setting up the
+;; can type `A W' (aka M-x gnus-warp-to-article RET) on an article. You
+;; will be warped into the group this article came from. Typing `A W'
+;; (aka M-x gnus-summary-refer-thread RET) will warp to the group and
+;; also show the thread this article is part of.
+
+;; The Lisp setup may involve setting a few variables and setting up the
;; search engine. You can define the variables in the server definition
;; like this :
;; (setq gnus-secondary-select-methods '(
;; (nnimap "" (nnimap-address "localhost")
-;; (nnir-search-engine hyrex)
-;; (nnir-hyrex-additional-switches ("-d" "ddl-nnimap.xml"))
+;; (nnir-search-engine namazu)
;; )))
-;; Or you can define the global ones. The variables set in the mailer-
-;; definition will be used first.
-;; The variable to set is `nnir-search-engine'. Choose one of the engines
-;; listed in `nnir-engines'. (Actually `nnir-engines' is an alist,
-;; type `C-h v nnir-engines RET' for more information; this includes
-;; examples for setting `nnir-search-engine', too.)
-;;
-;; The variable nnir-mail-backend isn't used anymore.
-;;
+;; The main variable to set is `nnir-search-engine'. Choose one of
+;; the engines listed in `nnir-engines'. (Actually `nnir-engines' is
+;; an alist, type `C-h v nnir-engines RET' for more information; this
+;; includes examples for setting `nnir-search-engine', too.)
-;; You must also set up a search engine. I'll tell you about the two
-;; search engines currently supported:
+;; If you use one of the local indices (namazu, find-grep, swish) you
+;; must also set up a search engine backend.
-;; 1. freeWAIS-sf
-;;
-;; As always with freeWAIS-sf, you need a so-called `format file'. I
-;; use the following file:
-;;
-;; ,-----
-;; | # Kai's format file for freeWAIS-sf for indexing mails.
-;; | # Each mail is in a file, much like the MH format.
-;; |
-;; | # Document separator should never match -- each file is a document.
-;; | record-sep: /^@this regex should never match@$/
-;; |
-;; | # Searchable fields specification.
-;; |
-;; | region: /^[sS]ubject:/ /^[sS]ubject: */
-;; | subject "Subject header" stemming TEXT BOTH
-;; | end: /^[^ \t]/
-;; |
-;; | region: /^([tT][oO]|[cC][cC]):/ /^([tT][oO]|[cC][cC]): */
-;; | to "To and Cc headers" SOUNDEX BOTH
-;; | end: /^[^ \t]/
-;; |
-;; | region: /^[fF][rR][oO][mM]:/ /^[fF][rR][oO][mM]: */
-;; | from "From header" SOUNDEX BOTH
-;; | end: /^[^ \t]/
-;; |
-;; | region: /^$/
-;; | stemming TEXT GLOBAL
-;; | end: /^@this regex should never match@$/
-;; `-----
-;;
-;; 1998-07-22: waisindex would dump core on me for large articles with
-;; the above settings. I used /^$/ as the end regex for the global
-;; field. That seemed to work okay.
-
-;; There is a Perl module called `WAIS.pm' which is available from
-;; CPAN as well as ls6-ftp.cs.uni-dortmund.de:/pub/wais/Perl. This
-;; module comes with a nifty tool called `makedb', which I use for
-;; indexing. Here's my `makedb.conf':
-;;
-;; ,-----
-;; | # Config file for makedb
-;; |
-;; | # Global options
-;; | waisindex = /usr/local/bin/waisindex
-;; | wais_opt = -stem -t fields
-;; | # `-stem' option necessary when `stemming' is specified for the
-;; | # global field in the *.fmt file
-;; |
-;; | # Own variables
-;; | homedir = /home/kai
-;; |
-;; | # The mail database.
-;; | database = mail
-;; | files = `find $homedir/Mail -name \*[0-9] -print`
-;; | dbdir = $homedir/.wais
-;; | limit = 100
-;; `-----
-;;
-;; The Lisp setup involves the `nnir-wais-*' variables. The most
-;; difficult to understand variable is probably
-;; `nnir-wais-remove-prefix'. Here's what it does: the output of
-;; `waissearch' basically contains the file name and the (full)
-;; directory name. As Gnus works with group names rather than
-;; directory names, the directory name is transformed into a group
-;; name as follows: first, a prefix is removed from the (full)
-;; directory name, then all `/' are replaced with `.'. The variable
-;; `nnir-wais-remove-prefix' should contain a regex matching exactly
-;; this prefix. It defaults to `$HOME/Mail/' (note the trailing
-;; slash).
-
-;; 2. Namazu
+;; 1. Namazu
;;
;; The Namazu backend requires you to have one directory containing all
;; index files, this is controlled by the `nnir-namazu-index-directory'
;; variable. To function the `nnir-namazu-remove-prefix' variable must
-;; also be correct, see the documentation for `nnir-wais-remove-prefix'
+;; also be correct, see the documentation for `nnir-namazu-remove-prefix'
;; above.
;;
;; It is particularly important not to pass any any switches to namazu
@@ -227,18 +105,7 @@
;; For maximum searching efficiency I have a cron job set to run this
;; command every four hours.
-;; 3. HyREX
-;;
-;; The HyREX backend requires you to have one directory from where all
-;; your relative paths are to, if you use them. This directory must be
-;; set in the `nnir-hyrex-index-directory' variable, which defaults to
-;; your home directory. You must also pass the base, class and
-;; directory options or simply your dll to the `nnir-hyrex-programm' by
-;; setting the `nnir-hyrex-additional-switches' variable accordently.
-;; To function the `nnir-hyrex-remove-prefix' variable must also be
-;; correct, see the documentation for `nnir-wais-remove-prefix' above.
-
-;; 4. find-grep
+;; 2. find-grep
;;
;; The find-grep engine simply runs find(1) to locate eligible
;; articles and searches them with grep(1). This, of course, is much
@@ -263,10 +130,10 @@
;; I have tried to make the code expandable. Basically, it is divided
;; into two layers. The upper layer is somewhat like the `nnvirtual'
-;; or `nnkiboze' backends: given a specification of what articles to
-;; show from another backend, it creates a group containing exactly
-;; those articles. The lower layer issues a query to a search engine
-;; and produces such a specification of what articles to show from the
+;; backend: given a specification of what articles to show from
+;; another backend, it creates a group containing exactly those
+;; articles. The lower layer issues a query to a search engine and
+;; produces such a specification of what articles to show from the
;; other backend.
;; The interface between the two layers consists of the single
@@ -294,43 +161,14 @@
;; function should return the list of articles as a vector, as
;; described above. Then, you need to register this backend in
;; `nnir-engines'. Then, users can choose the backend by setting
-;; `nnir-search-engine'.
-
-;; Todo, or future ideas:
-
-;; * It should be possible to restrict search to certain groups.
-;;
-;; * There is currently no error checking.
-;;
-;; * The summary buffer display is currently really ugly, with all the
-;; added information in the subjects. How could I make this
-;; prettier?
-;;
-;; * A function which can be called from an nnir summary buffer which
-;; teleports you into the group the current article came from and
-;; shows you the whole thread this article is part of.
-;; Implementation suggestions?
-;; (1998-07-24: There is now a preliminary implementation, but
-;; it is much too slow and quite fragile.)
-;;
-;; * Support other mail backends. In particular, probably quite a few
-;; people use nnfolder. How would one go about searching nnfolders
-;; and producing the right data needed? The group name and the RSV
-;; are simple, but what about the article number?
-;; - The article number is encoded in the `X-Gnus-Article-Number'
-;; header of each mail.
-;; - The HyREX engine supports nnfolder.
-;;
-;; * Support compressed mail files. Probably, just stripping off the
-;; `.gz' or `.Z' file name extension is sufficient.
-;;
-;; * At least for imap, the query is performed twice.
-;;
-
-;; Have you got other ideas?
+;; `nnir-search-engine' as a server variable.
;;; Setup Code:
+;; For Emacs <22.2 and XEmacs.
+(eval-and-compile
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
+
(require 'nnoo)
(require 'gnus-group)
(require 'gnus-sum)
@@ -339,134 +177,38 @@
(eval-when-compile
(require 'cl))
+
+(eval-when-compile
+ (autoload 'nnimap-buffer "nnimap")
+ (autoload 'nnimap-command "nnimap")
+ (autoload 'nnimap-possibly-change-group "nnimap"))
+
(nnoo-declare nnir)
(nnoo-define-basics nnir)
(gnus-declare-backend "nnir" 'mail)
-(defvar nnir-imap-search-field "TEXT"
- "The IMAP search item when doing an nnir search")
-
-(defvar nnir-imap-search-arguments
- '(("Whole message" . "TEXT")
- ("Subject" . "SUBJECT")
- ("To" . "TO")
- ("From" . "FROM")
- (nil . "HEADER \"%s\""))
- "Mapping from user readable strings to IMAP search items for use in nnir")
-
-(defvar nnir-imap-search-argument-history ()
- "The history for querying search options in nnir")
-
-;;; Developer Extension Variable:
-
-(defvar nnir-engines
- `((wais nnir-run-waissearch
- ())
- (imap nnir-run-imap
- ((criteria
- "Search in: " ; Prompt
- ,nnir-imap-search-arguments ; alist for completing
- nil ; no filtering
- nil ; allow any user input
- nil ; initial value
- nnir-imap-search-argument-history ; the history to use
- ,nnir-imap-search-field ; default
- )))
- (swish++ nnir-run-swish++
- ((group . "Group spec: ")))
- (swish-e nnir-run-swish-e
- ((group . "Group spec: ")))
- (namazu nnir-run-namazu
- ())
- (hyrex nnir-run-hyrex
- ((group . "Group spec: ")))
- (find-grep nnir-run-find-grep
- ((grep-options . "Grep options: "))))
- "Alist of supported search engines.
-Each element in the alist is a three-element list (ENGINE FUNCTION ARGS).
-ENGINE is a symbol designating the searching engine. FUNCTION is also
-a symbol, giving the function that does the search. The third element
-ARGS is a list of cons pairs (PARAM . PROMPT). When issuing a query,
-the FUNCTION will issue a query for each of the PARAMs, using PROMPT.
-
-The value of `nnir-search-engine' must be one of the ENGINE symbols.
-For example, use the following line for searching using freeWAIS-sf:
- (setq nnir-search-engine 'wais)
-Use the following line if you read your mail via IMAP and your IMAP
-server supports searching:
- (setq nnir-search-engine 'imap)
-Note that you have to set additional variables for most backends. For
-example, the `wais' backend needs the variables `nnir-wais-program',
-`nnir-wais-database' and `nnir-wais-remove-prefix'.
-
-Add an entry here when adding a new search engine.")
;;; User Customizable Variables:
(defgroup nnir nil
- "Search nnmh and nnml groups in Gnus with swish-e, freeWAIS-sf, or EWS."
+ "Search groups in Gnus with assorted seach engines."
:group 'gnus)
-;; Mail backend.
-
-;; TODO:
-;; If `nil', use server parameters to find out which server to search. CCC
-;;
-(defcustom nnir-mail-backend '(nnml "")
- "*Specifies which backend should be searched.
-More precisely, this is used to determine from which backend to fetch the
-messages found.
-
-This must be equal to an existing server, so maybe it is best to use
-something like the following:
- (setq nnir-mail-backend (nth 0 gnus-secondary-select-methods))
-The above line works fine if the mail backend you want to search is
-the first element of gnus-secondary-select-methods (`nth' starts counting
-at zero)."
- :type '(sexp)
- :group 'nnir)
-
-;; Search engine to use.
-
-(defcustom nnir-search-engine 'wais
- "*The search engine to use. Must be a symbol.
-See `nnir-engines' for a list of supported engines, and for example
-settings of `nnir-search-engine'."
- :type '(sexp)
+(defcustom nnir-method-default-engines
+ '((nnimap . imap)
+ (nntp . gmane))
+ "*Alist of default search engines keyed by server method"
+ :type '(alist)
:group 'nnir)
-;; freeWAIS-sf.
-
-(defcustom nnir-wais-program "waissearch"
- "*Name of waissearch executable."
+(defcustom nnir-imap-default-search-key "Whole message"
+ "*The default IMAP search key for an nnir search. Must be one of
+ the keys in `nnir-imap-search-arguments'. To use raw imap queries
+ by default set this to \"Imap\""
:type '(string)
:group 'nnir)
-(defcustom nnir-wais-database (expand-file-name "~/.wais/mail")
- "*Name of Wais database containing the mail.
-
-Note that this should be a file name without extension. For example,
-if you have a file /home/john/.wais/mail.fmt, use this:
- (setq nnir-wais-database \"/home/john/.wais/mail\")
-The string given here is passed to `waissearch -d' as-is."
- :type '(file)
- :group 'nnir)
-
-(defcustom nnir-wais-remove-prefix (concat (getenv "HOME") "/Mail/")
- "*The prefix to remove from each directory name returned by waissearch
-in order to get a group name (albeit with / instead of .). This is a
-regular expression.
-
-For example, suppose that Wais returns file names such as
-\"/home/john/Mail/mail/misc/42\". For this example, use the following
-setting: (setq nnir-wais-remove-prefix \"/home/john/Mail/\")
-Note the trailing slash. Removing this prefix gives \"mail/misc/42\".
-`nnir' knows to remove the \"/42\" and to replace \"/\" with \".\" to
-arrive at the correct group name, \"mail.misc\"."
- :type '(regexp)
- :group 'nnir)
-
(defcustom nnir-swish++-configuration-file
(expand-file-name "~/Mail/swish++.conf")
"*Configuration file for swish++."
@@ -493,14 +235,13 @@ Instead, use this:
in order to get a group name (albeit with / instead of .). This is a
regular expression.
-This variable is very similar to `nnir-wais-remove-prefix', except
-that it is for swish++, not Wais."
+This variable is very similar to `nnir-namazu-remove-prefix', except
+that it is for swish++, not Namazu."
:type '(regexp)
:group 'nnir)
;; Swish-E.
-;; URL: http://sunsite.berkeley.edu/SWISH-E/
-;; New version: http://www.boe.es/swish-e
+;; URL: http://swish-e.org/
;; Variables `nnir-swish-e-index-file', `nnir-swish-e-program' and
;; `nnir-swish-e-additional-switches'
@@ -545,8 +286,8 @@ This could be a server parameter."
in order to get a group name (albeit with / instead of .). This is a
regular expression.
-This variable is very similar to `nnir-wais-remove-prefix', except
-that it is for swish-e, not Wais.
+This variable is very similar to `nnir-namazu-remove-prefix', except
+that it is for swish-e, not Namazu.
This could be a server parameter."
:type '(regexp)
@@ -586,7 +327,7 @@ arrive at the correct group name, \"mail.misc\"."
:type '(directory)
:group 'nnir)
-;; Namazu engine, see <URL:http://ww.namazu.org/>
+;; Namazu engine, see <URL:http://www.namazu.org/>
(defcustom nnir-namazu-program "namazu"
"*Name of Namazu search executable."
@@ -614,11 +355,81 @@ Instead, use this:
"*The prefix to remove from each file name returned by Namazu
in order to get a group name (albeit with / instead of .).
-This variable is very similar to `nnir-wais-remove-prefix', except
-that it is for Namazu, not Wais."
+For example, suppose that Namazu returns file names such as
+\"/home/john/Mail/mail/misc/42\". For this example, use the following
+setting: (setq nnir-namazu-remove-prefix \"/home/john/Mail/\")
+Note the trailing slash. Removing this prefix gives \"mail/misc/42\".
+`nnir' knows to remove the \"/42\" and to replace \"/\" with \".\" to
+arrive at the correct group name, \"mail.misc\"."
:type '(directory)
:group 'nnir)
+;; Imap variables
+
+(defvar nnir-imap-search-arguments
+ '(("Whole message" . "TEXT")
+ ("Subject" . "SUBJECT")
+ ("To" . "TO")
+ ("From" . "FROM")
+ ("Imap" . ""))
+ "Mapping from user readable keys to IMAP search items for use in nnir")
+
+(defvar nnir-imap-search-other "HEADER %S"
+ "The IMAP search item to use for anything other than
+ `nnir-imap-search-arguments'. By default this is the name of an
+ email header field")
+
+(defvar nnir-imap-search-argument-history ()
+ "The history for querying search options in nnir")
+
+;;; Developer Extension Variable:
+
+(defvar nnir-engines
+ `((imap nnir-run-imap
+ ((criteria
+ "Imap Search in" ; Prompt
+ ,(mapcar 'car nnir-imap-search-arguments) ; alist for completing
+ nil ; allow any user input
+ nil ; initial value
+ nnir-imap-search-argument-history ; the history to use
+ ,nnir-imap-default-search-key ; default
+ )))
+ (gmane nnir-run-gmane
+ ((author . "Gmane Author: ")))
+ (swish++ nnir-run-swish++
+ ((group . "Swish++ Group spec: ")))
+ (swish-e nnir-run-swish-e
+ ((group . "Swish-e Group spec: ")))
+ (namazu nnir-run-namazu
+ ())
+ (hyrex nnir-run-hyrex
+ ((group . "Hyrex Group spec: ")))
+ (find-grep nnir-run-find-grep
+ ((grep-options . "Grep options: "))))
+ "Alist of supported search engines.
+Each element in the alist is a three-element list (ENGINE FUNCTION ARGS).
+ENGINE is a symbol designating the searching engine. FUNCTION is also
+a symbol, giving the function that does the search. The third element
+ARGS is a list of cons pairs (PARAM . PROMPT). When issuing a query,
+the FUNCTION will issue a query for each of the PARAMs, using PROMPT.
+
+The value of `nnir-search-engine' must be one of the ENGINE symbols.
+For example, for searching a server using namazu include
+ (nnir-search-engine namazu)
+in the server definition. Note that you have to set additional
+variables for most backends. For example, the `namazu' backend
+needs the variables `nnir-namazu-program',
+`nnir-namazu-index-directory' and `nnir-namazu-remove-prefix'.
+
+Add an entry here when adding a new search engine.")
+
+(defvar nnir-get-article-nov-override-function nil
+ "If non-nil, a function that will be passed each search result. This
+should return a message's headers in NOV format.
+
+If this variable is nil, or if the provided function returns nil for a search
+result, `gnus-retrieve-headers' will be called instead.")
+
;;; Internal Variables:
(defvar nnir-current-query nil
@@ -636,88 +447,33 @@ that it is for Namazu, not Wais."
(defvar nnir-tmp-buffer " *nnir*"
"Internal: temporary buffer.")
+(defvar nnir-search-history ()
+ "Internal: the history for querying search options in nnir")
+
+(defvar nnir-extra-parms nil
+ "Internal: stores request for extra search parms")
+
;;; Code:
;; Gnus glue.
-(defun gnus-group-make-nnir-group (extra-parms query)
+(defun gnus-group-make-nnir-group (nnir-extra-parms)
"Create an nnir group. Asks for query."
- (interactive "P\nsQuery: ")
+ (interactive "P")
(setq nnir-current-query nil
nnir-current-server nil
nnir-current-group-marked nil
nnir-artlist nil)
- (let ((parms nil))
- (if extra-parms
- (setq parms (nnir-read-parms query))
- (setq parms (list (cons 'query query))))
+ (let* ((query (read-string "Query: " nil 'nnir-search-history))
+ (parms (list (cons 'query query)))
+ (srv (if (gnus-server-server-name)
+ "all" "")))
(add-to-list 'parms (cons 'unique-id (message-unique-id)) t)
(gnus-group-read-ephemeral-group
- (concat "nnir:" (prin1-to-string parms)) '(nnir "") t
- (cons (current-buffer)
- gnus-current-window-configuration)
+ (concat "nnir:" (prin1-to-string parms)) (list 'nnir srv) t
+ (cons (current-buffer) gnus-current-window-configuration)
nil)))
-(eval-when-compile
- (when (featurep 'xemacs)
- ;; The `kbd' macro requires that the `read-kbd-macro' macro is available.
- (require 'edmacro)))
-
-(defun nnir-group-mode-hook ()
- (define-key gnus-group-mode-map (kbd "G G")
- 'gnus-group-make-nnir-group))
-(add-hook 'gnus-group-mode-hook 'nnir-group-mode-hook)
-
-;; Why is this needed? Is this for compatibility with old/new gnusae? Using
-;; gnus-group-server instead works for me. -- Justus Piater
-(defmacro nnir-group-server (group)
- "Return the server for a newsgroup GROUP.
-The returned format is as `gnus-server-to-method' needs it. See
-`gnus-group-real-prefix' and `gnus-group-real-name'."
- `(let ((gname ,group))
- (if (string-match "^\\([^:]+\\):" gname)
- (progn
- (setq gname (match-string 1 gname))
- (if (string-match "^\\([^+]+\\)\\+\\(.+\\)$" gname)
- (format "%s:%s" (match-string 1 gname) (match-string 2 gname))
- (concat gname ":")))
- (format "%s:%s" (car gnus-select-method) (cadr gnus-select-method)))))
-
-;; Summary mode commands.
-
-(defun gnus-summary-nnir-goto-thread ()
- "Only applies to nnir groups. Go to group this article came from
-and show thread that contains this article."
- (interactive)
- (unless (eq 'nnir (car (gnus-find-method-for-group gnus-newsgroup-name)))
- (error "Can't execute this command unless in nnir group"))
- (let* ((cur (gnus-summary-article-number))
- (group (nnir-artlist-artitem-group nnir-artlist cur))
- (backend-number (nnir-artlist-artitem-number nnir-artlist cur))
- server backend-group)
- (setq server (nnir-group-server group))
- (setq backend-group (gnus-group-real-name group))
- (gnus-group-read-ephemeral-group
- backend-group
- (gnus-server-to-method server)
- t ; activate
- (cons (current-buffer)
- 'summary) ; window config
- nil
- (list backend-number))
- (gnus-summary-limit (list backend-number))
- (gnus-summary-refer-thread)))
-
-(if (fboundp 'eval-after-load)
- (eval-after-load "gnus-sum"
- '(define-key gnus-summary-goto-map
- "T" 'gnus-summary-nnir-goto-thread))
- (add-hook 'gnus-summary-mode-hook
- (function (lambda ()
- (define-key gnus-summary-goto-map
- "T" 'gnus-summary-nnir-goto-thread)))))
-
-
;; Gnus backend interface functions.
@@ -725,7 +481,7 @@ and show thread that contains this article."
;; Just set the server variables appropriately.
(nnoo-change-server 'nnir server definitions))
-(deffoo nnir-request-group (group &optional server fast)
+(deffoo nnir-request-group (group &optional server fast info)
"GROUP is the query string."
(nnir-possibly-change-server server)
;; Check for cache and return that if appropriate.
@@ -735,25 +491,19 @@ and show thread that contains this article."
(equal server nnir-current-server)))
nnir-artlist
;; Cache miss.
- (setq nnir-artlist (nnir-run-query group)))
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (setq nnir-artlist (nnir-run-query group server)))
+ (with-current-buffer nntp-server-buffer
+ (setq nnir-current-query group)
+ (when server (setq nnir-current-server server))
+ (setq nnir-current-group-marked gnus-group-marked)
(if (zerop (length nnir-artlist))
- (progn
- (setq nnir-current-query nil
- nnir-current-server nil
- nnir-current-group-marked nil
- nnir-artlist nil)
- (nnheader-report 'nnir "Search produced empty results."))
+ (nnheader-report 'nnir "Search produced empty results.")
;; Remember data for cache.
- (setq nnir-current-query group)
- (when server (setq nnir-current-server server))
- (setq nnir-current-group-marked gnus-group-marked)
(nnheader-insert "211 %d %d %d %s\n"
(nnir-artlist-length nnir-artlist) ; total #
1 ; first #
(nnir-artlist-length nnir-artlist) ; last #
- group)))) ; group name
+ group)))) ; group name
(deffoo nnir-retrieve-headers (articles &optional group server fetch-old)
(save-excursion
@@ -772,45 +522,39 @@ and show thread that contains this article."
(setq artfullgroup (nnir-artitem-group artitem))
(setq artno (nnir-artitem-number artitem))
(setq artgroup (gnus-group-real-name artfullgroup))
- (setq server (nnir-group-server artfullgroup))
+ (setq server (gnus-group-server artfullgroup))
;; retrieve NOV or HEAD data for this article, transform into
;; NOV data and prepend to `novdata'
(set-buffer nntp-server-buffer)
(nnir-possibly-change-server server)
(let ((gnus-override-method
(gnus-server-to-method server)))
- (case (setq foo (gnus-retrieve-headers (list artno) artfullgroup nil))
- (nov
- (goto-char (point-min))
- (setq novitem (nnheader-parse-nov))
- (unless novitem
- (pop-to-buffer nntp-server-buffer)
- (error
- "nnheader-parse-nov returned nil for article %s in group %s"
- artno artfullgroup)))
- (headers
- (goto-char (point-min))
- (setq novitem (nnheader-parse-head))
- (unless novitem
- (pop-to-buffer nntp-server-buffer)
- (error
- "nnheader-parse-head returned nil for article %s in group %s"
- artno artfullgroup)))
- (t (error "Unknown header type %s while requesting article %s of group %s"
- foo artno artfullgroup))))
+ ;; if nnir-get-article-nov-override-function is set, use it
+ (if nnir-get-article-nov-override-function
+ (setq novitem (funcall nnir-get-article-nov-override-function
+ artitem))
+ ;; else, set novitem through nnheader-parse-nov/nnheader-parse-head
+ (case (setq foo (gnus-retrieve-headers (list artno)
+ artfullgroup nil))
+ (nov
+ (goto-char (point-min))
+ (setq novitem (nnheader-parse-nov)))
+ (headers
+ (goto-char (point-min))
+ (setq novitem (nnheader-parse-head)))
+ (t (error "Unknown header type %s while requesting article %s of group %s"
+ foo artno artfullgroup)))))
;; replace article number in original group with article number
;; in nnir group
- (mail-header-set-number novitem art)
- (mail-header-set-from novitem
- (mail-header-from novitem))
- (mail-header-set-subject
- novitem
- (format "[%d: %s/%d] %s"
- artrsv artgroup artno
- (mail-header-subject novitem)))
- ;;-(mail-header-set-extra novitem nil)
- (push novitem novdata)
- (setq artlist (cdr artlist)))
+ (when novitem
+ (mail-header-set-number novitem art)
+ (mail-header-set-subject
+ novitem
+ (format "[%d: %s/%d] %s"
+ artrsv artgroup artno
+ (mail-header-subject novitem)))
+ (push novitem novdata)
+ (setq artlist (cdr artlist))))
(setq novdata (nreverse novdata))
(set-buffer nntp-server-buffer) (erase-buffer)
(mapc 'nnheader-insert-nov novdata)
@@ -840,6 +584,40 @@ and show thread that contains this article."
(gnus-request-article artno artfullgroup nntp-server-buffer)
(cons artfullgroup artno)))))
+(deffoo nnir-request-move-article (article group server accept-form
+ &optional last internal-move-group)
+ (let* ((artitem (nnir-artlist-article nnir-artlist
+ article))
+ (artfullgroup (nnir-artitem-group artitem))
+ (artno (nnir-artitem-number artitem))
+ (to-newsgroup (nth 1 accept-form))
+ (to-method (gnus-find-method-for-group to-newsgroup))
+ (from-method (gnus-find-method-for-group artfullgroup))
+ (move-is-internal (gnus-server-equal from-method to-method))
+ (artsubject (mail-header-subject
+ (gnus-data-header
+ (assoc article (gnus-data-list nil))))))
+ (setq gnus-newsgroup-original-name artfullgroup)
+ (string-match "^\\[[0-9]+:.+/[0-9]+\\] " artsubject)
+ (setq gnus-article-original-subject (substring artsubject (match-end 0)))
+ (gnus-request-move-article
+ artno
+ artfullgroup
+ (nth 1 from-method)
+ accept-form
+ last
+ (and move-is-internal
+ to-newsgroup ; Not respooling
+ (gnus-group-real-name to-newsgroup)))))
+
+(deffoo nnir-warp-to-article ()
+ (let* ((cur (if (> (gnus-summary-article-number) 0)
+ (gnus-summary-article-number)
+ (error "This is not a real article.")))
+ (gnus-newsgroup-name (nnir-artlist-artitem-group nnir-artlist cur))
+ (backend-number (nnir-artlist-artitem-number nnir-artlist cur)))
+ (gnus-summary-read-group-1 gnus-newsgroup-name t t gnus-summary-buffer
+ nil (list backend-number))))
(nnoo-define-skeleton nnir)
@@ -866,7 +644,9 @@ ready to be added to the list of search results."
(when (file-readable-p (concat prefix dirnam article))
;; remove trailing slash and, for nnmaildir, cur/new/tmp
(setq dirnam
- (substring dirnam 0 (if (string= server "nnmaildir:") -5 -1)))
+ (substring dirnam 0
+ (if (string= (gnus-group-server server) "nnmaildir")
+ -5 -1)))
;; Set group to dirnam without any leading dots or slashes,
;; and with all subsequent slashes replaced by dots
@@ -875,7 +655,7 @@ ready to be added to the list of search results."
"[/\\]" "." t)))
(vector (nnir-group-full-name group server)
- (if (string= server "nnmaildir:")
+ (if (string= (gnus-group-server server) "nnmaildir")
(nnmaildir-base-name-to-article-number
(substring article 0 (string-match ":" article))
group nil)
@@ -884,94 +664,49 @@ ready to be added to the list of search results."
;;; Search Engine Interfaces:
-;; freeWAIS-sf interface.
-(defun nnir-run-waissearch (query server &optional group)
- "Run given query agains waissearch. Returns vector of (group name, file name)
-pairs (also vectors, actually)."
- (when group
- (error "The freeWAIS-sf backend cannot search specific groups"))
- (save-excursion
- (let ((qstring (cdr (assq 'query query)))
- (prefix (nnir-read-server-parm 'nnir-wais-remove-prefix server))
- artlist score artno dirnam)
- (set-buffer (get-buffer-create nnir-tmp-buffer))
- (erase-buffer)
- (message "Doing WAIS query %s..." query)
- (call-process nnir-wais-program
- nil ; input from /dev/null
- t ; output to current buffer
- nil ; don't redisplay
- "-d" (nnir-read-server-parm 'nnir-wais-database server) ; database to search
- qstring)
- (message "Massaging waissearch output...")
- ;; remove superfluous lines
- (keep-lines "Score:")
- ;; extract data from result lines
- (goto-char (point-min))
- (while (re-search-forward
- "Score: +\\([0-9]+\\).*'\\([0-9]+\\) +\\([^']+\\)/'" nil t)
- (setq score (match-string 1)
- artno (match-string 2)
- dirnam (match-string 3))
- (unless (string-match prefix dirnam)
- (nnheader-report 'nnir "Dir name %s doesn't contain prefix %s"
- dirnam prefix))
- (setq group (gnus-replace-in-string
- (replace-match "" t t dirnam) "/" "."))
- (push (vector (nnir-group-full-name group server)
- (string-to-number artno)
- (string-to-number score))
- artlist))
- (message "Massaging waissearch output...done")
- (apply 'vector
- (sort artlist
- (function (lambda (x y)
- (> (nnir-artitem-rsv x)
- (nnir-artitem-rsv y)))))))))
-
-;; IMAP interface.
-;; todo:
-;; nnir invokes this two (2) times???!
-;; we should not use nnimap at all but open our own server connection
-;; we should not LIST * but use nnimap-list-pattern from defs
-;; send queries as literals
-;; handle errors
-
-(autoload 'nnimap-open-server "nnimap")
-(defvar nnimap-server-buffer) ;; nnimap.el
-(autoload 'imap-mailbox-select "imap")
-(autoload 'imap-search "imap")
-(autoload 'imap-quote-specials "imap")
-
-(defun nnir-run-imap (query srv &optional group-option)
+;; imap interface
+(defun nnir-run-imap (query srv &optional groups)
"Run a search against an IMAP back-end server.
This uses a custom query language parser; see `nnir-imap-make-query' for
details on the language and supported extensions"
(save-excursion
(let ((qstring (cdr (assq 'query query)))
- (server (cadr (gnus-server-to-method srv)))
- (group (or group-option (gnus-group-group-name)))
- (defs (caddr (gnus-server-to-method srv)))
- (criteria (or (cdr (assq 'criteria query))
- nnir-imap-search-field))
- artlist buf)
+ (server (cadr (gnus-server-to-method srv)))
+ (defs (caddr (gnus-server-to-method srv)))
+ (criteria (or (cdr (assq 'criteria query))
+ (cdr (assoc nnir-imap-default-search-key
+ nnir-imap-search-arguments))))
+ (gnus-inhibit-demon t)
+ (groups (or groups (nnir-get-active srv))))
(message "Opening server %s" server)
- (condition-case ()
- (when (nnimap-open-server server defs) ;; xxx
- (setq buf nnimap-server-buffer) ;; xxx
- (message "Searching %s..." group)
- (let ((arts 0)
- (mbx (gnus-group-real-name group)))
- (when (imap-mailbox-select mbx nil buf)
- (mapc
- (lambda (artnum)
- (push (vector group artnum 1) artlist)
- (setq arts (1+ arts)))
- (imap-search (nnir-imap-make-query criteria qstring) buf))
- (message "Searching %s... %d matches" mbx arts)))
- (message "Searching %s...done" group))
- (quit nil))
- (reverse artlist))))
+ (apply
+ 'vconcat
+ (mapcar
+ (lambda (group)
+ (let (artlist)
+ (condition-case ()
+ (when (nnimap-possibly-change-group
+ (gnus-group-short-name group) server)
+ (with-current-buffer (nnimap-buffer)
+ (message "Searching %s..." group)
+ (let ((arts 0)
+ (result (nnimap-command "UID SEARCH %s"
+ (if (string= criteria "")
+ qstring
+ (nnir-imap-make-query
+ criteria qstring)))))
+ (mapc
+ (lambda (artnum) (push (vector group artnum 1) artlist)
+ (setq arts (1+ arts)))
+ (and (car result)
+ (delete 0 (mapcar #'string-to-number
+ (cdr (assoc "SEARCH"
+ (cdr result)))))))
+ (message "Searching %s... %d matches" group arts)))
+ (message "Searching %s...done" group))
+ (quit nil))
+ artlist))
+ groups)))))
(defun nnir-imap-make-query (criteria qstring)
"Parse the query string and criteria into an appropriate IMAP search
@@ -1027,7 +762,7 @@ In future the following will be added to the language:
(cond
;; Simple string term
((stringp expr)
- (format "%s \"%s\"" criteria (imap-quote-specials expr)))
+ (format "%s %S" criteria expr))
;; Trivial term: and
((eq expr 'and) nil)
;; Composite term: or expression
@@ -1161,8 +896,8 @@ actually).
Tested with swish++ 4.7 on GNU/Linux and with swish++ 5.0b2 on
Windows NT 4.0."
- (when group
- (error "The swish++ backend cannot search specific groups"))
+ ;; (when group
+ ;; (error "The swish++ backend cannot search specific groups"))
(save-excursion
(let ( (qstring (cdr (assq 'query query)))
@@ -1173,7 +908,7 @@ Windows NT 4.0."
;; is sufficient. Note that we can't only use the value of
;; nnml-use-compressed-files because old articles might have been
;; saved with a different value.
- (article-pattern (if (string= server "nnmaildir:")
+ (article-pattern (if (string= (gnus-group-server server) "nnmaildir")
":[0-9]+"
"^[0-9]+\\(\\.[a-z0-9]+\\)?$"))
score artno dirnam filenam)
@@ -1250,8 +985,8 @@ actually).
Tested with swish-e-2.0.1 on Windows NT 4.0."
;; swish-e crashes with empty parameter to "-w" on commandline...
- (when group
- (error "The swish-e backend cannot search specific groups"))
+ ;; (when group
+ ;; (error "The swish-e backend cannot search specific groups"))
(save-excursion
(let ((qstring (cdr (assq 'query query)))
@@ -1343,19 +1078,13 @@ Tested with swish-e-2.0.1 on Windows NT 4.0."
(qstring (cdr (assq 'query query)))
(prefix (nnir-read-server-parm 'nnir-hyrex-remove-prefix server))
score artno dirnam)
- (when (and group groupspec)
- (error (concat "It does not make sense to use a group spec"
- " with process-marked groups.")))
- (when group
- (setq groupspec (gnus-group-real-name group)))
- (when (and group (not (equal group (nnir-group-full-name groupspec server))))
- (message "%s vs. %s" group (nnir-group-full-name groupspec server))
- (error "Server with groupspec doesn't match group !"))
+ (when (and (not groupspec) group)
+ (setq groupspec
+ (regexp-opt
+ (mapcar (lambda (x) (gnus-group-real-name x)) group))))
(set-buffer (get-buffer-create nnir-tmp-buffer))
(erase-buffer)
- (if groupspec
- (message "Doing hyrex-search query %s on %s..." query groupspec)
- (message "Doing hyrex-search query %s..." query))
+ (message "Doing hyrex-search query %s..." query)
(let* ((cp-list
`( ,nnir-hyrex-program
nil ; input from /dev/null
@@ -1377,16 +1106,14 @@ Tested with swish-e-2.0.1 on Windows NT 4.0."
;; the user wants it.
(when (> gnus-verbose 6)
(display-buffer nnir-tmp-buffer)))) ;; FIXME: Dont clear buffer !
- (if groupspec
- (message "Doing hyrex-search query \"%s\" on %s...done" qstring groupspec)
- (message "Doing hyrex-search query \"%s\"...done" qstring))
+ (message "Doing hyrex-search query \"%s\"...done" qstring)
(sit-for 0)
;; nnir-search returns:
;; for nnml/nnfolder: "filename mailid weigth"
;; for nnimap: "group mailid weigth"
(goto-char (point-min))
(delete-non-matching-lines "^\\S + [0-9]+ [0-9]+$")
- ;; HyREX couldn't search directly in groups -- so filter out here.
+ ;; HyREX doesn't search directly in groups -- so filter out here.
(when groupspec
(keep-lines groupspec))
;; extract data from result lines
@@ -1420,10 +1147,10 @@ Tested with swish-e-2.0.1 on Windows NT 4.0."
pairs (also vectors, actually).
Tested with Namazu 2.0.6 on a GNU/Linux system."
- (when group
- (error "The Namazu backend cannot search specific groups"))
+ ;; (when group
+ ;; (error "The Namazu backend cannot search specific groups"))
(save-excursion
- (let ((article-pattern (if (string= server "nnmaildir:")
+ (let ((article-pattern (if (string= (gnus-group-server server) "nnmaildir")
":[0-9]+"
"^[0-9]+$"))
artlist
@@ -1483,7 +1210,7 @@ Tested with Namazu 2.0.6 on a GNU/Linux system."
(> (nnir-artitem-rsv x)
(nnir-artitem-rsv y)))))))))
-(defun nnir-run-find-grep (query server &optional group)
+(defun nnir-run-find-grep (query server &optional grouplist)
"Run find and grep to obtain matching articles."
(let* ((method (gnus-server-to-method server))
(sym (intern
@@ -1495,69 +1222,141 @@ Tested with Namazu 2.0.6 on a GNU/Linux system."
(unless directory
(error "No directory found in method specification of server %s"
server))
- (message "Searching %s using find-grep..." (or group server))
- (save-window-excursion
- (set-buffer (get-buffer-create nnir-tmp-buffer))
- (erase-buffer)
- (if (> gnus-verbose 6)
- (pop-to-buffer (current-buffer)))
- (cd directory) ; Using relative paths simplifies postprocessing.
- (let ((group
- (if (not group)
- "."
- ;; Try accessing the group literally as well as
- ;; interpreting dots as directory separators so the
- ;; engine works with plain nnml as well as the Gnus Cache.
- (let ((group (gnus-group-real-name group)))
- ;; Replace cl-func find-if.
- (if (file-directory-p group)
- group
- (if (file-directory-p
- (setq group (gnus-replace-in-string group "\\." "/" t)))
- group))))))
- (unless group
- (error "Cannot locate directory for group"))
- (save-excursion
- (apply
- 'call-process "find" nil t
- "find" group "-type" "f" "-name" "[0-9]*" "-exec"
- "grep"
- `("-l" ,@(and grep-options
- ;; Note: the 3rd arg of `split-string' is not
- ;; available in Emacs 21.
- (delete "" (split-string grep-options "\\s-")))
- "-e" ,regexp "{}" "+"))))
-
- ;; Translate relative paths to group names.
- (while (not (eobp))
- (let* ((path (delete
- ""
- (split-string
- (buffer-substring (point) (line-end-position)) "/")))
- (art (string-to-number (car (last path)))))
- (while (string= "." (car path))
- (setq path (cdr path)))
- (let ((group (mapconcat 'identity
- ;; Replace cl-func: (subseq path 0 -1)
- (let ((end (1- (length path)))
- res)
- (while (>= (setq end (1- end)) 0)
- (push (pop path) res))
- (nreverse res))
- ".")))
- (push (vector (nnir-group-full-name group server) art 0)
- artlist))
- (forward-line 1)))
- (message "Searching %s using find-grep...done" (or group server))
- artlist)))
+ (apply
+ 'vconcat
+ (mapcar (lambda (x)
+ (let ((group x))
+ (message "Searching %s using find-grep..."
+ (or group server))
+ (save-window-excursion
+ (set-buffer (get-buffer-create nnir-tmp-buffer))
+ (erase-buffer)
+ (if (> gnus-verbose 6)
+ (pop-to-buffer (current-buffer)))
+ (cd directory) ; Using relative paths simplifies
+ ; postprocessing.
+ (let ((group
+ (if (not group)
+ "."
+ ;; Try accessing the group literally as
+ ;; well as interpreting dots as directory
+ ;; separators so the engine works with
+ ;; plain nnml as well as the Gnus Cache.
+ (let ((group (gnus-group-real-name group)))
+ ;; Replace cl-func find-if.
+ (if (file-directory-p group)
+ group
+ (if (file-directory-p
+ (setq group
+ (gnus-replace-in-string
+ group
+ "\\." "/" t)))
+ group))))))
+ (unless group
+ (error "Cannot locate directory for group"))
+ (save-excursion
+ (apply
+ 'call-process "find" nil t
+ "find" group "-type" "f" "-name" "[0-9]*" "-exec"
+ "grep"
+ `("-l" ,@(and grep-options
+ (split-string grep-options "\\s-" t))
+ "-e" ,regexp "{}" "+"))))
+
+ ;; Translate relative paths to group names.
+ (while (not (eobp))
+ (let* ((path (split-string
+ (buffer-substring
+ (point)
+ (line-end-position)) "/" t))
+ (art (string-to-number (car (last path)))))
+ (while (string= "." (car path))
+ (setq path (cdr path)))
+ (let ((group (mapconcat 'identity
+ ;; Replace cl-func:
+ ;; (subseq path 0 -1)
+ (let ((end (1- (length path)))
+ res)
+ (while
+ (>= (setq end (1- end)) 0)
+ (push (pop path) res))
+ (nreverse res))
+ ".")))
+ (push
+ (vector (nnir-group-full-name group server) art 0)
+ artlist))
+ (forward-line 1)))
+ (message "Searching %s using find-grep...done"
+ (or group server))
+ artlist)))
+ grouplist))))
+
+(declare-function mm-url-insert "mm-url" (url &optional follow-refresh))
+(declare-function mm-url-encode-www-form-urlencoded "mm-url" (pairs))
+
+;; gmane interface
+(defun nnir-run-gmane (query srv &optional groups)
+ "Run a search against a gmane back-end server."
+ (if (gnus-string-match-p "gmane" srv)
+ (let* ((case-fold-search t)
+ (qstring (cdr (assq 'query query)))
+ (server (cadr (gnus-server-to-method srv)))
+ (groupspec (if groups
+ (mapconcat
+ (function (lambda (x)
+ (format "group:%s"
+ (gnus-group-short-name x))))
+ groups " ") ""))
+ (authorspec
+ (if (assq 'author query)
+ (format "author:%s" (cdr (assq 'author query))) ""))
+ (search (format "%s %s %s"
+ qstring groupspec authorspec))
+ (gnus-inhibit-demon t)
+ artlist)
+ (require 'mm-url)
+ (with-current-buffer (get-buffer-create nnir-tmp-buffer)
+ (erase-buffer)
+ (mm-url-insert
+ (concat
+ "http://search.gmane.org/nov.php"
+ "?"
+ (mm-url-encode-www-form-urlencoded
+ `(("query" . ,search)
+ ("HITSPERPAGE" . "999")))))
+ (unless (featurep 'xemacs) (set-buffer-multibyte t))
+ (mm-decode-coding-region (point-min) (point-max) 'utf-8)
+ (goto-char (point-min))
+ (forward-line 1)
+ (while (not (eobp))
+ (unless (or (eolp) (looking-at "\x0d"))
+ (let ((header (nnheader-parse-nov)))
+ (let ((xref (mail-header-xref header))
+ (xscore (string-to-number (cdr (assoc 'X-Score
+ (mail-header-extra header))))))
+ (when (string-match " \\([^:]+\\)[:/]\\([0-9]+\\)" xref)
+ (push
+ (vector
+ (gnus-group-prefixed-name (match-string 1 xref) srv)
+ (string-to-number (match-string 2 xref)) xscore)
+ artlist)))))
+ (forward-line 1)))
+ ;; Sort by score
+ (apply 'vector
+ (sort artlist
+ (function (lambda (x y)
+ (> (nnir-artitem-rsv x)
+ (nnir-artitem-rsv y)))))))
+ (message "Can't search non-gmane nntp groups")
+ nil))
;;; Util Code:
-(defun nnir-read-parms (query)
+(defun nnir-read-parms (query nnir-search-engine)
"Reads additional search parameters according to `nnir-engines'."
(let ((parmspec (caddr (assoc nnir-search-engine nnir-engines))))
- (cons (cons 'query query)
- (mapcar 'nnir-read-parm parmspec))))
+ (append query
+ (mapcar 'nnir-read-parm parmspec))))
(defun nnir-read-parm (parmspec)
"Reads a single search parameter.
@@ -1565,62 +1364,57 @@ Tested with Namazu 2.0.6 on a GNU/Linux system."
(let ((sym (car parmspec))
(prompt (cdr parmspec)))
(if (listp prompt)
- (let* ((result (apply 'completing-read prompt))
+ (let* ((result (apply 'gnus-completing-read prompt))
(mapping (or (assoc result nnir-imap-search-arguments)
- (assoc nil nnir-imap-search-arguments))))
+ (cons nil nnir-imap-search-other))))
(cons sym (format (cdr mapping) result)))
(cons sym (read-string prompt)))))
-(defun nnir-run-query (query)
+(autoload 'gnus-group-topic-name "gnus-topic")
+
+(defun nnir-run-query (query nserver)
"Invoke appropriate search engine function (see `nnir-engines').
-If some groups were process-marked, run the query for each of the groups
-and concat the results."
- (let ((q (car (read-from-string query))))
- (if gnus-group-marked
- (apply 'vconcat
- (mapcar (lambda (x)
- (let ((server (nnir-group-server x))
- search-func)
- (setq search-func (cadr
- (assoc
- (nnir-read-server-parm 'nnir-search-engine server) nnir-engines)))
- (if search-func
- (funcall search-func q server x)
- nil)))
- gnus-group-marked)
- )
- (apply 'vconcat
- (mapcar (lambda (x)
- (if (and (equal (cadr x) 'ok) (not (equal (cadar x) "-ephemeral")))
- (let ((server (format "%s:%s" (caar x) (cadar x)))
- search-func)
- (setq search-func (cadr
- (assoc
- (nnir-read-server-parm 'nnir-search-engine server) nnir-engines)))
- (if search-func
- (funcall search-func q server nil)
- nil))
- nil))
- gnus-opened-servers)
- ))
- ))
+ If some groups were process-marked, run the query for each of the groups
+ and concat the results."
+ (let ((q (car (read-from-string query)))
+ (groups (if (string= "all-ephemeral" nserver)
+ (with-current-buffer gnus-server-buffer
+ (list (list (gnus-server-server-name))))
+ (nnir-sort-groups-by-server
+ (or gnus-group-marked
+ (if (gnus-group-group-name)
+ (list (gnus-group-group-name))
+ (cdr (assoc (gnus-group-topic-name)
+ gnus-topic-alist))))))))
+ (apply 'vconcat
+ (mapcar (lambda (x)
+ (let* ((server (car x))
+ (nnir-search-engine
+ (or (nnir-read-server-parm 'nnir-search-engine
+ server)
+ (cdr (assoc (car
+ (gnus-server-to-method server))
+ nnir-method-default-engines))))
+ search-func)
+ (setq search-func (cadr
+ (assoc nnir-search-engine
+ nnir-engines)))
+ (if search-func
+ (funcall search-func
+ (if nnir-extra-parms
+ (nnir-read-parms q nnir-search-engine)
+ q)
+ server (cdr x))
+ nil)))
+ groups))))
(defun nnir-read-server-parm (key server)
- "Returns the parameter value of for the given server, where server is of
-form 'backend:name'."
+ "Returns the parameter value of key for the given server, where
+server is of form 'backend:name'."
(let ((method (gnus-server-to-method server)))
(cond ((and method (assq key (cddr method)))
- (nth 1 (assq key (cddr method))))
- ((and nnir-mail-backend
- (gnus-server-equal method nnir-mail-backend))
- (symbol-value key))
- (t nil))))
-;; (if method
-;; (if (assq key (cddr method))
-;; (nth 1 (assq key (cddr method)))
-;; (symbol-value key))
-;; (symbol-value key))
-;; ))
+ (nth 1 (assq key (cddr method))))
+ (t nil))))
(defun nnir-group-full-name (shortname server)
"For the given group name, return a full Gnus group name.
@@ -1663,8 +1457,8 @@ The Gnus backend/server information is added."
(elt artitem 2))
(defun nnir-artlist-artitem-rsv (artlist n)
- "Returns from ARTLIST the Retrieval Status Value of the Nth artitem
-\(counting from 1)."
+ "Returns from ARTLIST the Retrieval Status Value of the Nth
+artitem (counting from 1)."
(nnir-artitem-rsv (nnir-artlist-article artlist n)))
;; unused?
@@ -1679,9 +1473,40 @@ The Gnus backend/server information is added."
with-dups)
res))
+(defun nnir-sort-groups-by-server (groups)
+ "sorts a list of groups into an alist keyed by server"
+(if (car groups)
+ (let (value)
+ (dolist (var groups value)
+ (let ((server (gnus-group-server var)))
+ (if (assoc server value)
+ (nconc (cdr (assoc server value)) (list var))
+ (push (cons server (list var)) value))))
+ value)
+ nil))
+
+(defun nnir-get-active (srv)
+ (let ((method (gnus-server-to-method srv))
+ groups)
+ (gnus-request-list method)
+ (with-current-buffer nntp-server-buffer
+ (let ((cur (current-buffer))
+ name)
+ (goto-char (point-min))
+ (unless (string= gnus-ignored-newsgroups "")
+ (delete-matching-lines gnus-ignored-newsgroups))
+ (while (not (eobp))
+ (ignore-errors
+ (push (mm-string-as-unibyte
+ (let ((p (point)))
+ (skip-chars-forward "^ \t\\\\")
+ (setq name (buffer-substring (+ p 1) (- (point) 1)))
+ (gnus-group-full-name name method)))
+ groups))
+ (forward-line))))
+ groups))
;; The end.
(provide 'nnir)
-;; arch-tag: 9b3fecf8-4397-4bbb-bf3c-6ac3cbbc6664
;;; nnir.el ends here
diff --git a/lisp/gnus/nnkiboze.el b/lisp/gnus/nnkiboze.el
deleted file mode 100644
index 17a10e66191..00000000000
--- a/lisp/gnus/nnkiboze.el
+++ /dev/null
@@ -1,391 +0,0 @@
-;;; nnkiboze.el --- select virtual news access for Gnus
-
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; Keywords: news
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; The other access methods (nntp, nnspool, etc) are general news
-;; access methods. This module relies on Gnus and can't be used
-;; separately.
-
-;;; Code:
-
-(require 'nntp)
-(require 'nnheader)
-(require 'gnus)
-(require 'gnus-score)
-(require 'nnoo)
-(require 'mm-util)
-(eval-when-compile (require 'cl))
-
-(nnoo-declare nnkiboze)
-(defvoo nnkiboze-directory (nnheader-concat gnus-directory "kiboze/")
- "nnkiboze will put its files in this directory.")
-
-(defvoo nnkiboze-level 9
- "The maximum level to be searched for articles.")
-
-(defvoo nnkiboze-remove-read-articles t
- "If non-nil, nnkiboze will remove read articles from the kiboze group.")
-
-(defvoo nnkiboze-ephemeral nil
- "If non-nil, don't store any data anywhere.")
-
-(defvoo nnkiboze-scores nil
- "Score rules for generating the nnkiboze group.")
-
-(defvoo nnkiboze-regexp nil
- "Regexp for matching component groups.")
-
-(defvoo nnkiboze-file-coding-system mm-text-coding-system
- "Coding system for nnkiboze files.")
-
-
-
-(defconst nnkiboze-version "nnkiboze 1.0")
-
-(defvoo nnkiboze-current-group nil)
-(defvoo nnkiboze-status-string "")
-
-(defvoo nnkiboze-headers nil)
-
-
-
-;;; Interface functions.
-
-(nnoo-define-basics nnkiboze)
-
-(deffoo nnkiboze-retrieve-headers (articles &optional group server fetch-old)
- (nnkiboze-possibly-change-group group)
- (unless gnus-nov-is-evil
- (if (stringp (car articles))
- 'headers
- (let ((nov (nnkiboze-nov-file-name)))
- (when (file-exists-p nov)
- (save-excursion
- (set-buffer nntp-server-buffer)
- (erase-buffer)
- (let ((nnheader-file-coding-system nnkiboze-file-coding-system))
- (nnheader-insert-file-contents nov))
- (nnheader-nov-delete-outside-range
- (car articles) (car (last articles)))
- 'nov))))))
-
-(deffoo nnkiboze-request-article (article &optional newsgroup server buffer)
- (nnkiboze-possibly-change-group newsgroup)
- (if (not (numberp article))
- ;; This is a real kludge. It might not work at times, but it
- ;; does no harm I think. The only alternative is to offer no
- ;; article fetching by message-id at all.
- (nntp-request-article article newsgroup gnus-nntp-server buffer)
- (let* ((header (gnus-summary-article-header article))
- (xref (mail-header-xref header))
- num group)
- (unless xref
- (error "nnkiboze: No xref"))
- (unless (string-match " \\([^ ]+\\):\\([0-9]+\\)" xref)
- (error "nnkiboze: Malformed xref"))
- (setq num (string-to-number (match-string 2 xref))
- group (match-string 1 xref))
- (or (with-current-buffer buffer
- (or (and gnus-use-cache (gnus-cache-request-article num group))
- (gnus-agent-request-article num group)))
- (gnus-request-article num group buffer)))))
-
-(deffoo nnkiboze-request-scan (&optional group server)
- (nnkiboze-possibly-change-group group)
- (nnkiboze-generate-group (concat "nnkiboze:" group)))
-
-(deffoo nnkiboze-request-group (group &optional server dont-check)
- "Make GROUP the current newsgroup."
- (nnkiboze-possibly-change-group group)
- (if dont-check
- t
- (let ((nov-file (nnkiboze-nov-file-name))
- beg end total)
- (save-excursion
- (set-buffer nntp-server-buffer)
- (erase-buffer)
- (unless (file-exists-p nov-file)
- (nnkiboze-request-scan group))
- (if (not (file-exists-p nov-file))
- (nnheader-report 'nnkiboze "Can't select group %s" group)
- (let ((nnheader-file-coding-system nnkiboze-file-coding-system))
- (nnheader-insert-file-contents nov-file))
- (if (zerop (buffer-size))
- (nnheader-insert "211 0 0 0 %s\n" group)
- (goto-char (point-min))
- (when (looking-at "[0-9]+")
- (setq beg (read (current-buffer))))
- (goto-char (point-max))
- (when (re-search-backward "^[0-9]" nil t)
- (setq end (read (current-buffer))))
- (setq total (count-lines (point-min) (point-max)))
- (nnheader-insert "211 %d %d %d %s\n" total beg end group)))))))
-
-(deffoo nnkiboze-close-group (group &optional server)
- (nnkiboze-possibly-change-group group)
- ;; Remove NOV lines of articles that are marked as read.
- (when (and (file-exists-p (nnkiboze-nov-file-name))
- nnkiboze-remove-read-articles)
- (let ((coding-system-for-write nnkiboze-file-coding-system))
- (with-temp-file (nnkiboze-nov-file-name)
- (let ((cur (current-buffer))
- (nnheader-file-coding-system nnkiboze-file-coding-system))
- (nnheader-insert-file-contents (nnkiboze-nov-file-name))
- (goto-char (point-min))
- (while (not (eobp))
- (if (not (gnus-article-read-p (read cur)))
- (forward-line 1)
- (gnus-delete-line))))))
- (setq nnkiboze-current-group nil)))
-
-(deffoo nnkiboze-open-server (server &optional defs)
- (unless (assq 'nnkiboze-regexp defs)
- (push `(nnkiboze-regexp ,server)
- defs))
- (nnoo-change-server 'nnkiboze server defs))
-
-(deffoo nnkiboze-request-delete-group (group &optional force server)
- (nnkiboze-possibly-change-group group)
- (when force
- (let ((files (nconc
- (nnkiboze-score-file group)
- (list (nnkiboze-nov-file-name)
- (nnkiboze-nov-file-name ".newsrc")))))
- (while files
- (and (file-exists-p (car files))
- (file-writable-p (car files))
- (delete-file (car files)))
- (setq files (cdr files)))))
- (setq nnkiboze-current-group nil)
- t)
-
-(nnoo-define-skeleton nnkiboze)
-
-
-;;; Internal functions.
-
-(defun nnkiboze-possibly-change-group (group)
- (setq nnkiboze-current-group group))
-
-(defun nnkiboze-prefixed-name (group)
- (gnus-group-prefixed-name group '(nnkiboze "")))
-
-;;;###autoload
-(defun nnkiboze-generate-groups ()
- "\"Usage: emacs -batch -l nnkiboze -f nnkiboze-generate-groups\".
-Finds out what articles are to be part of the nnkiboze groups."
- (interactive)
- (let ((mail-sources nil)
- (gnus-use-dribble-file nil)
- (gnus-read-active-file t)
- (gnus-expert-user t))
- (gnus))
- (let* ((gnus-newsrc-alist (gnus-copy-sequence gnus-newsrc-alist))
- (newsrc (cdr gnus-newsrc-alist))
- gnus-newsrc-hashtb info)
- (gnus-make-hashtable-from-newsrc-alist)
- ;; We have copied all the newsrc alist info over to local copies
- ;; so that we can mess all we want with these lists.
- (while (setq info (pop newsrc))
- (when (string-match "nnkiboze" (gnus-info-group info))
- ;; For each kiboze group, we call this function to generate
- ;; it.
- (nnkiboze-generate-group (gnus-info-group info) t))))
- (save-excursion
- (set-buffer gnus-group-buffer)
- (gnus-group-list-groups)))
-
-(defun nnkiboze-score-file (group)
- (list (expand-file-name
- (concat (file-name-as-directory gnus-kill-files-directory)
- (nnheader-translate-file-chars
- (concat (nnkiboze-prefixed-name nnkiboze-current-group)
- "." gnus-score-file-suffix))))))
-
-(defun nnkiboze-generate-group (group &optional inhibit-list-groups)
- (let* ((info (gnus-get-info group))
- (newsrc-file (concat nnkiboze-directory
- (nnheader-translate-file-chars
- (concat group ".newsrc"))))
- (nov-file (concat nnkiboze-directory
- (nnheader-translate-file-chars
- (concat group ".nov"))))
- method nnkiboze-newsrc gname newsrc active
- ginfo lowest glevel orig-info nov-buffer
- ;; Bind various things to nil to make group entry faster.
- (gnus-expert-user t)
- (gnus-large-newsgroup nil)
- (gnus-score-find-score-files-function 'nnkiboze-score-file)
- ;; Use only nnkiboze-score-file!
- (gnus-score-use-all-scores nil)
- (gnus-use-scoring t)
- (gnus-verbose (min gnus-verbose 3))
- gnus-select-group-hook gnus-summary-prepare-hook
- gnus-thread-sort-functions gnus-show-threads
- gnus-visual gnus-suppress-duplicates num-unread)
- (unless info
- (error "No such group: %s" group))
- ;; Load the kiboze newsrc file for this group.
- (when (file-exists-p newsrc-file)
- (load newsrc-file))
- (let ((coding-system-for-write nnkiboze-file-coding-system))
- (gnus-make-directory (file-name-directory nov-file))
- (with-temp-file nov-file
- (mm-disable-multibyte)
- (when (file-exists-p nov-file)
- (insert-file-contents nov-file))
- (setq nov-buffer (current-buffer))
- ;; Go through the active hashtb and add new all groups that match the
- ;; kiboze regexp.
- (mapatoms
- (lambda (group)
- (and (string-match nnkiboze-regexp
- (setq gname (symbol-name group))) ; Match
- (not (assoc gname nnkiboze-newsrc)) ; It isn't registered
- (numberp (car (symbol-value group))) ; It is active
- (or (> nnkiboze-level 7)
- (and (setq glevel
- (gnus-info-level (gnus-get-info gname)))
- (>= nnkiboze-level glevel)))
- (not (string-match "^nnkiboze:" gname)) ; Exclude kibozes
- (push (cons gname (1- (car (symbol-value group))))
- nnkiboze-newsrc)))
- gnus-active-hashtb)
- ;; `newsrc' is set to the list of groups that possibly are
- ;; component groups to this kiboze group. This list has elements
- ;; on the form `(GROUP . NUMBER)', where NUMBER is the highest
- ;; number that has been kibozed in GROUP in this kiboze group.
- (setq newsrc nnkiboze-newsrc)
- (while newsrc
- (if (not (setq active (gnus-active (caar newsrc))))
- ;; This group isn't active after all, so we remove it from
- ;; the list of component groups.
- (setq nnkiboze-newsrc (delq (car newsrc) nnkiboze-newsrc))
- (setq lowest (cdar newsrc))
- ;; Ok, we have a valid component group, so we jump to it.
- (switch-to-buffer gnus-group-buffer)
- (gnus-group-jump-to-group (caar newsrc))
- (gnus-message 3 "nnkiboze: Checking %s..." (caar newsrc))
- (setq ginfo (gnus-get-info (gnus-group-group-name))
- orig-info (gnus-copy-sequence ginfo)
- num-unread (gnus-group-unread (caar newsrc)))
- (unwind-protect
- (progn
- ;; We set all list of article marks to nil. Since we operate
- ;; on copies of the real lists, we can destroy anything we
- ;; want here.
- (when (nth 3 ginfo)
- (setcar (nthcdr 3 ginfo) nil))
- ;; We set the list of read articles to be what we expect for
- ;; this kiboze group -- either nil or `(1 . LOWEST)'.
- (when ginfo
- (setcar (nthcdr 2 ginfo)
- (and (not (= lowest 1)) (cons 1 lowest))))
- (when (and (or (not ginfo)
- (> (length (gnus-list-of-unread-articles
- (car ginfo)))
- 0))
- (progn
- (ignore-errors
- (gnus-group-select-group nil))
- (eq major-mode 'gnus-summary-mode)))
- ;; We are now in the group where we want to be.
- (setq method (gnus-find-method-for-group
- gnus-newsgroup-name))
- (when (eq method gnus-select-method)
- (setq method nil))
- ;; We go through the list of scored articles.
- (while gnus-newsgroup-scored
- (when (> (caar gnus-newsgroup-scored) lowest)
- ;; If it has a good score, then we enter this article
- ;; into the kiboze group.
- (nnkiboze-enter-nov
- nov-buffer
- (gnus-summary-article-header
- (caar gnus-newsgroup-scored))
- gnus-newsgroup-name))
- (setq gnus-newsgroup-scored (cdr gnus-newsgroup-scored)))
- ;; That's it. We exit this group.
- (when (eq major-mode 'gnus-summary-mode)
- (kill-buffer (current-buffer)))))
- ;; Restore the proper info.
- (when ginfo
- (setcdr ginfo (cdr orig-info)))
- (setcar (gnus-group-entry (caar newsrc)) num-unread)))
- (setcdr (car newsrc) (cdr active))
- (gnus-message 3 "nnkiboze: Checking %s...done" (caar newsrc))
- (setq newsrc (cdr newsrc)))))
- ;; We save the kiboze newsrc for this group.
- (gnus-make-directory (file-name-directory newsrc-file))
- (with-temp-file newsrc-file
- (mm-disable-multibyte)
- (insert "(setq nnkiboze-newsrc '")
- (gnus-prin1 nnkiboze-newsrc)
- (insert ")\n"))
- (unless inhibit-list-groups
- (save-excursion
- (set-buffer gnus-group-buffer)
- (gnus-group-list-groups)))
- t))
-
-(defun nnkiboze-enter-nov (buffer header group)
- (save-excursion
- (set-buffer buffer)
- (goto-char (point-max))
- (let ((prefix (gnus-group-real-prefix group))
- (oheader (copy-sequence header))
- article)
- (if (zerop (forward-line -1))
- (progn
- (setq article (1+ (read (current-buffer))))
- (forward-line 1))
- (setq article 1))
- (mail-header-set-number oheader article)
- (with-temp-buffer
- (insert (or (mail-header-xref oheader) ""))
- (goto-char (point-min))
- (if (re-search-forward " [^ ]+:[0-9]+" nil t)
- (goto-char (match-beginning 0))
- (or (eobp) (forward-char 1)))
- ;; The first Xref has to be the group this article
- ;; really came for - this is the article nnkiboze
- ;; will request when it is asked for the article.
- (insert " " group ":"
- (int-to-string (mail-header-number header)) " ")
- (while (re-search-forward " [^ ]+:[0-9]+" nil t)
- (goto-char (1+ (match-beginning 0)))
- (insert prefix))
- (mail-header-set-xref oheader (buffer-string)))
- (nnheader-insert-nov oheader))))
-
-(defun nnkiboze-nov-file-name (&optional suffix)
- (concat (file-name-as-directory nnkiboze-directory)
- (nnheader-translate-file-chars
- (concat (nnkiboze-prefixed-name nnkiboze-current-group)
- (or suffix ".nov")))))
-
-(provide 'nnkiboze)
-
-;; arch-tag: 66068271-bdc9-4801-bcde-779702e73a05
-;;; nnkiboze.el ends here
diff --git a/lisp/gnus/nnlistserv.el b/lisp/gnus/nnlistserv.el
deleted file mode 100644
index 3e53001cec0..00000000000
--- a/lisp/gnus/nnlistserv.el
+++ /dev/null
@@ -1,152 +0,0 @@
-;;; nnlistserv.el --- retrieving articles via web mailing list archives
-
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; Keywords: news, mail
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-
-(require 'nnoo)
-(require 'mm-url)
-(require 'nnweb)
-
-(nnoo-declare nnlistserv
- nnweb)
-
-(defvoo nnlistserv-directory (nnheader-concat gnus-directory "nnlistserv/")
- "Where nnlistserv will save its files."
- nnweb-directory)
-
-(defvoo nnlistserv-name 'kk
- "What search engine type is being used."
- nnweb-type)
-
-(defvoo nnlistserv-type-definition
- '((kk
- (article . nnlistserv-kk-wash-article)
- (map . nnlistserv-kk-create-mapping)
- (search . nnlistserv-kk-search)
- (address . "http://www.itk.ntnu.no/ansatte/Andresen_Trond/kk-f/%s/")
- (pages "fra160396" "fra160796" "fra061196" "fra160197"
- "fra090997" "fra040797" "fra130397" "nye")
- (index . "date.html")
- (identifier . nnlistserv-kk-identity)))
- "Type-definition alist."
- nnweb-type-definition)
-
-(defvoo nnlistserv-search nil
- "Search string to feed to DejaNews."
- nnweb-search)
-
-(defvoo nnlistserv-ephemeral-p nil
- "Whether this nnlistserv server is ephemeral."
- nnweb-ephemeral-p)
-
-;;; Internal variables
-
-;;; Interface functions
-
-(nnoo-define-basics nnlistserv)
-
-(nnoo-import nnlistserv
- (nnweb))
-
-;;; Internal functions
-
-;;;
-;;; KK functions.
-;;;
-
-(defun nnlistserv-kk-create-mapping ()
- "Perform the search and create a number-to-url alist."
- (save-excursion
- (set-buffer nnweb-buffer)
- (let ((case-fold-search t)
- (active (or (cadr (assoc nnweb-group nnweb-group-alist))
- (cons 1 0)))
- (pages (nnweb-definition 'pages))
- map url page subject from )
- (while (setq page (pop pages))
- (erase-buffer)
- (when (funcall (nnweb-definition 'search) page)
- ;; Go through all the article hits on this page.
- (goto-char (point-min))
- (mm-url-decode-entities)
- (goto-char (point-min))
- (while (re-search-forward "^<li> *<a href=\"\\([^\"]+\\)\"><b>\\([^\\>]+\\)</b></a> *<[^>]+><i>\\([^>]+\\)<" nil t)
- (setq url (match-string 1)
- subject (match-string 2)
- from (match-string 3))
- (setq url (concat (format (nnweb-definition 'address) page) url))
- (unless (nnweb-get-hashtb url)
- (push
- (list
- (incf (cdr active))
- (make-full-mail-header
- (cdr active) subject from ""
- (concat "<" (nnweb-identifier url) "@kk>")
- nil 0 0 url))
- map)
- (nnweb-set-hashtb (cadar map) (car map))
- (nnheader-message 5 "%s %s %s" (cdr active) (point) pages)))))
- ;; Return the articles in the right order.
- (setq nnweb-articles
- (sort (nconc nnweb-articles map) 'car-less-than-car)))))
-
-(defun nnlistserv-kk-wash-article ()
- (let ((case-fold-search t)
- (headers '(sent name email subject id))
- sent name email subject id)
- (mm-url-decode-entities)
- (while headers
- (goto-char (point-min))
- (re-search-forward (format "<!-- %s=\"\\([^\"]+\\)" (car headers)) nil t)
- (set (pop headers) (match-string 1)))
- (goto-char (point-min))
- (search-forward "<!-- body" nil t)
- (delete-region (point-min) (progn (forward-line 1) (point)))
- (goto-char (point-max))
- (search-backward "<!-- body" nil t)
- (delete-region (point-max) (progn (beginning-of-line) (point)))
- (mm-url-remove-markup)
- (goto-char (point-min))
- (insert (format "From: %s <%s>\n" name email)
- (format "Subject: %s\n" subject)
- (format "Message-ID: %s\n" id)
- (format "Date: %s\n\n" sent))))
-
-(defun nnlistserv-kk-search (search)
- (mm-url-insert
- (concat (format (nnweb-definition 'address) search)
- (nnweb-definition 'index)))
- t)
-
-(defun nnlistserv-kk-identity (url)
- "Return an unique identifier based on URL."
- url)
-
-(provide 'nnlistserv)
-
-;; arch-tag: 7705176f-d332-4a5e-a520-d0d319445617
-;;; nnlistserv.el ends here
diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el
index 58c69b8cc35..06b464c0b29 100644
--- a/lisp/gnus/nnmail.el
+++ b/lisp/gnus/nnmail.el
@@ -1,7 +1,8 @@
;;; nnmail.el --- mail support functions for the Gnus mail backends
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news, mail
@@ -25,7 +26,7 @@
;;; Code:
-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
@@ -104,7 +105,9 @@ mail belongs in that group.
The last element should always have \"\" as the regexp.
-This variable can also have a function as its value."
+This variable can also have a function as its value, and it can
+also have a fancy split method as its value. See
+`nnmail-split-fancy' for an explanation of that syntax."
:group 'nnmail-split
:type '(choice (repeat :tag "Alist" (group (string :tag "Name")
(choice regexp function)))
@@ -265,7 +268,7 @@ It scans low-level sorted spools even when not required."
:type 'function)
(defcustom nnmail-crosspost-link-function
- (if (string-match "windows-nt\\|emx" (symbol-name system-type))
+ (if (string-match "windows-nt" (symbol-name system-type))
'copy-file
'add-name-to-file)
"*Function called to create a copy of a file.
@@ -614,6 +617,7 @@ using different case (i.e. mailing-list@domain vs Mailing-List@Domain)."
(defvar nnmail-split-tracing nil)
(defvar nnmail-split-trace nil)
+(defvar nnmail-inhibit-default-split-group nil)
@@ -674,8 +678,7 @@ using different case (i.e. mailing-list@domain vs Mailing-List@Domain)."
"Returns an assoc of group names and active ranges.
nn*-request-list should have been called before calling this function."
;; Go through all groups from the active list.
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(nnmail-parse-active)))
(defun nnmail-parse-active ()
@@ -963,7 +966,7 @@ If SOURCE is a directory spec, try to return the group name component."
(goto-char end)))
count))
-(defun nnmail-process-mmdf-mail-format (func artnum-func)
+(defun nnmail-process-mmdf-mail-format (func artnum-func &optional junk-func)
(let ((delim "^\^A\^A\^A\^A$")
(case-fold-search t)
(count 0)
@@ -1011,7 +1014,7 @@ If SOURCE is a directory spec, try to return the group name component."
(narrow-to-region start (point))
(goto-char (point-min))
(incf count)
- (nnmail-check-duplication message-id func artnum-func)
+ (nnmail-check-duplication message-id func artnum-func junk-func)
(setq end (point-max))))
(goto-char end)
(forward-line 2)))
@@ -1056,9 +1059,11 @@ If SOURCE is a directory spec, try to return the group name component."
"Non-nil means group names are not encoded.")
(defun nnmail-split-incoming (incoming func &optional exit-func
- group artnum-func)
+ group artnum-func junk-func)
"Go through the entire INCOMING file and pick out each individual mail.
-FUNC will be called with the buffer narrowed to each mail."
+FUNC will be called with the buffer narrowed to each mail.
+INCOMING can also be a buffer object. In that case, the mail
+will be copied over from that buffer."
(let ( ;; If this is a group-specific split, we bind the split
;; methods to just this group.
(nnmail-split-methods (if (and group
@@ -1066,12 +1071,13 @@ FUNC will be called with the buffer narrowed to each mail."
(list (list group ""))
nnmail-split-methods))
(nnmail-group-names-not-encoded-p t))
- (save-excursion
- ;; Insert the incoming file.
- (set-buffer (get-buffer-create nnmail-article-buffer))
+ ;; Insert the incoming file.
+ (with-current-buffer (get-buffer-create nnmail-article-buffer)
(erase-buffer)
- (let ((coding-system-for-read nnmail-incoming-coding-system))
- (mm-insert-file-contents incoming))
+ (if (bufferp incoming)
+ (insert-buffer-substring incoming)
+ (let ((coding-system-for-read nnmail-incoming-coding-system))
+ (mm-insert-file-contents incoming)))
(prog1
(if (zerop (buffer-size))
0
@@ -1084,7 +1090,8 @@ FUNC will be called with the buffer narrowed to each mail."
(looking-at "BABYL OPTIONS:"))
(nnmail-process-babyl-mail-format func artnum-func))
((looking-at "\^A\^A\^A\^A")
- (nnmail-process-mmdf-mail-format func artnum-func))
+ (nnmail-process-mmdf-mail-format
+ func artnum-func junk-func))
((looking-at "Return-Path:")
(nnmail-process-maildir-mail-format func artnum-func))
(t
@@ -1093,22 +1100,22 @@ FUNC will be called with the buffer narrowed to each mail."
(funcall exit-func))
(kill-buffer (current-buffer))))))
-(defun nnmail-article-group (func &optional trace)
+(defun nnmail-article-group (func &optional trace junk-func)
"Look at the headers and return an alist of groups that match.
FUNC will be called with the group name to determine the article number."
(let ((methods (or nnmail-split-methods '(("bogus" ""))))
(obuf (current-buffer))
group-art method grp)
(if (and (sequencep methods)
- (= (length methods) 1))
+ (= (length methods) 1)
+ (not nnmail-inhibit-default-split-group))
;; If there is only just one group to put everything in, we
;; just return a list with just this one method in.
(setq group-art
(list (cons (caar methods) (funcall func (caar methods)))))
;; We do actual comparison.
- (save-excursion
- ;; Copy the article into the work buffer.
- (set-buffer nntp-server-buffer)
+ ;; Copy the article into the work buffer.
+ (with-current-buffer nntp-server-buffer
(erase-buffer)
(insert-buffer-substring obuf)
;; Narrow to headers.
@@ -1141,27 +1148,41 @@ FUNC will be called with the group name to determine the article number."
(run-hooks 'nnmail-split-hook)
(when (setq nnmail-split-tracing trace)
(setq nnmail-split-trace nil))
- (if (and (symbolp nnmail-split-methods)
- (fboundp nnmail-split-methods))
- (let ((split
- (condition-case error-info
- ;; `nnmail-split-methods' is a function, so we
- ;; just call this function here and use the
- ;; result.
- (or (funcall nnmail-split-methods)
- '("bogus"))
- (error
- (nnheader-message
- 5 "Error in `nnmail-split-methods'; using `bogus' mail group: %S" error-info)
- (sit-for 1)
- '("bogus")))))
+ (if (or (and (symbolp nnmail-split-methods)
+ (fboundp nnmail-split-methods))
+ (and (listp nnmail-split-methods)
+ ;; Not a regular split method, so it has to be a
+ ;; fancy one.
+ (not (let ((top-element (car-safe nnmail-split-methods)))
+ (and (= 2 (length top-element))
+ (stringp (nth 0 top-element))
+ (stringp (nth 1 top-element)))))))
+ (let* ((method-function
+ (if (and (symbolp nnmail-split-methods)
+ (fboundp nnmail-split-methods))
+ nnmail-split-methods
+ 'nnmail-split-fancy))
+ (split
+ (condition-case error-info
+ ;; `nnmail-split-methods' is a function, so we
+ ;; just call this function here and use the
+ ;; result.
+ (or (funcall method-function)
+ (and (not nnmail-inhibit-default-split-group)
+ '("bogus")))
+ (error
+ (nnheader-message
+ 5 "Error in `nnmail-split-methods'; using `bogus' mail group: %S" error-info)
+ (sit-for 1)
+ '("bogus")))))
(setq split (mm-delete-duplicates split))
;; The article may be "cross-posted" to `junk'. What
;; to do? Just remove the `junk' spec. Don't really
;; see anything else to do...
- (let (elem)
- (while (setq elem (car (memq 'junk split)))
- (setq split (delq elem split))))
+ (when (and (memq 'junk split)
+ junk-func)
+ (funcall junk-func 'junk))
+ (setq split (delq 'junk split))
(when split
(setq group-art
(mapcar
@@ -1194,12 +1215,14 @@ FUNC will be called with the group name to determine the article number."
group-art))
;; This is the final group, which is used as a
;; catch-all.
- (unless group-art
+ (when (and (not group-art)
+ (not nnmail-inhibit-default-split-group))
(setq group-art
(list (cons (car method)
(funcall func (car method))))))))
;; Fall back on "bogus" if all else fails.
- (unless group-art
+ (when (and (not group-art)
+ (not nnmail-inhibit-default-split-group))
(setq group-art (list (cons "bogus" (funcall func "bogus"))))))
;; Produce a trace if non-empty.
(when (and trace nnmail-split-trace)
@@ -1325,7 +1348,7 @@ Eudora has a broken References line, but an OK In-Reply-To."
;;; Utility functions
(declare-function gnus-activate-group "gnus-start"
- (group &optional scan dont-check method))
+ (group &optional scan dont-check method dont-sub-check))
(defun nnmail-do-request-post (accept-func &optional server)
"Utility function to directly post a message to an nnmail-derived group.
@@ -1572,10 +1595,9 @@ See the documentation for the variable `nnmail-split-fancy' for details."
(and nnmail-cache-buffer
(buffer-name nnmail-cache-buffer)))
() ; The buffer is open.
- (save-excursion
- (set-buffer
+ (with-current-buffer
(setq nnmail-cache-buffer
- (get-buffer-create " *nnmail message-id cache*")))
+ (get-buffer-create " *nnmail message-id cache*"))
(gnus-add-buffer)
(when (file-exists-p nnmail-message-id-cache-file)
(nnheader-insert-file-contents nnmail-message-id-cache-file))
@@ -1587,8 +1609,7 @@ See the documentation for the variable `nnmail-split-fancy' for details."
nnmail-treat-duplicates
(buffer-name nnmail-cache-buffer)
(buffer-modified-p nnmail-cache-buffer))
- (save-excursion
- (set-buffer nnmail-cache-buffer)
+ (with-current-buffer nnmail-cache-buffer
;; Weed out the excess number of Message-IDs.
(goto-char (point-max))
(when (search-backward "\n" nil t nnmail-message-id-cache-length)
@@ -1605,10 +1626,6 @@ See the documentation for the variable `nnmail-split-fancy' for details."
(setq nnmail-cache-buffer nil)
(gnus-kill-buffer (current-buffer)))))
-;; Compiler directives.
-(defvar group)
-(defvar group-art-list)
-(defvar group-art)
(defun nnmail-cache-insert (id grp &optional subject sender)
(when (stringp id)
;; this will handle cases like `B r' where the group is nil
@@ -1623,8 +1640,7 @@ See the documentation for the variable `nnmail-split-fancy' for details."
;; pass the first (of possibly >1) group which matches. -Josh
(unless (gnus-buffer-live-p nnmail-cache-buffer)
(nnmail-cache-open))
- (save-excursion
- (set-buffer nnmail-cache-buffer)
+ (with-current-buffer nnmail-cache-buffer
(goto-char (point-max))
(if (and grp (not (string= "" grp))
(gnus-methods-equal-p gnus-command-method
@@ -1657,8 +1673,7 @@ See the documentation for the variable `nnmail-split-fancy' for details."
;; cache.
(defun nnmail-cache-fetch-group (id)
(when (and nnmail-treat-duplicates nnmail-cache-buffer)
- (save-excursion
- (set-buffer nnmail-cache-buffer)
+ (with-current-buffer nnmail-cache-buffer
(goto-char (point-max))
(when (search-backward id nil t)
(beginning-of-line)
@@ -1702,8 +1717,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(defun nnmail-cache-id-exists-p (id)
(when nnmail-treat-duplicates
- (save-excursion
- (set-buffer nnmail-cache-buffer)
+ (with-current-buffer nnmail-cache-buffer
(goto-char (point-max))
(search-backward id nil t))))
@@ -1713,7 +1727,8 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(message-narrow-to-head)
(message-fetch-field header))))
-(defun nnmail-check-duplication (message-id func artnum-func)
+(defun nnmail-check-duplication (message-id func artnum-func
+ &optional junk-func)
(run-hooks 'nnmail-prepare-incoming-message-hook)
;; If this is a duplicate message, then we do not save it.
(let* ((duplication (nnmail-cache-id-exists-p message-id))
@@ -1738,7 +1753,8 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(cond
((not duplication)
(funcall func (setq group-art
- (nreverse (nnmail-article-group artnum-func))))
+ (nreverse (nnmail-article-group
+ artnum-func nil junk-func))))
(nnmail-cache-insert message-id (caar group-art)))
((eq action 'delete)
(setq group-art nil))
@@ -1823,8 +1839,6 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
;; The we go through all the existing mail source specification
;; and fetch the mail from each.
(while (setq source (pop fetching-sources))
- (nnheader-message 4 "%s: Reading incoming mail from %s..."
- method (car source))
(when (setq new
(mail-source-fetch
source
@@ -1842,8 +1856,9 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(incf i)))
;; If we did indeed read any incoming spools, we save all info.
(if (zerop total)
- (nnheader-message 4 "%s: Reading incoming mail (no new mail)...done"
- method (car source))
+ (when mail-source-plugged
+ (nnheader-message 4 "%s: Reading incoming mail (no new mail)...done"
+ method (car source)))
(nnmail-save-active
(nnmail-get-value "%s-group-alist" method)
(nnmail-get-value "%s-active-file" method))
@@ -1858,9 +1873,12 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(run-hooks 'nnmail-post-get-new-mail-hook))))
(defun nnmail-expired-article-p (group time force &optional inhibit)
- "Say whether an article that is TIME old in GROUP should be expired."
+ "Say whether an article that is TIME old in GROUP should be expired.
+If TIME is nil, then return the cutoff time for oldness instead."
(if force
- t
+ (if (null time)
+ (current-time)
+ t)
(let ((days (or (and nnmail-expiry-wait-function
(funcall nnmail-expiry-wait-function group))
nnmail-expiry-wait)))
@@ -1871,14 +1889,18 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
nil)
((eq days 'immediate)
;; We expire all articles on sight.
- t)
+ (if (null time)
+ (current-time)
+ t))
((equal time '(0 0))
;; This is an ange-ftp group, and we don't have any dates.
nil)
((numberp days)
(setq days (days-to-time days))
;; Compare the time with the current time.
- (ignore-errors (time-less-p days (time-since time))))))))
+ (if (null time)
+ (time-subtract (current-time) days)
+ (ignore-errors (time-less-p days (time-since time)))))))))
(declare-function gnus-group-mark-article-read "gnus-group" (group article))
@@ -1893,8 +1915,9 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(unless (eq target 'delete)
(when (or (gnus-request-group target)
(gnus-request-create-group target))
- (let ((group-art (gnus-request-accept-article target nil nil t)))
- (when (consp group-art)
+ (let ((group-art (gnus-request-accept-article target nil t t)))
+ (when (and (consp group-art)
+ (cdr group-art))
(gnus-group-mark-article-read target (cdr group-art))))))))
(defun nnmail-fancy-expiry-target (group)
@@ -2052,5 +2075,4 @@ Doesn't change point."
(provide 'nnmail)
-;; arch-tag: fe8f671a-50db-428a-bb5d-f00462f72ed7
;;; nnmail.el ends here
diff --git a/lisp/gnus/nnmaildir.el b/lisp/gnus/nnmaildir.el
index 628b4c5d2a2..65f33411297 100644
--- a/lisp/gnus/nnmaildir.el
+++ b/lisp/gnus/nnmaildir.el
@@ -59,7 +59,7 @@
)
]
-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
@@ -208,20 +208,16 @@ by nnmaildir-request-article.")
(eval param))
(defmacro nnmaildir--with-nntp-buffer (&rest body)
- `(save-excursion
- (set-buffer nntp-server-buffer)
+ `(with-current-buffer nntp-server-buffer
,@body))
(defmacro nnmaildir--with-work-buffer (&rest body)
- `(save-excursion
- (set-buffer (get-buffer-create " *nnmaildir work*"))
+ `(with-current-buffer (get-buffer-create " *nnmaildir work*")
,@body))
(defmacro nnmaildir--with-nov-buffer (&rest body)
- `(save-excursion
- (set-buffer (get-buffer-create " *nnmaildir nov*"))
+ `(with-current-buffer (get-buffer-create " *nnmaildir nov*")
,@body))
(defmacro nnmaildir--with-move-buffer (&rest body)
- `(save-excursion
- (set-buffer (get-buffer-create " *nnmaildir move*"))
+ `(with-current-buffer (get-buffer-create " *nnmaildir move*")
,@body))
(defmacro nnmaildir--subdir (dir subdir)
@@ -920,7 +916,7 @@ by nnmaildir-request-article.")
"\n")))))
'group)
-(defun nnmaildir-request-update-info (gname info &optional server)
+(defun nnmaildir-request-marks (gname info &optional server)
(let ((group (nnmaildir--prepare server gname))
pgname flist always-marks never-marks old-marks dotfile num dir
markdirs marks mark ranges markdir article read end new-marks ls
@@ -987,7 +983,7 @@ by nnmaildir-request-article.")
(setf (nnmaildir--grp-mmth group) new-mmth)
info)))
-(defun nnmaildir-request-group (gname &optional server fast)
+(defun nnmaildir-request-group (gname &optional server fast info)
(let ((group (nnmaildir--prepare server gname))
deactivate-mark)
(catch 'return
@@ -1249,8 +1245,7 @@ by nnmaildir-request-article.")
(setf (nnmaildir--srv-error nnmaildir--cur-server)
"Article has expired")
(throw 'return nil))
- (save-excursion
- (set-buffer (or to-buffer nntp-server-buffer))
+ (with-current-buffer (or to-buffer nntp-server-buffer)
(erase-buffer)
(nnheader-insert-file-contents nnmaildir-article-file-name))
(cons gname num-msgid))))
@@ -1289,8 +1284,7 @@ by nnmaildir-request-article.")
(setf (nnmaildir--srv-error nnmaildir--cur-server)
(concat "File exists: " tmpfile))
(throw 'return nil))
- (save-excursion
- (set-buffer buffer)
+ (with-current-buffer buffer
(gmm-write-region (point-min) (point-max) tmpfile nil 'no-message nil
'excl))
(unix-sync) ;; no fsync :(
@@ -1596,7 +1590,7 @@ by nnmaildir-request-article.")
(nnmaildir--nlist-iterate nlist ranges
(cond ((eq 'del (cadr action)) del-action)
((eq 'add (cadr action)) add-action)
- (t set-action))))
+ ((eq 'set (cadr action)) set-action))))
nil)))
(defun nnmaildir-close-group (gname &optional server)
@@ -1667,5 +1661,4 @@ by nnmaildir-request-article.")
;; fill-column: 77
;; End:
-;; arch-tag: 0c4e44cd-dfde-4040-888e-5597ec771849
;;; nnmaildir.el ends here
diff --git a/lisp/gnus/nnmairix.el b/lisp/gnus/nnmairix.el
index e39149b996c..7ea2437b956 100644
--- a/lisp/gnus/nnmairix.el
+++ b/lisp/gnus/nnmairix.el
@@ -188,17 +188,17 @@
(defun nnmairix-summary-mode-hook ()
"Nnmairix summary mode keymap."
(define-key gnus-summary-mode-map
- (kbd "$ t") 'nnmairix-search-thread-this-article)
+ (kbd "G G t") 'nnmairix-search-thread-this-article)
(define-key gnus-summary-mode-map
- (kbd "$ f") 'nnmairix-search-from-this-article)
+ (kbd "G G f") 'nnmairix-search-from-this-article)
(define-key gnus-summary-mode-map
- (kbd "$ m") 'nnmairix-widget-search-from-this-article)
+ (kbd "G G m") 'nnmairix-widget-search-from-this-article)
(define-key gnus-summary-mode-map
- (kbd "$ g") 'nnmairix-create-search-group-from-message)
+ (kbd "G G g") 'nnmairix-create-search-group-from-message)
(define-key gnus-summary-mode-map
- (kbd "$ o") 'nnmairix-goto-original-article)
+ (kbd "G G o") 'nnmairix-goto-original-article)
(define-key gnus-summary-mode-map
- (kbd "$ u") 'nnmairix-remove-tick-mark-original-article))
+ (kbd "G G u") 'nnmairix-remove-tick-mark-original-article))
(add-hook 'gnus-group-mode-hook 'nnmairix-group-mode-hook)
(add-hook 'gnus-summary-mode-hook 'nnmairix-summary-mode-hook)
@@ -424,7 +424,7 @@ Other back ends might or might not work.")
(setq nnmairix-current-server server)
(nnoo-change-server 'nnmairix server definitions))
-(deffoo nnmairix-request-group (group &optional server fast)
+(deffoo nnmairix-request-group (group &optional server fast info)
;; Call mairix and request group on back end server
(when server (nnmairix-open-server server))
(let* ((qualgroup (if server
@@ -445,8 +445,7 @@ Other back ends might or might not work.")
nil)
((not query)
;; No query -> return empty group
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(erase-buffer)
(insert (concat "211 0 1 0 " group))
t))
@@ -501,9 +500,9 @@ Other back ends might or might not work.")
(nnmairix-request-group-with-article-number-correction
folder qualgroup)))
((and (= rval 1)
- (save-excursion (set-buffer nnmairix-mairix-output-buffer)
- (goto-char (point-min))
- (looking-at "^Matched 0 messages")))
+ (with-current-buffer nnmairix-mairix-output-buffer
+ (goto-char (point-min))
+ (looking-at "^Matched 0 messages")))
;; No messages found -> return empty group
(nnheader-message 5 "Mairix: No matches found.")
(set-buffer nntp-server-buffer)
@@ -556,16 +555,15 @@ Other back ends might or might not work.")
(mapcar
(lambda (arg) (- arg numcorr))
articles)))
- (setq rval
+ (setq rval
(if (eq nnmairix-backend 'nnimap)
(let ((gnus-nov-is-evil t))
(nnmairix-call-backend
"retrieve-headers" articles folder nnmairix-backend-server fetch-old))
(nnmairix-call-backend
"retrieve-headers" articles folder nnmairix-backend-server fetch-old)))
- (when (eq rval 'nov)
- (nnmairix-replace-group-and-numbers articles folder group numcorr)
- rval)))
+ (nnmairix-replace-group-and-numbers articles folder group numcorr rval)
+ rval))
(deffoo nnmairix-request-article (article &optional group server to-buffer)
(when server (nnmairix-open-server server))
@@ -584,8 +582,7 @@ Other back ends might or might not work.")
(when server (nnmairix-open-server server))
(if (nnmairix-call-backend "request-list" nnmairix-backend-server)
(let (cpoint cur qualgroup folder)
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(goto-char (point-min))
(setq cpoint (point))
(while (re-search-forward nnmairix-group-regexp (point-max) t)
@@ -699,8 +696,7 @@ Other back ends might or might not work.")
(when (or (eq nnmairix-propagate-marks-upon-close t)
(and (eq nnmairix-propagate-marks-upon-close 'ask)
(y-or-n-p "Propagate marks to original articles? ")))
- (save-excursion
- (set-buffer gnus-group-buffer)
+ (with-current-buffer gnus-group-buffer
(nnmairix-propagate-marks)
;; update mairix group
(gnus-group-jump-to-group qualgroup)
@@ -708,7 +704,7 @@ Other back ends might or might not work.")
(autoload 'nnimap-request-update-info-internal "nnimap")
-(deffoo nnmairix-request-update-info (group info &optional server)
+(deffoo nnmairix-request-marks (group info &optional server)
;; propagate info from underlying IMAP folder to nnmairix group
;; This is currently experimental and must be explicitly activated
;; with nnmairix-propagate-marks-to-nnmairix-group
@@ -852,8 +848,8 @@ called interactively, user will be asked for parameters."
All necessary information will be queried from the user."
(interactive)
(let* ((name (read-string "Name of the mairix server: "))
- (server (completing-read "Back end server (TAB for completion): "
- (nnmairix-get-valid-servers) nil 1))
+ (server (gnus-completing-read "Back end server"
+ (nnmairix-get-valid-servers) t))
(mairix (read-string "Command to call mairix: " "mairix"))
(defaultgroup (read-string "Default search group: "))
(backend (symbol-name (car (gnus-server-to-method server))))
@@ -998,8 +994,7 @@ with m:msgid of the current article and enabled threads."
(if server
(if (gnus-buffer-live-p gnus-article-buffer)
(progn
- (save-excursion
- (set-buffer gnus-article-buffer)
+ (with-current-buffer gnus-article-buffer
(gnus-summary-toggle-header 1)
(setq mid (message-fetch-field "Message-ID")))
(while (string-match "[<>]" mid)
@@ -1021,8 +1016,7 @@ f:current_from."
(if server
(if (gnus-buffer-live-p gnus-article-buffer)
(progn
- (save-excursion
- (set-buffer gnus-article-buffer)
+ (with-current-buffer gnus-article-buffer
(gnus-summary-toggle-header 1)
(setq from (cadr (gnus-extract-address-components
(gnus-fetch-field "From"))))
@@ -1046,8 +1040,7 @@ before deleting a group on the back end. SERVER specifies nnmairix server."
(when (nnmairix-call-backend
"request-list" nnmairix-backend-server)
(let (cur qualgroup folder)
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(goto-char (point-min))
(while (re-search-forward nnmairix-group-regexp (point-max) t)
(setq cur (match-string 0)
@@ -1152,8 +1145,7 @@ nnmairix server. Only marks from current session will be set."
(push (list (car ogroup) (list (list number) (nth 1 mid-marks) (nth 2 mid-marks)))
number-cache)))))
;; now we set the marks
- (save-excursion
- (set-buffer gnus-group-buffer)
+ (with-current-buffer gnus-group-buffer
(nnheader-message 5 "nnmairix: Propagating marks...")
(dolist (cur number-cache)
(setq method (gnus-find-method-for-group (car cur)))
@@ -1173,7 +1165,7 @@ nnmairix server. Only marks from current session will be set."
If SKIPDEFAULT is t, the default search group will not be
updated.
If UPDATEDB is t, database for SERVERNAME will be updated first."
- (interactive (list (completing-read "Update groups on server: "
+ (interactive (list (gnus-completing-read "Update groups on server"
(nnmairix-get-nnmairix-servers))))
(save-excursion
(when (string-match ".*:\\(.*\\)" servername)
@@ -1272,9 +1264,8 @@ Marks propagation has to be enabled for this to work."
"Call mairix binary with COMMAND, using FOLDER and SEARCHQUERY.
If THREADS is non-nil, enable full threads."
(let ((args (cons (car command) '(nil t nil))))
- (save-excursion
- (set-buffer
- (get-buffer-create nnmairix-mairix-output-buffer))
+ (with-current-buffer
+ (get-buffer-create nnmairix-mairix-output-buffer)
(erase-buffer)
(when (> (length command) 1)
(setq args (append args (cdr command))))
@@ -1291,9 +1282,8 @@ If THREADS is non-nil, enable full threads."
(defun nnmairix-call-mairix-binary-raw (command query)
"Call mairix binary with COMMAND and QUERY in raw mode."
(let ((args (cons (car command) '(nil t nil))))
- (save-excursion
- (set-buffer
- (get-buffer-create nnmairix-mairix-output-buffer))
+ (with-current-buffer
+ (get-buffer-create nnmairix-mairix-output-buffer)
(erase-buffer)
(when (> (length command) 1)
(setq args (append args (cdr command))))
@@ -1312,7 +1302,7 @@ Otherwise, ask user for server."
(while
(equal '("")
(setq nnmairix-last-server
- (list (completing-read "Server: " openedserver nil 1
+ (list (gnus-completing-read "Server" openedserver t
(or nnmairix-last-server
"nnmairix:"))))))
nnmairix-last-server)
@@ -1367,7 +1357,7 @@ If ALL is t, return also the unopened/failed ones."
(not (member (car server) gnus-ephemeral-servers))
(not (member (gnus-method-to-server (car server)) occ)))
(push
- (list mserver)
+ mserver
openedserver)))
openedserver))
@@ -1422,44 +1412,55 @@ nnmairix with nnml backends."
(setq cur lastplusone))
(setq lastplusone (1+ cur)))))
-(defun nnmairix-replace-group-and-numbers (articles backendgroup mairixgroup numc)
+(defun nnmairix-replace-group-and-numbers (articles backendgroup mairixgroup numc type)
"Replace folder names in Xref header and correct article numbers.
Do this for all ARTICLES on BACKENDGROUP. Replace using
-MAIRIXGROUP. NUMC contains values for article number correction."
- (let ((buf (get-buffer-create " *nnmairix buffer*"))
- (corr (not (zerop numc)))
- (name (buffer-name nntp-server-buffer))
- header cur xref)
- (save-excursion
- (set-buffer buf)
- (erase-buffer)
- (set-buffer nntp-server-buffer)
- (goto-char (point-min))
- (nnheader-message 7 "nnmairix: Rewriting headers...")
- (mapc
- (lambda (article)
- (when (or (looking-at (number-to-string article))
- (nnheader-find-nov-line article))
- (setq cur (nnheader-parse-nov))
- (when corr
- (setq article (+ (mail-header-number cur) numc))
- (mail-header-set-number cur article))
- (setq xref (mail-header-xref cur))
- (when (and (stringp xref)
- (string-match (format "[ \t]%s:[0-9]+" backendgroup) xref))
- (setq xref (replace-match (format " %s:%d" mairixgroup article) t nil xref))
- (mail-header-set-xref cur xref))
- (set-buffer buf)
- (nnheader-insert-nov cur)
- (set-buffer nntp-server-buffer)
- (when (not (eobp))
- (forward-line 1))))
- articles)
- (nnheader-message 7 "nnmairix: Rewriting headers... done")
- (kill-buffer nntp-server-buffer)
- (set-buffer buf)
- (rename-buffer name)
- (setq nntp-server-buffer buf))))
+MAIRIXGROUP. NUMC contains values for article number correction.
+TYPE is either 'nov or 'headers."
+ (nnheader-message 7 "nnmairix: Rewriting headers...")
+ (cond
+ ((eq type 'nov)
+ (let ((buf (get-buffer-create " *nnmairix buffer*"))
+ (corr (not (zerop numc)))
+ (name (buffer-name nntp-server-buffer))
+ header cur xref)
+ (with-current-buffer buf
+ (erase-buffer)
+ (set-buffer nntp-server-buffer)
+ (goto-char (point-min))
+ (mapc
+ (lambda (article)
+ (when (or (looking-at (number-to-string article))
+ (nnheader-find-nov-line article))
+ (setq cur (nnheader-parse-nov))
+ (when corr
+ (setq article (+ (mail-header-number cur) numc))
+ (mail-header-set-number cur article))
+ (setq xref (mail-header-xref cur))
+ (when (and (stringp xref)
+ (string-match (format "[ \t]%s:[0-9]+" backendgroup) xref))
+ (setq xref (replace-match (format " %s:%d" mairixgroup article) t nil xref))
+ (mail-header-set-xref cur xref))
+ (set-buffer buf)
+ (nnheader-insert-nov cur)
+ (set-buffer nntp-server-buffer)
+ (when (not (eobp))
+ (forward-line 1))))
+ articles)
+ (kill-buffer nntp-server-buffer)
+ (set-buffer buf)
+ (rename-buffer name)
+ (setq nntp-server-buffer buf))))
+ ((and (eq type 'headers)
+ (not (zerop numc)))
+ (with-current-buffer nntp-server-buffer
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward "^[23][0-9]+ \\([0-9]+\\)" nil t)
+ (replace-match (number-to-string
+ (+ (string-to-number (match-string 1)) numc))
+ t t nil 1))))))
+ (nnheader-message 7 "nnmairix: Rewriting headers... done"))
(defun nnmairix-backend-to-server (server)
"Return nnmairix server most probably responsible for back end SERVER.
@@ -1491,10 +1492,10 @@ group."
(when (not found)
(setq mairixserver
(gnus-server-to-method
- (completing-read
- (format "Cannot determine which nnmairix server indexes %s. Please specify: "
+ (gnus-completing-read
+ (format "Cannot determine which nnmairix server indexes %s. Please specify"
(gnus-method-to-server server))
- (nnmairix-get-nnmairix-servers) nil nil "nnmairix:")))
+ (nnmairix-get-nnmairix-servers) nil "nnmairix:")))
;; Save result in parameter of default search group so that
;; we don't have to ask again
(setq defaultgroup (gnus-group-prefixed-name
@@ -1571,14 +1572,11 @@ See %s for details" proc nnmairix-mairix-output-buffer)))
(defun nnmairix-replace-illegal-chars (header)
"Replace illegal characters in HEADER for mairix query."
(when header
- (if (> emacs-major-version 20)
- (while (string-match "[^-.@/,& [:alnum:]]" header)
- (setq header (replace-match "" t t header)))
- (while (string-match "[[]{}:<>]" header)
- (setq header (replace-match "" t t header))))
+ (while (string-match "[^-.@/,& [:alnum:]]" header)
+ (setq header (replace-match "" t t header)))
(while (string-match "[-& ]" header)
(setq header (replace-match "," t t header)))
- header))
+ header))
(defun nnmairix-group-toggle-parameter (group parameter description &optional par)
"Toggle on GROUP a certain PARAMETER.
@@ -1621,8 +1619,7 @@ search in raw mode."
(let ((server (nth 1 gnus-current-select-method))
mid rval group allgroups)
;; get message id
- (save-excursion
- (set-buffer gnus-article-buffer)
+ (with-current-buffer gnus-article-buffer
(gnus-summary-toggle-header 1)
(setq mid (message-fetch-field "Message-ID"))
;; first check the registry (if available)
@@ -1643,9 +1640,9 @@ search in raw mode."
(gnus-registry-add-group mid cur)))))
(if (> (length allgroups) 1)
(setq group
- (completing-read
- "Message exists in more than one group. Choose: "
- allgroups nil t))
+ (gnus-completing-read
+ "Message exists in more than one group. Choose"
+ allgroups t))
(setq group (car allgroups))))
(if group
;; show article in summary buffer
@@ -1678,8 +1675,7 @@ SERVER."
(if (zerop (nnmairix-call-mairix-binary-raw
(split-string nnmairix-mairix-command)
(list (concat "m:" mid))))
- (save-excursion
- (set-buffer nnmairix-mairix-output-buffer)
+ (with-current-buffer nnmairix-mairix-output-buffer
(goto-char (point-min))
(while (re-search-forward "^/.*$" nil t)
(push (nnmairix-get-group-from-file-path (match-string 0))
@@ -1749,9 +1745,9 @@ SERVER."
(gnus-group-prefixed-name group (car cur))
allgroups))))
(if (> (length allgroups) 1)
- (setq group (completing-read
- "Group %s exists on more than one IMAP server. Choose: "
- allgroups nil t))
+ (setq group (gnus-completing-read
+ "Group %s exists on more than one IMAP server. Choose"
+ allgroups t))
(setq group (car allgroups))))
group))
@@ -2044,5 +2040,4 @@ VALUES may contain values for editable fields from current article."
(provide 'nnmairix)
-;; arch-tag: bb187498-b229-4a55-8c07-6d3f80713e94
;;; nnmairix.el ends here
diff --git a/lisp/gnus/nnmbox.el b/lisp/gnus/nnmbox.el
index 5ead1c96040..003c424f58d 100644
--- a/lisp/gnus/nnmbox.el
+++ b/lisp/gnus/nnmbox.el
@@ -79,8 +79,7 @@
(nnoo-define-basics nnmbox)
(deffoo nnmbox-retrieve-headers (sequence &optional newsgroup server fetch-old)
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(erase-buffer)
(let ((number (length sequence))
(count 0)
@@ -149,8 +148,7 @@
(deffoo nnmbox-request-article (article &optional newsgroup server buffer)
(nnmbox-possibly-change-newsgroup newsgroup server)
- (save-excursion
- (set-buffer nnmbox-mbox-buffer)
+ (with-current-buffer nnmbox-mbox-buffer
(when (nnmbox-find-article article)
(let (start stop)
(re-search-backward (concat "^" message-unix-mail-delimiter) nil t)
@@ -174,7 +172,7 @@
(cons nnmbox-current-group article)
(nnmbox-article-group-number nil)))))))
-(deffoo nnmbox-request-group (group &optional server dont-check)
+(deffoo nnmbox-request-group (group &optional server dont-check info)
(nnmbox-possibly-change-newsgroup nil server)
(let ((active (cadr (assoc group nnmbox-group-alist))))
(cond
@@ -208,8 +206,7 @@
(nnmail-get-new-mail
'nnmbox
(lambda ()
- (save-excursion
- (set-buffer nnmbox-mbox-buffer)
+ (with-current-buffer nnmbox-mbox-buffer
(nnmbox-save-buffer)))
(file-name-directory nnmbox-mbox-file)
group
@@ -253,8 +250,7 @@
rest)
(nnmail-activate 'nnmbox)
- (save-excursion
- (set-buffer nnmbox-mbox-buffer)
+ (with-current-buffer nnmbox-mbox-buffer
(while (and articles is-old)
(when (nnmbox-find-article (car articles))
(if (setq is-old
@@ -292,8 +288,7 @@
result)
(and
(nnmbox-request-article article group server)
- (save-excursion
- (set-buffer buf)
+ (with-current-buffer buf
(erase-buffer)
(insert-buffer-substring nntp-server-buffer)
(goto-char (point-min))
@@ -364,8 +359,7 @@
(deffoo nnmbox-request-replace-article (article group buffer)
(nnmbox-possibly-change-newsgroup group)
- (save-excursion
- (set-buffer nnmbox-mbox-buffer)
+ (with-current-buffer nnmbox-mbox-buffer
(if (not (nnmbox-find-article article))
nil
(nnmbox-delete-mail t t)
@@ -391,8 +385,7 @@
;; Delete all articles in GROUP.
(if (not force)
() ; Don't delete the articles.
- (save-excursion
- (set-buffer nnmbox-mbox-buffer)
+ (with-current-buffer nnmbox-mbox-buffer
(goto-char (point-min))
;; Delete all articles in this group.
(let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"))
@@ -412,8 +405,7 @@
(deffoo nnmbox-request-rename-group (group new-name &optional server)
(nnmbox-possibly-change-newsgroup group server)
- (save-excursion
- (set-buffer nnmbox-mbox-buffer)
+ (with-current-buffer nnmbox-mbox-buffer
(goto-char (point-min))
(let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"))
(new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":"))
@@ -633,8 +625,7 @@
(nnmbox-create-mbox)
(if (and nnmbox-mbox-buffer
(buffer-name nnmbox-mbox-buffer)
- (save-excursion
- (set-buffer nnmbox-mbox-buffer)
+ (with-current-buffer nnmbox-mbox-buffer
(= (buffer-size) (nnheader-file-size nnmbox-mbox-file))))
()
(save-excursion
@@ -649,6 +640,7 @@
nnmbox-mbox-file t t))))
(mm-enable-multibyte)
(buffer-disable-undo)
+ (gnus-add-buffer)
;; Go through the group alist and compare against the mbox file.
(while alist
@@ -718,5 +710,4 @@
(provide 'nnmbox)
-;; arch-tag: 611dd95f-be37-413a-b3ae-8b059ba93659
;;; nnmbox.el ends here
diff --git a/lisp/gnus/nnmh.el b/lisp/gnus/nnmh.el
index 2289eb6081a..984144e0d9a 100644
--- a/lisp/gnus/nnmh.el
+++ b/lisp/gnus/nnmh.el
@@ -149,7 +149,7 @@ as unread by Gnus.")
(save-excursion (nnmail-find-file file))
(string-to-number (file-name-nondirectory file)))))
-(deffoo nnmh-request-group (group &optional server dont-check)
+(deffoo nnmh-request-group (group &optional server dont-check info)
(nnheader-init-server-buffer)
(nnmh-possibly-change-directory group server)
(let ((pathname (nnmail-group-pathname group nnmh-directory))
@@ -207,40 +207,48 @@ as unread by Gnus.")
(defun nnmh-request-list-1 (dir)
(setq dir (expand-file-name dir))
;; Recurse down all directories.
- (let ((dirs (and (file-readable-p dir)
- (nnheader-directory-files dir t nil t)))
- rdir)
+ (let ((files (nnheader-directory-files dir t nil t))
+ (max 0)
+ min rdir num subdirectoriesp file)
;; Recurse down directories.
- (while (setq rdir (pop dirs))
- (when (and (file-directory-p rdir)
- (file-readable-p rdir)
- (not (equal (file-truename rdir)
- (file-truename dir))))
- (nnmh-request-list-1 rdir))))
- ;; For each directory, generate an active file line.
- (unless (string= (expand-file-name nnmh-toplev) dir)
- (let ((files (mapcar 'string-to-number
- (directory-files dir nil "^[0-9]+$" t))))
- (when files
- (with-current-buffer nntp-server-buffer
- (goto-char (point-max))
- (insert
- (format
- "%s %.0f %.0f y\n"
- (progn
- (string-match
- (regexp-quote
- (file-truename (file-name-as-directory
- (expand-file-name nnmh-toplev))))
- dir)
- (mm-string-to-multibyte ;Why? Isn't it multibyte already?
- (mm-encode-coding-string
- (nnheader-replace-chars-in-string
- (substring dir (match-end 0))
- ?/ ?.)
- nnmail-pathname-coding-system)))
- (apply 'max files)
- (apply 'min files)))))))
+ (setq subdirectoriesp (> (nth 1 (file-attributes dir)) 2))
+ (dolist (rdir files)
+ (if (or (not subdirectoriesp)
+ (file-regular-p rdir))
+ (progn
+ (setq file (file-name-nondirectory rdir))
+ (when (string-match "^[0-9]+$" file)
+ (setq num (string-to-number file))
+ (setq max (max max num))
+ (when (or (null min)
+ (< num min))
+ (setq min num))))
+ ;; This is a directory.
+ (when (and (file-readable-p rdir)
+ (not (equal (file-truename rdir)
+ (file-truename dir))))
+ (nnmh-request-list-1 rdir))))
+ ;; For each directory, generate an active file line.
+ (unless (string= (expand-file-name nnmh-toplev) dir)
+ (with-current-buffer nntp-server-buffer
+ (goto-char (point-max))
+ (insert
+ (format
+ "%s %.0f %.0f y\n"
+ (progn
+ (string-match
+ (regexp-quote
+ (file-truename (file-name-as-directory
+ (expand-file-name nnmh-toplev))))
+ dir)
+ (mm-string-to-multibyte ;Why? Isn't it multibyte already?
+ (mm-encode-coding-string
+ (nnheader-replace-chars-in-string
+ (substring dir (match-end 0))
+ ?/ ?.)
+ nnmail-pathname-coding-system)))
+ (or max 0)
+ (or min 1))))))
t)
(deffoo nnmh-request-newgroups (date &optional server)
@@ -250,9 +258,6 @@ as unread by Gnus.")
&optional server force)
(nnmh-possibly-change-directory newsgroup server)
(let ((is-old t)
- (nnmail-expiry-target
- (or (gnus-group-find-parameter newsgroup 'expiry-target t)
- nnmail-expiry-target))
article rest mod-time)
(nnheader-init-server-buffer)
@@ -287,7 +292,7 @@ as unread by Gnus.")
(deffoo nnmh-close-group (group &optional server)
t)
-(deffoo nnmh-request-move-article (article group server accept-form
+(deffoo nnmh-request-move-article (article group server accept-form
&optional last move-is-internal)
(let ((buf (get-buffer-create " *nnmh move*"))
result)
@@ -312,7 +317,7 @@ as unread by Gnus.")
(nnmh-possibly-change-directory group server)
(nnmail-check-syntax)
(when nnmail-cache-accepted-message-ids
- (nnmail-cache-insert (nnmail-fetch-field "message-id")
+ (nnmail-cache-insert (nnmail-fetch-field "message-id")
group
(nnmail-fetch-field "subject")
(nnmail-fetch-field "from")))
@@ -574,5 +579,4 @@ as unread by Gnus.")
(provide 'nnmh)
-;; arch-tag: 36c12a98-3bad-44b3-9953-628078ef0e04
;;; nnmh.el ends here
diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el
index fb5fb44113f..46a6d903f7e 100644
--- a/lisp/gnus/nnml.el
+++ b/lisp/gnus/nnml.el
@@ -160,8 +160,7 @@ non-nil.")
(deffoo nnml-retrieve-headers (sequence &optional group server fetch-old)
(when (nnml-possibly-change-directory group server)
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(erase-buffer)
(let* ((file nil)
(number (length sequence))
@@ -255,7 +254,7 @@ non-nil.")
(cons (if group-num (car group-num) group)
(string-to-number (file-name-nondirectory path)))))))
-(deffoo nnml-request-group (group &optional server dont-check)
+(deffoo nnml-request-group (group &optional server dont-check info)
(let ((file-name-coding-system nnmail-pathname-coding-system)
(decoded (nnml-decoded-group-name group server)))
(cond
@@ -283,7 +282,7 @@ non-nil.")
(deffoo nnml-request-scan (&optional group server)
(setq nnml-article-file-alist nil)
(nnml-possibly-change-directory group server)
- (nnmail-get-new-mail 'nnml 'nnml-save-nov nnml-directory group))
+ (nnmail-get-new-mail 'nnml 'nnml-save-incremental-nov nnml-directory group))
(deffoo nnml-close-group (group &optional server)
(setq nnml-article-file-alist nil)
@@ -405,8 +404,7 @@ non-nil.")
(let (nnml-current-directory
nnml-current-group
nnml-article-file-alist)
- (save-excursion
- (set-buffer buf)
+ (with-current-buffer buf
(insert-buffer-substring nntp-server-buffer)
(setq result (eval accept-form))
(kill-buffer (current-buffer))
@@ -438,7 +436,7 @@ non-nil.")
(setq result (car (nnml-save-mail
(list (cons group (nnml-active-number group
server)))
- server)))
+ server t)))
(progn
(nnmail-save-active nnml-group-alist nnml-active-file)
(and last (nnml-save-nov))))
@@ -449,7 +447,7 @@ non-nil.")
(nnml-active-number group ,server)))))
(yes-or-no-p "Moved to `junk' group; delete article? "))
(setq result 'junk)
- (setq result (car (nnml-save-mail result server))))
+ (setq result (car (nnml-save-mail result server t))))
(when last
(nnmail-save-active nnml-group-alist nnml-active-file)
(when nnmail-cache-accepted-message-ids
@@ -462,8 +460,7 @@ non-nil.")
(deffoo nnml-request-replace-article (article group buffer)
(nnml-possibly-change-directory group)
- (save-excursion
- (set-buffer buffer)
+ (with-current-buffer buffer
(nnml-possibly-create-directory group)
(let ((chars (nnmail-insert-lines))
(art (concat (int-to-string article) "\t"))
@@ -478,8 +475,7 @@ non-nil.")
t)
(setq headers (nnml-parse-head chars article))
;; Replace the NOV line in the NOV file.
- (save-excursion
- (set-buffer (nnml-open-nov group))
+ (with-current-buffer (nnml-open-nov group)
(goto-char (point-min))
(if (or (looking-at art)
(search-forward (concat "\n" art) nil t))
@@ -614,8 +610,7 @@ non-nil.")
;; Find an article number in the current group given the Message-ID.
(defun nnml-find-group-number (id server)
- (save-excursion
- (set-buffer (get-buffer-create " *nnml id*"))
+ (with-current-buffer (get-buffer-create " *nnml id*")
(let ((alist nnml-group-alist)
number)
;; We want to look through all .overview files, but we want to
@@ -657,8 +652,7 @@ non-nil.")
nil
(let ((nov (expand-file-name nnml-nov-file-name nnml-current-directory)))
(when (file-exists-p nov)
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(erase-buffer)
(nnheader-insert-file-contents nov)
(if (and fetch-old
@@ -691,7 +685,7 @@ non-nil.")
(make-directory (directory-file-name dir) t)
(nnheader-message 5 "Creating mail directory %s" dir))))
-(defun nnml-save-mail (group-art &optional server)
+(defun nnml-save-mail (group-art &optional server full-nov)
"Save a mail into the groups GROUP-ART in the nnml server SERVER.
GROUP-ART is a list that each element is a cons of a group name and an
article number. This function is called narrowed to an article."
@@ -742,19 +736,21 @@ article number. This function is called narrowed to an article."
;; header.
(setq headers (nnml-parse-head chars))
;; Output the nov line to all nov databases that should have it.
- (if nnmail-group-names-not-encoded-p
+ (let ((func (if full-nov
+ 'nnml-add-nov
+ 'nnml-add-incremental-nov)))
+ (if nnmail-group-names-not-encoded-p
+ (dolist (ga group-art)
+ (funcall func (pop dec) (cdr ga) headers))
(dolist (ga group-art)
- (nnml-add-nov (pop dec) (cdr ga) headers))
- (dolist (ga group-art)
- (nnml-add-nov (car ga) (cdr ga) headers))))
+ (funcall func (car ga) (cdr ga) headers)))))
group-art)
(defun nnml-active-number (group &optional server)
"Compute the next article number in GROUP on SERVER."
- (let ((active (cadr (assoc (if nnmail-group-names-not-encoded-p
- (nnml-encoded-group-name group server)
- group)
- nnml-group-alist))))
+ (let* ((encoded (if nnmail-group-names-not-encoded-p
+ (nnml-encoded-group-name group server)))
+ (active (cadr (assoc (or encoded group) nnml-group-alist))))
;; The group wasn't known to nnml, so we just create an active
;; entry for it.
(unless active
@@ -772,17 +768,44 @@ article number. This function is called narrowed to an article."
(cons (caar nnml-article-file-alist)
(caar (last nnml-article-file-alist)))
(cons 1 0)))
- (push (list group active) nnml-group-alist))
+ (push (list (or encoded group) active) nnml-group-alist))
(setcdr active (1+ (cdr active)))
(while (file-exists-p
(nnml-group-pathname group (int-to-string (cdr active)) server))
(setcdr active (1+ (cdr active))))
(cdr active)))
+(defvar nnml-incremental-nov-buffer-alist nil)
+
+(defun nnml-save-incremental-nov ()
+ (save-excursion
+ (while nnml-incremental-nov-buffer-alist
+ (when (buffer-name (cdar nnml-incremental-nov-buffer-alist))
+ (set-buffer (cdar nnml-incremental-nov-buffer-alist))
+ (when (buffer-modified-p)
+ (nnmail-write-region (point-min) (point-max)
+ nnml-nov-buffer-file-name t 'nomesg))
+ (set-buffer-modified-p nil)
+ (kill-buffer (current-buffer)))
+ (setq nnml-incremental-nov-buffer-alist
+ (cdr nnml-incremental-nov-buffer-alist)))))
+
+(defun nnml-open-incremental-nov (group)
+ (or (cdr (assoc group nnml-incremental-nov-buffer-alist))
+ (let ((buffer (nnml-get-nov-buffer group t)))
+ (push (cons group buffer) nnml-incremental-nov-buffer-alist)
+ buffer)))
+
+(defun nnml-add-incremental-nov (group article headers)
+ "Add a nov line for the GROUP nov headers, incrementally."
+ (with-current-buffer (nnml-open-incremental-nov group)
+ (goto-char (point-max))
+ (mail-header-set-number headers article)
+ (nnheader-insert-nov headers)))
+
(defun nnml-add-nov (group article headers)
"Add a nov line for the GROUP base."
- (save-excursion
- (set-buffer (nnml-open-nov group))
+ (with-current-buffer (nnml-open-nov group)
(goto-char (point-max))
(mail-header-set-number headers article)
(nnheader-insert-nov headers)))
@@ -805,21 +828,27 @@ article number. This function is called narrowed to an article."
(mail-header-set-number headers number)
headers))))
-(defun nnml-get-nov-buffer (group)
+(defun nnml-get-nov-buffer (group &optional incrementalp)
(let* ((decoded (nnml-decoded-group-name group))
- (buffer (get-buffer-create (format " *nnml overview %s*" decoded)))
+ (buffer (get-buffer-create (format " *nnml %soverview %s*"
+ (if incrementalp
+ "incremental "
+ "")
+ decoded)))
(file-name-coding-system nnmail-pathname-coding-system))
- (save-excursion
- (set-buffer buffer)
+ (with-current-buffer buffer
(set (make-local-variable 'nnml-nov-buffer-file-name)
(nnmail-group-pathname decoded nnml-directory nnml-nov-file-name))
(erase-buffer)
- (when (file-exists-p nnml-nov-buffer-file-name)
+ (when (and (not incrementalp)
+ (file-exists-p nnml-nov-buffer-file-name))
(nnheader-insert-file-contents nnml-nov-buffer-file-name)))
buffer))
(defun nnml-open-nov (group)
- (or (cdr (assoc group nnml-nov-buffer-alist))
+ (or (let ((buffer (cdr (assoc group nnml-nov-buffer-alist))))
+ (and (buffer-name buffer)
+ buffer))
(let ((buffer (nnml-get-nov-buffer group)))
(push (cons group buffer) nnml-nov-buffer-alist)
buffer)))
@@ -851,6 +880,7 @@ article number. This function is called narrowed to an article."
;; Save the active file.
(nnmail-save-active nnml-group-alist nnml-active-file))
+(defvar nnml-files)
(defun nnml-generate-nov-databases-directory (dir &optional seen no-active)
"Regenerate the NOV database in DIR.
@@ -870,9 +900,9 @@ Unless no-active is non-nil, update the active file too."
(file-directory-p dir))
(nnml-generate-nov-databases-directory dir seen)))
;; Do this directory.
- (let ((files (sort (nnheader-article-to-file-alist dir)
+ (let ((nnml-files (sort (nnheader-article-to-file-alist dir)
'car-less-than-car)))
- (if (not files)
+ (if (not nnml-files)
(let* ((group (nnheader-file-to-group
(directory-file-name dir) nnml-directory))
(info (cadr (assoc group nnml-group-alist))))
@@ -880,11 +910,10 @@ Unless no-active is non-nil, update the active file too."
(setcar info (1+ (cdr info)))))
(funcall nnml-generate-active-function dir)
;; Generate the nov file.
- (nnml-generate-nov-file dir files)
+ (nnml-generate-nov-file dir nnml-files)
(unless no-active
(nnmail-save-active nnml-group-alist nnml-active-file)))))))
-(defvar files)
(defun nnml-generate-active-info (dir)
;; Update the active info for this group.
(let ((group (directory-file-name dir))
@@ -895,9 +924,9 @@ Unless no-active is non-nil, update the active file too."
last (or (caadr entry) 0)
nnml-group-alist (delq entry nnml-group-alist))
(push (list group
- (cons (or (caar files) (1+ last))
+ (cons (or (caar nnml-files) (1+ last))
(max last
- (or (caar (last files))
+ (or (caar (last nnml-files))
0))))
nnml-group-alist)))
@@ -906,42 +935,38 @@ Unless no-active is non-nil, update the active file too."
(nov (concat dir nnml-nov-file-name))
(nov-buffer (get-buffer-create " *nov*"))
chars file headers)
- (save-excursion
+ (with-current-buffer nov-buffer
;; Init the nov buffer.
- (set-buffer nov-buffer)
(buffer-disable-undo)
(erase-buffer)
(set-buffer nntp-server-buffer)
;; Delete the old NOV file.
(when (file-exists-p nov)
(funcall nnmail-delete-file-function nov))
- (while files
- (unless (file-directory-p (setq file (concat dir (cdar files))))
- (erase-buffer)
- (nnheader-insert-file-contents file)
- (narrow-to-region
- (goto-char (point-min))
- (progn
- (re-search-forward "\n\r?\n" nil t)
- (setq chars (- (point-max) (point)))
- (max (point-min) (1- (point)))))
- (unless (zerop (buffer-size))
- (goto-char (point-min))
- (setq headers (nnml-parse-head chars (caar files)))
- (save-excursion
- (set-buffer nov-buffer)
- (goto-char (point-max))
- (nnheader-insert-nov headers)))
- (widen))
- (setq files (cdr files)))
- (save-excursion
- (set-buffer nov-buffer)
+ (dolist (file files)
+ (let ((path (concat dir (cdr file))))
+ (unless (file-directory-p path)
+ (erase-buffer)
+ (nnheader-insert-file-contents path)
+ (narrow-to-region
+ (goto-char (point-min))
+ (progn
+ (re-search-forward "\n\r?\n" nil t)
+ (setq chars (- (point-max) (point)))
+ (max (point-min) (1- (point)))))
+ (unless (zerop (buffer-size))
+ (goto-char (point-min))
+ (setq headers (nnml-parse-head chars (car file)))
+ (with-current-buffer nov-buffer
+ (goto-char (point-max))
+ (nnheader-insert-nov headers)))
+ (widen))))
+ (with-current-buffer nov-buffer
(nnmail-write-region (point-min) (point-max) nov nil 'nomesg)
(kill-buffer (current-buffer))))))
(defun nnml-nov-delete-article (group article)
- (save-excursion
- (set-buffer (nnml-open-nov group))
+ (with-current-buffer (nnml-open-nov group)
(when (nnheader-find-nov-line article)
(delete-region (point) (progn (forward-line 1) (point)))
(when (bobp)
@@ -972,11 +997,9 @@ Use the nov database for that directory if available."
;; build list from .overview if available
;; We would use nnml-open-nov, except that nnml-nov-buffer-alist is
;; defvoo'd, and we might get called when it hasn't been swapped in.
- (save-excursion
+ (with-current-buffer (nnml-get-nov-buffer nnml-current-group)
(let ((list nil)
- art
- (buffer (nnml-get-nov-buffer nnml-current-group)))
- (set-buffer buffer)
+ art)
(goto-char (point-min))
(while (not (eobp))
(setq art (read (current-buffer)))
@@ -995,11 +1018,9 @@ Use the nov database for the current group if available."
nnml-current-directory))))
(nnheader-article-to-file-alist nnml-current-directory)
;; build list from .overview if available
- (save-excursion
+ (with-current-buffer (nnml-get-nov-buffer nnml-current-group)
(let ((alist nil)
- (buffer (nnml-get-nov-buffer nnml-current-group))
art)
- (set-buffer buffer)
(goto-char (point-min))
(while (not (eobp))
(setq art (read (current-buffer)))
@@ -1012,23 +1033,11 @@ Use the nov database for the current group if available."
(nnml-possibly-change-directory group server)
(unless nnml-marks-is-evil
(nnml-open-marks group server)
- (dolist (action actions)
- (let ((range (nth 0 action))
- (what (nth 1 action))
- (marks (nth 2 action)))
- (assert (or (eq what 'add) (eq what 'del)) nil
- "Unknown request-set-mark action: %s" what)
- (dolist (mark marks)
- (setq nnml-marks (gnus-update-alist-soft
- mark
- (funcall (if (eq what 'add) 'gnus-range-add
- 'gnus-remove-from-range)
- (cdr (assoc mark nnml-marks)) range)
- nnml-marks)))))
+ (setq nnml-marks (nnheader-update-marks-actions nnml-marks actions))
(nnml-save-marks group server))
nil)
-(deffoo nnml-request-update-info (group info &optional server)
+(deffoo nnml-request-marks (group info &optional server)
(nnml-possibly-change-directory group server)
(when (and (not nnml-marks-is-evil) (nnml-marks-changed-p group server))
(nnheader-message 8 "Updating marks for %s..." group)
@@ -1224,8 +1233,7 @@ Use the nov database for the current group if available."
(gnus-info-set-marks info newmarks))
;; 3/ Update the NOV entry for this article:
(unless nnml-nov-is-evil
- (save-excursion
- (set-buffer (nnml-open-nov group))
+ (with-current-buffer (nnml-open-nov group)
(when (nnheader-find-nov-line old-number)
;; Replace the article number:
(looking-at old-number-string)
@@ -1307,5 +1315,4 @@ Use the nov database for the current group if available."
(provide 'nnml)
-;; arch-tag: 52c97dc3-9735-45de-b439-9e4d23b52004
;;; nnml.el ends here
diff --git a/lisp/gnus/nnnil.el b/lisp/gnus/nnnil.el
index f20d63e70aa..e40126d6e0d 100644
--- a/lisp/gnus/nnnil.el
+++ b/lisp/gnus/nnnil.el
@@ -56,10 +56,9 @@
(setq nnnil-status-string "No such group")
nil)
-(defun nnnil-request-group (group &optional server fast)
+(defun nnnil-request-group (group &optional server fast info)
(let (deactivate-mark)
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(erase-buffer)
(insert "411 no such news group\n")))
(setq nnnil-status-string "No such group")
@@ -79,4 +78,4 @@
(provide 'nnnil)
-;; arch-tag: a982a1a3-bc5e-4fb1-a233-d7657a3e3257
+;;; nnnil.el ends here
diff --git a/lisp/gnus/nnoo.el b/lisp/gnus/nnoo.el
index c57af29fb68..083bedc6e19 100644
--- a/lisp/gnus/nnoo.el
+++ b/lisp/gnus/nnoo.el
@@ -322,5 +322,4 @@ All functions will return nil and report an error."
(provide 'nnoo)
-;; arch-tag: 0196b5ed-6f34-4778-a455-73a971f837e7
;;; nnoo.el ends here
diff --git a/lisp/gnus/nnregistry.el b/lisp/gnus/nnregistry.el
new file mode 100644
index 00000000000..03ff5e716aa
--- /dev/null
+++ b/lisp/gnus/nnregistry.el
@@ -0,0 +1,66 @@
+;;; nnregistry.el --- access to articles via Gnus' message-id registry
+;;; -*- coding: utf-8 -*-
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Authors: Ludovic Courtès <ludo@gnu.org>
+;; Keywords: news, mail
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file provides the `nnregistry' Gnus back-end. It can be used
+;; in `gnus-refer-article-method' to quickly search for a message by
+;; id, regardless of the back-end that stores it. See the Gnus manual
+;; for usage examples and more information.
+
+;;; Code:
+
+(require 'nnoo)
+(require 'gnus-registry)
+(require 'gnus-int)
+
+(nnoo-declare nnregistry)
+
+(deffoo nnregistry-server-opened (server)
+ (eq gnus-registry-install t))
+
+(deffoo nnregistry-close-server (server)
+ t)
+
+(deffoo nnregistry-status-message (server)
+ nil)
+
+(deffoo nnregistry-open-server (server &optional defs)
+ (eq gnus-registry-install t))
+
+(defvar nnregistry-within-nnregistry nil)
+
+(deffoo nnregistry-request-article (id &optional group server buffer)
+ (and (not nnregistry-within-nnregistry)
+ (let* ((nnregistry-within-nnregistry t)
+ (group (gnus-registry-fetch-group id))
+ (gnus-override-method nil))
+ (message "nnregistry: requesting article `%s' in group `%s'"
+ id group)
+ (and group
+ (gnus-check-group group)
+ (gnus-request-article id group buffer)))))
+
+(provide 'nnregistry)
+
+;;; nnregistry.el ends here
diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el
index 08b621919eb..9a02c26073d 100644
--- a/lisp/gnus/nnrss.el
+++ b/lisp/gnus/nnrss.el
@@ -25,7 +25,7 @@
;;; Code:
-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
@@ -77,7 +77,8 @@ this variable to the list of fields to be ignored.")
(defvar nnrss-group-alist '()
"List of RSS addresses.")
-(defvar nnrss-use-local nil)
+(defvar nnrss-use-local nil
+ "If non-nil nnrss will read the feeds from local files in nnrss-directory.")
(defvar nnrss-description-field 'X-Gnus-Description
"Field name used for DESCRIPTION.
@@ -113,11 +114,6 @@ The cdr of each element is used to decode data if it is available when
the car is what the data specify as the encoding. Or, the car is used
for decoding when the cdr that the data specify is not available.")
-(defvar nnrss-wash-html-in-text-plain-parts nil
- "*Non-nil means render text in text/plain parts as HTML.
-The function specified by the `mm-text-html-renderer' variable will be
-used to render text. If it is nil, text will simply be folded.")
-
(nnoo-define-basics nnrss)
;;; Interface functions
@@ -134,8 +130,7 @@ used to render text. If it is nil, text will simply be folded.")
(setq group (nnrss-decode-group-name group))
(nnrss-possibly-change-group group server)
(let (e)
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(erase-buffer)
(dolist (article articles)
(if (setq e (assq article nnrss-group-data))
@@ -179,7 +174,7 @@ used to render text. If it is nil, text will simply be folded.")
"\n")))))
'nov)
-(deffoo nnrss-request-group (group &optional server dont-check)
+(deffoo nnrss-request-group (group &optional server dont-check info)
(setq group (nnrss-decode-group-name group))
(nnheader-message 6 "nnrss: Requesting %s..." group)
(nnrss-possibly-change-group group server)
@@ -197,9 +192,6 @@ used to render text. If it is nil, text will simply be folded.")
(deffoo nnrss-close-group (group &optional server)
t)
-(defvar mm-text-html-renderer)
-(defvar mm-text-html-washer-alist)
-
(deffoo nnrss-request-article (article &optional group server buffer)
(setq group (nnrss-decode-group-name group))
(when (stringp article)
@@ -240,46 +232,25 @@ used to render text. If it is nil, text will simply be folded.")
(when text
(insert text)
(goto-char body)
- (if (and nnrss-wash-html-in-text-plain-parts
- (progn
- (require 'mm-view)
- (setq fn (or (cdr (assq mm-text-html-renderer
- mm-text-html-washer-alist))
- mm-text-html-renderer))))
- (progn
- (narrow-to-region body (point-max))
- (if (functionp fn)
- (funcall fn)
- (apply (car fn) (cdr fn)))
- (widen)
- (goto-char body)
- (re-search-forward "[^\t\n ]" nil t)
- (beginning-of-line)
- (delete-region body (point))
- (goto-char (point-max))
- (skip-chars-backward "\t\n ")
- (end-of-line)
- (delete-region (point) (point-max))
- (insert "\n"))
- (while (re-search-forward "\n+" nil t)
- (replace-match " "))
- (goto-char body)
- ;; See `nnrss-check-group', which inserts "<br /><br />".
- (when (search-forward "<br /><br />" nil t)
- (if (eobp)
- (replace-match "\n")
- (replace-match "\n\n")))
- (unless (eobp)
- (let ((fill-column (default-value 'fill-column))
- (window (get-buffer-window nntp-server-buffer)))
- (when window
- (setq fill-column
- (max 1 (/ (* (window-width window) 7) 8))))
- (fill-region (point) (point-max))
- (goto-char (point-max))
- ;; XEmacs version of `fill-region' inserts newline.
- (unless (bolp)
- (insert "\n")))))
+ (while (re-search-forward "\n+" nil t)
+ (replace-match " "))
+ (goto-char body)
+ ;; See `nnrss-check-group', which inserts "<br /><br />".
+ (when (search-forward "<br /><br />" nil t)
+ (if (eobp)
+ (replace-match "\n")
+ (replace-match "\n\n")))
+ (unless (eobp)
+ (let ((fill-column (default-value 'fill-column))
+ (window (get-buffer-window nntp-server-buffer)))
+ (when window
+ (setq fill-column
+ (max 1 (/ (* (window-width window) 7) 8))))
+ (fill-region (point) (point-max))
+ (goto-char (point-max))
+ ;; XEmacs version of `fill-region' inserts newline.
+ (unless (bolp)
+ (insert "\n"))))
(when (or link enclosure)
(insert "\n")))
(when link
@@ -342,11 +313,6 @@ used to render text. If it is nil, text will simply be folded.")
;; we return the article number.
(cons nnrss-group (car e))))))
-(deffoo nnrss-request-list (&optional server)
- (nnrss-possibly-change-group nil server)
- (nnrss-generate-active)
- t)
-
(deffoo nnrss-open-server (server &optional defs connectionless)
(nnrss-read-server-data server)
(nnoo-change-server 'nnrss server defs)
@@ -389,14 +355,24 @@ used to render text. If it is nil, text will simply be folded.")
(deffoo nnrss-request-list-newsgroups (&optional server)
(nnrss-possibly-change-group nil server)
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(erase-buffer)
(dolist (elem nnrss-group-alist)
(if (third elem)
(insert (car elem) "\t" (third elem) "\n"))))
t)
+(deffoo nnrss-retrieve-groups (groups &optional server)
+ (dolist (group groups)
+ (nnrss-possibly-change-group group server)
+ (nnrss-check-group group server))
+ (with-current-buffer nntp-server-buffer
+ (erase-buffer)
+ (dolist (group groups)
+ (let ((elem (assoc group nnrss-server-data)))
+ (insert (format "%S %s 1 y\n" group (or (cadr elem) 0)))))
+ 'active))
+
(nnoo-define-skeleton nnrss)
;;; Internal functions
@@ -479,26 +455,12 @@ nnrss: %s: Not valid XML %s and w3-parse doesn't work %s"
(nnrss-read-group-data group server)
(setq nnrss-group group)))
-(defvar nnrss-extra-categories '(nnrss-snarf-moreover-categories))
-
-(defun nnrss-generate-active ()
- (when (y-or-n-p "Fetch extra categories? ")
- (mapc 'funcall nnrss-extra-categories))
- (save-excursion
- (set-buffer nntp-server-buffer)
- (erase-buffer)
- (dolist (elem nnrss-group-alist)
- (insert (prin1-to-string (car elem)) " 0 1 y\n"))
- (dolist (elem nnrss-server-data)
- (unless (assoc (car elem) nnrss-group-alist)
- (insert (prin1-to-string (car elem)) " 0 1 y\n")))))
-
(autoload 'timezone-parse-date "timezone")
(defun nnrss-normalize-date (date)
"Return a date string of DATE in the RFC822 style.
This function handles the ISO 8601 date format described in
-<URL:http://www.w3.org/TR/NOTE-datetime>, and also the RFC822 style
+URL `http://www.w3.org/TR/NOTE-datetime', and also the RFC822 style
which RSS 2.0 allows."
(let (case-fold-search vector year month day time zone cts given)
(cond ((null date)) ; do nothing for this case
@@ -571,12 +533,7 @@ which RSS 2.0 allows."
(let ((file (nnrss-make-filename "nnrss" server))
(file-name-coding-system nnmail-pathname-coding-system))
(when (file-exists-p file)
- ;; In Emacs 21.3 and earlier, `load' doesn't support non-ASCII
- ;; file names. So, we use `insert-file-contents' instead.
- (mm-with-multibyte-buffer
- (let ((coding-system-for-read nnrss-file-coding-system))
- (insert-file-contents file)
- (eval-region (point-min) (point-max)))))))
+ (load file nil t t))))
(defun nnrss-save-server-data (server)
(gnus-make-directory nnrss-directory)
@@ -600,12 +557,7 @@ which RSS 2.0 allows."
(let ((file (nnrss-make-filename group server))
(file-name-coding-system nnmail-pathname-coding-system))
(when (file-exists-p file)
- ;; In Emacs 21.3 and earlier, `load' doesn't support non-ASCII
- ;; file names. So, we use `insert-file-contents' instead.
- (mm-with-multibyte-buffer
- (let ((coding-system-for-read nnrss-file-coding-system))
- (insert-file-contents file)
- (eval-region (point-min) (point-max))))
+ (load file nil t t)
(dolist (e nnrss-group-data)
(puthash (nth 9 e) t nnrss-group-hashtb)
(when (and (car e) (> nnrss-group-min (car e)))
@@ -682,7 +634,7 @@ which RSS 2.0 allows."
(rfc2047-encode-region (point-min) (point-max)))
(goto-char (point-min))
(while (search-forward "\n" nil t)
- (delete-backward-char 1))
+ (delete-char -1))
(buffer-string)))
;;; Snarf functions
@@ -722,9 +674,6 @@ which RSS 2.0 allows."
(push (list group nnrss-group-max url) nnrss-server-data)))
(setq changed t))
(setq xml (nnrss-fetch url)))
- ;; See
- ;; http://feeds.archive.org/validator/docs/howto/declare_namespaces.html
- ;; for more RSS namespaces.
(setq dc-ns (nnrss-get-namespace-prefix xml "http://purl.org/dc/elements/1.1/")
rdf-ns (nnrss-get-namespace-prefix xml "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
rss-ns (nnrss-get-namespace-prefix xml "http://purl.org/rss/1.0/")
@@ -868,33 +817,6 @@ It is useful when `(setq nnrss-use-local t)'."
(append nnheader-file-name-translation-alist '((?' . ?_)))))
(nnheader-translate-file-chars name)))
-(defvar nnrss-moreover-url
- "http://w.moreover.com/categories/category_list_rss.html"
- "The url of moreover.com categories.")
-
-(defun nnrss-snarf-moreover-categories ()
- "Snarf RSS links from moreover.com."
- (interactive)
- (let (category name url changed)
- (with-temp-buffer
- (nnrss-insert nnrss-moreover-url)
- (goto-char (point-min))
- (while (re-search-forward
- "<a name=\"\\([^\"]+\\)\">\\|<a href=\"\\(http://[^\"]*moreover\\.com[^\"]+page\\?c=\\([^\"&]+\\)&o=rss\\)" nil t)
- (if (match-string 1)
- (setq category (match-string 1))
- (setq url (match-string 2)
- name (mm-url-decode-entities-string
- (rfc2231-decode-encoded-string
- (match-string 3))))
- (if category
- (setq name (concat category "." name)))
- (unless (assoc name nnrss-server-data)
- (setq changed t)
- (push (list name 0 url) nnrss-server-data)))))
- (if changed
- (nnrss-save-server-data ""))))
-
(defun nnrss-node-text (namespace local-name element)
(let* ((node (assq (intern (concat namespace (symbol-name local-name)))
element))
@@ -1012,7 +934,7 @@ whether they are `offsite' or `onsite'."
(defun nnrss-discover-feed (url)
"Given a page, find an RSS feed using Mark Pilgrim's
-`ultra-liberal rss locator' (http://diveintomark.org/2002/08/15.html)."
+`ultra-liberal rss locator'."
(let ((parsed-page (nnrss-fetch url)))
@@ -1095,9 +1017,9 @@ whether they are `offsite' or `onsite'."
(cdr (assoc "feedid" listinfo)))))
feedinfo)))
(cdr (assoc
- (completing-read
- "Multiple feeds found. Select one: "
- selection nil t) urllist)))))))))
+ (gnus-completing-read
+ "Multiple feeds found. Select one"
+ selection t) urllist)))))))))
(defun nnrss-rss-p (data)
"Test if DATA is an RSS feed.
@@ -1134,5 +1056,4 @@ prefix), return the prefix."
(provide 'nnrss)
-;; arch-tag: 12910c07-0cdf-44fb-8d2c-416ded64c267
;;; nnrss.el ends here
diff --git a/lisp/gnus/nnslashdot.el b/lisp/gnus/nnslashdot.el
deleted file mode 100644
index 3a0d6077ad8..00000000000
--- a/lisp/gnus/nnslashdot.el
+++ /dev/null
@@ -1,505 +0,0 @@
-;;; nnslashdot.el --- interfacing with Slashdot
-
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; Keywords: news
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-
-(require 'nnoo)
-(require 'message)
-(require 'gnus-util)
-(require 'gnus)
-(require 'nnmail)
-(require 'mm-util)
-(require 'mm-url)
-
-(nnoo-declare nnslashdot)
-
-(defvoo nnslashdot-directory (nnheader-concat gnus-directory "slashdot/")
- "Where nnslashdot will save its files.")
-
-(defvoo nnslashdot-active-url "http://slashdot.org/search.pl?section=&min=%d"
- "Where nnslashdot will fetch the active file from.")
-
-(defvoo nnslashdot-comments-url "http://slashdot.org/comments.pl?sid=%s&threshold=%d&commentsort=%d&mode=flat&startat=%d"
- "Where nnslashdot will fetch comments from.")
-
-(defvoo nnslashdot-article-url
- "http://slashdot.org/article.pl?sid=%s&mode=nocomment"
- "Where nnslashdot will fetch the article from.")
-
-(defvoo nnslashdot-backslash-url "http://slashdot.org/slashdot.xml"
- "Where nnslashdot will fetch the stories from.")
-
-(defvoo nnslashdot-use-front-page nil
- "Use the front page in addition to the backslash page.")
-
-(defvoo nnslashdot-threshold -1
- "The article threshold.")
-
-(defvoo nnslashdot-threaded t
- "Whether the nnslashdot groups should be threaded or not.")
-
-(defvoo nnslashdot-group-number 0
- "The number of non-fresh groups to keep updated.")
-
-(defvoo nnslashdot-login-name ""
- "The login name to use when posting.")
-
-(defvoo nnslashdot-password ""
- "The password to use when posting.")
-
-;;; Internal variables
-
-(defvar nnslashdot-groups nil)
-(defvar nnslashdot-buffer nil)
-(defvar nnslashdot-headers nil)
-
-;;; Interface functions
-
-(nnoo-define-basics nnslashdot)
-
-(deffoo nnslashdot-retrieve-headers (articles &optional group server fetch-old)
- (nnslashdot-possibly-change-server group server)
- (condition-case why
- (unless gnus-nov-is-evil
- (nnslashdot-retrieve-headers-1 articles group))
- (search-failed (nnslashdot-lose why))))
-
-(deffoo nnslashdot-retrieve-headers-1 (articles group)
- (let* ((last (car (last articles)))
- (start (if nnslashdot-threaded 1 (pop articles)))
- (entry (assoc group nnslashdot-groups))
- (sid (nth 2 entry))
- (first-comments t)
- headers article subject score from date lines parent point cid
- s startats changed)
- (save-excursion
- (set-buffer nnslashdot-buffer)
- (let ((case-fold-search t))
- (erase-buffer)
- (when (= start 1)
- (mm-url-insert (format nnslashdot-article-url sid) t)
- (goto-char (point-min))
- (if (eobp)
- (error "Couldn't open connection to slashdot"))
- (re-search-forward "Posted by[ \t\r\n]+")
- (when (looking-at "\\(<a[^>]+>\\)?[ \t\r\n]*\\([^<\r\n]+\\)")
- (setq from (mm-url-decode-entities-string (match-string 2))))
- (search-forward "on ")
- (setq date (nnslashdot-date-to-date
- (buffer-substring (point) (1- (search-forward "<")))))
- (setq lines (/ (- (point)
- (progn (forward-line 1) (point)))
- 60))
- (push
- (cons
- 1
- (make-full-mail-header
- 1 group from date
- (concat "<" sid "%1@slashdot>")
- "" 0 lines nil nil))
- headers)
- (setq start (if nnslashdot-threaded 2 (pop articles))))
- (while (and start (<= start last))
- (setq point (goto-char (point-max)))
- (mm-url-insert
- (format nnslashdot-comments-url sid
- nnslashdot-threshold 0 (- start 2))
- t)
- (when (and nnslashdot-threaded first-comments)
- (setq first-comments nil)
- (goto-char (point-max))
- (while (re-search-backward "startat=\\([0-9]+\\)" nil t)
- (setq s (string-to-number (match-string 1)))
- (unless (memq s startats)
- (push s startats)))
- (setq startats (sort startats '<)))
- (setq article (if (and article (< start article)) article start))
- (goto-char point)
- (while (re-search-forward
- "<a name=\"\\([0-9]+\\)\">\\([^<]+\\)\\(?:.*\n\\)\\{2,10\\}.*score:\\([^)]+\\))"
- nil t)
- (setq cid (match-string 1)
- subject (match-string 2)
- score (match-string 3))
- (unless (assq article (nth 4 entry))
- (setcar (nthcdr 4 entry) (cons (cons article cid) (nth 4 entry)))
- (setq changed t))
- (when (string-match "^Re: *" subject)
- (setq subject (concat "Re: " (substring subject (match-end 0)))))
- (setq subject (mm-url-decode-entities-string subject)
- from "")
- (when (re-search-forward "by[ \t\n]+<[^>]+>\\([^<(]+\\)" nil t)
- (setq from
- (concat
- (mm-url-decode-entities-string (match-string 1))
- " <nobody@slashdot.org>")))
- (search-forward "on ")
- (setq date
- (nnslashdot-date-to-date
- (buffer-substring
- (point) (progn (skip-chars-forward "^()<>\n\r") (point)))))
- (setq lines (/ (abs (- (search-forward "<div")
- (search-forward "</div>")))
- 70))
- (if (not
- (re-search-forward ".*cid=\\([0-9]+\\)\">Parent</A>" nil t))
- (setq parent nil)
- (setq parent (match-string 1))
- (when (string= parent "0")
- (setq parent nil)))
- (push
- (cons
- article
- (make-full-mail-header
- article
- (concat subject " (" score ")")
- from date
- (concat "<" sid "%" cid "@slashdot>")
- (if parent
- (concat "<" sid "%" parent "@slashdot>")
- "")
- 0 lines nil nil))
- headers)
- (while (and articles (<= (car articles) article))
- (pop articles))
- (setq article (1+ article)))
- (if nnslashdot-threaded
- (progn
- (setq start (pop startats))
- (if start (setq start (+ start 2))))
- (setq start (pop articles))))))
- (if changed (nnslashdot-write-groups))
- (setq nnslashdot-headers (sort headers 'car-less-than-car))
- (save-excursion
- (set-buffer nntp-server-buffer)
- (erase-buffer)
- (mm-with-unibyte-current-buffer
- (dolist (header nnslashdot-headers)
- (nnheader-insert-nov (cdr header)))))
- 'nov))
-
-(deffoo nnslashdot-request-group (group &optional server dont-check)
- (nnslashdot-possibly-change-server nil server)
- (let ((elem (assoc group nnslashdot-groups)))
- (cond
- ((not elem)
- (nnheader-report 'nnslashdot "Group does not exist"))
- (t
- (nnheader-report 'nnslashdot "Opened group %s" group)
- (nnheader-insert
- "211 %d %d %d %s\n" (cadr elem) 1 (cadr elem)
- (prin1-to-string group))))))
-
-(deffoo nnslashdot-close-group (group &optional server)
- (nnslashdot-possibly-change-server group server)
- (when (gnus-buffer-live-p nnslashdot-buffer)
- (save-excursion
- (set-buffer nnslashdot-buffer)
- (kill-buffer nnslashdot-buffer)))
- t)
-
-(deffoo nnslashdot-request-article (article &optional group server buffer)
- (nnslashdot-possibly-change-server group server)
- (let (contents cid)
- (condition-case why
- (save-excursion
- (set-buffer nnslashdot-buffer)
- (let ((case-fold-search t))
- (goto-char (point-min))
- (when (and (stringp article)
- (string-match "%\\([0-9]+\\)@" article))
- (setq cid (match-string 1 article))
- (let ((map (nth 4 (assoc group nnslashdot-groups))))
- (while map
- (if (equal (cdar map) cid)
- (setq article (caar map)
- map nil)
- (setq map (cdr map))))))
- (when (numberp article)
- (if (= article 1)
- (progn
- (search-forward "Posted by")
- (search-forward "<div class=\"intro\">")
- (setq contents
- (buffer-substring
- (point)
- (progn
- (search-forward "commentwrap")
- (match-beginning 0)))))
- (setq cid (cdr (assq article
- (nth 4 (assoc group nnslashdot-groups)))))
- (search-forward (format "<a name=\"%s\">" cid))
- (setq contents
- (buffer-substring
- (search-forward "<div class=\"commentBody\">")
- (progn
- (search-forward "<div class=\"commentSub\"")
- (match-beginning 0))))))))
- (search-failed (nnslashdot-lose why)))
-
- (when contents
- (save-excursion
- (set-buffer (or buffer nntp-server-buffer))
- (erase-buffer)
- (mm-with-unibyte-current-buffer
- (insert contents)
- (goto-char (point-min))
- (while (re-search-forward "\\(<br>\r?\\)+" nil t)
- (replace-match "<p>" t t))
- (goto-char (point-min))
- (insert "Content-Type: text/html\nMIME-Version: 1.0\n")
- (insert "Newsgroups: " (caddr (assoc group nnslashdot-groups))
- "\n")
- (let ((header (cdr (assq article nnslashdot-headers))))
- (nnheader-insert-header header))
- (nnheader-report 'nnslashdot "Fetched article %s" article))
- (cons group article)))))
-
-(deffoo nnslashdot-close-server (&optional server)
- (when (and (nnslashdot-server-opened server)
- (gnus-buffer-live-p nnslashdot-buffer))
- (save-excursion
- (set-buffer nnslashdot-buffer)
- (kill-buffer nnslashdot-buffer)))
- (nnoo-close-server 'nnslashdot server))
-
-(deffoo nnslashdot-request-list (&optional server)
- (nnslashdot-possibly-change-server nil server)
- (let ((number 0)
- (first nnslashdot-use-front-page)
- sid elem description articles gname)
- (condition-case why
- ;; First we do the Ultramode to get info on all the latest groups.
- (progn
- (mm-with-unibyte-buffer
- (mm-url-insert nnslashdot-backslash-url t)
- (goto-char (point-min))
- (if (eobp)
- (error "Couldn't open connection to slashdot"))
- (while (search-forward "<story>" nil t)
- (narrow-to-region (point) (search-forward "</story>"))
- (goto-char (point-min))
- (re-search-forward "<title>\\([^<]+\\)</title>")
- (setq description
- (mm-url-decode-entities-string (match-string 1)))
- (re-search-forward "<url>\\([^<]+\\)</url>")
- (setq sid (match-string 1))
- (string-match "sid=\\([0-9/]+\\)\\(.shtml\\|$\\)" sid)
- (setq sid (match-string 1 sid))
- (re-search-forward "<comments>\\([^<]+\\)</comments>")
- (setq articles (string-to-number (match-string 1)))
- (setq gname (concat description " (" sid ")"))
- (if (setq elem (assoc gname nnslashdot-groups))
- (setcar (cdr elem) articles)
- (push (list gname articles sid (current-time) nil)
- nnslashdot-groups))
- (goto-char (point-max))
- (widen)))
- ;; Then do the older groups.
- (while (or first
- (> (- nnslashdot-group-number number) 0))
- (setq first nil)
- (mm-with-unibyte-buffer
- (let ((case-fold-search t))
- (mm-url-insert (format nnslashdot-active-url number) t)
- (goto-char (point-min))
- (while (re-search-forward
- "article.pl\\?sid=\\([^&]+\\).*>\\([^<]+\\)</a>"
- nil t)
- (setq sid (match-string 1)
- description
- (mm-url-decode-entities-string (match-string 2)))
- (forward-line 1)
- (when (re-search-forward "with \\([0-9]+\\) comment" nil t)
- (setq articles (1+ (string-to-number (match-string 1)))))
- (setq gname (concat description " (" sid ")"))
- (if (setq elem (assoc gname nnslashdot-groups))
- (setcar (cdr elem) articles)
- (push (list gname articles sid (current-time) nil)
- nnslashdot-groups)))))
- (incf number 30)))
- (search-failed (nnslashdot-lose why)))
- (nnslashdot-write-groups)
- (nnslashdot-generate-active)
- t))
-
-(deffoo nnslashdot-request-newgroups (date &optional server)
- (nnslashdot-possibly-change-server nil server)
- (nnslashdot-generate-active)
- t)
-
-(deffoo nnslashdot-request-post (&optional server)
- (nnslashdot-possibly-change-server nil server)
- (let ((sid (message-fetch-field "newsgroups"))
- (subject (message-fetch-field "subject"))
- (references (car (last (split-string
- (message-fetch-field "references")))))
- body quoted pid)
- (string-match "%\\([0-9]+\\)@slashdot" references)
- (setq pid (match-string 1 references))
- (message-goto-body)
- (narrow-to-region (point) (progn (message-goto-signature) (point)))
- (goto-char (point-min))
- (while (not (eobp))
- (if (looking-at "> ")
- (progn
- (delete-region (point) (+ (point) 2))
- (unless quoted
- (insert "<blockquote>\n"))
- (setq quoted t))
- (when quoted
- (insert "</blockquote>\n")
- (setq quoted nil)))
- (forward-line 1))
- (goto-char (point-min))
- (while (re-search-forward "^ *\n" nil t)
- (replace-match "<p>\n"))
- (widen)
- (when (message-goto-signature)
- (forward-line -1)
- (insert "<p>\n")
- (while (not (eobp))
- (end-of-line)
- (insert "<br>")
- (forward-line 1)))
- (message-goto-body)
- (setq body (buffer-substring (point) (point-max)))
- (erase-buffer)
- (mm-url-fetch-form
- "http://slashdot.org/comments.pl"
- `(("sid" . ,sid)
- ("pid" . ,pid)
- ("rlogin" . "userlogin")
- ("unickname" . ,nnslashdot-login-name)
- ("upasswd" . ,nnslashdot-password)
- ("postersubj" . ,subject)
- ("op" . "Submit")
- ("postercomment" . ,body)
- ("posttype" . "html")))))
-
-(deffoo nnslashdot-request-delete-group (group &optional force server)
- (nnslashdot-possibly-change-server group server)
- (setq nnslashdot-groups (delq (assoc group nnslashdot-groups)
- nnslashdot-groups))
- (nnslashdot-write-groups))
-
-(deffoo nnslashdot-request-close ()
- (setq nnslashdot-headers nil
- nnslashdot-groups nil))
-
-(deffoo nnslashdot-request-expire-articles
- (articles group &optional server force)
- (nnslashdot-possibly-change-server group server)
- (let ((item (assoc group nnslashdot-groups)))
- (when item
- (if (fourth item)
- (when (and (>= (length articles) (cadr item)) ;; All are expirable.
- (nnmail-expired-article-p
- group
- (fourth item)
- force))
- (setq nnslashdot-groups (delq item nnslashdot-groups))
- (nnslashdot-write-groups)
- (setq articles nil)) ;; all expired.
- (setcdr (cddr item) (list (current-time)))
- (nnslashdot-write-groups))))
- articles)
-
-(nnoo-define-skeleton nnslashdot)
-
-;;; Internal functions
-
-(defun nnslashdot-possibly-change-server (&optional group server)
- (nnslashdot-init server)
- (when (and server
- (not (nnslashdot-server-opened server)))
- (nnslashdot-open-server server))
- (unless nnslashdot-groups
- (nnslashdot-read-groups)))
-
-(defun nnslashdot-make-tuple (tuple n)
- (prog1
- tuple
- (while (> n 1)
- (unless (cdr tuple)
- (setcdr tuple (list nil)))
- (setq tuple (cdr tuple)
- n (1- n)))))
-
-(defun nnslashdot-read-groups ()
- (let ((file (expand-file-name "groups" nnslashdot-directory)))
- (when (file-exists-p file)
- (mm-with-unibyte-buffer
- (insert-file-contents file)
- (goto-char (point-min))
- (setq nnslashdot-groups (read (current-buffer))))
- (when (and nnslashdot-groups (< (length (car nnslashdot-groups)) 5))
- (dolist (group nnslashdot-groups)
- (nnslashdot-make-tuple group 5))))))
-
-(defun nnslashdot-write-groups ()
- (with-temp-file (expand-file-name "groups" nnslashdot-directory)
- (gnus-prin1 nnslashdot-groups)))
-
-(defun nnslashdot-init (server)
- "Initialize buffers and such."
- (unless (file-exists-p nnslashdot-directory)
- (gnus-make-directory nnslashdot-directory))
- (unless (gnus-buffer-live-p nnslashdot-buffer)
- (setq nnslashdot-buffer
- (save-excursion
- (nnheader-set-temp-buffer
- (format " *nnslashdot %s*" server))))
- (push nnslashdot-buffer gnus-buffers)))
-
-(defun nnslashdot-date-to-date (sdate)
- (condition-case err
- (let ((elem (delete "" (split-string sdate))))
- (concat (substring (nth 0 elem) 0 3) " "
- (substring (nth 1 elem) 0 3) " "
- (substring (nth 2 elem) 0 2) " "
- (substring (nth 3 elem) 1 6) " "
- (format-time-string "%Y") " "
- (nth 4 elem)))
- (error "")))
-
-(defun nnslashdot-generate-active ()
- (save-excursion
- (set-buffer nntp-server-buffer)
- (erase-buffer)
- (dolist (elem nnslashdot-groups)
- (when (numberp (cadr elem))
- (insert (prin1-to-string (car elem))
- " " (number-to-string (cadr elem)) " 1 y\n")))))
-
-(defun nnslashdot-lose (why)
- (error "Slashdot HTML has changed; please get a new version of nnslashdot"))
-
-(provide 'nnslashdot)
-
-;; arch-tag: aa73df7a-f7e6-4eef-bdea-5ce2f8c691b3
-;;; nnslashdot.el ends here
diff --git a/lisp/gnus/nnsoup.el b/lisp/gnus/nnsoup.el
deleted file mode 100644
index 3cb453818bc..00000000000
--- a/lisp/gnus/nnsoup.el
+++ /dev/null
@@ -1,812 +0,0 @@
-;;; nnsoup.el --- SOUP access for Gnus
-
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
-;; Keywords: news, mail
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-(require 'nnheader)
-(require 'nnmail)
-(require 'gnus-soup)
-(require 'gnus-msg)
-(require 'nnoo)
-(eval-when-compile (require 'cl))
-
-(nnoo-declare nnsoup)
-
-(defvoo nnsoup-directory (nnheader-concat gnus-home-directory "SOUP/")
- "*SOUP packet directory.")
-
-(defvoo nnsoup-tmp-directory
- (cond ((fboundp 'temp-directory) (temp-directory))
- ((boundp 'temporary-file-directory) temporary-file-directory)
- ("/tmp/"))
- "*Where nnsoup will store temporary files.")
-
-(defvoo nnsoup-replies-directory (expand-file-name "replies/" nnsoup-directory)
- "*Directory where outgoing packets will be composed.")
-
-(defvoo nnsoup-replies-format-type ?u ;; u is USENET news format.
- "*Format of the replies packages.")
-
-(defvoo nnsoup-replies-index-type ?n
- "*Index type of the replies packages.")
-
-(defvoo nnsoup-active-file (expand-file-name "active" nnsoup-directory)
- "Active file.")
-
-(defvoo nnsoup-packer (concat "tar cf - %s | gzip > "
- (expand-file-name gnus-home-directory)
- "Soupin%d.tgz")
- "Format string command for packing a SOUP packet.
-The SOUP files will be inserted where the %s is in the string.
-This string MUST contain both %s and %d. The file number will be
-inserted where %d appears.")
-
-(defvoo nnsoup-unpacker "gunzip -c %s | tar xvf -"
- "*Format string command for unpacking a SOUP packet.
-The SOUP packet file name will be inserted at the %s.")
-
-(defvoo nnsoup-packet-directory gnus-home-directory
- "*Where nnsoup will look for incoming packets.")
-
-(defvoo nnsoup-packet-regexp "Soupout"
- "*Regular expression matching SOUP packets in `nnsoup-packet-directory'.")
-
-(defvoo nnsoup-always-save t
- "If non-nil commit the reply buffer on each message send.
-This is necessary if using message mode outside Gnus with nnsoup as a
-backend for the messages.")
-
-
-
-(defconst nnsoup-version "nnsoup 0.0"
- "nnsoup version.")
-
-(defvoo nnsoup-status-string "")
-(defvoo nnsoup-group-alist nil)
-(defvoo nnsoup-current-prefix 0)
-(defvoo nnsoup-replies-list nil)
-(defvoo nnsoup-buffers nil)
-(defvoo nnsoup-current-group nil)
-(defvoo nnsoup-group-alist-touched nil)
-(defvoo nnsoup-article-alist nil)
-
-
-;;; Interface functions.
-
-(nnoo-define-basics nnsoup)
-
-(deffoo nnsoup-retrieve-headers (sequence &optional group server fetch-old)
- (nnsoup-possibly-change-group group)
- (save-excursion
- (set-buffer nntp-server-buffer)
- (erase-buffer)
- (let ((areas (cddr (assoc nnsoup-current-group nnsoup-group-alist)))
- (articles sequence)
- (use-nov t)
- useful-areas this-area-seq msg-buf)
- (if (stringp (car sequence))
- ;; We don't support fetching by Message-ID.
- 'headers
- ;; We go through all the areas and find which files the
- ;; articles in SEQUENCE come from.
- (while (and areas sequence)
- ;; Peel off areas that are below sequence.
- (while (and areas (< (cdar (car areas)) (car sequence)))
- (setq areas (cdr areas)))
- (when areas
- ;; This is a useful area.
- (push (car areas) useful-areas)
- (setq this-area-seq nil)
- ;; We take note whether this MSG has a corresponding IDX
- ;; for later use.
- (when (or (= (gnus-soup-encoding-index
- (gnus-soup-area-encoding (nth 1 (car areas)))) ?n)
- (not (file-exists-p
- (nnsoup-file
- (gnus-soup-area-prefix (nth 1 (car areas)))))))
- (setq use-nov nil))
- ;; We assign the portion of `sequence' that is relevant to
- ;; this MSG packet to this packet.
- (while (and sequence (<= (car sequence) (cdar (car areas))))
- (push (car sequence) this-area-seq)
- (setq sequence (cdr sequence)))
- (setcar useful-areas (cons (nreverse this-area-seq)
- (car useful-areas)))))
-
- ;; We now have a list of article numbers and corresponding
- ;; areas.
- (setq useful-areas (nreverse useful-areas))
-
- ;; Two different approaches depending on whether all the MSG
- ;; files have corresponding IDX files. If they all do, we
- ;; simply return the relevant IDX files and let Gnus sort out
- ;; what lines are relevant. If some of the IDX files are
- ;; missing, we must return HEADs for all the articles.
- (if use-nov
- ;; We have IDX files for all areas.
- (progn
- (while useful-areas
- (goto-char (point-max))
- (let ((b (point))
- (number (car (nth 1 (car useful-areas))))
- (index-buffer (nnsoup-index-buffer
- (gnus-soup-area-prefix
- (nth 2 (car useful-areas))))))
- (when index-buffer
- (insert-buffer-substring index-buffer)
- (goto-char b)
- ;; We have to remove the index number entries and
- ;; insert article numbers instead.
- (while (looking-at "[0-9]+")
- (replace-match (int-to-string number) t t)
- (incf number)
- (forward-line 1))))
- (setq useful-areas (cdr useful-areas)))
- 'nov)
- ;; We insert HEADs.
- (while useful-areas
- (setq articles (caar useful-areas)
- useful-areas (cdr useful-areas))
- (while articles
- (when (setq msg-buf
- (nnsoup-narrow-to-article
- (car articles) (cdar useful-areas) 'head))
- (goto-char (point-max))
- (insert (format "221 %d Article retrieved.\n" (car articles)))
- (insert-buffer-substring msg-buf)
- (goto-char (point-max))
- (insert ".\n"))
- (setq articles (cdr articles))))
-
- (nnheader-fold-continuation-lines)
- 'headers)))))
-
-(deffoo nnsoup-open-server (server &optional defs)
- (nnoo-change-server 'nnsoup server defs)
- (when (not (file-exists-p nnsoup-directory))
- (condition-case ()
- (make-directory nnsoup-directory t)
- (error t)))
- (cond
- ((not (file-exists-p nnsoup-directory))
- (nnsoup-close-server)
- (nnheader-report 'nnsoup "Couldn't create directory: %s" nnsoup-directory))
- ((not (file-directory-p (file-truename nnsoup-directory)))
- (nnsoup-close-server)
- (nnheader-report 'nnsoup "Not a directory: %s" nnsoup-directory))
- (t
- (nnsoup-read-active-file)
- (nnheader-report 'nnsoup "Opened server %s using directory %s"
- server nnsoup-directory)
- t)))
-
-(deffoo nnsoup-request-close ()
- (nnsoup-write-active-file)
- (nnsoup-write-replies)
- (gnus-soup-save-areas)
- ;; Kill all nnsoup buffers.
- (let (buffer)
- (while nnsoup-buffers
- (setq buffer (cdr (pop nnsoup-buffers)))
- (and buffer
- (buffer-name buffer)
- (kill-buffer buffer))))
- (setq nnsoup-group-alist nil
- nnsoup-group-alist-touched nil
- nnsoup-current-group nil
- nnsoup-replies-list nil)
- (nnoo-close-server 'nnoo)
- t)
-
-(deffoo nnsoup-request-article (id &optional newsgroup server buffer)
- (nnsoup-possibly-change-group newsgroup)
- (let (buf)
- (save-excursion
- (set-buffer (or buffer nntp-server-buffer))
- (erase-buffer)
- (when (and (not (stringp id))
- (setq buf (nnsoup-narrow-to-article id)))
- (insert-buffer-substring buf)
- t))))
-
-(deffoo nnsoup-request-group (group &optional server dont-check)
- (nnsoup-possibly-change-group group)
- (if dont-check
- t
- (let ((active (cadr (assoc group nnsoup-group-alist))))
- (if (not active)
- (nnheader-report 'nnsoup "No such group: %s" group)
- (nnheader-insert
- "211 %d %d %d %s\n"
- (max (1+ (- (cdr active) (car active))) 0)
- (car active) (cdr active) group)))))
-
-(deffoo nnsoup-request-type (group &optional article)
- (nnsoup-possibly-change-group group)
- ;; Try to guess the type based on the first article in the group.
- (when (not article)
- (setq article
- (cdar (car (cddr (assoc group nnsoup-group-alist))))))
- (if (not article)
- 'unknown
- (let ((kind (gnus-soup-encoding-kind
- (gnus-soup-area-encoding
- (nth 1 (nnsoup-article-to-area
- article nnsoup-current-group))))))
- (cond ((= kind ?m) 'mail)
- ((= kind ?n) 'news)
- (t 'unknown)))))
-
-(deffoo nnsoup-close-group (group &optional server)
- ;; Kill all nnsoup buffers.
- (let ((buffers nnsoup-buffers)
- elem)
- (while buffers
- (when (equal (car (setq elem (pop buffers))) group)
- (setq nnsoup-buffers (delq elem nnsoup-buffers))
- (and (cdr elem) (buffer-name (cdr elem))
- (kill-buffer (cdr elem))))))
- t)
-
-(deffoo nnsoup-request-list (&optional server)
- (save-excursion
- (set-buffer nntp-server-buffer)
- (erase-buffer)
- (unless nnsoup-group-alist
- (nnsoup-read-active-file))
- (let ((alist nnsoup-group-alist)
- (standard-output (current-buffer))
- entry)
- (while (setq entry (pop alist))
- (insert (car entry) " ")
- (princ (cdadr entry))
- (insert " ")
- (princ (caadr entry))
- (insert " y\n"))
- t)))
-
-(deffoo nnsoup-request-scan (group &optional server)
- (nnsoup-unpack-packets))
-
-(deffoo nnsoup-request-newgroups (date &optional server)
- (nnsoup-request-list))
-
-(deffoo nnsoup-request-list-newsgroups (&optional server)
- nil)
-
-(deffoo nnsoup-request-post (&optional server)
- (nnsoup-store-reply "news")
- t)
-
-(deffoo nnsoup-request-mail (&optional server)
- (nnsoup-store-reply "mail")
- t)
-
-(deffoo nnsoup-request-expire-articles (articles group &optional server force)
- (nnsoup-possibly-change-group group)
- (let* ((total-infolist (assoc group nnsoup-group-alist))
- (active (cadr total-infolist))
- (infolist (cddr total-infolist))
- info range-list mod-time prefix)
- (while infolist
- (setq info (pop infolist)
- range-list (gnus-uncompress-range (car info))
- prefix (gnus-soup-area-prefix (nth 1 info)))
- (when;; All the articles in this file are marked for expiry.
- (and (or (setq mod-time (nth 5 (file-attributes
- (nnsoup-file prefix))))
- (setq mod-time (nth 5 (file-attributes
- (nnsoup-file prefix t)))))
- (gnus-sublist-p articles range-list)
- ;; This file is old enough.
- (nnmail-expired-article-p group mod-time force))
- ;; Ok, we delete this file.
- (when (ignore-errors
- (nnheader-message
- 5 "Deleting %s in group %s..." (nnsoup-file prefix)
- group)
- (when (file-exists-p (nnsoup-file prefix))
- (delete-file (nnsoup-file prefix)))
- (nnheader-message
- 5 "Deleting %s in group %s..." (nnsoup-file prefix t)
- group)
- (when (file-exists-p (nnsoup-file prefix t))
- (delete-file (nnsoup-file prefix t)))
- t)
- (setcdr (cdr total-infolist) (delq info (cddr total-infolist)))
- (setq articles (gnus-sorted-difference articles range-list))))
- (when (not mod-time)
- (setcdr (cdr total-infolist) (delq info (cddr total-infolist)))))
- (if (cddr total-infolist)
- (setcar active (caaadr (cdr total-infolist)))
- (setcar active (1+ (cdr active))))
- (nnsoup-write-active-file t)
- ;; Return the articles that weren't expired.
- articles))
-
-
-;;; Internal functions
-
-(defun nnsoup-possibly-change-group (group &optional force)
- (when (and group
- (not (equal nnsoup-current-group group)))
- (setq nnsoup-article-alist nil)
- (setq nnsoup-current-group group))
- t)
-
-(defun nnsoup-read-active-file ()
- (setq nnsoup-group-alist nil)
- (when (file-exists-p nnsoup-active-file)
- (ignore-errors
- (load nnsoup-active-file t t t))
- ;; Be backwards compatible.
- (when (and nnsoup-group-alist
- (not (atom (caadar nnsoup-group-alist))))
- (let ((alist nnsoup-group-alist)
- entry e min max)
- (while (setq e (cdr (setq entry (pop alist))))
- (setq min (caaar e))
- (setq max (cdar (car (last e))))
- (setcdr entry (cons (cons min max) (cdr entry)))))
- (setq nnsoup-group-alist-touched t))
- nnsoup-group-alist))
-
-(defun nnsoup-write-active-file (&optional force)
- (when (and nnsoup-group-alist
- (or force
- nnsoup-group-alist-touched))
- (setq nnsoup-group-alist-touched nil)
- (with-temp-file nnsoup-active-file
- (gnus-prin1 `(setq nnsoup-group-alist ',nnsoup-group-alist))
- (insert "\n")
- (gnus-prin1 `(setq nnsoup-current-prefix ,nnsoup-current-prefix))
- (insert "\n"))))
-
-(defun nnsoup-next-prefix ()
- "Return the next free prefix."
- (let (prefix)
- (while (or (file-exists-p
- (nnsoup-file (setq prefix (int-to-string
- nnsoup-current-prefix))))
- (file-exists-p (nnsoup-file prefix t)))
- (incf nnsoup-current-prefix))
- (incf nnsoup-current-prefix)
- prefix))
-
-(defun nnsoup-file-name (dir file)
- "Return the full name of FILE (in any case) in DIR."
- (let* ((case-fold-search t)
- (files (directory-files dir t))
- (regexp (concat (regexp-quote file) "$")))
- (car (delq nil
- (mapcar
- (lambda (file)
- (if (string-match regexp file)
- file
- nil))
- files)))))
-
-(defun nnsoup-read-areas ()
- (let ((areas-file (nnsoup-file-name nnsoup-tmp-directory "areas")))
- (when areas-file
- (save-excursion
- (set-buffer nntp-server-buffer)
- (let ((areas (gnus-soup-parse-areas areas-file))
- entry number area lnum cur-prefix file)
- ;; Go through all areas in the new AREAS file.
- (while (setq area (pop areas))
- ;; Change the name to the permanent name and move the files.
- (setq cur-prefix (nnsoup-next-prefix))
- (nnheader-message 5 "Incorporating file %s..." cur-prefix)
- (when (file-exists-p
- (setq file
- (expand-file-name
- (concat (gnus-soup-area-prefix area) ".IDX")
- nnsoup-tmp-directory)))
- (rename-file file (nnsoup-file cur-prefix)))
- (when (file-exists-p
- (setq file (expand-file-name
- (concat (gnus-soup-area-prefix area) ".MSG")
- nnsoup-tmp-directory)))
- (rename-file file (nnsoup-file cur-prefix t))
- (gnus-soup-set-area-prefix area cur-prefix)
- ;; Find the number of new articles in this area.
- (setq number (nnsoup-number-of-articles area))
- (if (not (setq entry (assoc (gnus-soup-area-name area)
- nnsoup-group-alist)))
- ;; If this is a new area (group), we just add this info to
- ;; the group alist.
- (push (list (gnus-soup-area-name area)
- (cons 1 number)
- (list (cons 1 number) area))
- nnsoup-group-alist)
- ;; There are already articles in this group, so we add this
- ;; info to the end of the entry.
- (nconc entry (list (list (cons (1+ (setq lnum (cdadr entry)))
- (+ lnum number))
- area)))
- (setcdr (cadr entry) (+ lnum number))))))
- (nnsoup-write-active-file t)
- (delete-file areas-file)))))
-
-(defun nnsoup-number-of-articles (area)
- (save-excursion
- (cond
- ;; If the number is in the area info, we just return it.
- ((gnus-soup-area-number area)
- (gnus-soup-area-number area))
- ;; If there is an index file, we just count the lines.
- ((/= (gnus-soup-encoding-index (gnus-soup-area-encoding area)) ?n)
- (set-buffer (nnsoup-index-buffer (gnus-soup-area-prefix area)))
- (count-lines (point-min) (point-max)))
- ;; We do it the hard way - re-searching through the message
- ;; buffer.
- (t
- (set-buffer (nnsoup-message-buffer (gnus-soup-area-prefix area)))
- (unless (assoc (gnus-soup-area-prefix area) nnsoup-article-alist)
- (nnsoup-dissect-buffer area))
- (length (cdr (assoc (gnus-soup-area-prefix area)
- nnsoup-article-alist)))))))
-
-(defun nnsoup-dissect-buffer (area)
- (let ((mbox-delim (concat "^" message-unix-mail-delimiter))
- (format (gnus-soup-encoding-format (gnus-soup-area-encoding area)))
- (i 0)
- alist len)
- (goto-char (point-min))
- (cond
- ;; rnews batch format
- ((or (= format ?u)
- (= format ?n)) ;; Gnus back compatibility.
- (while (looking-at "^#! *rnews \\(+[0-9]+\\) *$")
- (forward-line 1)
- (push (list
- (incf i) (point)
- (progn
- (forward-char (string-to-number (match-string 1)))
- (point)))
- alist)))
- ;; Unix mbox format
- ((= format ?m)
- (while (looking-at mbox-delim)
- (forward-line 1)
- (push (list
- (incf i) (point)
- (progn
- (if (re-search-forward mbox-delim nil t)
- (beginning-of-line)
- (goto-char (point-max)))
- (point)))
- alist)))
- ;; MMDF format
- ((= format ?M)
- (while (looking-at "\^A\^A\^A\^A\n")
- (forward-line 1)
- (push (list
- (incf i) (point)
- (progn
- (if (search-forward "\n\^A\^A\^A\^A\n" nil t)
- (beginning-of-line)
- (goto-char (point-max)))
- (point)))
- alist)))
- ;; Binary format
- ((or (= format ?B) (= format ?b))
- (while (not (eobp))
- (setq len (+ (* (char-after (point)) (expt 2.0 24))
- (* (char-after (+ (point) 1)) (expt 2 16))
- (* (char-after (+ (point) 2)) (expt 2 8))
- (char-after (+ (point) 3))))
- (push (list
- (incf i) (+ (point) 4)
- (progn
- (forward-char (floor (+ len 4)))
- (point)))
- alist)))
- (t
- (error "Unknown format: %c" format)))
- (push (cons (gnus-soup-area-prefix area) alist) nnsoup-article-alist)))
-
-(defun nnsoup-index-buffer (prefix &optional message)
- (let* ((file (concat prefix (if message ".MSG" ".IDX")))
- (buffer-name (concat " *nnsoup " file "*")))
- (or (get-buffer buffer-name) ; File already loaded.
- (when (file-exists-p (expand-file-name file nnsoup-directory))
- (save-excursion ; Load the file.
- (set-buffer (get-buffer-create buffer-name))
- (buffer-disable-undo)
- (push (cons nnsoup-current-group (current-buffer)) nnsoup-buffers)
- (nnheader-insert-file-contents
- (expand-file-name file nnsoup-directory))
- (current-buffer))))))
-
-(defun nnsoup-file (prefix &optional message)
- (expand-file-name
- (concat prefix (if message ".MSG" ".IDX"))
- nnsoup-directory))
-
-(defun nnsoup-message-buffer (prefix)
- (nnsoup-index-buffer prefix 'msg))
-
-(defun nnsoup-unpack-packets ()
- "Unpack all packets in `nnsoup-packet-directory'."
- (let ((packets (directory-files
- nnsoup-packet-directory t nnsoup-packet-regexp)))
- (dolist (packet packets)
- (nnheader-message 5 "nnsoup: unpacking %s..." packet)
- (if (not (gnus-soup-unpack-packet
- nnsoup-tmp-directory nnsoup-unpacker packet))
- (nnheader-message 5 "Couldn't unpack %s" packet)
- (delete-file packet)
- (nnsoup-read-areas)
- (nnheader-message 5 "Unpacking...done")))))
-
-(defun nnsoup-narrow-to-article (article &optional area head)
- (let* ((area (or area (nnsoup-article-to-area article nnsoup-current-group)))
- (prefix (and area (gnus-soup-area-prefix (nth 1 area))))
- (msg-buf (and prefix (nnsoup-index-buffer prefix 'msg)))
- beg end)
- (when area
- (save-excursion
- (cond
- ;; There is no MSG file.
- ((null msg-buf)
- nil)
- ;; We use the index file to find out where the article
- ;; begins and ends.
- ((and (= (gnus-soup-encoding-index
- (gnus-soup-area-encoding (nth 1 area)))
- ?c)
- (file-exists-p (nnsoup-file prefix)))
- (set-buffer (nnsoup-index-buffer prefix))
- (widen)
- (goto-char (point-min))
- (forward-line (- article (caar area)))
- (setq beg (read (current-buffer)))
- (forward-line 1)
- (if (looking-at "[0-9]+")
- (progn
- (setq end (read (current-buffer)))
- (set-buffer msg-buf)
- (widen)
- (let ((format (gnus-soup-encoding-format
- (gnus-soup-area-encoding (nth 1 area)))))
- (goto-char end)
- (when (or (= format ?u) (= format ?n) (= format ?m))
- (setq end (progn (forward-line -1) (point))))))
- (set-buffer msg-buf))
- (widen)
- (narrow-to-region beg (or end (point-max))))
- (t
- (set-buffer msg-buf)
- (widen)
- (unless (assoc (gnus-soup-area-prefix (nth 1 area))
- nnsoup-article-alist)
- (nnsoup-dissect-buffer (nth 1 area)))
- (let ((entry (assq article (cdr (assoc (gnus-soup-area-prefix
- (nth 1 area))
- nnsoup-article-alist)))))
- (when entry
- (narrow-to-region (cadr entry) (caddr entry))))))
- (goto-char (point-min))
- (if (not head)
- ()
- (narrow-to-region
- (point-min)
- (if (search-forward "\n\n" nil t)
- (1- (point))
- (point-max))))
- msg-buf))))
-
-;;;###autoload
-(defun nnsoup-pack-replies ()
- "Make an outbound package of SOUP replies."
- (interactive)
- (unless (file-exists-p nnsoup-replies-directory)
- (nnheader-message 5 "No such directory: %s" nnsoup-replies-directory))
- ;; Write all data buffers.
- (gnus-soup-save-areas)
- ;; Write the active file.
- (nnsoup-write-active-file)
- ;; Write the REPLIES file.
- (nnsoup-write-replies)
- ;; Check whether there is anything here.
- (when (null (directory-files nnsoup-replies-directory nil "\\.MSG$"))
- (error "No files to pack"))
- ;; Pack all these files into a SOUP packet.
- (gnus-soup-pack nnsoup-replies-directory nnsoup-packer))
-
-(defun nnsoup-write-replies ()
- "Write the REPLIES file."
- (when nnsoup-replies-list
- (gnus-soup-write-replies nnsoup-replies-directory nnsoup-replies-list)
- (setq nnsoup-replies-list nil)))
-
-(defun nnsoup-article-to-area (article group)
- "Return the area that ARTICLE in GROUP is located in."
- (let ((areas (cddr (assoc group nnsoup-group-alist))))
- (while (and areas (< (cdar (car areas)) article))
- (setq areas (cdr areas)))
- (and areas (car areas))))
-
-(defvar nnsoup-old-functions
- (list message-send-mail-real-function message-send-news-function))
-
-;;;###autoload
-(defun nnsoup-set-variables ()
- "Use the SOUP methods for posting news and mailing mail."
- (interactive)
- (setq message-send-news-function 'nnsoup-request-post)
- (setq message-send-mail-real-function 'nnsoup-request-mail))
-
-;;;###autoload
-(defun nnsoup-revert-variables ()
- "Revert posting and mailing methods to the standard Emacs methods."
- (interactive)
- (setq message-send-mail-real-function (car nnsoup-old-functions))
- (setq message-send-news-function (cadr nnsoup-old-functions)))
-
-(defun nnsoup-store-reply (kind)
- ;; Mostly stolen from `message.el'.
- (require 'mail-utils)
- (let ((tembuf (generate-new-buffer " message temp"))
- (case-fold-search nil)
- delimline
- (mailbuf (current-buffer)))
- (unwind-protect
- (save-excursion
- (save-restriction
- (message-narrow-to-headers)
- (if (equal kind "mail")
- (message-generate-headers message-required-mail-headers)
- (message-generate-headers message-required-news-headers)))
- (set-buffer tembuf)
- (erase-buffer)
- (insert-buffer-substring mailbuf)
- ;; Remove some headers.
- (save-restriction
- (message-narrow-to-headers)
- ;; Remove some headers.
- (message-remove-header message-ignored-mail-headers t))
- (goto-char (point-max))
- ;; require one newline at the end.
- (or (= (preceding-char) ?\n)
- (insert ?\n))
- (let ((case-fold-search t))
- ;; Change header-delimiter to be what sendmail expects.
- (goto-char (point-min))
- (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "\n"))
- (replace-match "\n")
- (backward-char 1)
- (setq delimline (point-marker))
- (goto-char (1+ delimline))
- (let ((msg-buf
- (gnus-soup-store
- nnsoup-replies-directory
- (nnsoup-kind-to-prefix kind) nil nnsoup-replies-format-type
- nnsoup-replies-index-type))
- (num 0))
- (when (and msg-buf (bufferp msg-buf))
- (save-excursion
- (set-buffer msg-buf)
- (goto-char (point-min))
- (while (re-search-forward "^#! *rnews" nil t)
- (incf num))
- (when nnsoup-always-save
- (save-buffer)))
- (nnheader-message 5 "Stored %d messages" num)))
- (nnsoup-write-replies)
- (kill-buffer tembuf))))))
-
-(defun nnsoup-kind-to-prefix (kind)
- (unless nnsoup-replies-list
- (setq nnsoup-replies-list
- (gnus-soup-parse-replies
- (expand-file-name "REPLIES" nnsoup-replies-directory))))
- (let ((replies nnsoup-replies-list))
- (while (and replies
- (not (string= kind (gnus-soup-reply-kind (car replies)))))
- (setq replies (cdr replies)))
- (if replies
- (gnus-soup-reply-prefix (car replies))
- (push (vector (gnus-soup-unique-prefix nnsoup-replies-directory)
- kind
- (format "%c%c%c"
- nnsoup-replies-format-type
- nnsoup-replies-index-type
- (if (string= kind "news")
- ?n ?m)))
- nnsoup-replies-list)
- (gnus-soup-reply-prefix (car nnsoup-replies-list)))))
-
-(defun nnsoup-make-active ()
- "(Re-)create the SOUP active file."
- (interactive)
- (let ((files (sort (directory-files nnsoup-directory t "IDX$")
- (lambda (f1 f2)
- (< (progn (string-match "/\\([0-9]+\\)\\." f1)
- (string-to-number (match-string 1 f1)))
- (progn (string-match "/\\([0-9]+\\)\\." f2)
- (string-to-number (match-string 1 f2)))))))
- active group lines ident elem min)
- (set-buffer (get-buffer-create " *nnsoup work*"))
- (dolist (file files)
- (nnheader-message 5 "Doing %s..." file)
- (erase-buffer)
- (nnheader-insert-file-contents file)
- (goto-char (point-min))
- (if (not (re-search-forward "^[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t *\\(Xref: \\)? *[^ ]* \\([^ ]+\\):[0-9]" nil t))
- (setq group "unknown")
- (setq group (match-string 2)))
- (setq lines (count-lines (point-min) (point-max)))
- (setq ident (progn (string-match
- "/\\([0-9]+\\)\\." file)
- (match-string 1 file)))
- (if (not (setq elem (assoc group active)))
- (push (list group (cons 1 lines)
- (list (cons 1 lines)
- (vector ident group "ucm" "" lines)))
- active)
- (nconc elem
- (list
- (list (cons (1+ (setq min (cdadr elem)))
- (+ min lines))
- (vector ident group "ucm" "" lines))))
- (setcdr (cadr elem) (+ min lines))))
- (nnheader-message 5 "")
- (setq nnsoup-group-alist active)
- (nnsoup-write-active-file t)))
-
-(defun nnsoup-delete-unreferenced-message-files ()
- "Delete any *.MSG and *.IDX files that aren't known by nnsoup."
- (interactive)
- (let* ((known (apply 'nconc (mapcar
- (lambda (ga)
- (mapcar
- (lambda (area)
- (gnus-soup-area-prefix (cadr area)))
- (cddr ga)))
- nnsoup-group-alist)))
- (regexp "\\.MSG$\\|\\.IDX$")
- (files (directory-files nnsoup-directory nil regexp))
- non-files)
- ;; Find all files that aren't known by nnsoup.
- (dolist (file files)
- (string-match regexp file)
- (unless (member (substring file 0 (match-beginning 0)) known)
- (push file non-files)))
- ;; Sort and delete the files.
- (setq non-files (sort non-files 'string<))
- (map-y-or-n-p "Delete file %s? "
- (lambda (file) (delete-file
- (expand-file-name file nnsoup-directory)))
- non-files)))
-
-(provide 'nnsoup)
-
-;; arch-tag: b0451389-5703-4450-9425-f66f6b38c828
-;;; nnsoup.el ends here
diff --git a/lisp/gnus/nnspool.el b/lisp/gnus/nnspool.el
index cf79613ad09..1916c1ac9ad 100644
--- a/lisp/gnus/nnspool.el
+++ b/lisp/gnus/nnspool.el
@@ -109,8 +109,7 @@ there.")
(deffoo nnspool-retrieve-headers (articles &optional group server fetch-old)
"Retrieve the headers of ARTICLES."
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(erase-buffer)
(when (nnspool-possibly-change-directory group)
(let* ((number (length articles))
@@ -209,8 +208,7 @@ there.")
(nnspool-possibly-change-directory group)
(let ((res (nnspool-request-article id)))
(when res
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(goto-char (point-min))
(when (search-forward "\n\n" nil t)
(delete-region (point-min) (point)))
@@ -221,15 +219,14 @@ there.")
(nnspool-possibly-change-directory group)
(let ((res (nnspool-request-article id)))
(when res
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(goto-char (point-min))
(when (search-forward "\n\n" nil t)
(delete-region (1- (point)) (point-max)))
(nnheader-fold-continuation-lines)))
res))
-(deffoo nnspool-request-group (group &optional server dont-check)
+(deffoo nnspool-request-group (group &optional server dont-check info)
"Select news GROUP."
(let ((pathname (nnspool-article-pathname group))
dir)
@@ -343,8 +340,7 @@ there.")
;;; Internal functions.
(defun nnspool-inews-sentinel (proc status)
- (save-excursion
- (set-buffer (process-buffer proc))
+ (with-current-buffer (process-buffer proc)
(goto-char (point-min))
(if (or (zerop (buffer-size))
(search-forward "spooled" nil t))
@@ -367,8 +363,7 @@ there.")
last)
(if (not (file-exists-p nov))
()
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(erase-buffer)
(if nnspool-sift-nov-with-sed
(nnspool-sift-nov-with-sed articles nov)
@@ -404,15 +399,16 @@ there.")
"Read the head of ARTICLE, convert to NOV headers, and insert."
(save-excursion
(let ((cur (current-buffer))
- buf)
+ buf)
(setq buf (nnheader-set-temp-buffer " *nnspool head*"))
(when (nnheader-insert-head
- (nnspool-article-pathname nnspool-current-group article))
- (nnheader-insert-article-line article)
- (let ((headers (nnheader-parse-head)))
- (set-buffer cur)
- (goto-char (point-max))
- (nnheader-insert-nov headers)))
+ (nnspool-article-pathname nnspool-current-group article))
+ (nnheader-insert-article-line article)
+ (goto-char (point-min))
+ (let ((headers (nnheader-parse-head)))
+ (set-buffer cur)
+ (goto-char (point-max))
+ (nnheader-insert-nov headers)))
(kill-buffer buf))))
(defun nnspool-sift-nov-with-sed (articles file)
@@ -458,5 +454,4 @@ there.")
(provide 'nnspool)
-;; arch-tag: bdac8d27-2934-4eee-bad0-49e6b90c0d05
;;; nnspool.el ends here
diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el
index 6e42a1fa31d..f37a1c8c48f 100644
--- a/lisp/gnus/nntp.el
+++ b/lisp/gnus/nntp.el
@@ -1,8 +1,8 @@
;;; nntp.el --- nntp access for Gnus
-;; Copyright (C) 1987, 1988, 1989, 1990, 1992, 1993,
-;; 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1987, 1988, 1989, 1990, 1992, 1993, 1994, 1995, 1996,
+;; 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+;; 2009, 2010 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
@@ -26,6 +26,10 @@
;;; Code:
+;; For Emacs <22.2 and XEmacs.
+(eval-and-compile
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
+
(require 'nnheader)
(require 'nnoo)
(require 'gnus-util)
@@ -263,6 +267,11 @@ NOTE: This variable is never seen to work in Emacs 20 and XEmacs 21.")
"*Hook run just before posting an article. It is supposed to be used
to insert Cancel-Lock headers.")
+(defvoo nntp-server-list-active-group 'try
+ "If nil, then always use GROUP instead of LIST ACTIVE.
+This is usually slower, but on misconfigured servers that don't
+update their active files often, this can help.")
+
;;; Internal variables.
(defvar nntp-record-commands nil
@@ -292,14 +301,6 @@ to insert Cancel-Lock headers.")
(defvoo nntp-inhibit-output nil)
(defvoo nntp-server-xover 'try)
-(defvoo nntp-server-list-active-group 'try)
-
-(defvar nntp-async-needs-kluge
- (string-match "^GNU Emacs 20\\.3\\." (emacs-version))
- "*When non-nil, nntp will poll asynchronous connections
-once a second. By default, this is turned on only for Emacs
-20.3, which has a bug that breaks nntp's normal method of
-noticing asynchronous data.")
(defvar nntp-async-timer nil)
(defvar nntp-async-process-list nil)
@@ -312,8 +313,8 @@ port number on server. The program should accept IMAP commands on
stdin and return responses to stdout.")
(defvar nntp-authinfo-rejected nil
-"A custom error condition used to report 'Authentication Rejected' errors.
-Condition handlers that match just this condition ensure that the nntp
+"A custom error condition used to report 'Authentication Rejected' errors.
+Condition handlers that match just this condition ensure that the nntp
backend doesn't catch this error.")
(put 'nntp-authinfo-rejected 'error-conditions '(error nntp-authinfo-rejected))
(put 'nntp-authinfo-rejected 'error-message "Authorization Rejected")
@@ -990,7 +991,7 @@ command whose response triggered the error."
"\r?\n\\.\r?\n" "BODY"
(if (numberp article) (int-to-string article) article))))
-(deffoo nntp-request-group (group &optional server dont-check)
+(deffoo nntp-request-group (group &optional server dont-check info)
(nntp-with-open-group
nil server
(when (nntp-send-command "^[245].*\n" "GROUP" group)
@@ -1017,7 +1018,8 @@ command whose response triggered the error."
(unless (assq 'nntp-address defs)
(setq defs (append defs (list (list 'nntp-address server)))))
(nnoo-change-server 'nntp server defs)
- (unless connectionless
+ (if connectionless
+ t
(or (nntp-find-connection nntp-server-buffer)
(nntp-open-connection nntp-server-buffer)))))
@@ -1112,27 +1114,17 @@ command whose response triggered the error."
t)
(deffoo nntp-request-set-mark (group actions &optional server)
- (unless nntp-marks-is-evil
+ (when (and (not nntp-marks-is-evil)
+ nntp-marks-file-name)
(nntp-possibly-create-directory group server)
(nntp-open-marks group server)
- (dolist (action actions)
- (let ((range (nth 0 action))
- (what (nth 1 action))
- (marks (nth 2 action)))
- (assert (or (eq what 'add) (eq what 'del)) nil
- "Unknown request-set-mark action: %s" what)
- (dolist (mark marks)
- (setq nntp-marks (gnus-update-alist-soft
- mark
- (funcall (if (eq what 'add) 'gnus-range-add
- 'gnus-remove-from-range)
- (cdr (assoc mark nntp-marks)) range)
- nntp-marks)))))
+ (setq nntp-marks (nnheader-update-marks-actions nntp-marks actions))
(nntp-save-marks group server))
nil)
-(deffoo nntp-request-update-info (group info &optional server)
- (unless nntp-marks-is-evil
+(deffoo nntp-request-marks (group info &optional server)
+ (when (and (not nntp-marks-is-evil)
+ nntp-marks-file-name)
(nntp-possibly-create-directory group server)
(when (nntp-marks-changed-p group server)
(nnheader-message 8 "Updating marks for %s..." group)
@@ -1168,6 +1160,11 @@ It will make innd servers spawn an nnrpd process to allow actual article
reading."
(nntp-send-command "^.*\n" "MODE READER"))
+(declare-function netrc-parse "netrc" (&optional file))
+(declare-function netrc-machine "netrc"
+ (list machine &optional port defaultport))
+(declare-function netrc-get "netrc" (alist type))
+
(defun nntp-send-authinfo (&optional send-if-force)
"Send the AUTHINFO to the nntp server.
It will look in the \"~/.authinfo\" file for matching entries. If
@@ -1176,10 +1173,11 @@ and a password.
If SEND-IF-FORCE, only send authinfo to the server if the
.authinfo file has the FORCE token."
+ (require 'netrc)
(let* ((list (netrc-parse nntp-authinfo-file))
(alist (netrc-machine list nntp-address "nntp"))
(force (or (netrc-get alist "force") nntp-authinfo-force))
- (auth-info
+ (auth-info
(auth-source-user-or-password '("login" "password") nntp-address "nntp"))
(auth-user (nth 0 auth-info))
(auth-passwd (nth 1 auth-info))
@@ -1358,17 +1356,7 @@ password contained in '~/.nntp-authinfo'."
nntp-process-decode decode
nntp-process-callback callback
nntp-process-start-point (point-max))
- (setq after-change-functions '(nntp-after-change-function))
- (if nntp-async-needs-kluge
- (nntp-async-kluge process))))
-
-(defun nntp-async-kluge (process)
- ;; emacs 20.3 bug: process output with encoding 'binary
- ;; doesn't trigger after-change-functions.
- (unless nntp-async-timer
- (setq nntp-async-timer
- (run-at-time 1 1 'nntp-async-timer-handler)))
- (add-to-list 'nntp-async-process-list process))
+ (setq after-change-functions '(nntp-after-change-function))))
(defun nntp-async-timer-handler ()
(mapcar
@@ -1773,7 +1761,7 @@ password contained in '~/.nntp-authinfo'."
(while (and (setq proc (get-buffer-process buf))
(memq (process-status proc) '(open run))
(not (re-search-forward regexp nil t)))
- (accept-process-output proc)
+ (accept-process-output proc 0.1)
(set-buffer buf)
(goto-char (point-min)))))
@@ -2018,7 +2006,7 @@ Please refer to the following variables to customize the connection:
(and nntp-pre-command (push nntp-pre-command command))
(let ((process-connection-type nil)) ;See `nntp-open-via-rlogin-and-netcat'.
(apply 'start-process "nntpd" buffer command))))
-
+
(defun nntp-open-via-telnet-and-telnet (buffer)
"Open a connection to an nntp server through an intermediate host.
@@ -2185,5 +2173,4 @@ Please refer to the following variables to customize the connection:
(provide 'nntp)
-;; arch-tag: 8655466a-b1b5-4929-9c45-7b1b2e767271
;;; nntp.el ends here
diff --git a/lisp/gnus/nnultimate.el b/lisp/gnus/nnultimate.el
deleted file mode 100644
index e65d30f2758..00000000000
--- a/lisp/gnus/nnultimate.el
+++ /dev/null
@@ -1,480 +0,0 @@
-;;; nnultimate.el --- interfacing with the Ultimate Bulletin Board system
-
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; Keywords: news
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Note: You need to have `url' and `w3' installed for this
-;; backend to work.
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-
-(require 'nnoo)
-(require 'message)
-(require 'gnus-util)
-(require 'gnus)
-(require 'nnmail)
-(require 'mm-util)
-(require 'mm-url)
-(require 'nnweb)
-(require 'parse-time)
-(autoload 'w3-parse-buffer "w3-parse")
-
-(nnoo-declare nnultimate)
-
-(defvoo nnultimate-directory (nnheader-concat gnus-directory "ultimate/")
- "Where nnultimate will save its files.")
-
-(defvoo nnultimate-address ""
- "The address of the Ultimate bulletin board.")
-
-;;; Internal variables
-
-(defvar nnultimate-groups-alist nil)
-(defvoo nnultimate-groups nil)
-(defvoo nnultimate-headers nil)
-(defvoo nnultimate-articles nil)
-(defvar nnultimate-table-regexp
- "postings.*editpost\\|forumdisplay\\|Forum[0-9]+/HTML\\|getbio")
-
-;;; Interface functions
-
-(nnoo-define-basics nnultimate)
-
-(deffoo nnultimate-retrieve-headers (articles &optional group server fetch-old)
- (nnultimate-possibly-change-server group server)
- (unless gnus-nov-is-evil
- (let* ((last (car (last articles)))
- (did nil)
- (start 1)
- (entry (assoc group nnultimate-groups))
- (sid (nth 2 entry))
- (topics (nth 4 entry))
- (mapping (nth 5 entry))
- (old-total (or (nth 6 entry) 1))
- (furl "forumdisplay.cgi?action=topics&number=%d&DaysPrune=1000")
- (furls (list (concat nnultimate-address (format furl sid))))
- (nnultimate-table-regexp
- "postings.*editpost\\|forumdisplay\\|getbio")
- headers article subject score from date lines parent point
- contents tinfo fetchers map elem a href garticles topic old-max
- inc datel table current-page total-contents pages
- farticles forum-contents parse furl-fetched mmap farticle)
- (setq map mapping)
- (while (and (setq article (car articles))
- map)
- ;; Skip past the articles in the map until we reach the
- ;; article we're looking for.
- (while (and map
- (or (> article (caar map))
- (< (cadar map) (caar map))))
- (pop map))
- (when (setq mmap (car map))
- (setq farticle -1)
- (while (and article
- (<= article (nth 1 mmap)))
- ;; Do we already have a fetcher for this topic?
- (if (setq elem (assq (nth 2 mmap) fetchers))
- ;; Yes, so we just add the spec to the end.
- (nconc elem (list (cons article
- (+ (nth 3 mmap) (incf farticle)))))
- ;; No, so we add a new one.
- (push (list (nth 2 mmap)
- (cons article
- (+ (nth 3 mmap) (incf farticle))))
- fetchers))
- (pop articles)
- (setq article (car articles)))))
- ;; Now we have the mapping from/to Gnus/nnultimate article numbers,
- ;; so we start fetching the topics that we need to satisfy the
- ;; request.
- (if (not fetchers)
- (save-excursion
- (set-buffer nntp-server-buffer)
- (erase-buffer))
- (setq nnultimate-articles nil)
- (mm-with-unibyte-buffer
- (dolist (elem fetchers)
- (setq pages 1
- current-page 1
- total-contents nil)
- (while (<= current-page pages)
- (erase-buffer)
- (setq subject (nth 2 (assq (car elem) topics)))
- (setq href (nth 3 (assq (car elem) topics)))
- (if (= current-page 1)
- (mm-url-insert href)
- (string-match "\\.html$" href)
- (mm-url-insert (concat (substring href 0 (match-beginning 0))
- "-" (number-to-string current-page)
- (match-string 0 href))))
- (goto-char (point-min))
- (setq contents
- (ignore-errors (w3-parse-buffer (current-buffer))))
- (setq table (nnultimate-find-forum-table contents))
- (goto-char (point-min))
- (when (re-search-forward "topic is \\([0-9]+\\) pages" nil t)
- (setq pages (string-to-number (match-string 1))))
- (setq contents (cdr (nth 2 (car (nth 2 table)))))
- (setq total-contents (nconc total-contents contents))
- (incf current-page))
- (when t
- (let ((i 0))
- (dolist (co total-contents)
- (push (list (or (nnultimate-topic-article-to-article
- group (car elem) (incf i))
- 1)
- co subject)
- nnultimate-articles))))
- (when nil
- (dolist (art (cdr elem))
- (when (nth (1- (cdr art)) total-contents)
- (push (list (car art)
- (nth (1- (cdr art)) total-contents)
- subject)
- nnultimate-articles))))))
- (setq nnultimate-articles
- (sort nnultimate-articles 'car-less-than-car))
- ;; Now we have all the articles, conveniently in an alist
- ;; where the key is the Gnus article number.
- (dolist (articlef nnultimate-articles)
- (setq article (nth 0 articlef)
- contents (nth 1 articlef)
- subject (nth 2 articlef))
- (setq from (mapconcat 'identity
- (nnweb-text (car (nth 2 contents)))
- " ")
- datel (nnweb-text (nth 2 (car (cdr (nth 2 contents))))))
- (while datel
- (when (string-match "Posted" (car datel))
- (setq date (substring (car datel) (match-end 0))
- datel nil))
- (pop datel))
- (when date
- (setq date (delete "" (split-string date "[-, \n\t\r ]")))
- (setq date
- (if (or (member "AM" date)
- (member "PM" date))
- (format
- "%s %s %s %s"
- (nth 1 date)
- (if (and (>= (length (nth 0 date)) 3)
- (assoc (downcase
- (substring (nth 0 date) 0 3))
- parse-time-months))
- (substring (nth 0 date) 0 3)
- (car (rassq (string-to-number (nth 0 date))
- parse-time-months)))
- (nth 2 date) (nth 3 date))
- (format "%s %s %s %s"
- (car (rassq (string-to-number (nth 1 date))
- parse-time-months))
- (nth 0 date) (nth 2 date) (nth 3 date)))))
- (push
- (cons
- article
- (make-full-mail-header
- article subject
- from (or date "")
- (concat "<" (number-to-string sid) "%"
- (number-to-string article)
- "@ultimate." server ">")
- "" 0
- (/ (length (mapconcat
- 'identity
- (nnweb-text
- (cdr (nth 2 (nth 1 (nth 2 contents)))))
- ""))
- 70)
- nil nil))
- headers))
- (setq nnultimate-headers (sort headers 'car-less-than-car))
- (save-excursion
- (set-buffer nntp-server-buffer)
- (mm-with-unibyte-current-buffer
- (erase-buffer)
- (dolist (header nnultimate-headers)
- (nnheader-insert-nov (cdr header))))))
- 'nov)))
-
-(defun nnultimate-topic-article-to-article (group topic article)
- (catch 'found
- (dolist (elem (nth 5 (assoc group nnultimate-groups)))
- (when (and (= topic (nth 2 elem))
- (>= article (nth 3 elem))
- (< article (+ (- (nth 1 elem) (nth 0 elem)) 1
- (nth 3 elem))))
- (throw 'found
- (+ (nth 0 elem) (- article (nth 3 elem))))))))
-
-(deffoo nnultimate-request-group (group &optional server dont-check)
- (nnultimate-possibly-change-server nil server)
- (when (not nnultimate-groups)
- (nnultimate-request-list))
- (unless dont-check
- (nnultimate-create-mapping group))
- (let ((elem (assoc group nnultimate-groups)))
- (cond
- ((not elem)
- (nnheader-report 'nnultimate "Group does not exist"))
- (t
- (nnheader-report 'nnultimate "Opened group %s" group)
- (nnheader-insert
- "211 %d %d %d %s\n" (cadr elem) 1 (cadr elem)
- (prin1-to-string group))))))
-
-(deffoo nnultimate-request-close ()
- (setq nnultimate-groups-alist nil
- nnultimate-groups nil))
-
-(deffoo nnultimate-request-article (article &optional group server buffer)
- (nnultimate-possibly-change-server group server)
- (let ((contents (cdr (assq article nnultimate-articles))))
- (setq contents (cddr (nth 2 (nth 1 (nth 2 (car contents))))))
- (when contents
- (save-excursion
- (set-buffer (or buffer nntp-server-buffer))
- (erase-buffer)
- (nnweb-insert-html (cons 'p (cons nil (list contents))))
- (goto-char (point-min))
- (insert "Content-Type: text/html\nMIME-Version: 1.0\n")
- (let ((header (cdr (assq article nnultimate-headers))))
- (mm-with-unibyte-current-buffer
- (nnheader-insert-header header)))
- (nnheader-report 'nnultimate "Fetched article %s" article)
- (cons group article)))))
-
-(deffoo nnultimate-request-list (&optional server)
- (nnultimate-possibly-change-server nil server)
- (mm-with-unibyte-buffer
- (mm-url-insert
- (if (string-match "/$" nnultimate-address)
- (concat nnultimate-address "Ultimate.cgi")
- nnultimate-address))
- (let ((contents (nth 2 (car (nth 2
- (nnultimate-find-forum-table
- (w3-parse-buffer (current-buffer)))))))
- sid elem description articles a href group forum
- a1 a2)
- (dolist (row contents)
- (setq row (nth 2 row))
- (when (setq a (nnweb-parse-find 'a row))
- (setq group (car (last (nnweb-text a)))
- href (cdr (assq 'href (nth 1 a))))
- (setq description (car (last (nnweb-text (nth 1 row)))))
- (setq a1 (car (last (nnweb-text (nth 2 row)))))
- (setq a2 (car (last (nnweb-text (nth 3 row)))))
- (when (string-match "^[0-9]+$" a1)
- (setq articles (string-to-number a1)))
- (when (and a2 (string-match "^[0-9]+$" a2))
- (setq articles (max articles (string-to-number a2))))
- (when href
- (string-match "number=\\([0-9]+\\)" href)
- (setq forum (string-to-number (match-string 1 href)))
- (if (setq elem (assoc group nnultimate-groups))
- (setcar (cdr elem) articles)
- (push (list group articles forum description nil nil nil nil)
- nnultimate-groups))))))
- (nnultimate-write-groups)
- (nnultimate-generate-active)
- t))
-
-(deffoo nnultimate-request-newgroups (date &optional server)
- (nnultimate-possibly-change-server nil server)
- (nnultimate-generate-active)
- t)
-
-(nnoo-define-skeleton nnultimate)
-
-;;; Internal functions
-
-(defun nnultimate-prune-days (group time)
- "Compute the number of days to fetch info for."
- (let ((old-time (nth 7 (assoc group nnultimate-groups))))
- (if (null old-time)
- 1000
- (- (time-to-days time) (time-to-days old-time)))))
-
-(defun nnultimate-create-mapping (group)
- (let* ((entry (assoc group nnultimate-groups))
- (sid (nth 2 entry))
- (topics (nth 4 entry))
- (mapping (nth 5 entry))
- (old-total (or (nth 6 entry) 1))
- (current-time (current-time))
- (furl
- (concat "forumdisplay.cgi?action=topics&number=%d&DaysPrune="
- (number-to-string
- (nnultimate-prune-days group current-time))))
- (furls (list (concat nnultimate-address (format furl sid))))
- contents forum-contents furl-fetched a subject href
- garticles topic tinfo old-max inc parse)
- (mm-with-unibyte-buffer
- (while furls
- (erase-buffer)
- (mm-url-insert (pop furls))
- (goto-char (point-min))
- (setq parse (w3-parse-buffer (current-buffer)))
- (setq contents
- (cdr (nth 2 (car (nth 2 (nnultimate-find-forum-table
- parse))))))
- (setq forum-contents (nconc contents forum-contents))
- (unless furl-fetched
- (setq furl-fetched t)
- ;; On the first time through this loop, we find all the
- ;; forum URLs.
- (dolist (a (nnweb-parse-find-all 'a parse))
- (let ((href (cdr (assq 'href (nth 1 a)))))
- (when (and href
- (string-match "forumdisplay.*startpoint" href))
- (push href furls))))
- (setq furls (nreverse furls))))
- ;; The main idea here is to map Gnus article numbers to
- ;; nnultimate article numbers. Say there are three topics in
- ;; this forum, the first with 4 articles, the seconds with 2,
- ;; and the third with 1. Then this will translate into 7 Gnus
- ;; article numbers, where 1-4 comes from the first topic, 5-6
- ;; from the second and 7 from the third. Now, then next time
- ;; the group is entered, there's 2 new articles in topic one
- ;; and 1 in topic three. Then Gnus article number 8-9 be 5-6
- ;; in topic one and 10 will be the 2 in topic three.
- (dolist (row (nreverse forum-contents))
- (setq row (nth 2 row))
- (when (setq a (nnweb-parse-find 'a row))
- (setq subject (car (last (nnweb-text a)))
- href (cdr (assq 'href (nth 1 a))))
- (let ((artlist (nreverse (nnweb-text row)))
- art)
- (while (and (not art)
- artlist)
- (when (string-match "^[0-9]+$" (car artlist))
- (setq art (1+ (string-to-number (car artlist)))))
- (pop artlist))
- (setq garticles art))
- (when garticles
- (string-match "/\\([0-9]+\\).html" href)
- (setq topic (string-to-number (match-string 1 href)))
- (if (setq tinfo (assq topic topics))
- (progn
- (setq old-max (cadr tinfo))
- (setcar (cdr tinfo) garticles))
- (setq old-max 0)
- (push (list topic garticles subject href) topics)
- (setcar (nthcdr 4 entry) topics))
- (when (not (= old-max garticles))
- (setq inc (- garticles old-max))
- (setq mapping (nconc mapping
- (list
- (list
- old-total (1- (incf old-total inc))
- topic (1+ old-max)))))
- (incf old-max inc)
- (setcar (nthcdr 5 entry) mapping)
- (setcar (nthcdr 6 entry) old-total))))))
- (setcar (nthcdr 7 entry) current-time)
- (setcar (nthcdr 1 entry) (1- old-total))
- (nnultimate-write-groups)
- mapping))
-
-(defun nnultimate-possibly-change-server (&optional group server)
- (nnultimate-init server)
- (when (and server
- (not (nnultimate-server-opened server)))
- (nnultimate-open-server server))
- (unless nnultimate-groups-alist
- (nnultimate-read-groups)
- (setq nnultimate-groups (cdr (assoc nnultimate-address
- nnultimate-groups-alist)))))
-
-(deffoo nnultimate-open-server (server &optional defs connectionless)
- (nnheader-init-server-buffer)
- (if (nnultimate-server-opened server)
- t
- (unless (assq 'nnultimate-address defs)
- (setq defs (append defs (list (list 'nnultimate-address server)))))
- (nnoo-change-server 'nnultimate server defs)))
-
-(defun nnultimate-read-groups ()
- (setq nnultimate-groups-alist nil)
- (let ((file (expand-file-name "groups" nnultimate-directory)))
- (when (file-exists-p file)
- (mm-with-unibyte-buffer
- (insert-file-contents file)
- (goto-char (point-min))
- (setq nnultimate-groups-alist (read (current-buffer)))))))
-
-(defun nnultimate-write-groups ()
- (setq nnultimate-groups-alist
- (delq (assoc nnultimate-address nnultimate-groups-alist)
- nnultimate-groups-alist))
- (push (cons nnultimate-address nnultimate-groups)
- nnultimate-groups-alist)
- (with-temp-file (expand-file-name "groups" nnultimate-directory)
- (prin1 nnultimate-groups-alist (current-buffer))))
-
-(defun nnultimate-init (server)
- "Initialize buffers and such."
- (unless (file-exists-p nnultimate-directory)
- (gnus-make-directory nnultimate-directory)))
-
-(defun nnultimate-generate-active ()
- (save-excursion
- (set-buffer nntp-server-buffer)
- (erase-buffer)
- (dolist (elem nnultimate-groups)
- (insert (prin1-to-string (car elem))
- " " (number-to-string (cadr elem)) " 1 y\n"))))
-
-(defun nnultimate-find-forum-table (contents)
- (catch 'found
- (nnultimate-find-forum-table-1 contents)))
-
-(defun nnultimate-find-forum-table-1 (contents)
- (dolist (element contents)
- (unless (stringp element)
- (when (and (eq (car element) 'table)
- (nnultimate-forum-table-p element))
- (throw 'found element))
- (when (nth 2 element)
- (nnultimate-find-forum-table-1 (nth 2 element))))))
-
-(defun nnultimate-forum-table-p (parse)
- (when (not (apply 'gnus-or
- (mapcar
- (lambda (p)
- (nnweb-parse-find 'table p))
- (nth 2 parse))))
- (let ((href (cdr (assq 'href (nth 1 (nnweb-parse-find 'a parse 20)))))
- case-fold-search)
- (when (and href (string-match nnultimate-table-regexp href))
- t))))
-
-(provide 'nnultimate)
-
-;; Local Variables:
-;; coding: iso-8859-1
-;; End:
-
-;; arch-tag: ab6bfc45-8fe1-4647-9c78-41050eb152b8
-;;; nnultimate.el ends here
diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el
index 87cfd14d821..88ff852e854 100644
--- a/lisp/gnus/nnvirtual.el
+++ b/lisp/gnus/nnvirtual.el
@@ -93,8 +93,7 @@ component group will show up when you enter the virtual group.")
(deffoo nnvirtual-retrieve-headers (articles &optional newsgroup
server fetch-old)
(when (nnvirtual-possibly-change-server server)
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(erase-buffer)
(if (stringp (car articles))
'headers
@@ -170,8 +169,7 @@ component group will show up when you enter the virtual group.")
;; the nntp-server-buffer, which is where Gnus expects to find
;; them.
(prog1
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(erase-buffer)
(insert-buffer-substring vbuf)
;; FIX FIX FIX, we should be able to sort faster than
@@ -215,8 +213,7 @@ component group will show up when you enter the virtual group.")
(t
(setq nnvirtual-last-accessed-component-group cgroup)
(if buffer
- (save-excursion
- (set-buffer buffer)
+ (with-current-buffer buffer
;; We bind this here to avoid double decoding.
(let ((gnus-article-decode-hook nil))
(gnus-request-article-this-buffer (cdr amap) cgroup)))
@@ -250,7 +247,7 @@ component group will show up when you enter the virtual group.")
t)))
-(deffoo nnvirtual-request-group (group &optional server dont-check)
+(deffoo nnvirtual-request-group (group &optional server dont-check info)
(nnvirtual-possibly-change-server server)
(setq nnvirtual-component-groups
(delete (nnvirtual-current-group) nnvirtual-component-groups))
@@ -260,13 +257,11 @@ component group will show up when you enter the virtual group.")
(nnheader-report 'nnvirtual "No component groups in %s" group))
(t
(setq nnvirtual-current-group group)
- (when (or (not dont-check)
- nnvirtual-always-rescan)
- (nnvirtual-create-mapping)
- (when nnvirtual-always-rescan
- (nnvirtual-request-update-info
- (nnvirtual-current-group)
- (gnus-get-info (nnvirtual-current-group)))))
+ (nnvirtual-create-mapping dont-check)
+ (when nnvirtual-always-rescan
+ (nnvirtual-request-update-info
+ (nnvirtual-current-group)
+ (gnus-get-info (nnvirtual-current-group))))
(nnheader-insert "211 %d 1 %d %s\n"
nnvirtual-mapping-len nnvirtual-mapping-len group))))
@@ -300,10 +295,6 @@ component group will show up when you enter the virtual group.")
t)
-(deffoo nnvirtual-request-list (&optional server)
- (nnheader-report 'nnvirtual "LIST is not implemented."))
-
-
(deffoo nnvirtual-request-newgroups (date &optional server)
(nnheader-report 'nnvirtual "NEWGROUPS is not supported."))
@@ -341,8 +332,7 @@ component group will show up when you enter the virtual group.")
(when (not (numberp (gnus-group-unread g)))
(gnus-activate-group g)))
nnvirtual-component-groups)
- (save-excursion
- (set-buffer gnus-group-buffer)
+ (with-current-buffer gnus-group-buffer
(gnus-group-catchup-current nil all)))))
@@ -674,7 +664,7 @@ the result."
carticles))
-(defun nnvirtual-create-mapping ()
+(defun nnvirtual-create-mapping (dont-check)
"Build the tables necessary to map between component (group, article) to virtual article.
Generate the set of read messages and marks for the virtual group
based on the marks on the component groups."
@@ -693,7 +683,9 @@ based on the marks on the component groups."
;; Into all-marks we put (g marks).
;; We also increment cnt and tot here, and compute M (max of sizes).
(mapc (lambda (g)
- (setq active (gnus-activate-group g)
+ (setq active (or (and dont-check
+ (gnus-active g))
+ (gnus-activate-group g))
min (car active)
max (cdr active))
(when (and active (>= max min) (not (zerop max)))
@@ -809,5 +801,4 @@ based on the marks on the component groups."
(provide 'nnvirtual)
-;; arch-tag: ca8c8ad9-1bd8-4b0f-9722-90dc645a45f5
;;; nnvirtual.el ends here
diff --git a/lisp/gnus/nnwarchive.el b/lisp/gnus/nnwarchive.el
deleted file mode 100644
index 9b4e804d48f..00000000000
--- a/lisp/gnus/nnwarchive.el
+++ /dev/null
@@ -1,727 +0,0 @@
-;;; nnwarchive.el --- interfacing with web archives
-
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
-;; Keywords: news egroups mail-archive
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Note: You need to have `url' (w3 0.46) or greater version
-;; installed for some functions of this backend to work.
-
-;; Todo:
-;; 1. To support more web archives.
-;; 2. Generalize webmail to other MHonArc archive.
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-
-(require 'nnoo)
-(require 'message)
-(require 'gnus-util)
-(require 'gnus)
-(require 'gnus-bcklg)
-(require 'nnmail)
-(require 'mm-util)
-(require 'mm-url)
-
-(nnoo-declare nnwarchive)
-
-(defvar nnwarchive-type-definition
- '((egroups
- (address . "www.egroups.com")
- (open-url
- "http://www.egroups.com/login.cgi?&login_email=%s&login_password=%s"
- nnwarchive-login nnwarchive-passwd)
- (list-url
- "http://www.egroups.com/mygroups")
- (list-dissect . nnwarchive-egroups-list)
- (list-groups . nnwarchive-egroups-list-groups)
- (xover-url
- "http://www.egroups.com/messages/%s/%d" group aux)
- (xover-last-url
- "http://www.egroups.com/messages/%s/" group)
- (xover-page-size . 13)
- (xover-dissect . nnwarchive-egroups-xover)
- (article-url
- "http://www.egroups.com/message/%s/%d?source=1" group article)
- (article-dissect . nnwarchive-egroups-article)
- (authentication . t)
- (article-offset . 0)
- (xover-files . nnwarchive-egroups-xover-files))
- (mail-archive
- (address . "www.mail-archive.com")
- (open-url)
- (list-url
- "http://www.mail-archive.com/lists.html")
- (list-dissect . nnwarchive-mail-archive-list)
- (list-groups . nnwarchive-mail-archive-list-groups)
- (xover-url
- "http://www.mail-archive.com/%s/mail%d.html" group aux)
- (xover-last-url
- "http://www.mail-archive.com/%s/maillist.html" group)
- (xover-page-size)
- (xover-dissect . nnwarchive-mail-archive-xover)
- (article-url
- "http://www.mail-archive.com/%s/msg%05d.html" group article1)
- (article-dissect . nnwarchive-mail-archive-article)
- (xover-files . nnwarchive-mail-archive-xover-files)
- (authentication)
- (article-offset . 1))))
-
-(defvar nnwarchive-default-type 'egroups)
-
-(defvoo nnwarchive-directory (nnheader-concat gnus-directory "warchive/")
- "Where nnwarchive will save its files.")
-
-(defvoo nnwarchive-type nil
- "The type of nnwarchive.")
-
-(defvoo nnwarchive-address ""
- "The address of nnwarchive.")
-
-(defvoo nnwarchive-login nil
- "Your login name for the group.")
-
-(defvoo nnwarchive-passwd nil
- "Your password for the group.")
-
-(defvoo nnwarchive-groups nil)
-
-(defvoo nnwarchive-headers-cache nil)
-
-(defvoo nnwarchive-authentication nil)
-
-(defvoo nnwarchive-nov-is-evil nil)
-
-(defconst nnwarchive-version "nnwarchive 1.0")
-
-;;; Internal variables
-
-(defvoo nnwarchive-open-url nil)
-(defvoo nnwarchive-open-dissect nil)
-
-(defvoo nnwarchive-list-url nil)
-(defvoo nnwarchive-list-dissect nil)
-(defvoo nnwarchive-list-groups nil)
-
-(defvoo nnwarchive-xover-files nil)
-(defvoo nnwarchive-xover-url nil)
-(defvoo nnwarchive-xover-last-url nil)
-(defvoo nnwarchive-xover-dissect nil)
-(defvoo nnwarchive-xover-page-size nil)
-
-(defvoo nnwarchive-article-url nil)
-(defvoo nnwarchive-article-dissect nil)
-(defvoo nnwarchive-xover-files nil)
-(defvoo nnwarchive-article-offset 0)
-
-(defvoo nnwarchive-buffer nil)
-
-(defvoo nnwarchive-keep-backlog 300)
-(defvar nnwarchive-backlog-articles nil)
-(defvar nnwarchive-backlog-hashtb nil)
-
-(defvoo nnwarchive-headers nil)
-
-
-;;; Interface functions
-
-(nnoo-define-basics nnwarchive)
-
-(defun nnwarchive-set-default (type)
- (let ((defs (cdr (assq type nnwarchive-type-definition)))
- def)
- (dolist (def defs)
- (set (intern (concat "nnwarchive-" (symbol-name (car def))))
- (cdr def)))))
-
-(defmacro nnwarchive-backlog (&rest form)
- `(let ((gnus-keep-backlog nnwarchive-keep-backlog)
- (gnus-backlog-buffer
- (format " *nnwarchive backlog %s*" nnwarchive-address))
- (gnus-backlog-articles nnwarchive-backlog-articles)
- (gnus-backlog-hashtb nnwarchive-backlog-hashtb))
- (unwind-protect
- (progn ,@form)
- (setq nnwarchive-backlog-articles gnus-backlog-articles
- nnwarchive-backlog-hashtb gnus-backlog-hashtb))))
-(put 'nnwarchive-backlog 'lisp-indent-function 0)
-(put 'nnwarchive-backlog 'edebug-form-spec '(form body))
-
-(defun nnwarchive-backlog-enter-article (group number buffer)
- (nnwarchive-backlog
- (gnus-backlog-enter-article group number buffer)))
-
-(defun nnwarchive-get-article (article &optional group server buffer)
- (if (numberp article)
- (if (nnwarchive-backlog
- (gnus-backlog-request-article group article
- (or buffer nntp-server-buffer)))
- (cons group article)
- (let (contents)
- (save-excursion
- (set-buffer nnwarchive-buffer)
- (goto-char (point-min))
- (let ((article1 (- article nnwarchive-article-offset)))
- (nnwarchive-url nnwarchive-article-url))
- (setq contents (funcall nnwarchive-article-dissect group article)))
- (when contents
- (save-excursion
- (set-buffer (or buffer nntp-server-buffer))
- (erase-buffer)
- (insert contents)
- (nnwarchive-backlog-enter-article group article (current-buffer))
- (nnheader-report 'nnwarchive "Fetched article %s" article)
- (cons group article)))))
- nil))
-
-(deffoo nnwarchive-retrieve-headers (articles &optional group server fetch-old)
- (nnwarchive-possibly-change-server group server)
- (if (or gnus-nov-is-evil nnwarchive-nov-is-evil)
- (with-temp-buffer
- (with-current-buffer nntp-server-buffer
- (erase-buffer))
- (let ((buf (current-buffer)) b e)
- (dolist (art articles)
- (nnwarchive-get-article art group server buf)
- (setq b (goto-char (point-min)))
- (if (search-forward "\n\n" nil t)
- (forward-char -1)
- (goto-char (point-max)))
- (setq e (point))
- (with-current-buffer nntp-server-buffer
- (insert (format "221 %d Article retrieved.\n" art))
- (insert-buffer-substring buf b e)
- (insert ".\n"))))
- 'headers)
- (setq nnwarchive-headers (cdr (assoc group nnwarchive-headers-cache)))
- (save-excursion
- (set-buffer nnwarchive-buffer)
- (erase-buffer)
- (funcall nnwarchive-xover-files group articles))
- (save-excursion
- (set-buffer nntp-server-buffer)
- (erase-buffer)
- (let (header)
- (dolist (art articles)
- (if (setq header (assq art nnwarchive-headers))
- (nnheader-insert-nov (cdr header))))))
- (let ((elem (assoc group nnwarchive-headers-cache)))
- (if elem
- (setcdr elem nnwarchive-headers)
- (push (cons group nnwarchive-headers) nnwarchive-headers-cache)))
- 'nov))
-
-(deffoo nnwarchive-request-group (group &optional server dont-check)
- (nnwarchive-possibly-change-server nil server)
- (when (and (not dont-check) nnwarchive-list-groups)
- (funcall nnwarchive-list-groups (list group))
- (nnwarchive-write-groups))
- (let ((elem (assoc group nnwarchive-groups)))
- (cond
- ((not elem)
- (nnheader-report 'nnwarchive "Group does not exist"))
- (t
- (nnheader-report 'nnwarchive "Opened group %s" group)
- (nnheader-insert
- "211 %d %d %d %s\n" (or (cadr elem) 0) 1 (or (cadr elem) 0)
- (prin1-to-string group))
- t))))
-
-(deffoo nnwarchive-request-article (article &optional group server buffer)
- (nnwarchive-possibly-change-server group server)
- (nnwarchive-get-article article group server buffer))
-
-(deffoo nnwarchive-close-server (&optional server)
- (when (and (nnwarchive-server-opened server)
- (gnus-buffer-live-p nnwarchive-buffer))
- (save-excursion
- (set-buffer nnwarchive-buffer)
- (kill-buffer nnwarchive-buffer)))
- (nnwarchive-backlog
- (gnus-backlog-shutdown))
- (nnoo-close-server 'nnwarchive server))
-
-(deffoo nnwarchive-request-list (&optional server)
- (nnwarchive-possibly-change-server nil server)
- (save-excursion
- (set-buffer nnwarchive-buffer)
- (erase-buffer)
- (if nnwarchive-list-url
- (nnwarchive-url nnwarchive-list-url))
- (if nnwarchive-list-dissect
- (funcall nnwarchive-list-dissect))
- (nnwarchive-write-groups)
- (nnwarchive-generate-active))
- t)
-
-(deffoo nnwarchive-open-server (server &optional defs connectionless)
- (nnoo-change-server 'nnwarchive server defs)
- (nnwarchive-init server)
- (when nnwarchive-authentication
- (setq nnwarchive-login
- (or nnwarchive-login
- (read-string
- (format "Login at %s: " server)
- user-mail-address)))
- (setq nnwarchive-passwd
- (or nnwarchive-passwd
- (read-passwd
- (format "Password for %s at %s: "
- nnwarchive-login server)))))
- (unless nnwarchive-groups
- (nnwarchive-read-groups))
- (save-excursion
- (set-buffer nnwarchive-buffer)
- (erase-buffer)
- (if nnwarchive-open-url
- (nnwarchive-url nnwarchive-open-url))
- (if nnwarchive-open-dissect
- (funcall nnwarchive-open-dissect)))
- t)
-
-(nnoo-define-skeleton nnwarchive)
-
-;;; Internal functions
-
-(defun nnwarchive-possibly-change-server (&optional group server)
- (nnwarchive-init server)
- (when (and server
- (not (nnwarchive-server-opened server)))
- (nnwarchive-open-server server)))
-
-(defun nnwarchive-read-groups ()
- (let ((file (expand-file-name (concat "groups-" nnwarchive-address)
- nnwarchive-directory)))
- (when (file-exists-p file)
- (with-temp-buffer
- (insert-file-contents file)
- (goto-char (point-min))
- (setq nnwarchive-groups (read (current-buffer)))))))
-
-(defun nnwarchive-write-groups ()
- (with-temp-file (expand-file-name (concat "groups-" nnwarchive-address)
- nnwarchive-directory)
- (prin1 nnwarchive-groups (current-buffer))))
-
-(defun nnwarchive-init (server)
- "Initialize buffers and such."
- (let ((type (intern server)) (defs nnwarchive-type-definition) def)
- (cond
- ((equal server "")
- (setq type nnwarchive-default-type))
- ((assq type nnwarchive-type-definition) t)
- (t
- (setq type nil)
- (while (setq def (pop defs))
- (when (equal (cdr (assq 'address (cdr def))) server)
- (setq defs nil)
- (setq type (car def))))
- (unless type
- (error "Undefined server %s" server))))
- (setq nnwarchive-type type))
- (unless (file-exists-p nnwarchive-directory)
- (gnus-make-directory nnwarchive-directory))
- (unless (gnus-buffer-live-p nnwarchive-buffer)
- (setq nnwarchive-buffer
- (save-excursion
- (nnheader-set-temp-buffer
- (format " *nnwarchive %s %s*" nnwarchive-type server)))))
- (nnwarchive-set-default nnwarchive-type))
-
-(defun nnwarchive-eval (expr)
- (cond
- ((consp expr)
- (cons (nnwarchive-eval (car expr)) (nnwarchive-eval (cdr expr))))
- ((symbolp expr)
- (eval expr))
- (t
- expr)))
-
-(defun nnwarchive-url (xurl)
- (mm-with-unibyte-current-buffer
- (let ((url-confirmation-func 'identity) ;; Some hacks.
- (url-cookie-multiple-line nil))
- (cond
- ((eq (car xurl) 'post)
- (pop xurl)
- (mm-url-fetch-form (car xurl) (nnwarchive-eval (cdr xurl))))
- (t
- (mm-url-insert (apply 'format (nnwarchive-eval xurl))))))))
-
-(defun nnwarchive-generate-active ()
- (save-excursion
- (set-buffer nntp-server-buffer)
- (erase-buffer)
- (dolist (elem nnwarchive-groups)
- (insert (prin1-to-string (car elem))
- " " (number-to-string (or (cadr elem) 0)) " 1 y\n"))))
-
-(defun nnwarchive-paged (articles)
- (let (art narts next)
- (while (setq art (pop articles))
- (when (and (>= art (or next 0))
- (not (assq art nnwarchive-headers)))
- (push art narts)
- (setq next (+ art nnwarchive-xover-page-size))))
- narts))
-
-;; egroups
-
-(defun nnwarchive-egroups-list-groups (groups)
- (save-excursion
- (let (articles)
- (set-buffer nnwarchive-buffer)
- (dolist (group groups)
- (erase-buffer)
- (nnwarchive-url nnwarchive-xover-last-url)
- (goto-char (point-min))
- (when (re-search-forward "of \\([0-9]+\\)[ \t\n\r]*</title>" nil t)
- (setq articles (string-to-number (match-string 1))))
- (let ((elem (assoc group nnwarchive-groups)))
- (if elem
- (setcar (cdr elem) articles)
- (push (list group articles "") nnwarchive-groups)))
- (setq nnwarchive-headers (cdr (assoc group nnwarchive-headers-cache)))
- (nnwarchive-egroups-xover group)
- (let ((elem (assoc group nnwarchive-headers-cache)))
- (if elem
- (setcdr elem nnwarchive-headers)
- (push (cons group nnwarchive-headers) nnwarchive-headers-cache)))))))
-
-(defun nnwarchive-egroups-list ()
- (let ((case-fold-search t)
- group description elem articles)
- (goto-char (point-min))
- (while
- (re-search-forward "href=\"/group/\\([^/\"\> ]+\\)" nil t)
- (setq group (match-string 1)
- description (match-string 2))
- (if (setq elem (assoc group nnwarchive-groups))
- (setcar (cdr elem) 0)
- (push (list group articles description) nnwarchive-groups))))
- t)
-
-(defun nnwarchive-egroups-xover (group)
- (let (article subject from date)
- (goto-char (point-min))
- (while (re-search-forward
- "<a href=\"/group/\\([^/]+\\)/\\([0-9]+\\)[^>]+>\\([^<]+\\)<"
- nil t)
- (setq group (match-string 1)
- article (string-to-number (match-string 2))
- subject (match-string 3))
- (forward-line 1)
- (unless (assq article nnwarchive-headers)
- (if (looking-at "<td[^>]+><font[^>]+>\\([^<]+\\)</font>")
- (setq from (match-string 1)))
- (forward-line 1)
- (if (looking-at "<td[^>]+><font[^>]+>\\([^<]+\\)</font>")
- (setq date (identity (match-string 1))))
- (push (cons
- article
- (make-full-mail-header
- article
- (mm-url-decode-entities-string subject)
- (mm-url-decode-entities-string from)
- date
- (concat "<" group "%"
- (number-to-string article)
- "@egroup.com>")
- ""
- 0 0 "")) nnwarchive-headers))))
- nnwarchive-headers)
-
-(defun nnwarchive-egroups-article (group articles)
- (goto-char (point-min))
- (if (search-forward "<pre>" nil t)
- (delete-region (point-min) (point)))
- (goto-char (point-max))
- (if (search-backward "</pre>" nil t)
- (delete-region (point) (point-max)))
- (goto-char (point-min))
- (while (re-search-forward "<a[^>]+>\\([^<]+\\)</a>" nil t)
- (replace-match "\\1"))
- (mm-url-decode-entities)
- (buffer-string))
-
-(defun nnwarchive-egroups-xover-files (group articles)
- (let (aux auxs)
- (setq auxs (nnwarchive-paged (sort articles '<)))
- (while (setq aux (pop auxs))
- (goto-char (point-max))
- (nnwarchive-url nnwarchive-xover-url))
- (if nnwarchive-xover-dissect
- (nnwarchive-egroups-xover group))))
-
-;; mail-archive
-
-(defun nnwarchive-mail-archive-list-groups (groups)
- (save-excursion
- (let (articles)
- (set-buffer nnwarchive-buffer)
- (dolist (group groups)
- (erase-buffer)
- (nnwarchive-url nnwarchive-xover-last-url)
- (goto-char (point-min))
- (when (re-search-forward "msg\\([0-9]+\\)\\.html" nil t)
- (setq articles (1+ (string-to-number (match-string 1)))))
- (let ((elem (assoc group nnwarchive-groups)))
- (if elem
- (setcar (cdr elem) articles)
- (push (list group articles "") nnwarchive-groups)))
- (setq nnwarchive-headers (cdr (assoc group nnwarchive-headers-cache)))
- (nnwarchive-mail-archive-xover group)
- (let ((elem (assoc group nnwarchive-headers-cache)))
- (if elem
- (setcdr elem nnwarchive-headers)
- (push (cons group nnwarchive-headers)
- nnwarchive-headers-cache)))))))
-
-(defun nnwarchive-mail-archive-list ()
- (let ((case-fold-search t)
- group description elem articles)
- (goto-char (point-min))
- (while (re-search-forward "<a href=\"\\([^/]+\\)/\">\\([^>]+\\)<" nil t)
- (setq group (match-string 1)
- description (match-string 2))
- (forward-line 1)
- (setq articles 0)
- (if (setq elem (assoc group nnwarchive-groups))
- (setcar (cdr elem) articles)
- (push (list group articles description) nnwarchive-groups))))
- t)
-
-(defun nnwarchive-mail-archive-xover (group)
- (let (article subject from date)
- (goto-char (point-min))
- (while (re-search-forward
- "<A[^>]*HREF=\"msg\\([0-9]+\\)\\.html[^>]+>\\([^<]+\\)<"
- nil t)
- (setq article (1+ (string-to-number (match-string 1)))
- subject (match-string 2))
- (forward-line 1)
- (unless (assq article nnwarchive-headers)
- (if (looking-at "<UL><LI><EM>From</EM>: *\\([^<]*[^< ]\\) *&lt;\\([^&]+\\)&gt;")
- (progn
- (setq from (match-string 1)
- date (identity (match-string 2))))
- (setq from "" date ""))
- (push (cons
- article
- (make-full-mail-header
- article
- (mm-url-decode-entities-string subject)
- (mm-url-decode-entities-string from)
- date
- (format "<%05d%%%s>\n" (1- article) group)
- ""
- 0 0 "")) nnwarchive-headers))))
- nnwarchive-headers)
-
-(defun nnwarchive-mail-archive-xover-files (group articles)
- (unless nnwarchive-headers
- (erase-buffer)
- (nnwarchive-url nnwarchive-xover-last-url)
- (goto-char (point-min))
- (nnwarchive-mail-archive-xover group))
- (let ((minart (apply 'min articles))
- (min (apply 'min (mapcar 'car nnwarchive-headers)))
- (aux 2))
- (while (> min minart)
- (erase-buffer)
- (nnwarchive-url nnwarchive-xover-url)
- (nnwarchive-mail-archive-xover group)
- (setq min (apply 'min (mapcar 'car nnwarchive-headers))))))
-
-(defvar nnwarchive-caesar-translation-table nil
- "Modified rot13 table. tr/@A-Z[a-z/N-Z[@A-Mn-za-m/.")
-
-(defun nnwarchive-make-caesar-translation-table ()
- "Create modified rot13 table. tr/@A-Z[a-z/N-Z[@A-Mn-za-m/."
- (let ((i -1)
- (table (make-string 256 0))
- (a (mm-char-int ?a))
- (A (mm-char-int ?A)))
- (while (< (incf i) 256)
- (aset table i i))
- (concat
- (substring table 0 (1- A))
- (substring table (+ A 13) (+ A 27))
- (substring table (1- A) (+ A 13))
- (substring table (+ A 27) a)
- (substring table (+ a 13) (+ a 26))
- (substring table a (+ a 13))
- (substring table (+ a 26) 255))))
-
-(defun nnwarchive-from-r13 (from-r13)
- (when from-r13
- (with-temp-buffer
- (insert from-r13)
- (let ((message-caesar-translation-table
- (or nnwarchive-caesar-translation-table
- (setq nnwarchive-caesar-translation-table
- (nnwarchive-make-caesar-translation-table)))))
- (message-caesar-region (point-min) (point-max))
- (buffer-string)))))
-
-(defun nnwarchive-mail-archive-article (group article)
- (let (p refs url mime e
- from subject date id
- done
- (case-fold-search t))
- (save-restriction
- (goto-char (point-min))
- (when (search-forward "X-Head-End" nil t)
- (beginning-of-line)
- (narrow-to-region (point-min) (point))
- (mm-url-decode-entities)
- (goto-char (point-min))
- (while (search-forward "<!--X-" nil t)
- (replace-match ""))
- (goto-char (point-min))
- (while (search-forward " -->" nil t)
- (replace-match ""))
- (setq from
- (or (mail-fetch-field "from")
- (nnwarchive-from-r13
- (mail-fetch-field "from-r13"))))
- (setq date (mail-fetch-field "date"))
- (setq id (mail-fetch-field "message-id"))
- (setq subject (mail-fetch-field "subject"))
- (goto-char (point-max))
- (widen))
- (when (search-forward "<ul>" nil t)
- (forward-line)
- (delete-region (point-min) (point))
- (search-forward "</ul>" nil t)
- (end-of-line)
- (narrow-to-region (point-min) (point))
- (mm-url-remove-markup)
- (mm-url-decode-entities)
- (goto-char (point-min))
- (delete-blank-lines)
- (when from
- (message-remove-header "from")
- (goto-char (point-max))
- (insert "From: " from "\n"))
- (when subject
- (message-remove-header "subject")
- (goto-char (point-max))
- (insert "Subject: " subject "\n"))
- (when id
- (goto-char (point-max))
- (insert "X-Message-ID: <" id ">\n"))
- (when date
- (message-remove-header "date")
- (goto-char (point-max))
- (insert "Date: " date "\n"))
- (goto-char (point-max))
- (widen)
- (insert "\n"))
- (setq p (point))
- (when (search-forward "X-Body-of-Message" nil t)
- (forward-line)
- (delete-region p (point))
- (search-forward "X-Body-of-Message-End" nil t)
- (beginning-of-line)
- (save-restriction
- (narrow-to-region p (point))
- (goto-char (point-min))
- (if (> (skip-chars-forward "\040\n\r\t") 0)
- (delete-region (point-min) (point)))
- (while (not (eobp))
- (cond
- ((looking-at "<PRE>\r?\n?")
- (delete-region (match-beginning 0) (match-end 0))
- (setq p (point))
- (when (search-forward "</PRE>" nil t)
- (delete-region (match-beginning 0) (match-end 0))
- (save-restriction
- (narrow-to-region p (point))
- (mm-url-remove-markup)
- (mm-url-decode-entities)
- (goto-char (point-max)))))
- ((looking-at "<P><A HREF=\"\\([^\"]+\\)")
- (setq url (match-string 1))
- (delete-region (match-beginning 0)
- (progn (forward-line) (point)))
- ;; I hate to download the url encode it, then immediately
- ;; decode it.
- (insert "<#external"
- " type="
- (or (and url
- (string-match "\\.[^\\.]+$" url)
- (mailcap-extension-to-mime
- (match-string 0 url)))
- "application/octet-stream")
- (format " url=\"http://www.mail-archive.com/%s/%s\""
- group url)
- ">\n"
- "<#/external>")
- (setq mime t))
- (t
- (setq p (point))
- (insert "<#part type=\"text/html\" disposition=inline>")
- (goto-char
- (if (re-search-forward
- "[\040\n\r\t]*<PRE>\\|[\040\n\r\t]*<P><A HREF=\""
- nil t)
- (match-beginning 0)
- (point-max)))
- (insert "<#/part>")
- (setq mime t)))
- (setq p (point))
- (if (> (skip-chars-forward "\040\n\r\t") 0)
- (delete-region p (point))))
- (goto-char (point-max))))
- (setq p (point))
- (when (search-forward "X-References-End" nil t)
- (setq e (point))
- (beginning-of-line)
- (search-backward "X-References" p t)
- (while (re-search-forward "msg\\([0-9]+\\)\\.html" e t)
- (push (concat "<" (match-string 1) "%" group ">") refs)))
- (delete-region p (point-max))
- (goto-char (point-min))
- (insert (format "Message-ID: <%05d%%%s>\n" (1- article) group))
- (when refs
- (insert "References:")
- (while refs
- (insert " " (pop refs)))
- (insert "\n"))
- (when mime
- (unless (looking-at "$")
- (search-forward "\n\n" nil t)
- (forward-line -1))
- (narrow-to-region (point) (point-max))
- (insert "MIME-Version: 1.0\n"
- (prog1
- (mml-generate-mime)
- (delete-region (point-min) (point-max))))
- (widen)))
- (buffer-string)))
-
-(provide 'nnwarchive)
-
-;; arch-tag: 1ab7a15c-777a-40e0-95c0-0c41b3963578
-;;; nnwarchive.el ends here
diff --git a/lisp/gnus/nnweb.el b/lisp/gnus/nnweb.el
index b6b0ddd41a9..ac643f9ed1f 100644
--- a/lisp/gnus/nnweb.el
+++ b/lisp/gnus/nnweb.el
@@ -104,8 +104,7 @@ Valid types include `google', `dejanews', and `gmane'.")
(deffoo nnweb-retrieve-headers (articles &optional group server fetch-old)
(nnweb-possibly-change-server group server)
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(erase-buffer)
(let (article header)
(mm-with-unibyte-current-buffer
@@ -125,7 +124,7 @@ Valid types include `google', `dejanews', and `gmane'.")
(nnweb-write-active)
(nnweb-write-overview group)))
-(deffoo nnweb-request-group (group &optional server dont-check)
+(deffoo nnweb-request-group (group &optional server dont-check info)
(nnweb-possibly-change-server group server)
(unless (or nnweb-ephemeral-p
dont-check
@@ -147,16 +146,14 @@ Valid types include `google', `dejanews', and `gmane'.")
(deffoo nnweb-close-group (group &optional server)
(nnweb-possibly-change-server group server)
(when (gnus-buffer-live-p nnweb-buffer)
- (save-excursion
- (set-buffer nnweb-buffer)
+ (with-current-buffer nnweb-buffer
(set-buffer-modified-p nil)
(kill-buffer nnweb-buffer)))
t)
(deffoo nnweb-request-article (article &optional group server buffer)
(nnweb-possibly-change-server group server)
- (save-excursion
- (set-buffer (or buffer nntp-server-buffer))
+ (with-current-buffer (or buffer nntp-server-buffer)
(let* ((header (cadr (assq article nnweb-articles)))
(url (and header (mail-header-xref header))))
(when (or (and url
@@ -185,21 +182,18 @@ Valid types include `google', `dejanews', and `gmane'.")
(deffoo nnweb-close-server (&optional server)
(when (and (nnweb-server-opened server)
(gnus-buffer-live-p nnweb-buffer))
- (save-excursion
- (set-buffer nnweb-buffer)
+ (with-current-buffer nnweb-buffer
(set-buffer-modified-p nil)
(kill-buffer nnweb-buffer)))
(nnoo-close-server 'nnweb server))
(deffoo nnweb-request-list (&optional server)
(nnweb-possibly-change-server nil server)
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(nnmail-generate-active (list (assoc server nnweb-group-alist)))
t))
-(deffoo nnweb-request-update-info (group info &optional server)
- (nnweb-possibly-change-server group server))
+(deffoo nnweb-request-update-info (group info &optional server))
(deffoo nnweb-asynchronous-p ()
nil)
@@ -213,7 +207,7 @@ Valid types include `google', `dejanews', and `gmane'.")
(deffoo nnweb-request-delete-group (group &optional force server)
(nnweb-possibly-change-server group server)
- (gnus-pull group nnweb-group-alist t)
+ (gnus-alist-pull group nnweb-group-alist t)
(nnweb-write-active)
(gnus-delete-file (nnweb-overview-file group))
t)
@@ -402,8 +396,7 @@ Valid types include `google', `dejanews', and `gmane'.")
(defun nnweb-google-create-mapping ()
"Perform the search and create a number-to-url alist."
- (save-excursion
- (set-buffer nnweb-buffer)
+ (with-current-buffer nnweb-buffer
(erase-buffer)
(nnheader-message 7 "Searching google...")
(when (funcall (nnweb-definition 'search) nnweb-search)
@@ -459,8 +452,7 @@ Valid types include `google', `dejanews', and `gmane'.")
;;;
(defun nnweb-gmane-create-mapping ()
"Perform the search and create a number-to-url alist."
- (save-excursion
- (set-buffer nnweb-buffer)
+ (with-current-buffer nnweb-buffer
(let ((case-fold-search t)
(active (or (cadr (assoc nnweb-group nnweb-group-alist))
(cons 1 0)))
@@ -525,7 +517,7 @@ Valid types include `google', `dejanews', and `gmane'.")
;;("TOPDOC" . "1000")
))))
(setq buffer-file-name nil)
- (set-buffer-multibyte t)
+ (unless (featurep 'xemacs) (set-buffer-multibyte t))
(mm-decode-coding-region (point-min) (point-max) 'utf-8)
t)
@@ -612,5 +604,4 @@ Valid types include `google', `dejanews', and `gmane'.")
(provide 'nnweb)
-;; arch-tag: f59307eb-c90f-479f-b7d2-dbd8bf51b697
;;; nnweb.el ends here
diff --git a/lisp/gnus/nnwfm.el b/lisp/gnus/nnwfm.el
deleted file mode 100644
index fceb3ccd6ad..00000000000
--- a/lisp/gnus/nnwfm.el
+++ /dev/null
@@ -1,432 +0,0 @@
-;;; nnwfm.el --- interfacing with a web forum
-
-;; Copyright (C) 2000, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; Keywords: news
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Note: You need to have `url' and `w3' installed for this
-;; backend to work.
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-
-(require 'nnoo)
-(require 'message)
-(require 'gnus-util)
-(require 'gnus)
-(require 'nnmail)
-(require 'mm-util)
-(require 'mm-url)
-(require 'nnweb)
-(autoload 'w3-parse-buffer "w3-parse")
-
-(nnoo-declare nnwfm)
-
-(defvoo nnwfm-directory (nnheader-concat gnus-directory "wfm/")
- "Where nnwfm will save its files.")
-
-(defvoo nnwfm-address ""
- "The address of the Ultimate bulletin board.")
-
-;;; Internal variables
-
-(defvar nnwfm-groups-alist nil)
-(defvoo nnwfm-groups nil)
-(defvoo nnwfm-headers nil)
-(defvoo nnwfm-articles nil)
-(defvar nnwfm-table-regexp
- "postings.*editpost\\|forumdisplay\\|Forum[0-9]+/HTML\\|getbio")
-
-;;; Interface functions
-
-(nnoo-define-basics nnwfm)
-
-(deffoo nnwfm-retrieve-headers (articles &optional group server fetch-old)
- (nnwfm-possibly-change-server group server)
- (unless gnus-nov-is-evil
- (let* ((last (car (last articles)))
- (did nil)
- (start 1)
- (entry (assoc group nnwfm-groups))
- (sid (nth 2 entry))
- (topics (nth 4 entry))
- (mapping (nth 5 entry))
- (old-total (or (nth 6 entry) 1))
- (nnwfm-table-regexp "Thread.asp")
- headers article subject score from date lines parent point
- contents tinfo fetchers map elem a href garticles topic old-max
- inc datel table string current-page total-contents pages
- farticles forum-contents parse furl-fetched mmap farticle
- thread-id tables hstuff bstuff time)
- (setq map mapping)
- (while (and (setq article (car articles))
- map)
- (while (and map
- (or (> article (caar map))
- (< (cadar map) (caar map))))
- (pop map))
- (when (setq mmap (car map))
- (setq farticle -1)
- (while (and article
- (<= article (nth 1 mmap)))
- ;; Do we already have a fetcher for this topic?
- (if (setq elem (assq (nth 2 mmap) fetchers))
- ;; Yes, so we just add the spec to the end.
- (nconc elem (list (cons article
- (+ (nth 3 mmap) (incf farticle)))))
- ;; No, so we add a new one.
- (push (list (nth 2 mmap)
- (cons article
- (+ (nth 3 mmap) (incf farticle))))
- fetchers))
- (pop articles)
- (setq article (car articles)))))
- ;; Now we have the mapping from/to Gnus/nnwfm article numbers,
- ;; so we start fetching the topics that we need to satisfy the
- ;; request.
- (if (not fetchers)
- (save-excursion
- (set-buffer nntp-server-buffer)
- (erase-buffer))
- (setq nnwfm-articles nil)
- (mm-with-unibyte-buffer
- (dolist (elem fetchers)
- (erase-buffer)
- (setq subject (nth 2 (assq (car elem) topics))
- thread-id (nth 0 (assq (car elem) topics)))
- (mm-url-insert
- (concat nnwfm-address
- (format "Item.asp?GroupID=%d&ThreadID=%d" sid
- thread-id)))
- (goto-char (point-min))
- (setq tables (caddar
- (caddar
- (cdr (caddar
- (caddar
- (ignore-errors
- (w3-parse-buffer (current-buffer)))))))))
- (setq tables (cdr (caddar (memq (assq 'div tables) tables))))
- (setq contents nil)
- (dolist (table tables)
- (when (eq (car table) 'table)
- (setq table (caddar (caddar (caddr table)))
- hstuff (delete ":link" (nnweb-text (car table)))
- bstuff (car (caddar (cdr table)))
- from (car hstuff))
- (when (nth 2 hstuff)
- (setq time (nnwfm-date-to-time (nth 2 hstuff)))
- (push (list from time bstuff) contents))))
- (setq contents (nreverse contents))
- (dolist (art (cdr elem))
- (push (list (car art)
- (nth (1- (cdr art)) contents)
- subject)
- nnwfm-articles))))
- (setq nnwfm-articles
- (sort nnwfm-articles 'car-less-than-car))
- ;; Now we have all the articles, conveniently in an alist
- ;; where the key is the Gnus article number.
- (dolist (articlef nnwfm-articles)
- (setq article (nth 0 articlef)
- contents (nth 1 articlef)
- subject (nth 2 articlef))
- (setq from (nth 0 contents)
- date (message-make-date (nth 1 contents)))
- (push
- (cons
- article
- (make-full-mail-header
- article subject
- from (or date "")
- (concat "<" (number-to-string sid) "%"
- (number-to-string article)
- "@wfm>")
- "" 0
- (/ (length (mapconcat 'identity (nnweb-text (nth 2 contents)) ""))
- 70)
- nil nil))
- headers))
- (setq nnwfm-headers (sort headers 'car-less-than-car))
- (save-excursion
- (set-buffer nntp-server-buffer)
- (mm-with-unibyte-current-buffer
- (erase-buffer)
- (dolist (header nnwfm-headers)
- (nnheader-insert-nov (cdr header))))))
- 'nov)))
-
-(deffoo nnwfm-request-group (group &optional server dont-check)
- (nnwfm-possibly-change-server nil server)
- (when (not nnwfm-groups)
- (nnwfm-request-list))
- (unless dont-check
- (nnwfm-create-mapping group))
- (let ((elem (assoc group nnwfm-groups)))
- (cond
- ((not elem)
- (nnheader-report 'nnwfm "Group does not exist"))
- (t
- (nnheader-report 'nnwfm "Opened group %s" group)
- (nnheader-insert
- "211 %d %d %d %s\n" (cadr elem) 1 (cadr elem)
- (prin1-to-string group))))))
-
-(deffoo nnwfm-request-close ()
- (setq nnwfm-groups-alist nil
- nnwfm-groups nil))
-
-(deffoo nnwfm-request-article (article &optional group server buffer)
- (nnwfm-possibly-change-server group server)
- (let ((contents (cdr (assq article nnwfm-articles))))
- (when (setq contents (nth 2 (car contents)))
- (save-excursion
- (set-buffer (or buffer nntp-server-buffer))
- (erase-buffer)
- (nnweb-insert-html contents)
- (goto-char (point-min))
- (insert "Content-Type: text/html\nMIME-Version: 1.0\n")
- (let ((header (cdr (assq article nnwfm-headers))))
- (mm-with-unibyte-current-buffer
- (nnheader-insert-header header)))
- (nnheader-report 'nnwfm "Fetched article %s" article)
- (cons group article)))))
-
-(deffoo nnwfm-request-list (&optional server)
- (nnwfm-possibly-change-server nil server)
- (mm-with-unibyte-buffer
- (mm-url-insert
- (if (string-match "/$" nnwfm-address)
- (concat nnwfm-address "Group.asp")
- nnwfm-address))
- (let* ((nnwfm-table-regexp "Thread.asp")
- (contents (w3-parse-buffer (current-buffer)))
- sid elem description articles a href group forum
- a1 a2)
- (dolist (row (cdr (nth 2 (car (nth 2 (nnwfm-find-forum-table
- contents))))))
- (setq row (nth 2 row))
- (when (setq a (nnweb-parse-find 'a row))
- (setq group (car (last (nnweb-text a)))
- href (cdr (assq 'href (nth 1 a))))
- (setq description (car (last (nnweb-text (nth 1 row)))))
- (setq articles
- (string-to-number
- (gnus-replace-in-string
- (car (last (nnweb-text (nth 3 row)))) "," "")))
- (when (and href
- (string-match "GroupId=\\([0-9]+\\)" href))
- (setq forum (string-to-number (match-string 1 href)))
- (if (setq elem (assoc group nnwfm-groups))
- (setcar (cdr elem) articles)
- (push (list group articles forum description nil nil nil nil)
- nnwfm-groups))))))
- (nnwfm-write-groups)
- (nnwfm-generate-active)
- t))
-
-(deffoo nnwfm-request-newgroups (date &optional server)
- (nnwfm-possibly-change-server nil server)
- (nnwfm-generate-active)
- t)
-
-(nnoo-define-skeleton nnwfm)
-
-;;; Internal functions
-
-(defun nnwfm-new-threads-p (group time)
- "See whether we want to fetch the threads for GROUP written before TIME."
- (let ((old-time (nth 7 (assoc group nnwfm-groups))))
- (or (null old-time)
- (time-less-p old-time time))))
-
-(defun nnwfm-create-mapping (group)
- (let* ((entry (assoc group nnwfm-groups))
- (sid (nth 2 entry))
- (topics (nth 4 entry))
- (mapping (nth 5 entry))
- (old-total (or (nth 6 entry) 1))
- (current-time (current-time))
- (nnwfm-table-regexp "Thread.asp")
- (furls (list (concat nnwfm-address
- (format "Thread.asp?GroupId=%d" sid))))
- fetched-urls
- contents forum-contents a subject href
- garticles topic tinfo old-max inc parse elem date
- url time)
- (mm-with-unibyte-buffer
- (while furls
- (erase-buffer)
- (push (car furls) fetched-urls)
- (mm-url-insert (pop furls))
- (goto-char (point-min))
- (while (re-search-forward " wr(" nil t)
- (forward-char -1)
- (setq elem (message-tokenize-header
- (gnus-replace-in-string
- (buffer-substring
- (1+ (point))
- (progn
- (forward-sexp 1)
- (1- (point))))
- "\\\\[\"\\\\]" "")))
- (push (list
- (string-to-number (nth 1 elem))
- (gnus-replace-in-string (nth 2 elem) "\"" "")
- (string-to-number (nth 5 elem)))
- forum-contents))
- (when (re-search-forward "href=\"\\(Thread.*DateLast=\\([^\"]+\\)\\)"
- nil t)
- (setq url (match-string 1)
- time (nnwfm-date-to-time (gnus-url-unhex-string
- (match-string 2))))
- (when (and (nnwfm-new-threads-p group time)
- (not (member
- (setq url (concat
- nnwfm-address
- (mm-url-decode-entities-string url)))
- fetched-urls)))
- (push url furls))))
- ;; The main idea here is to map Gnus article numbers to
- ;; nnwfm article numbers. Say there are three topics in
- ;; this forum, the first with 4 articles, the seconds with 2,
- ;; and the third with 1. Then this will translate into 7 Gnus
- ;; article numbers, where 1-4 comes from the first topic, 5-6
- ;; from the second and 7 from the third. Now, then next time
- ;; the group is entered, there's 2 new articles in topic one
- ;; and 1 in topic three. Then Gnus article number 8-9 be 5-6
- ;; in topic one and 10 will be the 2 in topic three.
- (dolist (elem (nreverse forum-contents))
- (setq subject (nth 1 elem)
- topic (nth 0 elem)
- garticles (nth 2 elem))
- (if (setq tinfo (assq topic topics))
- (progn
- (setq old-max (cadr tinfo))
- (setcar (cdr tinfo) garticles))
- (setq old-max 0)
- (push (list topic garticles subject) topics)
- (setcar (nthcdr 4 entry) topics))
- (when (not (= old-max garticles))
- (setq inc (- garticles old-max))
- (setq mapping (nconc mapping
- (list
- (list
- old-total (1- (incf old-total inc))
- topic (1+ old-max)))))
- (incf old-max inc)
- (setcar (nthcdr 5 entry) mapping)
- (setcar (nthcdr 6 entry) old-total))))
- (setcar (nthcdr 7 entry) current-time)
- (setcar (nthcdr 1 entry) (1- old-total))
- (nnwfm-write-groups)
- mapping))
-
-(defun nnwfm-possibly-change-server (&optional group server)
- (nnwfm-init server)
- (when (and server
- (not (nnwfm-server-opened server)))
- (nnwfm-open-server server))
- (unless nnwfm-groups-alist
- (nnwfm-read-groups)
- (setq nnwfm-groups (cdr (assoc nnwfm-address
- nnwfm-groups-alist)))))
-
-(deffoo nnwfm-open-server (server &optional defs connectionless)
- (nnheader-init-server-buffer)
- (if (nnwfm-server-opened server)
- t
- (unless (assq 'nnwfm-address defs)
- (setq defs (append defs (list (list 'nnwfm-address server)))))
- (nnoo-change-server 'nnwfm server defs)))
-
-(defun nnwfm-read-groups ()
- (setq nnwfm-groups-alist nil)
- (let ((file (expand-file-name "groups" nnwfm-directory)))
- (when (file-exists-p file)
- (mm-with-unibyte-buffer
- (insert-file-contents file)
- (goto-char (point-min))
- (setq nnwfm-groups-alist (read (current-buffer)))))))
-
-(defun nnwfm-write-groups ()
- (setq nnwfm-groups-alist
- (delq (assoc nnwfm-address nnwfm-groups-alist)
- nnwfm-groups-alist))
- (push (cons nnwfm-address nnwfm-groups)
- nnwfm-groups-alist)
- (with-temp-file (expand-file-name "groups" nnwfm-directory)
- (prin1 nnwfm-groups-alist (current-buffer))))
-
-(defun nnwfm-init (server)
- "Initialize buffers and such."
- (unless (file-exists-p nnwfm-directory)
- (gnus-make-directory nnwfm-directory)))
-
-(defun nnwfm-generate-active ()
- (save-excursion
- (set-buffer nntp-server-buffer)
- (erase-buffer)
- (dolist (elem nnwfm-groups)
- (insert (prin1-to-string (car elem))
- " " (number-to-string (cadr elem)) " 1 y\n"))))
-
-(defun nnwfm-find-forum-table (contents)
- (catch 'found
- (nnwfm-find-forum-table-1 contents)))
-
-(defun nnwfm-find-forum-table-1 (contents)
- (dolist (element contents)
- (unless (stringp element)
- (when (and (eq (car element) 'table)
- (nnwfm-forum-table-p element))
- (throw 'found element))
- (when (nth 2 element)
- (nnwfm-find-forum-table-1 (nth 2 element))))))
-
-(defun nnwfm-forum-table-p (parse)
- (when (not (apply 'gnus-or
- (mapcar
- (lambda (p)
- (nnweb-parse-find 'table p))
- (nth 2 parse))))
- (let ((href (cdr (assq 'href (nth 1 (nnweb-parse-find 'a parse 20)))))
- case-fold-search)
- (when (and href (string-match nnwfm-table-regexp href))
- t))))
-
-(defun nnwfm-date-to-time (date)
- (let ((time (mapcar #'string-to-number (split-string date "[\\.\\+ :]"))))
- (encode-time 0 (nth 4 time) (nth 3 time)
- (nth 0 time) (nth 1 time)
- (if (< (nth 2 time) 70)
- (+ 2000 (nth 2 time))
- (+ 1900 (nth 2 time))))))
-
-(provide 'nnwfm)
-
-;; Local Variables:
-;; coding: iso-8859-1
-;; End:
-
-;; arch-tag: d813966a-4211-4557-ad11-d1ac2bc86536
-;;; nnwfm.el ends here
diff --git a/lisp/gnus/pop3.el b/lisp/gnus/pop3.el
index b445b8979ea..eef53c2797d 100644
--- a/lisp/gnus/pop3.el
+++ b/lisp/gnus/pop3.el
@@ -33,6 +33,7 @@
;;; Code:
+(eval-when-compile (require 'cl))
(require 'mail-utils)
(defvar parse-time-months)
@@ -81,6 +82,15 @@ valid value is 'apop'."
:version "22.1" ;; Oort Gnus
:group 'pop3)
+(defcustom pop3-stream-length 100
+ "How many messages should be requested at one time.
+The lower the number, the more latency-sensitive the fetching
+will be. If your pop3 server doesn't support streaming at all,
+set this to 1."
+ :type 'number
+ :version "24.1"
+ :group 'pop3)
+
(defcustom pop3-leave-mail-on-server nil
"*Non-nil if the mail is to be left on the POP server after fetching.
@@ -114,7 +124,7 @@ Used for APOP authentication.")
(defalias 'pop3-accept-process-output 'nnheader-accept-process-output)
;; Borrowed from `nnheader.el':
(defvar pop3-read-timeout
- (if (string-match "windows-nt\\|os/2\\|emx\\|cygwin"
+ (if (string-match "windows-nt\\|os/2\\|cygwin"
(symbol-name system-type))
1.0
0.01)
@@ -128,14 +138,92 @@ Shorter values mean quicker response, but are more CPU intensive.")
(truncate pop3-read-timeout))
1000))))))
-(defun pop3-movemail (&optional crashbox)
- "Transfer contents of a maildrop to the specified CRASHBOX."
- (or crashbox (setq crashbox (expand-file-name "~/.crashbox")))
+;;;###autoload
+(defun pop3-movemail (file)
+ "Transfer contents of a maildrop to the specified FILE.
+Use streaming commands."
(let* ((process (pop3-open-server pop3-mailhost pop3-port))
- (crashbuf (get-buffer-create " *pop3-retr*"))
- (n 1)
- message-count
- (pop3-password pop3-password))
+ message-count message-total-size)
+ (pop3-logon process)
+ (with-current-buffer (process-buffer process)
+ (let ((size (pop3-stat process)))
+ (setq message-count (car size)
+ message-total-size (cadr size)))
+ (when (> message-count 0)
+ (pop3-send-streaming-command
+ process "RETR" message-count message-total-size)
+ (pop3-write-to-file file)
+ (unless pop3-leave-mail-on-server
+ (pop3-send-streaming-command
+ process "DELE" message-count nil))))
+ (pop3-quit process)
+ t))
+
+(defun pop3-send-streaming-command (process command count total-size)
+ (erase-buffer)
+ (let ((i 1))
+ (while (>= count i)
+ (process-send-string process (format "%s %d\r\n" command i))
+ ;; Only do 100 messages at a time to avoid pipe stalls.
+ (when (zerop (% i pop3-stream-length))
+ (pop3-wait-for-messages process i total-size))
+ (incf i)))
+ (pop3-wait-for-messages process count total-size))
+
+(defun pop3-wait-for-messages (process count total-size)
+ (while (< (pop3-number-of-responses total-size) count)
+ (when total-size
+ (message "pop3 retrieved %dKB (%d%%)"
+ (truncate (/ (buffer-size) 1000))
+ (truncate (* (/ (* (buffer-size) 1.0)
+ total-size) 100))))
+ (pop3-accept-process-output process)))
+
+(defun pop3-write-to-file (file)
+ (let ((pop-buffer (current-buffer))
+ (start (point-min))
+ beg end
+ temp-buffer)
+ (with-temp-buffer
+ (setq temp-buffer (current-buffer))
+ (with-current-buffer pop-buffer
+ (goto-char (point-min))
+ (while (re-search-forward "^\\+OK" nil t)
+ (forward-line 1)
+ (setq beg (point))
+ (when (re-search-forward "^\\.\r?\n" nil t)
+ (setq start (point))
+ (forward-line -1)
+ (setq end (point)))
+ (with-current-buffer temp-buffer
+ (goto-char (point-max))
+ (let ((hstart (point)))
+ (insert-buffer-substring pop-buffer beg end)
+ (pop3-clean-region hstart (point))
+ (goto-char (point-max))
+ (pop3-munge-message-separator hstart (point))
+ (goto-char (point-max))))))
+ (let ((coding-system-for-write 'binary))
+ (goto-char (point-min))
+ ;; Check whether something inserted a newline at the start and
+ ;; delete it.
+ (when (eolp)
+ (delete-char 1))
+ (write-region (point-min) (point-max) file nil 'nomesg)))))
+
+(defun pop3-number-of-responses (endp)
+ (let ((responses 0))
+ (save-excursion
+ (goto-char (point-min))
+ (while (or (and (re-search-forward "^\\+OK" nil t)
+ (or (not endp)
+ (re-search-forward "^\\.\r?\n" nil t)))
+ (re-search-forward "^-ERR " nil t))
+ (incf responses)))
+ responses))
+
+(defun pop3-logon (process)
+ (let ((pop3-password pop3-password))
;; for debugging only
(if pop3-debug (switch-to-buffer (process-buffer process)))
;; query for password
@@ -147,34 +235,7 @@ Shorter values mean quicker response, but are more CPU intensive.")
((equal 'pass pop3-authentication-scheme)
(pop3-user process pop3-maildrop)
(pop3-pass process))
- (t (error "Invalid POP3 authentication scheme")))
- (setq message-count (car (pop3-stat process)))
- (unwind-protect
- (while (<= n message-count)
- (message "Retrieving message %d of %d from %s..."
- n message-count pop3-mailhost)
- (pop3-retr process n crashbuf)
- (save-excursion
- (set-buffer crashbuf)
- (let ((coding-system-for-write 'binary))
- (write-region (point-min) (point-max) crashbox t 'nomesg))
- (set-buffer (process-buffer process))
- (while (> (buffer-size) 5000)
- (goto-char (point-min))
- (forward-line 50)
- (delete-region (point-min) (point))))
- (unless pop3-leave-mail-on-server
- (pop3-dele process n))
- (setq n (+ 1 n))
- (pop3-accept-process-output process))
- (when (and pop3-leave-mail-on-server
- (> n 1))
- (message "pop3.el doesn't support UIDL. Setting `pop3-leave-mail-on-server'
-to %s might not give the result you'd expect." pop3-leave-mail-on-server)
- (sit-for 1))
- (pop3-quit process))
- (kill-buffer crashbuf))
- t)
+ (t (error "Invalid POP3 authentication scheme")))))
(defun pop3-get-message-count ()
"Return the number of messages in the maildrop."
@@ -214,15 +275,22 @@ this is nil, `ssl' is assumed for connexions to port
(const :tag "SSL/TLS" ssl)
(const starttls)))
+(eval-and-compile
+ (if (fboundp 'set-process-query-on-exit-flag)
+ (defalias 'pop3-set-process-query-on-exit-flag
+ 'set-process-query-on-exit-flag)
+ (defalias 'pop3-set-process-query-on-exit-flag
+ 'process-kill-without-query)))
+
(defun pop3-open-server (mailhost port)
"Open TCP connection to MAILHOST on PORT.
Returns the process associated with the connection."
(let ((coding-system-for-read 'binary)
(coding-system-for-write 'binary)
process)
- (save-excursion
- (set-buffer (get-buffer-create (concat " trace of POP session to "
- mailhost)))
+ (with-current-buffer
+ (get-buffer-create (concat " trace of POP session to "
+ mailhost))
(erase-buffer)
(setq pop3-read-point (point-min))
(setq process
@@ -275,16 +343,11 @@ Returns the process associated with the connection."
(starttls-negotiate process)
(pop3-quit process)
(error "POP server doesn't support starttls"))))
+ (pop3-set-process-query-on-exit-flag process nil)
process)))
;; Support functions
-(defun pop3-process-filter (process output)
- (save-excursion
- (set-buffer (process-buffer process))
- (goto-char (point-max))
- (insert output)))
-
(defun pop3-send-command (process command)
(set-buffer (process-buffer process))
(goto-char (point-max))
@@ -300,8 +363,7 @@ Returns the process associated with the connection."
Return the response string if optional second argument is non-nil."
(let ((case-fold-search nil)
match-end)
- (save-excursion
- (set-buffer (process-buffer process))
+ (with-current-buffer (process-buffer process)
(goto-char pop3-read-point)
(while (and (memq (process-status process) '(open run))
(not (search-forward "\r\n" nil t)))
@@ -401,10 +463,7 @@ If NOW, use that time instead."
nil
(goto-char (point-max))
(insert "\n"))
- (narrow-to-region (point) (point-max))
- (let ((size (- (point-max) (point-min))))
- (goto-char (point-min))
- (widen)
+ (let ((size (- (point-max) (point))))
(forward-line -1)
(insert (format "Content-Length: %s\n" size)))
)))))
@@ -452,16 +511,33 @@ If NOW, use that time instead."
))
(defun pop3-list (process &optional msg)
- "Scan listing of available messages.
-This function currently does nothing.")
+ "If MSG is nil, return an alist of (MESSAGE-ID . SIZE) pairs.
+Otherwise, return the size of the message-id MSG"
+ (pop3-send-command process (if msg
+ (format "LIST %d" msg)
+ "LIST"))
+ (let ((response (pop3-read-response process t)))
+ (if msg
+ (string-to-number (nth 2 (split-string response " ")))
+ (let ((start pop3-read-point) end)
+ (with-current-buffer (process-buffer process)
+ (while (not (re-search-forward "^\\.\r\n" nil t))
+ (pop3-accept-process-output process)
+ (goto-char start))
+ (setq pop3-read-point (point-marker))
+ (goto-char (match-beginning 0))
+ (setq end (point-marker))
+ (mapcar #'(lambda (s) (let ((split (split-string s " ")))
+ (cons (string-to-number (nth 0 split))
+ (string-to-number (nth 1 split)))))
+ (split-string (buffer-substring start end) "\r\n" t)))))))
(defun pop3-retr (process msg crashbuf)
"Retrieve message-id MSG to buffer CRASHBUF."
(pop3-send-command process (format "RETR %s" msg))
(pop3-read-response process)
(let ((start pop3-read-point) end)
- (save-excursion
- (set-buffer (process-buffer process))
+ (with-current-buffer (process-buffer process)
(while (not (re-search-forward "^\\.\r\n" nil t))
(pop3-accept-process-output process)
(goto-char start))
@@ -477,8 +553,7 @@ This function currently does nothing.")
(setq end (point-marker))
(pop3-clean-region start end)
(pop3-munge-message-separator start end)
- (save-excursion
- (set-buffer crashbuf)
+ (with-current-buffer crashbuf
(erase-buffer))
(copy-to-buffer crashbuf start end)
(delete-region start end)
@@ -515,8 +590,7 @@ and close the connection."
(pop3-send-command process "QUIT")
(pop3-read-response process t)
(if process
- (save-excursion
- (set-buffer (process-buffer process))
+ (with-current-buffer (process-buffer process)
(goto-char (point-max))
(delete-process process))))
@@ -609,5 +683,4 @@ and close the connection."
(provide 'pop3)
-;; arch-tag: 2facc142-1d74-498e-82af-4659b64cac12
;;; pop3.el ends here
diff --git a/lisp/gnus/qp.el b/lisp/gnus/qp.el
index 1b9b4ce01ec..90975c48cd3 100644
--- a/lisp/gnus/qp.el
+++ b/lisp/gnus/qp.el
@@ -164,5 +164,4 @@ encode lines starting with \"From\"."
(provide 'qp)
-;; arch-tag: db89e52a-e4a1-4b69-926f-f434f04216ba
;;; qp.el ends here
diff --git a/lisp/gnus/rfc1843.el b/lisp/gnus/rfc1843.el
index b491a76b9c2..87fcde60138 100644
--- a/lisp/gnus/rfc1843.el
+++ b/lisp/gnus/rfc1843.el
@@ -32,7 +32,7 @@
;;; Code:
-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
@@ -166,7 +166,6 @@ ftp://ftp.math.psu.edu/pub/simpson/chinese/hzp/hzp.doc"
(equal (car ctl) "text/plain"))
(rfc1843-decode-region (point) (point-max))))))))
-(defvar rfc1843-old-gnus-decode-header-function nil)
(defvar gnus-decode-header-methods)
(defvar gnus-decode-encoded-word-methods)
@@ -192,5 +191,4 @@ ftp://ftp.math.psu.edu/pub/simpson/chinese/hzp/hzp.doc"
(provide 'rfc1843)
-;; arch-tag: 5149c301-a6ca-4731-9c9d-ba616e2cb687
;;; rfc1843.el ends here
diff --git a/lisp/gnus/rfc2045.el b/lisp/gnus/rfc2045.el
index b3eaefbf690..0263129c20a 100644
--- a/lisp/gnus/rfc2045.el
+++ b/lisp/gnus/rfc2045.el
@@ -39,5 +39,4 @@
(provide 'rfc2045)
-;; arch-tag: 9ca54127-97bc-432c-b6e2-8c59cadba306
;;; rfc2045.el ends here
diff --git a/lisp/gnus/rfc2047.el b/lisp/gnus/rfc2047.el
index 793aa1f32dc..51eef88dadc 100644
--- a/lisp/gnus/rfc2047.el
+++ b/lisp/gnus/rfc2047.el
@@ -31,7 +31,6 @@
(require 'cl))
(defvar message-posting-charset)
-(require 'qp)
(require 'mm-util)
(require 'ietf-drums)
;; Fixme: Avoid this (used for mail-parse-charset) mm dependence on gnus.
@@ -343,17 +342,13 @@ The buffer may be narrowed."
(defconst rfc2047-syntax-table
;; (make-char-table 'syntax-table '(2)) only works in Emacs.
(let ((table (make-syntax-table)))
- ;; The following is done to work for setting all elements of the table
- ;; in Emacs 21-23 and XEmacs; it appears to be the cleanest way.
+ ;; The following is done to work for setting all elements of the table;
+ ;; it appears to be the cleanest way.
;; Play safe and don't assume the form of the word syntax entry --
;; copy it from ?a.
- (if (fboundp 'set-char-table-range) ; Emacs
- (funcall (intern "set-char-table-range")
- table t (aref (standard-syntax-table) ?a))
- (if (fboundp 'put-char-table)
- (if (fboundp 'get-char-table) ; warning avoidance
- (put-char-table t (get-char-table ?a (standard-syntax-table))
- table))))
+ (if (featurep 'xemacs)
+ (put-char-table t (get-char-table ?a (standard-syntax-table)) table)
+ (set-char-table-range table t (aref (standard-syntax-table) ?a)))
(modify-syntax-entry ?\\ "\\" table)
(modify-syntax-entry ?\" "\"" table)
(modify-syntax-entry ?\( "(" table)
@@ -428,7 +423,7 @@ Dynamically bind `rfc2047-encoding-type' to change that."
;; since encoded words can't occur in quotes.
(progn
(goto-char end)
- (delete-backward-char 1)
+ (delete-char -1)
(goto-char start)
(delete-char 1)
(when last-encoded
@@ -656,6 +651,9 @@ should not change this value.")
Point moves to the end of the region."
(let ((mime-charset (or (mm-find-mime-charset-region b e) (list 'us-ascii)))
cs encoding tail crest eword)
+ ;; Use utf-8 as a last resort if determining charset of text fails.
+ (if (memq nil mime-charset)
+ (setq mime-charset (list 'utf-8)))
(cond ((> (length mime-charset) 1)
(error "Can't rfc2047-encode `%s'"
(buffer-substring-no-properties b e)))
@@ -827,6 +825,8 @@ Point moves to the end of the region."
"Base64-encode the header contained in STRING."
(base64-encode-string string t))
+(autoload 'quoted-printable-encode-region "qp")
+
(defun rfc2047-q-encode-string (string)
"Quoted-printable-encode the header in STRING."
(mm-with-unibyte-buffer
@@ -847,18 +847,8 @@ Point moves to the end of the region."
(defun rfc2047-encode-parameter (param value)
"Return and PARAM=VALUE string encoded in the RFC2047-like style.
-This is a replacement for the `rfc2231-encode-string' function.
-
-When attaching files as MIME parts, we should use the RFC2231 encoding
-to specify the file names containing non-ASCII characters. However,
-many mail softwares don't support it in practice and recipients won't
-be able to extract files with correct names. Instead, the RFC2047-like
-encoding is acceptable generally. This function provides the very
-RFC2047-like encoding, resigning to such a regrettable trend. To use
-it, put the following line in your ~/.gnus.el file:
-
-\(defalias 'mail-header-encode-parameter 'rfc2047-encode-parameter)
-"
+This is a substitution for the `rfc2231-encode-string' function, that
+is the standard but many mailers don't support it."
(let ((rfc2047-encoding-type 'mime)
(rfc2047-encode-max-chars nil))
(rfc2045-encode-string param (rfc2047-encode-string value))))
@@ -896,7 +886,7 @@ them.")
(goto-char beg)
(while (search-forward "\\" nil 'move)
(unless (memq (char-after) '(?\"))
- (delete-backward-char 1))
+ (delete-char -1))
(forward-char)))
(forward-char))
(error
@@ -929,6 +919,8 @@ only be used for decoding, not for encoding."
'raw-text
cs)))
+(autoload 'quoted-printable-decode-string "qp")
+
(defun rfc2047-decode-encoded-words (words)
"Decode successive encoded-words in WORDS and return a decoded string.
Each element of WORDS looks like (CHARSET ENCODING ENCODED-TEXT
@@ -1169,5 +1161,4 @@ strings are stripped."
(provide 'rfc2047)
-;; arch-tag: a07fe3d4-22b5-4c4a-bd89-b1f82d5d36f6
;;; rfc2047.el ends here
diff --git a/lisp/gnus/rfc2104.el b/lisp/gnus/rfc2104.el
index 84cb64dfd25..c1d07231978 100644
--- a/lisp/gnus/rfc2104.el
+++ b/lisp/gnus/rfc2104.el
@@ -122,5 +122,4 @@ In XEmacs return just STRING."
(provide 'rfc2104)
-;; arch-tag: cf671d5c-a45f-4a09-815e-704e59e43950
;;; rfc2104.el ends here
diff --git a/lisp/gnus/rfc2231.el b/lisp/gnus/rfc2231.el
index bb38c021cfb..0b028a08b83 100644
--- a/lisp/gnus/rfc2231.el
+++ b/lisp/gnus/rfc2231.el
@@ -185,11 +185,19 @@ must never cause a Lisp error."
in (sort parameters (lambda (e1 e2)
(< (or (caddr e1) 0)
(or (caddr e2) 0))))
- do (if (or (not (setq elem (assq attribute cparams)))
- (and (numberp part)
- (zerop part)))
- (push (list attribute value encoded) cparams)
- (setcar (cdr elem) (concat (cadr elem) value))))
+ do (cond
+ ;; First part.
+ ((or (not (setq elem (assq attribute cparams)))
+ (and (numberp part)
+ (zerop part)))
+ (push (list attribute value encoded) cparams))
+ ;; Repetition of a part; do nothing.
+ ((and elem
+ (null number))
+ )
+ ;; Concatenate continuation parts.
+ (t
+ (setcar (cdr elem) (concat (cadr elem) value)))))
;; Finally decode encoded values.
(cons type (mapcar
(lambda (elem)
@@ -296,5 +304,4 @@ the result of this function."
(provide 'rfc2231)
-;; arch-tag: c3ab751d-d108-406a-b301-68882ad8cd63
;;; rfc2231.el ends here
diff --git a/lisp/gnus/score-mode.el b/lisp/gnus/score-mode.el
index 9ae3e4e9ac6..04eae85bac5 100644
--- a/lisp/gnus/score-mode.el
+++ b/lisp/gnus/score-mode.el
@@ -116,5 +116,4 @@ This mode is an extended emacs-lisp mode.
(provide 'score-mode)
-;; arch-tag: a74a416b-2505-4ad4-bc4e-a418c96b8845
;;; score-mode.el ends here
diff --git a/lisp/gnus/shr-color.el b/lisp/gnus/shr-color.el
new file mode 100644
index 00000000000..afb56ae38a7
--- /dev/null
+++ b/lisp/gnus/shr-color.el
@@ -0,0 +1,361 @@
+;;; shr-color.el --- Simple HTML Renderer color management
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Julien Danjou <julien@danjou.info>
+;; Keywords: 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 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package handles colors display for shr.
+
+;;; Code:
+
+(require 'color)
+(eval-when-compile (require 'cl))
+
+(defgroup shr-color nil
+ "Simple HTML Renderer colors"
+ :group 'shr)
+
+(defcustom shr-color-visible-luminance-min 40
+ "Minimum luminance distance between two colors to be considered visible.
+Must be between 0 and 100."
+ :group 'shr
+ :type 'float)
+
+(defcustom shr-color-visible-distance-min 5
+ "Minimum color distance between two colors to be considered visible.
+This value is used to compare result for `ciede2000'. Its an
+absolute value without any unit."
+ :group 'shr
+ :type 'integer)
+
+(defconst shr-color-html-colors-alist
+ '(("AliceBlue" . "#F0F8FF")
+ ("AntiqueWhite" . "#FAEBD7")
+ ("Aqua" . "#00FFFF")
+ ("Aquamarine" . "#7FFFD4")
+ ("Azure" . "#F0FFFF")
+ ("Beige" . "#F5F5DC")
+ ("Bisque" . "#FFE4C4")
+ ("Black" . "#000000")
+ ("BlanchedAlmond" . "#FFEBCD")
+ ("Blue" . "#0000FF")
+ ("BlueViolet" . "#8A2BE2")
+ ("Brown" . "#A52A2A")
+ ("BurlyWood" . "#DEB887")
+ ("CadetBlue" . "#5F9EA0")
+ ("Chartreuse" . "#7FFF00")
+ ("Chocolate" . "#D2691E")
+ ("Coral" . "#FF7F50")
+ ("CornflowerBlue" . "#6495ED")
+ ("Cornsilk" . "#FFF8DC")
+ ("Crimson" . "#DC143C")
+ ("Cyan" . "#00FFFF")
+ ("DarkBlue" . "#00008B")
+ ("DarkCyan" . "#008B8B")
+ ("DarkGoldenRod" . "#B8860B")
+ ("DarkGray" . "#A9A9A9")
+ ("DarkGrey" . "#A9A9A9")
+ ("DarkGreen" . "#006400")
+ ("DarkKhaki" . "#BDB76B")
+ ("DarkMagenta" . "#8B008B")
+ ("DarkOliveGreen" . "#556B2F")
+ ("Darkorange" . "#FF8C00")
+ ("DarkOrchid" . "#9932CC")
+ ("DarkRed" . "#8B0000")
+ ("DarkSalmon" . "#E9967A")
+ ("DarkSeaGreen" . "#8FBC8F")
+ ("DarkSlateBlue" . "#483D8B")
+ ("DarkSlateGray" . "#2F4F4F")
+ ("DarkSlateGrey" . "#2F4F4F")
+ ("DarkTurquoise" . "#00CED1")
+ ("DarkViolet" . "#9400D3")
+ ("DeepPink" . "#FF1493")
+ ("DeepSkyBlue" . "#00BFFF")
+ ("DimGray" . "#696969")
+ ("DimGrey" . "#696969")
+ ("DodgerBlue" . "#1E90FF")
+ ("FireBrick" . "#B22222")
+ ("FloralWhite" . "#FFFAF0")
+ ("ForestGreen" . "#228B22")
+ ("Fuchsia" . "#FF00FF")
+ ("Gainsboro" . "#DCDCDC")
+ ("GhostWhite" . "#F8F8FF")
+ ("Gold" . "#FFD700")
+ ("GoldenRod" . "#DAA520")
+ ("Gray" . "#808080")
+ ("Grey" . "#808080")
+ ("Green" . "#008000")
+ ("GreenYellow" . "#ADFF2F")
+ ("HoneyDew" . "#F0FFF0")
+ ("HotPink" . "#FF69B4")
+ ("IndianRed" . "#CD5C5C")
+ ("Indigo" . "#4B0082")
+ ("Ivory" . "#FFFFF0")
+ ("Khaki" . "#F0E68C")
+ ("Lavender" . "#E6E6FA")
+ ("LavenderBlush" . "#FFF0F5")
+ ("LawnGreen" . "#7CFC00")
+ ("LemonChiffon" . "#FFFACD")
+ ("LightBlue" . "#ADD8E6")
+ ("LightCoral" . "#F08080")
+ ("LightCyan" . "#E0FFFF")
+ ("LightGoldenRodYellow" . "#FAFAD2")
+ ("LightGray" . "#D3D3D3")
+ ("LightGrey" . "#D3D3D3")
+ ("LightGreen" . "#90EE90")
+ ("LightPink" . "#FFB6C1")
+ ("LightSalmon" . "#FFA07A")
+ ("LightSeaGreen" . "#20B2AA")
+ ("LightSkyBlue" . "#87CEFA")
+ ("LightSlateGray" . "#778899")
+ ("LightSlateGrey" . "#778899")
+ ("LightSteelBlue" . "#B0C4DE")
+ ("LightYellow" . "#FFFFE0")
+ ("Lime" . "#00FF00")
+ ("LimeGreen" . "#32CD32")
+ ("Linen" . "#FAF0E6")
+ ("Magenta" . "#FF00FF")
+ ("Maroon" . "#800000")
+ ("MediumAquaMarine" . "#66CDAA")
+ ("MediumBlue" . "#0000CD")
+ ("MediumOrchid" . "#BA55D3")
+ ("MediumPurple" . "#9370D8")
+ ("MediumSeaGreen" . "#3CB371")
+ ("MediumSlateBlue" . "#7B68EE")
+ ("MediumSpringGreen" . "#00FA9A")
+ ("MediumTurquoise" . "#48D1CC")
+ ("MediumVioletRed" . "#C71585")
+ ("MidnightBlue" . "#191970")
+ ("MintCream" . "#F5FFFA")
+ ("MistyRose" . "#FFE4E1")
+ ("Moccasin" . "#FFE4B5")
+ ("NavajoWhite" . "#FFDEAD")
+ ("Navy" . "#000080")
+ ("OldLace" . "#FDF5E6")
+ ("Olive" . "#808000")
+ ("OliveDrab" . "#6B8E23")
+ ("Orange" . "#FFA500")
+ ("OrangeRed" . "#FF4500")
+ ("Orchid" . "#DA70D6")
+ ("PaleGoldenRod" . "#EEE8AA")
+ ("PaleGreen" . "#98FB98")
+ ("PaleTurquoise" . "#AFEEEE")
+ ("PaleVioletRed" . "#D87093")
+ ("PapayaWhip" . "#FFEFD5")
+ ("PeachPuff" . "#FFDAB9")
+ ("Peru" . "#CD853F")
+ ("Pink" . "#FFC0CB")
+ ("Plum" . "#DDA0DD")
+ ("PowderBlue" . "#B0E0E6")
+ ("Purple" . "#800080")
+ ("Red" . "#FF0000")
+ ("RosyBrown" . "#BC8F8F")
+ ("RoyalBlue" . "#4169E1")
+ ("SaddleBrown" . "#8B4513")
+ ("Salmon" . "#FA8072")
+ ("SandyBrown" . "#F4A460")
+ ("SeaGreen" . "#2E8B57")
+ ("SeaShell" . "#FFF5EE")
+ ("Sienna" . "#A0522D")
+ ("Silver" . "#C0C0C0")
+ ("SkyBlue" . "#87CEEB")
+ ("SlateBlue" . "#6A5ACD")
+ ("SlateGray" . "#708090")
+ ("SlateGrey" . "#708090")
+ ("Snow" . "#FFFAFA")
+ ("SpringGreen" . "#00FF7F")
+ ("SteelBlue" . "#4682B4")
+ ("Tan" . "#D2B48C")
+ ("Teal" . "#008080")
+ ("Thistle" . "#D8BFD8")
+ ("Tomato" . "#FF6347")
+ ("Turquoise" . "#40E0D0")
+ ("Violet" . "#EE82EE")
+ ("Wheat" . "#F5DEB3")
+ ("White" . "#FFFFFF")
+ ("WhiteSmoke" . "#F5F5F5")
+ ("Yellow" . "#FFFF00")
+ ("YellowGreen" . "#9ACD32"))
+ "Alist of HTML colors.
+Each entry should have the form (COLOR-NAME . HEXADECIMAL-COLOR).")
+
+(defun shr-color-relative-to-absolute (number)
+ "Convert a relative NUMBER to absolute. If NUMBER is absolute, return NUMBER.
+This will convert \"80 %\" to 204, \"100 %\" to 255 but \"123\" to \"123\"."
+ (let ((string-length (- (length number) 1)))
+ ;; Is this a number with %?
+ (if (eq (elt number string-length) ?%)
+ (/ (* (string-to-number (substring number 0 string-length)) 255) 100)
+ (string-to-number number))))
+
+(defun shr-color-hue-to-rgb (x y h)
+ "Convert X Y H to RGB value."
+ (when (< h 0) (incf h))
+ (when (> h 1) (decf h))
+ (cond ((< h (/ 1 6.0)) (+ x (* (- y x) h 6)))
+ ((< h 0.5) y)
+ ((< h (/ 2.0 3.0)) (+ x (* (- y x) (- (/ 2.0 3.0) h) 6)))
+ (t x)))
+
+(defun shr-color-hsl-to-rgb-fractions (h s l)
+ "Convert H S L to fractional RGB values."
+ (let (m1 m2)
+ (if (<= l 0.5)
+ (setq m2 (* l (+ s 1)))
+ (setq m2 (- (+ l s) (* l s))))
+ (setq m1 (- (* l 2) m2))
+ (list (shr-color-hue-to-rgb m1 m2 (+ h (/ 1 3.0)))
+ (shr-color-hue-to-rgb m1 m2 h)
+ (shr-color-hue-to-rgb m1 m2 (- h (/ 1 3.0))))))
+
+(defun shr-color->hexadecimal (color)
+ "Convert any color format to hexadecimal representation.
+Like rgb() or hsl()."
+ (when color
+ (cond
+ ;; Hexadecimal color: #abc or #aabbcc
+ ((string-match
+ "\\(#[0-9a-fA-F]\\{3\\}[0-9a-fA-F]\\{3\\}?\\)"
+ color)
+ (match-string 1 color))
+ ;; rgb() or rgba() colors
+ ((or (string-match
+ "rgb(\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*)"
+ color)
+ (string-match
+ "rgba(\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*[0-9]*\.?[0-9]+\s*%?\s*)"
+ color))
+ (format "#%02X%02X%02X"
+ (shr-color-relative-to-absolute (match-string-no-properties 1 color))
+ (shr-color-relative-to-absolute (match-string-no-properties 2 color))
+ (shr-color-relative-to-absolute (match-string-no-properties 3 color))))
+ ;; hsl() or hsla() colors
+ ((or (string-match
+ "hsl(\s*\\([0-9]\\{1,3\\}\\)\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*)"
+ color)
+ (string-match
+ "hsla(\s*\\([0-9]\\{1,3\\}\\)\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*[0-9]*\.?[0-9]+\s*%?\s*)"
+ color))
+ (let ((h (/ (string-to-number (match-string-no-properties 1 color)) 360.0))
+ (s (/ (string-to-number (match-string-no-properties 2 color)) 100.0))
+ (l (/ (string-to-number (match-string-no-properties 3 color)) 100.0)))
+ (destructuring-bind (r g b)
+ (shr-color-hsl-to-rgb-fractions h s l)
+ (color-rgb->hex r g b))))
+ ;; Color names
+ ((cdr (assoc-string color shr-color-html-colors-alist t)))
+ ;; Unrecognized color :(
+ (t
+ nil))))
+
+(defun set-minimum-interval (val1 val2 min max interval &optional fixed)
+ "Set minimum interval between VAL1 and VAL2 to INTERVAL.
+The values are bound by MIN and MAX.
+If FIXED is t, then val1 will not be touched."
+ (let ((diff (abs (- val1 val2))))
+ (unless (>= diff interval)
+ (if fixed
+ (let* ((missing (- interval diff))
+ ;; If val2 > val1, try to increase val2
+ ;; That's the "good direction"
+ (val2-good-direction
+ (if (> val2 val1)
+ (min max (+ val2 missing))
+ (max min (- val2 missing))))
+ (diff-val2-good-direction-val1 (abs (- val2-good-direction val1))))
+ (if (>= diff-val2-good-direction-val1 interval)
+ (setq val2 val2-good-direction)
+ ;; Good-direction is not so good, compute bad-direction
+ (let* ((val2-bad-direction
+ (if (> val2 val1)
+ (max min (- val1 interval))
+ (min max (+ val1 interval))))
+ (diff-val2-bad-direction-val1 (abs (- val2-bad-direction val1))))
+ (if (>= diff-val2-bad-direction-val1 interval)
+ (setq val2 val2-bad-direction)
+ ;; Still not good, pick the best and prefer good direction
+ (setq val2
+ (if (>= diff-val2-good-direction-val1 diff-val2-bad-direction-val1)
+ val2-good-direction
+ val2-bad-direction))))))
+ ;; No fixed, move val1 and val2
+ (let ((missing (/ (- interval diff) 2.0)))
+ (if (< val1 val2)
+ (setq val1 (max min (- val1 missing))
+ val2 (min max (+ val2 missing)))
+ (setq val2 (max min (- val2 missing))
+ val1 (min max (+ val1 missing))))
+ (setq diff (abs (- val1 val2))) ; Recompute diff
+ (unless (>= diff interval)
+ ;; Not ok, we hit a boundary
+ (let ((missing (- interval diff)))
+ (cond ((= val1 min)
+ (setq val2 (+ val2 missing)))
+ ((= val2 min)
+ (setq val1 (+ val1 missing)))
+ ((= val1 max)
+ (setq val2 (- val2 missing)))
+ ((= val2 max)
+ (setq val1 (- val1 missing)))))))))
+ (list val1 val2)))
+
+(defun shr-color-visible (bg fg &optional fixed-background)
+ "Check that BG and FG colors are visible if they are drawn on each other.
+Return (bg fg) if they are. If they are too similar, two new
+colors are returned instead.
+If FIXED-BACKGROUND is set, and if the color are not visible, a
+new background color will not be computed. Only the foreground
+color will be adapted to be visible on BG."
+ ;; Convert fg and bg to CIE Lab
+ (let ((fg-norm (color-rgb->normalize fg))
+ (bg-norm (color-rgb->normalize bg)))
+ (if (or (null fg-norm)
+ (null bg-norm))
+ (list bg fg)
+ (let* ((fg-lab (apply 'color-srgb->lab fg-norm))
+ (bg-lab (apply 'color-srgb->lab bg-norm))
+ ;; Compute color distance using CIE DE 2000
+ (fg-bg-distance (color-cie-de2000 fg-lab bg-lab))
+ ;; Compute luminance distance (substract L component)
+ (luminance-distance (abs (- (car fg-lab) (car bg-lab)))))
+ (if (and (>= fg-bg-distance shr-color-visible-distance-min)
+ (>= luminance-distance shr-color-visible-luminance-min))
+ (list bg fg)
+ ;; Not visible, try to change luminance to make them visible
+ (let ((Ls (set-minimum-interval (car bg-lab) (car fg-lab) 0 100
+ shr-color-visible-luminance-min
+ fixed-background)))
+ (unless fixed-background
+ (setcar bg-lab (car Ls)))
+ (setcar fg-lab (cadr Ls))
+ (list
+ (if fixed-background
+ bg
+ (apply 'format "#%02x%02x%02x"
+ (mapcar (lambda (x) (* (max (min 1 x) 0) 255))
+ (apply 'color-lab->srgb bg-lab))))
+ (apply 'format "#%02x%02x%02x"
+ (mapcar (lambda (x) (* (max (min 1 x) 0) 255))
+ (apply 'color-lab->srgb fg-lab))))))))))
+
+(provide 'shr-color)
+
+;;; shr-color.el ends here
diff --git a/lisp/gnus/shr.el b/lisp/gnus/shr.el
new file mode 100644
index 00000000000..69973fbfb50
--- /dev/null
+++ b/lisp/gnus/shr.el
@@ -0,0 +1,1104 @@
+;;; shr.el --- Simple HTML Renderer
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Keywords: 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 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package takes a HTML parse tree (as provided by
+;; libxml-parse-html-region) and renders it in the current buffer. It
+;; does not do CSS, JavaScript or anything advanced: It's geared
+;; towards rendering typical short snippets of HTML, like what you'd
+;; find in HTML email and the like.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'browse-url)
+(unless (aref (char-category-set (make-char 'japanese-jisx0208 33 35)) ?>)
+ (load "kinsoku" nil t))
+
+(defgroup shr nil
+ "Simple HTML Renderer"
+ :group 'mail)
+
+(defcustom shr-max-image-proportion 0.9
+ "How big pictures displayed are in relation to the window they're in.
+A value of 0.7 means that they are allowed to take up 70% of the
+width and height of the window. If they are larger than this,
+and Emacs supports it, then the images will be rescaled down to
+fit these criteria."
+ :version "24.1"
+ :group 'shr
+ :type 'float)
+
+(defcustom shr-blocked-images nil
+ "Images that have URLs matching this regexp will be blocked."
+ :version "24.1"
+ :group 'shr
+ :type 'regexp)
+
+(defcustom shr-table-horizontal-line ?-
+ "Character used to draw horizontal table lines."
+ :group 'shr
+ :type 'character)
+
+(defcustom shr-table-vertical-line ?|
+ "Character used to draw vertical table lines."
+ :group 'shr
+ :type 'character)
+
+(defcustom shr-table-corner ?+
+ "Character used to draw table corners."
+ :group 'shr
+ :type 'character)
+
+(defcustom shr-hr-line ?-
+ "Character used to draw hr lines."
+ :group 'shr
+ :type 'character)
+
+(defcustom shr-width fill-column
+ "Frame width to use for rendering."
+ :type 'integer
+ :group 'shr)
+
+(defvar shr-content-function nil
+ "If bound, this should be a function that will return the content.
+This is used for cid: URLs, and the function is called with the
+cid: URL as the argument.")
+
+;;; Internal variables.
+
+(defvar shr-folding-mode nil)
+(defvar shr-state nil)
+(defvar shr-start nil)
+(defvar shr-indentation 0)
+(defvar shr-inhibit-images nil)
+(defvar shr-list-mode nil)
+(defvar shr-content-cache nil)
+(defvar shr-kinsoku-shorten nil)
+(defvar shr-table-depth 0)
+
+(defvar shr-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "a" 'shr-show-alt-text)
+ (define-key map "i" 'shr-browse-image)
+ (define-key map "I" 'shr-insert-image)
+ (define-key map "u" 'shr-copy-url)
+ (define-key map "v" 'shr-browse-url)
+ (define-key map "o" 'shr-save-contents)
+ (define-key map "\r" 'shr-browse-url)
+ map))
+
+;; Public functions and commands.
+
+;;;###autoload
+(defun shr-insert-document (dom)
+ (setq shr-content-cache nil)
+ (let ((shr-state nil)
+ (shr-start nil))
+ (shr-descend (shr-transform-dom dom))))
+
+(defun shr-copy-url ()
+ "Copy the URL under point to the kill ring.
+If called twice, then try to fetch the URL and see whether it
+redirects somewhere else."
+ (interactive)
+ (let ((url (get-text-property (point) 'shr-url)))
+ (cond
+ ((not url)
+ (message "No URL under point"))
+ ;; Resolve redirected URLs.
+ ((equal url (car kill-ring))
+ (url-retrieve
+ url
+ (lambda (a)
+ (when (and (consp a)
+ (eq (car a) :redirect))
+ (with-temp-buffer
+ (insert (cadr a))
+ (goto-char (point-min))
+ ;; Remove common tracking junk from the URL.
+ (when (re-search-forward ".utm_.*" nil t)
+ (replace-match "" t t))
+ (message "Copied %s" (buffer-string))
+ (copy-region-as-kill (point-min) (point-max)))))))
+ ;; Copy the URL to the kill ring.
+ (t
+ (with-temp-buffer
+ (insert url)
+ (copy-region-as-kill (point-min) (point-max))
+ (message "Copied %s" url))))))
+
+(defun shr-show-alt-text ()
+ "Show the ALT text of the image under point."
+ (interactive)
+ (let ((text (get-text-property (point) 'shr-alt)))
+ (if (not text)
+ (message "No image under point")
+ (message "%s" text))))
+
+(defun shr-browse-image ()
+ "Browse the image under point."
+ (interactive)
+ (let ((url (get-text-property (point) 'image-url)))
+ (if (not url)
+ (message "No image under point")
+ (message "Browsing %s..." url)
+ (browse-url url))))
+
+(defun shr-insert-image ()
+ "Insert the image under point into the buffer."
+ (interactive)
+ (let ((url (get-text-property (point) 'image-url)))
+ (if (not url)
+ (message "No image under point")
+ (message "Inserting %s..." url)
+ (url-retrieve url 'shr-image-fetched
+ (list (current-buffer) (1- (point)) (point-marker))
+ t))))
+
+;;; Utility functions.
+
+(defun shr-transform-dom (dom)
+ (let ((result (list (pop dom))))
+ (dolist (arg (pop dom))
+ (push (cons (intern (concat ":" (symbol-name (car arg))) obarray)
+ (cdr arg))
+ result))
+ (dolist (sub dom)
+ (if (stringp sub)
+ (push (cons 'text sub) result)
+ (push (shr-transform-dom sub) result)))
+ (nreverse result)))
+
+(defun shr-descend (dom)
+ (let ((function (intern (concat "shr-tag-" (symbol-name (car dom))) obarray))
+ (style (cdr (assq :style (cdr dom))))
+ (start (point)))
+ (when (and style
+ (string-match "color" style))
+ (setq style (shr-parse-style style)))
+ (if (fboundp function)
+ (funcall function (cdr dom))
+ (shr-generic (cdr dom)))
+ (when (consp style)
+ (shr-insert-background-overlay (cdr (assq 'background-color style))
+ start)
+ (shr-insert-foreground-overlay (cdr (assq 'color style))
+ start (point)))))
+
+(defun shr-generic (cont)
+ (dolist (sub cont)
+ (cond
+ ((eq (car sub) 'text)
+ (shr-insert (cdr sub)))
+ ((listp (cdr sub))
+ (shr-descend sub)))))
+
+(defun shr-insert (text)
+ (when (and (eq shr-state 'image)
+ (not (string-match "\\`[ \t\n]+\\'" text)))
+ (insert "\n")
+ (setq shr-state nil))
+ (cond
+ ((eq shr-folding-mode 'none)
+ (insert text))
+ (t
+ (when (and (string-match "\\`[ \t\n]" text)
+ (not (bolp))
+ (not (eq (char-after (1- (point))) ? )))
+ (insert " "))
+ (dolist (elem (split-string text))
+ (when (and (bolp)
+ (> shr-indentation 0))
+ (shr-indent))
+ ;; The shr-start is a special variable that is used to pass
+ ;; upwards the first point in the buffer where the text really
+ ;; starts.
+ (unless shr-start
+ (setq shr-start (point)))
+ ;; No space is needed behind a wide character categorized as
+ ;; kinsoku-bol, between characters both categorized as nospace,
+ ;; or at the beginning of a line.
+ (let (prev)
+ (when (and (eq (preceding-char) ? )
+ (or (= (line-beginning-position) (1- (point)))
+ (and (aref fill-find-break-point-function-table
+ (setq prev (char-after (- (point) 2))))
+ (aref (char-category-set prev) ?>))
+ (and (aref fill-nospace-between-words-table prev)
+ (aref fill-nospace-between-words-table
+ (aref elem 0)))))
+ (delete-char -1)))
+ (insert elem)
+ (let (found)
+ (while (and (> (current-column) shr-width)
+ (progn
+ (setq found (shr-find-fill-point))
+ (not (eolp))))
+ (when (eq (preceding-char) ? )
+ (delete-char -1))
+ (insert "\n")
+ (unless found
+ (put-text-property (1- (point)) (point) 'shr-break t)
+ ;; No space is needed at the beginning of a line.
+ (when (eq (following-char) ? )
+ (delete-char 1)))
+ (when (> shr-indentation 0)
+ (shr-indent))
+ (end-of-line))
+ (insert " ")))
+ (unless (string-match "[ \t\n]\\'" text)
+ (delete-char -1)))))
+
+(defun shr-find-fill-point ()
+ (when (> (move-to-column shr-width) shr-width)
+ (backward-char 1))
+ (let (failed)
+ (while (not
+ (or (setq failed (= (current-column) shr-indentation))
+ (eq (preceding-char) ? )
+ (eq (following-char) ? )
+ (aref fill-find-break-point-function-table (preceding-char))
+ (aref (char-category-set (preceding-char)) ?>)))
+ (backward-char 1))
+ (if failed
+ ;; There's no breakable point, so we give it up.
+ (progn
+ (end-of-line)
+ (while (aref fill-find-break-point-function-table (preceding-char))
+ (backward-char 1))
+ nil)
+ (or
+ (eolp)
+ (progn
+ ;; Don't put kinsoku-bol characters at the beginning of a line,
+ ;; or kinsoku-eol characters at the end of a line.
+ (cond
+ (shr-kinsoku-shorten
+ (while (and
+ (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
+ (not (or (aref (char-category-set (preceding-char)) ?>)
+ (aref (char-category-set (following-char)) ?<)))
+ (or (aref (char-category-set (preceding-char)) ?<)
+ (aref (char-category-set (following-char)) ?>)))
+ (backward-char 1)))
+ ((aref (char-category-set (preceding-char)) ?<)
+ (let ((count 3))
+ (while (progn
+ (backward-char 1)
+ (and
+ (> (setq count (1- count)) 0)
+ (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
+ (or (aref (char-category-set (preceding-char)) ?<)
+ (aref (char-category-set (following-char)) ?>))))))
+ (if (and (setq failed (= (current-column) shr-indentation))
+ (re-search-forward "\\c|" (line-end-position) 'move))
+ ;; There's no breakable point that doesn't violate kinsoku,
+ ;; so we look for the second best position.
+ (let (bp)
+ (while (and (<= (current-column) shr-width)
+ (progn
+ (setq bp (point))
+ (not (eolp)))
+ (aref fill-find-break-point-function-table
+ (following-char)))
+ (forward-char 1))
+ (goto-char (or bp (line-end-position))))))
+ (t
+ (let ((count 4))
+ (while (and (>= (setq count (1- count)) 0)
+ (aref (char-category-set (following-char)) ?>)
+ (aref fill-find-break-point-function-table
+ (following-char)))
+ (forward-char 1)))))
+ (when (eq (following-char) ? )
+ (forward-char 1))
+ (not failed))))))
+
+(defun shr-ensure-newline ()
+ (unless (zerop (current-column))
+ (insert "\n")))
+
+(defun shr-ensure-paragraph ()
+ (unless (bobp)
+ (if (<= (current-column) shr-indentation)
+ (unless (save-excursion
+ (forward-line -1)
+ (looking-at " *$"))
+ (insert "\n"))
+ (if (save-excursion
+ (beginning-of-line)
+ (looking-at " *$"))
+ (insert "\n")
+ (insert "\n\n")))))
+
+(defun shr-indent ()
+ (when (> shr-indentation 0)
+ (insert (make-string shr-indentation ? ))))
+
+(defun shr-fontize-cont (cont &rest types)
+ (let (shr-start)
+ (shr-generic cont)
+ (dolist (type types)
+ (shr-add-font (or shr-start (point)) (point) type))))
+
+;; Add an overlay in the region, but avoid putting the font properties
+;; on blank text at the start of the line, and the newline at the end,
+;; to avoid ugliness.
+(defun shr-add-font (start end type)
+ (save-excursion
+ (goto-char start)
+ (while (< (point) end)
+ (when (bolp)
+ (skip-chars-forward " "))
+ (let ((overlay (make-overlay (point) (min (line-end-position) end))))
+ (overlay-put overlay 'face type))
+ (if (< (line-end-position) end)
+ (forward-line 1)
+ (goto-char end)))))
+
+(defun shr-browse-url ()
+ "Browse the URL under point."
+ (interactive)
+ (let ((url (get-text-property (point) 'shr-url)))
+ (cond
+ ((not url)
+ (message "No link under point"))
+ ((string-match "^mailto:" url)
+ (browse-url-mailto url))
+ (t
+ (browse-url url)))))
+
+(defun shr-save-contents (directory)
+ "Save the contents from URL in a file."
+ (interactive "DSave contents of URL to directory: ")
+ (let ((url (get-text-property (point) 'shr-url)))
+ (if (not url)
+ (message "No link under point")
+ (url-retrieve (shr-encode-url url)
+ 'shr-store-contents (list url directory)))))
+
+(defun shr-store-contents (status url directory)
+ (unless (plist-get status :error)
+ (when (or (search-forward "\n\n" nil t)
+ (search-forward "\r\n\r\n" nil t))
+ (write-region (point) (point-max)
+ (expand-file-name (file-name-nondirectory url)
+ directory)))))
+
+(defun shr-image-fetched (status buffer start end)
+ (when (and (buffer-name buffer)
+ (not (plist-get status :error)))
+ (url-store-in-cache (current-buffer))
+ (when (or (search-forward "\n\n" nil t)
+ (search-forward "\r\n\r\n" nil t))
+ (let ((data (buffer-substring (point) (point-max))))
+ (with-current-buffer buffer
+ (let ((alt (buffer-substring start end))
+ (inhibit-read-only t))
+ (delete-region start end)
+ (goto-char start)
+ (shr-put-image data alt))))))
+ (kill-buffer (current-buffer)))
+
+(defun shr-put-image (data alt)
+ (if (display-graphic-p)
+ (let ((image (ignore-errors
+ (shr-rescale-image data))))
+ (when image
+ ;; When inserting big-ish pictures, put them at the
+ ;; beginning of the line.
+ (when (and (> (current-column) 0)
+ (> (car (image-size image t)) 400))
+ (insert "\n"))
+ (insert-image image (or alt "*"))))
+ (insert alt)))
+
+(defun shr-rescale-image (data)
+ (if (or (not (fboundp 'imagemagick-types))
+ (not (get-buffer-window (current-buffer))))
+ (create-image data nil t)
+ (let* ((image (create-image data nil t))
+ (size (image-size image t))
+ (width (car size))
+ (height (cdr size))
+ (edges (window-inside-pixel-edges
+ (get-buffer-window (current-buffer))))
+ (window-width (truncate (* shr-max-image-proportion
+ (- (nth 2 edges) (nth 0 edges)))))
+ (window-height (truncate (* shr-max-image-proportion
+ (- (nth 3 edges) (nth 1 edges)))))
+ scaled-image)
+ (when (> height window-height)
+ (setq image (or (create-image data 'imagemagick t
+ :height window-height)
+ image))
+ (setq size (image-size image t)))
+ (when (> (car size) window-width)
+ (setq image (or
+ (create-image data 'imagemagick t
+ :width window-width)
+ image)))
+ image)))
+
+;; url-cache-extract autoloads url-cache.
+(declare-function url-cache-create-filename "url-cache" (url))
+(autoload 'mm-disable-multibyte "mm-util")
+(autoload 'browse-url-mailto "browse-url")
+
+(defun shr-get-image-data (url)
+ "Get image data for URL.
+Return a string with image data."
+ (with-temp-buffer
+ (mm-disable-multibyte)
+ (when (ignore-errors
+ (url-cache-extract (url-cache-create-filename (shr-encode-url url)))
+ t)
+ (when (or (search-forward "\n\n" nil t)
+ (search-forward "\r\n\r\n" nil t))
+ (buffer-substring (point) (point-max))))))
+
+(defun shr-image-displayer (content-function)
+ "Return a function to display an image.
+CONTENT-FUNCTION is a function to retrieve an image for a cid url that
+is an argument. The function to be returned takes three arguments URL,
+START, and END."
+ `(lambda (url start end)
+ (when url
+ (if (string-match "\\`cid:" url)
+ ,(when content-function
+ `(let ((image (funcall ,content-function
+ (substring url (match-end 0)))))
+ (when image
+ (goto-char start)
+ (shr-put-image image
+ (prog1
+ (buffer-substring-no-properties start end)
+ (delete-region start end))))))
+ (url-retrieve url 'shr-image-fetched
+ (list (current-buffer) start end)
+ t)))))
+
+(defun shr-heading (cont &rest types)
+ (shr-ensure-paragraph)
+ (apply #'shr-fontize-cont cont types)
+ (shr-ensure-paragraph))
+
+(autoload 'widget-convert-button "wid-edit")
+
+(defun shr-urlify (start url)
+ (widget-convert-button
+ 'url-link start (point)
+ :help-echo url
+ :keymap shr-map
+ url)
+ (put-text-property start (point) 'shr-url url))
+
+(defun shr-encode-url (url)
+ "Encode URL."
+ (browse-url-url-encode-chars url "[)$ ]"))
+
+(autoload 'shr-color-visible "shr-color")
+(autoload 'shr-color->hexadecimal "shr-color")
+
+(defun shr-color-check (fg bg)
+ "Check that FG is visible on BG.
+Returns (fg bg) with corrected values.
+Returns nil if the colors that would be used are the default
+ones, in case fg and bg are nil."
+ (when (or fg bg)
+ (let ((fixed (cond ((null fg) 'fg)
+ ((null bg) 'bg))))
+ ;; Convert colors to hexadecimal, or set them to default.
+ (let ((fg (or (shr-color->hexadecimal fg)
+ (frame-parameter nil 'foreground-color)))
+ (bg (or (shr-color->hexadecimal bg)
+ (frame-parameter nil 'background-color))))
+ (cond ((eq fixed 'bg)
+ ;; Only return the new fg
+ (list nil (cadr (shr-color-visible bg fg t))))
+ ((eq fixed 'fg)
+ ;; Invert args and results and return only the new bg
+ (list (cadr (shr-color-visible fg bg t)) nil))
+ (t
+ (shr-color-visible bg fg)))))))
+
+(defun shr-get-background (pos)
+ "Return background color at POS."
+ (dolist (overlay (overlays-in pos (1+ pos)))
+ (let ((background (plist-get (overlay-get overlay 'face)
+ :background)))
+ (when background
+ (return background)))))
+
+(defun shr-insert-foreground-overlay (fg start end)
+ (when fg
+ (let ((bg (shr-get-background start)))
+ (let ((new-colors (shr-color-check fg bg)))
+ (when new-colors
+ (overlay-put (make-overlay start end) 'face
+ (list :foreground (cadr new-colors))))))))
+
+(defun shr-insert-background-overlay (bg start)
+ "Insert an overlay with background color BG at START.
+The overlay has rear-advance set to t, so it will be used when
+text will be inserted at start."
+ (when bg
+ (let ((new-colors (shr-color-check nil bg)))
+ (when new-colors
+ (overlay-put (make-overlay start start nil nil t) 'face
+ (list :background (car new-colors)))))))
+
+;;; Tag-specific rendering rules.
+
+(defun shr-tag-body (cont)
+ (let ((start (point))
+ (fgcolor (cdr (assq :fgcolor cont)))
+ (bgcolor (cdr (assq :bgcolor cont))))
+ (shr-insert-background-overlay bgcolor start)
+ (shr-generic cont)
+ (shr-insert-foreground-overlay fgcolor start (point))))
+
+(defun shr-tag-p (cont)
+ (shr-ensure-paragraph)
+ (shr-indent)
+ (shr-generic cont)
+ (shr-ensure-paragraph))
+
+(defun shr-tag-div (cont)
+ (shr-ensure-newline)
+ (shr-indent)
+ (shr-generic cont)
+ (shr-ensure-newline))
+
+(defun shr-tag-b (cont)
+ (shr-fontize-cont cont 'bold))
+
+(defun shr-tag-i (cont)
+ (shr-fontize-cont cont 'italic))
+
+(defun shr-tag-em (cont)
+ (shr-fontize-cont cont 'bold))
+
+(defun shr-tag-strong (cont)
+ (shr-fontize-cont cont 'bold))
+
+(defun shr-tag-u (cont)
+ (shr-fontize-cont cont 'underline))
+
+(defun shr-tag-s (cont)
+ (shr-fontize-cont cont 'strike-through))
+
+(defun shr-parse-style (style)
+ (when style
+ (save-match-data
+ (when (string-match "\n" style)
+ (setq style (replace-match " " t t style))))
+ (let ((plist nil))
+ (dolist (elem (split-string style ";"))
+ (when elem
+ (setq elem (split-string elem ":"))
+ (when (and (car elem)
+ (cadr elem))
+ (let ((name (replace-regexp-in-string "^ +\\| +$" "" (car elem)))
+ (value (replace-regexp-in-string "^ +\\| +$" "" (cadr elem))))
+ (when (string-match " *!important\\'" value)
+ (setq value (substring value 0 (match-beginning 0))))
+ (push (cons (intern name obarray)
+ value)
+ plist)))))
+ plist)))
+
+(defun shr-tag-a (cont)
+ (let ((url (cdr (assq :href cont)))
+ (start (point))
+ shr-start)
+ (shr-generic cont)
+ (shr-urlify (or shr-start start) url)))
+
+(defun shr-tag-object (cont)
+ (let ((start (point))
+ url)
+ (dolist (elem cont)
+ (when (eq (car elem) 'embed)
+ (setq url (or url (cdr (assq :src (cdr elem))))))
+ (when (and (eq (car elem) 'param)
+ (equal (cdr (assq :name (cdr elem))) "movie"))
+ (setq url (or url (cdr (assq :value (cdr elem)))))))
+ (when url
+ (shr-insert " [multimedia] ")
+ (shr-urlify start url))
+ (shr-generic cont)))
+
+(defun shr-tag-video (cont)
+ (let ((image (cdr (assq :poster cont)))
+ (url (cdr (assq :src cont)))
+ (start (point)))
+ (shr-tag-img nil image)
+ (shr-urlify start url)))
+
+(defun shr-tag-img (cont &optional url)
+ (when (or url
+ (and cont
+ (cdr (assq :src cont))))
+ (when (and (> (current-column) 0)
+ (not (eq shr-state 'image)))
+ (insert "\n"))
+ (let ((alt (cdr (assq :alt cont)))
+ (url (or url (cdr (assq :src cont)))))
+ (let ((start (point-marker)))
+ (when (zerop (length alt))
+ (setq alt "*"))
+ (cond
+ ((or (member (cdr (assq :height cont)) '("0" "1"))
+ (member (cdr (assq :width cont)) '("0" "1")))
+ ;; Ignore zero-sized or single-pixel images.
+ )
+ ((and (not shr-inhibit-images)
+ (string-match "\\`cid:" url))
+ (let ((url (substring url (match-end 0)))
+ image)
+ (if (or (not shr-content-function)
+ (not (setq image (funcall shr-content-function url))))
+ (insert alt)
+ (shr-put-image image alt))))
+ ((or shr-inhibit-images
+ (and shr-blocked-images
+ (string-match shr-blocked-images url)))
+ (setq shr-start (point))
+ (let ((shr-state 'space))
+ (if (> (string-width alt) 8)
+ (shr-insert (truncate-string-to-width alt 8))
+ (shr-insert alt))))
+ ((url-is-cached (shr-encode-url url))
+ (shr-put-image (shr-get-image-data url) alt))
+ (t
+ (insert alt)
+ (ignore-errors
+ (url-retrieve (shr-encode-url url) 'shr-image-fetched
+ (list (current-buffer) start (point-marker))
+ t))))
+ (put-text-property start (point) 'keymap shr-map)
+ (put-text-property start (point) 'shr-alt alt)
+ (put-text-property start (point) 'image-url url)
+ (put-text-property start (point) 'image-displayer
+ (shr-image-displayer shr-content-function))
+ (put-text-property start (point) 'help-echo alt)
+ (setq shr-state 'image)))))
+
+(defun shr-tag-pre (cont)
+ (let ((shr-folding-mode 'none))
+ (shr-ensure-newline)
+ (shr-indent)
+ (shr-generic cont)
+ (shr-ensure-newline)))
+
+(defun shr-tag-blockquote (cont)
+ (shr-ensure-paragraph)
+ (shr-indent)
+ (let ((shr-indentation (+ shr-indentation 4)))
+ (shr-generic cont))
+ (shr-ensure-paragraph))
+
+(defun shr-tag-ul (cont)
+ (shr-ensure-paragraph)
+ (let ((shr-list-mode 'ul))
+ (shr-generic cont))
+ (shr-ensure-paragraph))
+
+(defun shr-tag-ol (cont)
+ (shr-ensure-paragraph)
+ (let ((shr-list-mode 1))
+ (shr-generic cont))
+ (shr-ensure-paragraph))
+
+(defun shr-tag-li (cont)
+ (shr-ensure-paragraph)
+ (shr-indent)
+ (let* ((bullet
+ (if (numberp shr-list-mode)
+ (prog1
+ (format "%d " shr-list-mode)
+ (setq shr-list-mode (1+ shr-list-mode)))
+ "* "))
+ (shr-indentation (+ shr-indentation (length bullet))))
+ (insert bullet)
+ (shr-generic cont)))
+
+(defun shr-tag-br (cont)
+ (unless (bobp)
+ (insert "\n")
+ (shr-indent))
+ (shr-generic cont))
+
+(defun shr-tag-h1 (cont)
+ (shr-heading cont 'bold 'underline))
+
+(defun shr-tag-h2 (cont)
+ (shr-heading cont 'bold))
+
+(defun shr-tag-h3 (cont)
+ (shr-heading cont 'italic))
+
+(defun shr-tag-h4 (cont)
+ (shr-heading cont))
+
+(defun shr-tag-h5 (cont)
+ (shr-heading cont))
+
+(defun shr-tag-h6 (cont)
+ (shr-heading cont))
+
+(defun shr-tag-hr (cont)
+ (shr-ensure-newline)
+ (insert (make-string shr-width shr-hr-line) "\n"))
+
+(defun shr-tag-title (cont)
+ (shr-heading cont 'bold 'underline))
+
+(defun shr-tag-font (cont)
+ (let ((start (point))
+ (color (cdr (assq :color cont))))
+ (shr-generic cont)
+ (shr-insert-foreground-overlay color start (point))))
+
+;;; Table rendering algorithm.
+
+;; Table rendering is the only complicated thing here. We do this by
+;; first counting how many TDs there are in each TR, and registering
+;; how wide they think they should be ("width=45%", etc). Then we
+;; render each TD separately (this is done in temporary buffers, so
+;; that we can use all the rendering machinery as if we were in the
+;; main buffer). Now we know how much space each TD really takes, so
+;; we then render everything again with the new widths, and finally
+;; insert all these boxes into the main buffer.
+(defun shr-tag-table-1 (cont)
+ (setq cont (or (cdr (assq 'tbody cont))
+ cont))
+ (let* ((shr-inhibit-images t)
+ (shr-table-depth (1+ shr-table-depth))
+ (shr-kinsoku-shorten t)
+ ;; Find all suggested widths.
+ (columns (shr-column-specs cont))
+ ;; Compute how many characters wide each TD should be.
+ (suggested-widths (shr-pro-rate-columns columns))
+ ;; Do a "test rendering" to see how big each TD is (this can
+ ;; be smaller (if there's little text) or bigger (if there's
+ ;; unbreakable text).
+ (sketch (shr-make-table cont suggested-widths))
+ (sketch-widths (shr-table-widths sketch suggested-widths)))
+ ;; This probably won't work very well.
+ (when (> (+ (loop for width across sketch-widths
+ summing (1+ width))
+ shr-indentation 1)
+ (frame-width))
+ (setq truncate-lines t))
+ ;; Then render the table again with these new "hard" widths.
+ (shr-insert-table (shr-make-table cont sketch-widths t) sketch-widths))
+ ;; Finally, insert all the images after the table. The Emacs buffer
+ ;; model isn't strong enough to allow us to put the images actually
+ ;; into the tables.
+ (when (zerop shr-table-depth)
+ (dolist (elem (shr-find-elements cont 'img))
+ (shr-tag-img (cdr elem)))))
+
+(defun shr-tag-table (cont)
+ (shr-ensure-paragraph)
+ (let* ((caption (cdr (assq 'caption cont)))
+ (header (cdr (assq 'thead cont)))
+ (body (or (cdr (assq 'tbody cont)) cont))
+ (footer (cdr (assq 'tfoot cont)))
+ (bgcolor (cdr (assq :bgcolor cont)))
+ (nheader (if header (shr-max-columns header)))
+ (nbody (if body (shr-max-columns body)))
+ (nfooter (if footer (shr-max-columns footer))))
+ (shr-insert-background-overlay bgcolor (point))
+ (shr-tag-table-1
+ (nconc
+ (if caption `((tr (td ,@caption))))
+ (if header
+ (if footer
+ ;; hader + body + footer
+ (if (= nheader nbody)
+ (if (= nbody nfooter)
+ `((tr (td (table (tbody ,@header ,@body ,@footer)))))
+ (nconc `((tr (td (table (tbody ,@header ,@body)))))
+ (if (= nfooter 1)
+ footer
+ `((tr (td (table (tbody ,@footer))))))))
+ (nconc `((tr (td (table (tbody ,@header)))))
+ (if (= nbody nfooter)
+ `((tr (td (table (tbody ,@body ,@footer)))))
+ (nconc `((tr (td (table (tbody ,@body)))))
+ (if (= nfooter 1)
+ footer
+ `((tr (td (table (tbody ,@footer))))))))))
+ ;; header + body
+ (if (= nheader nbody)
+ `((tr (td (table (tbody ,@header ,@body)))))
+ (if (= nheader 1)
+ `(,@header (tr (td (table (tbody ,@body)))))
+ `((tr (td (table (tbody ,@header))))
+ (tr (td (table (tbody ,@body))))))))
+ (if footer
+ ;; body + footer
+ (if (= nbody nfooter)
+ `((tr (td (table (tbody ,@body ,@footer)))))
+ (nconc `((tr (td (table (tbody ,@body)))))
+ (if (= nfooter 1)
+ footer
+ `((tr (td (table (tbody ,@footer))))))))
+ (if caption
+ `((tr (td (table (tbody ,@body)))))
+ body)))))))
+
+(defun shr-find-elements (cont type)
+ (let (result)
+ (dolist (elem cont)
+ (cond ((eq (car elem) type)
+ (push elem result))
+ ((consp (cdr elem))
+ (setq result (nconc (shr-find-elements (cdr elem) type) result)))))
+ (nreverse result)))
+
+(defun shr-insert-table (table widths)
+ (shr-insert-table-ruler widths)
+ (dolist (row table)
+ (let ((start (point))
+ (height (let ((max 0))
+ (dolist (column row)
+ (setq max (max max (cadr column))))
+ max)))
+ (dotimes (i height)
+ (shr-indent)
+ (insert shr-table-vertical-line "\n"))
+ (dolist (column row)
+ (goto-char start)
+ (let ((lines (nth 2 column))
+ (overlay-lines (nth 3 column))
+ overlay overlay-line)
+ (dolist (line lines)
+ (setq overlay-line (pop overlay-lines))
+ (end-of-line)
+ (insert line shr-table-vertical-line)
+ (dolist (overlay overlay-line)
+ (let ((o (make-overlay (- (point) (nth 0 overlay) 1)
+ (- (point) (nth 1 overlay) 1)))
+ (properties (nth 2 overlay)))
+ (while properties
+ (overlay-put o (pop properties) (pop properties)))))
+ (forward-line 1))
+ ;; Add blank lines at padding at the bottom of the TD,
+ ;; possibly.
+ (dotimes (i (- height (length lines)))
+ (end-of-line)
+ (insert (make-string (string-width (car lines)) ? )
+ shr-table-vertical-line)
+ (forward-line 1)))))
+ (shr-insert-table-ruler widths)))
+
+(defun shr-insert-table-ruler (widths)
+ (when (and (bolp)
+ (> shr-indentation 0))
+ (shr-indent))
+ (insert shr-table-corner)
+ (dotimes (i (length widths))
+ (insert (make-string (aref widths i) shr-table-horizontal-line)
+ shr-table-corner))
+ (insert "\n"))
+
+(defun shr-table-widths (table suggested-widths)
+ (let* ((length (length suggested-widths))
+ (widths (make-vector length 0))
+ (natural-widths (make-vector length 0)))
+ (dolist (row table)
+ (let ((i 0))
+ (dolist (column row)
+ (aset widths i (max (aref widths i)
+ (car column)))
+ (aset natural-widths i (max (aref natural-widths i)
+ (cadr column)))
+ (setq i (1+ i)))))
+ (let ((extra (- (apply '+ (append suggested-widths nil))
+ (apply '+ (append widths nil))))
+ (expanded-columns 0))
+ (when (> extra 0)
+ (dotimes (i length)
+ ;; If the natural width is wider than the rendered width, we
+ ;; want to allow the column to expand.
+ (when (> (aref natural-widths i) (aref widths i))
+ (setq expanded-columns (1+ expanded-columns))))
+ (dotimes (i length)
+ (when (> (aref natural-widths i) (aref widths i))
+ (aset widths i (min
+ (1+ (aref natural-widths i))
+ (+ (/ extra expanded-columns)
+ (aref widths i))))))))
+ widths))
+
+(defun shr-make-table (cont widths &optional fill)
+ (let ((trs nil))
+ (dolist (row cont)
+ (when (eq (car row) 'tr)
+ (let ((tds nil)
+ (columns (cdr row))
+ (i 0)
+ column)
+ (while (< i (length widths))
+ (setq column (pop columns))
+ (when (or (memq (car column) '(td th))
+ (null column))
+ (push (shr-render-td (cdr column) (aref widths i) fill)
+ tds)
+ (setq i (1+ i))))
+ (push (nreverse tds) trs))))
+ (nreverse trs)))
+
+(defun shr-render-td (cont width fill)
+ (let ((background (shr-get-background (point))))
+ (with-temp-buffer
+ (let ((cache (cdr (assoc (cons width cont) shr-content-cache))))
+ (if cache
+ (insert cache)
+ (shr-insert-background-overlay (or (cdr (assq :bgcolor cont))
+ background)
+ (point))
+ (let ((shr-width width)
+ (shr-indentation 0))
+ (shr-generic cont))
+ (delete-region
+ (point)
+ (+ (point)
+ (skip-chars-backward " \t\n")))
+ (push (cons (cons width cont) (buffer-string))
+ shr-content-cache)))
+ (goto-char (point-min))
+ (let ((max 0))
+ (while (not (eobp))
+ (end-of-line)
+ (setq max (max max (current-column)))
+ (forward-line 1))
+ (when fill
+ (goto-char (point-min))
+ ;; If the buffer is totally empty, then put a single blank
+ ;; line here.
+ (if (zerop (buffer-size))
+ (insert (make-string width ? ))
+ ;; Otherwise, fill the buffer.
+ (while (not (eobp))
+ (end-of-line)
+ (when (> (- width (current-column)) 0)
+ (insert (make-string (- width (current-column)) ? )))
+ (forward-line 1))))
+ (if fill
+ (list max
+ (count-lines (point-min) (point-max))
+ (split-string (buffer-string) "\n")
+ (shr-collect-overlays))
+ (list max
+ (shr-natural-width)))))))
+
+(defun shr-natural-width ()
+ (goto-char (point-min))
+ (let ((current 0)
+ (max 0))
+ (while (not (eobp))
+ (end-of-line)
+ (setq current (+ current (current-column)))
+ (unless (get-text-property (point) 'shr-break)
+ (setq max (max max current)
+ current 0))
+ (forward-line 1))
+ max))
+
+(defun shr-collect-overlays ()
+ (save-excursion
+ (goto-char (point-min))
+ (let ((overlays nil))
+ (while (not (eobp))
+ (push (shr-overlays-in-region (point) (line-end-position))
+ overlays)
+ (forward-line 1))
+ (nreverse overlays))))
+
+(defun shr-overlays-in-region (start end)
+ (let (result)
+ (dolist (overlay (overlays-in start end))
+ (push (list (if (> start (overlay-start overlay))
+ (- end start)
+ (- end (overlay-start overlay)))
+ (if (< end (overlay-end overlay))
+ 0
+ (- end (overlay-end overlay)))
+ (overlay-properties overlay))
+ result))
+ (nreverse result)))
+
+(defun shr-pro-rate-columns (columns)
+ (let ((total-percentage 0)
+ (widths (make-vector (length columns) 0)))
+ (dotimes (i (length columns))
+ (setq total-percentage (+ total-percentage (aref columns i))))
+ (setq total-percentage (/ 1.0 total-percentage))
+ (dotimes (i (length columns))
+ (aset widths i (max (truncate (* (aref columns i)
+ total-percentage
+ (- shr-width (1+ (length columns)))))
+ 10)))
+ widths))
+
+;; Return a summary of the number and shape of the TDs in the table.
+(defun shr-column-specs (cont)
+ (let ((columns (make-vector (shr-max-columns cont) 1)))
+ (dolist (row cont)
+ (when (eq (car row) 'tr)
+ (let ((i 0))
+ (dolist (column (cdr row))
+ (when (memq (car column) '(td th))
+ (let ((width (cdr (assq :width (cdr column)))))
+ (when (and width
+ (string-match "\\([0-9]+\\)%" width))
+ (aset columns i
+ (/ (string-to-number (match-string 1 width))
+ 100.0))))
+ (setq i (1+ i)))))))
+ columns))
+
+(defun shr-count (cont elem)
+ (let ((i 0))
+ (dolist (sub cont)
+ (when (eq (car sub) elem)
+ (setq i (1+ i))))
+ i))
+
+(defun shr-max-columns (cont)
+ (let ((max 0))
+ (dolist (row cont)
+ (when (eq (car row) 'tr)
+ (setq max (max max (+ (shr-count (cdr row) 'td)
+ (shr-count (cdr row) 'th))))))
+ max))
+
+(provide 'shr)
+
+;;; shr.el ends here
diff --git a/lisp/gnus/sieve-manage.el b/lisp/gnus/sieve-manage.el
index 4b78490bbe3..a3647061d15 100644
--- a/lisp/gnus/sieve-manage.el
+++ b/lisp/gnus/sieve-manage.el
@@ -1,7 +1,7 @@
;;; sieve-manage.el --- Implementation of the managesive protocol in elisp
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+;; 2010 Free Software Foundation, Inc.
;; Author: Simon Josefsson <simon@josefsson.org>
@@ -43,7 +43,6 @@
;; `sieve-manage-close'
;; close a server connection.
;;
-;; `sieve-manage-authenticate'
;; `sieve-manage-listscripts'
;; `sieve-manage-deletescript'
;; `sieve-manage-getscript'
@@ -51,14 +50,11 @@
;;
;; and that's it. Example of a managesieve session in *scratch*:
;;
-;; (setq my-buf (sieve-manage-open "my.server.com"))
-;; " *sieve* my.server.com:2000*"
+;; (with-current-buffer (sieve-manage-open "mail.example.com")
+;; (sieve-manage-authenticate)
+;; (sieve-manage-listscripts))
;;
-;; (sieve-manage-authenticate "myusername" "mypassword" my-buf)
-;; 'auth
-;;
-;; (sieve-manage-listscripts my-buf)
-;; ("vacation" "testscript" ("splitmail") "badscript")
+;; => ((active . "main") "vacation")
;;
;; References:
;;
@@ -74,7 +70,7 @@
;;; Code:
-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
@@ -83,10 +79,12 @@
(require 'password))
(eval-when-compile
+ (require 'cl) ; caddr
(require 'sasl)
(require 'starttls))
(autoload 'sasl-find-mechanism "sasl")
(autoload 'starttls-open-stream "starttls")
+(autoload 'auth-source-user-or-password "auth-source")
;; User customizable variables:
@@ -100,11 +98,6 @@
:type 'string
:group 'sieve-manage)
-(defcustom sieve-manage-default-user (user-login-name)
- "Default username to use."
- :type 'string
- :group 'sieve-manage)
-
(defcustom sieve-manage-server-eol "\r\n"
"The EOL string sent from the server."
:type 'string
@@ -158,31 +151,32 @@ for doing the actual authentication."
:group 'sieve-manage)
(defcustom sieve-manage-default-port 2000
- "Default port number for managesieve protocol."
+ "Default port number or service name for managesieve protocol."
:type 'integer
:group 'sieve-manage)
+(defcustom sieve-manage-default-stream 'network
+ "Default stream type to use for `sieve-manage'.
+Must be a name of a stream in `sieve-manage-stream-alist'."
+ :type 'symbol
+ :group 'sieve-manage)
+
;; Internal variables:
(defconst sieve-manage-local-variables '(sieve-manage-server
sieve-manage-port
sieve-manage-auth
sieve-manage-stream
- sieve-manage-username
- sieve-manage-password
sieve-manage-process
sieve-manage-client-eol
sieve-manage-server-eol
sieve-manage-capability))
-(defconst sieve-manage-default-stream 'network)
(defconst sieve-manage-coding-system-for-read 'binary)
(defconst sieve-manage-coding-system-for-write 'binary)
(defvar sieve-manage-stream nil)
(defvar sieve-manage-auth nil)
(defvar sieve-manage-server nil)
(defvar sieve-manage-port nil)
-(defvar sieve-manage-username nil)
-(defvar sieve-manage-password nil)
(defvar sieve-manage-state 'closed
"Managesieve state.
Valid states are `closed', `initial', `nonauth', and `auth'.")
@@ -191,65 +185,10 @@ Valid states are `closed', `initial', `nonauth', and `auth'.")
;; Internal utility functions
-(defsubst sieve-manage-disable-multibyte ()
+(defmacro sieve-manage-disable-multibyte ()
"Enable multibyte in the current buffer."
- (when (fboundp 'set-buffer-multibyte)
- (set-buffer-multibyte nil)))
-
-(declare-function password-read "password-cache" (prompt &optional key))
-(declare-function password-cache-add "password-cache" (key password))
-(declare-function password-cache-remove "password-cache" (key))
-
-;; Uses the dynamically bound `reason' variable.
-(defvar reason)
-(defun sieve-manage-interactive-login (buffer loginfunc)
- "Login to server in BUFFER.
-LOGINFUNC is passed a username and a password, it should return t if
-it was successful authenticating itself to the server, nil otherwise.
-Returns t if login was successful, nil otherwise."
- (with-current-buffer buffer
- (make-local-variable 'sieve-manage-username)
- (make-local-variable 'sieve-manage-password)
- (let (user passwd ret reason passwd-key)
- (condition-case ()
- (while (or (not user) (not passwd))
- (setq user (or sieve-manage-username
- (read-from-minibuffer
- (concat "Managesieve username for "
- sieve-manage-server ": ")
- (or user sieve-manage-default-user)))
- passwd-key (concat "managesieve:" user "@" sieve-manage-server
- ":" sieve-manage-port)
- passwd (or sieve-manage-password
- (password-read (concat "Managesieve password for "
- user "@" sieve-manage-server
- ": ")
- passwd-key)))
- (when (y-or-n-p "Store password for this session? ")
- (password-cache-add passwd-key (copy-sequence passwd)))
- (when (and user passwd)
- (if (funcall loginfunc user passwd)
- (setq ret t
- sieve-manage-username user)
- (if reason
- (message "Login failed (reason given: %s)..." reason)
- (message "Login failed..."))
- (password-cache-remove passwd-key)
- (setq sieve-manage-password nil)
- (setq passwd nil)
- (setq reason nil)
- (sit-for 1))))
- (quit (with-current-buffer buffer
- (password-cache-remove passwd-key)
- (setq user nil
- passwd nil
- sieve-manage-password nil)))
- (error (with-current-buffer buffer
- (password-cache-remove passwd-key)
- (setq user nil
- passwd nil
- sieve-manage-password nil))))
- ret)))
+ (unless (featurep 'xemacs)
+ '(set-buffer-multibyte nil)))
(defun sieve-manage-erase (&optional p buffer)
(let ((buffer (or buffer (current-buffer))))
@@ -331,70 +270,72 @@ Returns t if login was successful, nil otherwise."
process)))
;; Authenticators
-
(defun sieve-sasl-auth (buffer mech)
"Login to server using the SASL MECH method."
(message "sieve: Authenticating using %s..." mech)
- (if (sieve-manage-interactive-login
- buffer
- (lambda (user passwd)
- (let (client step tag data rsp)
- (setq client (sasl-make-client (sasl-find-mechanism (list mech))
- user "sieve" sieve-manage-server))
- (setq sasl-read-passphrase (function (lambda (prompt) passwd)))
- (setq step (sasl-next-step client nil))
- (setq tag
- (sieve-manage-send
- (concat
- "AUTHENTICATE \""
- mech
- "\""
- (and (sasl-step-data step)
- (concat
- " \""
- (base64-encode-string
- (sasl-step-data step)
- 'no-line-break)
- "\"")))))
- (catch 'done
- (while t
- (setq rsp nil)
- (goto-char (point-min))
- (while (null (or (progn
- (setq rsp (sieve-manage-is-string))
- (if (not (and rsp (looking-at
- sieve-manage-server-eol)))
- (setq rsp nil)
- (goto-char (match-end 0))
- rsp))
- (setq rsp (sieve-manage-is-okno))))
- (accept-process-output sieve-manage-process 1)
- (goto-char (point-min)))
- (sieve-manage-erase)
- (when (sieve-manage-ok-p rsp)
- (when (string-match "^SASL \"\\([^\"]+\\)\"" (cadr rsp))
- (sasl-step-set-data
- step (base64-decode-string (match-string 1 (cadr rsp)))))
- (if (and (setq step (sasl-next-step client step))
- (setq data (sasl-step-data step)))
- ;; We got data for server but it's finished
- (error "Server not ready for SASL data: %s" data)
- ;; The authentication process is finished.
- (throw 'done t)))
- (unless (stringp rsp)
- (apply 'error "Server aborted SASL authentication: %s %s %s"
- rsp))
- (sasl-step-set-data step (base64-decode-string rsp))
- (setq step (sasl-next-step client step))
- (sieve-manage-send
- (if (sasl-step-data step)
- (concat "\""
- (base64-encode-string (sasl-step-data step)
- 'no-line-break)
- "\"")
- "")))))))
- (message "sieve: Authenticating using %s...done" mech)
- (message "sieve: Authenticating using %s...failed" mech)))
+ (with-current-buffer buffer
+ (let* ((user-password (auth-source-user-or-password
+ '("login" "password")
+ sieve-manage-server
+ "sieve" nil t))
+ (client (sasl-make-client (sasl-find-mechanism (list mech))
+ (car user-password) "sieve" sieve-manage-server))
+ (sasl-read-passphrase
+ ;; We *need* to copy the password, because sasl will modify it
+ ;; somehow.
+ `(lambda (prompt) ,(copy-sequence (cadr user-password))))
+ (step (sasl-next-step client nil))
+ (tag (sieve-manage-send
+ (concat
+ "AUTHENTICATE \""
+ mech
+ "\""
+ (and (sasl-step-data step)
+ (concat
+ " \""
+ (base64-encode-string
+ (sasl-step-data step)
+ 'no-line-break)
+ "\"")))))
+ data rsp)
+ (catch 'done
+ (while t
+ (setq rsp nil)
+ (goto-char (point-min))
+ (while (null (or (progn
+ (setq rsp (sieve-manage-is-string))
+ (if (not (and rsp (looking-at
+ sieve-manage-server-eol)))
+ (setq rsp nil)
+ (goto-char (match-end 0))
+ rsp))
+ (setq rsp (sieve-manage-is-okno))))
+ (accept-process-output sieve-manage-process 1)
+ (goto-char (point-min)))
+ (sieve-manage-erase)
+ (when (sieve-manage-ok-p rsp)
+ (when (and (cadr rsp)
+ (string-match "^SASL \"\\([^\"]+\\)\"" (cadr rsp)))
+ (sasl-step-set-data
+ step (base64-decode-string (match-string 1 (cadr rsp)))))
+ (if (and (setq step (sasl-next-step client step))
+ (setq data (sasl-step-data step)))
+ ;; We got data for server but it's finished
+ (error "Server not ready for SASL data: %s" data)
+ ;; The authentication process is finished.
+ (throw 'done t)))
+ (unless (stringp rsp)
+ (error "Server aborted SASL authentication: %s" (caddr rsp)))
+ (sasl-step-set-data step (base64-decode-string rsp))
+ (setq step (sasl-next-step client step))
+ (sieve-manage-send
+ (if (sasl-step-data step)
+ (concat "\""
+ (base64-encode-string (sasl-step-data step)
+ 'no-line-break)
+ "\"")
+ ""))))
+ (message "sieve: Login using %s...done" mech))))
(defun sieve-manage-cram-md5-p (buffer)
(sieve-manage-capability "SASL" "CRAM-MD5" buffer))
@@ -449,7 +390,7 @@ Optional argument AUTH indicates authenticator to use, see
If nil, chooses the best stream the server is capable of.
Optional argument BUFFER is buffer (buffer, or string naming buffer)
to work in."
- (setq buffer (or buffer (format " *sieve* %s:%d" server (or port 2000))))
+ (setq buffer (or buffer (format " *sieve* %s:%s" server (or port sieve-manage-default-port))))
(with-current-buffer (get-buffer-create buffer)
(mapc 'make-local-variable sieve-manage-local-variables)
(sieve-manage-disable-multibyte)
@@ -506,6 +447,17 @@ to work in."
(sieve-manage-erase)
buffer)))
+(defun sieve-manage-authenticate (&optional buffer)
+ "Authenticate on server in BUFFER.
+Return `sieve-manage-state' value."
+ (with-current-buffer (or buffer (current-buffer))
+ (if (eq sieve-manage-state 'nonauth)
+ (when (funcall (nth 2 (assq sieve-manage-auth
+ sieve-manage-authenticator-alist))
+ (current-buffer))
+ (setq sieve-manage-state 'auth))
+ sieve-manage-state)))
+
(defun sieve-manage-opened (&optional buffer)
"Return non-nil if connection to managesieve server in BUFFER is open.
If BUFFER is nil then the current buffer is used."
@@ -529,32 +481,19 @@ If BUFFER is nil, the current buffer is used."
(sieve-manage-erase)
t))
-(defun sieve-manage-authenticate (&optional user passwd buffer)
- "Authenticate to server in BUFFER, using current buffer if nil.
-It uses the authenticator specified when opening the server. If the
-authenticator requires username/passwords, they are queried from the
-user and optionally stored in the buffer. If USER and/or PASSWD is
-specified, the user will not be questioned and the username and/or
-password is remembered in the buffer."
- (with-current-buffer (or buffer (current-buffer))
- (if (not (eq sieve-manage-state 'nonauth))
- (eq sieve-manage-state 'auth)
- (make-local-variable 'sieve-manage-username)
- (make-local-variable 'sieve-manage-password)
- (if user (setq sieve-manage-username user))
- (if passwd (setq sieve-manage-password passwd))
- (if (funcall (nth 2 (assq sieve-manage-auth
- sieve-manage-authenticator-alist)) buffer)
- (setq sieve-manage-state 'auth)))))
-
(defun sieve-manage-capability (&optional name value buffer)
+ "Check if capability NAME of server BUFFER match VALUE.
+If it does, return the server value of NAME. If not returns nil.
+If VALUE is nil, do not check VALUE and return server value.
+If NAME is nil, return the full server list of capabilities."
(with-current-buffer (or buffer (current-buffer))
(if (null name)
sieve-manage-capability
- (if (null value)
- (nth 1 (assoc name sieve-manage-capability))
- (when (string-match value (nth 1 (assoc name sieve-manage-capability)))
- (nth 1 (assoc name sieve-manage-capability)))))))
+ (let ((server-value (cadr (assoc name sieve-manage-capability))))
+ (when (or (null value)
+ (and server-value
+ (string-match value server-value)))
+ server-value)))))
(defun sieve-manage-listscripts (&optional buffer)
(with-current-buffer (or buffer (current-buffer))
@@ -701,5 +640,4 @@ password is remembered in the buffer."
(provide 'sieve-manage)
-;; arch-tag: 321c4640-1371-4495-9baf-8ccb71dd5bd1
;; sieve-manage.el ends here
diff --git a/lisp/gnus/sieve-mode.el b/lisp/gnus/sieve-mode.el
index 99ec57ce38b..78927009fc6 100644
--- a/lisp/gnus/sieve-mode.el
+++ b/lisp/gnus/sieve-mode.el
@@ -1,7 +1,7 @@
;;; sieve-mode.el --- Sieve code editing commands for Emacs
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+;; 2010 Free Software Foundation, Inc.
;; Author: Simon Josefsson <simon@josefsson.org>
@@ -49,7 +49,6 @@
(autoload 'sieve-manage "sieve")
(autoload 'sieve-upload "sieve")
-(require 'easymenu)
(eval-when-compile
(require 'font-lock))
@@ -186,6 +185,7 @@
"Menubar used in sieve mode.")
;; Code for Sieve editing mode.
+(autoload 'easy-menu-add-item "easymenu")
;;;###autoload
(define-derived-mode sieve-mode c-mode "Sieve"
@@ -216,5 +216,4 @@ Turning on Sieve mode runs `sieve-mode-hook'."
(provide 'sieve-mode)
-;; arch-tag: 3b8ab76d-065d-4c52-b1e8-ab2ec21f2ace
;; sieve-mode.el ends here
diff --git a/lisp/gnus/sieve.el b/lisp/gnus/sieve.el
index 1b0322064df..ca181c2e7b3 100644
--- a/lisp/gnus/sieve.el
+++ b/lisp/gnus/sieve.el
@@ -320,11 +320,12 @@ Server : " server ":" (or port "2000") "
(insert "\n"))))
(defun sieve-open-server (server &optional port)
- ;; open server
- (set (make-local-variable 'sieve-manage-buffer)
- (sieve-manage-open server))
- ;; authenticate
- (sieve-manage-authenticate nil nil sieve-manage-buffer))
+ "Open SERVER (on PORT) and authenticate."
+ (with-current-buffer
+ ;; open server
+ (set (make-local-variable 'sieve-manage-buffer)
+ (sieve-manage-open server))
+ (sieve-manage-authenticate)))
(defun sieve-refresh-scriptlist ()
(interactive)
@@ -380,5 +381,4 @@ Server : " server ":" (or port "2000") "
(provide 'sieve)
-;; arch-tag: 7f6a6d94-94e1-4654-ab9a-aee21b9b8a94
;; sieve.el ends here
diff --git a/lisp/gnus/smiley.el b/lisp/gnus/smiley.el
index fbe71e7725f..afffc64f12f 100644
--- a/lisp/gnus/smiley.el
+++ b/lisp/gnus/smiley.el
@@ -102,7 +102,8 @@ is nil, use `smiley-style'."
;; The XEmacs version has a baroque, if not rococo, set of these.
(defcustom smiley-regexp-alist
- '(("\\(;-?)\\)\\W" 1 "blink")
+ '(("\\(;-)\\)\\W" 1 "blink")
+ ("[^;]\\(;)\\)\\W" 1 "blink")
("\\(:-]\\)\\W" 1 "forced")
("\\(8-)\\)\\W" 1 "braindamaged")
("\\(:-|\\)\\W" 1 "indifferent")
@@ -119,6 +120,7 @@ is nil, use `smiley-style'."
The elements are (REGEXP MATCH IMAGE), where MATCH is the submatch in
regexp to replace with IMAGE. IMAGE is the name of an image file in
`smiley-data-directory'."
+ :version "24.1"
:type '(repeat (list regexp
(integer :tag "Regexp match number")
(string :tag "Image name")))
@@ -226,5 +228,4 @@ With arg, turn displaying on if and only if arg is positive."
(provide 'smiley)
-;; arch-tag: 5beb161b-4321-40af-8ac9-876afb8ee818
;;; smiley.el ends here
diff --git a/lisp/gnus/smime.el b/lisp/gnus/smime.el
index b60acee445d..27db3e35e20 100644
--- a/lisp/gnus/smime.el
+++ b/lisp/gnus/smime.el
@@ -1,7 +1,7 @@
;;; smime.el --- S/MIME support library
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+;; 2009, 2010 Free Software Foundation, Inc.
;; Author: Simon Josefsson <simon@josefsson.org>
;; Keywords: SMIME X.509 PEM OpenSSL
@@ -119,7 +119,7 @@
;;; Code:
-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
(require 'dig)
@@ -371,12 +371,9 @@ KEYFILE should contain a PEM encoded key and certificate."
(if keyfile
keyfile
(smime-get-key-with-certs-by-email
- (completing-read
- (concat "Sign using key"
- (if smime-keys
- (concat " (default " (caar smime-keys) "): ")
- ": "))
- smime-keys nil nil (car-safe (car-safe smime-keys))))))
+ (gnus-completing-read
+ "Sign using key"
+ smime-keys nil (car-safe (car-safe smime-keys))))))
(error "Signing failed"))))
(defun smime-encrypt-buffer (&optional certfiles buffer)
@@ -429,10 +426,9 @@ Any details (stdout and stderr) are left in the buffer specified by
(insert-buffer-substring smime-details-buffer)
nil))
-(defvar from)
-
-(defun smime-decrypt-region (b e keyfile)
+(defun smime-decrypt-region (b e keyfile &optional from)
"Decrypt S/MIME message in region between B and E with key in KEYFILE.
+Optional FROM specifies sender's mail address.
On success, replaces region with decrypted data and return non-nil.
Any details (stderr on success, stdout and stderr on error) are left
in the buffer specified by `smime-details-buffer'."
@@ -455,8 +451,7 @@ in the buffer specified by `smime-details-buffer'."
(delete-file tmpfile)))
(progn
(delete-region b e)
- (when (boundp 'from)
- ;; `from' is dynamically bound in mm-dissect.
+ (when from
(insert "From: " from "\n"))
(insert-buffer-substring buffer)
(kill-buffer buffer)
@@ -502,11 +497,9 @@ in the buffer specified by `smime-details-buffer'."
(expand-file-name
(or keyfile
(smime-get-key-by-email
- (completing-read
- (concat "Decipher using key"
- (if smime-keys (concat " (default " (caar smime-keys) "): ")
- ": "))
- smime-keys nil nil (car-safe (car-safe smime-keys)))))))))
+ (gnus-completing-read
+ "Decipher using key"
+ smime-keys nil (car-safe (car-safe smime-keys)))))))))
;; Various operations
@@ -592,17 +585,20 @@ A string or a list of strings is returned."
(kill-buffer digbuf)
retbuf))
+(declare-function ldap-search "ldap"
+ (filter &optional host attributes attrsonly withdn))
+
(defun smime-cert-by-ldap-1 (mail host)
"Get cetificate for MAIL from the ldap server at HOST."
(let ((ldapresult
(funcall
- (if (or (featurep 'xemacs)
- ;; For Emacs >= 22 we don't need smime-ldap.el
- (< emacs-major-version 22))
+ (if (featurep 'xemacs)
(progn
(require 'smime-ldap)
'smime-ldap-search)
- 'ldap-search)
+ (progn
+ (require 'ldap)
+ 'ldap-search))
(concat "mail=" mail)
host '("userCertificate") nil))
(retbuf (generate-new-buffer (format "*certificate for %s*" mail)))
@@ -649,19 +645,18 @@ A string or a list of strings is returned."
(defvar smime-buffer "*SMIME*")
-(defvar smime-mode-map nil)
-(put 'smime-mode 'mode-class 'special)
-
-(unless smime-mode-map
- (setq smime-mode-map (make-sparse-keymap))
- (suppress-keymap smime-mode-map)
+(defvar smime-mode-map
+ (let ((map (make-sparse-keymap)))
+ (suppress-keymap map)
+ (define-key map "q" 'smime-exit)
+ (define-key map "f" 'smime-certificate-info)
+ map))
- (define-key smime-mode-map "q" 'smime-exit)
- (define-key smime-mode-map "f" 'smime-certificate-info))
+(autoload 'gnus-completing-read "gnus-util")
-(autoload 'gnus-run-mode-hooks "gnus-util")
-
-(defun smime-mode ()
+(put 'smime-mode 'mode-class 'special)
+(define-derived-mode smime-mode fundamental-mode ;special-mode
+ "SMIME"
"Major mode for browsing, viewing and fetching certificates.
All normal editing commands are switched off.
@@ -670,16 +665,10 @@ All normal editing commands are switched off.
The following commands are available:
\\{smime-mode-map}"
- (interactive)
- (kill-all-local-variables)
- (setq major-mode 'smime-mode)
- (setq mode-name "SMIME")
(setq mode-line-process nil)
- (use-local-map smime-mode-map)
(buffer-disable-undo)
(setq truncate-lines t)
- (setq buffer-read-only t)
- (gnus-run-mode-hooks 'smime-mode-hook))
+ (setq buffer-read-only t))
(defun smime-certificate-info (certfile)
(interactive "fCertificate file: ")
@@ -708,8 +697,7 @@ The following commands are available:
"Go to the SMIME buffer."
(interactive)
(unless (get-buffer smime-buffer)
- (save-excursion
- (set-buffer (get-buffer-create smime-buffer))
+ (with-current-buffer (get-buffer-create smime-buffer)
(smime-mode)))
(smime-draw-buffer)
(switch-to-buffer smime-buffer))
@@ -729,5 +717,4 @@ The following commands are available:
(provide 'smime)
-;; arch-tag: e3f9b938-5085-4510-8a11-6625269c9a9e
;;; smime.el ends here
diff --git a/lisp/gnus/spam-report.el b/lisp/gnus/spam-report.el
index 45ca4b03978..30e0ae58f05 100644
--- a/lisp/gnus/spam-report.el
+++ b/lisp/gnus/spam-report.el
@@ -95,12 +95,12 @@ undo that change.")
"Report an article as spam by resending via email.
Reports is as ham when HAM is set."
(dolist (article articles)
- (gnus-message 6
+ (gnus-message 6
"Reporting %s article %d to <%s>..."
(if ham "ham" "spam")
article spam-report-resend-to)
(unless spam-report-resend-to
- (customize-set-variable
+ (customize-set-variable
spam-report-resend-to
(read-from-minibuffer "email address to resend SPAM/HAM to? ")))
;; This is ganked from the `gnus-summary-resend-message' function.
@@ -109,8 +109,7 @@ Reports is as ham when HAM is set."
;; select this particular article
(gnus-summary-select-article nil nil nil article)
;; resend it to the destination address
- (save-excursion
- (set-buffer gnus-original-article-buffer)
+ (with-current-buffer gnus-original-article-buffer
(message-resend spam-report-resend-to))))
(defun spam-report-resend-ham (articles)
@@ -257,6 +256,7 @@ This is initialized based on `user-mail-address'."
80))
(error "Could not open connection to %s" host))
(set-marker (process-mark tcp-connection) (point-min))
+ (gnus-set-process-query-on-exit-flag tcp-connection nil)
(process-send-string
tcp-connection
(format "GET %s HTTP/1.1\nUser-Agent: %s\nHost: %s\n\n"
@@ -267,7 +267,7 @@ This is initialized based on `user-mail-address'."
(gnus-message 7 "Waiting for response from %s..." host)
(while (and (memq (process-status tcp-connection) '(open run))
(zerop (buffer-size)))
- (accept-process-output tcp-connection))
+ (accept-process-output tcp-connection 1))
(gnus-message 7 "Waiting for response from %s... done" host)))))
;;;###autoload
@@ -292,8 +292,7 @@ symbol `ask', query before flushing the queue file."
(gnus-message 7 "Processing requests using `%s'."
spam-report-url-ping-function))
(or file (setq file spam-report-requests-file))
- (save-excursion
- (set-buffer (find-file-noselect file))
+ (with-current-buffer (find-file-noselect file)
(goto-char (point-min))
(while (and (not (eobp))
(re-search-forward
@@ -385,5 +384,4 @@ Process queued spam reports."
(provide 'spam-report)
-;; arch-tag: f6683295-ec89-4ab5-8803-8cc842293022
;;; spam-report.el ends here.
diff --git a/lisp/gnus/spam-stat.el b/lisp/gnus/spam-stat.el
index 45c596539c9..d6b20df78b8 100644
--- a/lisp/gnus/spam-stat.el
+++ b/lisp/gnus/spam-stat.el
@@ -1,6 +1,7 @@
;;; spam-stat.el --- detecting spam based on statistics
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+;; 2010 Free Software Foundation, Inc.
;; Author: Alex Schroeder <alex@gnu.org>
;; Keywords: network
@@ -557,6 +558,8 @@ check the variable `spam-stat-score-data'."
(when (re-search-forward "^Xref:.*\n" nil t)
(delete-region (match-beginning 0) (match-end 0)))))
+(autoload 'time-to-number-of-days "time-date")
+
(defun spam-stat-process-directory (dir func)
"Process all the regular files in directory DIR using function FUNC."
(let* ((files (directory-files dir t "^[^.]"))
@@ -671,5 +674,4 @@ COUNT defaults to 5"
(provide 'spam-stat)
-;; arch-tag: ff1d2200-8ddb-42fb-bb7b-1b5e20448554
;;; spam-stat.el ends here
diff --git a/lisp/gnus/spam-wash.el b/lisp/gnus/spam-wash.el
index 2ef7452a0e9..d201c9eddf9 100644
--- a/lisp/gnus/spam-wash.el
+++ b/lisp/gnus/spam-wash.el
@@ -69,5 +69,4 @@
(provide 'spam-wash)
-;; arch-tag: 3c7f94a7-c96d-4c77-bb59-950df12bc85f
;;; spam-wash.el ends here
diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el
index 10304c00c86..097299f30c4 100644
--- a/lisp/gnus/spam.el
+++ b/lisp/gnus/spam.el
@@ -39,7 +39,7 @@
;;{{{ compilation directives and autoloads/requires
-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
@@ -689,7 +689,8 @@ order for SpamAssassin to recognize the new registered spam."
"Sx" gnus-summary-mark-as-spam
"Mst" spam-generic-score
"Msx" gnus-summary-mark-as-spam
- "\M-d" gnus-summary-mark-as-spam)
+ "\M-d" gnus-summary-mark-as-spam
+ "$" gnus-summary-mark-as-spam)
(defvar spam-cache-lookups t
"Whether spam.el will try to cache lookups using `spam-caches'.")
@@ -1286,6 +1287,7 @@ variable. When the processor variable is nil, just the
classification and spam-use-* check variable are used. This is
superseded by the new spam backend code, so it's only consulted
for backwards compatibility.")
+(make-obsolete-variable 'spam-list-of-processors nil "22.1")
(defun spam-group-processor-p (group backend &optional classification)
"Checks if GROUP has a BACKEND with CLASSIFICATION registered.
@@ -1605,8 +1607,7 @@ to find it out)."
article))))
(defun spam-fetch-article-header (article)
- (save-excursion
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
(gnus-read-header article)
(nth 3 (assq article gnus-newsgroup-data))))
;;}}}
@@ -2172,8 +2173,7 @@ See `spam-ifile-database'."
(with-temp-buffer
(let ((temp-buffer-name (buffer-name))
(db-param (spam-get-ifile-database-parameter)))
- (save-excursion
- (set-buffer article-buffer-name)
+ (with-current-buffer article-buffer-name
(apply 'call-process-region
(point-min) (point-max) spam-ifile-program
nil temp-buffer-name nil "-c"
@@ -2318,9 +2318,8 @@ With a non-nil REMOVE, remove the ADDRESSES."
;; else, we have a list of addresses here
(unless (file-exists-p (file-name-directory file))
(make-directory (file-name-directory file) t))
- (save-excursion
- (set-buffer
- (find-file-noselect file))
+ (with-current-buffer
+ (find-file-noselect file)
(dolist (a addresses)
(when (stringp a)
(goto-char (point-min))
@@ -2521,8 +2520,7 @@ With a non-nil REMOVE, remove the ADDRESSES."
return)
(with-temp-buffer
(let ((temp-buffer-name (buffer-name)))
- (save-excursion
- (set-buffer article-buffer-name)
+ (with-current-buffer article-buffer-name
(apply 'call-process-region
(point-min) (point-max)
spam-bogofilter-program
@@ -2579,8 +2577,7 @@ With a non-nil REMOVE, remove the ADDRESSES."
(let ((article-buffer-name (buffer-name)))
(with-temp-buffer
(let ((temp-buffer-name (buffer-name)))
- (save-excursion
- (set-buffer article-buffer-name)
+ (with-current-buffer article-buffer-name
(let ((status
(apply 'call-process-region
(point-min) (point-max)
@@ -2656,8 +2653,7 @@ With a non-nil REMOVE, remove the ADDRESSES."
(let ((article-buffer-name (buffer-name)))
(with-temp-buffer
(let ((temp-buffer-name (buffer-name)))
- (save-excursion
- (set-buffer article-buffer-name)
+ (with-current-buffer article-buffer-name
(apply 'call-process-region
(point-min) (point-max) spam-assassin-program
nil temp-buffer-name nil spam-spamassassin-arguments))
@@ -2691,8 +2687,7 @@ With a non-nil REMOVE, remove the ADDRESSES."
;; group the articles into mbox format
(dolist (article articles)
(let (article-string)
- (save-excursion
- (set-buffer summary-buffer-name)
+ (with-current-buffer summary-buffer-name
(setq article-string (spam-get-article-as-string article)))
(when (stringp article-string)
(insert "From \n") ; mbox separator (sa-learn only checks the
@@ -2755,8 +2750,7 @@ With a non-nil REMOVE, remove the ADDRESSES."
return)
(with-temp-buffer
(let ((temp-buffer-name (buffer-name)))
- (save-excursion
- (set-buffer article-buffer-name)
+ (with-current-buffer article-buffer-name
(apply 'call-process-region
(point-min) (point-max)
spam-bsfilter-program
@@ -2841,8 +2835,7 @@ With a non-nil REMOVE, remove the ADDRESSES."
return)
(with-temp-buffer
(let ((temp-buffer-name (buffer-name)))
- (save-excursion
- (set-buffer article-buffer-name)
+ (with-current-buffer article-buffer-name
(apply 'call-process-region
(point-min) (point-max)
spam-crm114-program
@@ -2941,5 +2934,4 @@ installed through `spam-necessary-extra-headers'."
(provide 'spam)
-;; arch-tag: 07e6e0ca-ab0a-4412-b445-1f6c72a4f27f
;;; spam.el ends here
diff --git a/lisp/gnus/starttls.el b/lisp/gnus/starttls.el
index 18c05bfc50f..a4d33b81bb5 100644
--- a/lisp/gnus/starttls.el
+++ b/lisp/gnus/starttls.el
@@ -254,8 +254,7 @@ handshake, or nil on failure."
(starttls-set-process-query-on-exit-flag process nil)
(while (and (processp process)
(eq (process-status process) 'run)
- (save-excursion
- (set-buffer buffer)
+ (with-current-buffer buffer
(goto-char old-max)
(not (setq done (re-search-forward
starttls-connect nil t)))))
@@ -270,6 +269,7 @@ handshake, or nil on failure."
host port (if done "done" "failed"))
process))
+;;;###autoload
(defun starttls-open-stream (name buffer host port)
"Open a TLS connection for a port to a host.
Returns a subprocess object to represent the connection.
@@ -311,5 +311,4 @@ GNUTLS requires a port number."
(provide 'starttls)
-;; arch-tag: 648b3bd8-63bd-47f5-904c-7c819aea2297
;;; starttls.el ends here
diff --git a/lisp/gnus/utf7.el b/lisp/gnus/utf7.el
index ebf01d17b9c..47c3b0f4c5d 100644
--- a/lisp/gnus/utf7.el
+++ b/lisp/gnus/utf7.el
@@ -78,7 +78,7 @@
(defconst utf7-utf-16-coding-system
(cond ((mm-coding-system-p 'utf-16-be-no-signature) ; Mule-UCS
'utf-16-be-no-signature)
- ((and (mm-coding-system-p 'utf-16-be) ; Emacs 21.3, Emacs 22
+ ((and (mm-coding-system-p 'utf-16-be) ; Emacs
;; Avoid versions with BOM.
(= 2 (length (encode-coding-string "a" 'utf-16-be))))
'utf-16-be)
@@ -112,7 +112,7 @@ Use IMAP modification if FOR-IMAP is non-nil."
(skip-chars-forward not-direct-encoding-chars)))
(if (and (= fc esc-char)
(= run-length 1)) ; Lone esc-char?
- (delete-backward-char 1) ; Now there's one too many
+ (delete-char -1) ; Now there's one too many
(utf7-fragment-encode p (point) for-imap))
(insert "-")))))))
@@ -153,7 +153,7 @@ Use IMAP modification if FOR-IMAP is non-nil."
(save-excursion
(utf7-fragment-decode p (point) for-imap)
(goto-char p)
- (delete-backward-char 1)))))))))
+ (delete-char -1)))))))))
(defun utf7-fragment-decode (start end &optional for-imap)
"Decode base64 encoded fragment from START to END of UTF-7 text in buffer.
@@ -205,6 +205,7 @@ Characters are in raw byte pairs in narrowed buffer."
(mm-decode-coding-region (point-min) (point-max) 'iso-8859-1)
(mm-enable-multibyte))
+;;;###autoload
(defun utf7-encode (string &optional for-imap)
"Encode UTF-7 STRING. Use IMAP modification if FOR-IMAP is non-nil."
(if (and (coding-system-p 'utf-7) (coding-system-p 'utf-7-imap))
@@ -228,5 +229,4 @@ Characters are in raw byte pairs in narrowed buffer."
(provide 'utf7)
-;; arch-tag: 96078b55-85c7-4161-aed2-932c24b282c7
;;; utf7.el ends here
diff --git a/lisp/gnus/webmail.el b/lisp/gnus/webmail.el
deleted file mode 100644
index 106445d0522..00000000000
--- a/lisp/gnus/webmail.el
+++ /dev/null
@@ -1,1152 +0,0 @@
-;;; webmail.el --- interface of web mail
-
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
-;; Keywords: hotmail netaddress my-deja netscape
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Note: Now mail.yahoo.com provides POP3 service, the webmail
-;; fetching is not going to be supported.
-
-;; Note: You need to have `url' and `w3' installed for this backend to
-;; work. `w3' must be 4.0pre46+one-line-cookie patch or standalone
-;; `url'.
-
-;; Todo: To support more web mail servers.
-
-;; Known bugs:
-;; 1. Net@ddress may corrupt `X-Face'.
-
-;; Warning:
-;; Webmail is an experimental function, which means NO WARRANTY.
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-
-(require 'nnoo)
-(require 'message)
-(require 'gnus-util)
-(require 'gnus)
-(require 'nnmail)
-(require 'mm-util)
-(require 'mm-url)
-(require 'mml)
-(eval-when-compile
- (ignore-errors
- (require 'url)
- (require 'url-cookie)))
-;; Report failure to find w3 at load time if appropriate.
-(eval '(progn
- (require 'url)
- (require 'url-cookie)))
-
-;;;
-
-(defvar webmail-type-definition
- '((hotmail
- ;; Hotmail hate other HTTP user agents and use one line cookie
- (paranoid agent cookie post)
- (address . "www.hotmail.com")
- (open-url "http://www.hotmail.com/")
- (open-snarf . webmail-hotmail-open)
- ;; W3 hate redirect POST
- (login-url
- "http://%s/cgi-bin/dologin?login=%s&passwd=%s&enter=Sign+in&sec=no&curmbox=ACTIVE&_lang=&js=yes&id=2&tw=-10000&beta="
- webmail-aux user password)
- ;;(login-snarf . webmail-hotmail-login)
- ;;(list-url "%s" webmail-aux)
- (list-snarf . webmail-hotmail-list)
- (article-snarf . webmail-hotmail-article)
- (trash-url
- "%s&login=%s&f=33792&curmbox=ACTIVE&_lang=&foo=inbox&js=&page=&%s=on&_HMaction=MoveTo&tobox=trAsH&nullbox="
- webmail-aux user id))
- (yahoo
- (paranoid agent cookie post)
- (address . "mail.yahoo.com")
- (open-url "http://mail.yahoo.com/")
- (open-snarf . webmail-yahoo-open)
- (login-url;; yahoo will not accept GET
- content
- ("%s" webmail-aux)
- ".tries=&.src=ym&.last=&promo=&.intl=&.bypass=&.partner=&.chkP=Y&.done=&login=%s&passwd=%s"
- user password)
- (login-snarf . webmail-yahoo-login)
- (list-url "%s&rb=Inbox&YN=1" webmail-aux)
- (list-snarf . webmail-yahoo-list)
- (article-snarf . webmail-yahoo-article)
- (trash-url
- "%s/ym/ShowFolder?YY=52107&inc=50&order=down&sort=date&pos=0&box=Inbox&DEL=Delete&destBox=&Mid=%s&destBox2="
- webmail-aux id))
- (netaddress
- (paranoid cookie post)
- (address . "www.netaddress.com")
- (open-url "http://www.netaddress.com/")
- (open-snarf . webmail-netaddress-open)
- (login-url
- content
- ("%s" webmail-aux)
- "LoginState=2&SuccessfulLogin=%%2Ftpl&NewServerName=www.netaddress.com&JavaScript=JavaScript1.2&DomainID=4&Domain=usa.net&NA31site=classic.netaddress.com&NA31port=80&UserID=%s&passwd=%s"
- user password)
- (login-snarf . webmail-netaddress-login)
- (list-url
- "http://www.netaddress.com/tpl/Mail/%s/List?FolderID=-4&SortUseCase=True"
- webmail-session)
- (list-snarf . webmail-netaddress-list)
- (article-url "http://www.netaddress.com/")
- (article-snarf . webmail-netaddress-article)
- (trash-url
- "http://www.netaddress.com/tpl/Message/%s/Move?FolderID=-4&Q=%s&N=&Sort=Date&F=-1"
- webmail-session id))
- (netscape
- (paranoid cookie post agent)
- (address . "webmail.netscape.com")
- (open-url "http://ureg.netscape.com/iiop/UReg2/login/login?U2_LA=en&U2_BACK_FROM_CJ=true&U2_CS=iso-8859-1&U2_ENDURL=http://webmail.netscape.com/tpl/Subscribe/Step1&U2_NEW_ENDURL=http://webmail.netscape.com/tpl/Subscribe/Step1&U2_EXITURL=http://home.netscape.com/&U2_SOURCE=Webmail")
- (open-snarf . webmail-netscape-open)
- (login-url
- content
- ("http://ureg.netscape.com/iiop/UReg2/login/loginform")
- "U2_USERNAME=%s&U2_PASSWORD=%s%s"
- user password webmail-aux)
- (login-snarf . webmail-netaddress-login)
- (list-url
- "http://webmail.netscape.com/tpl/Mail/%s/List?FolderID=-4&SortUseCase=True"
- webmail-session)
- (list-snarf . webmail-netaddress-list)
- (article-url "http://webmail.netscape.com/")
- (article-snarf . webmail-netscape-article)
- (trash-url
- "http://webmail.netscape.com/tpl/Message/%s/Move?FolderID=-4&Q=%s&N=&Sort=Date&F=-1"
- webmail-session id))
- (my-deja
- (paranoid cookie post)
- (address . "www.my-deja.com")
- ;;(open-snarf . webmail-my-deja-open)
- (login-url
- content
- ("http://mydeja.google.com/cgi-bin/deja/maillogin.py")
- "userid=%s&password=%s"
- user password)
- (list-snarf . webmail-my-deja-list)
- (article-snarf . webmail-my-deja-article)
- (trash-url webmail-aux id))))
-
-(defvar webmail-variables
- '(address article-snarf article-url list-snarf list-url
- login-url login-snarf open-url open-snarf site articles
- post-process paranoid trash-url))
-
-(defconst webmail-version "webmail 1.0")
-
-(defvar webmail-newmail-only nil
- "Only fetch new mails.")
-
-(defvar webmail-move-to-trash-can t
- "Move mail to trash can after fetch it.")
-
-;;; Internal variables
-
-(defvar webmail-address nil)
-(defvar webmail-paranoid nil)
-(defvar webmail-aux nil)
-(defvar webmail-session nil)
-(defvar webmail-article-snarf nil)
-(defvar webmail-article-url nil)
-(defvar webmail-list-snarf nil)
-(defvar webmail-list-url nil)
-(defvar webmail-login-url nil)
-(defvar webmail-login-snarf nil)
-(defvar webmail-open-snarf nil)
-(defvar webmail-open-url nil)
-(defvar webmail-trash-url nil)
-(defvar webmail-articles nil)
-(defvar webmail-post-process nil)
-
-(defvar webmail-buffer nil)
-(defvar webmail-buffer-list nil)
-
-(defvar webmail-type nil)
-
-(defvar webmail-error-function nil)
-
-(defvar webmail-debug-file "~/.emacs-webmail-debug")
-
-;;; Interface functions
-
-(defun webmail-debug (str)
- (with-temp-buffer
- (insert "\n---------------- A bug at " str " ------------------\n")
- (dolist (sym '(webmail-type user))
- (if (boundp sym)
- (gnus-pp `(setq ,sym ',(eval sym)))))
- (insert "---------------- webmail buffer ------------------\n\n")
- (insert-buffer-substring webmail-buffer)
- (insert "\n---------------- end of buffer ------------------\n\n")
- (append-to-file (point-min) (point-max) webmail-debug-file)))
-
-(defun webmail-error (str)
- (if webmail-error-function
- (funcall webmail-error-function str))
- (message "%s HTML has changed or your w3 package is too old.(%s)"
- webmail-type str)
- (error "%s HTML has changed or your w3 package is too old.(%s)"
- webmail-type str))
-
-(defun webmail-setdefault (type)
- (let ((type-def (cdr (assq type webmail-type-definition)))
- (vars webmail-variables)
- pair)
- (setq webmail-type type)
- (dolist (var vars)
- (if (setq pair (assq var type-def))
- (set (intern (concat "webmail-" (symbol-name var))) (cdr pair))
- (set (intern (concat "webmail-" (symbol-name var))) nil)))))
-
-(defun webmail-eval (expr)
- (cond
- ((consp expr)
- (cons (webmail-eval (car expr)) (webmail-eval (cdr expr))))
- ((symbolp expr)
- (eval expr))
- (t
- expr)))
-
-(defun webmail-url (xurl)
- (mm-with-unibyte-current-buffer
- (cond
- ((eq (car xurl) 'content)
- (pop xurl)
- (mm-url-fetch-simple (if (stringp (car xurl))
- (car xurl)
- (apply 'format (webmail-eval (car xurl))))
- (apply 'format (webmail-eval (cdr xurl)))))
- ((eq (car xurl) 'post)
- (pop xurl)
- (mm-url-fetch-form (car xurl) (webmail-eval (cdr xurl))))
- (t
- (mm-url-insert (apply 'format (webmail-eval xurl)))))))
-
-(defun webmail-init ()
- "Initialize buffers and such."
- (if (gnus-buffer-live-p webmail-buffer)
- (set-buffer webmail-buffer)
- (setq webmail-buffer
- (nnheader-set-temp-buffer " *webmail*"))
- (mm-disable-multibyte)))
-
-(defvar url-package-name)
-(defvar url-package-version)
-(defvar url-cookie-multiple-line)
-(defvar url-confirmation-func)
-
-;; Hack W3 POST redirect. See `url-parse-mime-headers'.
-;;
-;; Netscape uses "GET" as redirect method when orignal method is POST
-;; and status is 302, .i.e no security risks by default without
-;; confirmation.
-;;
-;; Some web servers (at least Apache used by yahoo) return status 302
-;; instead of 303, though they mean 303.
-
-(defun webmail-url-confirmation-func (prompt)
- (cond
- ((equal prompt (concat "Honor redirection with non-GET method "
- "(possible security risks)? "))
- nil)
- ((equal prompt "Continue (with method of GET)? ")
- t)
- (t (error prompt))))
-
-(defun webmail-refresh-redirect ()
- "Redirect refresh url in META."
- (goto-char (point-min))
- (while (re-search-forward
- "<meta[ \t\r\n]*http-equiv=\"Refresh\"[^>]*URL=\\([^\"]+\\)\""
- nil t)
- (let ((url (match-string 1)))
- (erase-buffer)
- (mm-with-unibyte-current-buffer
- (mm-url-insert url)))
- (goto-char (point-min))))
-
-(defun webmail-fetch (file subtype user password)
- (save-excursion
- (webmail-setdefault subtype)
- (let ((url-package-name (if (memq 'agent webmail-paranoid)
- "Mozilla"
- url-package-name))
- (url-package-version (if (memq 'agent webmail-paranoid)
- "4.0"
- url-package-version))
- (url-cookie-multiple-line (if (memq 'cookie webmail-paranoid)
- nil
- url-cookie-multiple-line))
- (url-confirmation-func (if (memq 'post webmail-paranoid)
- 'webmail-url-confirmation-func
- url-confirmation-func))
- (url-http-silence-on-insecure-redirection t)
- url-cookie-storage url-cookie-secure-storage
- url-cookie-confirmation
- item id (n 0))
- (webmail-init)
- (setq webmail-articles nil)
- (when webmail-open-url
- (erase-buffer)
- (webmail-url webmail-open-url))
- (if webmail-open-snarf (funcall webmail-open-snarf))
- (when webmail-login-url
- (erase-buffer)
- (webmail-url webmail-login-url))
- (if webmail-login-snarf
- (funcall webmail-login-snarf))
- (when webmail-list-url
- (erase-buffer)
- (webmail-url webmail-list-url))
- (if webmail-list-snarf
- (funcall webmail-list-snarf))
- (while (setq item (pop webmail-articles))
- (message "Fetching mail #%d..." (setq n (1+ n)))
- (erase-buffer)
- (mm-with-unibyte-current-buffer
- (mm-url-insert (cdr item)))
- (setq id (car item))
- (if webmail-article-snarf
- (funcall webmail-article-snarf file id))
- (when (and webmail-trash-url webmail-move-to-trash-can)
- (message "Move mail #%d to trash can..." n)
- (condition-case err
- (progn
- (webmail-url webmail-trash-url)
- (let (buf)
- (while (setq buf (pop webmail-buffer-list))
- (kill-buffer buf))))
- (error
- (let (buf)
- (while (setq buf (pop webmail-buffer-list))
- (kill-buffer buf)))
- (error err))))))
- (if webmail-post-process
- (funcall webmail-post-process))))
-
-(defun webmail-encode-8bit ()
- (goto-char (point-min))
- (skip-chars-forward "^\200-\377")
- (while (not (eobp))
- (insert (format "&%d;" (mm-char-int (char-after))))
- (delete-char 1)
- (skip-chars-forward "^\200-\377")))
-
-;;; hotmail
-
-(defun webmail-hotmail-open ()
- (goto-char (point-min))
- (if (re-search-forward
- "action=\"https?://\\([^/]+\\)/cgi-bin/dologin" nil t)
- (setq webmail-aux (match-string 1))
- (webmail-error "open@1")))
-
-(defun webmail-hotmail-login ()
- (let (site)
- (goto-char (point-min))
- (if (re-search-forward
- "https?://\\([^/]+hotmail\\.msn\\.com\\)/cgi-bin/" nil t)
- (setq site (match-string 1))
- (webmail-error "login@1"))
- (goto-char (point-min))
- (if (re-search-forward
- "\\(/cgi-bin/HoTMaiL\\?[^\"]*a=b[^\"]*\\)" nil t)
- (setq webmail-aux (concat "http://" site (match-string 1)))
- (webmail-error "login@2"))))
-
-(defun webmail-hotmail-list ()
- (goto-char (point-min))
- (skip-chars-forward " \t\n\r")
- (let (site url newp (total "0"))
- (if (eobp)
- (setq total "0")
- (if (re-search-forward "\\([0-9]+\\) *<b>(\\([0-9]+\\) new)" nil t)
- (message "Found %s (%s new)" (setq total (match-string 1))
- (match-string 2))
- (if (re-search-forward "\\([0-9]+\\) new" nil t)
- (message "Found %s new" (setq total (match-string 1)))
- (webmail-error "list@0"))))
- (unless (equal total "0")
- (goto-char (point-min))
- (if (re-search-forward
- "https?://\\([^/]+hotmail\\.msn\\.com\\)/cgi-bin/" nil t)
- (setq site (match-string 1))
- (webmail-error "list@1"))
- (goto-char (point-min))
- (if (re-search-forward "disk=\\([^&]*\\)&" nil t)
- (setq webmail-aux
- (concat "http://" site "/cgi-bin/HoTMaiL?disk="
- (match-string 1)))
- (webmail-error "list@2"))
- (goto-char (point-max))
- (while (re-search-backward
- "newmail\\.gif\\|href=\"\\(/cgi-bin/getmsg\\?[^\"]+\\)\""
- nil t)
- (if (setq url (match-string 1))
- (progn
- (if (or newp (not webmail-newmail-only))
- (let (id)
- (if (string-match "msg=\\([^&]+\\)" url)
- (setq id (match-string 1 url)))
- (push (cons id (concat "http://" site url "&raw=0"))
- webmail-articles)))
- (setq newp nil))
- (setq newp t))))))
-
-;; Thank victor@idaccr.org (Victor S. Miller) for raw=0
-
-(defun webmail-hotmail-article (file id)
- (goto-char (point-min))
- (skip-chars-forward " \t\n\r")
- (unless (eobp)
- (if (not (search-forward "<pre>" nil t))
- (webmail-error "article@3"))
- (skip-chars-forward "\n\r\t ")
- (delete-region (point-min) (point))
- (if (not (search-forward "</pre>" nil t))
- (webmail-error "article@3.1"))
- (delete-region (match-beginning 0) (point-max))
- (mm-url-remove-markup)
- (mm-url-decode-entities-nbsp)
- (goto-char (point-min))
- (while (re-search-forward "\r\n?" nil t)
- (replace-match "\n"))
- (goto-char (point-min))
- (insert "\n\n")
- (if (not (looking-at "\n*From "))
- (insert "From nobody " (current-time-string) "\n")
- (forward-line))
- (insert "X-Gnus-Webmail: " (symbol-value 'user)
- "@" (symbol-name webmail-type) "\n")
- (mm-append-to-file (point-min) (point-max) file)))
-
-(defun webmail-hotmail-article-old (file id)
- (let (p attachment count mime hotmail-direct)
- (save-restriction
- (webmail-encode-8bit)
- (goto-char (point-min))
- (if (not (search-forward "<DIV>" nil t))
- (if (not (search-forward "Reply&nbsp;All" nil t))
- (webmail-error "article@1")
- (setq hotmail-direct t))
- (goto-char (match-beginning 0)))
- (narrow-to-region (point-min) (point))
- (if (not (search-backward "<table" nil t 2))
- (webmail-error "article@1.1"))
- (delete-region (point-min) (match-beginning 0))
- (while (search-forward "<a href=" nil t)
- (setq p (match-beginning 0))
- (search-forward "</a>" nil t)
- (delete-region p (match-end 0)))
- (mm-url-remove-markup)
- (mm-url-decode-entities-nbsp)
- (goto-char (point-min))
- (delete-blank-lines)
- (goto-char (point-min))
- (when (search-forward "\n\n" nil t)
- (backward-char)
- (delete-region (point) (point-max)))
- (goto-char (point-max))
- (widen)
- (insert "\n")
- (setq p (point))
- (while (re-search-forward
- "<tt>\\|<div>\\|\\(http://[^/]+/cgi-bin/getmsg/\\([^\?]+\\)\?[^\"]*\\)\""
- nil t)
- (if (setq attachment (match-string 1))
- (let ((filename (match-string 2))
- bufname);; Attachment
- (delete-region p (match-end 0))
- (save-excursion
- (set-buffer (generate-new-buffer " *webmail-att*"))
- (mm-url-insert attachment)
- (push (current-buffer) webmail-buffer-list)
- (setq bufname (buffer-name)))
- (setq mime t)
- (insert "<#part type="
- (or (and filename
- (string-match "\\.[^\\.]+$" filename)
- (mailcap-extension-to-mime
- (match-string 0 filename)))
- "application/octet-stream"))
- (insert " buffer=\"" bufname "\"")
- (insert " filename=\"" filename "\"")
- (insert " disposition=\"inline\"")
- (insert "><#/part>\n")
- (setq p (point)))
- (delete-region p (match-end 0))
- (if hotmail-direct
- (if (not (search-forward "</tt>" nil t))
- (webmail-error "article@1.2")
- (delete-region (match-beginning 0) (match-end 0)))
- (setq count 1)
- (while (and (> count 0)
- (re-search-forward "</div>\\|\\(<div>\\)" nil t))
- (if (match-string 1)
- (setq count (1+ count))
- (if (= (setq count (1- count)) 0)
- (delete-region (match-beginning 0)
- (match-end 0))))))
- (narrow-to-region p (point))
- (goto-char (point-min))
- (cond
- ((looking-at "<pre>")
- (goto-char (match-end 0))
- (if (looking-at "$") (forward-char))
- (delete-region (point-min) (point))
- (mm-url-remove-markup)
- (mm-url-decode-entities-nbsp)
- nil)
- (t
- (setq mime t)
- (insert "<#part type=\"text/html\" disposition=inline>")
- (goto-char (point-max))
- (insert "<#/part>")))
- (goto-char (point-max))
- (setq p (point))
- (widen)))
- (delete-region p (point-max))
- (goto-char (point-min))
- ;; Some blank line to separate mails.
- (insert "\n\nFrom nobody " (current-time-string) "\n")
- (insert "X-Gnus-Webmail: " (symbol-value 'user)
- "@" (symbol-name webmail-type) "\n")
- (if id
- (insert (format "X-Message-ID: <%s@hotmail.com>\n" id)))
- (unless (looking-at "$")
- (if (search-forward "\n\n" nil t)
- (forward-line -1)
- (webmail-error "article@2")))
- (narrow-to-region (point) (point-max))
- (if mime
- (insert "MIME-Version: 1.0\n"
- (prog1
- (mml-generate-mime)
- (delete-region (point-min) (point-max)))))
- (goto-char (point-min))
- (widen)
- (let (case-fold-search)
- (while (re-search-forward "^From " nil t)
- (beginning-of-line)
- (insert ">"))))
- (mm-append-to-file (point-min) (point-max) file)))
-
-;;; yahoo
-
-(defun webmail-yahoo-open ()
- (goto-char (point-min))
- (if (re-search-forward "action=\"\\([^\"]+\\)\"" nil t)
- (setq webmail-aux (match-string 1))
- (webmail-error "open@1")))
-
-(defun webmail-yahoo-login ()
- (goto-char (point-min))
- (if (re-search-forward "http://[^/]+[0-9]\\.mail\\.yahoo\\.com/" nil t)
- (setq webmail-aux (match-string 0))
- (webmail-error "login@1"))
- (if (re-search-forward "YY=[0-9]+" nil t)
- (setq webmail-aux (concat webmail-aux "ym/ShowFolder?"
- (match-string 0)))
- (webmail-error "login@2")))
-
-(defun webmail-yahoo-list ()
- (let (url (newp t) (tofetch 0))
- (goto-char (point-min))
- (when (re-search-forward
- "showing [0-9]+-\\([0-9]+\\) of \\([0-9]+\\)" nil t)
- ;;(setq listed (match-string 1))
- (message "Found %s mail(s)" (match-string 2)))
- (if (string-match "http://[^/]+" webmail-aux)
- (setq webmail-aux (match-string 0 webmail-aux))
- (webmail-error "list@1"))
- (goto-char (point-min))
- (while (re-search-forward
- "bgcolor=\"#eeeeee\"\\|href=\"\\(/ym/ShowLetter\\?MsgId=\\([^&]+\\)&[^\"]*\\)\""
- nil t)
- (if (setq url (match-string 1))
- (progn
- (when (or newp (not webmail-newmail-only))
- (push (cons (match-string 2) (concat webmail-aux url "&toc=1"))
- webmail-articles)
- (setq tofetch (1+ tofetch)))
- (setq newp t))
- (setq newp nil)))
- (setq webmail-articles (nreverse webmail-articles))
- (message "Fetching %d mail(s)" tofetch)))
-
-(defun webmail-yahoo-article (file id)
- (let (p attachment)
- (save-restriction
- (goto-char (point-min))
- (if (not (search-forward "value=\"Done\"" nil t))
- (webmail-error "article@1"))
- (if (not (search-forward "<table" nil t))
- (webmail-error "article@2"))
- (delete-region (point-min) (match-beginning 0))
- (if (not (search-forward "</table>" nil t))
- (webmail-error "article@3"))
- (narrow-to-region (point-min) (match-end 0))
- (while (search-forward "<a href=" nil t)
- (setq p (match-beginning 0))
- (search-forward "</a>" nil t)
- (delete-region p (match-end 0)))
- (mm-url-remove-markup)
- (mm-url-decode-entities-nbsp)
- (goto-char (point-min))
- (delete-blank-lines)
- (goto-char (point-max))
- (widen)
- (insert "\n")
- (setq p (point))
- (while (re-search-forward "[^\"]*/ShowLetter/[^\?]+\?[^\"]*" nil t)
- (setq attachment (match-string 0))
- (let (bufname ct ctl cd description)
- (if (not (search-forward "<table" nil t))
- (webmail-error "article@4"))
- (delete-region p (match-beginning 0))
- (if (not (search-forward "</table>" nil t))
- (webmail-error "article@5"))
- (narrow-to-region p (match-end 0))
- (mm-url-remove-markup)
- (mm-url-decode-entities-nbsp)
- (goto-char (point-min))
- (delete-blank-lines)
- (setq ct (mail-fetch-field "content-type")
- ctl (and ct (mail-header-parse-content-type ct))
- ;;cte (mail-fetch-field "content-transfer-encoding")
- cd (mail-fetch-field "content-disposition")
- description (mail-fetch-field "content-description")
- id (mail-fetch-field "content-id"))
- (delete-region (point-min) (point-max))
- (widen)
- (save-excursion
- (set-buffer (generate-new-buffer " *webmail-att*"))
- (mm-url-insert (concat webmail-aux attachment))
- (push (current-buffer) webmail-buffer-list)
- (setq bufname (buffer-name)))
- (insert "<#part")
- (if (and ctl (not (equal (car ctl) "text/")))
- (insert " type=\"" (car ctl) "\""))
- (insert " buffer=\"" bufname "\"")
- (if cd
- (insert " disposition=\"" cd "\""))
- (if description
- (insert " description=\"" description "\""))
- (insert "><#/part>\n")
- (setq p (point))))
- (delete-region p (point-max))
- (goto-char (point-min))
- ;; Some blank line to separate mails.
- (insert "\n\nFrom nobody " (current-time-string) "\n")
- (insert "X-Gnus-Webmail: " (symbol-value 'user)
- "@" (symbol-name webmail-type) "\n")
- (if id
- (insert (format "X-Message-ID: <%s@yahoo.com>\n" id)))
- (unless (looking-at "$")
- (if (search-forward "\n\n" nil t)
- (forward-line -1)
- (webmail-error "article@2")))
- (narrow-to-region (point) (point-max))
- (insert "MIME-Version: 1.0\n"
- (prog1
- (mml-generate-mime)
- (delete-region (point-min) (point-max))))
- (goto-char (point-min))
- (widen)
- (let (case-fold-search)
- (while (re-search-forward "^From " nil t)
- (beginning-of-line)
- (insert ">"))))
- (mm-append-to-file (point-min) (point-max) file)))
-
-;;; netaddress
-
-(defun webmail-netscape-open ()
- (goto-char (point-min))
- (setq webmail-aux "")
- (while (re-search-forward
- "TYPE=hidden *NAME=\\([^ ]+\\) *VALUE=\"\\([^\"]+\\)"
- nil t)
- (setq webmail-aux (concat webmail-aux "&" (match-string 1) "="
- (match-string 2)))))
-
-(defun webmail-netaddress-open ()
- (goto-char (point-min))
- (if (re-search-forward "action=\"\\([^\"]+\\)\"" nil t)
- (setq webmail-aux (concat (car webmail-open-url) (match-string 1)))
- (webmail-error "open@1")))
-
-(defun webmail-netaddress-login ()
- (webmail-refresh-redirect)
- (goto-char (point-min))
- (if (re-search-forward "tpl/[^/]+/\\([^/]+\\)" nil t)
- (setq webmail-session (match-string 1))
- (webmail-error "login@1")))
-
-(defun webmail-netaddress-list ()
- (webmail-refresh-redirect)
- (let (item id)
- (goto-char (point-min))
- (when (re-search-forward
- "(\\([0-9]+\\) unread, \\([0-9]+\\) total)" nil t)
- (message "Found %s mail(s), %s unread"
- (match-string 2) (match-string 1)))
- (goto-char (point-min))
- (while (re-search-forward
- "MR\\[i\\]\\.R='\\([^']*\\)'\\|MR\\[i\\]\\.Q='\\([^']+\\)'" nil t)
- (if (setq id (match-string 2))
- (setq item
- (cons id
- (format "%s/tpl/Message/%s/Read?Q=%s&FolderID=-4&SortUseCase=True&Sort=Date&Headers=True"
- (car webmail-article-url)
- webmail-session id)))
- (if (or (not webmail-newmail-only)
- (equal (match-string 1) "True"))
- (push item webmail-articles))))
- (setq webmail-articles (nreverse webmail-articles))))
-
-(defun webmail-netaddress-single-part ()
- (goto-char (point-min))
- (cond
- ((looking-at "[\t\040\r\n]*<font face=[^>]+>[\t\040\r\n]*")
- ;; text/plain
- (replace-match "")
- (while (re-search-forward "[\t\040\r\n]+" nil t)
- (replace-match " "))
- (goto-char (point-min))
- (while (re-search-forward "<br>" nil t)
- (replace-match "\n"))
- (mm-url-remove-markup)
- (mm-url-decode-entities-nbsp)
- nil)
- (t
- (insert "<#part type=\"text/html\" disposition=inline>")
- (goto-char (point-max))
- (insert "<#/part>")
- t)))
-
-(defun webmail-netaddress-article (file id)
- (webmail-refresh-redirect)
- (let (p p1 attachment count mime type)
- (save-restriction
- (webmail-encode-8bit)
- (goto-char (point-min))
- (if (not (search-forward "Trash" nil t))
- (webmail-error "article@1"))
- (if (not (search-forward "<form>" nil t))
- (webmail-error "article@2"))
- (delete-region (point-min) (match-beginning 0))
- (if (not (search-forward "</form>" nil t))
- (webmail-error "article@3"))
- (narrow-to-region (point-min) (match-end 0))
- (goto-char (point-min))
- (while (re-search-forward "[\040\t\r\n]+" nil t)
- (replace-match " "))
- (goto-char (point-min))
- (while (search-forward "<b>" nil t)
- (replace-match "\n"))
- (mm-url-remove-markup)
- (mm-url-decode-entities-nbsp)
- (goto-char (point-min))
- (delete-blank-lines)
- (goto-char (point-min))
- (while (re-search-forward "^\040+\\|\040+$" nil t)
- (replace-match ""))
- (goto-char (point-min))
- (while (re-search-forward "\040+" nil t)
- (replace-match " "))
- (goto-char (point-max))
- (widen)
- (insert "\n\n")
- (setq p (point))
- (unless (search-forward "<!-- Data -->" nil t)
- (webmail-error "article@4"))
- (forward-line 14)
- (delete-region p (point))
- (goto-char (point-max))
- (unless (re-search-backward
- "[\040\t]*<br>[\040\t\r\n]*<br>[\040\t\r\n]*<form" p t)
- (webmail-error "article@5"))
- (delete-region (point) (point-max))
- (goto-char p)
- (while (search-forward
- "<TABLE border=\"0\" WIDTH=\"98%\" cellpadding=0 cellspacing=0>"
- nil t 2)
- (setq mime t)
- (unless (search-forward "</TABLE>" nil t)
- (webmail-error "article@6"))
- (setq p1 (point))
- (if (search-backward "<IMG " p t)
- (progn
- (unless (re-search-forward "HREF=\"\\(/tpl/Attachment/[^/]+/\\([^/]+/[^\?]+\\)[^\"]+\\)\"" p1 t)
- (webmail-error "article@7"))
- (setq attachment (match-string 1))
- (setq type (match-string 2))
- (unless (search-forward "</TABLE>" nil t)
- (webmail-error "article@8"))
- (delete-region p (point))
- (let (bufname);; Attachment
- (save-excursion
- (set-buffer (generate-new-buffer " *webmail-att*"))
- (mm-url-insert (concat (car webmail-open-url) attachment))
- (push (current-buffer) webmail-buffer-list)
- (setq bufname (buffer-name)))
- (insert "<#part type=" type)
- (insert " buffer=\"" bufname "\"")
- (insert " disposition=\"inline\"")
- (insert "><#/part>\n")
- (setq p (point))))
- (delete-region p p1)
- (narrow-to-region
- p
- (if (search-forward
- "<TABLE border=\"0\" WIDTH=\"98%\" cellpadding=0 cellspacing=0>"
- nil t)
- (match-beginning 0)
- (point-max)))
- (webmail-netaddress-single-part)
- (goto-char (point-max))
- (setq p (point))
- (widen)))
- (unless mime
- (narrow-to-region p (point-max))
- (setq mime (webmail-netaddress-single-part))
- (widen))
- (goto-char (point-min))
- ;; Some blank line to separate mails.
- (insert "\n\nFrom nobody " (current-time-string) "\n")
- (insert "X-Gnus-Webmail: " (symbol-value 'user)
- "@" (symbol-name webmail-type) "\n")
- (if id
- (insert (format "X-Message-ID: <%s@%s>\n" id webmail-address)))
- (unless (looking-at "$")
- (if (search-forward "\n\n" nil t)
- (forward-line -1)
- (webmail-error "article@2")))
- (when mime
- (narrow-to-region (point-min) (point))
- (goto-char (point-min))
- (while (not (eobp))
- (if (looking-at "MIME-Version\\|Content-Type")
- (delete-region (point)
- (progn
- (forward-line 1)
- (if (re-search-forward "^[^ \t]" nil t)
- (goto-char (match-beginning 0))
- (point-max))))
- (forward-line 1)))
- (goto-char (point-max))
- (widen)
- (narrow-to-region (point) (point-max))
- (insert "MIME-Version: 1.0\n"
- (prog1
- (mml-generate-mime)
- (delete-region (point-min) (point-max))))
- (goto-char (point-min))
- (widen))
- (let (case-fold-search)
- (while (re-search-forward "^From " nil t)
- (beginning-of-line)
- (insert ">"))))
- (mm-append-to-file (point-min) (point-max) file)))
-
-(defun webmail-netscape-article (file id)
- (let (p p1 attachment count mime type)
- (save-restriction
- (webmail-encode-8bit)
- (goto-char (point-min))
- (if (not (search-forward "Trash" nil t))
- (webmail-error "article@1"))
- (if (not (search-forward "<form>" nil t))
- (webmail-error "article@2"))
- (delete-region (point-min) (match-beginning 0))
- (if (not (search-forward "</form>" nil t))
- (webmail-error "article@3"))
- (narrow-to-region (point-min) (match-end 0))
- (goto-char (point-min))
- (while (re-search-forward "[\040\t\r\n]+" nil t)
- (replace-match " "))
- (goto-char (point-min))
- (while (re-search-forward "<a href=[^>]*>[^<]*</a>" nil t)
- (replace-match ""))
- (goto-char (point-min))
- (while (search-forward "<b>" nil t)
- (replace-match "\n"))
- (mm-url-remove-markup)
- (mm-url-decode-entities-nbsp)
- (goto-char (point-min))
- (delete-blank-lines)
- (goto-char (point-min))
- (while (re-search-forward "^\040+\\|\040+$" nil t)
- (replace-match ""))
- (goto-char (point-min))
- (while (re-search-forward "\040+" nil t)
- (replace-match " "))
- (goto-char (point-max))
- (widen)
- (insert "\n\n")
- (setq p (point))
- (unless (search-forward "<!-- Data -->" nil t)
- (webmail-error "article@4"))
- (forward-line 14)
- (delete-region p (point))
- (goto-char (point-max))
- (unless (re-search-backward
- "<form name=\"Transfer2\"" p t)
- (webmail-error "article@5"))
- (delete-region (point) (point-max))
- (goto-char p)
- (while (search-forward
- "<TABLE border=\"0\" WIDTH=\"98%\" cellpadding=0 cellspacing=0>"
- nil t 2)
- (setq mime t)
- (unless (search-forward "</TABLE>" nil t)
- (webmail-error "article@6"))
- (setq p1 (point))
- (if (search-backward "<IMG " p t)
- (progn
- (unless (re-search-forward "HREF=\"\\(/tpl/Attachment/[^/]+/\\([^/]+/[^\?]+\\)[^\"]+\\)\"" p1 t)
- (webmail-error "article@7"))
- (setq attachment (match-string 1))
- (setq type (match-string 2))
- (unless (search-forward "</TABLE>" nil t)
- (webmail-error "article@8"))
- (delete-region p (point))
- (let (bufname);; Attachment
- (save-excursion
- (set-buffer (generate-new-buffer " *webmail-att*"))
- (mm-url-insert (concat (car webmail-open-url) attachment))
- (push (current-buffer) webmail-buffer-list)
- (setq bufname (buffer-name)))
- (insert "<#part type=" type)
- (insert " buffer=\"" bufname "\"")
- (insert " disposition=\"inline\"")
- (insert "><#/part>\n")
- (setq p (point))))
- (delete-region p p1)
- (narrow-to-region
- p
- (if (search-forward
- "<TABLE border=\"0\" WIDTH=\"98%\" cellpadding=0 cellspacing=0>"
- nil t)
- (match-beginning 0)
- (point-max)))
- (webmail-netaddress-single-part)
- (goto-char (point-max))
- (setq p (point))
- (widen)))
- (unless mime
- (narrow-to-region p (point-max))
- (setq mime (webmail-netaddress-single-part))
- (widen))
- (goto-char (point-min))
- ;; Some blank line to separate mails.
- (insert "\n\nFrom nobody " (current-time-string) "\n")
- (insert "X-Gnus-Webmail: " (symbol-value 'user)
- "@" (symbol-name webmail-type) "\n")
- (if id
- (insert (format "X-Message-ID: <%s@%s>\n" id webmail-address)))
- (unless (looking-at "$")
- (if (search-forward "\n\n" nil t)
- (forward-line -1)
- (webmail-error "article@2")))
- (when mime
- (narrow-to-region (point-min) (point))
- (goto-char (point-min))
- (while (not (eobp))
- (if (looking-at "MIME-Version\\|Content-Type")
- (delete-region (point)
- (progn
- (forward-line 1)
- (if (re-search-forward "^[^ \t]" nil t)
- (goto-char (match-beginning 0))
- (point-max))))
- (forward-line 1)))
- (goto-char (point-max))
- (widen)
- (narrow-to-region (point) (point-max))
- (insert "MIME-Version: 1.0\n"
- (prog1
- (mml-generate-mime)
- (delete-region (point-min) (point-max))))
- (goto-char (point-min))
- (widen))
- (let (case-fold-search)
- (while (re-search-forward "^From " nil t)
- (beginning-of-line)
- (insert ">"))))
- (mm-append-to-file (point-min) (point-max) file)))
-
-;;; my-deja
-
-(defun webmail-my-deja-open ()
- (webmail-refresh-redirect)
- (goto-char (point-min))
- (if (re-search-forward "action=\"\\([^\"]+maillogin\\.py[^\"]*\\)\""
- nil t)
- (setq webmail-aux (match-string 1))
- (webmail-error "open@1")))
-
-(defun webmail-my-deja-list ()
- (let (item id newp base)
- (goto-char (point-min))
- (when (re-search-forward "href=\"\\(\\([^\"]*\\)/mailnf\\.[^\"]*\\)\""
- nil t)
- (let ((url (match-string 1)))
- (setq base (match-string 2))
- (erase-buffer)
- (mm-url-insert url)))
- (goto-char (point-min))
- (when (re-search-forward
- "(\\([0-9]+\\) Message.?-[^>]*\\([0-9]+\\) New"
- nil t)
- (message "Found %s mail(s), %s unread"
- (match-string 1) (match-string 2)))
- (goto-char (point-min))
- (while (re-search-forward
- "newmail\\.gif\\|href=\"[^\"]*\\(mailnf\\.[^\"]+act=view[^\"]+mid=\\([^\"&]+\\)[^\"]+\\)\""
- nil t)
- (if (setq id (match-string 2))
- (when (and (or newp (not webmail-newmail-only))
- (not (assoc id webmail-articles)))
- (push (cons id (setq webmail-aux
- (concat base "/" (match-string 1))))
- webmail-articles)
- (setq newp nil))
- (setq newp t)))
- (setq webmail-articles (nreverse webmail-articles))))
-
-(defun webmail-my-deja-article-part (base)
- (let (p)
- (cond
- ((looking-at "[\t\040\r\n]*<!--[^>]*>")
- (replace-match ""))
- ((looking-at "[\t\040\r\n]*</PRE>")
- (replace-match ""))
- ((looking-at "[\t\040\r\n]*<PRE>")
- ;; text/plain
- (replace-match "")
- (save-restriction
- (narrow-to-region (point)
- (if (re-search-forward "</?PRE>" nil t)
- (match-beginning 0)
- (point-max)))
- (goto-char (point-min))
- (mm-url-remove-markup)
- (mm-url-decode-entities-nbsp)
- (goto-char (point-max))))
- ((looking-at "[\t\040\r\n]*<TABLE")
- (save-restriction
- (narrow-to-region (point)
- (if (search-forward "</TABLE>" nil t 2)
- (point)
- (point-max)))
- (goto-char (point-min))
- (let (name type url bufname)
- (if (and (search-forward "File Name:" nil t)
- (re-search-forward "<FONT[^>]+>\\([^<]+\\)" nil t))
- (setq name (match-string 1)))
- (if (and (search-forward "File Type:" nil t)
- (re-search-forward "<FONT[^>]+>\\([^<]+\\)" nil t))
- (setq type (match-string 1)))
- (unless (re-search-forward "action=\"getattach\\.cgi/\\([^\"]+\\)"
- nil t)
- (webmail-error "article@5"))
- (setq url (concat base "/getattach.cgi/" (match-string 1)
- "?sm=Download"))
- (while (re-search-forward
- "type=hidden name=\"\\([^\"]+\\)\" value=\"\\([^\"]+\\)"
- nil t)
- (setq url (concat url "&" (match-string 1) "="
- (match-string 2))))
- (delete-region (point-min) (point-max))
- (save-excursion
- (set-buffer (generate-new-buffer " *webmail-att*"))
- (mm-url-insert url)
- (push (current-buffer) webmail-buffer-list)
- (setq bufname (buffer-name)))
- (insert "<#part type=\"" type "\"")
- (if name (insert " filename=\"" name "\""))
- (insert " buffer=\"" bufname "\"")
- (insert " disposition=inline><#/part>"))))
- (t
- (insert "<#part type=\"text/html\" disposition=inline>")
- (goto-char (point-max))
- (insert "<#/part>")))))
-
-(defun webmail-my-deja-article (file id)
- (let (base)
- (goto-char (point-min))
- (unless (string-match "\\([^\"]+\\)/mail" webmail-aux)
- (webmail-error "article@0"))
- (setq base (match-string 1 webmail-aux))
- (when (re-search-forward
- "href=\"[^\"]*\\(mailnf\\.[^\"]+act=move[^\"]+mid=\\([^\"&]+\\)[^\"]+\\)\""
- nil t)
- (setq webmail-aux (concat base "/" (match-string 1)))
- (string-match "mid=[^\"&]+" webmail-aux)
- (setq webmail-aux (replace-match "mid=%s" nil nil webmail-aux)))
- (unless (search-forward "<HR noshade>" nil t)
- (webmail-error "article@1"))
- (delete-region (point-min) (point))
- (unless (search-forward "<HR noshade>" nil t)
- (webmail-error "article@2"))
- (save-restriction
- (narrow-to-region (point-min) (point))
- (while (search-forward "\r\n" nil t)
- (replace-match "\n"))
- (mm-url-remove-markup)
- (mm-url-decode-entities-nbsp)
- (goto-char (point-min))
- (while (re-search-forward "\n\n+" nil t)
- (replace-match "\n"))
- (goto-char (point-max)))
- (save-restriction
- (narrow-to-region (point) (point-max))
- (goto-char (point-max))
- (unless (search-backward "<HR noshade>" nil t)
- (webmail-error "article@3"))
- (unless (search-backward "</TT>" nil t)
- (webmail-error "article@4"))
- (delete-region (point) (point-max))
- (goto-char (point-min))
- (while (not (eobp))
- (webmail-my-deja-article-part base))
- (insert "MIME-Version: 1.0\n"
- (prog1
- (mml-generate-mime)
- (delete-region (point-min) (point-max)))))
- (goto-char (point-min))
- (insert "\n\nFrom nobody " (current-time-string) "\n")
- (insert "X-Gnus-Webmail: " (symbol-value 'user)
- "@" (symbol-name webmail-type) "\n")
- (if (eq (char-after) ?\n)
- (delete-char 1))
- (mm-append-to-file (point-min) (point-max) file)))
-
-(provide 'webmail)
-
-;; arch-tag: f75a4558-a8f6-46ec-b1c3-7a6434b3dd71
-;;; webmail.el ends here
diff --git a/lisp/gnus/yenc.el b/lisp/gnus/yenc.el
index b0f7b4115b2..9fdf62d43b3 100644
--- a/lisp/gnus/yenc.el
+++ b/lisp/gnus/yenc.el
@@ -89,8 +89,9 @@
(when (re-search-forward "^=yend.*$" end t)
(setq last (match-beginning 0))
(setq footer-alist (yenc-parse-line (match-string 0)))
- (letf (((default-value 'enable-multibyte-characters) nil))
- (setq work-buffer (generate-new-buffer " *yenc-work*")))
+ (setq work-buffer (generate-new-buffer " *yenc-work*"))
+ (unless (featurep 'xemacs)
+ (with-current-buffer work-buffer (set-buffer-multibyte nil)))
(while (< first last)
(setq char (char-after first))
(cond ((or (eq char ?\r)
@@ -135,5 +136,4 @@
(provide 'yenc)
-;; arch-tag: 74df17e8-6fa8-4071-9f7d-54d548d79d9a
;;; yenc.el ends here
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index 18db4f443f6..d49b06a16e6 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -6,6 +6,7 @@
;; Maintainer: FSF
;; Keywords: help, internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -644,7 +645,20 @@ it is displayed along with the global value."
;; inappropriate e.g C-h v <RET> features <RET>
;; (help-xref-on-pp from (point))
(if (< (point) (+ from 20))
- (delete-region (1- from) from)))))
+ (delete-region (1- from) from))
+ (let* ((sv (get variable 'standard-value))
+ (origval (and (consp sv)
+ (condition-case nil
+ (eval (car sv))
+ (error :help-eval-error)))))
+ (when (and (consp sv)
+ (not (equal origval val))
+ (not (equal origval :help-eval-error)))
+ (princ "\nOriginal value was \n")
+ (setq from (point))
+ (pp origval)
+ (if (< (point) (+ from 20))
+ (delete-region (1- from) from)))))))
(terpri)
(when locus
@@ -873,7 +887,111 @@ BUFFER should be a buffer or a buffer name."
(insert "\nThe parent category table is:")
(describe-vector table 'help-describe-category-set))))))
+
+;;; Replacements for old lib-src/ programs. Don't seem especially useful.
+
+;; Replaces lib-src/digest-doc.c.
+;;;###autoload
+(defun doc-file-to-man (file)
+ "Produce an nroff buffer containing the doc-strings from the DOC file."
+ (interactive (list (read-file-name "Name of DOC file: " doc-directory
+ internal-doc-file-name t)))
+ (or (file-readable-p file)
+ (error "Cannot read file `%s'" file))
+ (pop-to-buffer (generate-new-buffer "*man-doc*"))
+ (setq buffer-undo-list t)
+ (insert ".TH \"Command Summary for GNU Emacs\"\n"
+ ".AU Richard M. Stallman\n")
+ (insert-file-contents file)
+ (let (notfirst)
+ (while (search-forward "" nil 'move)
+ (if (looking-at "S")
+ (delete-region (1- (point)) (line-end-position))
+ (delete-char -1)
+ (if notfirst
+ (insert "\n.DE\n")
+ (setq notfirst t))
+ (insert "\n.SH ")
+ (insert (if (looking-at "F") "Function " "Variable "))
+ (delete-char 1)
+ (forward-line 1)
+ (insert ".DS L\n"))))
+ (insert "\n.DE\n")
+ (setq buffer-undo-list nil)
+ (nroff-mode))
+
+;; Replaces lib-src/sorted-doc.c.
+;;;###autoload
+(defun doc-file-to-info (file)
+ "Produce a texinfo buffer with sorted doc-strings from the DOC file."
+ (interactive (list (read-file-name "Name of DOC file: " doc-directory
+ internal-doc-file-name t)))
+ (or (file-readable-p file)
+ (error "Cannot read file `%s'" file))
+ (let ((i 0) type name doc alist)
+ (with-temp-buffer
+ (insert-file-contents file)
+ ;; The characters "@{}" need special treatment.
+ (while (re-search-forward "[@{}]" nil t)
+ (backward-char)
+ (insert "@")
+ (forward-char 1))
+ (goto-char (point-min))
+ (while (search-forward "" nil t)
+ (unless (looking-at "S")
+ (setq type (char-after)
+ name (buffer-substring (1+ (point)) (line-end-position))
+ doc (buffer-substring (line-beginning-position 2)
+ (if (search-forward "" nil 'move)
+ (1- (point))
+ (point)))
+ alist (cons (list name type doc) alist))
+ (backward-char 1))))
+ (pop-to-buffer (generate-new-buffer "*info-doc*"))
+ (setq buffer-undo-list t)
+ ;; Write the output header.
+ (insert "\\input texinfo @c -*-texinfo-*-\n"
+ "@setfilename emacsdoc.info\n"
+ "@settitle Command Summary for GNU Emacs\n"
+ "@finalout\n"
+ "\n@node Top\n"
+ "@unnumbered Command Summary for GNU Emacs\n\n"
+ "@table @asis\n\n"
+ "@iftex\n"
+ "@global@let@ITEM@item\n"
+ "@def@item{@filbreak@vskip5pt@ITEM}\n"
+ "@font@tensy cmsy10 scaled @magstephalf\n"
+ "@font@teni cmmi10 scaled @magstephalf\n"
+ "@def\\{{@tensy@char110}}\n" ; this backslash goes with cmr10
+ "@def|{{@tensy@char106}}\n"
+ "@def@{{{@tensy@char102}}\n"
+ "@def@}{{@tensy@char103}}\n"
+ "@def<{{@teni@char62}}\n"
+ "@def>{{@teni@char60}}\n"
+ "@chardef@@64\n"
+ "@catcode43=12\n"
+ "@tableindent-0.2in\n"
+ "@end iftex\n")
+ ;; Sort the array by name; within each name, by type (functions first).
+ (setq alist (sort alist (lambda (e1 e2)
+ (if (string-equal (car e1) (car e2))
+ (<= (cadr e1) (cadr e2))
+ (string-lessp (car e1) (car e2))))))
+ ;; Print each function.
+ (dolist (e alist)
+ (insert "\n@item "
+ (if (char-equal (cadr e) ?\F) "Function" "Variable")
+ " @code{" (car e) "}\n@display\n"
+ (nth 2 e)
+ "\n@end display\n")
+ ;; Try to avoid a save size overflow in the TeX output routine.
+ (if (zerop (setq i (% (1+ i) 100)))
+ (insert "\n@end table\n@table @asis\n")))
+ (insert "@end table\n"
+ "@bye\n")
+ (setq buffer-undo-list nil)
+ (texinfo-mode)))
+
(provide 'help-fns)
-;; arch-tag: 9e10331c-ae81-4d13-965d-c4819aaab0b3
;;; help-fns.el ends here
diff --git a/lisp/help-macro.el b/lisp/help-macro.el
index 12fa29abf58..2e0f7fad539 100644
--- a/lisp/help-macro.el
+++ b/lisp/help-macro.el
@@ -7,6 +7,7 @@
;; Maintainer: FSF
;; Created: Mon Oct 1 11:42:39 1990
;; Adapted-By: ESR
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/help-mode.el b/lisp/help-mode.el
index bad4ae94e2a..9f54ff08c0b 100644
--- a/lisp/help-mode.el
+++ b/lisp/help-mode.el
@@ -5,6 +5,7 @@
;; Maintainer: FSF
;; Keywords: help, internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -244,6 +245,25 @@ The format is (FUNCTION ARGS...).")
(message "Unable to find location in file"))))
'help-echo (purecopy "mouse-2, RET: find face's definition"))
+(define-button-type 'help-package
+ :supertype 'help-xref
+ 'help-function 'describe-package
+ 'help-echo (purecopy "mouse-2, RET: Describe package"))
+
+(define-button-type 'help-package-def
+ :supertype 'help-xref
+ 'help-function (lambda (file) (dired file))
+ 'help-echo (purecopy "mouse-2, RET: visit package directory"))
+
+(define-button-type 'help-theme-def
+ :supertype 'help-xref
+ 'help-function 'find-file
+ 'help-echo (purecopy "mouse-2, RET: visit theme file"))
+
+(define-button-type 'help-theme-edit
+ :supertype 'help-xref
+ 'help-function 'customize-create-theme
+ 'help-echo (purecopy "mouse-2, RET: edit this theme file"))
;;;###autoload
(defun help-mode ()
@@ -272,6 +292,9 @@ Commands:
(with-current-buffer buffer
(bury-buffer))))
+ (set (make-local-variable 'revert-buffer-function)
+ 'help-mode-revert-buffer)
+
(run-mode-hooks 'help-mode-hook))
;;;###autoload
@@ -433,7 +456,9 @@ that."
(let ((data (match-string 2)))
(save-match-data
(unless (string-match "^([^)]+)" data)
- (setq data (concat "(emacs)" data))))
+ (setq data (concat "(emacs)" data)))
+ (setq data ;; possible newlines if para filled
+ (replace-regexp-in-string "[ \t\n]+" " " data t t)))
(help-xref-button 2 'help-info data))))
;; URLs
(save-excursion
@@ -781,6 +806,17 @@ Show all docs for that symbol as either a variable, function or face."
(fboundp sym) (facep sym))
(help-do-xref pos #'help-xref-interned (list sym)))))
+(defun help-mode-revert-buffer (ignore-auto noconfirm)
+ (when (or noconfirm (yes-or-no-p "Revert help buffer? "))
+ (let ((pos (point))
+ (item help-xref-stack-item)
+ ;; Pretend there is no current item to add to the history.
+ (help-xref-stack-item nil)
+ ;; Use the current buffer.
+ (help-xref-following t))
+ (apply (car item) (cdr item))
+ (goto-char pos))))
+
(defun help-insert-string (string)
"Insert STRING to the help buffer and install xref info for it.
This function can be used to restore the old contents of the help buffer
diff --git a/lisp/help.el b/lisp/help.el
index acfd78b301f..6c6bd76ec4b 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -1,10 +1,12 @@
;;; help.el --- help commands for Emacs
;; Copyright (C) 1985, 1986, 1993, 1994, 1998, 1999, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: help, internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -103,6 +105,7 @@
(define-key map "m" 'describe-mode)
(define-key map "n" 'view-emacs-news)
(define-key map "p" 'finder-by-keyword)
+ (define-key map "P" 'describe-package)
(define-key map "r" 'info-emacs-manual)
(define-key map "s" 'describe-syntax)
(define-key map "t" 'help-with-tutorial)
@@ -117,9 +120,6 @@
(define-key global-map [f1] 'help-command)
(fset 'help-command help-map)
-(autoload 'finder-by-keyword "finder"
- "Find packages matching a given keyword." t)
-
;; insert-button makes the action nil if it is not store somewhere
(defvar help-button-cache nil)
@@ -873,7 +873,9 @@ whose documentation describes the minor mode."
(insert (format-mode-line mode nil nil buffer))
(add-text-properties start (point) '(face bold)))))
(princ " mode:\n")
- (princ (documentation major-mode))))))
+ (princ (documentation major-mode)))))
+ ;; For the sake of IELM and maybe others
+ nil)
(defun describe-minor-mode (minor-mode)
@@ -1248,5 +1250,4 @@ Select help window if the actual value of the user option
(provide 'help)
-;; arch-tag: cf427352-27e9-49b7-9a6f-741ebab02423
;;; help.el ends here
diff --git a/lisp/hex-util.el b/lisp/hex-util.el
index 10142896f1d..932a7fe3543 100644
--- a/lisp/hex-util.el
+++ b/lisp/hex-util.el
@@ -69,5 +69,4 @@
(provide 'hex-util)
-;; arch-tag: fe8aaa79-6c86-400e-813f-5a8cc4cb3859
;;; hex-util.el ends here
diff --git a/lisp/hexl.el b/lisp/hexl.el
index 7edf5ec10ac..8e000e72ecd 100644
--- a/lisp/hexl.el
+++ b/lisp/hexl.el
@@ -97,7 +97,99 @@ Quoting cannot be used, so the arguments cannot themselves contain spaces."
(defvar hexl-max-address 0
"Maximum offset into hexl buffer.")
-(defvar hexl-mode-map nil)
+(defvar hexl-mode-map
+ (let ((map (make-keymap)))
+ ;; Make all self-inserting keys go through hexl-self-insert-command,
+ ;; because we need to convert them to unibyte characters before
+ ;; inserting them into the buffer.
+ (define-key map [remap self-insert-command] 'hexl-self-insert-command)
+
+ (define-key map "\C-m" 'hexl-self-insert-command)
+ (define-key map [left] 'hexl-backward-char)
+ (define-key map [right] 'hexl-forward-char)
+ (define-key map [up] 'hexl-previous-line)
+ (define-key map [down] 'hexl-next-line)
+ (define-key map [M-left] 'hexl-backward-short)
+ (define-key map [?\e left] 'hexl-backward-short)
+ (define-key map [M-right] 'hexl-forward-short)
+ (define-key map [?\e right] 'hexl-forward-short)
+ (define-key map [next] 'hexl-scroll-up)
+ (define-key map [prior] 'hexl-scroll-down)
+ (define-key map [home] 'hexl-beginning-of-line)
+ (define-key map [end] 'hexl-end-of-line)
+ (define-key map [C-home] 'hexl-beginning-of-buffer)
+ (define-key map [C-end] 'hexl-end-of-buffer)
+ (define-key map [deletechar] 'undefined)
+ (define-key map [deleteline] 'undefined)
+ (define-key map [insertline] 'undefined)
+ (define-key map [S-delete] 'undefined)
+ (define-key map "\177" 'undefined)
+
+ (define-key map "\C-a" 'hexl-beginning-of-line)
+ (define-key map "\C-b" 'hexl-backward-char)
+ (define-key map "\C-d" 'undefined)
+ (define-key map "\C-e" 'hexl-end-of-line)
+ (define-key map "\C-f" 'hexl-forward-char)
+
+ (if (not (memq (key-binding (char-to-string help-char))
+ '(help-command ehelp-command)))
+ (define-key map (char-to-string help-char) 'undefined))
+
+ (define-key map "\C-k" 'undefined)
+ (define-key map "\C-n" 'hexl-next-line)
+ (define-key map "\C-o" 'undefined)
+ (define-key map "\C-p" 'hexl-previous-line)
+ (define-key map "\C-q" 'hexl-quoted-insert)
+ (define-key map "\C-t" 'undefined)
+ (define-key map "\C-v" 'hexl-scroll-up)
+ (define-key map "\C-w" 'undefined)
+ (define-key map "\C-y" 'undefined)
+
+ (fset 'hexl-ESC-prefix (copy-keymap 'ESC-prefix))
+ (define-key map "\e" 'hexl-ESC-prefix)
+ (define-key map "\e\C-a" 'hexl-beginning-of-512b-page)
+ (define-key map "\e\C-b" 'hexl-backward-short)
+ (define-key map "\e\C-d" 'hexl-insert-decimal-char)
+ (define-key map "\e\C-e" 'hexl-end-of-512b-page)
+ (define-key map "\e\C-f" 'hexl-forward-short)
+ (define-key map "\e\C-i" 'undefined)
+ (define-key map "\e\C-j" 'undefined)
+ (define-key map "\e\C-k" 'undefined)
+ (define-key map "\e\C-o" 'hexl-insert-octal-char)
+ (define-key map "\e\C-q" 'undefined)
+ (define-key map "\e\C-t" 'undefined)
+ (define-key map "\e\C-x" 'hexl-insert-hex-char)
+ (define-key map "\eb" 'hexl-backward-word)
+ (define-key map "\ec" 'undefined)
+ (define-key map "\ed" 'undefined)
+ (define-key map "\ef" 'hexl-forward-word)
+ (define-key map "\eg" 'hexl-goto-hex-address)
+ (define-key map "\ei" 'undefined)
+ (define-key map "\ej" 'hexl-goto-address)
+ (define-key map "\ek" 'undefined)
+ (define-key map "\el" 'undefined)
+ (define-key map "\eq" 'undefined)
+ (define-key map "\es" 'undefined)
+ (define-key map "\et" 'undefined)
+ (define-key map "\eu" 'undefined)
+ (define-key map "\ev" 'hexl-scroll-down)
+ (define-key map "\ey" 'undefined)
+ (define-key map "\ez" 'undefined)
+ (define-key map "\e<" 'hexl-beginning-of-buffer)
+ (define-key map "\e>" 'hexl-end-of-buffer)
+
+ (fset 'hexl-C-c-prefix (copy-keymap mode-specific-map))
+ (define-key map "\C-c" 'hexl-C-c-prefix)
+ (define-key map "\C-c\C-c" 'hexl-mode-exit)
+
+ (fset 'hexl-C-x-prefix (copy-keymap 'Control-X-prefix))
+ (define-key map "\C-x" 'hexl-C-x-prefix)
+ (define-key map "\C-x[" 'hexl-beginning-of-1k-page)
+ (define-key map "\C-x]" 'hexl-end-of-1k-page)
+ (define-key map "\C-x\C-p" 'undefined)
+ (define-key map "\C-x\C-s" 'hexl-save-buffer)
+ (define-key map "\C-x\C-t" 'undefined)
+ map))
;; Variable declarations for suppressing warnings from the byte-compiler.
(defvar ruler-mode)
@@ -120,6 +212,7 @@ Quoting cannot be used, so the arguments cannot themselves contain spaces."
(defvar hexl-mode-old-syntax-table)
(defvar hexl-mode-old-font-lock-keywords)
(defvar hexl-mode-old-eldoc-documentation-function)
+(defvar hexl-mode-old-revert-buffer-function)
(defvar hexl-ascii-overlay nil
"Overlay used to highlight ASCII element corresponding to current point.")
@@ -281,10 +374,9 @@ You can use \\[hexl-find-file] to visit a file in Hexl mode.
(setq hexl-mode-old-font-lock-keywords font-lock-defaults)
(setq font-lock-defaults '(hexl-font-lock-keywords t))
- ;; Add hooks to rehexlify or dehexlify on various events.
- (add-hook 'before-revert-hook 'hexl-before-revert-hook nil t)
- (add-hook 'after-revert-hook 'hexl-after-revert-hook nil t)
-
+ (make-local-variable 'hexl-mode-old-revert-buffer-function)
+ (setq hexl-mode-old-revert-buffer-function revert-buffer-function)
+ (setq revert-buffer-function 'hexl-revert-buffer-function)
(add-hook 'change-major-mode-hook 'hexl-maybe-dehexlify-buffer nil t)
;; Set a callback function for eldoc.
@@ -321,12 +413,6 @@ You can use \\[hexl-find-file] to visit a file in Hexl mode.
(let ((isearch-search-fun-function nil))
(isearch-search-fun))))
-(defun hexl-before-revert-hook ()
- (remove-hook 'change-major-mode-hook 'hexl-maybe-dehexlify-buffer t))
-
-(defun hexl-after-revert-hook ()
- (hexl-mode))
-
(defvar hexl-in-save-buffer nil)
(defun hexl-save-buffer ()
@@ -372,6 +458,23 @@ and edit the file in `hexl-mode'."
(if (not (eq major-mode 'hexl-mode))
(hexl-mode)))
+(defun hexl-revert-buffer-function (ignore-auto noconfirm)
+ (let ((coding-system-for-read 'no-conversion)
+ revert-buffer-function)
+ ;; Call the original `revert-buffer' without code conversion; also
+ ;; prevent it from changing the major mode to normal-mode, which
+ ;; calls `set-auto-mode'.
+ (revert-buffer nil nil t)
+ ;; A couple of hacks are necessary here:
+ ;; 1. change the major-mode to one other than hexl-mode since the
+ ;; function `hexl-mode' does nothing if the current major-mode is
+ ;; already hexl-mode.
+ ;; 2. reset change-major-mode-hook in case that `hexl-mode'
+ ;; previously added hexl-maybe-dehexlify-buffer to it.
+ (remove-hook 'change-major-mode-hook 'hexl-maybe-dehexlify-buffer t)
+ (setq major-mode 'fundamental-mode)
+ (hexl-mode)))
+
(defun hexl-mode-exit (&optional arg)
"Exit Hexl mode, returning to previous mode.
With arg, don't unhexlify buffer."
@@ -391,8 +494,6 @@ With arg, don't unhexlify buffer."
(or (bobp) (setq original-point (1+ original-point))))
(goto-char original-point)))
- (remove-hook 'before-revert-hook 'hexl-before-revert-hook t)
- (remove-hook 'after-revert-hook 'hexl-after-revert-hook t)
(remove-hook 'change-major-mode-hook 'hexl-maybe-dehexlify-buffer t)
(remove-hook 'post-command-hook 'hexl-follow-ascii-find t)
(setq hexl-ascii-overlay nil)
@@ -420,6 +521,7 @@ With arg, don't unhexlify buffer."
(set-syntax-table hexl-mode-old-syntax-table)
(setq font-lock-defaults hexl-mode-old-font-lock-keywords)
(setq major-mode hexl-mode-old-major-mode)
+ (setq revert-buffer-function hexl-mode-old-revert-buffer-function)
(force-mode-line-update))
(defun hexl-maybe-dehexlify-buffer ()
@@ -1017,100 +1119,6 @@ This function is assumed to be used as callback function for `hl-line-mode'."
;; startup stuff.
-(if hexl-mode-map
- nil
- (setq hexl-mode-map (make-keymap))
- ;; Make all self-inserting keys go through hexl-self-insert-command,
- ;; because we need to convert them to unibyte characters before
- ;; inserting them into the buffer.
- (define-key hexl-mode-map [remap self-insert-command] 'hexl-self-insert-command)
-
- (define-key hexl-mode-map "\C-m" 'hexl-self-insert-command)
- (define-key hexl-mode-map [left] 'hexl-backward-char)
- (define-key hexl-mode-map [right] 'hexl-forward-char)
- (define-key hexl-mode-map [up] 'hexl-previous-line)
- (define-key hexl-mode-map [down] 'hexl-next-line)
- (define-key hexl-mode-map [M-left] 'hexl-backward-short)
- (define-key hexl-mode-map [?\e left] 'hexl-backward-short)
- (define-key hexl-mode-map [M-right] 'hexl-forward-short)
- (define-key hexl-mode-map [?\e right] 'hexl-forward-short)
- (define-key hexl-mode-map [next] 'hexl-scroll-up)
- (define-key hexl-mode-map [prior] 'hexl-scroll-down)
- (define-key hexl-mode-map [home] 'hexl-beginning-of-line)
- (define-key hexl-mode-map [end] 'hexl-end-of-line)
- (define-key hexl-mode-map [C-home] 'hexl-beginning-of-buffer)
- (define-key hexl-mode-map [C-end] 'hexl-end-of-buffer)
- (define-key hexl-mode-map [deletechar] 'undefined)
- (define-key hexl-mode-map [deleteline] 'undefined)
- (define-key hexl-mode-map [insertline] 'undefined)
- (define-key hexl-mode-map [S-delete] 'undefined)
- (define-key hexl-mode-map "\177" 'undefined)
-
- (define-key hexl-mode-map "\C-a" 'hexl-beginning-of-line)
- (define-key hexl-mode-map "\C-b" 'hexl-backward-char)
- (define-key hexl-mode-map "\C-d" 'undefined)
- (define-key hexl-mode-map "\C-e" 'hexl-end-of-line)
- (define-key hexl-mode-map "\C-f" 'hexl-forward-char)
-
- (if (not (memq (key-binding (char-to-string help-char))
- '(help-command ehelp-command)))
- (define-key hexl-mode-map (char-to-string help-char) 'undefined))
-
- (define-key hexl-mode-map "\C-k" 'undefined)
- (define-key hexl-mode-map "\C-n" 'hexl-next-line)
- (define-key hexl-mode-map "\C-o" 'undefined)
- (define-key hexl-mode-map "\C-p" 'hexl-previous-line)
- (define-key hexl-mode-map "\C-q" 'hexl-quoted-insert)
- (define-key hexl-mode-map "\C-t" 'undefined)
- (define-key hexl-mode-map "\C-v" 'hexl-scroll-up)
- (define-key hexl-mode-map "\C-w" 'undefined)
- (define-key hexl-mode-map "\C-y" 'undefined)
-
- (fset 'hexl-ESC-prefix (copy-keymap 'ESC-prefix))
- (define-key hexl-mode-map "\e" 'hexl-ESC-prefix)
- (define-key hexl-mode-map "\e\C-a" 'hexl-beginning-of-512b-page)
- (define-key hexl-mode-map "\e\C-b" 'hexl-backward-short)
- (define-key hexl-mode-map "\e\C-d" 'hexl-insert-decimal-char)
- (define-key hexl-mode-map "\e\C-e" 'hexl-end-of-512b-page)
- (define-key hexl-mode-map "\e\C-f" 'hexl-forward-short)
- (define-key hexl-mode-map "\e\C-i" 'undefined)
- (define-key hexl-mode-map "\e\C-j" 'undefined)
- (define-key hexl-mode-map "\e\C-k" 'undefined)
- (define-key hexl-mode-map "\e\C-o" 'hexl-insert-octal-char)
- (define-key hexl-mode-map "\e\C-q" 'undefined)
- (define-key hexl-mode-map "\e\C-t" 'undefined)
- (define-key hexl-mode-map "\e\C-x" 'hexl-insert-hex-char)
- (define-key hexl-mode-map "\eb" 'hexl-backward-word)
- (define-key hexl-mode-map "\ec" 'undefined)
- (define-key hexl-mode-map "\ed" 'undefined)
- (define-key hexl-mode-map "\ef" 'hexl-forward-word)
- (define-key hexl-mode-map "\eg" 'hexl-goto-hex-address)
- (define-key hexl-mode-map "\ei" 'undefined)
- (define-key hexl-mode-map "\ej" 'hexl-goto-address)
- (define-key hexl-mode-map "\ek" 'undefined)
- (define-key hexl-mode-map "\el" 'undefined)
- (define-key hexl-mode-map "\eq" 'undefined)
- (define-key hexl-mode-map "\es" 'undefined)
- (define-key hexl-mode-map "\et" 'undefined)
- (define-key hexl-mode-map "\eu" 'undefined)
- (define-key hexl-mode-map "\ev" 'hexl-scroll-down)
- (define-key hexl-mode-map "\ey" 'undefined)
- (define-key hexl-mode-map "\ez" 'undefined)
- (define-key hexl-mode-map "\e<" 'hexl-beginning-of-buffer)
- (define-key hexl-mode-map "\e>" 'hexl-end-of-buffer)
-
- (fset 'hexl-C-c-prefix (copy-keymap mode-specific-map))
- (define-key hexl-mode-map "\C-c" 'hexl-C-c-prefix)
- (define-key hexl-mode-map "\C-c\C-c" 'hexl-mode-exit)
-
- (fset 'hexl-C-x-prefix (copy-keymap 'Control-X-prefix))
- (define-key hexl-mode-map "\C-x" 'hexl-C-x-prefix)
- (define-key hexl-mode-map "\C-x[" 'hexl-beginning-of-1k-page)
- (define-key hexl-mode-map "\C-x]" 'hexl-end-of-1k-page)
- (define-key hexl-mode-map "\C-x\C-p" 'undefined)
- (define-key hexl-mode-map "\C-x\C-s" 'hexl-save-buffer)
- (define-key hexl-mode-map "\C-x\C-t" 'undefined))
-
(easy-menu-define hexl-menu hexl-mode-map "Hexl Mode menu"
`("Hexl"
:help "Hexl-specific Features"
diff --git a/lisp/hfy-cmap.el b/lisp/hfy-cmap.el
index fc5359e1f65..7aefc36224b 100644
--- a/lisp/hfy-cmap.el
+++ b/lisp/hfy-cmap.el
@@ -13,6 +13,7 @@
;; Description: fallback code for colour name -> rgb mapping
;; URL: http://rtfm.etla.org/emacs/htmlfontify/
;; Last-Updated: Sat 2003-02-15 03:49:32 +0000
+;; Package: htmlfontify
;; This file is part of GNU Emacs.
@@ -803,6 +804,7 @@
(defconst hfy-rgb-regex
"^\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\(.+\\)\\s-*$")
+;;;###autoload
(defun htmlfontify-load-rgb-file (&optional file)
"Load an X11 style rgb.txt FILE.
Search `hfy-rgb-load-path' if FILE is not specified.
@@ -832,14 +834,21 @@ Loads the variable `hfy-rgb-txt-colour-map', which is used by
(kill-buffer rgb-buffer)))))
(defun htmlfontify-unload-rgb-file ()
+ "Unload the current color name -> rgb translation map."
(interactive)
(setq hfy-rgb-txt-colour-map nil))
+;;;###autoload
(defun hfy-fallback-colour-values (colour-string)
+ "Use a fallback method for obtaining the rgb values for a color."
(cdr (assoc-string colour-string (or hfy-rgb-txt-colour-map
hfy-fallback-colour-map))) )
(provide 'hfy-cmap)
-;;; hfy-cmap.el ends here
+
+;; Local Variables:
+;; generated-autoload-file: "htmlfontify.el"
+;; End:
;; arch-tag: dff7feea-add4-48ba-937c-e79ac40cec9b
+;;; hfy-cmap.el ends here
diff --git a/lisp/hilit-chg.el b/lisp/hilit-chg.el
index ec9c88fd6ec..956cfc1c597 100644
--- a/lisp/hilit-chg.el
+++ b/lisp/hilit-chg.el
@@ -921,24 +921,26 @@ changes are made, so \\[highlight-changes-next-change] and
(defun hilit-chg-get-diff-info (buf-a file-a buf-b file-b)
- (let ((e nil) x y) ;; e is set by function hilit-chg-get-diff-list-hk
+ ;; hilit-e,x,y are set by function hilit-chg-get-diff-list-hk.
+ (let (hilit-e hilit-x hilit-y)
(ediff-setup buf-a file-a buf-b file-b
nil nil ; buf-c file-C
'hilit-chg-get-diff-list-hk
(list (cons 'ediff-job-name 'something))
)
- (ediff-with-current-buffer e (ediff-really-quit nil))
- (list x y)))
+ (ediff-with-current-buffer hilit-e (ediff-really-quit nil))
+ (list hilit-x hilit-y)))
(defun hilit-chg-get-diff-list-hk ()
- ;; x and y are dynamically bound by hilit-chg-get-diff-info
- ;; which calls this function as a hook
- (defvar x) ;; placate the byte-compiler
- (defvar y)
- (setq e (current-buffer))
+ ;; hilit-e/x/y are dynamically bound by hilit-chg-get-diff-info
+ ;; which calls this function as a hook.
+ (defvar hilit-x) ; placate the byte-compiler
+ (defvar hilit-y)
+ (defvar hilit-e)
+ (setq hilit-e (current-buffer))
(let ((n 0) extent p va vb a b)
- (setq x nil y nil) ;; x and y are bound by hilit-chg-get-diff-info
+ (setq hilit-x nil hilit-y nil)
(while (< n ediff-number-of-differences)
(ediff-make-fine-diffs n)
(setq va (ediff-get-fine-diff-vector n 'A))
@@ -954,7 +956,7 @@ changes are made, so \\[highlight-changes-next-change] and
(setq extent (list (overlay-start (car p))
(overlay-end (car p))))
(setq p (cdr p))
- (setq x (append x (list extent) )));; while p
+ (setq hilit-x (append hilit-x (list extent) )));; while p
;;
(setq vb (ediff-get-fine-diff-vector n 'B))
;; vb is a vector
@@ -969,7 +971,7 @@ changes are made, so \\[highlight-changes-next-change] and
(setq extent (list (overlay-start (car p))
(overlay-end (car p))))
(setq p (cdr p))
- (setq y (append y (list extent) )))
+ (setq hilit-y (append hilit-y (list extent) )))
(setq n (1+ n)));; while
;; ediff-quit doesn't work here.
;; No point in returning a value, since this is a hook function.
@@ -1035,5 +1037,4 @@ This is called when `global-highlight-changes-mode' is turned on."
(provide 'hilit-chg)
-;; arch-tag: de00301d-5bad-44da-aa82-e0e010b0c463
;;; hilit-chg.el ends here
diff --git a/lisp/hippie-exp.el b/lisp/hippie-exp.el
index 68c8f70cae3..2533587bcc5 100644
--- a/lisp/hippie-exp.el
+++ b/lisp/hippie-exp.el
@@ -716,8 +716,7 @@ string). It returns t if a new completion is found, nil otherwise."
(defun he-line-beg (strip-prompt)
(save-excursion
(if (re-search-backward (he-line-search-regexp "" strip-prompt)
- (save-excursion (beginning-of-line)
- (point)) t)
+ (line-beginning-position) t)
(match-beginning 2)
(point))))
@@ -1184,5 +1183,4 @@ string). It returns t if a new completion is found, nil otherwise."
(provide 'hippie-exp)
-;; arch-tag: 5e6e00bf-b061-4a7a-9b46-de0ae105ab99
;;; hippie-exp.el ends here
diff --git a/lisp/hl-line.el b/lisp/hl-line.el
index eed03ff54db..9a791076002 100644
--- a/lisp/hl-line.el
+++ b/lisp/hl-line.el
@@ -72,7 +72,7 @@
(defgroup hl-line nil
"Highlight the current line."
:version "21.1"
- :group 'editing)
+ :group 'convenience)
(defface hl-line
'((t :inherit highlight))
diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el
index f7a5382e6b8..0a4bec2248f 100644
--- a/lisp/htmlfontify.el
+++ b/lisp/htmlfontify.el
@@ -1,6 +1,7 @@
;;; htmlfontify.el --- htmlise a buffer/source tree with optional hyperlinks
-;; Copyright (C) 2002, 2003, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2002, 2003, 2009, 2010
+;; Free Software Foundation, Inc.
;; Emacs Lisp Archive Entry
;; Package: htmlfontify
@@ -15,6 +16,7 @@
;; Compatibility: Emacs23, Emacs22
;; Incompatibility: Emacs19, Emacs20, Emacs21
;; Last Updated: Thu 2009-11-19 01:31:21 +0000
+;; Version: 0.21
;; This file is part of GNU Emacs.
@@ -90,39 +92,6 @@
;; (`font-lock-fontify-region')
(require 'cus-edit)
-(eval-and-compile
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;; I want these - can't be bothered requiring all of cl though.
- (if (not (fboundp 'caddr))
- (defun caddr (list)
- "Return the `car' of the `cddr' of LIST."
- (car (cddr list))))
-
- (if (not (fboundp 'cadddr))
- (defun cadddr (list)
- "Return the `cadr' of the `cddr' of LIST."
- (cadr (cddr list))))
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
- (autoload
- 'htmlfontify-load-rgb-file
- "hfy-cmap"
- "Load an rgb.txt file for color name -> rgb translation purposes."
- 'interactive)
-
- (autoload
- 'htmlfontify-unload-rgb-file
- "hfy-cmap"
- "Unload the current color name -> rgb translation map."
- 'interactive)
-
- (autoload
- 'hfy-fallback-colour-values
- "hfy-cmap"
- "Use a fallback method for obtaining the rgb values for a color."
- 'interactive)
- )
-
(defconst htmlfontify-version 0.21)
(defconst hfy-meta-tags
@@ -2379,7 +2348,31 @@ You may also want to set `hfy-page-header' and `hfy-page-footer'."
(let ((file (hfy-initfile)))
(load file 'NOERROR nil nil) ))
+
+;;;### (autoloads (hfy-fallback-colour-values htmlfontify-load-rgb-file)
+;;;;;; "hfy-cmap" "hfy-cmap.el" "7e622e4b131ea5efbe9d258f719822d6")
+;;; Generated autoloads from hfy-cmap.el
+
+(autoload 'htmlfontify-load-rgb-file "hfy-cmap" "\
+Load an X11 style rgb.txt FILE.
+Search `hfy-rgb-load-path' if FILE is not specified.
+Loads the variable `hfy-rgb-txt-colour-map', which is used by
+`hfy-fallback-colour-values'.
+
+\(fn &optional FILE)" t nil)
+
+(autoload 'hfy-fallback-colour-values "hfy-cmap" "\
+Use a fallback method for obtaining the rgb values for a color.
+
+\(fn COLOUR-STRING)" nil nil)
+
+;;;***
+
+
(provide 'htmlfontify)
-;;; htmlfontify.el ends here
-;; arch-tag: 944e5e63-c81d-4baa-a82a-0275f9c30e61
+;; Local Variables:
+;; coding: utf-8
+;; End:
+
+;;; htmlfontify.el ends here
diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el
index 69eb3188862..196838f248d 100644
--- a/lisp/ibuf-ext.el
+++ b/lisp/ibuf-ext.el
@@ -7,6 +7,7 @@
;; Maintainer: John Paul Wallington <jpw@gnu.org>
;; Created: 2 Dec 2001
;; Keywords: buffer, convenience
+;; Package: ibuffer
;; This file is part of GNU Emacs.
@@ -91,11 +92,6 @@ regardless of any active filters in this buffer."
(defvar ibuffer-tmp-show-regexps nil
"A list of regexps which should match buffer names to always show.")
-(defvar ibuffer-auto-mode nil
- "If non-nil, Ibuffer auto-mode should be enabled for this buffer.
-Do not set this variable directly! Use the function
-`ibuffer-auto-mode' instead.")
-
(defvar ibuffer-auto-buffers-changed nil)
(defcustom ibuffer-saved-filters '(("gnus"
@@ -220,6 +216,16 @@ Currently, this only applies to `ibuffer-saved-filters' and
(ibuffer-included-in-filters-p buf ibuffer-filtering-qualifiers)
(ibuffer-buf-matches-predicates buf ibuffer-always-show-predicates)))))
+;;;###autoload
+(define-minor-mode ibuffer-auto-mode
+ "Toggle use of Ibuffer's auto-update facility.
+With numeric ARG, enable auto-update if and only if ARG is positive."
+ nil nil nil
+ (unless (derived-mode-p 'ibuffer-mode)
+ (error "This buffer is not in Ibuffer mode"))
+ (frame-or-buffer-changed-p 'ibuffer-auto-buffers-changed) ; Initialize state vector
+ (add-hook 'post-command-hook 'ibuffer-auto-update-changed))
+
(defun ibuffer-auto-update-changed ()
(when (frame-or-buffer-changed-p 'ibuffer-auto-buffers-changed)
(dolist (buf (buffer-list))
@@ -230,20 +236,6 @@ Currently, this only applies to `ibuffer-saved-filters' and
(ibuffer-update nil t)))))))
;;;###autoload
-(defun ibuffer-auto-mode (&optional arg)
- "Toggle use of Ibuffer's auto-update facility.
-With numeric ARG, enable auto-update if and only if ARG is positive."
- (interactive)
- (unless (derived-mode-p 'ibuffer-mode)
- (error "This buffer is not in Ibuffer mode"))
- (set (make-local-variable 'ibuffer-auto-mode)
- (if arg
- (plusp arg)
- (not ibuffer-auto-mode)))
- (frame-or-buffer-changed-p 'ibuffer-auto-buffers-changed) ; Initialize state vector
- (add-hook 'post-command-hook 'ibuffer-auto-update-changed))
-
-;;;###autoload
(defun ibuffer-mouse-filter-by-mode (event)
"Enable or disable filtering by the major mode chosen via mouse."
(interactive "e")
diff --git a/lisp/ibuf-macs.el b/lisp/ibuf-macs.el
index 60fb7e3b820..684cfe8f51b 100644
--- a/lisp/ibuf-macs.el
+++ b/lisp/ibuf-macs.el
@@ -7,6 +7,7 @@
;; Maintainer: John Paul Wallington <jpw@gnu.org>
;; Created: 6 Dec 2001
;; Keywords: buffer, convenience
+;; Package: ibuffer
;; This file is part of GNU Emacs.
diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el
index ea48ad5438a..052d43b41b6 100644
--- a/lisp/ibuffer.el
+++ b/lisp/ibuffer.el
@@ -332,8 +332,9 @@ directory, like `default-directory'."
:group 'ibuffer)
(defcustom ibuffer-compressed-file-name-regexp
- "\\.\\(arj\\|bgz\\|bz2\\|gz\\|lzh\\|taz\\|tgz\\|zip\\|z\\)$"
+ "\\.\\(arj\\|bgz\\|bz2\\|gz\\|lzh\\|taz\\|tgz\\|xz\\|zip\\|z\\)$"
"Regexp to match compressed file names."
+ :version "24.1" ; added xz
:type 'regexp
:group 'ibuffer)
@@ -432,10 +433,8 @@ directory, like `default-directory'."
;; immediate operations
(define-key map (kbd "n") 'ibuffer-forward-line)
- (define-key map (kbd "<down>") 'ibuffer-forward-line)
(define-key map (kbd "SPC") 'forward-line)
(define-key map (kbd "p") 'ibuffer-backward-line)
- (define-key map (kbd "<up>") 'ibuffer-backward-line)
(define-key map (kbd "M-}") 'ibuffer-forward-next-marked)
(define-key map (kbd "M-{") 'ibuffer-backwards-next-marked)
(define-key map (kbd "l") 'ibuffer-redisplay)
@@ -476,9 +475,9 @@ directory, like `default-directory'."
(define-key map (kbd "/ /") 'ibuffer-filter-disable)
(define-key map (kbd "M-n") 'ibuffer-forward-filter-group)
- (define-key map (kbd "<right>") 'ibuffer-forward-filter-group)
+ (define-key map "\t" 'ibuffer-forward-filter-group)
(define-key map (kbd "M-p") 'ibuffer-backward-filter-group)
- (define-key map (kbd "<left>") 'ibuffer-backward-filter-group)
+ (define-key map [backtab] 'ibuffer-backward-filter-group)
(define-key map (kbd "M-j") 'ibuffer-jump-to-filter-group)
(define-key map (kbd "C-k") 'ibuffer-kill-line)
(define-key map (kbd "C-y") 'ibuffer-yank)
@@ -1052,7 +1051,6 @@ If optional argument SINGLE is non-nil, then also ensure there is only
one window."
(interactive "P")
(let ((buf (ibuffer-current-buffer t)))
- (bury-buffer (current-buffer))
(switch-to-buffer buf)
(when single
(delete-other-windows))))
@@ -2641,7 +2639,7 @@ will be inserted before the group at point."
;;;;;; ibuffer-backward-filter-group ibuffer-forward-filter-group
;;;;;; ibuffer-toggle-filter-group ibuffer-mouse-toggle-filter-group
;;;;;; ibuffer-interactive-filter-by-mode ibuffer-mouse-filter-by-mode
-;;;;;; ibuffer-auto-mode) "ibuf-ext" "ibuf-ext.el" "4fb4f1a32cf4ecf4669a133a866f4a14")
+;;;;;; ibuffer-auto-mode) "ibuf-ext" "ibuf-ext.el" "fa9822b5ef905f06d8a03dc9ce3a2894")
;;; Generated autoloads from ibuf-ext.el
(autoload 'ibuffer-auto-mode "ibuf-ext" "\
diff --git a/lisp/icomplete.el b/lisp/icomplete.el
index 94822a60a63..645981539d4 100644
--- a/lisp/icomplete.el
+++ b/lisp/icomplete.el
@@ -283,7 +283,8 @@ The displays for unambiguous matches have ` [Matched]' appended
matches exist. \(Keybindings for uniquely matched commands
are exhibited within the square braces.)"
- (let* ((comps (completion-all-sorted-completions))
+ (let* ((non-essential t)
+ (comps (completion-all-sorted-completions))
(last (if (consp comps) (last comps)))
(base-size (cdr last))
(open-bracket (if require-match "(" "["))
diff --git a/lisp/ido.el b/lisp/ido.el
index a4409775a86..2df9b8666af 100644
--- a/lisp/ido.el
+++ b/lisp/ido.el
@@ -322,7 +322,7 @@
;;; Code:
-(defvar cua-inhibit-cua-keys)
+(defvar recentf-list)
;;; User Variables
;;
@@ -774,6 +774,24 @@ can be completed using TAB,
:type '(repeat string)
:group 'ido)
+(defcustom ido-use-virtual-buffers nil
+ "If non-nil, refer to past buffers as well as existing ones.
+Essentially it works as follows: Say you are visiting a file and
+the buffer gets cleaned up by mignight.el. Later, you want to
+switch to that buffer, but find it's no longer open. With
+virtual buffers enabled, the buffer name stays in the buffer
+list (using the `ido-virtual' face, and always at the end), and if
+you select it, it opens the file back up again. This allows you
+to think less about whether recently opened files are still open
+or not. Most of the time you can quit Emacs, restart, and then
+switch to a file buffer that was previously open as if it still
+were.
+ This feature relies upon the `recentf' package, which will be
+enabled if this variable is configured to a non-nil value."
+ :version "24.1"
+ :type 'boolean
+ :group 'ido)
+
(defcustom ido-use-faces t
"Non-nil means use ido faces to highlighting first match, only match and
subdirs in the alternatives."
@@ -798,6 +816,11 @@ subdirs in the alternatives."
"Face used by ido for highlighting subdirs in the alternatives."
:group 'ido)
+(defface ido-virtual '((t (:inherit font-lock-builtin-face)))
+ "Face used by ido for matching virtual buffer names."
+ :version "24.1"
+ :group 'ido)
+
(defface ido-indicator '((((min-colors 88) (class color))
(:foreground "yellow1"
:background "red1"
@@ -1030,6 +1053,11 @@ so that it doesn't interfere with other minibuffer usage.")
"Non-nil means to explicitly cursor on entry to minibuffer.
Value is an integer which is number of chars to right of prompt.")
+(defvar ido-virtual-buffers nil
+ "List of virtual buffers, that is, past visited files.
+This is a copy of `recentf-list', pared down and with faces applied.
+Only used if `ido-use-virtual-buffers' is non-nil.")
+
;;; Variables with dynamic bindings.
;;; Declared here to keep the byte compiler quiet.
@@ -1595,7 +1623,6 @@ This function also adds a hook to the minibuffer."
(define-key map "\C-o" 'ido-copy-current-word)
(define-key map "\C-w" 'ido-copy-current-file-name)
(define-key map [(meta ?l)] 'ido-toggle-literal)
- (define-key map "\C-v" 'ido-toggle-vc)
(set-keymap-parent map ido-file-dir-completion-map)
(setq ido-file-completion-map map))
@@ -1604,6 +1631,7 @@ This function also adds a hook to the minibuffer."
(define-key map "\C-x\C-f" 'ido-enter-find-file)
(define-key map "\C-x\C-b" 'ido-fallback-command)
(define-key map "\C-k" 'ido-kill-buffer-at-head)
+ (define-key map "\C-o" 'ido-toggle-virtual-buffers)
(set-keymap-parent map ido-common-completion-map)
(setq ido-buffer-completion-map map)))
@@ -2153,9 +2181,13 @@ If cursor is not at the end of the user input, move to end of input."
(ido-current-directory nil)
(ido-directory-nonreadable nil)
(ido-directory-too-big nil)
+ (ido-use-virtual-buffers (if (eq method 'kill)
+ nil ;; Don't consider virtual buffers for killing
+ ido-use-virtual-buffers))
(require-match (confirm-nonexistent-file-or-buffer))
(buf (ido-read-internal 'buffer (or prompt "Buffer: ") 'ido-buffer-history default
- require-match initial)))
+ require-match initial))
+ filename)
;; Choose the buffer name: either the text typed in, or the head
;; of the list of matches
@@ -2191,6 +2223,16 @@ If cursor is not at the end of the user input, move to end of input."
(point))))
(ido-visit-buffer buf method t)))
+ ;; check for a virtual buffer reference
+ ((and ido-use-virtual-buffers ido-virtual-buffers
+ (setq filename (assoc buf ido-virtual-buffers)))
+ (ido-visit-buffer (find-file-noselect (cdr filename)) method t))
+
+ ((and (eq ido-create-new-buffer 'prompt)
+ (null require-match)
+ (not (y-or-n-p (format "No buffer matching `%s', create one? " buf))))
+ nil)
+
;; buffer doesn't exist
((and (eq ido-create-new-buffer 'never)
(null require-match))
@@ -2665,6 +2707,16 @@ C-x C-f ... C-d enter `dired' on current directory."
(setq ido-exit 'keep)
(exit-minibuffer))))
+(defun ido-toggle-virtual-buffers ()
+ "Toggle the use of virtual buffers.
+See `ido-use-virtual-buffers' for explanation of virtual buffer."
+ (interactive)
+ (when (and ido-mode (eq ido-cur-item 'buffer))
+ (setq ido-use-virtual-buffers (not ido-use-virtual-buffers))
+ (setq ido-text-init ido-text)
+ (setq ido-exit 'refresh)
+ (exit-minibuffer)))
+
(defun ido-reread-directory ()
"Read current directory again.
May be useful if cached version is no longer valid, but directory
@@ -2763,7 +2815,7 @@ If no buffer or file exactly matching the prompt exists, maybe create a new one.
((eq this-original-command 'viper-del-backward-char-in-insert)
(funcall this-original-command))
(t
- (delete-backward-char (prefix-numeric-value count)))))
+ (delete-char (- (prefix-numeric-value count))))))
(defun ido-delete-backward-word-updir (count)
"Delete all chars backwards, or at beginning of buffer, go up one level."
@@ -3351,9 +3403,38 @@ for first matching file."
(if default
(setq ido-temp-list
(cons default (delete default ido-temp-list))))
+ (if ido-use-virtual-buffers
+ (ido-add-virtual-buffers-to-list))
(run-hooks 'ido-make-buffer-list-hook)
ido-temp-list))
+(defun ido-add-virtual-buffers-to-list ()
+ "Add recently visited files, and bookmark files, to the buffer list.
+This is to make them appear as if they were \"virtual buffers\"."
+ ;; 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.
+ (unless recentf-mode (recentf-mode 1))
+ (setq ido-virtual-buffers nil)
+ (let (name)
+ (dolist (head recentf-list)
+ (and (setq name (file-name-nondirectory head))
+ (null (get-file-buffer head))
+ (not (assoc name ido-virtual-buffers))
+ (not (member name ido-temp-list))
+ (not (ido-ignore-item-p name ido-ignore-buffers))
+ ;;(file-exists-p head)
+ (push (cons name head) ido-virtual-buffers))))
+ (when ido-virtual-buffers
+ (if ido-use-faces
+ (dolist (comp ido-virtual-buffers)
+ (put-text-property 0 (length (car comp))
+ 'face 'ido-virtual
+ (car comp))))
+ (setq ido-temp-list
+ (nconc ido-temp-list
+ (nreverse (mapcar #'car ido-virtual-buffers))))))
+
(defun ido-make-choice-list (default)
;; Return the current list of choices.
;; If DEFAULT is non-nil, and corresponds to an element of choices,
@@ -3393,7 +3474,7 @@ for first matching file."
;; Strip method:user@host: part of tramp completions.
;; Tramp completions do not include leading slash.
(let* ((len (1- (length dir)))
- (tramp-completion-mode t)
+ (non-essential t)
(compl
(or (file-name-all-completions "" dir)
;; work around bug in ange-ftp.
@@ -4515,7 +4596,6 @@ For details of keybindings, see `ido-find-file'."
(when (ido-active)
(add-hook 'pre-command-hook 'ido-tidy nil t)
(add-hook 'post-command-hook 'ido-exhibit nil t)
- (setq cua-inhibit-cua-keys t)
(when (featurep 'xemacs)
(ido-exhibit)
(goto-char (point-min)))
diff --git a/lisp/iimage.el b/lisp/iimage.el
index e52a7d37301..ca300bf9fb2 100644
--- a/lisp/iimage.el
+++ b/lisp/iimage.el
@@ -1,6 +1,7 @@
;;; iimage.el --- Inline image minor mode.
-;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: KOSEKI Yoshinori <kose@meadowy.org>
;; Maintainer: KOSEKI Yoshinori <kose@meadowy.org>
@@ -27,20 +28,16 @@
;; exists in the buffer.
;; http://www.netlaputa.ne.jp/~kose/Emacs/iimage.html
;;
-;; Add to your `~/.emacs':
-;; (autoload 'iimage-mode "iimage" "Support Inline image minor mode." t)
-;; (autoload 'turn-on-iimage-mode "iimage" "Turn on Inline image minor mode." t)
-;;
;; ** Display images in *Info* buffer.
;;
-;; (add-hook 'info-mode-hook 'turn-on-iimage-mode)
+;; (add-hook 'info-mode-hook '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)
+;; (add-hook 'wiki-mode-hook 'iimage-mode)
;;
;; wiki-file: [[foo.png]]
@@ -54,21 +51,10 @@
:version "22.1"
:group 'image)
-(defconst iimage-version "1.1")
-(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))
+(defcustom iimage-mode-image-search-path nil
+ "List of directories to search for image files for iimage-mode."
+ :type '(choice (const nil) (repeat directory))
+ :group 'iimage)
(defvar iimage-mode-image-filename-regex
(concat "[-+./_0-9a-zA-Z]+\\."
@@ -77,70 +63,86 @@
image-file-name-extensions)
t)))
-(defvar iimage-mode-image-regex-alist
+(defcustom iimage-mode-image-regex-alist
`((,(concat "\\(`?file://\\|\\[\\[\\|<\\|`\\)?"
"\\(" iimage-mode-image-filename-regex "\\)"
"\\(\\]\\]\\|>\\|'\\)?") . 2))
-"*Alist of filename REGEXP vs NUM.
+ "Alist of filename REGEXP vs NUM.
Each element looks like (REGEXP . NUM).
NUM specifies which parenthesized expression in the regexp.
-Examples of image filename regexps:
+Examples of image filename patterns to match:
file://foo.png
`file://foo.png'
\\[\\[foo.gif]]
<foo.png>
foo.JPG
-")
+"
+ :type '(alist :key-type regexp :value-type integer)
+ :group 'iimage)
-(defvar iimage-mode-image-search-path nil
-"*List of directories to search for image files for iimage-mode.")
+(defvar iimage-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\C-l" 'iimage-recenter)
+ map)
+ "Keymap used in `iimage-mode'.")
+
+(defun iimage-recenter (&optional arg)
+ "Re-draw images and recenter."
+ (interactive "P")
+ (iimage-mode-buffer nil)
+ (iimage-mode-buffer t)
+ (recenter arg))
;;;###autoload
-(defun turn-on-iimage-mode ()
-"Unconditionally turn on iimage mode."
- (interactive)
- (iimage-mode 1))
+(define-obsolete-function-alias 'turn-on-iimage-mode 'iimage-mode "24.1")
(defun turn-off-iimage-mode ()
-"Unconditionally turn off iimage mode."
+ "Unconditionally turn off iimage mode."
(interactive)
(iimage-mode 0))
-(defalias 'iimage-locate-file 'locate-file)
+(defun iimage-modification-hook (beg end)
+ "Remove display property if a display region is modified."
+ ;;(debug-print "ii1 begin %d, end %d\n" beg end)
+ (let ((inhibit-modification-hooks t)
+ (beg (previous-single-property-change end 'display
+ nil (line-beginning-position)))
+ (end (next-single-property-change beg 'display
+ nil (line-end-position))))
+ (when (and beg end (plist-get (text-properties-at beg) 'display))
+ ;;(debug-print "ii2 begin %d, end %d\n" beg end)
+ (remove-text-properties beg end
+ '(display nil modification-hooks nil)))))
(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 (iimage-locate-file file
- (cons default-directory
- iimage-mode-image-search-path))))
- (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)))
+ "Display images if ARG is non-nil, undisplay them otherwise."
+ (let ((image-path (cons default-directory iimage-mode-image-search-path))
+ file)
+ (with-silent-modifications
+ (save-excursion
+ (goto-char (point-min))
+ (dolist (pair iimage-mode-image-regex-alist)
+ (while (re-search-forward (car pair) nil t)
+ (when (and (setq file (match-string (cdr pair)))
+ (setq file (locate-file file image-path)))
+ ;; FIXME: we don't mark our images, so we can't reliably
+ ;; remove them either (we may leave some of ours, and we
+ ;; may remove other packages's display properties).
+ (if arg
+ (add-text-properties (match-beginning 0) (match-end 0)
+ `(display ,(create-image file)
+ modification-hooks
+ (iimage-modification-hook)))
+ (remove-text-properties (match-beginning 0) (match-end 0)
+ '(display modification-hooks))))))))))
;;;###autoload
(define-minor-mode iimage-mode
"Toggle inline image minor mode."
:group 'iimage :lighter " iImg" :keymap 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-dired.el b/lisp/image-dired.el
index f006e2e9edd..a74ddd312d5 100644
--- a/lisp/image-dired.el
+++ b/lisp/image-dired.el
@@ -157,6 +157,7 @@
(require 'widget)
(eval-when-compile
+ (require 'cl)
(require 'wid-edit))
(defgroup image-dired nil
@@ -632,26 +633,32 @@ according to the Thumbnail Managing Standard."
(call-process shell-file-name nil nil nil shell-command-switch command)))
;;;###autoload
-(defun image-dired-dired-insert-marked-thumbs ()
- "Insert thumbnails before file names of marked files in the dired buffer."
- (interactive)
+(defun image-dired-dired-toggle-marked-thumbs (&optional arg)
+ "Toggle thumbnails in front of file names in the dired buffer.
+If no marked file could be found, insert or hide thumbnails on the
+current line. ARG, if non-nil, specifies the files to use instead
+of the marked files. If ARG is an integer, use the next ARG (or
+previous -ARG, if ARG<0) files."
+ (interactive "P")
(dired-map-over-marks
- (let* ((image-pos (dired-move-to-filename))
- (image-file (dired-get-filename))
- (thumb-file (image-dired-get-thumbnail-image image-file))
+ (let* ((image-pos (dired-move-to-filename))
+ (image-file (dired-get-filename nil t))
+ thumb-file
overlay)
- ;; If image is not already added, then add it.
- (unless (delq nil (mapcar (lambda (o) (overlay-get o 'put-image))
- ;; Can't use (overlays-at (point)), BUG?
- (overlays-in (point) (1+ (point)))))
- (put-image thumb-file image-pos)
- (setq
- overlay
- (car (delq nil (mapcar (lambda (o) (and (overlay-get o 'put-image) o))
- (overlays-in (point) (1+ (point)))))))
- (overlay-put overlay 'image-file image-file)
- (overlay-put overlay 'thumb-file thumb-file)))
- nil)
+ (when (and image-file (string-match-p (image-file-name-regexp) image-file))
+ (setq thumb-file (image-dired-get-thumbnail-image image-file))
+ ;; If image is not already added, then add it.
+ (let ((cur-ov (overlays-in (point) (1+ (point)))))
+ (if cur-ov
+ (delete-overlay (car cur-ov))
+ (put-image thumb-file image-pos)
+ (setq overlay (loop for o in (overlays-in (point) (1+ (point)))
+ when (overlay-get o 'put-image) collect o into ov
+ finally return (car ov)))
+ (overlay-put overlay 'image-file image-file)
+ (overlay-put overlay 'thumb-file thumb-file)))))
+ arg ; Show or hide image on ARG next files.
+ 'show-progress) ; Update dired display after each image is updated.
(add-hook 'dired-after-readin-hook 'image-dired-dired-after-readin-hook nil t))
(defun image-dired-dired-after-readin-hook ()
@@ -937,7 +944,7 @@ FILE-TAGS is an alist in the following form:
;; If on empty line at end of buffer
(when (and (eobp)
(looking-at "^$"))
- (delete-backward-char 1))))))
+ (delete-char -1))))))
files)
(save-buffer)
(kill-buffer buf))))
diff --git a/lisp/image-mode.el b/lisp/image-mode.el
index 7143d9833c0..5f43f390c2a 100644
--- a/lisp/image-mode.el
+++ b/lisp/image-mode.el
@@ -4,6 +4,7 @@
;;
;; Author: Richard Stallman <rms@gnu.org>
;; Keywords: multimedia
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -35,18 +36,6 @@
(require 'image)
(eval-when-compile (require 'cl))
-;;;###autoload (push (cons (purecopy "\\.jpe?g\\'") 'image-mode) auto-mode-alist)
-;;;###autoload (push (cons (purecopy "\\.png\\'") 'image-mode) auto-mode-alist)
-;;;###autoload (push (cons (purecopy "\\.gif\\'") 'image-mode) auto-mode-alist)
-;;;###autoload (push (cons (purecopy "\\.tiff?\\'") 'image-mode) auto-mode-alist)
-;;;###autoload (push (cons (purecopy "\\.p[bpgn]m\\'") 'image-mode) auto-mode-alist)
-
-;;;###autoload (push (cons (purecopy "\\.x[bp]m\\'") 'c-mode) auto-mode-alist)
-;;;###autoload (push (cons (purecopy "\\.x[bp]m\\'") 'image-mode) auto-mode-alist)
-
-;;;###autoload (push (cons (purecopy "\\.svgz?\\'") 'xml-mode) auto-mode-alist)
-;;;###autoload (push (cons (purecopy "\\.svgz?\\'") 'image-mode) auto-mode-alist)
-
;;; Image mode window-info management.
(defvar image-mode-winprops-alist t)
@@ -320,10 +309,14 @@ This variable is used to display the current image type in the mode line.")
(define-key map (kbd "DEL") 'image-scroll-down)
(define-key map [remap forward-char] 'image-forward-hscroll)
(define-key map [remap backward-char] 'image-backward-hscroll)
+ (define-key map [remap right-char] 'image-forward-hscroll)
+ (define-key map [remap left-char] 'image-backward-hscroll)
(define-key map [remap previous-line] 'image-previous-line)
(define-key map [remap next-line] 'image-next-line)
(define-key map [remap scroll-up] 'image-scroll-up)
(define-key map [remap scroll-down] 'image-scroll-down)
+ (define-key map [remap scroll-up-command] 'image-scroll-up)
+ (define-key map [remap scroll-down-command] 'image-scroll-down)
(define-key map [remap move-beginning-of-line] 'image-bol)
(define-key map [remap move-end-of-line] 'image-eol)
(define-key map [remap beginning-of-buffer] 'image-bob)
@@ -377,6 +370,7 @@ to toggle between display as an image and display as text."
(image-mode-setup-winprops)
(add-hook 'change-major-mode-hook 'image-toggle-display-text nil t)
+ (add-hook 'after-revert-hook 'image-after-revert-hook nil t)
(run-mode-hooks 'image-mode-hook)
(message "%s" (concat
(substitute-command-keys
@@ -468,7 +462,7 @@ Remove text properties that display the image."
(defvar archive-superior-buffer)
(defvar tar-superior-buffer)
-(declare-function image-refresh "image.c" (spec &optional frame))
+(declare-function image-flush "image.c" (spec &optional frame))
(defun image-toggle-display-image ()
"Show the image of the image file.
@@ -488,7 +482,10 @@ was inserted."
(buffer-substring-no-properties (point-min) (point-max)))
filename))
(type (image-type file-or-data nil data-p))
- (image (create-image file-or-data type data-p))
+ (image0 (create-animated-image file-or-data type data-p))
+ (image (append image0
+ (image-transform-properties image0)
+ ))
(props
`(display ,image
intangible ,image
@@ -497,7 +494,7 @@ was inserted."
(inhibit-read-only t)
(buffer-undo-list t)
(modified (buffer-modified-p)))
- (image-refresh image)
+ (image-flush image)
(let ((buffer-file-truename nil)) ; avoid changing dir mtime by lock_file
(add-text-properties (point-min) (point-max) props)
(restore-buffer-modified-p modified))
@@ -523,17 +520,25 @@ the image file and `image-mode' showing the image as an image."
(if (image-get-display-property)
(image-mode-as-text)
(image-mode)))
+
+(defun image-after-revert-hook ()
+ (when (image-get-display-property)
+ (image-toggle-display-text)
+ ;; Update image display.
+ (redraw-frame (selected-frame))
+ (image-toggle-display-image)))
+
;;; Support for bookmark.el
-(declare-function bookmark-make-record-default "bookmark"
- (&optional point-only))
+(declare-function bookmark-make-record-default
+ "bookmark" (&optional no-file no-context posn))
(declare-function bookmark-prop-get "bookmark" (bookmark prop))
(declare-function bookmark-default-handler "bookmark" (bmk))
(defun image-bookmark-make-record ()
- (nconc (bookmark-make-record-default)
- `((image-type . ,image-type)
- (handler . image-bookmark-jump))))
+ `(,@(bookmark-make-record-default nil 'no-context 0)
+ (image-type . ,image-type)
+ (handler . image-bookmark-jump)))
;;;###autoload
(defun image-bookmark-jump (bmk)
@@ -543,6 +548,84 @@ the image file and `image-mode' showing the image as an image."
(when (not (string= image-type (bookmark-prop-get bmk 'image-type)))
(image-toggle-display))))
+
+(defvar image-transform-minor-mode-map
+ (let ((map (make-sparse-keymap)))
+; (define-key map [(control ?+)] 'image-scale-in)
+; (define-key map [(control ?-)] 'image-scale-out)
+; (define-key map [(control ?=)] 'image-scale-none)
+;; (define-key map "c f h" 'image-scale-fit-height)
+;; (define-key map "c ]" 'image-rotate-right)
+ map)
+ "Minor mode keymap for transforming the view of images Image mode.")
+
+(define-minor-mode image-transform-mode
+ "minor mode for scaleing and rotation"
+ nil "image-transform"
+ image-transform-minor-mode-map)
+
+(defvar image-transform-resize nil
+ "The image resize operation. See the command
+ `image-transform-set-scale' for more information." )
+
+(defvar image-transform-rotation 0.0)
+
+
+(defun image-transform-properties (display)
+ "Calculate the display properties for transformations; scaling
+and rotation. "
+ (let*
+ ((size (image-size display t))
+ (height
+ (cond
+ ((and (numberp image-transform-resize) (eq 100 image-transform-resize))
+ nil)
+ ((numberp image-transform-resize)
+ (* image-transform-resize (cdr size)))
+ ((eq image-transform-resize 'fit-height)
+ (- (nth 3 (window-inside-pixel-edges)) (nth 1 (window-inside-pixel-edges))))
+ (t nil)))
+ (width (if (eq image-transform-resize 'fit-width)
+ (- (nth 2 (window-inside-pixel-edges)) (nth 0 (window-inside-pixel-edges))))))
+
+ `(,@(if height (list :height height))
+ ,@(if width (list :width width))
+ ,@(if (not (equal 0.0 image-transform-rotation))
+ (list :rotation image-transform-rotation))
+ ;;TODO fit-to-* should consider the rotation angle
+ )))
+
+(defun image-transform-set-scale (scale)
+ "SCALE sets the scaling for images. "
+ (interactive "nscale:")
+ (image-transform-set-resize (float scale)))
+
+(defun image-transform-fit-to-height ()
+ "Fit image height to window height. "
+ (interactive)
+ (image-transform-set-resize 'fit-height))
+
+(defun image-transform-fit-to-width ()
+ "Fit image width to window width. "
+ (interactive)
+ (image-transform-set-resize 'fit-width))
+
+(defun image-transform-set-resize (resize)
+ "Set the resize mode for images. The RESIZE value can be the
+symbol fit-height which fits the image to the window height. The
+symbol fit-width fits the image to the window width. A number
+indicates a scaling factor. nil indicates scale to 100%. "
+ (setq image-transform-resize resize)
+ (if (eq 'image-mode major-mode) (image-toggle-display-image)))
+
+(defun image-transform-set-rotation (rotation)
+ "Set the image ROTATION angle. "
+ (interactive "nrotation:")
+ ;;TODO 0 90 180 270 degrees are the only reasonable angles here
+ ;;otherwise combining with rescaling will get very awkward
+ (setq image-transform-rotation (float rotation))
+ (if (eq major-mode 'image-mode) (image-toggle-display-image)))
+
(provide 'image-mode)
;; arch-tag: b5b2b7e6-26a7-4b79-96e3-1546b5c4c6cb
diff --git a/lisp/image.el b/lisp/image.el
index 944c6135e23..f93fd03fba3 100644
--- a/lisp/image.el
+++ b/lisp/image.el
@@ -1,10 +1,11 @@
;;; image.el --- image API
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: multimedia
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -30,6 +31,7 @@
"Image support."
:group 'multimedia)
+(defalias 'image-refresh 'image-flush)
(defconst image-type-header-regexps
`(("\\`/[\t\n\r ]*\\*.*XPM.\\*/" . xpm)
@@ -328,14 +330,16 @@ Optional DATA-P non-nil means SOURCE is a string containing image data."
type)
-(defvar image-library-alist)
+(define-obsolete-variable-alias
+ 'image-library-alist
+ 'dynamic-library-alist "24.1")
;;;###autoload
(defun image-type-available-p (type)
"Return non-nil if image type TYPE is available.
Image types are symbols like `xbm' or `jpeg'."
(and (fboundp 'init-image-library)
- (init-image-library type image-library-alist)))
+ (init-image-library type dynamic-library-alist)))
;;;###autoload
@@ -584,6 +588,140 @@ Example:
(declare (doc-string 3))
`(defvar ,symbol (find-image ',specs) ,doc))
+
+;;; Animated image API
+
+(defcustom image-animate-max-time 30
+ "Time in seconds to animate images."
+ :type 'integer
+ :version "24.1"
+ :group 'image)
+
+(defconst image-animated-types '(gif)
+ "List of supported animated image types.")
+
+;;;###autoload
+(defun create-animated-image (file-or-data &optional type data-p &rest props)
+ "Create an animated image.
+FILE-OR-DATA is an image file name or image data.
+Optional TYPE is a symbol describing the image type. If TYPE is omitted
+or nil, try to determine the image type from its first few bytes
+of image data. If that doesn't work, and FILE-OR-DATA is a file name,
+use its file extension as image type.
+Optional DATA-P non-nil means FILE-OR-DATA is a string containing image data.
+Optional PROPS are additional image attributes to assign to the image,
+like, e.g. `:mask MASK'.
+Value is the image created, or nil if images of type TYPE are not supported.
+
+Images should not be larger than specified by `max-image-size'."
+ (setq type (image-type file-or-data type data-p))
+ (when (image-type-available-p type)
+ (let* ((animate (memq type image-animated-types))
+ (image
+ (append (list 'image :type type (if data-p :data :file) file-or-data)
+ (if animate '(:index 0))
+ props)))
+ (if animate
+ (image-animate-start image))
+ image)))
+
+(defun image-animate-timer (image)
+ "Return the animation timer for image IMAGE."
+ ;; See cancel-function-timers
+ (let ((tail timer-list) timer)
+ (while tail
+ (setq timer (car tail)
+ tail (cdr tail))
+ (if (and (eq (aref timer 5) #'image-animate-timeout)
+ (consp (aref timer 6))
+ (eq (car (aref timer 6)) image))
+ (setq tail nil)
+ (setq timer nil)))
+ timer))
+
+(defun image-animate-start (image &optional max-time)
+ "Start animation of image IMAGE.
+Optional second arg MAX-TIME is number of seconds to animate image,
+or t to animate infinitely."
+ (let ((anim (image-animated-p image))
+ timer tmo)
+ (when anim
+ (if (setq timer (image-animate-timer image))
+ (setcar (nthcdr 3 (aref timer 6)) max-time)
+ (setq tmo (* (cdr anim) 0.01))
+ (setq max-time (or max-time image-animate-max-time))
+ (run-with-timer tmo nil #'image-animate-timeout
+ image 1 (car anim)
+ (if (numberp max-time)
+ (- max-time tmo)
+ max-time))))))
+
+(defun image-animate-stop (image)
+ "Stop animation of image."
+ (let ((timer (image-animate-timer image)))
+ (when timer
+ (cancel-timer timer))))
+
+(defun image-animate-timeout (image ino count time-left)
+ (if (>= ino count)
+ (setq ino 0))
+ (plist-put (cdr image) :index ino)
+ (force-window-update)
+ (let ((anim (image-animated-p image)) tmo)
+ (when anim
+ (setq tmo (* (cdr anim) 0.01))
+ (unless (and (= ino 0) (numberp time-left) (< time-left tmo))
+ (run-with-timer tmo nil #'image-animate-timeout
+ image (1+ ino) count
+ (if (numberp time-left)
+ (- time-left tmo)
+ time-left))))))
+
+(defun image-animated-p (image)
+ "Return non-nil if image is animated.
+Actually, return value is a cons (IMAGES . DELAY) where IMAGES
+is the number of sub-images in the animated image, and DELAY
+is the delay in 100ths of a second until the next sub-image
+shall be displayed."
+ (cond
+ ((eq (plist-get (cdr image) :type) 'gif)
+ (let* ((metadata (image-metadata image))
+ (images (plist-get metadata 'count))
+ (extdata (plist-get metadata 'extension-data))
+ (anim (plist-get extdata #xF9))
+ (tmo (and (integerp images) (> images 1)
+ (stringp anim) (>= (length anim) 4)
+ (+ (aref anim 1) (* (aref anim 2) 256)))))
+ (when tmo
+ (if (eq tmo 0) (setq tmo 10))
+ (cons images tmo))))))
+
+
+(defcustom imagemagick-types-inhibit
+ '(C HTML HTM TXT PDF)
+ ;; FIXME what are the possible options?
+ ;; Are these actually file-name extensions?
+ ;; Why are these upper-case when eg image-types is lower-case?
+ "Types the ImageMagick loader should not try to handle."
+ :type '(choice (const :tag "Let ImageMagick handle all the types it can" nil)
+ (repeat symbol))
+ :version "24.1"
+ :group 'image)
+
+;;;###autoload
+(defun imagemagick-register-types ()
+ "Register the file types that ImageMagick is able to handle."
+ (let ((im-types (imagemagick-types)))
+ (dolist (im-inhibit imagemagick-types-inhibit)
+ (setq im-types (remove im-inhibit im-types)))
+ (dolist (im-type im-types)
+ (let ((extension (downcase (symbol-name im-type))))
+ (push
+ (cons (concat "\\." extension "\\'") 'image-mode)
+ auto-mode-alist)
+ (push
+ (cons (concat "\\." extension "\\'") 'imagemagick)
+ image-type-file-name-regexps)))))
(provide 'image)
diff --git a/lisp/imenu.el b/lisp/imenu.el
index 1eac458fd51..cf055b38550 100644
--- a/lisp/imenu.el
+++ b/lisp/imenu.el
@@ -162,7 +162,7 @@ element should come before the second. The arguments are cons cells;
;; No longer used. KFS 2004-10-27
;; (defcustom imenu-scanning-message "Scanning buffer for index (%3d%%)"
-;; "*Progress message during the index scanning of the buffer.
+;; "Progress message during the index scanning of the buffer.
;; If non-nil, user gets a message during the scanning of the buffer.
;;
;; Relevant only if the mode-specific function that creates the buffer
diff --git a/lisp/indent.el b/lisp/indent.el
index adecbfaeb12..e57d6068ef5 100644
--- a/lisp/indent.el
+++ b/lisp/indent.el
@@ -4,6 +4,7 @@
;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Maintainer: FSF
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -67,6 +68,7 @@ The buffer-local variable `indent-line-function' determines how to do this,
but the functions `indent-relative' and `indent-relative-maybe' are
special; we don't actually use them here."
(interactive)
+ (syntax-propertize (line-end-position))
(if (memq indent-line-function
'(indent-relative indent-relative-maybe))
;; These functions are used for tabbing, but can't be used for
@@ -417,7 +419,7 @@ column to indent to; if it is nil, use one of the three methods above."
(goto-char start)
(while (< (point) end)
(or (and (bolp) (eolp))
- (funcall indent-line-function))
+ (indent-according-to-mode))
(forward-line 1))
(move-marker end nil))))
(setq column (prefix-numeric-value column))
@@ -431,7 +433,11 @@ column to indent to; if it is nil, use one of the three methods above."
(or (eolp)
(indent-to column 0))
(forward-line 1))
- (move-marker end nil))))
+ (move-marker end nil)))
+ ;; In most cases, reindenting modifies the buffer, but it may also
+ ;; leave it unmodified, in which case we have to deactivate the mark
+ ;; by hand.
+ (deactivate-mark))
(defun indent-relative-maybe ()
"Indent a new line like previous nonblank line.
diff --git a/lisp/info.el b/lisp/info.el
index 42ec43eee22..7c0333f6b8e 100644
--- a/lisp/info.el
+++ b/lisp/info.el
@@ -1,8 +1,8 @@
;; info.el --- info package for Emacs
-;; Copyright (C) 1985, 1986, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1986, 1992, 1993, 1994, 1995, 1996, 1997, 1998,
+;; 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+;; 2010 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: help
@@ -238,7 +238,9 @@ This only has an effect if `Info-hide-note-references' is non-nil."
(defcustom Info-breadcrumbs-depth 4
"Depth of breadcrumbs to display.
0 means do not display breadcrumbs."
- :type 'integer)
+ :version "23.1"
+ :type 'integer
+ :group 'info)
(defcustom Info-search-whitespace-regexp "\\s-+"
"If non-nil, regular expression to match a sequence of whitespace chars.
@@ -266,6 +268,8 @@ with wrapping around the current Info node."
:group 'info)
(defvar Info-isearch-initial-node nil)
+(defvar Info-isearch-initial-history nil)
+(defvar Info-isearch-initial-history-list nil)
(defcustom Info-mode-hook
;; Try to obey obsolete Info-fontify settings.
@@ -398,24 +402,28 @@ or `Info-virtual-nodes'."
(".info.gz". "gunzip")
(".info.z". "gunzip")
(".info.bz2" . ("bzip2" "-dc"))
+ (".info.xz". "unxz")
(".info". nil)
("-info.Z". "uncompress")
("-info.Y". "unyabba")
("-info.gz". "gunzip")
("-info.bz2" . ("bzip2" "-dc"))
("-info.z". "gunzip")
+ ("-info.xz". "unxz")
("-info". nil)
("/index.Z". "uncompress")
("/index.Y". "unyabba")
("/index.gz". "gunzip")
("/index.z". "gunzip")
("/index.bz2". ("bzip2" "-dc"))
+ ("/index.xz". "unxz")
("/index". nil)
(".Z". "uncompress")
(".Y". "unyabba")
(".gz". "gunzip")
(".z". "gunzip")
(".bz2" . ("bzip2" "-dc"))
+ (".xz". "unxz")
("". nil)))
"List of file name suffixes and associated decoding commands.
Each entry should be (SUFFIX . STRING); the file is given to
@@ -798,17 +806,22 @@ otherwise, that defaults to `Top'."
"Go to an Info node FILENAME and NODENAME, re-reading disk contents.
When *info* is already displaying FILENAME and NODENAME, the window position
is preserved, if possible."
- (pop-to-buffer "*info*")
+ (or (eq major-mode 'Info-mode) (pop-to-buffer "*info*"))
(let ((old-filename Info-current-file)
(old-nodename Info-current-node)
+ (old-buffer-name (buffer-name))
(pcolumn (current-column))
(pline (count-lines (point-min) (line-beginning-position)))
(wline (count-lines (point-min) (window-start)))
+ (old-history-forward Info-history-forward)
(old-history Info-history)
(new-history (and Info-current-file
(list Info-current-file Info-current-node (point)))))
(kill-buffer (current-buffer))
+ (pop-to-buffer (or old-buffer-name "*info*"))
+ (Info-mode)
(Info-find-node filename nodename)
+ (setq Info-history-forward old-history-forward)
(setq Info-history old-history)
(if (and (equal old-filename Info-current-file)
(equal old-nodename Info-current-node))
@@ -875,17 +888,16 @@ Value is the position at which a match was found, or nil if not found."
(let ((case-fold-search case-fold)
found)
(save-excursion
- (when (Info-node-at-bob-matching regexp)
- (setq found (point)))
- (while (and (not found)
- (search-forward "\n\^_" nil t))
- (forward-line 1)
- (let ((beg (point)))
- (forward-line 1)
- (when (re-search-backward regexp beg t)
- (beginning-of-line)
- (setq found (point)))))
- found)))
+ (if (Info-node-at-bob-matching regexp)
+ (setq found (point))
+ (while (and (not found)
+ (search-forward "\n\^_" nil t))
+ (forward-line 1)
+ (let ((beg (point)))
+ (forward-line 1)
+ (if (re-search-backward regexp beg t)
+ (setq found (line-beginning-position)))))))
+ found))
(defun Info-find-node-in-buffer (regexp)
"Find a node or anchor in the current buffer.
@@ -1914,7 +1926,27 @@ If DIRECTION is `backward', search in the reverse direction."
(setq Info-isearch-initial-node
;; Don't stop at initial node for nonincremental search.
;; Otherwise this variable is set after first search failure.
- (and isearch-nonincremental Info-current-node)))
+ (and isearch-nonincremental Info-current-node))
+ (setq Info-isearch-initial-history Info-history
+ Info-isearch-initial-history-list Info-history-list)
+ (add-hook 'isearch-mode-end-hook 'Info-isearch-end nil t))
+
+(defun Info-isearch-end ()
+ ;; Remove intermediate nodes (visited while searching)
+ ;; from the history. Add only the last node (where Isearch ended).
+ (if (> (length Info-history)
+ (length Info-isearch-initial-history))
+ (setq Info-history
+ (nthcdr (- (length Info-history)
+ (length Info-isearch-initial-history)
+ 1)
+ Info-history)))
+ (if (> (length Info-history-list)
+ (length Info-isearch-initial-history-list))
+ (setq Info-history-list
+ (cons (car Info-history-list)
+ Info-isearch-initial-history-list)))
+ (remove-hook 'isearch-mode-end-hook 'Info-isearch-end t))
(defun Info-isearch-filter (beg-found found)
"Test whether the current search hit is a visible useful text.
@@ -2290,11 +2322,8 @@ new buffer."
completions default alt-default (start-point (point)) str i bol eol)
(save-excursion
;; Store end and beginning of line.
- (end-of-line)
- (setq eol (point))
- (beginning-of-line)
- (setq bol (point))
-
+ (setq eol (line-end-position)
+ bol (line-beginning-position))
(goto-char (point-min))
(while (re-search-forward "\\*note[ \n\t]+\\([^:]*\\):" nil t)
(setq str (match-string-no-properties 1))
@@ -2810,12 +2839,9 @@ parent node."
(virtual-end
(and Info-scroll-prefer-subnodes
(save-excursion
- (beginning-of-line)
- (setq current-point (point))
+ (setq current-point (line-beginning-position))
(goto-char (point-min))
- (search-forward "\n* Menu:"
- current-point
- t)))))
+ (search-forward "\n* Menu:" current-point t)))))
(if (or virtual-end
(pos-visible-in-window-p (point-min) nil t))
(Info-last-preorder)
@@ -3104,6 +3130,7 @@ Give an empty topic name to go to the Index node itself."
(add-to-list 'Info-virtual-nodes
'("\\`\\*Index.*\\*\\'"
(find-node . Info-virtual-index-find-node)
+ (slow . t)
))
(defvar Info-virtual-index-nodes nil
@@ -3193,6 +3220,7 @@ search results."
(toc-nodes . Info-apropos-toc-nodes)
(find-file . Info-apropos-find-file)
(find-node . Info-apropos-find-node)
+ (slow . t)
))
(defvar Info-apropos-file "*Apropos*"
@@ -3341,12 +3369,15 @@ Build a menu of the possible matches."
filename)
(defvar finder-known-keywords)
-(defvar finder-package-info)
(declare-function find-library-name "find-func" (library))
+(declare-function finder-unknown-keywords "finder" ())
(declare-function lm-commentary "lisp-mnt" (&optional file))
+(defvar finder-keywords-hash)
+(defvar package-alist) ; finder requires package
(defun Info-finder-find-node (filename nodename &optional no-going-back)
"Finder-specific implementation of Info-find-node-2."
+ (require 'finder)
(cond
((equal nodename "Top")
;; Display Top menu with descriptions of the keywords
@@ -3355,14 +3386,63 @@ Build a menu of the possible matches."
(insert "Finder Keywords\n")
(insert "***************\n\n")
(insert "* Menu:\n\n")
+ (dolist (assoc (append '((all . "All package info")
+ (unknown . "unknown keywords"))
+ finder-known-keywords))
+ (let ((keyword (car assoc)))
+ (insert (format "* %s %s.\n"
+ (concat (symbol-name keyword) ": "
+ "kw:" (symbol-name keyword) ".")
+ (cdr assoc))))))
+ ((equal nodename "unknown")
+ ;; Display unknown keywords
+ (insert (format "\n\^_\nFile: %s, Node: %s, Up: Top\n\n"
+ Info-finder-file nodename))
+ (insert "Finder Unknown Keywords\n")
+ (insert "***********************\n\n")
+ (insert "* Menu:\n\n")
(mapc
(lambda (assoc)
- (let ((keyword (car assoc)))
- (insert (format "* %-14s %s.\n"
- (concat (symbol-name keyword) "::")
- (cdr assoc)))))
- finder-known-keywords))
- ((string-match-p "\\.el\\'" nodename)
+ (insert (format "* %-14s %s.\n"
+ (concat (symbol-name (car assoc)) "::")
+ (cdr assoc))))
+ (finder-unknown-keywords)))
+ ((equal nodename "all")
+ ;; Display all package info.
+ (insert (format "\n\^_\nFile: %s, Node: %s, Up: Top\n\n"
+ Info-finder-file nodename))
+ (insert "Finder Package Info\n")
+ (insert "*******************\n\n")
+ (dolist (package package-alist)
+ (insert (format "%s - %s\n"
+ (format "*Note %s::" (nth 0 package))
+ (nth 1 package)))))
+ ((string-match "\\`kw:" nodename)
+ (setq nodename (substring nodename (match-end 0)))
+ ;; Display packages that match the keyword
+ ;; or the list of keywords separated by comma.
+ (insert (format "\n\^_\nFile: %s, Node: kw:%s, Up: Top\n\n"
+ Info-finder-file nodename))
+ (insert "Finder Packages\n")
+ (insert "***************\n\n")
+ (insert
+ "The following packages match the keyword `" nodename "':\n\n")
+ (insert "* Menu:\n\n")
+ (let ((keywords
+ (mapcar 'intern (if (string-match-p "," nodename)
+ (split-string nodename ",[ \t\n]*" t)
+ (list nodename))))
+ hits desc)
+ (dolist (kw keywords)
+ (push (copy-tree (gethash kw finder-keywords-hash)) hits))
+ (setq hits (delete-dups (apply 'append hits)))
+ (dolist (package hits)
+ (setq desc (cdr-safe (assq package package-alist)))
+ (when (vectorp desc)
+ (insert (format "* %-16s %s.\n"
+ (concat (symbol-name package) "::")
+ (aref desc 2)))))))
+ (t
;; Display commentary section
(insert (format "\n\^_\nFile: %s, Node: %s, Up: Top\n\n"
Info-finder-file nodename))
@@ -3383,31 +3463,28 @@ Build a menu of the possible matches."
(goto-char (point-min))
(while (re-search-forward "^;+ ?" nil t)
(replace-match "" nil nil))
- (buffer-string))))))
- (t
- ;; Display packages that match the keyword
- (insert (format "\n\^_\nFile: %s, Node: %s, Up: Top\n\n"
- Info-finder-file nodename))
- (insert "Finder Packages\n")
- (insert "***************\n\n")
- (insert
- "The following packages match the keyword `" nodename "':\n\n")
- (insert "* Menu:\n\n")
- (let ((id (intern nodename)))
- (mapc
- (lambda (x)
- (when (memq id (cadr (cdr x)))
- (insert (format "* %-16s %s.\n"
- (concat (car x) "::")
- (cadr x)))))
- finder-package-info)))))
+ (buffer-string))))))))
;;;###autoload
-(defun info-finder ()
- "Display descriptions of the keywords in the Finder virtual manual."
- (interactive)
+(defun info-finder (&optional keywords)
+ "Display descriptions of the keywords in the Finder virtual manual.
+In interactive use, a prefix argument directs this command to read
+a list of keywords separated by comma. After that, it displays a node
+with a list packages that contain all specified keywords."
+ (interactive
+ (when current-prefix-arg
+ (require 'finder)
+ (list
+ (completing-read-multiple
+ "Keywords (separated by comma): "
+ (mapcar 'symbol-name (mapcar 'car (append finder-known-keywords
+ (finder-unknown-keywords))))
+ nil t))))
(require 'finder)
- (Info-find-node Info-finder-file "Top"))
+ (if keywords
+ (Info-find-node Info-finder-file (mapconcat 'identity keywords ", "))
+ (Info-find-node Info-finder-file "Top")))
+
(defun Info-undefined ()
"Make command be undefined in Info."
@@ -3685,17 +3762,23 @@ If FORK is non-nil, it is passed to `Info-goto-node'."
(defvar info-tool-bar-map
(let ((map (make-sparse-keymap)))
(tool-bar-local-item-from-menu 'Info-history-back "left-arrow" map Info-mode-map
- :rtl "right-arrow")
+ :rtl "right-arrow"
+ :label "Back"
+ :vert-only t)
(tool-bar-local-item-from-menu 'Info-history-forward "right-arrow" map Info-mode-map
- :rtl "left-arrow")
+ :rtl "left-arrow"
+ :label "Forward"
+ :vert-only t)
(tool-bar-local-item-from-menu 'Info-prev "prev-node" map Info-mode-map
:rtl "next-node")
(tool-bar-local-item-from-menu 'Info-next "next-node" map Info-mode-map
:rtl "prev-node")
- (tool-bar-local-item-from-menu 'Info-up "up-node" map Info-mode-map)
+ (tool-bar-local-item-from-menu 'Info-up "up-node" map Info-mode-map
+ :vert-only t)
(tool-bar-local-item-from-menu 'Info-top-node "home" map Info-mode-map)
(tool-bar-local-item-from-menu 'Info-goto-node "jump-to" map Info-mode-map)
- (tool-bar-local-item-from-menu 'Info-index "index" map Info-mode-map)
+ (tool-bar-local-item-from-menu 'Info-index "index" map Info-mode-map
+ :label "Index Search")
(tool-bar-local-item-from-menu 'Info-search "search" map Info-mode-map)
(tool-bar-local-item-from-menu 'Info-exit "exit" map Info-mode-map)
map))
@@ -3795,7 +3878,7 @@ With a zero prefix arg, put the name inside a function call to `info'."
;; Autoload cookie needed by desktop.el
;;;###autoload
-(defun Info-mode ()
+(define-derived-mode Info-mode nil "Info"
"Info mode provides commands for browsing through the Info documentation tree.
Documentation in Info is divided into \"nodes\", each of which discusses
one topic and contains references to other nodes which discuss related
@@ -3857,23 +3940,17 @@ Advanced commands:
\\[clone-buffer] Select a new cloned Info buffer in another window.
\\[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>."
- (kill-all-local-variables)
- (setq major-mode 'Info-mode)
- (setq mode-name "Info")
+ :syntax-table text-mode-syntax-table
+ :abbrev-table text-mode-abbrev-table
(setq tab-width 8)
- (use-local-map Info-mode-map)
(add-hook 'activate-menubar-hook 'Info-menu-update nil t)
- (set-syntax-table text-mode-syntax-table)
- (setq local-abbrev-table text-mode-abbrev-table)
(setq case-fold-search t)
(setq buffer-read-only t)
(make-local-variable 'Info-current-file)
(make-local-variable 'Info-current-subfile)
(make-local-variable 'Info-current-node)
- (make-local-variable 'Info-tag-table-marker)
- (setq Info-tag-table-marker (make-marker))
- (make-local-variable 'Info-tag-table-buffer)
- (setq Info-tag-table-buffer nil)
+ (set (make-local-variable 'Info-tag-table-marker) (make-marker))
+ (set (make-local-variable 'Info-tag-table-buffer) nil)
(make-local-variable 'Info-history)
(make-local-variable 'Info-history-forward)
(make-local-variable 'Info-index-alternatives)
@@ -3882,12 +3959,10 @@ Advanced commands:
'(:eval (get-text-property (point-min) 'header-line))))
(set (make-local-variable 'tool-bar-map) info-tool-bar-map)
;; 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)
- (make-local-variable 'widen-automatically)
- (setq widen-automatically nil)
- (setq desktop-save-buffer 'Info-desktop-buffer-misc-data)
+ (set (make-local-variable 'line-move-ignore-invisible) t)
+ (set (make-local-variable 'desktop-save-buffer)
+ 'Info-desktop-buffer-misc-data)
+ (set (make-local-variable 'widen-automatically) nil)
(add-hook 'kill-buffer-hook 'Info-kill-buffer nil t)
(add-hook 'clone-buffer-hook 'Info-clone-buffer nil t)
(add-hook 'change-major-mode-hook 'font-lock-defontify nil t)
@@ -3906,8 +3981,7 @@ Advanced commands:
'Info-revert-buffer-function)
(Info-set-mode-line)
(set (make-local-variable 'bookmark-make-record-function)
- 'Info-bookmark-make-record)
- (run-mode-hooks 'Info-mode-hook))
+ 'Info-bookmark-make-record))
;; When an Info buffer is killed, make sure the associated tags buffer
;; is killed too.
@@ -4790,27 +4864,42 @@ BUFFER is the buffer speedbar is requesting buttons for."
(defun Info-desktop-buffer-misc-data (desktop-dirname)
"Auxiliary information to be saved in desktop file."
- (unless (Info-virtual-file-p Info-current-file)
- (list Info-current-file Info-current-node)))
+ (list Info-current-file
+ Info-current-node
+ ;; Additional data as an association list.
+ (delq nil (list
+ (and Info-history
+ (cons 'history Info-history))
+ (and (Info-virtual-fun
+ 'slow Info-current-file Info-current-node)
+ (cons 'slow t))))))
(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))))
+ (let* ((file (nth 0 desktop-buffer-misc))
+ (node (nth 1 desktop-buffer-misc))
+ (data (nth 2 desktop-buffer-misc))
+ (hist (assq 'history data))
+ (slow (assq 'slow data)))
+ ;; Don't restore nodes slow to regenerate.
+ (unless slow
+ (when (and file node)
+ (when desktop-buffer-name
+ (set-buffer (get-buffer-create desktop-buffer-name))
+ (Info-mode))
+ (Info-find-node file node)
+ (when hist
+ (setq Info-history (cdr hist)))
+ (current-buffer)))))
(add-to-list 'desktop-buffer-mode-handlers
'(Info-mode . Info-restore-desktop-buffer))
;;;; Bookmark support
-(declare-function bookmark-make-record-default "bookmark" (&optional pos-only))
+(declare-function bookmark-make-record-default
+ "bookmark" (&optional no-file no-context posn))
(declare-function bookmark-prop-get "bookmark" (bookmark prop))
(declare-function bookmark-default-handler "bookmark" (bmk))
(declare-function bookmark-get-bookmark-record "bookmark" (bmk))
@@ -4819,7 +4908,7 @@ BUFFER is the buffer speedbar is requesting buttons for."
"This implements the `bookmark-make-record-function' type (which see)
for Info nodes."
`(,Info-current-node
- ,@(bookmark-make-record-default 'point-only)
+ ,@(bookmark-make-record-default 'no-file)
(filename . ,Info-current-file)
(info-node . ,Info-current-node)
(handler . Info-bookmark-jump)))
@@ -4839,5 +4928,4 @@ type returned by `Info-bookmark-make-record', which see."
(provide 'info)
-;; arch-tag: f2480fe2-2139-40c1-a49b-6314991164ac
;;; info.el ends here
diff --git a/lisp/international/characters.el b/lisp/international/characters.el
index e33f1449357..db5fe7e86ba 100644
--- a/lisp/international/characters.el
+++ b/lisp/international/characters.el
@@ -1234,6 +1234,170 @@ Setup char-width-table appropriate for non-CJK language environment."
(optimize-char-table (standard-category-table))
+;; Display of glyphless characters.
+
+(defvar char-acronym-table
+ (make-char-table 'char-acronym-table nil)
+ "Char table of acronyms for non-graphic characters.")
+
+(let ((c0-acronyms '("NUL" "SOH" "STX" "ETX" "EOT" "ENQ" "ACK" "BEL"
+ "BS" nil nil "VT" "FF" "CR" "SO" "SI"
+ "DLE" "DC1" "DC2" "DC3" "DC4" "NAK" "SYN" "ETB"
+ "CAN" "EM" "SUB" "ESC" "FC" "GS" "RS" "US")))
+ (dotimes (i 32)
+ (aset char-acronym-table i (car c0-acronyms))
+ (setq c0-acronyms (cdr c0-acronyms))))
+
+(let ((c1-acronyms '("XXX" "XXX" "BPH" "NBH" "IND" "NEL" "SSA" "ESA"
+ "HTS" "HTJ" "VTS" "PLD" "PLU" "R1" "SS2" "SS1"
+ "DCS" "PU1" "PU2" "STS" "CCH" "MW" "SPA" "EPA"
+ "SOS" "XXX" "SC1" "CSI" "ST" "OSC" "PM" "APC")))
+ (dotimes (i 32)
+ (aset char-acronym-table (+ #x0080 i) (car c1-acronyms))
+ (setq c1-acronyms (cdr c1-acronyms))))
+
+(aset char-acronym-table #x17B4 "KIVAQ") ; KHMER VOWEL INHERENT AQ
+(aset char-acronym-table #x17B5 "KIVAA") ; KHMER VOWEL INHERENT AA
+(aset char-acronym-table #x200B "ZWSP") ; ZERO WIDTH SPACE
+(aset char-acronym-table #x200C "ZWNJ") ; ZERO WIDTH NON-JOINER
+(aset char-acronym-table #x200D "ZWJ") ; ZERO WIDTH JOINER
+(aset char-acronym-table #x200E "LRM") ; LEFT-TO-RIGHT MARK
+(aset char-acronym-table #x200F "RLM") ; RIGHT-TO-LEFT MARK
+(aset char-acronym-table #x202A "LRE") ; LEFT-TO-RIGHT EMBEDDING
+(aset char-acronym-table #x202B "RLE") ; RIGHT-TO-LEFT EMBEDDING
+(aset char-acronym-table #x202C "PDF") ; POP DIRECTIONAL FORMATTING
+(aset char-acronym-table #x202D "LRO") ; LEFT-TO-RIGHT OVERRIDE
+(aset char-acronym-table #x202E "RLO") ; RIGHT-TO-LEFT OVERRIDE
+(aset char-acronym-table #x2060 "WJ") ; WORD JOINER
+(aset char-acronym-table #x206A "ISS") ; INHIBIT SYMMETRIC SWAPPING
+(aset char-acronym-table #x206B "ASS") ; ACTIVATE SYMMETRIC SWAPPING
+(aset char-acronym-table #x206C "IAFS") ; INHIBIT ARABIC FORM SHAPING
+(aset char-acronym-table #x206D "AAFS") ; ACTIVATE ARABIC FORM SHAPING
+(aset char-acronym-table #x206E "NADS") ; NATIONAL DIGIT SHAPES
+(aset char-acronym-table #x206F "NODS") ; NOMINAL DIGIT SHAPES
+(aset char-acronym-table #xFEFF "ZWNBSP") ; ZERO WIDTH NO-BREAK SPACE
+(aset char-acronym-table #xFFF9 "IAA") ; INTERLINEAR ANNOTATION ANCHOR
+(aset char-acronym-table #xFFFA "IAS") ; INTERLINEAR ANNOTATION SEPARATOR
+(aset char-acronym-table #xFFFB "IAT") ; INTERLINEAR ANNOTATION TERMINATOR
+(aset char-acronym-table #x1D173 "BEGBM") ; MUSICAL SYMBOL BEGIN BEAM
+(aset char-acronym-table #x1D174 "ENDBM") ; MUSICAL SYMBOL END BEAM
+(aset char-acronym-table #x1D175 "BEGTIE") ; MUSICAL SYMBOL BEGIN TIE
+(aset char-acronym-table #x1D176 "END") ; MUSICAL SYMBOL END TIE
+(aset char-acronym-table #x1D177 "BEGSLR") ; MUSICAL SYMBOL BEGIN SLUR
+(aset char-acronym-table #x1D178 "ENDSLR") ; MUSICAL SYMBOL END SLUR
+(aset char-acronym-table #x1D179 "BEGPHR") ; MUSICAL SYMBOL BEGIN PHRASE
+(aset char-acronym-table #x1D17A "ENDPHR") ; MUSICAL SYMBOL END PHRASE
+(aset char-acronym-table #xE0001 "|->TAG") ; LANGUAGE TAG
+(aset char-acronym-table #xE0020 "SP TAG") ; TAG SPACE
+(dotimes (i 94)
+ (aset char-acronym-table (+ #xE0021 i) (format " %c TAG" (+ 33 i))))
+(aset char-acronym-table #xE007F "->|TAG") ; CANCEL TAG
+
+(defun update-glyphless-char-display (&optional variable value)
+ "Make the setting of `glyphless-char-display-control' take effect.
+This function updates the char-table `glyphless-char-display'."
+ (when value
+ (set-default variable value))
+ (dolist (elt value)
+ (let ((target (car elt))
+ (method (cdr elt)))
+ (or (memq method '(zero-width thin-space empty-box acronym hex-code))
+ (error "Invalid glyphless character display method: %s" method))
+ (cond ((eq target 'c0-control)
+ (set-char-table-range glyphless-char-display '(#x00 . #x1F)
+ method)
+ ;; Users will not expect their newlines and TABs be
+ ;; displayed as anything but themselves, so exempt those
+ ;; two characters from c0-control.
+ (set-char-table-range glyphless-char-display #x9 nil)
+ (set-char-table-range glyphless-char-display #xa nil))
+ ((eq target 'c1-control)
+ (set-char-table-range glyphless-char-display '(#x80 . #x9F)
+ method))
+ ((eq target 'format-control)
+ (map-char-table
+ #'(lambda (char category)
+ (if (eq category 'Cf)
+ (let ((this-method method)
+ from to)
+ (if (consp char)
+ (setq from (car char) to (cdr char))
+ (setq from char to char))
+ (while (<= from to)
+ (when (/= from #xAD)
+ (if (eq method 'acronym)
+ (setq this-method
+ (aref char-acronym-table from)))
+ (set-char-table-range glyphless-char-display
+ from this-method))
+ (setq from (1+ from))))))
+ unicode-category-table))
+ ((eq target 'no-font)
+ (set-char-table-extra-slot glyphless-char-display 0 method))
+ (t
+ (error "Invalid glyphless character group: %s" target))))))
+
+;;; Control of displaying glyphless characters.
+(defcustom glyphless-char-display-control
+ '((format-control . thin-space)
+ (no-font . hex-code))
+ "List of directives to control display of glyphless characters.
+
+Each element has the form (GROUP . METHOD), where GROUP is a
+symbol specifying the character group, and METHOD is a symbol
+specifying the method of displaying characters belonging to that
+group.
+
+GROUP must be one of these symbols:
+ `c0-control': U+0000..U+001F, but excluding newline and TAB.
+ `c1-control': U+0080..U+009F.
+ `format-control': Characters of Unicode General Category `Cf',
+ such as U+200C (ZWNJ), U+200E (LRM), but
+ excluding characters that have graphic images,
+ such as U+00AD (SHY).
+ `no-font': characters for which no suitable font is found.
+ For character terminals, characters that cannot
+ be encoded by `terminal-coding-system'.
+
+METHOD must be one of these symbols:
+ `zero-width': don't display.
+ `thin-space': display a thin (1-pixel width) space. On character
+ terminals, display as 1-character space.
+ `empty-box': display an empty box.
+ `acronym': display an acronym of the character in a box. The
+ acronym is taken from `char-acronym-table', which see.
+ `hex-code': display the hexadecimal character code in a box."
+
+ :type '(alist :key-type (symbol :tag "Character Group")
+ :value-type (symbol :tag "Display Method"))
+ :options '((c0-control
+ (choice (const :tag "Don't display" zero-width)
+ (const :tag "Display as thin space" thin-space)
+ (const :tag "Display as empty box" empty-box)
+ (const :tag "Display acronym" acronym)
+ (const :tag "Display hex code in a box" hex-code)))
+ (c1-control
+ (choice (const :tag "Don't display" zero-width)
+ (const :tag "Display as thin space" thin-space)
+ (const :tag "Display as empty box" empty-box)
+ (const :tag "Display acronym" acronym)
+ (const :tag "Display hex code in a box" hex-code)))
+ (format-control
+ (choice (const :tag "Don't display" zero-width)
+ (const :tag "Display as thin space" thin-space)
+ (const :tag "Display as empty box" empty-box)
+ (const :tag "Display acronym" acronym)
+ (const :tag "Display hex code in a box" hex-code)))
+ (no-font
+ (choice (const :tag "Don't display" zero-width)
+ (const :tag "Display as thin space" thin-space)
+ (const :tag "Display as empty box" empty-box)
+ (const :tag "Display acronym" acronym)
+ (const :tag "Display hex code in a box" hex-code))))
+ :set 'update-glyphless-char-display
+ :group 'display)
+
+
;;; Setting word boundary.
(setq word-combining-categories
diff --git a/lisp/international/charprop.el b/lisp/international/charprop.el
index db3ae0a5111..5c3efcc9d07 100644
--- a/lisp/international/charprop.el
+++ b/lisp/international/charprop.el
@@ -1,4 +1,4 @@
-;; Copyright (C) 1991-2009 Unicode, Inc.
+;; Copyright (C) 1991-2010 Unicode, Inc.
;; This file was generated from the Unicode data file at
;; http://www.unicode.org/Public/UNIDATA/UnicodeData.txt.
;; See lisp/international/README for the copyright and permission notice.
diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el
index 1a5823826dd..07557aacc88 100644
--- a/lisp/international/fontset.el
+++ b/lisp/international/fontset.el
@@ -433,7 +433,7 @@
(nil . "koi8-r"))
(arabic ,(font-spec :registry "iso10646-1"
- :otf '(arab nil (init medi fini liga)))
+ :otf '(arab nil (init medi fina liga)))
(nil . "MuleArabic-0")
(nil . "MuleArabic-1")
(nil . "MuleArabic-2")
diff --git a/lisp/international/iso-ascii.el b/lisp/international/iso-ascii.el
index 268f4c89900..fab96f9a682 100644
--- a/lisp/international/iso-ascii.el
+++ b/lisp/international/iso-ascii.el
@@ -1,7 +1,7 @@
;;; iso-ascii.el --- set up char tables for ISO 8859/1 on ASCII terminals
-;; Copyright (C) 1987, 1995, 1998, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1987, 1995, 1998, 2001, 2002, 2003, 2004, 2005, 2006,
+;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Howard Gayle
;; Maintainer: FSF
@@ -33,6 +33,7 @@
;;; Code:
(require 'disp-table)
+(eval-when-compile (require 'cl))
(defgroup iso-ascii nil
"Set up char tables for ISO 8859/1 on ASCII terminals."
@@ -40,7 +41,7 @@
:group 'i18n)
(defcustom iso-ascii-convenient nil
- "*Non-nil means `iso-ascii' should aim for convenience, not precision."
+ "Non-nil means `iso-ascii' should aim for convenience, not precision."
:type 'boolean
:group 'iso-ascii)
@@ -162,15 +163,11 @@
(iso-ascii-display 254 "th") ; small thorn, Icelandic
(iso-ascii-display 255 "\"y") ; small y with diaeresis or umlaut mark
-(defun iso-ascii-mode (arg)
+(define-minor-mode iso-ascii-mode
"Toggle ISO-ASCII mode."
- (interactive "P")
- (unless arg
- (setq arg (eq standard-display-table iso-ascii-standard-display-table)))
- (setq standard-display-table
- (if arg
- iso-ascii-display-table
- iso-ascii-standard-display-table)))
+ :variable (eq standard-display-table iso-ascii-display-table)
+ (unless standard-display-table
+ (setq standard-display-table iso-ascii-standard-display-table)))
(provide 'iso-ascii)
diff --git a/lisp/international/kkc.el b/lisp/international/kkc.el
index 9652fe89dbe..976b0a6d167 100644
--- a/lisp/international/kkc.el
+++ b/lisp/international/kkc.el
@@ -1,7 +1,7 @@
;;; kkc.el --- Kana Kanji converter -*- coding: iso-2022-7bit; -*-
-;; Copyright (C) 1997, 1998, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 1998, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010
;; National Institute of Advanced Industrial Science and Technology (AIST)
@@ -135,7 +135,7 @@ This string is shown at mode line when users are in KKC mode.")
(defvar kkc-current-conversions-width nil)
(defcustom kkc-show-conversion-list-count 4
- "*Count of successive `kkc-next' or `kkc-prev' to show conversion list.
+ "Count of successive `kkc-next' or `kkc-prev' to show conversion list.
When you type SPC or C-p successively this count while using the input
method `japanese', the conversion candidates are shown in the echo
area while indicating the current selection by `<N>'."
diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el
index 049a3fcc1cb..4701e7e5718 100644
--- a/lisp/international/mule-cmds.el
+++ b/lisp/international/mule-cmds.el
@@ -140,7 +140,7 @@
(define-key-after map [describe-language-environment]
`(menu-item ,(purecopy "Describe Language Environment")
- describe-language-environment-map
+ ,describe-language-environment-map
:help ,(purecopy "Show multilingual settings for a specific language")))
(define-key-after map [describe-input-method]
`(menu-item ,(purecopy "Describe Input Method...") describe-input-method
@@ -286,9 +286,8 @@ wrong, use this command again to toggle back to the right mode."
"Display the HELLO file, which lists many languages and characters."
(interactive)
;; We have to decode the file in any environment.
- (letf (((default-value 'enable-multibyte-characters) t)
- (coding-system-for-read 'iso-2022-7bit))
- (view-file (expand-file-name "HELLO" data-directory))))
+ (letf ((coding-system-for-read 'iso-2022-7bit))
+ (view-file (expand-file-name "HELLO" data-directory))))
(defun universal-coding-system-argument (coding-system)
"Execute an I/O command using the specified coding system."
@@ -2036,7 +2035,7 @@ See `set-language-info-alist' for use in programs."
(defun princ-list (&rest args)
"Print all arguments with `princ', then print \"\\n\"."
- (while args (princ (car args)) (setq args (cdr args)))
+ (mapc #'princ args)
(princ "\n"))
(make-obsolete 'princ-list "use mapc and princ instead" "23.3")
@@ -2181,7 +2180,7 @@ See `set-language-info-alist' for use in programs."
("af" . "Latin-1") ; Afrikaans
("am" "Ethiopic" utf-8) ; Amharic
("an" . "Latin-9") ; Aragonese
- ; ar Arabic glibc uses 8859-6
+ ("ar" . "Arabic")
; as Assamese
; ay Aymara
("az" . "UTF-8") ; Azerbaijani
@@ -2884,8 +2883,10 @@ on encoding."
:group 'mule
:global t)
-(defvar nonascii-insert-offset 0 "This variable is obsolete.")
-(defvar nonascii-translation-table nil "This variable is obsolete.")
+(defvar nonascii-insert-offset 0)
+(make-obsolete-variable 'nonascii-insert-offset "do not use it." "23.1")
+(defvar nonascii-translation-table nil)
+(make-obsolete-variable 'nonascii-translation-table "do not use it." "23.1")
(defvar ucs-names nil
"Alist of cached (CHAR-NAME . CHAR-CODE) pairs.")
@@ -2895,15 +2896,19 @@ on encoding."
(or ucs-names
(let ((bmp-ranges
'((#x0000 . #x33FF)
- ;; (#x3400 . #x4DBF) CJK Ideograph Extension A
+ ;; (#x3400 . #x4DBF) CJK Ideographs Extension A
(#x4DC0 . #x4DFF)
- ;; (#x4E00 . #x9FFF) CJK Ideograph
- (#xA000 . #x0D7FF)
+ ;; (#x4E00 . #x9FFF) CJK Unified Ideographs
+ (#xA000 . #xD7FF)
;; (#xD800 . #xFAFF) Surrogate/Private
(#xFB00 . #xFFFD)))
(upper-ranges
'((#x10000 . #x134FF)
- ;; (#x13500 . #x1CFFF) unused
+ ;; (#x13500 . #x167FF) unused
+ (#x16800 . #x16A3F)
+ ;; (#x16A40 . #x1AFFF) unused
+ (#x1B000 . #x1B0FF)
+ ;; (#x1B100 . #x1CFFF) unused
(#x1D000 . #x1FFFF)
;; (#x20000 . #xDFFFF) CJK Ideograph Extension A, B, etc, unused
(#xE0000 . #xE01FF)))
diff --git a/lisp/international/mule.el b/lisp/international/mule.el
index 6e1be8b4465..df362d96c07 100644
--- a/lisp/international/mule.el
+++ b/lisp/international/mule.el
@@ -326,8 +326,7 @@ Return t if file exists."
(with-current-buffer buffer
;; So that we don't get completely screwed if the
;; file is encoded in some complicated character set,
- ;; read it with real decoding, as a multibyte buffer,
- ;; even if this is a --unibyte Emacs session.
+ ;; read it with real decoding, as a multibyte buffer.
(set-buffer-multibyte t)
;; Don't let deactivate-mark remain set.
(let (deactivate-mark)
@@ -346,12 +345,7 @@ Return t if file exists."
(eval-buffer buffer nil
;; This is compatible with what `load' does.
(if purify-flag file fullname)
- ;; If this Emacs is running with --unibyte,
- ;; convert multibyte strings to unibyte
- ;; after reading them.
-;; (not (default-value 'enable-multibyte-characters))
- nil t
- ))
+ nil t))
(let (kill-buffer-hook kill-buffer-query-functions)
(kill-buffer buffer)))
(do-after-load-evaluation fullname)
@@ -609,9 +603,8 @@ VALUE must be one of `charset', `utf-8', `utf-16', `iso-2022',
VALUE is the EOL (end-of-line) format of the coding system. It must be
one of `unix', `dos', `mac'. The symbol `unix' means Unix-like EOL
\(i.e. single LF), `dos' means DOS-like EOL \(i.e. sequence of CR LF),
-and `mac' means Mac-like EOL \(i.e. single CR). If omitted, on
-decoding by the coding system, Emacs automatically detects the EOL
-format of the source text.
+and `mac' means Mac-like EOL \(i.e. single CR). If omitted, Emacs
+detects the EOL format automatically when decoding.
`:charset-list'
@@ -666,13 +659,6 @@ the coding system is replaced with VALUE.
VALUE non-nil means that visiting a file with the coding system
results in a unibyte buffer.
-`:eol-type'
-
-VALUE must be `unix', `dos', `mac'. The symbol `unix' means Unix-like
-EOL (LF), `dos' means DOS-like EOL (CRLF), and `mac' means Mac-like
-EOL (CR). If omitted, on decoding, the coding system detects EOL
-format automatically, and on encoding, uses Unix-like EOL.
-
`:mime-charset'
VALUE must be a symbol whose name is that of a MIME charset converted
@@ -1167,6 +1153,64 @@ Internal use only.")
(make-variable-buffer-local 'buffer-file-coding-system-explicit)
(put 'buffer-file-coding-system-explicit 'permanent-local t)
+(defun read-buffer-file-coding-system ()
+ (let* ((bcss (find-coding-systems-region (point-min) (point-max)))
+ (css-table
+ (unless (equal bcss '(undecided))
+ (append '("dos" "unix" "mac")
+ (delq nil (mapcar (lambda (cs)
+ (if (memq (coding-system-base cs) bcss)
+ (symbol-name cs)))
+ coding-system-list)))))
+ (combined-table
+ (if css-table
+ (completion-table-in-turn css-table coding-system-alist)
+ coding-system-alist))
+ (auto-cs
+ (unless find-file-literally
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (funcall set-auto-coding-function
+ (or buffer-file-name "") (buffer-size))))))
+ (preferred
+ (let ((bfcs (default-value 'buffer-file-coding-system)))
+ (cons (and (or (equal bcss '(undecided))
+ (memq (coding-system-base bfcs) bcss))
+ bfcs)
+ (mapcar (lambda (cs)
+ (and (coding-system-p cs)
+ (coding-system-get cs :mime-charset)
+ (or (equal bcss '(undecided))
+ (memq (coding-system-base cs) bcss))
+ cs))
+ (coding-system-priority-list)))))
+ (default
+ (let ((current (coding-system-base buffer-file-coding-system)))
+ ;; Generally use as a default the first preferred coding-system
+ ;; different from the current coding-system, except for
+ ;; the case of auto-cs since choosing anything else is asking
+ ;; for trouble (would lead to using a different coding
+ ;; system than specified in the coding tag).
+ (or auto-cs
+ (car (delq nil
+ (mapcar (lambda (cs)
+ (if (eq current (coding-system-base cs))
+ nil
+ cs))
+ preferred))))))
+ (completion-ignore-case t)
+ (completion-pcm--delim-wild-regex ; Let "u8" complete to "utf-8".
+ (concat completion-pcm--delim-wild-regex
+ "\\|\\([[:alpha:]]\\)[[:digit:]]"))
+ (cs (completing-read
+ (format "Coding system for saving file (default %s): " default)
+ combined-table
+ nil t nil 'coding-system-history
+ (if default (symbol-name default)))))
+ (unless (zerop (length cs)) (intern cs))))
+
(defun set-buffer-file-coding-system (coding-system &optional force nomodify)
"Set the file coding-system of the current buffer to CODING-SYSTEM.
This means that when you save the buffer, it will be converted
@@ -1184,19 +1228,26 @@ surely saves the buffer with CODING-SYSTEM. From a program, if you
don't want to mark the buffer modified, specify t for NOMODIFY.
If you know exactly what coding system you want to use,
just set the variable `buffer-file-coding-system' directly."
- (interactive "zCoding system for saving file (default nil): \nP")
+ (interactive
+ (list (read-buffer-file-coding-system)
+ current-prefix-arg))
(check-coding-system coding-system)
(if (and coding-system buffer-file-coding-system (null force))
(setq coding-system
(merge-coding-systems coding-system buffer-file-coding-system)))
+ (when (called-interactively-p 'interactive)
+ ;; Check whether save would succeed, and jump to the offending char(s)
+ ;; if not.
+ (let ((css (find-coding-systems-region (point-min) (point-max))))
+ (unless (or (eq (car css) 'undecided)
+ (memq (coding-system-base coding-system) css))
+ (setq coding-system (select-safe-coding-system-interactively
+ (point-min) (point-max) css
+ (list coding-system))))))
(setq buffer-file-coding-system coding-system)
(if buffer-file-coding-system-explicit
(setcdr buffer-file-coding-system-explicit coding-system)
(setq buffer-file-coding-system-explicit (cons nil coding-system)))
- ;; This is in case of an explicit call. Normally, `normal-mode' and
- ;; `set-buffer-major-mode-hook' take care of setting the table.
- (if (fboundp 'ucs-set-table-for-input) ; don't lose when building
- (ucs-set-table-for-input))
(unless nomodify
(set-buffer-modified-p t))
(force-mode-line-update))
@@ -1624,12 +1675,12 @@ in-place."
;; self-extracting exe archives.
(mapcar (lambda (arg) (cons (purecopy (car arg)) (cdr arg)))
'(("\\.\\(\
-arc\\|zip\\|lzh\\|lha\\|zoo\\|[jew]ar\\|xpi\\|rar\\|\
-ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|RAR\\)\\'"
+arc\\|zip\\|lzh\\|lha\\|zoo\\|[jew]ar\\|xpi\\|rar\\|7z\\|\
+ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|RAR\\|7Z\\)\\'"
. no-conversion-multibyte)
("\\.\\(exe\\|EXE\\)\\'" . no-conversion)
("\\.\\(sx[dmicw]\\|odt\\|tar\\|tgz\\)\\'" . no-conversion)
- ("\\.\\(gz\\|Z\\|bz\\|bz2\\|gpg\\)\\'" . no-conversion)
+ ("\\.\\(gz\\|Z\\|bz\\|bz2\\|xz\\|gpg\\)\\'" . no-conversion)
("\\.\\(jpe?g\\|png\\|gif\\|tiff?\\|p[bpgn]m\\)\\'" . no-conversion)
("\\.pdf\\'" . no-conversion)
("/#[^/]+#\\'" . emacs-mule)))
@@ -1640,6 +1691,7 @@ A file whose name matches REGEXP is decoded by CODING-SYSTEM on reading.
The settings in this alist take priority over `coding:' tags
in the file (see the function `set-auto-coding')
and the contents of `file-coding-system-alist'."
+ :version "24.1" ; added xz
:group 'files
:group 'mule
:type '(repeat (cons (regexp :tag "File name regexp")
@@ -2128,8 +2180,7 @@ character, say TO-ALT, FROM is also translated to TO-ALT."
(defun make-translation-table-from-vector (vec)
"Make translation table from decoding vector VEC.
VEC is an array of 256 elements to map unibyte codes to multibyte
-characters. Elements may be nil for undefined code points.
-See also the variable `nonascii-translation-table'."
+characters. Elements may be nil for undefined code points."
(let ((table (make-char-table 'translation-table))
(rev-table (make-char-table 'translation-table))
ch)
@@ -2248,13 +2299,12 @@ It returns the number of characters changed."
(setq table val)))
(translate-region-internal start end table))
-(put 'with-category-table 'lisp-indent-function 1)
-
(defmacro with-category-table (table &rest body)
"Execute BODY like `progn' with TABLE the current category table.
The category table of the current buffer is saved, BODY is evaluated,
then the saved table is restored, even in case of an abnormal exit.
Value is what BODY returns."
+ (declare (indent 1) (debug t))
(let ((old-table (make-symbol "old-table"))
(old-buffer (make-symbol "old-buffer")))
`(let ((,old-table (category-table))
diff --git a/lisp/international/ogonek.el b/lisp/international/ogonek.el
index eefefff2cf5..750d47629e3 100644
--- a/lisp/international/ogonek.el
+++ b/lisp/international/ogonek.el
@@ -273,23 +273,23 @@ The functions come in the following groups.
ogonek-name-encoding-alist))
"List of ogonek encodings. Used only for customization.")
(defcustom ogonek-from-encoding "iso8859-2"
- "*Encoding in the source file of recoding."
+ "Encoding in the source file of recoding."
:type ogonek-encoding-choices
:group 'ogonek)
(defcustom ogonek-to-encoding "ascii"
- "*Encoding in the target file of recoding."
+ "Encoding in the target file of recoding."
:type ogonek-encoding-choices
:group 'ogonek)
(defcustom ogonek-prefix-char ?/
- "*Prefix character for prefix encodings."
+ "Prefix character for prefix encodings."
:type 'character
:group 'ogonek)
(defcustom ogonek-prefix-from-encoding "iso8859-2"
- "*Encoding in the source file subject to prefixifation."
+ "Encoding in the source file subject to prefixifation."
:type ogonek-encoding-choices
:group 'ogonek)
(defcustom ogonek-prefix-to-encoding "iso8859-2"
- "*Encoding in the target file subject to deprefixifation."
+ "Encoding in the target file subject to deprefixifation."
:type ogonek-encoding-choices
:group 'ogonek)
diff --git a/lisp/international/quail.el b/lisp/international/quail.el
index 9959b275943..621f314bf70 100644
--- a/lisp/international/quail.el
+++ b/lisp/international/quail.el
@@ -811,7 +811,7 @@ The format of KBD-LAYOUT is the same as `quail-keyboard-layout'."
(setq translation (aref (cdr translation) 0))
(setq translation " ")))
(setq done-list (cons translation done-list)))
- (setq translation ch))
+ (setq translation (aref kbd-layout i)))
(aset layout i translation))
(setq i (1+ i)))
diff --git a/lisp/international/ucs-normalize.el b/lisp/international/ucs-normalize.el
index 5061e500587..59850621388 100644
--- a/lisp/international/ucs-normalize.el
+++ b/lisp/international/ucs-normalize.el
@@ -100,7 +100,7 @@
;; D. Sorting and Composition of Smaller Blocks (`ucs-normalize-block-compose-chars')
;;
;; The block will be split to multiple samller blocks by starter
-;; charcters. Each block is sorted, and composed if necessary.
+;; characters. Each block is sorted, and composed if necessary.
;;
;; E. Composition of Entire Block (`ucs-normalize-compose-chars')
;;
diff --git a/lisp/international/uni-bidi.el b/lisp/international/uni-bidi.el
index 1afd451994c..9e571ef9d0d 100644
--- a/lisp/international/uni-bidi.el
+++ b/lisp/international/uni-bidi.el
Binary files differ
diff --git a/lisp/international/uni-category.el b/lisp/international/uni-category.el
index a410af13852..80538f7b416 100644
--- a/lisp/international/uni-category.el
+++ b/lisp/international/uni-category.el
Binary files differ
diff --git a/lisp/international/uni-combining.el b/lisp/international/uni-combining.el
index ff26fa9519d..2ee74d8b818 100644
--- a/lisp/international/uni-combining.el
+++ b/lisp/international/uni-combining.el
Binary files differ
diff --git a/lisp/international/uni-comment.el b/lisp/international/uni-comment.el
index be62ed3ff69..dcc717977c7 100644
--- a/lisp/international/uni-comment.el
+++ b/lisp/international/uni-comment.el
Binary files differ
diff --git a/lisp/international/uni-decimal.el b/lisp/international/uni-decimal.el
index 410390dc9c2..22207a224b0 100644
--- a/lisp/international/uni-decimal.el
+++ b/lisp/international/uni-decimal.el
Binary files differ
diff --git a/lisp/international/uni-decomposition.el b/lisp/international/uni-decomposition.el
index 76e05f2ccec..f35bcebfed8 100644
--- a/lisp/international/uni-decomposition.el
+++ b/lisp/international/uni-decomposition.el
Binary files differ
diff --git a/lisp/international/uni-digit.el b/lisp/international/uni-digit.el
index 023ddcb71b0..692dea1edc8 100644
--- a/lisp/international/uni-digit.el
+++ b/lisp/international/uni-digit.el
Binary files differ
diff --git a/lisp/international/uni-lowercase.el b/lisp/international/uni-lowercase.el
index 6574cc7a9c4..7cc601159f0 100644
--- a/lisp/international/uni-lowercase.el
+++ b/lisp/international/uni-lowercase.el
Binary files differ
diff --git a/lisp/international/uni-mirrored.el b/lisp/international/uni-mirrored.el
index dfdccfd2560..5129a93396d 100644
--- a/lisp/international/uni-mirrored.el
+++ b/lisp/international/uni-mirrored.el
Binary files differ
diff --git a/lisp/international/uni-name.el b/lisp/international/uni-name.el
index 7ee5e104a0a..5b9e8323d21 100644
--- a/lisp/international/uni-name.el
+++ b/lisp/international/uni-name.el
Binary files differ
diff --git a/lisp/international/uni-numeric.el b/lisp/international/uni-numeric.el
index 9ef409e509b..278ad683fe4 100644
--- a/lisp/international/uni-numeric.el
+++ b/lisp/international/uni-numeric.el
Binary files differ
diff --git a/lisp/international/uni-old-name.el b/lisp/international/uni-old-name.el
index a6e1f643458..2e283492408 100644
--- a/lisp/international/uni-old-name.el
+++ b/lisp/international/uni-old-name.el
Binary files differ
diff --git a/lisp/international/uni-titlecase.el b/lisp/international/uni-titlecase.el
index ed8121e2daf..729a469d103 100644
--- a/lisp/international/uni-titlecase.el
+++ b/lisp/international/uni-titlecase.el
Binary files differ
diff --git a/lisp/international/uni-uppercase.el b/lisp/international/uni-uppercase.el
index 1652caf4359..0714b14794f 100644
--- a/lisp/international/uni-uppercase.el
+++ b/lisp/international/uni-uppercase.el
Binary files differ
diff --git a/lisp/international/utf-7.el b/lisp/international/utf-7.el
index 831ccd391cf..c2cd6346745 100644
--- a/lisp/international/utf-7.el
+++ b/lisp/international/utf-7.el
@@ -62,7 +62,7 @@ IMAP non-nil means use the IMAP version."
(decode-coding-region p (point) 'utf-16be)
(save-excursion
(goto-char p)
- (delete-backward-char 1)))))))
+ (delete-char -1)))))))
(- (point-max) (point-min)))))
;;;###autoload
diff --git a/lisp/isearch.el b/lisp/isearch.el
index 3b04fa270b0..ebe2e8fa009 100644
--- a/lisp/isearch.el
+++ b/lisp/isearch.el
@@ -7,6 +7,7 @@
;; Author: Daniel LaLiberte <liberte@cs.uiuc.edu>
;; Maintainer: FSF
;; Keywords: matching
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -156,6 +157,9 @@ command history."
(defvar isearch-mode-hook nil
"Function(s) to call after starting up an incremental search.")
+(defvar isearch-update-post-hook nil
+ "Function(s) to call after isearch has found matches in the buffer.")
+
(defvar isearch-mode-end-hook nil
"Function(s) to call after terminating an incremental search.
When these functions are called, `isearch-mode-end-hook-quit'
@@ -235,7 +239,7 @@ Default value, nil, means edit the string instead."
"Face for highlighting Isearch matches."
:group 'isearch
:group 'basic-faces)
-(defvar isearch 'isearch)
+(defvar isearch-face 'isearch)
(defface isearch-fail
'((((class color) (min-colors 88) (background light))
@@ -464,7 +468,9 @@ This is like `describe-bindings', but displays only Isearch keys."
(define-key map "\M-\C-y" 'isearch-yank-char)
(define-key map "\C-y" 'isearch-yank-line)
- (define-key map "\C-h" isearch-help-map)
+ (define-key map (char-to-string help-char) isearch-help-map)
+ (define-key map [help] isearch-help-map)
+ (define-key map [f1] isearch-help-map)
(define-key map "\M-n" 'isearch-ring-advance)
(define-key map "\M-p" 'isearch-ring-retreat)
@@ -872,7 +878,8 @@ It is called by the function `isearch-forward' and other related functions."
(isearch-lazy-highlight-new-loop))
;; We must prevent the point moving to the end of composition when a
;; part of the composition has just been searched.
- (setq disable-point-adjustment t))
+ (setq disable-point-adjustment t)
+ (run-hooks 'isearch-update-post-hook))
(defun isearch-done (&optional nopush edit)
"Exit Isearch mode.
@@ -1480,14 +1487,10 @@ If search string is empty, just beep."
(eq 'not-yanks search-upper-case))
(setq string (downcase string)))
(if isearch-regexp (setq string (regexp-quote string)))
- (setq isearch-string (concat isearch-string string)
- isearch-message
- (concat isearch-message
- (mapconcat 'isearch-text-char-description
- string ""))
- ;; Don't move cursor in reverse search.
- isearch-yank-flag t)
- (isearch-search-and-update))
+ ;; Don't move cursor in reverse search.
+ (setq isearch-yank-flag t)
+ (isearch-process-search-string
+ string (mapconcat 'isearch-text-char-description string "")))
(defun isearch-yank-kill ()
"Pull string from kill ring into search string."
@@ -1542,14 +1545,18 @@ or it might return the position of the end of the line."
(interactive "p")
(isearch-yank-internal (lambda () (forward-char arg) (point))))
+(declare-function subword-forward "subword" (&optional arg))
(defun isearch-yank-word-or-char ()
- "Pull next character or word from buffer into search string."
+ "Pull next character, subword or word from buffer into search string.
+Subword is used when `subword-mode' is activated. "
(interactive)
(isearch-yank-internal
(lambda ()
(if (or (= (char-syntax (or (char-after) 0)) ?w)
(= (char-syntax (or (char-after (1+ (point))) 0)) ?w))
- (forward-word 1)
+ (if (and (boundp 'subword-mode) subword-mode)
+ (subword-forward 1)
+ (forward-word 1))
(forward-char 1)) (point))))
(defun isearch-yank-word ()
@@ -1712,9 +1719,10 @@ Scroll-bar or mode-line events are processed appropriately."
;; attempts this, we scroll the text back again.
;;
;; We implement this feature with a property called `isearch-scroll'.
-;; If a command's symbol has the value t for this property it is a
-;; scrolling command. The feature needs to be enabled by setting the
-;; customizable variable `isearch-allow-scroll' to a non-nil value.
+;; If a command's symbol has the value t for this property or for the
+;; `scroll-command' property, it is a scrolling command. The feature
+;; needs to be enabled by setting the customizable variable
+;; `isearch-allow-scroll' to a non-nil value.
;;
;; The universal argument commands (e.g. C-u) in simple.el are marked
;; as scrolling commands, and isearch.el has been amended to allow
@@ -1731,12 +1739,11 @@ Scroll-bar or mode-line events are processed appropriately."
(if (fboundp 'w32-handle-scroll-bar-event)
(put 'w32-handle-scroll-bar-event 'isearch-scroll t))
-;; Commands which scroll the window:
+;; Commands which scroll the window (some scroll commands
+;; already have the `scroll-command' property on them):
(put 'recenter 'isearch-scroll t)
(put 'recenter-top-bottom 'isearch-scroll t)
(put 'reposition-window 'isearch-scroll t)
-(put 'scroll-up 'isearch-scroll t)
-(put 'scroll-down 'isearch-scroll t)
;; Commands which act on the other window
(put 'list-buffers 'isearch-scroll t)
@@ -1761,7 +1768,7 @@ Scroll-bar or mode-line events are processed appropriately."
"Whether scrolling is allowed during incremental search.
If non-nil, scrolling commands can be used in Isearch mode.
However, the current match will never scroll offscreen.
-If nil, scolling commands will first cancel Isearch mode."
+If nil, scrolling commands will first cancel Isearch mode."
:type 'boolean
:group 'isearch)
@@ -1825,7 +1832,8 @@ Otherwise return nil."
(let* ((overriding-terminal-local-map nil)
(binding (key-binding key-seq)))
(and binding (symbolp binding) (commandp binding)
- (eq (get binding 'isearch-scroll) t)
+ (or (eq (get binding 'isearch-scroll) t)
+ (eq (get binding 'scroll-command) t))
binding)))
(defalias 'isearch-other-control-char 'isearch-other-meta-char)
@@ -1986,12 +1994,6 @@ Isearch mode."
(setq char (unibyte-char-to-multibyte char)))
(isearch-process-search-char char))))
-(defun isearch-return-char ()
- "Convert return into newline for incremental search."
- (interactive)
- (isearch-process-search-char ?\n))
-(make-obsolete 'isearch-return-char 'isearch-printing-char "19.7")
-
(defun isearch-printing-char ()
"Add this ordinary printing character to the search string and search."
(interactive)
@@ -2533,7 +2535,7 @@ since they have special meaning in a regexp."
(setq isearch-overlay (make-overlay beg end))
;; 1001 is higher than lazy's 1000 and ediff's 100+
(overlay-put isearch-overlay 'priority 1001)
- (overlay-put isearch-overlay 'face isearch))))
+ (overlay-put isearch-overlay 'face isearch-face))))
(defun isearch-dehighlight ()
(when isearch-overlay
@@ -2669,6 +2671,8 @@ Attempt to do the search exactly the way the pending Isearch would."
;; Clear RETRY unless the search predicate says
;; to skip this search hit.
(if (or (not success)
+ (= (point) bound) ; like (bobp) (eobp) in `isearch-search'.
+ (= (match-beginning 0) (match-end 0))
(funcall isearch-filter-predicate
(match-beginning 0) (match-end 0)))
(setq retry nil)))
diff --git a/lisp/iswitchb.el b/lisp/iswitchb.el
index 081897a89b3..48f0edb49e0 100644
--- a/lisp/iswitchb.el
+++ b/lisp/iswitchb.el
@@ -1,7 +1,7 @@
;;; iswitchb.el --- switch between buffers using substrings
-;; Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Stephen Eglen <stephen@gnu.org>
;; Maintainer: Stephen Eglen <stephen@gnu.org>
@@ -1033,7 +1033,9 @@ Return the modified list with the last element prepended to it."
(setq buf (car iswitchb-matches))
;; check to see if buf is non-nil.
(if buf
- (progn
+ (let ((bufobjs (mapcar (lambda (name)
+ (or (get-buffer name) name))
+ iswitchb-buflist)))
(kill-buffer buf)
;; Check if buffer exists. XEmacs gnuserv.el makes alias
@@ -1044,8 +1046,13 @@ Return the modified list with the last element prepended to it."
(setq iswitchb-rescan t)
;; Else `kill-buffer' succeeds so re-make the buffer list
;; taking into account packages like uniquify may rename
- ;; buffers
- (iswitchb-make-buflist iswitchb-default))))))
+ ;; buffers, and try to preserve the ordering of buffers.
+ (setq iswitchb-buflist
+ (delq nil (mapcar (lambda (b)
+ (if (bufferp b)
+ (buffer-name b)
+ b))
+ bufobjs))))))))
;;; VISIT CHOSEN BUFFER
(defun iswitchb-visit-buffer (buffer)
@@ -1119,19 +1126,6 @@ If BUFFER is visible in the current frame, return nil."
(get-buffer-window buffer 0) ; better than 'visible
)))
-(defun iswitchb-default-keybindings ()
- "Set up default keybindings for `iswitchb-buffer'.
-Call this function to override the normal bindings. This function also
-adds a hook to the minibuffer."
- (interactive)
- (add-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup)
- (global-set-key "\C-xb" 'iswitchb-buffer)
- (global-set-key "\C-x4b" 'iswitchb-buffer-other-window)
- (global-set-key "\C-x4\C-o" 'iswitchb-display-buffer)
- (global-set-key "\C-x5b" 'iswitchb-buffer-other-frame))
-
-(make-obsolete 'iswitchb-default-keybindings 'iswitchb-mode "21.1")
-
(defun iswitchb-buffer ()
"Switch to another buffer.
diff --git a/lisp/jit-lock.el b/lisp/jit-lock.el
index dbe1cbe23e1..cc250567ad8 100644
--- a/lisp/jit-lock.el
+++ b/lisp/jit-lock.el
@@ -5,6 +5,7 @@
;; Author: Gerd Moellmann <gerd@gnu.org>
;; Keywords: faces files
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -31,33 +32,13 @@
(eval-when-compile
(require 'cl)
- (defmacro with-buffer-unmodified (&rest body)
- "Eval BODY, preserving the current buffer's modified state."
- (declare (debug t))
- (let ((modified (make-symbol "modified")))
- `(let ((,modified (buffer-modified-p)))
- (unwind-protect
- (progn ,@body)
- (unless ,modified
- (restore-buffer-modified-p nil))))))
-
(defmacro with-buffer-prepared-for-jit-lock (&rest body)
"Execute BODY in current buffer, overriding several variables.
Preserves the `buffer-modified-p' state of the current buffer."
(declare (debug t))
- `(let ((buffer-undo-list t)
- (inhibit-read-only t)
- (inhibit-point-motion-hooks t)
- (inhibit-modification-hooks t)
- deactivate-mark
- buffer-file-name
- buffer-file-truename)
- ;; Do reset the modification status from within the let, since
- ;; otherwise set-buffer-modified-p may try to unlock the file.
- (with-buffer-unmodified
- ,@body))))
-
-
+ `(let ((inhibit-point-motion-hooks t))
+ (with-silent-modifications
+ ,@body))))
;;; Customization.
diff --git a/lisp/jka-cmpr-hook.el b/lisp/jka-cmpr-hook.el
index da8512d7fb9..68f564c488f 100644
--- a/lisp/jka-cmpr-hook.el
+++ b/lisp/jka-cmpr-hook.el
@@ -6,6 +6,7 @@
;; Author: jka@ece.cmu.edu (Jay K. Adams)
;; Maintainer: FSF
;; Keywords: data
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -334,6 +335,7 @@ Return the new status of auto compression (non-nil means on)."
(defmacro with-auto-compression-mode (&rest body)
"Evalute BODY with automatic file compression and uncompression enabled."
+ (declare (indent 0))
(let ((already-installed (make-symbol "already-installed")))
`(let ((,already-installed (jka-compr-installed-p)))
(unwind-protect
@@ -343,8 +345,6 @@ Return the new status of auto compression (non-nil means on)."
,@body)
(unless ,already-installed
(jka-compr-uninstall))))))
-(put 'with-auto-compression-mode 'lisp-indent-function 0)
-
;; This is what we need to know about jka-compr-handler
;; in order to decide when to call it.
diff --git a/lisp/jka-compr.el b/lisp/jka-compr.el
index 34ffcc90a76..3f0ff542212 100644
--- a/lisp/jka-compr.el
+++ b/lisp/jka-compr.el
@@ -181,7 +181,8 @@ to keep: LEN chars starting BEG chars from the beginning."
null-device))
jka-compr-acceptable-retval-list)
(jka-compr-error prog args infile message err-file))
- (jka-compr-delete-temp-file err-file)))
+ (delete-file err-file)))
+
;; Run the uncompression program directly.
;; We get the whole file and must delete what we don't want.
(jka-compr-call-process prog message infile t nil args))
@@ -222,7 +223,7 @@ to keep: LEN chars starting BEG chars from the beginning."
"")))
jka-compr-acceptable-retval-list)
(jka-compr-error prog args infile message err-file))
- (jka-compr-delete-temp-file err-file)))
+ (delete-file err-file)))
(or (eq 0
(apply 'call-process
prog infile (if (stringp output) temp output)
@@ -248,9 +249,6 @@ There should be no more than seven characters after the final `/'."
"This routine will return the name of a new file."
(make-temp-file jka-compr-temp-name-template))
-(defalias 'jka-compr-delete-temp-file 'delete-file)
-
-
(defun jka-compr-write-region (start end file &optional append visit)
(let* ((filename (expand-file-name file))
(visit-file (if (stringp visit) (expand-file-name visit) filename))
@@ -337,7 +335,7 @@ There should be no more than seven characters after the final `/'."
(and append can-append) 'dont))
(erase-buffer)) )
- (jka-compr-delete-temp-file temp-file)
+ (delete-file temp-file)
(and
compress-message
@@ -603,7 +601,7 @@ There should be no more than seven characters after the final `/'."
(setq file (file-name-sans-extension file)))
(setcar l file)))
- (jka-compr-delete-temp-file local-copy))
+ (delete-file local-copy))
t))
diff --git a/lisp/kmacro.el b/lisp/kmacro.el
index c2bedf35339..439c7383223 100644
--- a/lisp/kmacro.el
+++ b/lisp/kmacro.el
@@ -642,11 +642,13 @@ others, use \\[kmacro-name-last-macro]."
kmacro-call-repeat-key)))
(setq repeat-key-str (format-kbd-macro (vector repeat-key) nil))
(while repeat-key
- (message "(Type %s to repeat macro%s)"
- repeat-key-str
- (if (and kmacro-call-repeat-with-arg
- arg (> arg 1))
- (format " %d times" arg) ""))
+ ;; Issue a hint to the user, if the echo area isn't in use.
+ (unless (current-message)
+ (message "(Type %s to repeat macro%s)"
+ repeat-key-str
+ (if (and kmacro-call-repeat-with-arg
+ arg (> arg 1))
+ (format " %d times" arg) "")))
(if (equal repeat-key (read-event))
(progn
(clear-this-command-keys t)
diff --git a/lisp/language/ethio-util.el b/lisp/language/ethio-util.el
index 8d9b2d9f0cd..ee5073d308f 100644
--- a/lisp/language/ethio-util.el
+++ b/lisp/language/ethio-util.el
@@ -869,7 +869,7 @@ Otherwise, [0-9A-F]."
(goto-char (point-min))
(while (re-search-forward "[ሀ-፼]" nil t)
(setq ucode (preceding-char))
- (delete-backward-char 1)
+ (delete-char -1)
(insert
(format (if ethio-java-save-lowercase "\\u%4x" "\\u%4X")
ucode)))))
diff --git a/lisp/language/hebrew.el b/lisp/language/hebrew.el
index 993df98b3a6..bcc3d625d68 100644
--- a/lisp/language/hebrew.el
+++ b/lisp/language/hebrew.el
@@ -1,4 +1,4 @@
-;;; hebrew.el --- support for Hebrew -*- coding: iso-2022-7bit; no-byte-compile: t -*-
+;;; hebrew.el --- support for Hebrew -*- coding: utf-8 -*-
;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
;; Free Software Foundation, Inc.
@@ -46,28 +46,27 @@
(define-coding-system-alias 'iso-8859-8 'hebrew-iso-8bit)
;; These are for Explicit and Implicit directionality information, as
-;; defined in RFC 1556. We don't yet support directional information
-;; in bidi languages, so these aliases are a lie, especially as far as
-;; iso-8859-8-e is concerned. FIXME.
+;; defined in RFC 1556.
(define-coding-system-alias 'iso-8859-8-e 'hebrew-iso-8bit)
(define-coding-system-alias 'iso-8859-8-i 'hebrew-iso-8bit)
(set-language-info-alist
- "Hebrew" '((charset iso-8859-8)
+ "Hebrew" '((tutorial . "TUTORIAL.he")
+ (charset iso-8859-8)
(coding-priority hebrew-iso-8bit)
(coding-system hebrew-iso-8bit windows-1255 cp862)
(nonascii-translation . iso-8859-8)
(input-method . "hebrew")
(unibyte-display . hebrew-iso-8bit)
- (sample-text . "Hebrew ,Hylem(B")
- (documentation . "Right-to-left writing is not yet supported.")))
+ (sample-text . "Hebrew שלום")
+ (documentation . "Bidirectional editing is supported.")))
(set-language-info-alist
"Windows-1255" '((coding-priority windows-1255)
(coding-system windows-1255)
(documentation . "\
Support for Windows-1255 encoding, e.g. for Yiddish.
-Right-to-left writing is not yet supported.")))
+Bidirectional editing is supported.")))
(define-coding-system 'windows-1255
"windows-1255 (Hebrew) encoding (MIME: WINDOWS-1255)"
@@ -85,6 +84,179 @@ Right-to-left writing is not yet supported.")))
:mime-charset 'cp862)
(define-coding-system-alias 'ibm862 'cp862)
+;; Return a nested alist of Hebrew character sequences vs the
+;; corresponding glyph of FONT-OBJECT.
+(defun hebrew-font-get-precomposed (font-object)
+ (let ((precomposed (font-get font-object 'hebrew-precomposed))
+ ;; Vector of Hebrew precomposed characters.
+ (chars [#xFB2A #xFB2B #xFB2C #xFB2D #xFB2E #xFB2F #xFB30 #xFB31
+ #xFB32 #xFB33 #xFB34 #xFB35 #xFB36 #xFB38 #xFB39 #xFB3A
+ #xFB3B #xFB3C #xFB3E #xFB40 #xFB41 #xFB43 #xFB44 #xFB46
+ #xFB47 #xFB48 #xFB49 #xFB4A #xFB4B #xFB4C #xFB4D #xFB4E])
+ ;; Vector of decomposition character sequences corresponding
+ ;; to the above vector.
+ (decomposed
+ [[#x05E9 #x05C1]
+ [#x05E9 #x05C2]
+ [#x05E9 #x05BC #x05C1]
+ [#x05E9 #x05BC #x05C2]
+ [#x05D0 #x05B7]
+ [#x05D0 #x05B8]
+ [#x05D0 #x05BC]
+ [#x05D1 #x05BC]
+ [#x05D2 #x05BC]
+ [#x05D3 #x05BC]
+ [#x05D4 #x05BC]
+ [#x05D5 #x05BC]
+ [#x05D6 #x05BC]
+ [#x05D8 #x05BC]
+ [#x05D9 #x05BC]
+ [#x05DA #x05BC]
+ [#x05DB #x05BC]
+ [#x05DC #x05BC]
+ [#x05DE #x05BC]
+ [#x05E0 #x05BC]
+ [#x05E1 #x05BC]
+ [#x05E3 #x05BC]
+ [#x05E4 #x05BC]
+ [#x05E6 #x05BC]
+ [#x05E7 #x05BC]
+ [#x05E8 #x05BC]
+ [#x05E9 #x05BC]
+ [#x05EA #x05BC]
+ [#x05D5 #x05B9]
+ [#x05D1 #x05BF]
+ [#x05DB #x05BF]
+ [#x05E4 #x05BF]]))
+ (unless precomposed
+ (setq precomposed (list t))
+ (let ((gvec (font-get-glyphs font-object 0 (length chars) chars)))
+ (dotimes (i (length chars))
+ (if (aref gvec i)
+ (set-nested-alist (aref decomposed i) (aref gvec i)
+ precomposed))))
+ ;; Cache the result in FONT-OBJECT's property.
+ (font-put font-object 'hebrew-precomposed precomposed))
+ precomposed))
+
+;; Composition function for hebrew. GSTRING is made of a Hebrew base
+;; character followed by Hebrew diacritical marks, or is made of
+;; single Hebrew diacritical mark. Adjust GSTRING to display that
+;; sequence properly. The basic strategy is:
+;;
+;; (1) If there's single diacritical, add padding space to the left
+;; and right of the glyph.
+;;
+;; (2) If the font has OpenType features for Hebrew, ask the OTF
+;; driver the whole work.
+;;
+;; (3) If the font has precomposed glyphs, use them as far as
+;; possible. Adjust the remaining glyphs artificially.
+
+(defun hebrew-shape-gstring (gstring)
+ (let* ((font (lgstring-font gstring))
+ (otf (font-get font :otf))
+ (nchars (lgstring-char-len gstring))
+ header nglyphs base-width glyph precomposed val idx)
+ (cond
+ ((= nchars 1)
+ ;; Independent diacritical mark. Add padding space to left or
+ ;; right so that the glyph doesn't overlap with the surrounding
+ ;; chars.
+ (setq glyph (lgstring-glyph gstring 0))
+ (let ((width (lglyph-width glyph))
+ bearing)
+ (if (< (setq bearing (lglyph-lbearing glyph)) 0)
+ (lglyph-set-adjustment glyph bearing 0 (- width bearing)))
+ (if (> (setq bearing (lglyph-rbearing glyph)) width)
+ (lglyph-set-adjustment glyph 0 0 bearing))))
+
+ ((or (assq 'hebr (car otf)) (assq 'hebr (cdr otf)))
+ ;; FONT has OpenType features for Hebrew.
+ (font-shape-gstring gstring))
+
+ (t
+ ;; FONT doesn't have OpenType features for Hebrew.
+ ;; Try a precomposed glyph.
+ ;; Now GSTRING is in this form:
+ ;; [[FONT CHAR1 CHAR2 ... CHARn] nil GLYPH1 GLYPH2 ... GLYPHn nil ...]
+ (setq precomposed (hebrew-font-get-precomposed font)
+ header (lgstring-header gstring)
+ val (lookup-nested-alist header precomposed nil 1))
+ (if (and (consp val) (vectorp (car val)))
+ ;; All characters can be displayed by a single precomposed glyph.
+ ;; Reform GSTRING to [HEADER nil PRECOMPOSED-GLYPH nil ...]
+ (let ((glyph (copy-sequence (car val))))
+ (lglyph-set-from-to glyph 0 (1- nchars))
+ (lgstring-set-glyph gstring 0 glyph)
+ (lgstring-set-glyph gstring 1 nil))
+ (if (and (integerp val) (> val 2)
+ (setq glyph (lookup-nested-alist header precomposed val 1))
+ (consp glyph) (vectorp (car glyph)))
+ ;; The first (1- VAL) characters can be displayed by a
+ ;; precomposed glyph. Provided that VAL is 3, the first
+ ;; two glyphs should be replaced by the precomposed glyph.
+ ;; In that case, reform GSTRING to:
+ ;; [HEADER nil PRECOMPOSED-GLYPH GLYPH3 ... GLYPHn nil ...]
+ (let* ((ncmp (1- val)) ; number of composed glyphs
+ (diff (1- ncmp))) ; number of reduced glyphs
+ (setq glyph (copy-sequence (car glyph)))
+ (lglyph-set-from-to glyph 0 (1- nchars))
+ (lgstring-set-glyph gstring 0 glyph)
+ (setq idx ncmp)
+ (while (< idx nchars)
+ (setq glyph (lgstring-glyph gstring idx))
+ (lglyph-set-from-to glyph 0 (1- nchars))
+ (lgstring-set-glyph gstring (- idx diff) glyph)
+ (setq idx (1+ idx)))
+ (lgstring-set-glyph gstring (- idx diff) nil)
+ (setq idx (- ncmp diff)
+ nglyphs (- nchars diff)))
+ (setq glyph (lgstring-glyph gstring 0))
+ (lglyph-set-from-to glyph 0 (1- nchars))
+ (setq idx 1 nglyphs nchars))
+ ;; Now IDX is an index to the first non-precomposed glyph.
+ ;; Adjust positions of the remaining glyphs artificially.
+ (setq base-width (lglyph-width (lgstring-glyph gstring 0)))
+ (while (< idx nglyphs)
+ (setq glyph (lgstring-glyph gstring idx))
+ (lglyph-set-from-to glyph 0 (1- nchars))
+ (if (>= (lglyph-lbearing glyph) (lglyph-width glyph))
+ ;; It seems that this glyph is designed to be rendered
+ ;; before the base glyph.
+ (lglyph-set-adjustment glyph (- base-width) 0 0)
+ (if (>= (lglyph-lbearing glyph) 0)
+ ;; Align the horizontal center of this glyph to the
+ ;; horizontal center of the base glyph.
+ (let ((width (- (lglyph-rbearing glyph)
+ (lglyph-lbearing glyph))))
+ (lglyph-set-adjustment glyph
+ (- (/ (- base-width width) 2)
+ (lglyph-lbearing glyph)
+ base-width) 0 0))))
+ (setq idx (1+ idx))))))
+ gstring))
+
+(let* ((base "[\u05D0-\u05F2]")
+ (combining "[\u0591-\u05BD\u05BF\u05C1-\u05C2\u05C4-\u05C5\u05C7]+")
+ (pattern1 (concat base combining))
+ (pattern2 (concat base "\u200D" combining)))
+ (set-char-table-range
+ composition-function-table '(#x591 . #x5C7)
+ (list (vector pattern2 3 'hebrew-shape-gstring)
+ (vector pattern2 2 'hebrew-shape-gstring)
+ (vector pattern1 1 'hebrew-shape-gstring)
+ [nil 0 hebrew-shape-gstring]))
+ ;; Exclude non-combining characters.
+ (set-char-table-range
+ composition-function-table #x5BE nil)
+ (set-char-table-range
+ composition-function-table #x5C0 nil)
+ (set-char-table-range
+ composition-function-table #x5C3 nil)
+ (set-char-table-range
+ composition-function-table #x5C6 nil))
+
(provide 'hebrew)
;; arch-tag: 3ca04f32-3f1e-498e-af46-8267498ba5d9
diff --git a/lisp/language/misc-lang.el b/lisp/language/misc-lang.el
index 2431c9d9e99..e2e4f29dd9e 100644
--- a/lisp/language/misc-lang.el
+++ b/lisp/language/misc-lang.el
@@ -40,8 +40,9 @@
IPA is International Phonetic Alphabet for English, French, German
and Italian.")))
-;; This is for Arabic. But, as we still don't have Arabic language
-;; support, we at least define a coding system here.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Arabic
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-coding-system 'iso-8859-6
"ISO-8859-6 based encoding (MIME:ISO-8859-6)."
@@ -58,6 +59,19 @@ and Italian.")))
:mime-charset 'windows-1256)
(define-coding-system-alias 'cp1256 'windows-1256)
+(set-language-info-alist
+ "Arabic" '((charset unicode)
+ (coding-system utf-8 iso-8859-6 windows-1256)
+ (coding-priority utf-8 iso-8859-6 windows-1256)
+ (input-method . "arabic")
+ (sample-text . "Arabic السّلام عليكم")
+ (documentation . "Bidirectional editing is supported.")))
+
+(set-char-table-range
+ composition-function-table
+ '(#x600 . #x6FF)
+ (list ["[\u0600-\u06FF]+" 0 font-shape-gstring]))
+
(provide 'misc-lang)
;; arch-tag: 6953585c-1a1a-4c09-be82-a2518afb6074
diff --git a/lisp/language/tai-viet.el b/lisp/language/tai-viet.el
index 1423d298d27..25ac901a642 100644
--- a/lisp/language/tai-viet.el
+++ b/lisp/language/tai-viet.el
@@ -37,7 +37,7 @@
(coding-system utf-8)
(coding-priority utf-8)
(input-method . "tai-sonla")
- (sample-text . "TaiViet (ꪁꪫꪱꪣ ꪽꪕ)\t\tꪅꪰꪙ꫃ ꪨꪮ꫃ ꪁꪫꪱ / ꪅꪾ ꪨ� ꪁꪫꪱ")
+ (sample-text . "TaiViet (ꪁꪫꪱꪣ ꪼꪕ)\t\tꪅꪰꪙꫂ ꪨꪮꫂ ꪁꪫꪱ / ꪅꪽ ꪨꪷ ꪁꪫꪱ")
(documentation . "\
TaiViet refers to the Tai language used by Tai people in
Vietnam, and also refers to the script used for this language.
@@ -45,15 +45,15 @@ Both the script and language have the same origin as that of Thai
language/script used in Thailand, but now they differ from each
other in a significant way (especially the scripts are).
-The language name is spelled as \"ꪁꪫꪱꪣ ꪽꪕ\", and the script name is
-spelled as \"ꪎ� ꪽꪕ\" in the modern form, \"ꪎꪴ ꪽꪕ\" in the traditional
-from.
+The language name is spelled as \"ꪁꪫꪱꪣ ꪼꪕ\", and the script name is
+spelled as \"ꪎ ꪼꪕ\" in the modern form, \"ꪎꪳ ꪼꪕ\" in the traditional
+form.
As the proposal for TaiViet script to the Unicode is still on
the progress, we use the Private Use Area for TaiViet
characters (U+F000..U+F07E). A TaiViet font encoded accordingly
is available at this web page:
- http://www.m17n.org/TaiViet/
+ http://www.m17n.org/viettai/
")))
(provide 'tai-viet)
diff --git a/lisp/language/tv-util.el b/lisp/language/tv-util.el
index 842366dacbc..67ed6327971 100644
--- a/lisp/language/tv-util.el
+++ b/lisp/language/tv-util.el
@@ -24,8 +24,7 @@
;;; Code
;; Regexp matching with a sequence of Tai Viet characters.
-(defconst tai-viet-re
- (format "[\xaa80-\xaac2\xaadb-\xaadf-]+"))
+(defconst tai-viet-re "[\xaa80-\xaac2\xaadb-\xaadf]+")
;; Char-table of information about glyph type of Tai Viet characters.
(defconst tai-viet-glyph-info
diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el
index 4a47f95b7fc..af8ac63d5b5 100644
--- a/lisp/ldefs-boot.el
+++ b/lisp/ldefs-boot.el
@@ -5,7 +5,7 @@
;;;### (autoloads (5x5-crack 5x5-crack-xor-mutate 5x5-crack-mutating-best
;;;;;; 5x5-crack-mutating-current 5x5-crack-randomly 5x5) "5x5"
-;;;;;; "play/5x5.el" (19636 58496))
+;;;;;; "play/5x5.el" (19634 23255))
;;; Generated autoloads from play/5x5.el
(autoload '5x5 "5x5" "\
@@ -65,7 +65,7 @@ should return a grid vector array that is the new solution.
;;;***
;;;### (autoloads (list-one-abbrev-table) "abbrevlist" "abbrevlist.el"
-;;;;;; (19636 58496))
+;;;;;; (19580 19536))
;;; Generated autoloads from abbrevlist.el
(autoload 'list-one-abbrev-table "abbrevlist" "\
@@ -76,7 +76,7 @@ Display alphabetical listing of ABBREV-TABLE in buffer OUTPUT-BUFFER.
;;;***
;;;### (autoloads (ada-mode ada-add-extensions) "ada-mode" "progmodes/ada-mode.el"
-;;;;;; (19636 58496))
+;;;;;; (19672 56753))
;;; Generated autoloads from progmodes/ada-mode.el
(autoload 'ada-add-extensions "ada-mode" "\
@@ -90,13 +90,14 @@ the file name.
(autoload 'ada-mode "ada-mode" "\
Ada mode is the major mode for editing Ada code.
+\\{ada-mode-map}
\(fn)" t nil)
;;;***
;;;### (autoloads (ada-header) "ada-stmt" "progmodes/ada-stmt.el"
-;;;;;; (19636 58496))
+;;;;;; (19580 19536))
;;; Generated autoloads from progmodes/ada-stmt.el
(autoload 'ada-header "ada-stmt" "\
@@ -107,7 +108,7 @@ Insert a descriptive header at the top of the file.
;;;***
;;;### (autoloads (ada-find-file) "ada-xref" "progmodes/ada-xref.el"
-;;;;;; (19636 58496))
+;;;;;; (19672 41738))
;;; Generated autoloads from progmodes/ada-xref.el
(autoload 'ada-find-file "ada-xref" "\
@@ -121,9 +122,9 @@ Completion is available.
;;;### (autoloads (change-log-merge add-log-current-defun change-log-mode
;;;;;; add-change-log-entry-other-window add-change-log-entry find-change-log
;;;;;; prompt-for-change-log-name add-log-mailing-address add-log-full-name
-;;;;;; add-log-current-defun-function) "add-log" "add-log.el" (19658
-;;;;;; 61388))
-;;; Generated autoloads from add-log.el
+;;;;;; add-log-current-defun-function) "add-log" "vc/add-log.el"
+;;;;;; (19661 46305))
+;;; Generated autoloads from vc/add-log.el
(put 'change-log-default-name 'safe-local-variable 'string-or-null-p)
@@ -261,7 +262,7 @@ old-style time formats for entries are supported.
;;;### (autoloads (defadvice ad-activate ad-add-advice ad-disable-advice
;;;;;; ad-enable-advice ad-default-compilation-action ad-redefinition-action)
-;;;;;; "advice" "emacs-lisp/advice.el" (19636 58496))
+;;;;;; "advice" "emacs-lisp/advice.el" (19580 19536))
;;; Generated autoloads from emacs-lisp/advice.el
(defvar ad-redefinition-action 'warn "\
@@ -400,11 +401,13 @@ usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...)
\(fn FUNCTION ARGS &rest BODY)" nil (quote macro))
+(put 'defadvice 'doc-string-elt '3)
+
;;;***
;;;### (autoloads (align-newline-and-indent align-unhighlight-rule
;;;;;; align-highlight-rule align-current align-entire align-regexp
-;;;;;; align) "align" "align.el" (19636 58496))
+;;;;;; align) "align" "align.el" (19574 61126))
;;; Generated autoloads from align.el
(autoload 'align "align" "\
@@ -494,7 +497,7 @@ A replacement function for `newline-and-indent', aligning as it goes.
;;;***
;;;### (autoloads (outlineify-sticky allout-mode) "allout" "allout.el"
-;;;;;; (19636 58496))
+;;;;;; (19696 28661))
;;; Generated autoloads from allout.el
(put 'allout-use-hanging-indents 'safe-local-variable (if (fboundp 'booleanp) 'booleanp '(lambda (x) (member x '(t nil)))))
@@ -801,7 +804,7 @@ setup for auto-startup.
;;;***
;;;### (autoloads (ange-ftp-hook-function ange-ftp-reread-dir) "ange-ftp"
-;;;;;; "net/ange-ftp.el" (19636 58496))
+;;;;;; "net/ange-ftp.el" (19668 18649))
;;; Generated autoloads from net/ange-ftp.el
(defalias 'ange-ftp-re-read-dir 'ange-ftp-reread-dir)
@@ -823,7 +826,7 @@ Not documented
;;;***
;;;### (autoloads (animate-birthday-present animate-sequence animate-string)
-;;;;;; "animate" "play/animate.el" (19636 58496))
+;;;;;; "animate" "play/animate.el" (19277 34922))
;;; Generated autoloads from play/animate.el
(autoload 'animate-string "animate" "\
@@ -851,7 +854,7 @@ You can specify the one's name by NAME; the default value is \"Sarah\".
;;;***
;;;### (autoloads (ansi-color-process-output ansi-color-for-comint-mode-on)
-;;;;;; "ansi-color" "ansi-color.el" (19636 58496))
+;;;;;; "ansi-color" "ansi-color.el" (19594 48841))
;;; Generated autoloads from ansi-color.el
(autoload 'ansi-color-for-comint-mode-on "ansi-color" "\
@@ -877,7 +880,7 @@ This is a good function to put in `comint-output-filter-functions'.
;;;***
;;;### (autoloads (antlr-set-tabs antlr-mode antlr-show-makefile-rules)
-;;;;;; "antlr-mode" "progmodes/antlr-mode.el" (19636 58496))
+;;;;;; "antlr-mode" "progmodes/antlr-mode.el" (19599 45674))
;;; Generated autoloads from progmodes/antlr-mode.el
(autoload 'antlr-show-makefile-rules "antlr-mode" "\
@@ -913,8 +916,8 @@ Used in `antlr-mode'. Also a useful function in `java-mode-hook'.
;;;***
-;;;### (autoloads (appt-activate appt-make-list appt-delete appt-add)
-;;;;;; "appt" "calendar/appt.el" (19636 58496))
+;;;### (autoloads (appt-activate appt-add) "appt" "calendar/appt.el"
+;;;;;; (19628 54816))
;;; Generated autoloads from calendar/appt.el
(autoload 'appt-add "appt" "\
@@ -926,26 +929,6 @@ The default is `appt-message-warning-time'.
\(fn TIME MSG &optional WARNTIME)" t nil)
-(autoload 'appt-delete "appt" "\
-Delete an appointment from the list of appointments.
-
-\(fn)" t nil)
-
-(autoload 'appt-make-list "appt" "\
-Update the appointments list from today's diary buffer.
-The time must be at the beginning of a line for it to be
-put in the appointments list (see examples in documentation of
-the function `appt-check'). We assume that the variables DATE and
-NUMBER hold the arguments that `diary-list-entries' received.
-They specify the range of dates that the diary is being processed for.
-
-Any appointments made with `appt-add' are not affected by this function.
-
-For backwards compatibility, this function activates the
-appointment package (if it is not already active).
-
-\(fn)" nil nil)
-
(autoload 'appt-activate "appt" "\
Toggle checking of appointments.
With optional numeric argument ARG, turn appointment checking on if
@@ -957,7 +940,7 @@ ARG is positive, otherwise off.
;;;### (autoloads (apropos-documentation apropos-value apropos-library
;;;;;; apropos apropos-documentation-property apropos-command apropos-variable
-;;;;;; apropos-read-pattern) "apropos" "apropos.el" (19636 58496))
+;;;;;; apropos-read-pattern) "apropos" "apropos.el" (19580 19536))
;;; Generated autoloads from apropos.el
(autoload 'apropos-read-pattern "apropos" "\
@@ -1060,8 +1043,8 @@ Returns list of symbols and documentation found.
;;;***
-;;;### (autoloads (archive-mode) "arc-mode" "arc-mode.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (archive-mode) "arc-mode" "arc-mode.el" (19668
+;;;;;; 19473))
;;; Generated autoloads from arc-mode.el
(autoload 'archive-mode "arc-mode" "\
@@ -1081,7 +1064,7 @@ archive.
;;;***
-;;;### (autoloads (array-mode) "array" "array.el" (19636 58496))
+;;;### (autoloads (array-mode) "array" "array.el" (19672 56753))
;;; Generated autoloads from array.el
(autoload 'array-mode "array" "\
@@ -1152,8 +1135,8 @@ Entering array mode calls the function `array-mode-hook'.
;;;***
-;;;### (autoloads (artist-mode) "artist" "textmodes/artist.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (artist-mode) "artist" "textmodes/artist.el" (19623
+;;;;;; 59989))
;;; Generated autoloads from textmodes/artist.el
(autoload 'artist-mode "artist" "\
@@ -1359,8 +1342,8 @@ Keymap summary
;;;***
-;;;### (autoloads (asm-mode) "asm-mode" "progmodes/asm-mode.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (asm-mode) "asm-mode" "progmodes/asm-mode.el" (19439
+;;;;;; 4022))
;;; Generated autoloads from progmodes/asm-mode.el
(autoload 'asm-mode "asm-mode" "\
@@ -1388,7 +1371,7 @@ Special commands:
;;;***
;;;### (autoloads (autoarg-kp-mode autoarg-mode) "autoarg" "autoarg.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34915))
;;; Generated autoloads from autoarg.el
(defvar autoarg-mode nil "\
@@ -1442,7 +1425,7 @@ etc. to supply digit arguments.
;;;***
;;;### (autoloads (autoconf-mode) "autoconf" "progmodes/autoconf.el"
-;;;;;; (19636 58496))
+;;;;;; (19594 48841))
;;; Generated autoloads from progmodes/autoconf.el
(autoload 'autoconf-mode "autoconf" "\
@@ -1453,7 +1436,7 @@ Major mode for editing Autoconf configure.in files.
;;;***
;;;### (autoloads (auto-insert-mode define-auto-insert auto-insert)
-;;;;;; "autoinsert" "autoinsert.el" (19636 58496))
+;;;;;; "autoinsert" "autoinsert.el" (19508 78))
;;; Generated autoloads from autoinsert.el
(autoload 'auto-insert "autoinsert" "\
@@ -1492,7 +1475,7 @@ insert a template for the file depending on the mode of the buffer.
;;;### (autoloads (batch-update-autoloads update-directory-autoloads
;;;;;; update-file-autoloads) "autoload" "emacs-lisp/autoload.el"
-;;;;;; (19636 58496))
+;;;;;; (19687 6902))
;;; Generated autoloads from emacs-lisp/autoload.el
(put 'generated-autoload-file 'safe-local-variable 'stringp)
@@ -1531,7 +1514,7 @@ Calls `update-directory-autoloads' on the command line arguments.
;;;### (autoloads (global-auto-revert-mode turn-on-auto-revert-tail-mode
;;;;;; auto-revert-tail-mode turn-on-auto-revert-mode auto-revert-mode)
-;;;;;; "autorevert" "autorevert.el" (19636 58496))
+;;;;;; "autorevert" "autorevert.el" (19277 34915))
;;; Generated autoloads from autorevert.el
(autoload 'auto-revert-mode "autorevert" "\
@@ -1612,7 +1595,7 @@ specifies in the mode line.
;;;***
;;;### (autoloads (mouse-avoidance-mode mouse-avoidance-mode) "avoid"
-;;;;;; "avoid.el" (19636 58496))
+;;;;;; "avoid.el" (19645 60484))
;;; Generated autoloads from avoid.el
(defvar mouse-avoidance-mode nil "\
@@ -1653,7 +1636,7 @@ definition of \"random distance\".)
;;;***
;;;### (autoloads (display-battery-mode battery) "battery" "battery.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34915))
;;; Generated autoloads from battery.el
(put 'battery-mode-line-string 'risky-local-variable t)
@@ -1685,7 +1668,7 @@ seconds.
;;;***
;;;### (autoloads (benchmark benchmark-run-compiled benchmark-run)
-;;;;;; "benchmark" "emacs-lisp/benchmark.el" (19636 58496))
+;;;;;; "benchmark" "emacs-lisp/benchmark.el" (19277 34919))
;;; Generated autoloads from emacs-lisp/benchmark.el
(autoload 'benchmark-run "benchmark" "\
@@ -1718,7 +1701,7 @@ For non-interactive use see also `benchmark-run' and
;;;***
;;;### (autoloads (bibtex-search-entry bibtex-mode bibtex-initialize)
-;;;;;; "bibtex" "textmodes/bibtex.el" (19658 61388))
+;;;;;; "bibtex" "textmodes/bibtex.el" (19661 46305))
;;; Generated autoloads from textmodes/bibtex.el
(autoload 'bibtex-initialize "bibtex" "\
@@ -1805,9 +1788,8 @@ mode is not `bibtex-mode', START is nil, and DISPLAY is t.
;;;***
;;;### (autoloads (bibtex-style-mode) "bibtex-style" "textmodes/bibtex-style.el"
-;;;;;; (19636 58496))
+;;;;;; (19611 36358))
;;; Generated autoloads from textmodes/bibtex-style.el
- (add-to-list 'auto-mode-alist (cons (purecopy "\\.bst\\'") 'bibtex-style-mode))
(autoload 'bibtex-style-mode "bibtex-style" "\
Major mode for editing BibTeX style files.
@@ -1818,7 +1800,7 @@ Major mode for editing BibTeX style files.
;;;### (autoloads (binhex-decode-region binhex-decode-region-external
;;;;;; binhex-decode-region-internal) "binhex" "mail/binhex.el"
-;;;;;; (19636 58496))
+;;;;;; (19582 65302))
;;; Generated autoloads from mail/binhex.el
(defconst binhex-begin-line "^:...............................................................$")
@@ -1841,8 +1823,8 @@ Binhex decode region between START and END.
;;;***
-;;;### (autoloads (blackbox) "blackbox" "play/blackbox.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (blackbox) "blackbox" "play/blackbox.el" (19277
+;;;;;; 34922))
;;; Generated autoloads from play/blackbox.el
(autoload 'blackbox "blackbox" "\
@@ -1965,7 +1947,7 @@ a reflection.
;;;;;; bookmark-save bookmark-write bookmark-delete bookmark-insert
;;;;;; bookmark-rename bookmark-insert-location bookmark-relocate
;;;;;; bookmark-jump-other-window bookmark-jump bookmark-set) "bookmark"
-;;;;;; "bookmark.el" (19636 58496))
+;;;;;; "bookmark.el" (19668 18952))
;;; Generated autoloads from bookmark.el
(define-key ctl-x-r-map "b" 'bookmark-jump)
(define-key ctl-x-r-map "m" 'bookmark-set)
@@ -2167,12 +2149,12 @@ Incremental search of bookmarks, hiding the non-matches as we go.
;;;;;; browse-url-mail browse-url-text-emacs browse-url-text-xterm
;;;;;; browse-url-w3-gnudoit browse-url-w3 browse-url-cci browse-url-mosaic
;;;;;; browse-url-gnome-moz browse-url-emacs browse-url-galeon browse-url-firefox
-;;;;;; browse-url-mozilla browse-url-netscape browse-url-default-browser
-;;;;;; browse-url-at-mouse browse-url-at-point browse-url browse-url-of-region
-;;;;;; browse-url-of-dired-file browse-url-of-buffer browse-url-of-file
-;;;;;; browse-url-url-at-point browse-url-galeon-program browse-url-firefox-program
+;;;;;; browse-url-mozilla browse-url-netscape browse-url-xdg-open
+;;;;;; browse-url-default-browser browse-url-at-mouse browse-url-at-point
+;;;;;; browse-url browse-url-of-region browse-url-of-dired-file
+;;;;;; browse-url-of-buffer browse-url-of-file browse-url-url-at-point
;;;;;; browse-url-browser-function) "browse-url" "net/browse-url.el"
-;;;;;; (19636 58496))
+;;;;;; (19696 28661))
;;; Generated autoloads from net/browse-url.el
(defvar browse-url-browser-function (cond ((memq system-type '(windows-nt ms-dos cygwin)) 'browse-url-default-windows-browser) ((memq system-type '(darwin)) 'browse-url-default-macosx-browser) (t 'browse-url-default-browser)) "\
@@ -2188,16 +2170,6 @@ regexp should probably be \".\" to specify a default browser.")
(custom-autoload 'browse-url-browser-function "browse-url" t)
-(defvar browse-url-firefox-program (purecopy "firefox") "\
-The name by which to invoke Firefox.")
-
-(custom-autoload 'browse-url-firefox-program "browse-url" t)
-
-(defvar browse-url-galeon-program (purecopy "galeon") "\
-The name by which to invoke Galeon.")
-
-(custom-autoload 'browse-url-galeon-program "browse-url" t)
-
(autoload 'browse-url-url-at-point "browse-url" "\
Not documented
@@ -2234,6 +2206,8 @@ Ask a WWW browser to display the current region.
Ask a WWW browser to load URL.
Prompts for a URL, defaulting to the URL at or before point. Variable
`browse-url-browser-function' says which browser to use.
+If the URL is a mailto: URL, consult `browse-url-mailto-function'
+first, if that exists.
\(fn URL &rest ARGS)" t nil)
@@ -2270,6 +2244,11 @@ Galeon, Konqueror, Netscape, Mosaic, Lynx in an xterm, and then W3.
\(fn URL &rest ARGS)" nil nil)
+(autoload 'browse-url-xdg-open "browse-url" "\
+Not documented
+
+\(fn URL &optional NEW-WINDOW)" t nil)
+
(autoload 'browse-url-netscape "browse-url" "\
Ask the Netscape WWW browser to load URL.
Default to the URL around or before point. The strings in variable
@@ -2502,8 +2481,8 @@ from `browse-url-elinks-wrapper'.
;;;***
-;;;### (autoloads (snarf-bruces bruce) "bruce" "play/bruce.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (snarf-bruces bruce) "bruce" "play/bruce.el" (19277
+;;;;;; 34922))
;;; Generated autoloads from play/bruce.el
(autoload 'bruce "bruce" "\
@@ -2519,7 +2498,7 @@ Return a vector containing the lines from `bruce-phrases-file'.
;;;***
;;;### (autoloads (bs-show bs-customize bs-cycle-previous bs-cycle-next)
-;;;;;; "bs" "bs.el" (19636 58496))
+;;;;;; "bs" "bs.el" (19515 27412))
;;; Generated autoloads from bs.el
(autoload 'bs-cycle-next "bs" "\
@@ -2559,7 +2538,7 @@ name of buffer configuration.
;;;***
-;;;### (autoloads (bubbles) "bubbles" "play/bubbles.el" (19636 58496))
+;;;### (autoloads (bubbles) "bubbles" "play/bubbles.el" (19612 4032))
;;; Generated autoloads from play/bubbles.el
(autoload 'bubbles "bubbles" "\
@@ -2581,10 +2560,10 @@ columns on its right towards the left.
;;;***
;;;### (autoloads (bug-reference-prog-mode bug-reference-mode) "bug-reference"
-;;;;;; "progmodes/bug-reference.el" (19636 58496))
+;;;;;; "progmodes/bug-reference.el" (19418 12890))
;;; Generated autoloads from progmodes/bug-reference.el
-(put 'bug-reference-url-format 'safe-local-variable 'stringp)
+(put 'bug-reference-url-format 'safe-local-variable (lambda (s) (or (stringp s) (and (symbolp s) (get s 'bug-reference-url-format)))))
(autoload 'bug-reference-mode "bug-reference" "\
Minor mode to buttonize bugzilla references in the current buffer.
@@ -2601,19 +2580,14 @@ Like `bug-reference-mode', but only buttonize in comments and strings.
;;;### (autoloads (batch-byte-recompile-directory batch-byte-compile
;;;;;; batch-byte-compile-if-not-done display-call-tree byte-compile
;;;;;; compile-defun byte-compile-file byte-recompile-directory
-;;;;;; byte-force-recompile byte-compile-enable-warning byte-compile-disable-warning
-;;;;;; byte-compile-warnings-safe-p) "bytecomp" "emacs-lisp/bytecomp.el"
-;;;;;; (19636 58496))
+;;;;;; byte-force-recompile byte-compile-enable-warning byte-compile-disable-warning)
+;;;;;; "bytecomp" "emacs-lisp/bytecomp.el" (19687 6902))
;;; Generated autoloads from emacs-lisp/bytecomp.el
(put 'byte-compile-dynamic 'safe-local-variable 'booleanp)
(put 'byte-compile-disable-print-circle 'safe-local-variable 'booleanp)
(put 'byte-compile-dynamic-docstrings 'safe-local-variable 'booleanp)
-(put 'byte-compile-warnings 'safe-local-variable 'byte-compile-warnings-safe-p)
-(autoload 'byte-compile-warnings-safe-p "bytecomp" "\
-Return non-nil if X is valid as a value of `byte-compile-warnings'.
-
-\(fn X)" nil nil)
+(put 'byte-compile-warnings 'safe-local-variable (lambda (v) (or (symbolp v) (null (delq nil (mapcar (lambda (x) (not (symbolp x))) v))))))
(autoload 'byte-compile-disable-warning "bytecomp" "\
Change `byte-compile-warnings' to disable WARNING.
@@ -2727,8 +2701,8 @@ and corresponding effects.
;;;***
-;;;### (autoloads nil "cal-china" "calendar/cal-china.el" (19636
-;;;;;; 58496))
+;;;### (autoloads nil "cal-china" "calendar/cal-china.el" (19580
+;;;;;; 19536))
;;; Generated autoloads from calendar/cal-china.el
(put 'calendar-chinese-time-zone 'risky-local-variable t)
@@ -2737,7 +2711,7 @@ and corresponding effects.
;;;***
-;;;### (autoloads nil "cal-dst" "calendar/cal-dst.el" (19636 58496))
+;;;### (autoloads nil "cal-dst" "calendar/cal-dst.el" (19580 19536))
;;; Generated autoloads from calendar/cal-dst.el
(put 'calendar-daylight-savings-starts 'risky-local-variable t)
@@ -2749,7 +2723,7 @@ and corresponding effects.
;;;***
;;;### (autoloads (calendar-hebrew-list-yahrzeits) "cal-hebrew" "calendar/cal-hebrew.el"
-;;;;;; (19636 58496))
+;;;;;; (19631 54972))
;;; Generated autoloads from calendar/cal-hebrew.el
(autoload 'calendar-hebrew-list-yahrzeits "cal-hebrew" "\
@@ -2765,8 +2739,8 @@ from the cursor position.
;;;### (autoloads (defmath calc-embedded-activate calc-embedded calc-grab-rectangle
;;;;;; calc-grab-region full-calc-keypad calc-keypad calc-eval quick-calc
-;;;;;; full-calc calc calc-dispatch) "calc" "calc/calc.el" (19636
-;;;;;; 58496))
+;;;;;; full-calc calc calc-dispatch) "calc" "calc/calc.el" (19552
+;;;;;; 37739))
;;; Generated autoloads from calc/calc.el
(define-key ctl-x-map "*" 'calc-dispatch)
@@ -2846,10 +2820,12 @@ See Info node `(calc)Defining Functions'.
\(fn FUNC ARGS &rest BODY)" nil (quote macro))
+(put 'defmath 'doc-string-elt '3)
+
;;;***
-;;;### (autoloads (calculator) "calculator" "calculator.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (calculator) "calculator" "calculator.el" (19612
+;;;;;; 4032))
;;; Generated autoloads from calculator.el
(autoload 'calculator "calculator" "\
@@ -2860,8 +2836,8 @@ See the documentation for `calculator-mode' for more information.
;;;***
-;;;### (autoloads (calendar) "calendar" "calendar/calendar.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (calendar) "calendar" "calendar/calendar.el" (19687
+;;;;;; 6902))
;;; Generated autoloads from calendar/calendar.el
(autoload 'calendar "calendar" "\
@@ -2905,7 +2881,7 @@ This function is suitable for execution in a .emacs file.
;;;***
;;;### (autoloads (canlock-verify canlock-insert-header) "canlock"
-;;;;;; "gnus/canlock.el" (19636 58496))
+;;;;;; "gnus/canlock.el" (19582 65302))
;;; Generated autoloads from gnus/canlock.el
(autoload 'canlock-insert-header "canlock" "\
@@ -2923,7 +2899,7 @@ it fails.
;;;***
;;;### (autoloads (capitalized-words-mode) "cap-words" "progmodes/cap-words.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34922))
;;; Generated autoloads from progmodes/cap-words.el
(autoload 'capitalized-words-mode "cap-words" "\
@@ -2958,15 +2934,15 @@ Obsoletes `c-forward-into-nomenclature'.
;;;***
-;;;### (autoloads nil "cc-compat" "progmodes/cc-compat.el" (19636
-;;;;;; 58496))
+;;;### (autoloads nil "cc-compat" "progmodes/cc-compat.el" (19580
+;;;;;; 19536))
;;; Generated autoloads from progmodes/cc-compat.el
(put 'c-indent-level 'safe-local-variable 'integerp)
;;;***
;;;### (autoloads (c-guess-basic-syntax) "cc-engine" "progmodes/cc-engine.el"
-;;;;;; (19636 58496))
+;;;;;; (19632 52521))
;;; Generated autoloads from progmodes/cc-engine.el
(autoload 'c-guess-basic-syntax "cc-engine" "\
@@ -2978,7 +2954,7 @@ Return the syntactic context of the current line.
;;;### (autoloads (pike-mode idl-mode java-mode objc-mode c++-mode
;;;;;; c-mode c-initialize-cc-mode) "cc-mode" "progmodes/cc-mode.el"
-;;;;;; (19636 58496))
+;;;;;; (19646 27154))
;;; Generated autoloads from progmodes/cc-mode.el
(autoload 'c-initialize-cc-mode "cc-mode" "\
@@ -3138,7 +3114,7 @@ Key bindings:
;;;***
;;;### (autoloads (c-set-offset c-add-style c-set-style) "cc-styles"
-;;;;;; "progmodes/cc-styles.el" (19636 58496))
+;;;;;; "progmodes/cc-styles.el" (19623 58121))
;;; Generated autoloads from progmodes/cc-styles.el
(autoload 'c-set-style "cc-styles" "\
@@ -3189,7 +3165,7 @@ and exists only for compatibility reasons.
;;;***
-;;;### (autoloads nil "cc-vars" "progmodes/cc-vars.el" (19636 58496))
+;;;### (autoloads nil "cc-vars" "progmodes/cc-vars.el" (19580 19536))
;;; Generated autoloads from progmodes/cc-vars.el
(put 'c-basic-offset 'safe-local-variable 'integerp)
(put 'c-backslash-column 'safe-local-variable 'integerp)
@@ -3199,7 +3175,7 @@ and exists only for compatibility reasons.
;;;### (autoloads (ccl-execute-with-args check-ccl-program define-ccl-program
;;;;;; declare-ccl-program ccl-dump ccl-compile) "ccl" "international/ccl.el"
-;;;;;; (19636 58496))
+;;;;;; (19639 17158))
;;; Generated autoloads from international/ccl.el
(autoload 'ccl-compile "ccl" "\
@@ -3438,6 +3414,8 @@ MAP-ID := integer
\(fn NAME CCL-PROGRAM &optional DOC)" nil (quote macro))
+(put 'define-ccl-program 'doc-string-elt '3)
+
(autoload 'check-ccl-program "ccl" "\
Check validity of CCL-PROGRAM.
If CCL-PROGRAM is a symbol denoting a CCL program, return
@@ -3458,7 +3436,7 @@ See the documentation of `define-ccl-program' for the detail of CCL program.
;;;***
;;;### (autoloads (cfengine-mode) "cfengine" "progmodes/cfengine.el"
-;;;;;; (19636 58496))
+;;;;;; (19594 48841))
;;; Generated autoloads from progmodes/cfengine.el
(autoload 'cfengine-mode "cfengine" "\
@@ -3473,7 +3451,7 @@ to the action header.
;;;***
;;;### (autoloads (check-declare-directory check-declare-file) "check-declare"
-;;;;;; "emacs-lisp/check-declare.el" (19636 58496))
+;;;;;; "emacs-lisp/check-declare.el" (19277 34919))
;;; Generated autoloads from emacs-lisp/check-declare.el
(autoload 'check-declare-file "check-declare" "\
@@ -3498,7 +3476,7 @@ Returns non-nil if any false statements are found.
;;;;;; checkdoc-comments checkdoc-continue checkdoc-start checkdoc-current-buffer
;;;;;; checkdoc-eval-current-buffer checkdoc-message-interactive
;;;;;; checkdoc-interactive checkdoc checkdoc-list-of-strings-p)
-;;;;;; "checkdoc" "emacs-lisp/checkdoc.el" (19636 58496))
+;;;;;; "checkdoc" "emacs-lisp/checkdoc.el" (19687 6902))
;;; Generated autoloads from emacs-lisp/checkdoc.el
(put 'checkdoc-force-docstrings-flag 'safe-local-variable 'booleanp)
(put 'checkdoc-force-history-flag 'safe-local-variable 'booleanp)
@@ -3693,7 +3671,7 @@ checking of documentation strings.
;;;### (autoloads (pre-write-encode-hz post-read-decode-hz encode-hz-buffer
;;;;;; encode-hz-region decode-hz-buffer decode-hz-region) "china-util"
-;;;;;; "language/china-util.el" (19636 58496))
+;;;;;; "language/china-util.el" (19277 34920))
;;; Generated autoloads from language/china-util.el
(autoload 'decode-hz-region "china-util" "\
@@ -3731,7 +3709,7 @@ Not documented
;;;***
;;;### (autoloads (command-history list-command-history repeat-matching-complex-command)
-;;;;;; "chistory" "chistory.el" (19636 58496))
+;;;;;; "chistory" "chistory.el" (19277 34915))
;;; Generated autoloads from chistory.el
(autoload 'repeat-matching-complex-command "chistory" "\
@@ -3770,7 +3748,7 @@ and runs the normal hook `command-history-hook'.
;;;***
-;;;### (autoloads nil "cl" "emacs-lisp/cl.el" (19636 58496))
+;;;### (autoloads nil "cl" "emacs-lisp/cl.el" (19627 57387))
;;; Generated autoloads from emacs-lisp/cl.el
(defvar custom-print-functions nil "\
@@ -3786,7 +3764,7 @@ a future Emacs interpreter will be able to use it.")
;;;***
;;;### (autoloads (common-lisp-indent-function) "cl-indent" "emacs-lisp/cl-indent.el"
-;;;;;; (19636 58496))
+;;;;;; (19580 19536))
;;; Generated autoloads from emacs-lisp/cl-indent.el
(autoload 'common-lisp-indent-function "cl-indent" "\
@@ -3865,7 +3843,7 @@ For example, the function `case' has an indent property
;;;***
;;;### (autoloads (c-macro-expand) "cmacexp" "progmodes/cmacexp.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34922))
;;; Generated autoloads from progmodes/cmacexp.el
(autoload 'c-macro-expand "cmacexp" "\
@@ -3885,8 +3863,8 @@ For use inside Lisp programs, see also `c-macro-expansion'.
;;;***
-;;;### (autoloads (run-scheme) "cmuscheme" "cmuscheme.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (run-scheme) "cmuscheme" "cmuscheme.el" (19277
+;;;;;; 34915))
;;; Generated autoloads from cmuscheme.el
(autoload 'run-scheme "cmuscheme" "\
@@ -3910,7 +3888,7 @@ is run).
;;;### (autoloads (comint-redirect-results-list-from-process comint-redirect-results-list
;;;;;; comint-redirect-send-command-to-process comint-redirect-send-command
;;;;;; comint-run make-comint make-comint-in-buffer) "comint" "comint.el"
-;;;;;; (19652 24589))
+;;;;;; (19687 6902))
;;; Generated autoloads from comint.el
(defvar comint-output-filter-functions '(comint-postoutput-scroll-to-bottom comint-watch-for-password-prompt) "\
@@ -3926,8 +3904,6 @@ See also `comint-preoutput-filter-functions'.
You can use `add-hook' to add functions to this list
either globally or locally.")
-(define-obsolete-variable-alias 'comint-use-prompt-regexp-instead-of-fields 'comint-use-prompt-regexp "22.1")
-
(autoload 'make-comint-in-buffer "comint" "\
Make a Comint process NAME in BUFFER, running PROGRAM.
If BUFFER is nil, it defaults to NAME surrounded by `*'s.
@@ -4006,9 +3982,9 @@ REGEXP-GROUP is the regular expression group in REGEXP to use.
;;;***
-;;;### (autoloads (compare-windows) "compare-w" "compare-w.el" (19636
-;;;;;; 58496))
-;;; Generated autoloads from compare-w.el
+;;;### (autoloads (compare-windows) "compare-w" "vc/compare-w.el"
+;;;;;; (19478 62344))
+;;; Generated autoloads from vc/compare-w.el
(autoload 'compare-windows "compare-w" "\
Compare text in current window with text in next window.
@@ -4044,8 +4020,8 @@ on third call it again advances points to the next difference and so on.
;;;;;; compilation-shell-minor-mode compilation-mode compilation-start
;;;;;; compile compilation-disable-input compile-command compilation-search-path
;;;;;; compilation-ask-about-save compilation-window-height compilation-start-hook
-;;;;;; compilation-mode-hook) "compile" "progmodes/compile.el" (19636
-;;;;;; 58496))
+;;;;;; compilation-mode-hook) "compile" "progmodes/compile.el" (19656
+;;;;;; 61992))
;;; Generated autoloads from progmodes/compile.el
(defvar compilation-mode-hook nil "\
@@ -4218,54 +4194,10 @@ This is the value of `next-error-function' in Compilation buffers.
\(fn N &optional RESET)" t nil)
-(add-to-list 'auto-mode-alist (cons (purecopy "\\.gcov\\'") 'compilation-mode))
-
-;;;***
-
-;;;### (autoloads (partial-completion-mode) "complete" "complete.el"
-;;;;;; (19636 58496))
-;;; Generated autoloads from complete.el
-
-(defvar partial-completion-mode nil "\
-Non-nil if Partial-Completion mode is enabled.
-See the command `partial-completion-mode' for a description of this minor mode.
-Setting this variable directly does not take effect;
-either customize it (see the info node `Easy Customization')
-or call the function `partial-completion-mode'.")
-
-(custom-autoload 'partial-completion-mode "complete" nil)
-
-(autoload 'partial-completion-mode "complete" "\
-Toggle Partial Completion mode.
-With prefix ARG, turn Partial Completion mode on if ARG is positive.
-
-When Partial Completion mode is enabled, TAB (or M-TAB if `PC-meta-flag' is
-nil) is enhanced so that if some string is divided into words and each word is
-delimited by a character in `PC-word-delimiters', partial words are completed
-as much as possible and `*' characters are treated likewise in file names.
-
-For example, M-x p-c-m expands to M-x partial-completion-mode since no other
-command begins with that sequence of characters, and
-\\[find-file] f_b.c TAB might complete to foo_bar.c if that file existed and no
-other file in that directory begins with that sequence of characters.
-
-Unless `PC-disable-includes' is non-nil, the `<...>' sequence is interpreted
-specially in \\[find-file]. For example,
-\\[find-file] <sys/time.h> RET finds the file `/usr/include/sys/time.h'.
-See also the variable `PC-include-file-path'.
-
-Partial Completion mode extends the meaning of `completion-auto-help' (which
-see), so that if it is neither nil nor t, Emacs shows the `*Completions*'
-buffer only on the second attempt to complete. That is, if TAB finds nothing
-to complete, the first TAB just says \"Next char not unique\" and the
-second TAB brings up the `*Completions*' buffer.
-
-\(fn &optional ARG)" t nil)
-
;;;***
;;;### (autoloads (dynamic-completion-mode) "completion" "completion.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34915))
;;; Generated autoloads from completion.el
(defvar dynamic-completion-mode nil "\
@@ -4287,7 +4219,7 @@ Enable dynamic word-completion.
;;;### (autoloads (conf-xdefaults-mode conf-ppd-mode conf-colon-mode
;;;;;; conf-space-keywords conf-space-mode conf-javaprop-mode conf-windows-mode
;;;;;; conf-unix-mode conf-mode) "conf-mode" "textmodes/conf-mode.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34923))
;;; Generated autoloads from textmodes/conf-mode.el
(autoload 'conf-mode "conf-mode" "\
@@ -4443,7 +4375,7 @@ For details see `conf-mode'. Example:
;;;***
;;;### (autoloads (shuffle-vector cookie-snarf cookie-insert cookie)
-;;;;;; "cookie1" "play/cookie1.el" (19636 58496))
+;;;;;; "cookie1" "play/cookie1.el" (19583 60940))
;;; Generated autoloads from play/cookie1.el
(autoload 'cookie "cookie1" "\
@@ -4475,8 +4407,8 @@ Randomly permute the elements of VECTOR (all permutations equally likely).
;;;***
;;;### (autoloads (copyright-update-directory copyright copyright-fix-years
-;;;;;; copyright-update) "copyright" "emacs-lisp/copyright.el" (19636
-;;;;;; 58496))
+;;;;;; copyright-update) "copyright" "emacs-lisp/copyright.el" (19561
+;;;;;; 48711))
;;; Generated autoloads from emacs-lisp/copyright.el
(autoload 'copyright-update "copyright" "\
@@ -4509,7 +4441,7 @@ Update copyright notice for all files in DIRECTORY matching MATCH.
;;;***
;;;### (autoloads (cperl-perldoc-at-point cperl-perldoc cperl-mode)
-;;;;;; "cperl-mode" "progmodes/cperl-mode.el" (19636 58496))
+;;;;;; "cperl-mode" "progmodes/cperl-mode.el" (19672 56753))
;;; Generated autoloads from progmodes/cperl-mode.el
(put 'cperl-indent-level 'safe-local-variable 'integerp)
(put 'cperl-brace-offset 'safe-local-variable 'integerp)
@@ -4708,7 +4640,7 @@ Run a `perldoc' on the word around point.
;;;***
;;;### (autoloads (cpp-parse-edit cpp-highlight-buffer) "cpp" "progmodes/cpp.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34922))
;;; Generated autoloads from progmodes/cpp.el
(autoload 'cpp-highlight-buffer "cpp" "\
@@ -4727,7 +4659,7 @@ Edit display information for cpp conditionals.
;;;***
;;;### (autoloads (crisp-mode crisp-mode) "crisp" "emulation/crisp.el"
-;;;;;; (19636 58496))
+;;;;;; (19609 2266))
;;; Generated autoloads from emulation/crisp.el
(defvar crisp-mode nil "\
@@ -4751,7 +4683,7 @@ With ARG, turn CRiSP mode on if ARG is positive, off otherwise.
;;;***
;;;### (autoloads (completing-read-multiple) "crm" "emacs-lisp/crm.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34919))
;;; Generated autoloads from emacs-lisp/crm.el
(autoload 'completing-read-multiple "crm" "\
@@ -4786,10 +4718,9 @@ INHERIT-INPUT-METHOD.
;;;***
-;;;### (autoloads (css-mode) "css-mode" "textmodes/css-mode.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (css-mode) "css-mode" "textmodes/css-mode.el" (19611
+;;;;;; 35698))
;;; Generated autoloads from textmodes/css-mode.el
- (add-to-list 'auto-mode-alist (cons (purecopy "\\.css\\'") 'css-mode))
(autoload 'css-mode "css-mode" "\
Major mode to edit Cascading Style Sheets.
@@ -4799,7 +4730,7 @@ Major mode to edit Cascading Style Sheets.
;;;***
;;;### (autoloads (cua-selection-mode cua-mode) "cua-base" "emulation/cua-base.el"
-;;;;;; (19636 58496))
+;;;;;; (19648 63621))
;;; Generated autoloads from emulation/cua-base.el
(defvar cua-mode nil "\
@@ -4858,7 +4789,7 @@ Enable CUA selection mode without the C-z/C-x/C-c/C-v bindings.
;;;;;; customize-mode customize customize-save-variable customize-set-variable
;;;;;; customize-set-value custom-menu-sort-alphabetically custom-buffer-sort-alphabetically
;;;;;; custom-browse-sort-alphabetically) "cus-edit" "cus-edit.el"
-;;;;;; (19636 58496))
+;;;;;; (19645 60484))
;;; Generated autoloads from cus-edit.el
(defvar custom-browse-sort-alphabetically nil "\
@@ -4866,8 +4797,8 @@ If non-nil, sort customization group alphabetically in `custom-browse'.")
(custom-autoload 'custom-browse-sort-alphabetically "cus-edit" t)
-(defvar custom-buffer-sort-alphabetically nil "\
-If non-nil, sort each customization group alphabetically in Custom buffer.")
+(defvar custom-buffer-sort-alphabetically t "\
+Whether to sort customization groups alphabetically in Custom buffer.")
(custom-autoload 'custom-buffer-sort-alphabetically "cus-edit" t)
@@ -5043,15 +4974,20 @@ Customize all already saved user options.
\(fn)" t nil)
(autoload 'customize-apropos "cus-edit" "\
-Customize all loaded options, faces and groups matching REGEXP.
-If ALL is `options', include only options.
-If ALL is `faces', include only faces.
-If ALL is `groups', include only groups.
-If ALL is t (interactively, with prefix arg), include variables
+Customize all loaded options, faces and groups matching PATTERN.
+PATTERN can be a word, a list of words (separated by spaces),
+or a regexp (using some regexp special characters). If it is a word,
+search for matches for that word as a substring. If it is a list of words,
+search for matches for any two (or more) of those words.
+
+If TYPE is `options', include only options.
+If TYPE is `faces', include only faces.
+If TYPE is `groups', include only groups.
+If TYPE is t (interactively, with prefix arg), include variables
that are not customizable options, as well as faces and groups
\(but we recommend using `apropos-variable' instead).
-\(fn REGEXP &optional ALL)" t nil)
+\(fn PATTERN &optional TYPE)" t nil)
(autoload 'customize-apropos-options "cus-edit" "\
Customize all loaded customizable options matching REGEXP.
@@ -5155,20 +5091,36 @@ The format is suitable for use with `easy-menu-define'.
;;;***
-;;;### (autoloads (customize-create-theme) "cus-theme" "cus-theme.el"
-;;;;;; (19636 58496))
+;;;### (autoloads (customize-themes describe-theme customize-create-theme)
+;;;;;; "cus-theme" "cus-theme.el" (19645 60484))
;;; Generated autoloads from cus-theme.el
(autoload 'customize-create-theme "cus-theme" "\
-Create a custom theme.
+Create or edit a custom theme.
+THEME, if non-nil, should be an existing theme to edit. If THEME
+is `user', provide an option to remove these as custom settings.
+BUFFER, if non-nil, should be a buffer to use; the default is
+named *Custom Theme*.
-\(fn)" t nil)
+\(fn &optional THEME BUFFER)" t nil)
+
+(autoload 'describe-theme "cus-theme" "\
+Display a description of the Custom theme THEME (a symbol).
+
+\(fn THEME)" t nil)
+
+(autoload 'customize-themes "cus-theme" "\
+Display a selectable list of Custom themes.
+When called from Lisp, BUFFER should be the buffer to use; if
+omitted, a buffer named *Custom Themes* is used.
+
+\(fn &optional BUFFER)" t nil)
;;;***
-;;;### (autoloads (cvs-status-mode) "cvs-status" "cvs-status.el"
-;;;;;; (19636 58496))
-;;; Generated autoloads from cvs-status.el
+;;;### (autoloads (cvs-status-mode) "cvs-status" "vc/cvs-status.el"
+;;;;;; (19474 36901))
+;;; Generated autoloads from vc/cvs-status.el
(autoload 'cvs-status-mode "cvs-status" "\
Mode used for cvs status output.
@@ -5178,7 +5130,7 @@ Mode used for cvs status output.
;;;***
;;;### (autoloads (global-cwarn-mode turn-on-cwarn-mode cwarn-mode)
-;;;;;; "cwarn" "progmodes/cwarn.el" (19636 58496))
+;;;;;; "cwarn" "progmodes/cwarn.el" (19580 19536))
;;; Generated autoloads from progmodes/cwarn.el
(autoload 'cwarn-mode "cwarn" "\
@@ -5225,7 +5177,7 @@ See `cwarn-mode' for more information on Cwarn mode.
;;;### (autoloads (standard-display-cyrillic-translit cyrillic-encode-alternativnyj-char
;;;;;; cyrillic-encode-koi8-r-char) "cyril-util" "language/cyril-util.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34920))
;;; Generated autoloads from language/cyril-util.el
(autoload 'cyrillic-encode-koi8-r-char "cyril-util" "\
@@ -5254,7 +5206,7 @@ If the argument is nil, we return the display table to its standard state.
;;;***
;;;### (autoloads (dabbrev-expand dabbrev-completion) "dabbrev" "dabbrev.el"
-;;;;;; (19636 58496))
+;;;;;; (19552 37739))
;;; Generated autoloads from dabbrev.el
(put 'dabbrev-case-fold-search 'risky-local-variable t)
(put 'dabbrev-case-replace 'risky-local-variable t)
@@ -5301,7 +5253,7 @@ See also `dabbrev-abbrev-char-regexp' and \\[dabbrev-completion].
;;;***
;;;### (autoloads (data-debug-new-buffer) "data-debug" "cedet/data-debug.el"
-;;;;;; (19636 58496))
+;;;;;; (19580 19536))
;;; Generated autoloads from cedet/data-debug.el
(autoload 'data-debug-new-buffer "data-debug" "\
@@ -5311,8 +5263,8 @@ Create a new data-debug buffer with NAME.
;;;***
-;;;### (autoloads (dbus-handle-event) "dbus" "net/dbus.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (dbus-handle-event) "dbus" "net/dbus.el" (19664
+;;;;;; 56235))
;;; Generated autoloads from net/dbus.el
(autoload 'dbus-handle-event "dbus" "\
@@ -5325,8 +5277,8 @@ If the HANDLER returns a `dbus-error', it is propagated as return message.
;;;***
-;;;### (autoloads (dcl-mode) "dcl-mode" "progmodes/dcl-mode.el" (19652
-;;;;;; 24589))
+;;;### (autoloads (dcl-mode) "dcl-mode" "progmodes/dcl-mode.el" (19668
+;;;;;; 19168))
;;; Generated autoloads from progmodes/dcl-mode.el
(autoload 'dcl-mode "dcl-mode" "\
@@ -5453,7 +5405,7 @@ There is some minimal font-lock support (see vars
;;;***
;;;### (autoloads (cancel-debug-on-entry debug-on-entry debug) "debug"
-;;;;;; "emacs-lisp/debug.el" (19636 58496))
+;;;;;; "emacs-lisp/debug.el" (19580 19536))
;;; Generated autoloads from emacs-lisp/debug.el
(setq debugger 'debug)
@@ -5497,7 +5449,7 @@ To specify a nil argument interactively, exit with an empty minibuffer.
;;;***
;;;### (autoloads (decipher-mode decipher) "decipher" "play/decipher.el"
-;;;;;; (19636 58496))
+;;;;;; (19670 666))
;;; Generated autoloads from play/decipher.el
(autoload 'decipher "decipher" "\
@@ -5526,8 +5478,8 @@ The most useful commands are:
;;;***
;;;### (autoloads (delimit-columns-rectangle delimit-columns-region
-;;;;;; delimit-columns-customize) "delim-col" "delim-col.el" (19636
-;;;;;; 58496))
+;;;;;; delimit-columns-customize) "delim-col" "delim-col.el" (19324
+;;;;;; 55755))
;;; Generated autoloads from delim-col.el
(autoload 'delimit-columns-customize "delim-col" "\
@@ -5551,8 +5503,8 @@ START and END delimits the corners of text rectangle.
;;;***
-;;;### (autoloads (delphi-mode) "delphi" "progmodes/delphi.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (delphi-mode) "delphi" "progmodes/delphi.el" (19519
+;;;;;; 16431))
;;; Generated autoloads from progmodes/delphi.el
(autoload 'delphi-mode "delphi" "\
@@ -5603,8 +5555,8 @@ no args, if that value is non-nil.
;;;***
-;;;### (autoloads (delete-selection-mode) "delsel" "delsel.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (delete-selection-mode) "delsel" "delsel.el" (19277
+;;;;;; 34915))
;;; Generated autoloads from delsel.el
(defalias 'pending-delete-mode 'delete-selection-mode)
@@ -5633,7 +5585,7 @@ any selection.
;;;***
;;;### (autoloads (derived-mode-init-mode-variables define-derived-mode)
-;;;;;; "derived" "emacs-lisp/derived.el" (19636 58496))
+;;;;;; "derived" "emacs-lisp/derived.el" (19580 19536))
;;; Generated autoloads from emacs-lisp/derived.el
(autoload 'define-derived-mode "derived" "\
@@ -5687,6 +5639,8 @@ See Info node `(elisp)Derived Modes' for more details.
\(fn CHILD PARENT NAME &optional DOCSTRING &rest BODY)" nil (quote macro))
+(put 'define-derived-mode 'doc-string-elt '4)
+
(autoload 'derived-mode-init-mode-variables "derived" "\
Initialize variables for a new MODE.
Right now, if they don't already exist, set up a blank keymap, an
@@ -5698,7 +5652,7 @@ the first time the mode is used.
;;;***
;;;### (autoloads (describe-char describe-text-properties) "descr-text"
-;;;;;; "descr-text.el" (19636 58496))
+;;;;;; "descr-text.el" (19515 27412))
;;; Generated autoloads from descr-text.el
(autoload 'describe-text-properties "descr-text" "\
@@ -5726,7 +5680,7 @@ as well as widgets, buttons, overlays, and text properties.
;;;### (autoloads (desktop-revert desktop-save-in-desktop-dir desktop-change-dir
;;;;;; desktop-load-default desktop-read desktop-remove desktop-save
;;;;;; desktop-clear desktop-locals-to-save desktop-save-mode) "desktop"
-;;;;;; "desktop.el" (19636 58496))
+;;;;;; "desktop.el" (19590 30214))
;;; Generated autoloads from desktop.el
(defvar desktop-save-mode nil "\
@@ -5910,7 +5864,7 @@ Revert to the last loaded desktop.
;;;### (autoloads (gnus-article-outlook-deuglify-article gnus-outlook-deuglify-article
;;;;;; gnus-article-outlook-repair-attribution gnus-article-outlook-unwrap-lines)
-;;;;;; "deuglify" "gnus/deuglify.el" (19636 58496))
+;;;;;; "deuglify" "gnus/deuglify.el" (19582 65302))
;;; Generated autoloads from gnus/deuglify.el
(autoload 'gnus-article-outlook-unwrap-lines "deuglify" "\
@@ -5943,7 +5897,7 @@ Deuglify broken Outlook (Express) articles and redisplay.
;;;***
;;;### (autoloads (diary-mode diary-mail-entries diary) "diary-lib"
-;;;;;; "calendar/diary-lib.el" (19636 58496))
+;;;;;; "calendar/diary-lib.el" (19696 27153))
;;; Generated autoloads from calendar/diary-lib.el
(autoload 'diary "diary-lib" "\
@@ -5985,9 +5939,9 @@ Major mode for editing the diary file.
;;;***
-;;;### (autoloads (diff-backup diff diff-command diff-switches) "diff"
-;;;;;; "diff.el" (19636 58496))
-;;; Generated autoloads from diff.el
+;;;### (autoloads (diff-buffer-with-file diff-backup diff diff-command
+;;;;;; diff-switches) "diff" "vc/diff.el" (19695 9667))
+;;; Generated autoloads from vc/diff.el
(defvar diff-switches (purecopy "-c") "\
A string or list of strings specifying switches to be passed to diff.")
@@ -6021,11 +5975,17 @@ With prefix arg, prompt for diff switches.
\(fn FILE &optional SWITCHES)" t nil)
+(autoload 'diff-buffer-with-file "diff" "\
+View the differences between BUFFER and its associated file.
+This requires the external program `diff' to be in your `exec-path'.
+
+\(fn &optional BUFFER)" t nil)
+
;;;***
-;;;### (autoloads (diff-minor-mode diff-mode) "diff-mode" "diff-mode.el"
-;;;;;; (19661 51722))
-;;; Generated autoloads from diff-mode.el
+;;;### (autoloads (diff-minor-mode diff-mode) "diff-mode" "vc/diff-mode.el"
+;;;;;; (19552 37739))
+;;; Generated autoloads from vc/diff-mode.el
(autoload 'diff-mode "diff-mode" "\
Major mode for viewing/editing context diffs.
@@ -6052,7 +6012,7 @@ Minor mode for viewing/editing context diffs.
;;;***
-;;;### (autoloads (dig) "dig" "net/dig.el" (19636 58496))
+;;;### (autoloads (dig) "dig" "net/dig.el" (19634 23255))
;;; Generated autoloads from net/dig.el
(autoload 'dig "dig" "\
@@ -6065,7 +6025,7 @@ Optional arguments are passed to `dig-invoke'.
;;;### (autoloads (dired-mode dired-auto-revert-buffer dired-noselect
;;;;;; dired-other-frame dired-other-window dired dired-trivial-filenames
-;;;;;; dired-listing-switches) "dired" "dired.el" (19636 58496))
+;;;;;; dired-listing-switches) "dired" "dired.el" (19673 45510))
;;; Generated autoloads from dired.el
(defvar dired-listing-switches (purecopy "-al") "\
@@ -6079,7 +6039,7 @@ some of the `ls' switches are not supported; see the doc string of
(custom-autoload 'dired-listing-switches "dired" t)
-(defvar dired-chown-program (purecopy (if (memq system-type '(hpux usg-unix-v irix linux gnu/linux cygwin)) "chown" (if (file-exists-p "/usr/sbin/chown") "/usr/sbin/chown" "/etc/chown"))) "\
+(defvar dired-chown-program (purecopy (if (memq system-type '(hpux usg-unix-v irix gnu/linux cygwin)) "chown" (if (file-exists-p "/usr/sbin/chown") "/usr/sbin/chown" "/etc/chown"))) "\
Name of chown command (usually `chown' or `/etc/chown').")
(defvar dired-trivial-filenames (purecopy "^\\.\\.?$\\|^#") "\
@@ -6210,7 +6170,7 @@ Keybindings:
;;;***
;;;### (autoloads (dirtrack dirtrack-mode) "dirtrack" "dirtrack.el"
-;;;;;; (19636 58496))
+;;;;;; (19674 7816))
;;; Generated autoloads from dirtrack.el
(autoload 'dirtrack-mode "dirtrack" "\
@@ -6236,8 +6196,8 @@ function `dirtrack-debug-mode' to turn on debugging output.
;;;***
-;;;### (autoloads (disassemble) "disass" "emacs-lisp/disass.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (disassemble) "disass" "emacs-lisp/disass.el" (19277
+;;;;;; 34919))
;;; Generated autoloads from emacs-lisp/disass.el
(autoload 'disassemble "disass" "\
@@ -6256,7 +6216,7 @@ redefine OBJECT if it is a symbol.
;;;;;; standard-display-g1 standard-display-ascii standard-display-default
;;;;;; standard-display-8bit describe-current-display-table describe-display-table
;;;;;; set-display-table-slot display-table-slot make-display-table)
-;;;;;; "disp-table" "disp-table.el" (19636 58496))
+;;;;;; "disp-table" "disp-table.el" (19583 60940))
;;; Generated autoloads from disp-table.el
(autoload 'make-display-table "disp-table" "\
@@ -6378,7 +6338,7 @@ in `.emacs'.
;;;***
;;;### (autoloads (dissociated-press) "dissociate" "play/dissociate.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34922))
;;; Generated autoloads from play/dissociate.el
(autoload 'dissociated-press "dissociate" "\
@@ -6394,7 +6354,7 @@ Default is 2.
;;;***
-;;;### (autoloads (dnd-protocol-alist) "dnd" "dnd.el" (19636 58496))
+;;;### (autoloads (dnd-protocol-alist) "dnd" "dnd.el" (19631 26857))
;;; Generated autoloads from dnd.el
(defvar dnd-protocol-alist `((,(purecopy "^file:///") . dnd-open-local-file) (,(purecopy "^file://") . dnd-open-file) (,(purecopy "^file:") . dnd-open-local-file) (,(purecopy "^\\(https?\\|ftp\\|file\\|nfs\\)://") . dnd-open-file)) "\
@@ -6415,7 +6375,7 @@ if some action was made, or nil if the URL is ignored.")
;;;***
;;;### (autoloads (dns-mode-soa-increment-serial dns-mode) "dns-mode"
-;;;;;; "textmodes/dns-mode.el" (19636 58496))
+;;;;;; "textmodes/dns-mode.el" (19611 36311))
;;; Generated autoloads from textmodes/dns-mode.el
(autoload 'dns-mode "dns-mode" "\
@@ -6435,12 +6395,11 @@ Turning on DNS mode runs `dns-mode-hook'.
Locate SOA record and increment the serial field.
\(fn)" t nil)
-(add-to-list 'auto-mode-alist (purecopy '("\\.soa\\'" . dns-mode)))
;;;***
;;;### (autoloads (doc-view-bookmark-jump doc-view-minor-mode doc-view-mode
-;;;;;; doc-view-mode-p) "doc-view" "doc-view.el" (19636 58496))
+;;;;;; doc-view-mode-p) "doc-view" "doc-view.el" (19519 16431))
;;; Generated autoloads from doc-view.el
(autoload 'doc-view-mode-p "doc-view" "\
@@ -6475,7 +6434,7 @@ Not documented
;;;***
-;;;### (autoloads (doctor) "doctor" "play/doctor.el" (19636 58496))
+;;;### (autoloads (doctor) "doctor" "play/doctor.el" (19696 28661))
;;; Generated autoloads from play/doctor.el
(autoload 'doctor "doctor" "\
@@ -6485,7 +6444,7 @@ Switch to *doctor* buffer and start giving psychotherapy.
;;;***
-;;;### (autoloads (double-mode) "double" "double.el" (19636 58496))
+;;;### (autoloads (double-mode) "double" "double.el" (19277 34916))
;;; Generated autoloads from double.el
(autoload 'double-mode "double" "\
@@ -6500,7 +6459,7 @@ when pressed twice. See variable `double-map' for details.
;;;***
-;;;### (autoloads (dunnet) "dunnet" "play/dunnet.el" (19636 58496))
+;;;### (autoloads (dunnet) "dunnet" "play/dunnet.el" (19277 34922))
;;; Generated autoloads from play/dunnet.el
(autoload 'dunnet "dunnet" "\
@@ -6510,20 +6469,9 @@ Switch to *dungeon* buffer and start game.
;;;***
-;;;### (autoloads (gnus-earcon-display) "earcon" "gnus/earcon.el"
-;;;;;; (19636 58496))
-;;; Generated autoloads from gnus/earcon.el
-
-(autoload 'gnus-earcon-display "earcon" "\
-Play sounds in message buffers.
-
-\(fn)" t nil)
-
-;;;***
-
;;;### (autoloads (easy-mmode-defsyntax easy-mmode-defmap easy-mmode-define-keymap
;;;;;; define-globalized-minor-mode define-minor-mode) "easy-mmode"
-;;;;;; "emacs-lisp/easy-mmode.el" (19636 58496))
+;;;;;; "emacs-lisp/easy-mmode.el" (19658 807))
;;; Generated autoloads from emacs-lisp/easy-mmode.el
(defalias 'easy-mmode-define-minor-mode 'define-minor-mode)
@@ -6558,6 +6506,12 @@ BODY contains code to execute each time the mode is enabled or disabled.
:lighter SPEC Same as the LIGHTER argument.
:keymap MAP Same as the KEYMAP argument.
:require SYM Same as in `defcustom'.
+:variable PLACE The location (as can be used with `setf') to use instead
+ of the variable MODE to store the state of the mode. PLACE
+ can also be of the form (GET . SET) where GET is an expression
+ that returns the current state and SET is a function that takes
+ a new state and sets it. If you specify a :variable, this
+ function assumes it is defined elsewhere.
For example, you could write
(define-minor-mode foo-mode \"If enabled, foo on you!\"
@@ -6626,12 +6580,10 @@ CSS contains a list of syntax specifications of the form (CHAR . SYNTAX).
;;;***
;;;### (autoloads (easy-menu-change easy-menu-create-menu easy-menu-do-define
-;;;;;; easy-menu-define) "easymenu" "emacs-lisp/easymenu.el" (19636
-;;;;;; 58496))
+;;;;;; easy-menu-define) "easymenu" "emacs-lisp/easymenu.el" (19580
+;;;;;; 19536))
;;; Generated autoloads from emacs-lisp/easymenu.el
-(put 'easy-menu-define 'lisp-indent-function 'defun)
-
(autoload 'easy-menu-define "easymenu" "\
Define a menu bar submenu in maps MAPS, according to MENU.
@@ -6740,6 +6692,8 @@ A menu item can be a list with the same format as MENU. This is a submenu.
\(fn SYMBOL MAPS DOC MENU)" nil (quote macro))
+(put 'easy-menu-define 'lisp-indent-function 'defun)
+
(autoload 'easy-menu-do-define "easymenu" "\
Not documented
@@ -6781,7 +6735,7 @@ To implement dynamic menus, either call this from
;;;;;; ebnf-eps-file ebnf-eps-directory ebnf-spool-region ebnf-spool-buffer
;;;;;; ebnf-spool-file ebnf-spool-directory ebnf-print-region ebnf-print-buffer
;;;;;; ebnf-print-file ebnf-print-directory ebnf-customize) "ebnf2ps"
-;;;;;; "progmodes/ebnf2ps.el" (19636 58496))
+;;;;;; "progmodes/ebnf2ps.el" (19668 19251))
;;; Generated autoloads from progmodes/ebnf2ps.el
(autoload 'ebnf-customize "ebnf2ps" "\
@@ -7055,8 +7009,8 @@ See `ebnf-style-database' documentation.
;;;;;; ebrowse-tags-find-declaration-other-window ebrowse-tags-find-definition
;;;;;; ebrowse-tags-view-definition ebrowse-tags-find-declaration
;;;;;; ebrowse-tags-view-declaration ebrowse-member-mode ebrowse-electric-choose-tree
-;;;;;; ebrowse-tree-mode) "ebrowse" "progmodes/ebrowse.el" (19636
-;;;;;; 58496))
+;;;;;; ebrowse-tree-mode) "ebrowse" "progmodes/ebrowse.el" (19668
+;;;;;; 19022))
;;; Generated autoloads from progmodes/ebrowse.el
(autoload 'ebrowse-tree-mode "ebrowse" "\
@@ -7207,7 +7161,7 @@ Display statistics for a class tree.
;;;***
;;;### (autoloads (electric-buffer-list) "ebuff-menu" "ebuff-menu.el"
-;;;;;; (19636 58496))
+;;;;;; (19668 18204))
;;; Generated autoloads from ebuff-menu.el
(autoload 'electric-buffer-list "ebuff-menu" "\
@@ -7232,7 +7186,7 @@ Run hooks in `electric-buffer-menu-mode-hook' on entry.
;;;***
;;;### (autoloads (Electric-command-history-redo-expression) "echistory"
-;;;;;; "echistory.el" (19636 58496))
+;;;;;; "echistory.el" (19277 34916))
;;; Generated autoloads from echistory.el
(autoload 'Electric-command-history-redo-expression "echistory" "\
@@ -7244,7 +7198,7 @@ With prefix arg NOCONFIRM, execute current line as-is without editing.
;;;***
;;;### (autoloads (ecomplete-setup) "ecomplete" "gnus/ecomplete.el"
-;;;;;; (19636 58496))
+;;;;;; (19672 47597))
;;; Generated autoloads from gnus/ecomplete.el
(autoload 'ecomplete-setup "ecomplete" "\
@@ -7254,7 +7208,7 @@ Not documented
;;;***
-;;;### (autoloads (global-ede-mode) "ede" "cedet/ede.el" (19636 58496))
+;;;### (autoloads (global-ede-mode) "ede" "cedet/ede.el" (19662 23507))
;;; Generated autoloads from cedet/ede.el
(defvar global-ede-mode nil "\
@@ -7280,7 +7234,7 @@ an EDE controlled project.
;;;### (autoloads (edebug-all-forms edebug-all-defs edebug-eval-top-level-form
;;;;;; edebug-basic-spec edebug-all-forms edebug-all-defs) "edebug"
-;;;;;; "emacs-lisp/edebug.el" (19636 58496))
+;;;;;; "emacs-lisp/edebug.el" (19668 19725))
;;; Generated autoloads from emacs-lisp/edebug.el
(defvar edebug-all-defs nil "\
@@ -7353,8 +7307,8 @@ Toggle edebugging of all forms.
;;;;;; ediff-merge-directories-with-ancestor ediff-merge-directories
;;;;;; ediff-directories3 ediff-directory-revisions ediff-directories
;;;;;; ediff-buffers3 ediff-buffers ediff-backup ediff-current-file
-;;;;;; ediff-files3 ediff-files) "ediff" "ediff.el" (19636 58496))
-;;; Generated autoloads from ediff.el
+;;;;;; ediff-files3 ediff-files) "ediff" "vc/ediff.el" (19580 19536))
+;;; Generated autoloads from vc/ediff.el
(autoload 'ediff-files "ediff" "\
Run Ediff on a pair of files, FILE-A and FILE-B.
@@ -7584,9 +7538,9 @@ With optional NODE, goes to that node.
;;;***
-;;;### (autoloads (ediff-customize) "ediff-help" "ediff-help.el"
-;;;;;; (19636 58496))
-;;; Generated autoloads from ediff-help.el
+;;;### (autoloads (ediff-customize) "ediff-help" "vc/ediff-help.el"
+;;;;;; (19580 19536))
+;;; Generated autoloads from vc/ediff-help.el
(autoload 'ediff-customize "ediff-help" "\
Not documented
@@ -7595,9 +7549,9 @@ Not documented
;;;***
-;;;### (autoloads (ediff-show-registry) "ediff-mult" "ediff-mult.el"
-;;;;;; (19636 58496))
-;;; Generated autoloads from ediff-mult.el
+;;;### (autoloads (ediff-show-registry) "ediff-mult" "vc/ediff-mult.el"
+;;;;;; (19580 19536))
+;;; Generated autoloads from vc/ediff-mult.el
(autoload 'ediff-show-registry "ediff-mult" "\
Display Ediff's registry.
@@ -7609,8 +7563,8 @@ Display Ediff's registry.
;;;***
;;;### (autoloads (ediff-toggle-use-toolbar ediff-toggle-multiframe)
-;;;;;; "ediff-util" "ediff-util.el" (19636 58496))
-;;; Generated autoloads from ediff-util.el
+;;;;;; "ediff-util" "vc/ediff-util.el" (19664 56235))
+;;; Generated autoloads from vc/ediff-util.el
(autoload 'ediff-toggle-multiframe "ediff-util" "\
Switch from multiframe display to single-frame display and back.
@@ -7630,7 +7584,7 @@ To change the default, set the variable `ediff-use-toolbar-p', which see.
;;;### (autoloads (format-kbd-macro read-kbd-macro edit-named-kbd-macro
;;;;;; edit-last-kbd-macro edit-kbd-macro) "edmacro" "edmacro.el"
-;;;;;; (19636 58496))
+;;;;;; (19634 23255))
;;; Generated autoloads from edmacro.el
(defvar edmacro-eight-bits nil "\
@@ -7683,7 +7637,7 @@ or nil, use a compact 80-column format.
;;;***
;;;### (autoloads (edt-emulation-on edt-set-scroll-margins) "edt"
-;;;;;; "emulation/edt.el" (19636 58496))
+;;;;;; "emulation/edt.el" (19674 11425))
;;; Generated autoloads from emulation/edt.el
(autoload 'edt-set-scroll-margins "edt" "\
@@ -7701,7 +7655,7 @@ Turn on EDT Emulation.
;;;***
;;;### (autoloads (electric-helpify with-electric-help) "ehelp" "ehelp.el"
-;;;;;; (19636 58496))
+;;;;;; (19391 30349))
;;; Generated autoloads from ehelp.el
(autoload 'with-electric-help "ehelp" "\
@@ -7726,7 +7680,7 @@ If THUNK returns non-nil, we don't do those things.
When the user exits (with `electric-help-exit', or otherwise), the help
buffer's window disappears (i.e., we use `save-window-excursion'), and
-BUFFER is put into default `major-mode' (or `fundamental-mode').
+BUFFER is put back into its original major mode.
\(fn THUNK &optional BUFFER NOERASE MINHEIGHT)" nil nil)
@@ -7738,7 +7692,7 @@ Not documented
;;;***
;;;### (autoloads (turn-on-eldoc-mode eldoc-mode eldoc-minor-mode-string)
-;;;;;; "eldoc" "emacs-lisp/eldoc.el" (19636 58496))
+;;;;;; "eldoc" "emacs-lisp/eldoc.el" (19462 38192))
;;; Generated autoloads from emacs-lisp/eldoc.el
(defvar eldoc-minor-mode-string (purecopy " ElDoc") "\
@@ -7781,8 +7735,60 @@ Emacs Lisp mode) that support ElDoc.")
;;;***
-;;;### (autoloads (elide-head) "elide-head" "elide-head.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (electric-layout-mode electric-pair-mode electric-indent-mode)
+;;;;;; "electric" "electric.el" (19687 6902))
+;;; Generated autoloads from electric.el
+
+(defvar electric-indent-chars '(10) "\
+Characters that should cause automatic reindentation.")
+
+(defvar electric-indent-mode nil "\
+Non-nil if Electric-Indent mode is enabled.
+See the command `electric-indent-mode' for a description of this minor mode.
+Setting this variable directly does not take effect;
+either customize it (see the info node `Easy Customization')
+or call the function `electric-indent-mode'.")
+
+(custom-autoload 'electric-indent-mode "electric" nil)
+
+(autoload 'electric-indent-mode "electric" "\
+Automatically reindent lines of code when inserting particular chars.
+`electric-indent-chars' specifies the set of chars that should cause reindentation.
+
+\(fn &optional ARG)" t nil)
+
+(defvar electric-pair-mode nil "\
+Non-nil if Electric-Pair mode is enabled.
+See the command `electric-pair-mode' for a description of this minor mode.
+Setting this variable directly does not take effect;
+either customize it (see the info node `Easy Customization')
+or call the function `electric-pair-mode'.")
+
+(custom-autoload 'electric-pair-mode "electric" nil)
+
+(autoload 'electric-pair-mode "electric" "\
+Automatically pair-up parens when inserting an open paren.
+
+\(fn &optional ARG)" t nil)
+
+(defvar electric-layout-mode nil "\
+Non-nil if Electric-Layout mode is enabled.
+See the command `electric-layout-mode' for a description of this minor mode.
+Setting this variable directly does not take effect;
+either customize it (see the info node `Easy Customization')
+or call the function `electric-layout-mode'.")
+
+(custom-autoload 'electric-layout-mode "electric" nil)
+
+(autoload 'electric-layout-mode "electric" "\
+Automatically insert newlines around some chars.
+
+\(fn &optional ARG)" t nil)
+
+;;;***
+
+;;;### (autoloads (elide-head) "elide-head" "elide-head.el" (19277
+;;;;;; 34916))
;;; Generated autoloads from elide-head.el
(autoload 'elide-head "elide-head" "\
@@ -7799,7 +7805,7 @@ This is suitable as an entry on `find-file-hook' or appropriate mode hooks.
;;;### (autoloads (elint-initialize elint-defun elint-current-buffer
;;;;;; elint-directory elint-file) "elint" "emacs-lisp/elint.el"
-;;;;;; (19636 58496))
+;;;;;; (19668 31925))
;;; Generated autoloads from emacs-lisp/elint.el
(autoload 'elint-file "elint" "\
@@ -7835,8 +7841,8 @@ optional prefix argument REINIT is non-nil.
;;;***
;;;### (autoloads (elp-results elp-instrument-package elp-instrument-list
-;;;;;; elp-instrument-function) "elp" "emacs-lisp/elp.el" (19636
-;;;;;; 58496))
+;;;;;; elp-instrument-function) "elp" "emacs-lisp/elp.el" (19277
+;;;;;; 34919))
;;; Generated autoloads from emacs-lisp/elp.el
(autoload 'elp-instrument-function "elp" "\
@@ -7871,7 +7877,7 @@ displayed.
;;;***
;;;### (autoloads (report-emacs-bug) "emacsbug" "mail/emacsbug.el"
-;;;;;; (19641 1152))
+;;;;;; (19696 28661))
;;; Generated autoloads from mail/emacsbug.el
(autoload 'report-emacs-bug "emacsbug" "\
@@ -7886,8 +7892,8 @@ Prompts for bug subject. Leaves you in a mail buffer.
;;;;;; emerge-revisions emerge-files-with-ancestor-remote emerge-files-remote
;;;;;; emerge-files-with-ancestor-command emerge-files-command emerge-buffers-with-ancestor
;;;;;; emerge-buffers emerge-files-with-ancestor emerge-files) "emerge"
-;;;;;; "emerge.el" (19636 58496))
-;;; Generated autoloads from emerge.el
+;;;;;; "vc/emerge.el" (19672 56753))
+;;; Generated autoloads from vc/emerge.el
(autoload 'emerge-files "emerge" "\
Run Emerge on two files.
@@ -7947,7 +7953,7 @@ Not documented
;;;***
;;;### (autoloads (enriched-decode enriched-encode enriched-mode)
-;;;;;; "enriched" "textmodes/enriched.el" (19636 58496))
+;;;;;; "enriched" "textmodes/enriched.el" (19609 2751))
;;; Generated autoloads from textmodes/enriched.el
(autoload 'enriched-mode "enriched" "\
@@ -7982,8 +7988,8 @@ Not documented
;;;;;; epa-sign-region epa-verify-cleartext-in-region epa-verify-region
;;;;;; epa-decrypt-armor-in-region epa-decrypt-region epa-encrypt-file
;;;;;; epa-sign-file epa-verify-file epa-decrypt-file epa-select-keys
-;;;;;; epa-list-secret-keys epa-list-keys) "epa" "epa.el" (19636
-;;;;;; 58496))
+;;;;;; epa-list-secret-keys epa-list-keys) "epa" "epa.el" (19672
+;;;;;; 56753))
;;; Generated autoloads from epa.el
(autoload 'epa-list-keys "epa" "\
@@ -8156,7 +8162,7 @@ Insert selected KEYS after the point.
;;;***
;;;### (autoloads (epa-dired-do-encrypt epa-dired-do-sign epa-dired-do-verify
-;;;;;; epa-dired-do-decrypt) "epa-dired" "epa-dired.el" (19636 58496))
+;;;;;; epa-dired-do-decrypt) "epa-dired" "epa-dired.el" (19580 19536))
;;; Generated autoloads from epa-dired.el
(autoload 'epa-dired-do-decrypt "epa-dired" "\
@@ -8182,7 +8188,7 @@ Encrypt marked files.
;;;***
;;;### (autoloads (epa-file-disable epa-file-enable epa-file-handler)
-;;;;;; "epa-file" "epa-file.el" (19636 58496))
+;;;;;; "epa-file" "epa-file.el" (19634 14572))
;;; Generated autoloads from epa-file.el
(autoload 'epa-file-handler "epa-file" "\
@@ -8204,7 +8210,7 @@ Not documented
;;;### (autoloads (epa-global-mail-mode epa-mail-import-keys epa-mail-encrypt
;;;;;; epa-mail-sign epa-mail-verify epa-mail-decrypt epa-mail-mode)
-;;;;;; "epa-mail" "epa-mail.el" (19636 58496))
+;;;;;; "epa-mail" "epa-mail.el" (19654 15628))
;;; Generated autoloads from epa-mail.el
(autoload 'epa-mail-mode "epa-mail" "\
@@ -8268,7 +8274,7 @@ Minor mode to hook EasyPG into Mail mode.
;;;***
-;;;### (autoloads (epg-make-context) "epg" "epg.el" (19636 58496))
+;;;### (autoloads (epg-make-context) "epg" "epg.el" (19580 19536))
;;; Generated autoloads from epg.el
(autoload 'epg-make-context "epg" "\
@@ -8279,7 +8285,7 @@ Return a context object.
;;;***
;;;### (autoloads (epg-expand-group epg-check-configuration epg-configuration)
-;;;;;; "epg-config" "epg-config.el" (19636 58496))
+;;;;;; "epg-config" "epg-config.el" (19652 41479))
;;; Generated autoloads from epg-config.el
(autoload 'epg-configuration "epg-config" "\
@@ -8300,7 +8306,7 @@ Look at CONFIG and try to expand GROUP.
;;;***
;;;### (autoloads (erc-handle-irc-url erc erc-select-read-args) "erc"
-;;;;;; "erc/erc.el" (19636 58496))
+;;;;;; "erc/erc.el" (19580 19536))
;;; Generated autoloads from erc/erc.el
(autoload 'erc-select-read-args "erc" "\
@@ -8342,33 +8348,33 @@ Otherwise, connect to HOST:PORT as USER and /join CHANNEL.
;;;***
-;;;### (autoloads nil "erc-autoaway" "erc/erc-autoaway.el" (19636
-;;;;;; 58496))
+;;;### (autoloads nil "erc-autoaway" "erc/erc-autoaway.el" (19277
+;;;;;; 34919))
;;; Generated autoloads from erc/erc-autoaway.el
(autoload 'erc-autoaway-mode "erc-autoaway")
;;;***
-;;;### (autoloads nil "erc-button" "erc/erc-button.el" (19636 58496))
+;;;### (autoloads nil "erc-button" "erc/erc-button.el" (19277 34919))
;;; Generated autoloads from erc/erc-button.el
(autoload 'erc-button-mode "erc-button" nil t)
;;;***
-;;;### (autoloads nil "erc-capab" "erc/erc-capab.el" (19636 58496))
+;;;### (autoloads nil "erc-capab" "erc/erc-capab.el" (19277 34919))
;;; Generated autoloads from erc/erc-capab.el
(autoload 'erc-capab-identify-mode "erc-capab" nil t)
;;;***
-;;;### (autoloads nil "erc-compat" "erc/erc-compat.el" (19636 58496))
+;;;### (autoloads nil "erc-compat" "erc/erc-compat.el" (19277 34919))
;;; Generated autoloads from erc/erc-compat.el
(autoload 'erc-define-minor-mode "erc-compat")
;;;***
;;;### (autoloads (erc-ctcp-query-DCC pcomplete/erc-mode/DCC erc-cmd-DCC)
-;;;;;; "erc-dcc" "erc/erc-dcc.el" (19636 58496))
+;;;;;; "erc-dcc" "erc/erc-dcc.el" (19277 34919))
;;; Generated autoloads from erc/erc-dcc.el
(autoload 'erc-dcc-mode "erc-dcc")
@@ -8401,7 +8407,7 @@ that subcommand.
;;;;;; erc-ezb-add-session erc-ezb-end-of-session-list erc-ezb-init-session-list
;;;;;; erc-ezb-identify erc-ezb-notice-autodetect erc-ezb-lookup-action
;;;;;; erc-ezb-get-login erc-cmd-ezb) "erc-ezbounce" "erc/erc-ezbounce.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34919))
;;; Generated autoloads from erc/erc-ezbounce.el
(autoload 'erc-cmd-ezb "erc-ezbounce" "\
@@ -8463,8 +8469,8 @@ Add EZBouncer convenience functions to ERC.
;;;***
-;;;### (autoloads (erc-fill) "erc-fill" "erc/erc-fill.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (erc-fill) "erc-fill" "erc/erc-fill.el" (19277
+;;;;;; 34919))
;;; Generated autoloads from erc/erc-fill.el
(autoload 'erc-fill-mode "erc-fill" nil t)
@@ -8476,15 +8482,15 @@ You can put this on `erc-insert-modify-hook' and/or `erc-send-modify-hook'.
;;;***
-;;;### (autoloads nil "erc-hecomplete" "erc/erc-hecomplete.el" (19636
-;;;;;; 58496))
+;;;### (autoloads nil "erc-hecomplete" "erc/erc-hecomplete.el" (19277
+;;;;;; 34919))
;;; Generated autoloads from erc/erc-hecomplete.el
(autoload 'erc-hecomplete-mode "erc-hecomplete" nil t)
;;;***
;;;### (autoloads (erc-identd-stop erc-identd-start) "erc-identd"
-;;;;;; "erc/erc-identd.el" (19636 58496))
+;;;;;; "erc/erc-identd.el" (19277 34919))
;;; Generated autoloads from erc/erc-identd.el
(autoload 'erc-identd-mode "erc-identd")
@@ -8506,7 +8512,7 @@ Not documented
;;;***
;;;### (autoloads (erc-create-imenu-index) "erc-imenu" "erc/erc-imenu.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34919))
;;; Generated autoloads from erc/erc-imenu.el
(autoload 'erc-create-imenu-index "erc-imenu" "\
@@ -8516,20 +8522,20 @@ Not documented
;;;***
-;;;### (autoloads nil "erc-join" "erc/erc-join.el" (19636 58496))
+;;;### (autoloads nil "erc-join" "erc/erc-join.el" (19561 48711))
;;; Generated autoloads from erc/erc-join.el
(autoload 'erc-autojoin-mode "erc-join" nil t)
;;;***
-;;;### (autoloads nil "erc-list" "erc/erc-list.el" (19636 58496))
+;;;### (autoloads nil "erc-list" "erc/erc-list.el" (19634 23255))
;;; Generated autoloads from erc/erc-list.el
(autoload 'erc-list-mode "erc-list")
;;;***
;;;### (autoloads (erc-save-buffer-in-logs erc-logging-enabled) "erc-log"
-;;;;;; "erc/erc-log.el" (19636 58496))
+;;;;;; "erc/erc-log.el" (19277 34919))
;;; Generated autoloads from erc/erc-log.el
(autoload 'erc-log-mode "erc-log" nil t)
@@ -8561,7 +8567,7 @@ You can save every individual message by putting this function on
;;;### (autoloads (erc-delete-dangerous-host erc-add-dangerous-host
;;;;;; erc-delete-keyword erc-add-keyword erc-delete-fool erc-add-fool
;;;;;; erc-delete-pal erc-add-pal) "erc-match" "erc/erc-match.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34919))
;;; Generated autoloads from erc/erc-match.el
(autoload 'erc-match-mode "erc-match")
@@ -8607,14 +8613,14 @@ Delete dangerous-host interactively to `erc-dangerous-hosts'.
;;;***
-;;;### (autoloads nil "erc-menu" "erc/erc-menu.el" (19636 58496))
+;;;### (autoloads nil "erc-menu" "erc/erc-menu.el" (19277 34919))
;;; Generated autoloads from erc/erc-menu.el
(autoload 'erc-menu-mode "erc-menu" nil t)
;;;***
;;;### (autoloads (erc-cmd-WHOLEFT) "erc-netsplit" "erc/erc-netsplit.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34919))
;;; Generated autoloads from erc/erc-netsplit.el
(autoload 'erc-netsplit-mode "erc-netsplit")
@@ -8626,7 +8632,7 @@ Show who's gone.
;;;***
;;;### (autoloads (erc-server-select erc-determine-network) "erc-networks"
-;;;;;; "erc/erc-networks.el" (19636 58496))
+;;;;;; "erc/erc-networks.el" (19277 34919))
;;; Generated autoloads from erc/erc-networks.el
(autoload 'erc-determine-network "erc-networks" "\
@@ -8644,7 +8650,7 @@ Interactively select a server to connect to using `erc-server-alist'.
;;;***
;;;### (autoloads (pcomplete/erc-mode/NOTIFY erc-cmd-NOTIFY) "erc-notify"
-;;;;;; "erc/erc-notify.el" (19636 58496))
+;;;;;; "erc/erc-notify.el" (19277 34919))
;;; Generated autoloads from erc/erc-notify.el
(autoload 'erc-notify-mode "erc-notify" nil t)
@@ -8662,33 +8668,33 @@ Not documented
;;;***
-;;;### (autoloads nil "erc-page" "erc/erc-page.el" (19636 58496))
+;;;### (autoloads nil "erc-page" "erc/erc-page.el" (19277 34919))
;;; Generated autoloads from erc/erc-page.el
(autoload 'erc-page-mode "erc-page")
;;;***
-;;;### (autoloads nil "erc-pcomplete" "erc/erc-pcomplete.el" (19636
-;;;;;; 58496))
+;;;### (autoloads nil "erc-pcomplete" "erc/erc-pcomplete.el" (19277
+;;;;;; 34919))
;;; Generated autoloads from erc/erc-pcomplete.el
(autoload 'erc-completion-mode "erc-pcomplete" nil t)
;;;***
-;;;### (autoloads nil "erc-replace" "erc/erc-replace.el" (19636 58496))
+;;;### (autoloads nil "erc-replace" "erc/erc-replace.el" (19277 34919))
;;; Generated autoloads from erc/erc-replace.el
(autoload 'erc-replace-mode "erc-replace")
;;;***
-;;;### (autoloads nil "erc-ring" "erc/erc-ring.el" (19636 58496))
+;;;### (autoloads nil "erc-ring" "erc/erc-ring.el" (19277 34919))
;;; Generated autoloads from erc/erc-ring.el
(autoload 'erc-ring-mode "erc-ring" nil t)
;;;***
;;;### (autoloads (erc-nickserv-identify erc-nickserv-identify-mode)
-;;;;;; "erc-services" "erc/erc-services.el" (19636 58496))
+;;;;;; "erc-services" "erc/erc-services.el" (19311 8632))
;;; Generated autoloads from erc/erc-services.el
(autoload 'erc-services-mode "erc-services" nil t)
@@ -8705,14 +8711,14 @@ When called interactively, read the password using `read-passwd'.
;;;***
-;;;### (autoloads nil "erc-sound" "erc/erc-sound.el" (19636 58496))
+;;;### (autoloads nil "erc-sound" "erc/erc-sound.el" (19277 34919))
;;; Generated autoloads from erc/erc-sound.el
(autoload 'erc-sound-mode "erc-sound")
;;;***
;;;### (autoloads (erc-speedbar-browser) "erc-speedbar" "erc/erc-speedbar.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34919))
;;; Generated autoloads from erc/erc-speedbar.el
(autoload 'erc-speedbar-browser "erc-speedbar" "\
@@ -8723,21 +8729,21 @@ This will add a speedbar major display mode.
;;;***
-;;;### (autoloads nil "erc-spelling" "erc/erc-spelling.el" (19636
-;;;;;; 58496))
+;;;### (autoloads nil "erc-spelling" "erc/erc-spelling.el" (19277
+;;;;;; 34919))
;;; Generated autoloads from erc/erc-spelling.el
(autoload 'erc-spelling-mode "erc-spelling" nil t)
;;;***
-;;;### (autoloads nil "erc-stamp" "erc/erc-stamp.el" (19636 58496))
+;;;### (autoloads nil "erc-stamp" "erc/erc-stamp.el" (19277 34919))
;;; Generated autoloads from erc/erc-stamp.el
(autoload 'erc-timestamp-mode "erc-stamp" nil t)
;;;***
;;;### (autoloads (erc-track-minor-mode) "erc-track" "erc/erc-track.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34919))
;;; Generated autoloads from erc/erc-track.el
(defvar erc-track-minor-mode nil "\
@@ -8760,7 +8766,7 @@ module, otherwise the keybindings will not do anything useful.
;;;***
;;;### (autoloads (erc-truncate-buffer erc-truncate-buffer-to-size)
-;;;;;; "erc-truncate" "erc/erc-truncate.el" (19636 58496))
+;;;;;; "erc-truncate" "erc/erc-truncate.el" (19277 34919))
;;; Generated autoloads from erc/erc-truncate.el
(autoload 'erc-truncate-mode "erc-truncate" nil t)
@@ -8780,7 +8786,7 @@ Meant to be used in hooks, like `erc-insert-post-hook'.
;;;***
;;;### (autoloads (erc-xdcc-add-file) "erc-xdcc" "erc/erc-xdcc.el"
-;;;;;; (19641 1152))
+;;;;;; (19639 17158))
;;; Generated autoloads from erc/erc-xdcc.el
(autoload 'erc-xdcc-mode "erc-xdcc")
@@ -8791,8 +8797,8 @@ Add a file to `erc-xdcc-files'.
;;;***
-;;;### (autoloads (eshell-mode) "esh-mode" "eshell/esh-mode.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (eshell-mode) "esh-mode" "eshell/esh-mode.el" (19611
+;;;;;; 64957))
;;; Generated autoloads from eshell/esh-mode.el
(autoload 'eshell-mode "esh-mode" "\
@@ -8804,8 +8810,8 @@ Emacs shell interactive mode.
;;;***
-;;;### (autoloads (eshell-test) "esh-test" "eshell/esh-test.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (eshell-test) "esh-test" "eshell/esh-test.el" (19672
+;;;;;; 39436))
;;; Generated autoloads from eshell/esh-test.el
(autoload 'eshell-test "esh-test" "\
@@ -8816,7 +8822,7 @@ Test Eshell to verify that it works as expected.
;;;***
;;;### (autoloads (eshell-command-result eshell-command eshell) "eshell"
-;;;;;; "eshell/eshell.el" (19636 58496))
+;;;;;; "eshell/eshell.el" (19451 17238))
;;; Generated autoloads from eshell/eshell.el
(autoload 'eshell "eshell" "\
@@ -8857,7 +8863,7 @@ corresponding to a successful execution.
;;;;;; visit-tags-table tags-table-mode find-tag-default-function
;;;;;; find-tag-hook tags-add-tables tags-compression-info-list
;;;;;; tags-table-list tags-case-fold-search) "etags" "progmodes/etags.el"
-;;;;;; (19636 58496))
+;;;;;; (19672 56753))
;;; Generated autoloads from progmodes/etags.el
(defvar tags-file-name nil "\
@@ -8866,6 +8872,7 @@ To switch to a new tags table, setting this variable is sufficient.
If you set this variable, do not also set `tags-table-list'.
Use the `etags' program to make a tags table file.")
(put 'tags-file-name 'variable-interactive (purecopy "fVisit tags table: "))
+ (put 'tags-file-name 'safe-local-variable 'stringp)
(defvar tags-case-fold-search 'default "\
*Whether tags operations should be case-sensitive.
@@ -8883,7 +8890,7 @@ Use the `etags' program to make a tags table file.")
(custom-autoload 'tags-table-list "etags" t)
-(defvar tags-compression-info-list (purecopy '("" ".Z" ".bz2" ".gz" ".tgz")) "\
+(defvar tags-compression-info-list (purecopy '("" ".Z" ".bz2" ".gz" ".xz" ".tgz")) "\
*List of extensions tried by etags when jka-compr is used.
An empty string means search the non-compressed file.
These extensions will be tried only if jka-compr was activated
@@ -8952,6 +8959,11 @@ as they appeared in the `etags' command that created the table, usually
without directory names.
\(fn)" nil nil)
+ (defun tags-completion-at-point-function ()
+ (if (or tags-table-list tags-file-name)
+ (progn
+ (load "etags")
+ (tags-completion-at-point-function))))
(autoload 'find-tag-noselect "etags" "\
Find tag (in current tags table) whose name contains TAGNAME.
@@ -9165,7 +9177,7 @@ for \\[find-tag] (which see).
;;;;;; ethio-fidel-to-sera-marker ethio-fidel-to-sera-region ethio-fidel-to-sera-buffer
;;;;;; ethio-sera-to-fidel-marker ethio-sera-to-fidel-region ethio-sera-to-fidel-buffer
;;;;;; setup-ethiopic-environment-internal) "ethio-util" "language/ethio-util.el"
-;;;;;; (19636 58496))
+;;;;;; (19451 17238))
;;; Generated autoloads from language/ethio-util.el
(autoload 'setup-ethiopic-environment-internal "ethio-util" "\
@@ -9335,7 +9347,7 @@ Not documented
;;;### (autoloads (eudc-load-eudc eudc-query-form eudc-expand-inline
;;;;;; eudc-get-phone eudc-get-email eudc-set-server) "eudc" "net/eudc.el"
-;;;;;; (19636 58496))
+;;;;;; (19672 56753))
;;; Generated autoloads from net/eudc.el
(autoload 'eudc-set-server "eudc" "\
@@ -9391,7 +9403,7 @@ This does nothing except loading eudc by autoload side-effect.
;;;### (autoloads (eudc-display-jpeg-as-button eudc-display-jpeg-inline
;;;;;; eudc-display-sound eudc-display-mail eudc-display-url eudc-display-generic-binary)
-;;;;;; "eudc-bob" "net/eudc-bob.el" (19636 58496))
+;;;;;; "eudc-bob" "net/eudc-bob.el" (19580 19536))
;;; Generated autoloads from net/eudc-bob.el
(autoload 'eudc-display-generic-binary "eudc-bob" "\
@@ -9427,7 +9439,7 @@ Display a button for the JPEG DATA.
;;;***
;;;### (autoloads (eudc-try-bbdb-insert eudc-insert-record-at-point-into-bbdb)
-;;;;;; "eudc-export" "net/eudc-export.el" (19636 58496))
+;;;;;; "eudc-export" "net/eudc-export.el" (19580 19536))
;;; Generated autoloads from net/eudc-export.el
(autoload 'eudc-insert-record-at-point-into-bbdb "eudc-export" "\
@@ -9444,7 +9456,7 @@ Call `eudc-insert-record-at-point-into-bbdb' if on a record.
;;;***
;;;### (autoloads (eudc-edit-hotlist) "eudc-hotlist" "net/eudc-hotlist.el"
-;;;;;; (19636 58496))
+;;;;;; (19634 23255))
;;; Generated autoloads from net/eudc-hotlist.el
(autoload 'eudc-edit-hotlist "eudc-hotlist" "\
@@ -9454,8 +9466,8 @@ Edit the hotlist of directory servers in a specialized buffer.
;;;***
-;;;### (autoloads (ewoc-create) "ewoc" "emacs-lisp/ewoc.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (ewoc-create) "ewoc" "emacs-lisp/ewoc.el" (19277
+;;;;;; 34919))
;;; Generated autoloads from emacs-lisp/ewoc.el
(autoload 'ewoc-create "ewoc" "\
@@ -9484,7 +9496,7 @@ fourth arg NOSEP non-nil inhibits this.
;;;### (autoloads (executable-make-buffer-file-executable-if-script-p
;;;;;; executable-self-display executable-set-magic executable-interpret
;;;;;; executable-command-find-posix-p) "executable" "progmodes/executable.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34922))
;;; Generated autoloads from progmodes/executable.el
(autoload 'executable-command-find-posix-p "executable" "\
@@ -9527,7 +9539,7 @@ file modes.
;;;### (autoloads (expand-jump-to-next-slot expand-jump-to-previous-slot
;;;;;; expand-abbrev-hook expand-add-abbrevs) "expand" "expand.el"
-;;;;;; (19636 58496))
+;;;;;; (19451 17238))
;;; Generated autoloads from expand.el
(autoload 'expand-add-abbrevs "expand" "\
@@ -9576,7 +9588,7 @@ This is used only in conjunction with `expand-add-abbrevs'.
;;;***
-;;;### (autoloads (f90-mode) "f90" "progmodes/f90.el" (19636 58496))
+;;;### (autoloads (f90-mode) "f90" "progmodes/f90.el" (19651 33965))
;;; Generated autoloads from progmodes/f90.el
(autoload 'f90-mode "f90" "\
@@ -9643,7 +9655,7 @@ with no args, if that value is non-nil.
;;;;;; buffer-face-mode text-scale-adjust text-scale-decrease text-scale-increase
;;;;;; text-scale-set face-remap-set-base face-remap-reset-base
;;;;;; face-remap-add-relative) "face-remap" "face-remap.el" (19652
-;;;;;; 24589))
+;;;;;; 44405))
;;; Generated autoloads from face-remap.el
(autoload 'face-remap-add-relative "face-remap" "\
@@ -9783,7 +9795,7 @@ Besides the choice of face, it is the same as `buffer-face-mode'.
;;;### (autoloads (feedmail-queue-reminder feedmail-run-the-queue
;;;;;; feedmail-run-the-queue-global-prompt feedmail-run-the-queue-no-prompts
-;;;;;; feedmail-send-it) "feedmail" "mail/feedmail.el" (19636 58496))
+;;;;;; feedmail-send-it) "feedmail" "mail/feedmail.el" (19609 2433))
;;; Generated autoloads from mail/feedmail.el
(autoload 'feedmail-send-it "feedmail" "\
@@ -9837,7 +9849,7 @@ you can set `feedmail-queue-reminder-alist' to nil.
;;;***
;;;### (autoloads (ffap-bindings dired-at-point ffap-at-mouse ffap-menu
-;;;;;; find-file-at-point ffap-next) "ffap" "ffap.el" (19636 58496))
+;;;;;; find-file-at-point ffap-next) "ffap" "ffap.el" (19318 65023))
;;; Generated autoloads from ffap.el
(autoload 'ffap-next "ffap" "\
@@ -9901,7 +9913,7 @@ Evaluate the forms in variable `ffap-bindings'.
;;;### (autoloads (file-cache-minibuffer-complete file-cache-add-directory-recursively
;;;;;; file-cache-add-directory-using-locate file-cache-add-directory-using-find
;;;;;; file-cache-add-file file-cache-add-directory-list file-cache-add-directory)
-;;;;;; "filecache" "filecache.el" (19636 58496))
+;;;;;; "filecache" "filecache.el" (19672 41839))
;;; Generated autoloads from filecache.el
(autoload 'file-cache-add-directory "filecache" "\
@@ -9961,7 +9973,7 @@ the name is considered already unique; only the second substitution
;;;;;; copy-file-locals-to-dir-locals delete-dir-local-variable
;;;;;; add-dir-local-variable delete-file-local-variable-prop-line
;;;;;; add-file-local-variable-prop-line delete-file-local-variable
-;;;;;; add-file-local-variable) "files-x" "files-x.el" (19636 58496))
+;;;;;; add-file-local-variable) "files-x" "files-x.el" (19580 19536))
;;; Generated autoloads from files-x.el
(autoload 'add-file-local-variable "files-x" "\
@@ -10026,8 +10038,8 @@ Copy directory-local variables to the -*- line.
;;;***
-;;;### (autoloads (filesets-init) "filesets" "filesets.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (filesets-init) "filesets" "filesets.el" (19611
+;;;;;; 60752))
;;; Generated autoloads from filesets.el
(autoload 'filesets-init "filesets" "\
@@ -10038,7 +10050,7 @@ Set up hooks, load the cache file -- if existing -- and build the menu.
;;;***
-;;;### (autoloads (find-cmd) "find-cmd" "find-cmd.el" (19636 58496))
+;;;### (autoloads (find-cmd) "find-cmd" "find-cmd.el" (19279 53114))
;;; Generated autoloads from find-cmd.el
(autoload 'find-cmd "find-cmd" "\
@@ -10059,7 +10071,7 @@ result is a string that should be ready for the command line.
;;;### (autoloads (find-grep-dired find-name-dired find-dired find-grep-options
;;;;;; find-ls-subdir-switches find-ls-option) "find-dired" "find-dired.el"
-;;;;;; (19636 58496))
+;;;;;; (19379 30332))
;;; Generated autoloads from find-dired.el
(defvar find-ls-option (if (eq system-type 'berkeley-unix) (purecopy '("-ls" . "-gilsb")) (purecopy '("-exec ls -ld {} \\;" . "-ld"))) "\
@@ -10120,7 +10132,7 @@ Thus ARG can also contain additional grep options.
;;;### (autoloads (ff-mouse-find-other-file-other-window ff-mouse-find-other-file
;;;;;; ff-find-other-file ff-get-other-file) "find-file" "find-file.el"
-;;;;;; (19636 58496))
+;;;;;; (19442 62609))
;;; Generated autoloads from find-file.el
(defvar ff-special-constructs `((,(purecopy "^#\\s *\\(include\\|import\\)\\s +[<\"]\\(.*\\)[>\"]") lambda nil (buffer-substring (match-beginning 2) (match-end 2)))) "\
@@ -10214,7 +10226,7 @@ Visit the file you click on in another window.
;;;;;; find-variable find-variable-noselect find-function-other-frame
;;;;;; find-function-other-window find-function find-function-noselect
;;;;;; find-function-search-for-symbol find-library) "find-func"
-;;;;;; "emacs-lisp/find-func.el" (19636 58496))
+;;;;;; "emacs-lisp/find-func.el" (19649 956))
;;; Generated autoloads from emacs-lisp/find-func.el
(autoload 'find-library "find-func" "\
@@ -10369,7 +10381,7 @@ Define some key bindings for the find-function family of functions.
;;;***
;;;### (autoloads (find-lisp-find-dired-filter find-lisp-find-dired-subdirectories
-;;;;;; find-lisp-find-dired) "find-lisp" "find-lisp.el" (19636 58496))
+;;;;;; find-lisp-find-dired) "find-lisp" "find-lisp.el" (19277 34916))
;;; Generated autoloads from find-lisp.el
(autoload 'find-lisp-find-dired "find-lisp" "\
@@ -10390,7 +10402,7 @@ Change the filter on a find-lisp-find-dired buffer to REGEXP.
;;;***
;;;### (autoloads (finder-by-keyword finder-commentary finder-list-keywords)
-;;;;;; "finder" "finder.el" (19636 58496))
+;;;;;; "finder" "finder.el" (19662 23188))
;;; Generated autoloads from finder.el
(autoload 'finder-list-keywords "finder" "\
@@ -10412,7 +10424,7 @@ Find packages matching a given keyword.
;;;***
;;;### (autoloads (enable-flow-control-on enable-flow-control) "flow-ctrl"
-;;;;;; "flow-ctrl.el" (19636 58496))
+;;;;;; "flow-ctrl.el" (19277 34916))
;;; Generated autoloads from flow-ctrl.el
(autoload 'enable-flow-control "flow-ctrl" "\
@@ -10434,7 +10446,7 @@ to get the effect of a C-q.
;;;***
;;;### (autoloads (fill-flowed fill-flowed-encode) "flow-fill" "gnus/flow-fill.el"
-;;;;;; (19636 58496))
+;;;;;; (19604 65275))
;;; Generated autoloads from gnus/flow-fill.el
(autoload 'fill-flowed-encode "flow-fill" "\
@@ -10450,7 +10462,7 @@ Not documented
;;;***
;;;### (autoloads (flymake-mode-off flymake-mode-on flymake-mode)
-;;;;;; "flymake" "progmodes/flymake.el" (19636 58496))
+;;;;;; "flymake" "progmodes/flymake.el" (19670 2258))
;;; Generated autoloads from progmodes/flymake.el
(autoload 'flymake-mode "flymake" "\
@@ -10474,7 +10486,7 @@ Turn flymake mode off.
;;;### (autoloads (flyspell-buffer flyspell-region flyspell-mode-off
;;;;;; turn-off-flyspell turn-on-flyspell flyspell-mode flyspell-prog-mode)
-;;;;;; "flyspell" "textmodes/flyspell.el" (19636 58496))
+;;;;;; "flyspell" "textmodes/flyspell.el" (19681 34867))
;;; Generated autoloads from textmodes/flyspell.el
(autoload 'flyspell-prog-mode "flyspell" "\
@@ -10544,7 +10556,7 @@ Flyspell whole buffer.
;;;### (autoloads (follow-delete-other-windows-and-split follow-mode
;;;;;; turn-off-follow-mode turn-on-follow-mode) "follow" "follow.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34916))
;;; Generated autoloads from follow.el
(autoload 'turn-on-follow-mode "follow" "\
@@ -10617,8 +10629,8 @@ in your `~/.emacs' file, replacing [f7] by your favourite key:
;;;***
-;;;### (autoloads (footnote-mode) "footnote" "mail/footnote.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (footnote-mode) "footnote" "mail/footnote.el" (19277
+;;;;;; 34921))
;;; Generated autoloads from mail/footnote.el
(autoload 'footnote-mode "footnote" "\
@@ -10632,7 +10644,7 @@ started, play around with the following keys:
;;;***
;;;### (autoloads (forms-find-file-other-window forms-find-file forms-mode)
-;;;;;; "forms" "forms.el" (19636 58496))
+;;;;;; "forms" "forms.el" (19406 15657))
;;; Generated autoloads from forms.el
(autoload 'forms-mode "forms" "\
@@ -10669,7 +10681,7 @@ Visit a file in Forms mode in other window.
;;;***
;;;### (autoloads (fortran-mode) "fortran" "progmodes/fortran.el"
-;;;;;; (19636 58496))
+;;;;;; (19672 56753))
;;; Generated autoloads from progmodes/fortran.el
(autoload 'fortran-mode "fortran" "\
@@ -10747,7 +10759,7 @@ with no args, if that value is non-nil.
;;;***
;;;### (autoloads (fortune fortune-to-signature fortune-compile fortune-from-region
-;;;;;; fortune-add-fortune) "fortune" "play/fortune.el" (19658 61388))
+;;;;;; fortune-add-fortune) "fortune" "play/fortune.el" (19661 46305))
;;; Generated autoloads from play/fortune.el
(autoload 'fortune-add-fortune "fortune" "\
@@ -10795,14 +10807,19 @@ and choose the directory as the fortune-file.
;;;***
-;;;### (autoloads (gdb-enable-debug gdb) "gdb-ui" "progmodes/gdb-ui.el"
-;;;;;; (19636 58496))
-;;; Generated autoloads from progmodes/gdb-ui.el
+;;;### (autoloads (gdb gdb-enable-debug) "gdb-mi" "progmodes/gdb-mi.el"
+;;;;;; (19614 24990))
+;;; Generated autoloads from progmodes/gdb-mi.el
-(autoload 'gdb "gdb-ui" "\
+(defvar gdb-enable-debug nil "\
+Non-nil means record the process input and output in `gdb-debug-log'.")
+
+(custom-autoload 'gdb-enable-debug "gdb-mi" t)
+
+(autoload 'gdb "gdb-mi" "\
Run gdb on program FILE in buffer *gud-FILE*.
-The directory containing FILE becomes the initial working
-directory and source-file directory for your debugger.
+The directory containing FILE becomes the initial working directory
+and source-file directory for your debugger.
If `gdb-many-windows' is nil (the default value) then gdb just
pops up the GUD buffer unless `gdb-show-main' is t. In this case
@@ -10810,10 +10827,8 @@ it starts with two windows: one displaying the GUD buffer and the
other with the source file with the main routine of the inferior.
If `gdb-many-windows' is t, regardless of the value of
-`gdb-show-main', the layout below will appear unless
-`gdb-use-separate-io-buffer' is nil when the source buffer
-occupies the full width of the frame. Keybindings are shown in
-some of the buffers.
+`gdb-show-main', the layout below will appear. Keybindings are
+shown in some of the buffers.
Watch expressions appear in the speedbar/slowbar.
@@ -10825,37 +10840,37 @@ The following commands help control operation :
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 | I/O buffer for debugged program |
| | |
-|-----------------------------------+----------------------------------+
-| Stack buffer | Breakpoints/threads buffer |
+-----------------------------------+----------------------------------+
-
-The option \"--annotate=3\" must be included in this value. To
-run GDB in text command mode, use `gud-gdb'. You need to use
-text command mode to debug multiple programs within one Emacs
-session.
+| Source buffer | I/O buffer (of debugged program) |
+| | (comint-mode) |
+| | |
+| | |
+| | |
+| | |
+| | |
+| | |
++-----------------------------------+----------------------------------+
+| Stack buffer | Breakpoints buffer |
+| RET gdb-select-frame | SPC gdb-toggle-breakpoint |
+| | RET gdb-goto-breakpoint |
+| | D gdb-delete-breakpoint |
++-----------------------------------+----------------------------------+
\(fn COMMAND-LINE)" t nil)
-(defalias 'gdba 'gdb)
-
-(defvar gdb-enable-debug nil "\
-Non-nil means record the process input and output in `gdb-debug-log'.")
-
-(custom-autoload 'gdb-enable-debug "gdb-ui" t)
-
;;;***
;;;### (autoloads (generic-make-keywords-list generic-mode generic-mode-internal
-;;;;;; define-generic-mode) "generic" "emacs-lisp/generic.el" (19636
-;;;;;; 58496))
+;;;;;; define-generic-mode) "generic" "emacs-lisp/generic.el" (19580
+;;;;;; 19536))
;;; Generated autoloads from emacs-lisp/generic.el
(defvar generic-mode-list nil "\
@@ -10899,6 +10914,8 @@ See the file generic-x.el for some examples of `define-generic-mode'.
\(fn MODE COMMENT-LIST KEYWORD-LIST FONT-LOCK-LIST AUTO-MODE-LIST FUNCTION-LIST &optional DOCSTRING)" nil (quote macro))
+(put 'define-generic-mode 'lisp-indent-function '1)
+
(autoload 'generic-mode-internal "generic" "\
Go into the generic mode MODE.
@@ -10930,7 +10947,7 @@ regular expression that can be used as an element of
;;;***
;;;### (autoloads (glasses-mode) "glasses" "progmodes/glasses.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34922))
;;; Generated autoloads from progmodes/glasses.el
(autoload 'glasses-mode "glasses" "\
@@ -10944,7 +10961,7 @@ at places they belong to.
;;;### (autoloads (gmm-tool-bar-from-list gmm-widget-p gmm-error
;;;;;; gmm-message gmm-regexp-concat) "gmm-utils" "gnus/gmm-utils.el"
-;;;;;; (19636 58496))
+;;;;;; (19623 58490))
;;; Generated autoloads from gnus/gmm-utils.el
(autoload 'gmm-regexp-concat "gmm-utils" "\
@@ -10999,7 +11016,7 @@ DEFAULT-MAP specifies the default key map for ICON-LIST.
;;;***
;;;### (autoloads (gnus gnus-other-frame gnus-slave gnus-no-server
-;;;;;; gnus-slave-no-server) "gnus" "gnus/gnus.el" (19636 58496))
+;;;;;; gnus-slave-no-server) "gnus" "gnus/gnus.el" (19687 6902))
;;; Generated autoloads from gnus/gnus.el
(when (fboundp 'custom-autoload)
(custom-autoload 'gnus-select-method "gnus"))
@@ -11052,7 +11069,7 @@ prompt the user for the name of an NNTP server to use.
;;;;;; gnus-agent-get-undownloaded-list gnus-agent-delete-group
;;;;;; gnus-agent-rename-group gnus-agent-possibly-save-gcc gnus-agentize
;;;;;; gnus-slave-unplugged gnus-plugged gnus-unplugged) "gnus-agent"
-;;;;;; "gnus/gnus-agent.el" (19636 58496))
+;;;;;; "gnus/gnus-agent.el" (19687 6902))
;;; Generated autoloads from gnus/gnus-agent.el
(autoload 'gnus-unplugged "gnus-agent" "\
@@ -11143,7 +11160,7 @@ If CLEAN, obsolete (ignore).
;;;***
;;;### (autoloads (gnus-article-prepare-display) "gnus-art" "gnus/gnus-art.el"
-;;;;;; (19636 58496))
+;;;;;; (19695 9549))
;;; Generated autoloads from gnus/gnus-art.el
(autoload 'gnus-article-prepare-display "gnus-art" "\
@@ -11153,19 +11170,8 @@ Make the current buffer look like a nice article.
;;;***
-;;;### (autoloads (gnus-audio-play) "gnus-audio" "gnus/gnus-audio.el"
-;;;;;; (19636 58496))
-;;; Generated autoloads from gnus/gnus-audio.el
-
-(autoload 'gnus-audio-play "gnus-audio" "\
-Play a sound FILE through the speaker.
-
-\(fn FILE)" t nil)
-
-;;;***
-
;;;### (autoloads (gnus-bookmark-bmenu-list gnus-bookmark-jump gnus-bookmark-set)
-;;;;;; "gnus-bookmark" "gnus/gnus-bookmark.el" (19636 58496))
+;;;;;; "gnus-bookmark" "gnus/gnus-bookmark.el" (19670 666))
;;; Generated autoloads from gnus/gnus-bookmark.el
(autoload 'gnus-bookmark-set "gnus-bookmark" "\
@@ -11190,8 +11196,8 @@ deletion, or > if it is flagged for displaying.
;;;### (autoloads (gnus-cache-delete-group gnus-cache-rename-group
;;;;;; gnus-cache-generate-nov-databases gnus-cache-generate-active
-;;;;;; gnus-jog-cache) "gnus-cache" "gnus/gnus-cache.el" (19636
-;;;;;; 58496))
+;;;;;; gnus-jog-cache) "gnus-cache" "gnus/gnus-cache.el" (19693
+;;;;;; 40409))
;;; Generated autoloads from gnus/gnus-cache.el
(autoload 'gnus-jog-cache "gnus-cache" "\
@@ -11233,7 +11239,7 @@ supported.
;;;***
;;;### (autoloads (gnus-delay-initialize gnus-delay-send-queue gnus-delay-article)
-;;;;;; "gnus-delay" "gnus/gnus-delay.el" (19636 58496))
+;;;;;; "gnus-delay" "gnus/gnus-delay.el" (19645 60484))
;;; Generated autoloads from gnus/gnus-delay.el
(autoload 'gnus-delay-article "gnus-delay" "\
@@ -11269,7 +11275,7 @@ Checking delayed messages is skipped if optional arg NO-CHECK is non-nil.
;;;***
;;;### (autoloads (gnus-user-format-function-D gnus-user-format-function-d)
-;;;;;; "gnus-diary" "gnus/gnus-diary.el" (19636 58496))
+;;;;;; "gnus-diary" "gnus/gnus-diary.el" (19645 60484))
;;; Generated autoloads from gnus/gnus-diary.el
(autoload 'gnus-user-format-function-d "gnus-diary" "\
@@ -11285,7 +11291,7 @@ Not documented
;;;***
;;;### (autoloads (turn-on-gnus-dired-mode) "gnus-dired" "gnus/gnus-dired.el"
-;;;;;; (19636 58496))
+;;;;;; (19662 7391))
;;; Generated autoloads from gnus/gnus-dired.el
(autoload 'turn-on-gnus-dired-mode "gnus-dired" "\
@@ -11296,7 +11302,7 @@ Convenience method to turn on gnus-dired-mode.
;;;***
;;;### (autoloads (gnus-draft-reminder) "gnus-draft" "gnus/gnus-draft.el"
-;;;;;; (19636 58496))
+;;;;;; (19648 31344))
;;; Generated autoloads from gnus/gnus-draft.el
(autoload 'gnus-draft-reminder "gnus-draft" "\
@@ -11308,8 +11314,8 @@ Reminder user if there are unsent drafts.
;;;### (autoloads (gnus-convert-png-to-face gnus-convert-face-to-png
;;;;;; gnus-face-from-file gnus-x-face-from-file gnus-insert-random-x-face-header
-;;;;;; gnus-random-x-face) "gnus-fun" "gnus/gnus-fun.el" (19636
-;;;;;; 58496))
+;;;;;; gnus-random-x-face) "gnus-fun" "gnus/gnus-fun.el" (19635
+;;;;;; 50568))
;;; Generated autoloads from gnus/gnus-fun.el
(autoload 'gnus-random-x-face "gnus-fun" "\
@@ -11353,8 +11359,26 @@ FILE should be a PNG file that's 48x48 and smaller than or equal to
;;;***
+;;;### (autoloads (gnus-treat-mail-gravatar gnus-treat-from-gravatar)
+;;;;;; "gnus-gravatar" "gnus/gnus-gravatar.el" (19688 19082))
+;;; Generated autoloads from gnus/gnus-gravatar.el
+
+(autoload 'gnus-treat-from-gravatar "gnus-gravatar" "\
+Display gravatar in the From header.
+If gravatar is already displayed, remove it.
+
+\(fn &optional FORCE)" t nil)
+
+(autoload 'gnus-treat-mail-gravatar "gnus-gravatar" "\
+Display gravatars in the Cc and To headers.
+If gravatars are already displayed, remove them.
+
+\(fn &optional FORCE)" t nil)
+
+;;;***
+
;;;### (autoloads (gnus-fetch-group-other-frame gnus-fetch-group)
-;;;;;; "gnus-group" "gnus/gnus-group.el" (19636 58496))
+;;;;;; "gnus-group" "gnus/gnus-group.el" (19672 21006))
;;; Generated autoloads from gnus/gnus-group.el
(autoload 'gnus-fetch-group "gnus-group" "\
@@ -11371,8 +11395,24 @@ Pop up a frame and enter GROUP.
;;;***
+;;;### (autoloads (gnus-html-prefetch-images gnus-article-html) "gnus-html"
+;;;;;; "gnus/gnus-html.el" (19687 6902))
+;;; Generated autoloads from gnus/gnus-html.el
+
+(autoload 'gnus-article-html "gnus-html" "\
+Not documented
+
+\(fn &optional HANDLE)" nil nil)
+
+(autoload 'gnus-html-prefetch-images "gnus-html" "\
+Not documented
+
+\(fn SUMMARY)" nil nil)
+
+;;;***
+
;;;### (autoloads (gnus-batch-score) "gnus-kill" "gnus/gnus-kill.el"
-;;;;;; (19636 58496))
+;;;;;; (19636 38740))
;;; Generated autoloads from gnus/gnus-kill.el
(defalias 'gnus-batch-kill 'gnus-batch-score)
@@ -11387,7 +11427,7 @@ Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score
;;;### (autoloads (gnus-mailing-list-mode gnus-mailing-list-insinuate
;;;;;; turn-on-gnus-mailing-list-mode) "gnus-ml" "gnus/gnus-ml.el"
-;;;;;; (19636 58496))
+;;;;;; (19582 65302))
;;; Generated autoloads from gnus/gnus-ml.el
(autoload 'turn-on-gnus-mailing-list-mode "gnus-ml" "\
@@ -11412,7 +11452,7 @@ Minor mode for providing mailing-list commands.
;;;### (autoloads (gnus-group-split-fancy gnus-group-split gnus-group-split-update
;;;;;; gnus-group-split-setup) "gnus-mlspl" "gnus/gnus-mlspl.el"
-;;;;;; (19636 58496))
+;;;;;; (19582 65302))
;;; Generated autoloads from gnus/gnus-mlspl.el
(autoload 'gnus-group-split-setup "gnus-mlspl" "\
@@ -11512,20 +11552,8 @@ Calling (gnus-group-split-fancy nil nil \"mail.others\") returns:
;;;***
-;;;### (autoloads (gnus-change-server) "gnus-move" "gnus/gnus-move.el"
-;;;;;; (19636 58496))
-;;; Generated autoloads from gnus/gnus-move.el
-
-(autoload 'gnus-change-server "gnus-move" "\
-Move from FROM-SERVER to TO-SERVER.
-Update the .newsrc.eld file to reflect the change of nntp server.
-
-\(fn FROM-SERVER TO-SERVER)" t nil)
-
-;;;***
-
;;;### (autoloads (gnus-button-reply gnus-button-mailto gnus-msg-mail)
-;;;;;; "gnus-msg" "gnus/gnus-msg.el" (19636 58496))
+;;;;;; "gnus-msg" "gnus/gnus-msg.el" (19662 23188))
;;; Generated autoloads from gnus/gnus-msg.el
(autoload 'gnus-msg-mail "gnus-msg" "\
@@ -11549,25 +11577,9 @@ Like `message-reply'.
;;;***
-;;;### (autoloads (gnus-nocem-load-cache gnus-nocem-scan-groups)
-;;;;;; "gnus-nocem" "gnus/gnus-nocem.el" (19636 58496))
-;;; Generated autoloads from gnus/gnus-nocem.el
-
-(autoload 'gnus-nocem-scan-groups "gnus-nocem" "\
-Scan all NoCeM groups for new NoCeM messages.
-
-\(fn)" t nil)
-
-(autoload 'gnus-nocem-load-cache "gnus-nocem" "\
-Load the NoCeM cache.
-
-\(fn)" t nil)
-
-;;;***
-
;;;### (autoloads (gnus-treat-newsgroups-picon gnus-treat-mail-picon
;;;;;; gnus-treat-from-picon) "gnus-picon" "gnus/gnus-picon.el"
-;;;;;; (19636 58496))
+;;;;;; (19635 50568))
;;; Generated autoloads from gnus/gnus-picon.el
(autoload 'gnus-treat-from-picon "gnus-picon" "\
@@ -11594,7 +11606,7 @@ If picons are already displayed, remove them.
;;;;;; gnus-sorted-nintersection gnus-sorted-range-intersection
;;;;;; gnus-sorted-intersection gnus-intersection gnus-sorted-complement
;;;;;; gnus-sorted-ndifference gnus-sorted-difference) "gnus-range"
-;;;;;; "gnus/gnus-range.el" (19636 58496))
+;;;;;; "gnus/gnus-range.el" (19604 65275))
;;; Generated autoloads from gnus/gnus-range.el
(autoload 'gnus-sorted-difference "gnus-range" "\
@@ -11662,7 +11674,7 @@ Add NUM into sorted LIST by side effect.
;;;***
;;;### (autoloads (gnus-registry-install-hooks gnus-registry-initialize)
-;;;;;; "gnus-registry" "gnus/gnus-registry.el" (19636 58496))
+;;;;;; "gnus-registry" "gnus/gnus-registry.el" (19645 60484))
;;; Generated autoloads from gnus/gnus-registry.el
(autoload 'gnus-registry-initialize "gnus-registry" "\
@@ -11678,8 +11690,8 @@ Install the registry hooks.
;;;***
;;;### (autoloads (gnus-sieve-article-add-rule gnus-sieve-generate
-;;;;;; gnus-sieve-update) "gnus-sieve" "gnus/gnus-sieve.el" (19636
-;;;;;; 58496))
+;;;;;; gnus-sieve-update) "gnus-sieve" "gnus/gnus-sieve.el" (19582
+;;;;;; 65302))
;;; Generated autoloads from gnus/gnus-sieve.el
(autoload 'gnus-sieve-update "gnus-sieve" "\
@@ -11706,28 +11718,8 @@ Not documented
;;;***
-;;;### (autoloads (gnus-batch-brew-soup) "gnus-soup" "gnus/gnus-soup.el"
-;;;;;; (19636 58496))
-;;; Generated autoloads from gnus/gnus-soup.el
-
-(autoload 'gnus-batch-brew-soup "gnus-soup" "\
-Brew a SOUP packet from groups mention on the command line.
-Will use the remaining command line arguments as regular expressions
-for matching on group names.
-
-For instance, if you want to brew on all the nnml groups, as well as
-groups with \"emacs\" in the name, you could say something like:
-
-$ emacs -batch -f gnus-batch-brew-soup ^nnml \".*emacs.*\"
-
-Note -- this function hasn't been implemented yet.
-
-\(fn)" t nil)
-
-;;;***
-
;;;### (autoloads (gnus-update-format) "gnus-spec" "gnus/gnus-spec.el"
-;;;;;; (19636 58496))
+;;;;;; (19638 16738))
;;; Generated autoloads from gnus/gnus-spec.el
(autoload 'gnus-update-format "gnus-spec" "\
@@ -11737,9 +11729,8 @@ Update the format specification near point.
;;;***
-;;;### (autoloads (gnus-fixup-nnimap-unread-after-getting-new-news
-;;;;;; gnus-declare-backend) "gnus-start" "gnus/gnus-start.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (gnus-declare-backend) "gnus-start" "gnus/gnus-start.el"
+;;;;;; (19672 21006))
;;; Generated autoloads from gnus/gnus-start.el
(autoload 'gnus-declare-backend "gnus-start" "\
@@ -11747,15 +11738,38 @@ Declare back end NAME with ABILITIES as a Gnus back end.
\(fn NAME &rest ABILITIES)" nil nil)
-(autoload 'gnus-fixup-nnimap-unread-after-getting-new-news "gnus-start" "\
-Not documented
+;;;***
+
+;;;### (autoloads (gnus-summary-bookmark-jump) "gnus-sum" "gnus/gnus-sum.el"
+;;;;;; (19695 9549))
+;;; Generated autoloads from gnus/gnus-sum.el
-\(fn)" nil nil)
+(autoload 'gnus-summary-bookmark-jump "gnus-sum" "\
+Handler function for record returned by `gnus-summary-bookmark-make-record'.
+BOOKMARK is a bookmark name or a bookmark record.
+
+\(fn BOOKMARK)" nil nil)
+
+;;;***
+
+;;;### (autoloads (gnus-sync-install-hooks gnus-sync-initialize)
+;;;;;; "gnus-sync" "gnus/gnus-sync.el" (19630 1041))
+;;; Generated autoloads from gnus/gnus-sync.el
+
+(autoload 'gnus-sync-initialize "gnus-sync" "\
+Initialize the Gnus sync facility.
+
+\(fn)" t nil)
+
+(autoload 'gnus-sync-install-hooks "gnus-sync" "\
+Install the sync hooks.
+
+\(fn)" t nil)
;;;***
;;;### (autoloads (gnus-add-configuration) "gnus-win" "gnus/gnus-win.el"
-;;;;;; (19636 58496))
+;;;;;; (19626 25721))
;;; Generated autoloads from gnus/gnus-win.el
(autoload 'gnus-add-configuration "gnus-win" "\
@@ -11765,7 +11779,7 @@ Add the window configuration CONF to `gnus-buffer-configuration'.
;;;***
-;;;### (autoloads (gomoku) "gomoku" "play/gomoku.el" (19658 61388))
+;;;### (autoloads (gomoku) "gomoku" "play/gomoku.el" (19675 8283))
;;; Generated autoloads from play/gomoku.el
(autoload 'gomoku "gomoku" "\
@@ -11792,8 +11806,8 @@ Use \\[describe-mode] for more info.
;;;***
;;;### (autoloads (goto-address-prog-mode goto-address-mode goto-address
-;;;;;; goto-address-at-point) "goto-addr" "net/goto-addr.el" (19636
-;;;;;; 58496))
+;;;;;; goto-address-at-point) "goto-addr" "net/goto-addr.el" (19360
+;;;;;; 14173))
;;; Generated autoloads from net/goto-addr.el
(define-obsolete-function-alias 'goto-address-at-mouse 'goto-address-at-point "22.1")
@@ -11831,9 +11845,21 @@ Turn on `goto-address-mode', but only in comments and strings.
;;;***
+;;;### (autoloads (gravatar-retrieve) "gravatar" "gnus/gravatar.el"
+;;;;;; (19626 25721))
+;;; Generated autoloads from gnus/gravatar.el
+
+(autoload 'gravatar-retrieve "gravatar" "\
+Retrieve MAIL-ADDRESS gravatar and call CB on retrieval.
+You can provide a list of argument to pass to CB in CBARGS.
+
+\(fn MAIL-ADDRESS CB &optional CBARGS)" nil nil)
+
+;;;***
+
;;;### (autoloads (zrgrep rgrep lgrep grep-find grep grep-mode grep-compute-defaults
;;;;;; grep-process-setup grep-setup-hook grep-find-command grep-command
-;;;;;; grep-window-height) "grep" "progmodes/grep.el" (19636 58496))
+;;;;;; grep-window-height) "grep" "progmodes/grep.el" (19687 6902))
;;; Generated autoloads from progmodes/grep.el
(defvar grep-window-height nil "\
@@ -11866,7 +11892,7 @@ List of hook functions run by `grep-process-setup' (see `run-hooks').")
(custom-autoload 'grep-setup-hook "grep" t)
-(defconst grep-regexp-alist '(("^\\(.+?\\)\\(:[ ]*\\)\\([0-9]+\\)\\2" 1 3) ("^\\(\\(.+?\\):\\([0-9]+\\):\\).*?\\(\\[01;31m\\(?:\\[K\\)?\\)\\(.*?\\)\\(\\[[0-9]*m\\)" 2 3 ((lambda nil (setq compilation-error-screen-columns nil) (- (match-beginning 4) (match-end 1))) lambda nil (- (match-end 5) (match-end 1) (- (match-end 4) (match-beginning 4)))) nil 1) ("^Binary file \\(.+\\) matches$" 1 nil nil 0 1)) "\
+(defconst grep-regexp-alist '(("^\\(.+?\\)\\(:[ ]*\\)\\([0-9]+\\)\\2" 1 3) ("^\\(\\(.+?\\):\\([1-9][0-9]*\\):\\).*?\\(\\[01;31m\\(?:\\[K\\)?\\)\\(.*?\\)\\(\\[[0-9]*m\\)" 2 3 ((lambda nil (setq compilation-error-screen-columns nil) (- (match-beginning 4) (match-end 1))) lambda nil (- (match-end 5) (match-end 1) (- (match-end 4) (match-beginning 4)))) nil 1) ("^Binary file \\(.+\\) matches$" 1 nil nil 0 1)) "\
Regexp used to match grep hits. See `compilation-error-regexp-alist'.")
(defvar grep-program (purecopy "grep") "\
@@ -11989,7 +12015,7 @@ file name to `*.gz', and sets `grep-highlight-matches' to `always'.
;;;***
-;;;### (autoloads (gs-load-image) "gs" "gs.el" (19636 58496))
+;;;### (autoloads (gs-load-image) "gs" "gs.el" (19277 34916))
;;; Generated autoloads from gs.el
(autoload 'gs-load-image "gs" "\
@@ -12003,7 +12029,7 @@ the form \"WINDOW-ID PIXMAP-ID\". Value is non-nil if successful.
;;;***
;;;### (autoloads (gud-tooltip-mode gdb-script-mode jdb pdb perldb
-;;;;;; xdb dbx sdb gud-gdb) "gud" "progmodes/gud.el" (19636 58496))
+;;;;;; xdb dbx sdb gud-gdb) "gud" "progmodes/gud.el" (19611 36621))
;;; Generated autoloads from progmodes/gud.el
(autoload 'gud-gdb "gud" "\
@@ -12068,8 +12094,6 @@ gud, see `gud-mode'.
\(fn COMMAND-LINE)" t nil)
(add-hook 'same-window-regexps (purecopy "\\*gud-.*\\*\\(\\|<[0-9]+>\\)"))
-(add-to-list 'auto-mode-alist (cons (purecopy "/\\.[a-z0-9-]*gdbinit") 'gdb-script-mode))
-
(autoload 'gdb-script-mode "gud" "\
Major mode for editing GDB scripts.
@@ -12091,8 +12115,8 @@ Toggle the display of GUD tooltips.
;;;***
-;;;### (autoloads (handwrite) "handwrite" "play/handwrite.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (handwrite) "handwrite" "play/handwrite.el" (19277
+;;;;;; 34922))
;;; Generated autoloads from play/handwrite.el
(autoload 'handwrite "handwrite" "\
@@ -12110,7 +12134,7 @@ Variables: handwrite-linespace (default 12)
;;;***
;;;### (autoloads (hanoi-unix-64 hanoi-unix hanoi) "hanoi" "play/hanoi.el"
-;;;;;; (19636 58496))
+;;;;;; (19267 61658))
;;; Generated autoloads from play/hanoi.el
(autoload 'hanoi "hanoi" "\
@@ -12139,7 +12163,7 @@ to be updated.
;;;### (autoloads (mail-check-payment mail-add-payment-async mail-add-payment
;;;;;; hashcash-verify-payment hashcash-insert-payment-async hashcash-insert-payment)
-;;;;;; "hashcash" "mail/hashcash.el" (19636 58496))
+;;;;;; "hashcash" "mail/hashcash.el" (19635 50568))
;;; Generated autoloads from mail/hashcash.el
(autoload 'hashcash-insert-payment "hashcash" "\
@@ -12184,7 +12208,7 @@ Prefix arg sets default accept amount temporarily.
;;;### (autoloads (scan-buf-previous-region scan-buf-next-region
;;;;;; scan-buf-move-to-region help-at-pt-display-when-idle help-at-pt-set-timer
;;;;;; help-at-pt-cancel-timer display-local-help help-at-pt-kbd-string
-;;;;;; help-at-pt-string) "help-at-pt" "help-at-pt.el" (19636 58496))
+;;;;;; help-at-pt-string) "help-at-pt" "help-at-pt.el" (19277 34916))
;;; Generated autoloads from help-at-pt.el
(autoload 'help-at-pt-string "help-at-pt" "\
@@ -12311,10 +12335,10 @@ different regions. With numeric argument ARG, behaves like
;;;***
-;;;### (autoloads (describe-categories describe-syntax describe-variable
-;;;;;; variable-at-point describe-function-1 find-lisp-object-file-name
-;;;;;; help-C-file-name describe-function) "help-fns" "help-fns.el"
-;;;;;; (19636 58496))
+;;;### (autoloads (doc-file-to-info doc-file-to-man describe-categories
+;;;;;; describe-syntax describe-variable variable-at-point describe-function-1
+;;;;;; find-lisp-object-file-name help-C-file-name describe-function)
+;;;;;; "help-fns" "help-fns.el" (19649 15956))
;;; Generated autoloads from help-fns.el
(autoload 'describe-function "help-fns" "\
@@ -12381,10 +12405,20 @@ BUFFER should be a buffer or a buffer name.
\(fn &optional BUFFER)" t nil)
+(autoload 'doc-file-to-man "help-fns" "\
+Produce an nroff buffer containing the doc-strings from the DOC file.
+
+\(fn FILE)" t nil)
+
+(autoload 'doc-file-to-info "help-fns" "\
+Produce a texinfo buffer with sorted doc-strings from the DOC file.
+
+\(fn FILE)" t nil)
+
;;;***
;;;### (autoloads (three-step-help) "help-macro" "help-macro.el"
-;;;;;; (19636 58496))
+;;;;;; (19580 19536))
;;; Generated autoloads from help-macro.el
(defvar three-step-help nil "\
@@ -12400,8 +12434,8 @@ gives the window that lists the options.")
;;;### (autoloads (help-xref-on-pp help-insert-xref-button help-xref-button
;;;;;; help-make-xrefs help-buffer help-setup-xref help-mode-finish
-;;;;;; help-mode-setup help-mode) "help-mode" "help-mode.el" (19636
-;;;;;; 58496))
+;;;;;; help-mode-setup help-mode) "help-mode" "help-mode.el" (19635
+;;;;;; 56796))
;;; Generated autoloads from help-mode.el
(autoload 'help-mode "help-mode" "\
@@ -12493,7 +12527,7 @@ Add xrefs for symbols in `pp's output between FROM and TO.
;;;***
;;;### (autoloads (Helper-help Helper-describe-bindings) "helper"
-;;;;;; "emacs-lisp/helper.el" (19636 58496))
+;;;;;; "emacs-lisp/helper.el" (19580 19536))
;;; Generated autoloads from emacs-lisp/helper.el
(autoload 'Helper-describe-bindings "helper" "\
@@ -12509,7 +12543,7 @@ Provide help for current mode.
;;;***
;;;### (autoloads (hexlify-buffer hexl-find-file hexl-mode) "hexl"
-;;;;;; "hexl.el" (19636 58496))
+;;;;;; "hexl.el" (19648 31344))
;;; Generated autoloads from hexl.el
(autoload 'hexl-mode "hexl" "\
@@ -12606,7 +12640,7 @@ This discards the buffer's undo information.
;;;### (autoloads (hi-lock-write-interactive-patterns hi-lock-unface-buffer
;;;;;; hi-lock-face-phrase-buffer hi-lock-face-buffer hi-lock-line-face-buffer
;;;;;; global-hi-lock-mode hi-lock-mode) "hi-lock" "hi-lock.el"
-;;;;;; (19636 58496))
+;;;;;; (19635 50568))
;;; Generated autoloads from hi-lock.el
(autoload 'hi-lock-mode "hi-lock" "\
@@ -12740,7 +12774,7 @@ be found in variable `hi-lock-interactive-patterns'.
;;;***
;;;### (autoloads (hide-ifdef-mode) "hideif" "progmodes/hideif.el"
-;;;;;; (19636 58496))
+;;;;;; (19668 19057))
;;; Generated autoloads from progmodes/hideif.el
(autoload 'hide-ifdef-mode "hideif" "\
@@ -12780,7 +12814,7 @@ how the hiding is done:
;;;***
;;;### (autoloads (turn-off-hideshow hs-minor-mode) "hideshow" "progmodes/hideshow.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34922))
;;; Generated autoloads from progmodes/hideshow.el
(defvar hs-special-modes-alist (mapcar 'purecopy '((c-mode "{" "}" "/[*/]" nil nil) (c++-mode "{" "}" "/[*/]" nil nil) (bibtex-mode ("@\\S(*\\(\\s(\\)" 1)) (java-mode "{" "}" "/[*/]" nil nil) (js-mode "{" "}" "/[*/]" nil))) "\
@@ -12842,8 +12876,8 @@ Unconditionally turn off `hs-minor-mode'.
;;;;;; highlight-compare-buffers highlight-changes-rotate-faces
;;;;;; highlight-changes-previous-change highlight-changes-next-change
;;;;;; highlight-changes-remove-highlight highlight-changes-visible-mode
-;;;;;; highlight-changes-mode) "hilit-chg" "hilit-chg.el" (19636
-;;;;;; 58496))
+;;;;;; highlight-changes-mode) "hilit-chg" "hilit-chg.el" (19630
+;;;;;; 1041))
;;; Generated autoloads from hilit-chg.el
(autoload 'highlight-changes-mode "hilit-chg" "\
@@ -12972,7 +13006,7 @@ See `highlight-changes-mode' for more information on Highlight-Changes mode.
;;;;;; hippie-expand-ignore-buffers hippie-expand-max-buffers hippie-expand-no-restriction
;;;;;; hippie-expand-dabbrev-as-symbol hippie-expand-dabbrev-skip-space
;;;;;; hippie-expand-verbose hippie-expand-try-functions-list) "hippie-exp"
-;;;;;; "hippie-exp.el" (19636 58496))
+;;;;;; "hippie-exp.el" (19672 56753))
;;; Generated autoloads from hippie-exp.el
(defvar hippie-expand-try-functions-list '(try-complete-file-name-partially try-complete-file-name try-expand-all-abbrevs try-expand-list try-expand-line try-expand-dabbrev try-expand-dabbrev-all-buffers try-expand-dabbrev-from-kill try-complete-lisp-symbol-partially try-complete-lisp-symbol) "\
@@ -13045,7 +13079,7 @@ argument VERBOSE non-nil makes the function verbose.
;;;***
;;;### (autoloads (global-hl-line-mode hl-line-mode) "hl-line" "hl-line.el"
-;;;;;; (19636 58496))
+;;;;;; (19515 27412))
;;; Generated autoloads from hl-line.el
(autoload 'hl-line-mode "hl-line" "\
@@ -13089,9 +13123,11 @@ Global-Hl-Line mode uses the functions `global-hl-line-unhighlight' and
;;;;;; holiday-bahai-holidays holiday-islamic-holidays holiday-christian-holidays
;;;;;; holiday-hebrew-holidays holiday-other-holidays holiday-local-holidays
;;;;;; holiday-oriental-holidays holiday-general-holidays) "holidays"
-;;;;;; "calendar/holidays.el" (19636 58496))
+;;;;;; "calendar/holidays.el" (19662 28391))
;;; Generated autoloads from calendar/holidays.el
+(define-obsolete-variable-alias 'general-holidays 'holiday-general-holidays "23.1")
+
(defvar holiday-general-holidays (mapcar 'purecopy '((holiday-fixed 1 1 "New Year's Day") (holiday-float 1 1 3 "Martin Luther King Day") (holiday-fixed 2 2 "Groundhog Day") (holiday-fixed 2 14 "Valentine's Day") (holiday-float 2 1 3 "President's Day") (holiday-fixed 3 17 "St. Patrick's Day") (holiday-fixed 4 1 "April Fools' Day") (holiday-float 5 0 2 "Mother's Day") (holiday-float 5 1 -1 "Memorial Day") (holiday-fixed 6 14 "Flag Day") (holiday-float 6 0 3 "Father's Day") (holiday-fixed 7 4 "Independence Day") (holiday-float 9 1 1 "Labor Day") (holiday-float 10 1 2 "Columbus Day") (holiday-fixed 10 31 "Halloween") (holiday-fixed 11 11 "Veteran's Day") (holiday-float 11 4 4 "Thanksgiving"))) "\
General holidays. Default value is for the United States.
See the documentation for `calendar-holidays' for details.")
@@ -13100,7 +13136,7 @@ See the documentation for `calendar-holidays' for details.")
(put 'holiday-general-holidays 'risky-local-variable t)
-(define-obsolete-variable-alias 'general-holidays 'holiday-general-holidays "23.1")
+(define-obsolete-variable-alias 'oriental-holidays 'holiday-oriental-holidays "23.1")
(defvar holiday-oriental-holidays (mapcar 'purecopy '((holiday-chinese-new-year) (if calendar-chinese-all-holidays-flag (append (holiday-chinese 1 15 "Lantern Festival") (holiday-chinese-qingming) (holiday-chinese 5 5 "Dragon Boat Festival") (holiday-chinese 7 7 "Double Seventh Festival") (holiday-chinese 8 15 "Mid-Autumn Festival") (holiday-chinese 9 9 "Double Ninth Festival") (holiday-chinese-winter-solstice))))) "\
Oriental holidays.
@@ -13110,7 +13146,7 @@ See the documentation for `calendar-holidays' for details.")
(put 'holiday-oriental-holidays 'risky-local-variable t)
-(define-obsolete-variable-alias 'oriental-holidays 'holiday-oriental-holidays "23.1")
+(define-obsolete-variable-alias 'local-holidays 'holiday-local-holidays "23.1")
(defvar holiday-local-holidays nil "\
Local holidays.
@@ -13120,7 +13156,7 @@ See the documentation for `calendar-holidays' for details.")
(put 'holiday-local-holidays 'risky-local-variable t)
-(define-obsolete-variable-alias 'local-holidays 'holiday-local-holidays "23.1")
+(define-obsolete-variable-alias 'other-holidays 'holiday-other-holidays "23.1")
(defvar holiday-other-holidays nil "\
User defined holidays.
@@ -13130,8 +13166,6 @@ See the documentation for `calendar-holidays' for details.")
(put 'holiday-other-holidays 'risky-local-variable t)
-(define-obsolete-variable-alias 'other-holidays 'holiday-other-holidays "23.1")
-
(defvar hebrew-holidays-1 (mapcar 'purecopy '((holiday-hebrew-rosh-hashanah) (if calendar-hebrew-all-holidays-flag (holiday-julian 11 (let ((m displayed-month) (y displayed-year) year) (calendar-increment-month m y -1) (setq year (calendar-extract-year (calendar-julian-from-absolute (calendar-absolute-from-gregorian (list m 1 y))))) (if (zerop (% (1+ year) 4)) 22 21)) "\"Tal Umatar\" (evening)")))) "\
Component of the old default value of `holiday-hebrew-holidays'.")
@@ -13152,6 +13186,8 @@ Component of the old default value of `holiday-hebrew-holidays'.")
(put 'hebrew-holidays-4 'risky-local-variable t)
+(define-obsolete-variable-alias 'hebrew-holidays 'holiday-hebrew-holidays "23.1")
+
(defvar holiday-hebrew-holidays (mapcar 'purecopy '((holiday-hebrew-passover) (holiday-hebrew-rosh-hashanah) (holiday-hebrew-hanukkah) (if calendar-hebrew-all-holidays-flag (append (holiday-hebrew-tisha-b-av) (holiday-hebrew-misc))))) "\
Jewish holidays.
See the documentation for `calendar-holidays' for details.")
@@ -13160,7 +13196,7 @@ See the documentation for `calendar-holidays' for details.")
(put 'holiday-hebrew-holidays 'risky-local-variable t)
-(define-obsolete-variable-alias 'hebrew-holidays 'holiday-hebrew-holidays "23.1")
+(define-obsolete-variable-alias 'christian-holidays 'holiday-christian-holidays "23.1")
(defvar holiday-christian-holidays (mapcar 'purecopy '((holiday-easter-etc) (holiday-fixed 12 25 "Christmas") (if calendar-christian-all-holidays-flag (append (holiday-fixed 1 6 "Epiphany") (holiday-julian 12 25 "Eastern Orthodox Christmas") (holiday-greek-orthodox-easter) (holiday-fixed 8 15 "Assumption") (holiday-advent 0 "Advent"))))) "\
Christian holidays.
@@ -13170,7 +13206,7 @@ See the documentation for `calendar-holidays' for details.")
(put 'holiday-christian-holidays 'risky-local-variable t)
-(define-obsolete-variable-alias 'christian-holidays 'holiday-christian-holidays "23.1")
+(define-obsolete-variable-alias 'islamic-holidays 'holiday-islamic-holidays "23.1")
(defvar holiday-islamic-holidays (mapcar 'purecopy '((holiday-islamic-new-year) (holiday-islamic 9 1 "Ramadan Begins") (if calendar-islamic-all-holidays-flag (append (holiday-islamic 1 10 "Ashura") (holiday-islamic 3 12 "Mulad-al-Nabi") (holiday-islamic 7 26 "Shab-e-Mi'raj") (holiday-islamic 8 15 "Shab-e-Bara't") (holiday-islamic 9 27 "Shab-e Qadr") (holiday-islamic 10 1 "Id-al-Fitr") (holiday-islamic 12 10 "Id-al-Adha"))))) "\
Islamic holidays.
@@ -13180,7 +13216,7 @@ See the documentation for `calendar-holidays' for details.")
(put 'holiday-islamic-holidays 'risky-local-variable t)
-(define-obsolete-variable-alias 'islamic-holidays 'holiday-islamic-holidays "23.1")
+(define-obsolete-variable-alias 'bahai-holidays 'holiday-bahai-holidays "23.1")
(defvar holiday-bahai-holidays (mapcar 'purecopy '((holiday-bahai-new-year) (holiday-bahai-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 calendar-bahai-all-holidays-flag (append (holiday-fixed 11 26 "Day of the Covenant") (holiday-fixed 11 28 "Ascension of `Abdu'l-Baha"))))) "\
Baha'i holidays.
@@ -13190,7 +13226,7 @@ See the documentation for `calendar-holidays' for details.")
(put 'holiday-bahai-holidays 'risky-local-variable t)
-(define-obsolete-variable-alias 'bahai-holidays 'holiday-bahai-holidays "23.1")
+(define-obsolete-variable-alias 'solar-holidays 'holiday-solar-holidays "23.1")
(defvar holiday-solar-holidays (mapcar 'purecopy '((solar-equinoxes-solstices) (holiday-sexp calendar-daylight-savings-starts (format "Daylight Saving Time Begins %s" (solar-time-string (/ calendar-daylight-savings-starts-time (float 60)) calendar-standard-time-zone-name))) (holiday-sexp calendar-daylight-savings-ends (format "Daylight Saving Time Ends %s" (solar-time-string (/ calendar-daylight-savings-ends-time (float 60)) calendar-daylight-time-zone-name))))) "\
Sun-related holidays.
@@ -13200,8 +13236,6 @@ See the documentation for `calendar-holidays' for details.")
(put 'holiday-solar-holidays 'risky-local-variable t)
-(define-obsolete-variable-alias 'solar-holidays 'holiday-solar-holidays "23.1")
-
(put 'calendar-holidays 'risky-local-variable t)
(autoload 'holidays "holidays" "\
@@ -13237,8 +13271,8 @@ The optional LABEL is used to label the buffer created.
;;;***
-;;;### (autoloads (html2text) "html2text" "gnus/html2text.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (html2text) "html2text" "gnus/html2text.el" (19582
+;;;;;; 65302))
;;; Generated autoloads from gnus/html2text.el
(autoload 'html2text "html2text" "\
@@ -13249,7 +13283,7 @@ Convert HTML to plain text in the current buffer.
;;;***
;;;### (autoloads (htmlfontify-copy-and-link-dir htmlfontify-buffer)
-;;;;;; "htmlfontify" "htmlfontify.el" (19636 58496))
+;;;;;; "htmlfontify" "htmlfontify.el" (19631 26857))
;;; Generated autoloads from htmlfontify.el
(autoload 'htmlfontify-buffer "htmlfontify" "\
@@ -13282,8 +13316,8 @@ You may also want to set `hfy-page-header' and `hfy-page-footer'.
;;;***
;;;### (autoloads (define-ibuffer-filter define-ibuffer-op define-ibuffer-sorter
-;;;;;; define-ibuffer-column) "ibuf-macs" "ibuf-macs.el" (19636
-;;;;;; 58496))
+;;;;;; define-ibuffer-column) "ibuf-macs" "ibuf-macs.el" (19580
+;;;;;; 19536))
;;; Generated autoloads from ibuf-macs.el
(autoload 'define-ibuffer-column "ibuf-macs" "\
@@ -13311,6 +13345,8 @@ change its definition, you should explicitly call
\(fn SYMBOL (&key NAME INLINE PROPS SUMMARIZER) &rest BODY)" nil (quote macro))
+(put 'define-ibuffer-column 'lisp-indent-function 'defun)
+
(autoload 'define-ibuffer-sorter "ibuf-macs" "\
Define a method of sorting named NAME.
DOCUMENTATION is the documentation of the function, which will be called
@@ -13323,6 +13359,8 @@ value if and only if `a' is \"less than\" `b'.
\(fn NAME DOCUMENTATION (&key DESCRIPTION) &rest BODY)" nil (quote macro))
+(put 'define-ibuffer-sorter 'lisp-indent-function '1)
+
(autoload 'define-ibuffer-op "ibuf-macs" "\
Generate a function which operates on a buffer.
OP becomes the name of the function; if it doesn't begin with
@@ -13356,6 +13394,8 @@ macro for exactly what it does.
\(fn OP ARGS DOCUMENTATION (&key INTERACTIVE MARK MODIFIER-P DANGEROUS OPSTRING ACTIVE-OPSTRING COMPLEX) &rest BODY)" nil (quote macro))
+(put 'define-ibuffer-op 'lisp-indent-function '2)
+
(autoload 'define-ibuffer-filter "ibuf-macs" "\
Define a filter named NAME.
DOCUMENTATION is the documentation of the function.
@@ -13369,10 +13409,12 @@ bound to the current value of the filter.
\(fn NAME DOCUMENTATION (&key READER DESCRIPTION) &rest BODY)" nil (quote macro))
+(put 'define-ibuffer-filter 'lisp-indent-function '2)
+
;;;***
;;;### (autoloads (ibuffer ibuffer-other-window ibuffer-list-buffers)
-;;;;;; "ibuffer" "ibuffer.el" (19636 58496))
+;;;;;; "ibuffer" "ibuffer.el" (19632 44567))
;;; Generated autoloads from ibuffer.el
(autoload 'ibuffer-list-buffers "ibuffer" "\
@@ -13413,7 +13455,7 @@ FORMATS is the value to use for `ibuffer-formats'.
;;;### (autoloads (icalendar-import-buffer icalendar-import-file
;;;;;; icalendar-export-region icalendar-export-file) "icalendar"
-;;;;;; "calendar/icalendar.el" (19636 58496))
+;;;;;; "calendar/icalendar.el" (19580 19536))
;;; Generated autoloads from calendar/icalendar.el
(autoload 'icalendar-export-file "icalendar" "\
@@ -13465,8 +13507,8 @@ buffer `*icalendar-errors*'.
;;;***
-;;;### (autoloads (icomplete-mode) "icomplete" "icomplete.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (icomplete-mode) "icomplete" "icomplete.el" (19408
+;;;;;; 44404))
;;; Generated autoloads from icomplete.el
(defvar icomplete-mode nil "\
@@ -13487,7 +13529,7 @@ otherwise turn it off.
;;;***
-;;;### (autoloads (icon-mode) "icon" "progmodes/icon.el" (19636 58496))
+;;;### (autoloads (icon-mode) "icon" "progmodes/icon.el" (19668 19042))
;;; Generated autoloads from progmodes/icon.el
(autoload 'icon-mode "icon" "\
@@ -13528,7 +13570,7 @@ with no args, if that value is non-nil.
;;;***
;;;### (autoloads (idlwave-shell) "idlw-shell" "progmodes/idlw-shell.el"
-;;;;;; (19636 58496))
+;;;;;; (19675 14361))
;;; Generated autoloads from progmodes/idlw-shell.el
(autoload 'idlwave-shell "idlw-shell" "\
@@ -13554,7 +13596,7 @@ See also the variable `idlwave-shell-prompt-pattern'.
;;;***
;;;### (autoloads (idlwave-mode) "idlwave" "progmodes/idlwave.el"
-;;;;;; (19636 58496))
+;;;;;; (19675 14373))
;;; Generated autoloads from progmodes/idlwave.el
(autoload 'idlwave-mode "idlwave" "\
@@ -13688,8 +13730,8 @@ The main features of this mode are
;;;;;; ido-find-alternate-file ido-find-file-other-window ido-find-file
;;;;;; ido-find-file-in-dir ido-switch-buffer-other-frame ido-insert-buffer
;;;;;; ido-kill-buffer ido-display-buffer ido-switch-buffer-other-window
-;;;;;; ido-switch-buffer ido-mode ido-mode) "ido" "ido.el" (19636
-;;;;;; 58496))
+;;;;;; ido-switch-buffer ido-mode ido-mode) "ido" "ido.el" (19604
+;;;;;; 1959))
;;; Generated autoloads from ido.el
(defvar ido-mode nil "\
@@ -13950,7 +13992,7 @@ DEF, if non-nil, is the default value.
;;;***
-;;;### (autoloads (ielm) "ielm" "ielm.el" (19636 58496))
+;;;### (autoloads (ielm) "ielm" "ielm.el" (19277 34916))
;;; Generated autoloads from ielm.el
(add-hook 'same-window-buffer-names (purecopy "*ielm*"))
@@ -13962,14 +14004,10 @@ Switches to the buffer `*ielm*', or creates it if it does not exist.
;;;***
-;;;### (autoloads (iimage-mode turn-on-iimage-mode) "iimage" "iimage.el"
-;;;;;; (19636 58496))
+;;;### (autoloads (iimage-mode) "iimage" "iimage.el" (19629 13333))
;;; Generated autoloads from iimage.el
-(autoload 'turn-on-iimage-mode "iimage" "\
-Unconditionally turn on iimage mode.
-
-\(fn)" t nil)
+(define-obsolete-function-alias 'turn-on-iimage-mode 'iimage-mode "24.1")
(autoload 'iimage-mode "iimage" "\
Toggle inline image minor mode.
@@ -13978,11 +14016,12 @@ Toggle inline image minor mode.
;;;***
-;;;### (autoloads (defimage find-image remove-images insert-sliced-image
-;;;;;; insert-image put-image create-image image-type-auto-detected-p
-;;;;;; image-type-available-p image-type image-type-from-file-name
-;;;;;; image-type-from-file-header image-type-from-buffer image-type-from-data)
-;;;;;; "image" "image.el" (19636 58496))
+;;;### (autoloads (imagemagick-register-types create-animated-image
+;;;;;; defimage find-image remove-images insert-sliced-image insert-image
+;;;;;; put-image create-image image-type-auto-detected-p image-type-available-p
+;;;;;; image-type image-type-from-file-name image-type-from-file-header
+;;;;;; image-type-from-buffer image-type-from-data) "image" "image.el"
+;;;;;; (19652 54251))
;;; Generated autoloads from image.el
(autoload 'image-type-from-data "image" "\
@@ -14156,6 +14195,29 @@ Example:
\(fn SYMBOL SPECS &optional DOC)" nil (quote macro))
+(put 'defimage 'doc-string-elt '3)
+
+(autoload 'create-animated-image "image" "\
+Create an animated image.
+FILE-OR-DATA is an image file name or image data.
+Optional TYPE is a symbol describing the image type. If TYPE is omitted
+or nil, try to determine the image type from its first few bytes
+of image data. If that doesn't work, and FILE-OR-DATA is a file name,
+use its file extension as image type.
+Optional DATA-P non-nil means FILE-OR-DATA is a string containing image data.
+Optional PROPS are additional image attributes to assign to the image,
+like, e.g. `:mask MASK'.
+Value is the image created, or nil if images of type TYPE are not supported.
+
+Images should not be larger than specified by `max-image-size'.
+
+\(fn FILE-OR-DATA &optional TYPE DATA-P &rest PROPS)" nil nil)
+
+(autoload 'imagemagick-register-types "image" "\
+Register the file types that ImageMagick is able to handle.
+
+\(fn)" nil nil)
+
;;;***
;;;### (autoloads (image-dired-dired-edit-comment-and-tags image-dired-mark-tagged-files
@@ -14164,14 +14226,18 @@ Example:
;;;;;; image-dired-display-thumbs-append image-dired-setup-dired-keybindings
;;;;;; image-dired-jump-thumbnail-buffer image-dired-delete-tag
;;;;;; image-dired-tag-files image-dired-show-all-from-dir image-dired-display-thumbs
-;;;;;; image-dired-dired-with-window-configuration image-dired-dired-insert-marked-thumbs)
-;;;;;; "image-dired" "image-dired.el" (19636 58496))
+;;;;;; image-dired-dired-with-window-configuration image-dired-dired-toggle-marked-thumbs)
+;;;;;; "image-dired" "image-dired.el" (19457 25386))
;;; Generated autoloads from image-dired.el
-(autoload 'image-dired-dired-insert-marked-thumbs "image-dired" "\
-Insert thumbnails before file names of marked files in the dired buffer.
+(autoload 'image-dired-dired-toggle-marked-thumbs "image-dired" "\
+Toggle thumbnails in front of file names in the dired buffer.
+If no marked file could be found, insert or hide thumbnails on the
+current line. ARG, if non-nil, specifies the files to use instead
+of the marked files. If ARG is an integer, use the next ARG (or
+previous -ARG, if ARG<0) files.
-\(fn)" t nil)
+\(fn &optional ARG)" t nil)
(autoload 'image-dired-dired-with-window-configuration "image-dired" "\
Open directory DIR and create a default window configuration.
@@ -14299,7 +14365,7 @@ easy-to-use form.
;;;### (autoloads (auto-image-file-mode insert-image-file image-file-name-regexp
;;;;;; image-file-name-regexps image-file-name-extensions) "image-file"
-;;;;;; "image-file.el" (19636 58496))
+;;;;;; "image-file.el" (19277 34916))
;;; Generated autoloads from image-file.el
(defvar image-file-name-extensions (purecopy '("png" "jpeg" "jpg" "gif" "tiff" "tif" "xbm" "xpm" "pbm" "pgm" "ppm" "pnm" "svg")) "\
@@ -14361,17 +14427,8 @@ Image files are those whose name has an extension in
;;;***
;;;### (autoloads (image-bookmark-jump image-mode-as-text image-minor-mode
-;;;;;; image-mode) "image-mode" "image-mode.el" (19636 58496))
+;;;;;; image-mode) "image-mode" "image-mode.el" (19611 35948))
;;; Generated autoloads from image-mode.el
- (push (cons (purecopy "\\.jpe?g\\'") 'image-mode) auto-mode-alist)
- (push (cons (purecopy "\\.png\\'") 'image-mode) auto-mode-alist)
- (push (cons (purecopy "\\.gif\\'") 'image-mode) auto-mode-alist)
- (push (cons (purecopy "\\.tiff?\\'") 'image-mode) auto-mode-alist)
- (push (cons (purecopy "\\.p[bpgn]m\\'") 'image-mode) auto-mode-alist)
- (push (cons (purecopy "\\.x[bp]m\\'") 'c-mode) auto-mode-alist)
- (push (cons (purecopy "\\.x[bp]m\\'") 'image-mode) auto-mode-alist)
- (push (cons (purecopy "\\.svgz?\\'") 'xml-mode) auto-mode-alist)
- (push (cons (purecopy "\\.svgz?\\'") 'image-mode) auto-mode-alist)
(autoload 'image-mode "image-mode" "\
Major mode for image files.
@@ -14411,7 +14468,7 @@ Not documented
;;;***
;;;### (autoloads (imenu imenu-add-menubar-index imenu-add-to-menubar
-;;;;;; imenu-sort-function) "imenu" "imenu.el" (19636 58496))
+;;;;;; imenu-sort-function) "imenu" "imenu.el" (19611 60767))
;;; Generated autoloads from imenu.el
(defvar imenu-sort-function nil "\
@@ -14528,7 +14585,7 @@ for more information.
;;;### (autoloads (indian-2-column-to-ucs-region in-is13194-pre-write-conversion
;;;;;; in-is13194-post-read-conversion indian-compose-string indian-compose-region)
-;;;;;; "ind-util" "language/ind-util.el" (19636 58496))
+;;;;;; "ind-util" "language/ind-util.el" (19277 34920))
;;; Generated autoloads from language/ind-util.el
(autoload 'indian-compose-region "ind-util" "\
@@ -14560,7 +14617,7 @@ Convert old Emacs Devanagari characters to UCS.
;;;### (autoloads (inferior-lisp inferior-lisp-prompt inferior-lisp-load-command
;;;;;; inferior-lisp-program inferior-lisp-filter-regexp) "inf-lisp"
-;;;;;; "progmodes/inf-lisp.el" (19636 58496))
+;;;;;; "progmodes/inf-lisp.el" (19634 23255))
;;; Generated autoloads from progmodes/inf-lisp.el
(defvar inferior-lisp-filter-regexp (purecopy "\\`\\s *\\(:\\(\\w\\|\\s_\\)\\)?\\s *\\'") "\
@@ -14628,7 +14685,7 @@ of `inferior-lisp-program'). Runs the hooks from
;;;;;; Info-goto-emacs-command-node Info-mode info-finder info-apropos
;;;;;; Info-index Info-directory Info-on-current-buffer info-standalone
;;;;;; info-emacs-manual info info-other-window) "info" "info.el"
-;;;;;; (19636 58496))
+;;;;;; (19688 19082))
;;; Generated autoloads from info.el
(autoload 'info-other-window "info" "\
@@ -14703,8 +14760,11 @@ Build a menu of the possible matches.
(autoload 'info-finder "info" "\
Display descriptions of the keywords in the Finder virtual manual.
+In interactive use, a prefix argument directs this command to read
+a list of keywords separated by comma. After that, it displays a node
+with a list packages that contain all specified keywords.
-\(fn)" t nil)
+\(fn &optional KEYWORDS)" t nil)
(autoload 'Info-mode "info" "\
Info mode provides commands for browsing through the Info documentation tree.
@@ -14768,7 +14828,7 @@ Advanced commands:
\\[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>.
-\(fn)" nil nil)
+\(fn)" t nil)
(put 'Info-goto-emacs-command-node 'info-file (purecopy "emacs"))
(autoload 'Info-goto-emacs-command-node "info" "\
@@ -14807,7 +14867,7 @@ type returned by `Info-bookmark-make-record', which see.
;;;### (autoloads (info-complete-file info-complete-symbol info-lookup-file
;;;;;; info-lookup-symbol info-lookup-reset) "info-look" "info-look.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34916))
;;; Generated autoloads from info-look.el
(autoload 'info-lookup-reset "info-look" "\
@@ -14855,7 +14915,7 @@ Perform completion on file preceding point.
;;;***
;;;### (autoloads (info-xref-check-all-custom info-xref-check-all
-;;;;;; info-xref-check) "info-xref" "info-xref.el" (19636 58496))
+;;;;;; info-xref-check) "info-xref" "info-xref.el" (19277 34916))
;;; Generated autoloads from info-xref.el
(autoload 'info-xref-check "info-xref" "\
@@ -14882,7 +14942,7 @@ quite a while.
;;;***
;;;### (autoloads (batch-info-validate Info-validate Info-split Info-split-threshold
-;;;;;; Info-tagify) "informat" "informat.el" (19636 58496))
+;;;;;; Info-tagify) "informat" "informat.el" (19277 34916))
;;; Generated autoloads from informat.el
(autoload 'Info-tagify "informat" "\
@@ -14929,7 +14989,7 @@ For example, invoke \"emacs -batch -f batch-info-validate $info/ ~/*.info\"
;;;### (autoloads (isearch-process-search-multibyte-characters isearch-toggle-input-method
;;;;;; isearch-toggle-specified-input-method) "isearch-x" "international/isearch-x.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34920))
;;; Generated autoloads from international/isearch-x.el
(autoload 'isearch-toggle-specified-input-method "isearch-x" "\
@@ -14949,8 +15009,8 @@ Not documented
;;;***
-;;;### (autoloads (isearchb-activate) "isearchb" "isearchb.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (isearchb-activate) "isearchb" "isearchb.el" (19277
+;;;;;; 34916))
;;; Generated autoloads from isearchb.el
(autoload 'isearchb-activate "isearchb" "\
@@ -14966,7 +15026,7 @@ accessed via isearchb.
;;;### (autoloads (iso-cvt-define-menu iso-cvt-write-only iso-cvt-read-only
;;;;;; iso-sgml2iso iso-iso2sgml iso-iso2duden iso-iso2gtex iso-gtex2iso
;;;;;; iso-tex2iso iso-iso2tex iso-german iso-spanish) "iso-cvt"
-;;;;;; "international/iso-cvt.el" (19636 58496))
+;;;;;; "international/iso-cvt.el" (19277 34920))
;;; Generated autoloads from international/iso-cvt.el
(autoload 'iso-spanish "iso-cvt" "\
@@ -15057,7 +15117,7 @@ Add submenus to the File menu, to convert to and from various formats.
;;;***
;;;### (autoloads nil "iso-transl" "international/iso-transl.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34920))
;;; Generated autoloads from international/iso-transl.el
(or key-translation-map (setq key-translation-map (make-sparse-keymap)))
(define-key key-translation-map "\C-x8" 'iso-transl-ctl-x-8-map)
@@ -15069,8 +15129,9 @@ Add submenus to the File menu, to convert to and from various formats.
;;;;;; ispell-complete-word ispell-continue ispell-buffer ispell-comments-and-strings
;;;;;; ispell-region ispell-change-dictionary ispell-kill-ispell
;;;;;; ispell-help ispell-pdict-save ispell-word ispell-personal-dictionary)
-;;;;;; "ispell" "textmodes/ispell.el" (19636 58496))
+;;;;;; "ispell" "textmodes/ispell.el" (19672 56753))
;;; Generated autoloads from textmodes/ispell.el
+
(put 'ispell-check-comments 'safe-local-variable (lambda (a) (memq a '(nil t exclusive))))
(defvar ispell-personal-dictionary nil "\
@@ -15080,6 +15141,7 @@ If nil, the default personal dictionary, (\"~/.ispell_DICTNAME\" for ispell or
default dictionary and LANG the two letter language code.")
(custom-autoload 'ispell-personal-dictionary "ispell" t)
+
(put 'ispell-local-dictionary 'safe-local-variable 'string-or-null-p)
(defvar ispell-menu-map nil "\
@@ -15287,8 +15349,8 @@ You can bind this to the key C-c i in GNUS or mail by adding to
;;;***
-;;;### (autoloads (iswitchb-mode) "iswitchb" "iswitchb.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (iswitchb-mode) "iswitchb" "iswitchb.el" (19656
+;;;;;; 61992))
;;; Generated autoloads from iswitchb.el
(defvar iswitchb-mode nil "\
@@ -15313,7 +15375,7 @@ This mode enables switching between buffers using substrings. See
;;;### (autoloads (read-hiragana-string japanese-zenkaku-region japanese-hankaku-region
;;;;;; japanese-hiragana-region japanese-katakana-region japanese-zenkaku
;;;;;; japanese-hankaku japanese-hiragana japanese-katakana setup-japanese-environment-internal)
-;;;;;; "japan-util" "language/japan-util.el" (19636 58496))
+;;;;;; "japan-util" "language/japan-util.el" (19277 34920))
;;; Generated autoloads from language/japan-util.el
(autoload 'setup-japanese-environment-internal "japan-util" "\
@@ -15391,7 +15453,7 @@ If non-nil, second arg INITIAL-INPUT is a string to insert before reading.
;;;***
;;;### (autoloads (jka-compr-uninstall jka-compr-handler) "jka-compr"
-;;;;;; "jka-compr.el" (19636 58496))
+;;;;;; "jka-compr.el" (19455 3103))
;;; Generated autoloads from jka-compr.el
(defvar jka-compr-inhibit nil "\
@@ -15414,7 +15476,7 @@ by `jka-compr-installed'.
;;;***
-;;;### (autoloads (js-mode) "js" "progmodes/js.el" (19636 58496))
+;;;### (autoloads (js-mode) "js" "progmodes/js.el" (19670 666))
;;; Generated autoloads from progmodes/js.el
(autoload 'js-mode "js" "\
@@ -15432,7 +15494,7 @@ Key bindings:
;;;### (autoloads (keypad-setup keypad-numlock-shifted-setup keypad-shifted-setup
;;;;;; keypad-numlock-setup keypad-setup) "keypad" "emulation/keypad.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34919))
;;; Generated autoloads from emulation/keypad.el
(defvar keypad-setup nil "\
@@ -15488,7 +15550,7 @@ the decimal key on the keypad is mapped to DECIMAL instead of `.'
;;;***
;;;### (autoloads (kinsoku) "kinsoku" "international/kinsoku.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34920))
;;; Generated autoloads from international/kinsoku.el
(autoload 'kinsoku "kinsoku" "\
@@ -15509,8 +15571,8 @@ the context of text formatting.
;;;***
-;;;### (autoloads (kkc-region) "kkc" "international/kkc.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (kkc-region) "kkc" "international/kkc.el" (19609
+;;;;;; 2343))
;;; Generated autoloads from international/kkc.el
(defvar kkc-after-update-conversion-functions nil "\
@@ -15535,7 +15597,7 @@ and the return value is the length of the conversion.
;;;### (autoloads (kmacro-end-call-mouse kmacro-end-and-call-macro
;;;;;; kmacro-end-or-call-macro kmacro-start-macro-or-insert-counter
;;;;;; kmacro-call-macro kmacro-end-macro kmacro-start-macro kmacro-exec-ring-item)
-;;;;;; "kmacro" "kmacro.el" (19636 58496))
+;;;;;; "kmacro" "kmacro.el" (19498 12592))
;;; Generated autoloads from kmacro.el
(global-set-key "\C-x(" 'kmacro-start-macro)
(global-set-key "\C-x)" 'kmacro-end-macro)
@@ -15646,7 +15708,7 @@ If kbd macro currently being defined end it before activating it.
;;;***
;;;### (autoloads (setup-korean-environment-internal) "korea-util"
-;;;;;; "language/korea-util.el" (19636 58496))
+;;;;;; "language/korea-util.el" (19277 34920))
;;; Generated autoloads from language/korea-util.el
(defvar default-korean-keyboard (purecopy (if (string-match "3" (or (getenv "HANGUL_KEYBOARD_TYPE") "")) "3" "")) "\
@@ -15661,7 +15723,7 @@ Not documented
;;;***
;;;### (autoloads (lm lm-test-run) "landmark" "play/landmark.el"
-;;;;;; (19658 61388))
+;;;;;; (19675 8295))
;;; Generated autoloads from play/landmark.el
(defalias 'landmark-repeat 'lm-test-run)
@@ -15695,7 +15757,7 @@ Use \\[describe-mode] for more info.
;;;### (autoloads (lao-compose-region lao-composition-function lao-transcribe-roman-to-lao-string
;;;;;; lao-transcribe-single-roman-syllable-to-lao lao-compose-string)
-;;;;;; "lao-util" "language/lao-util.el" (19636 58496))
+;;;;;; "lao-util" "language/lao-util.el" (19277 34920))
;;; Generated autoloads from language/lao-util.el
(autoload 'lao-compose-string "lao-util" "\
@@ -15734,7 +15796,7 @@ Not documented
;;;### (autoloads (latexenc-find-file-coding-system latexenc-coding-system-to-inputenc
;;;;;; latexenc-inputenc-to-coding-system latex-inputenc-coding-alist)
-;;;;;; "latexenc" "international/latexenc.el" (19636 58496))
+;;;;;; "latexenc" "international/latexenc.el" (19277 34920))
;;; Generated autoloads from international/latexenc.el
(defvar latex-inputenc-coding-alist (purecopy '(("ansinew" . windows-1252) ("applemac" . mac-roman) ("ascii" . us-ascii) ("cp1250" . windows-1250) ("cp1252" . windows-1252) ("cp1257" . cp1257) ("cp437de" . cp437) ("cp437" . cp437) ("cp850" . cp850) ("cp852" . cp852) ("cp858" . cp858) ("cp865" . cp865) ("latin1" . iso-8859-1) ("latin2" . iso-8859-2) ("latin3" . iso-8859-3) ("latin4" . iso-8859-4) ("latin5" . iso-8859-5) ("latin9" . iso-8859-15) ("next" . next) ("utf8" . utf-8) ("utf8x" . utf-8))) "\
@@ -15766,7 +15828,7 @@ coding system names is determined from `latex-inputenc-coding-alist'.
;;;***
;;;### (autoloads (latin1-display-ucs-per-lynx latin1-display latin1-display)
-;;;;;; "latin1-disp" "international/latin1-disp.el" (19636 58496))
+;;;;;; "latin1-disp" "international/latin1-disp.el" (19277 34920))
;;; Generated autoloads from international/latin1-disp.el
(defvar latin1-display nil "\
@@ -15808,15 +15870,9 @@ use either \\[customize] or the function `latin1-display'.")
;;;***
;;;### (autoloads (ld-script-mode) "ld-script" "progmodes/ld-script.el"
-;;;;;; (19636 58496))
+;;;;;; (19611 1232))
;;; Generated autoloads from progmodes/ld-script.el
-(add-to-list 'auto-mode-alist (purecopy '("\\.ld[si]?\\>" . ld-script-mode)))
-
-(add-to-list 'auto-mode-alist (purecopy '("ld\\.?script\\>" . ld-script-mode)))
-
-(add-to-list 'auto-mode-alist (purecopy '("\\.x[bdsru]?[cn]?\\'" . ld-script-mode)))
-
(autoload 'ld-script-mode "ld-script" "\
A major mode to edit GNU ld script files
@@ -15825,7 +15881,7 @@ A major mode to edit GNU ld script files
;;;***
;;;### (autoloads (ledit-from-lisp-mode ledit-mode) "ledit" "ledit.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34916))
;;; Generated autoloads from ledit.el
(defconst ledit-save-files t "\
@@ -15860,7 +15916,7 @@ Not documented
;;;***
-;;;### (autoloads (life) "life" "play/life.el" (19636 58496))
+;;;### (autoloads (life) "life" "play/life.el" (19668 18627))
;;; Generated autoloads from play/life.el
(autoload 'life "life" "\
@@ -15874,7 +15930,7 @@ generations (this defaults to 1).
;;;***
;;;### (autoloads (global-linum-mode linum-mode linum-format) "linum"
-;;;;;; "linum.el" (19636 58496))
+;;;;;; "linum.el" (19580 19536))
;;; Generated autoloads from linum.el
(defvar linum-format 'dynamic "\
@@ -15912,8 +15968,8 @@ See `linum-mode' for more information on Linum mode.
;;;***
-;;;### (autoloads (unload-feature) "loadhist" "loadhist.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (unload-feature) "loadhist" "loadhist.el" (19277
+;;;;;; 34916))
;;; Generated autoloads from loadhist.el
(autoload 'unload-feature "loadhist" "\
@@ -15945,7 +16001,7 @@ something strange, such as redefining an Emacs function.
;;;***
;;;### (autoloads (locate-with-filter locate locate-ls-subdir-switches)
-;;;;;; "locate" "locate.el" (19662 53673))
+;;;;;; "locate" "locate.el" (19673 45510))
;;; Generated autoloads from locate.el
(defvar locate-ls-subdir-switches (purecopy "-al") "\
@@ -15997,8 +16053,8 @@ except that FILTER is not optional.
;;;***
-;;;### (autoloads (log-edit) "log-edit" "log-edit.el" (19661 52402))
-;;; Generated autoloads from log-edit.el
+;;;### (autoloads (log-edit) "log-edit" "vc/log-edit.el" (19657 48297))
+;;; Generated autoloads from vc/log-edit.el
(autoload 'log-edit "log-edit" "\
Setup a buffer to enter a log message.
@@ -16024,9 +16080,9 @@ uses the current buffer.
;;;***
-;;;### (autoloads (log-view-mode) "log-view" "log-view.el" (19661
-;;;;;; 51918))
-;;; Generated autoloads from log-view.el
+;;;### (autoloads (log-view-mode) "log-view" "vc/log-view.el" (19634
+;;;;;; 14572))
+;;; Generated autoloads from vc/log-view.el
(autoload 'log-view-mode "log-view" "\
Major mode for browsing CVS log output.
@@ -16035,8 +16091,8 @@ Major mode for browsing CVS log output.
;;;***
-;;;### (autoloads (longlines-mode) "longlines" "longlines.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (longlines-mode) "longlines" "longlines.el" (19277
+;;;;;; 34916))
;;; Generated autoloads from longlines.el
(autoload 'longlines-mode "longlines" "\
@@ -16057,8 +16113,8 @@ are indicated with a symbol.
;;;***
;;;### (autoloads (print-region lpr-region print-buffer lpr-buffer
-;;;;;; lpr-command lpr-switches printer-name) "lpr" "lpr.el" (19636
-;;;;;; 58496))
+;;;;;; lpr-command lpr-switches printer-name) "lpr" "lpr.el" (19451
+;;;;;; 17238))
;;; Generated autoloads from lpr.el
(defvar lpr-windows-system (memq system-type '(ms-dos windows-nt)))
@@ -16152,7 +16208,7 @@ for further customization of the printer command.
;;;***
;;;### (autoloads (ls-lisp-support-shell-wildcards) "ls-lisp" "ls-lisp.el"
-;;;;;; (19672 43471))
+;;;;;; (19687 6902))
;;; Generated autoloads from ls-lisp.el
(defvar ls-lisp-support-shell-wildcards t "\
@@ -16163,8 +16219,8 @@ Otherwise they are treated as Emacs regexps (for backward compatibility).")
;;;***
-;;;### (autoloads (lunar-phases) "lunar" "calendar/lunar.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (lunar-phases) "lunar" "calendar/lunar.el" (19580
+;;;;;; 19536))
;;; Generated autoloads from calendar/lunar.el
(autoload 'lunar-phases "lunar" "\
@@ -16178,8 +16234,8 @@ This function is suitable for execution in a .emacs file.
;;;***
-;;;### (autoloads (m4-mode) "m4-mode" "progmodes/m4-mode.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (m4-mode) "m4-mode" "progmodes/m4-mode.el" (19277
+;;;;;; 34922))
;;; Generated autoloads from progmodes/m4-mode.el
(autoload 'm4-mode "m4-mode" "\
@@ -16191,7 +16247,7 @@ A major mode to edit m4 macro files.
;;;***
;;;### (autoloads (macroexpand-all) "macroexp" "emacs-lisp/macroexp.el"
-;;;;;; (19636 58496))
+;;;;;; (19580 19536))
;;; Generated autoloads from emacs-lisp/macroexp.el
(autoload 'macroexpand-all "macroexp" "\
@@ -16205,7 +16261,7 @@ definitions to shadow the loaded ones for use in file byte-compilation.
;;;***
;;;### (autoloads (apply-macro-to-region-lines kbd-macro-query insert-kbd-macro
-;;;;;; name-last-kbd-macro) "macros" "macros.el" (19636 58496))
+;;;;;; name-last-kbd-macro) "macros" "macros.el" (19580 19536))
;;; Generated autoloads from macros.el
(autoload 'name-last-kbd-macro "macros" "\
@@ -16294,7 +16350,7 @@ and then select the region of un-tablified names and use
;;;***
;;;### (autoloads (what-domain mail-extract-address-components) "mail-extr"
-;;;;;; "mail/mail-extr.el" (19636 58496))
+;;;;;; "mail/mail-extr.el" (19668 31646))
;;; Generated autoloads from mail/mail-extr.el
(autoload 'mail-extract-address-components "mail-extr" "\
@@ -16326,7 +16382,7 @@ Convert mail domain DOMAIN to the country it corresponds to.
;;;### (autoloads (mail-hist-put-headers-into-history mail-hist-keep-history
;;;;;; mail-hist-enable mail-hist-define-keys) "mail-hist" "mail/mail-hist.el"
-;;;;;; (19636 58496))
+;;;;;; (19580 19536))
;;; Generated autoloads from mail/mail-hist.el
(autoload 'mail-hist-define-keys "mail-hist" "\
@@ -16358,7 +16414,7 @@ This function normally would be called when the message is sent.
;;;### (autoloads (mail-fetch-field mail-unquote-printable-region
;;;;;; mail-unquote-printable mail-quote-printable-region mail-quote-printable
;;;;;; mail-file-babyl-p mail-use-rfc822) "mail-utils" "mail/mail-utils.el"
-;;;;;; (19636 58496))
+;;;;;; (19635 50568))
;;; Generated autoloads from mail/mail-utils.el
(defvar mail-use-rfc822 nil "\
@@ -16420,8 +16476,8 @@ matches may be returned from the message body.
;;;***
;;;### (autoloads (define-mail-abbrev build-mail-abbrevs mail-abbrevs-setup
-;;;;;; mail-abbrevs-mode) "mailabbrev" "mail/mailabbrev.el" (19636
-;;;;;; 58496))
+;;;;;; mail-abbrevs-mode) "mailabbrev" "mail/mailabbrev.el" (19277
+;;;;;; 34921))
;;; Generated autoloads from mail/mailabbrev.el
(defvar mail-abbrevs-mode nil "\
@@ -16463,8 +16519,8 @@ double-quotes.
;;;***
;;;### (autoloads (mail-complete define-mail-alias expand-mail-aliases
-;;;;;; mail-complete-style) "mailalias" "mail/mailalias.el" (19636
-;;;;;; 58496))
+;;;;;; mail-complete-style) "mailalias" "mail/mailalias.el" (19277
+;;;;;; 34921))
;;; Generated autoloads from mail/mailalias.el
(defvar mail-complete-style 'angles "\
@@ -16510,7 +16566,7 @@ current header, calls `mail-complete-function' and passes prefix arg if any.
;;;***
;;;### (autoloads (mailclient-send-it) "mailclient" "mail/mailclient.el"
-;;;;;; (19636 58496))
+;;;;;; (19693 26133))
;;; Generated autoloads from mail/mailclient.el
(autoload 'mailclient-send-it "mailclient" "\
@@ -16524,7 +16580,7 @@ The mail client is taken to be the handler of mailto URLs.
;;;### (autoloads (makefile-imake-mode makefile-bsdmake-mode makefile-makepp-mode
;;;;;; makefile-gmake-mode makefile-automake-mode makefile-mode)
-;;;;;; "make-mode" "progmodes/make-mode.el" (19636 58496))
+;;;;;; "make-mode" "progmodes/make-mode.el" (19594 48841))
;;; Generated autoloads from progmodes/make-mode.el
(autoload 'makefile-mode "make-mode" "\
@@ -16641,8 +16697,8 @@ An adapted `makefile-mode' that knows about imake.
;;;***
-;;;### (autoloads (make-command-summary) "makesum" "makesum.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (make-command-summary) "makesum" "makesum.el" (19668
+;;;;;; 19366))
;;; Generated autoloads from makesum.el
(autoload 'make-command-summary "makesum" "\
@@ -16653,7 +16709,8 @@ Previous contents of that buffer are killed first.
;;;***
-;;;### (autoloads (man-follow man) "man" "man.el" (19641 1152))
+;;;### (autoloads (Man-bookmark-jump man-follow man) "man" "man.el"
+;;;;;; (19614 24990))
;;; Generated autoloads from man.el
(defalias 'manual-entry 'man)
@@ -16700,9 +16757,14 @@ Get a Un*x manual page of the item under point and put it in a buffer.
\(fn MAN-ARGS)" t nil)
+(autoload 'Man-bookmark-jump "man" "\
+Default bookmark handler for Man buffers.
+
+\(fn BOOKMARK)" nil nil)
+
;;;***
-;;;### (autoloads (master-mode) "master" "master.el" (19636 58496))
+;;;### (autoloads (master-mode) "master" "master.el" (19277 34916))
;;; Generated autoloads from master.el
(autoload 'master-mode "master" "\
@@ -16725,7 +16787,7 @@ yourself the value of `master-of' by calling `master-show-slave'.
;;;***
;;;### (autoloads (minibuffer-depth-indicate-mode) "mb-depth" "mb-depth.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34916))
;;; Generated autoloads from mb-depth.el
(defvar minibuffer-depth-indicate-mode nil "\
@@ -16756,7 +16818,7 @@ Returns non-nil if the new state is enabled.
;;;;;; message-forward-make-body message-forward message-recover
;;;;;; message-supersede message-cancel-news message-followup message-wide-reply
;;;;;; message-reply message-news message-mail message-mode) "message"
-;;;;;; "gnus/message.el" (19636 58496))
+;;;;;; "gnus/message.el" (19695 9549))
;;; Generated autoloads from gnus/message.el
(define-mail-user-agent 'message-user-agent 'message-mail 'message-send-and-exit 'message-kill-buffer 'message-send-hook)
@@ -16922,7 +16984,7 @@ which specify the range to operate on.
;;;***
;;;### (autoloads (metapost-mode metafont-mode) "meta-mode" "progmodes/meta-mode.el"
-;;;;;; (19636 58496))
+;;;;;; (19673 1234))
;;; Generated autoloads from progmodes/meta-mode.el
(autoload 'metafont-mode "meta-mode" "\
@@ -16949,7 +17011,7 @@ Turning on MetaPost mode calls the value of the variable
;;;### (autoloads (metamail-region metamail-buffer metamail-interpret-body
;;;;;; metamail-interpret-header) "metamail" "mail/metamail.el"
-;;;;;; (19636 58496))
+;;;;;; (19354 34807))
;;; Generated autoloads from mail/metamail.el
(autoload 'metamail-interpret-header "metamail" "\
@@ -16994,7 +17056,7 @@ redisplayed as output is inserted.
;;;### (autoloads (mh-fully-kill-draft mh-send-letter mh-user-agent-compose
;;;;;; mh-smail-batch mh-smail-other-window mh-smail) "mh-comp"
-;;;;;; "mh-e/mh-comp.el" (19636 58496))
+;;;;;; "mh-e/mh-comp.el" (19444 23363))
;;; Generated autoloads from mh-e/mh-comp.el
(autoload 'mh-smail "mh-comp" "\
@@ -17084,7 +17146,7 @@ delete the draft message.
;;;***
-;;;### (autoloads (mh-version) "mh-e" "mh-e/mh-e.el" (19636 58496))
+;;;### (autoloads (mh-version) "mh-e" "mh-e/mh-e.el" (19423 37200))
;;; Generated autoloads from mh-e/mh-e.el
(put 'mh-progs 'risky-local-variable t)
@@ -17101,7 +17163,7 @@ Display version information about MH-E and the MH mail handling system.
;;;***
;;;### (autoloads (mh-folder-mode mh-nmail mh-rmail) "mh-folder"
-;;;;;; "mh-e/mh-folder.el" (19636 58496))
+;;;;;; "mh-e/mh-folder.el" (19277 34921))
;;; Generated autoloads from mh-e/mh-folder.el
(autoload 'mh-rmail "mh-folder" "\
@@ -17183,7 +17245,7 @@ perform the operation on all messages in that region.
;;;***
;;;### (autoloads (midnight-delay-set clean-buffer-list) "midnight"
-;;;;;; "midnight.el" (19636 58496))
+;;;;;; "midnight.el" (19369 35251))
;;; Generated autoloads from midnight.el
(autoload 'clean-buffer-list "midnight" "\
@@ -17210,7 +17272,7 @@ to its second argument TM.
;;;***
;;;### (autoloads (minibuffer-electric-default-mode) "minibuf-eldef"
-;;;;;; "minibuf-eldef.el" (19636 58496))
+;;;;;; "minibuf-eldef.el" (19277 34917))
;;; Generated autoloads from minibuf-eldef.el
(defvar minibuffer-electric-default-mode nil "\
@@ -17237,7 +17299,7 @@ Returns non-nil if the new state is enabled.
;;;***
-;;;### (autoloads (butterfly) "misc" "misc.el" (19636 58496))
+;;;### (autoloads (butterfly) "misc" "misc.el" (19668 18610))
;;; Generated autoloads from misc.el
(autoload 'butterfly "misc" "\
@@ -17256,7 +17318,7 @@ variation of `C-x M-c M-butterfly' from url `http://xkcd.com/378/'.
;;;### (autoloads (multi-isearch-files-regexp multi-isearch-files
;;;;;; multi-isearch-buffers-regexp multi-isearch-buffers multi-isearch-setup)
-;;;;;; "misearch" "misearch.el" (19636 58496))
+;;;;;; "misearch" "misearch.el" (19277 34917))
;;; Generated autoloads from misearch.el
(add-hook 'isearch-mode-hook 'multi-isearch-setup)
@@ -17338,7 +17400,7 @@ whose file names match the specified wildcard.
;;;***
;;;### (autoloads (mixal-mode) "mixal-mode" "progmodes/mixal-mode.el"
-;;;;;; (19636 58496))
+;;;;;; (19611 35755))
;;; Generated autoloads from progmodes/mixal-mode.el
(autoload 'mixal-mode "mixal-mode" "\
@@ -17347,12 +17409,10 @@ Major mode for the mixal asm language.
\(fn)" t nil)
-(add-to-list 'auto-mode-alist '("\\.mixal\\'" . mixal-mode))
-
;;;***
;;;### (autoloads (mm-inline-external-body mm-extern-cache-contents)
-;;;;;; "mm-extern" "gnus/mm-extern.el" (19636 58496))
+;;;;;; "mm-extern" "gnus/mm-extern.el" (19635 50568))
;;; Generated autoloads from gnus/mm-extern.el
(autoload 'mm-extern-cache-contents "mm-extern" "\
@@ -17371,7 +17431,7 @@ If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing.
;;;***
;;;### (autoloads (mm-inline-partial) "mm-partial" "gnus/mm-partial.el"
-;;;;;; (19636 58496))
+;;;;;; (19604 65275))
;;; Generated autoloads from gnus/mm-partial.el
(autoload 'mm-inline-partial "mm-partial" "\
@@ -17385,7 +17445,7 @@ If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing.
;;;***
;;;### (autoloads (mm-url-insert-file-contents-external mm-url-insert-file-contents)
-;;;;;; "mm-url" "gnus/mm-url.el" (19636 58496))
+;;;;;; "mm-url" "gnus/mm-url.el" (19582 65302))
;;; Generated autoloads from gnus/mm-url.el
(autoload 'mm-url-insert-file-contents "mm-url" "\
@@ -17402,7 +17462,7 @@ Insert file contents of URL using `mm-url-program'.
;;;***
;;;### (autoloads (mm-uu-dissect-text-parts mm-uu-dissect) "mm-uu"
-;;;;;; "gnus/mm-uu.el" (19636 58496))
+;;;;;; "gnus/mm-uu.el" (19691 3508))
;;; Generated autoloads from gnus/mm-uu.el
(autoload 'mm-uu-dissect "mm-uu" "\
@@ -17422,7 +17482,7 @@ Assume text has been decoded if DECODED is non-nil.
;;;***
;;;### (autoloads (mml1991-sign mml1991-encrypt) "mml1991" "gnus/mml1991.el"
-;;;;;; (19636 58496))
+;;;;;; (19635 50568))
;;; Generated autoloads from gnus/mml1991.el
(autoload 'mml1991-encrypt "mml1991" "\
@@ -17439,7 +17499,7 @@ Not documented
;;;### (autoloads (mml2015-self-encrypt mml2015-sign mml2015-encrypt
;;;;;; mml2015-verify-test mml2015-verify mml2015-decrypt-test mml2015-decrypt)
-;;;;;; "mml2015" "gnus/mml2015.el" (19636 58496))
+;;;;;; "mml2015" "gnus/mml2015.el" (19687 6902))
;;; Generated autoloads from gnus/mml2015.el
(autoload 'mml2015-decrypt "mml2015" "\
@@ -17479,11 +17539,13 @@ Not documented
;;;***
-;;;### (autoloads (modula-2-mode) "modula2" "progmodes/modula2.el"
-;;;;;; (19636 58496))
+;;;### (autoloads (m2-mode) "modula2" "progmodes/modula2.el" (19676
+;;;;;; 36176))
;;; Generated autoloads from progmodes/modula2.el
-(autoload 'modula-2-mode "modula2" "\
+(defalias 'modula-2-mode 'm2-mode)
+
+(autoload 'm2-mode "modula2" "\
This is a mode intended to support program development in Modula-2.
All control constructs of Modula-2 can be reached by typing C-c
followed by the first character of the construct.
@@ -17512,7 +17574,7 @@ followed by the first character of the construct.
;;;***
;;;### (autoloads (unmorse-region morse-region) "morse" "play/morse.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34922))
;;; Generated autoloads from play/morse.el
(autoload 'morse-region "morse" "\
@@ -17528,7 +17590,7 @@ Convert morse coded text in region to ordinary ASCII text.
;;;***
;;;### (autoloads (mouse-drag-drag mouse-drag-throw) "mouse-drag"
-;;;;;; "mouse-drag.el" (19636 58496))
+;;;;;; "mouse-drag.el" (19672 56753))
;;; Generated autoloads from mouse-drag.el
(autoload 'mouse-drag-throw "mouse-drag" "\
@@ -17575,8 +17637,8 @@ To test this function, evaluate:
;;;***
-;;;### (autoloads (mouse-sel-mode) "mouse-sel" "mouse-sel.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (mouse-sel-mode) "mouse-sel" "mouse-sel.el" (19687
+;;;;;; 6902))
;;; Generated autoloads from mouse-sel.el
(defvar mouse-sel-mode nil "\
@@ -17628,7 +17690,7 @@ primary selection and region.
;;;***
-;;;### (autoloads (mpc) "mpc" "mpc.el" (19636 58496))
+;;;### (autoloads (mpc) "mpc" "mpc.el" (19373 24504))
;;; Generated autoloads from mpc.el
(autoload 'mpc "mpc" "\
@@ -17638,7 +17700,7 @@ Main entry point for MPC.
;;;***
-;;;### (autoloads (mpuz) "mpuz" "play/mpuz.el" (19636 58496))
+;;;### (autoloads (mpuz) "mpuz" "play/mpuz.el" (19634 23255))
;;; Generated autoloads from play/mpuz.el
(autoload 'mpuz "mpuz" "\
@@ -17648,7 +17710,7 @@ Multiplication puzzle with GNU Emacs.
;;;***
-;;;### (autoloads (msb-mode) "msb" "msb.el" (19636 58496))
+;;;### (autoloads (msb-mode) "msb" "msb.el" (19277 34917))
;;; Generated autoloads from msb.el
(defvar msb-mode nil "\
@@ -17675,7 +17737,7 @@ different buffer menu using the function `msb'.
;;;;;; describe-current-coding-system describe-current-coding-system-briefly
;;;;;; describe-coding-system describe-character-set list-charset-chars
;;;;;; read-charset list-character-sets) "mule-diag" "international/mule-diag.el"
-;;;;;; (19636 58496))
+;;;;;; (19617 12132))
;;; Generated autoloads from international/mule-diag.el
(autoload 'list-character-sets "mule-diag" "\
@@ -17812,7 +17874,7 @@ The default is 20. If LIMIT is negative, do not limit the listing.
;;;;;; coding-system-translation-table-for-decode coding-system-pre-write-conversion
;;;;;; coding-system-post-read-conversion lookup-nested-alist set-nested-alist
;;;;;; truncate-string-to-width store-substring string-to-sequence)
-;;;;;; "mule-util" "international/mule-util.el" (19636 58496))
+;;;;;; "mule-util" "international/mule-util.el" (19472 31430))
;;; Generated autoloads from international/mule-util.el
(autoload 'string-to-sequence "mule-util" "\
@@ -17952,8 +18014,8 @@ per-character basis, this may not be accurate.
;;;### (autoloads (network-connection network-connection-to-service
;;;;;; whois-reverse-lookup whois finger ftp run-dig dns-lookup-host
;;;;;; nslookup nslookup-host ping traceroute route arp netstat
-;;;;;; iwconfig ifconfig) "net-utils" "net/net-utils.el" (19636
-;;;;;; 58496))
+;;;;;; iwconfig ifconfig) "net-utils" "net/net-utils.el" (19672
+;;;;;; 41548))
;;; Generated autoloads from net/net-utils.el
(autoload 'ifconfig "net-utils" "\
@@ -18047,12 +18109,25 @@ Open a network connection to HOST on PORT.
;;;***
+;;;### (autoloads (netrc-credentials) "netrc" "net/netrc.el" (19621
+;;;;;; 23882))
+;;; Generated autoloads from net/netrc.el
+
+(autoload 'netrc-credentials "netrc" "\
+Return a user name/password pair.
+Port specifications will be prioritised in the order they are
+listed in the PORTS list.
+
+\(fn MACHINE &rest PORTS)" nil nil)
+
+;;;***
+
;;;### (autoloads (comment-indent-new-line comment-auto-fill-only-comments
;;;;;; comment-dwim comment-or-uncomment-region comment-box comment-region
;;;;;; uncomment-region comment-kill comment-set-column comment-indent
;;;;;; comment-indent-default comment-normalize-vars comment-multi-line
;;;;;; comment-padding comment-style comment-column) "newcomment"
-;;;;;; "newcomment.el" (19636 58496))
+;;;;;; "newcomment.el" (19648 59284))
;;; Generated autoloads from newcomment.el
(defalias 'indent-for-comment 'comment-indent)
@@ -18216,8 +18291,8 @@ is passed on to the respective function.
(autoload 'comment-dwim "newcomment" "\
Call the comment command you want (Do What I Mean).
If the region is active and `transient-mark-mode' is on, call
- `comment-region' (unless it only consists of comments, in which
- case it calls `uncomment-region').
+`comment-region' (unless it only consists of comments, in which
+case it calls `uncomment-region').
Else, if the current line is empty, call `comment-insert-comment-function'
if it is defined, otherwise insert a comment and indent it.
Else if a prefix ARG is specified, call `comment-kill'.
@@ -18252,7 +18327,7 @@ unless optional argument SOFT is non-nil.
;;;***
;;;### (autoloads (newsticker-start newsticker-running-p) "newst-backend"
-;;;;;; "net/newst-backend.el" (19636 58496))
+;;;;;; "net/newst-backend.el" (19580 19536))
;;; Generated autoloads from net/newst-backend.el
(autoload 'newsticker-running-p "newst-backend" "\
@@ -18274,7 +18349,7 @@ Run `newsticker-start-hook' if newsticker was not running already.
;;;***
;;;### (autoloads (newsticker-plainview) "newst-plainview" "net/newst-plainview.el"
-;;;;;; (19636 58496))
+;;;;;; (19580 19536))
;;; Generated autoloads from net/newst-plainview.el
(autoload 'newsticker-plainview "newst-plainview" "\
@@ -18285,7 +18360,7 @@ Start newsticker plainview.
;;;***
;;;### (autoloads (newsticker-show-news) "newst-reader" "net/newst-reader.el"
-;;;;;; (19636 58496))
+;;;;;; (19580 19536))
;;; Generated autoloads from net/newst-reader.el
(autoload 'newsticker-show-news "newst-reader" "\
@@ -18296,7 +18371,7 @@ Start reading news. You may want to bind this to a key.
;;;***
;;;### (autoloads (newsticker-start-ticker newsticker-ticker-running-p)
-;;;;;; "newst-ticker" "net/newst-ticker.el" (19636 58496))
+;;;;;; "newst-ticker" "net/newst-ticker.el" (19580 19536))
;;; Generated autoloads from net/newst-ticker.el
(autoload 'newsticker-ticker-running-p "newst-ticker" "\
@@ -18317,7 +18392,7 @@ running already.
;;;***
;;;### (autoloads (newsticker-treeview) "newst-treeview" "net/newst-treeview.el"
-;;;;;; (19636 58496))
+;;;;;; (19580 19536))
;;; Generated autoloads from net/newst-treeview.el
(autoload 'newsticker-treeview "newst-treeview" "\
@@ -18328,7 +18403,7 @@ Start newsticker treeview.
;;;***
;;;### (autoloads (nndiary-generate-nov-databases) "nndiary" "gnus/nndiary.el"
-;;;;;; (19636 58496))
+;;;;;; (19664 37038))
;;; Generated autoloads from gnus/nndiary.el
(autoload 'nndiary-generate-nov-databases "nndiary" "\
@@ -18338,8 +18413,8 @@ Generate NOV databases in all nndiary directories.
;;;***
-;;;### (autoloads (nndoc-add-type) "nndoc" "gnus/nndoc.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (nndoc-add-type) "nndoc" "gnus/nndoc.el" (19661
+;;;;;; 61255))
;;; Generated autoloads from gnus/nndoc.el
(autoload 'nndoc-add-type "nndoc" "\
@@ -18354,7 +18429,7 @@ symbol in the alist.
;;;***
;;;### (autoloads (nnfolder-generate-active-file) "nnfolder" "gnus/nnfolder.el"
-;;;;;; (19636 58496))
+;;;;;; (19695 9549))
;;; Generated autoloads from gnus/nnfolder.el
(autoload 'nnfolder-generate-active-file "nnfolder" "\
@@ -18365,20 +18440,8 @@ This command does not work if you use short group names.
;;;***
-;;;### (autoloads (nnkiboze-generate-groups) "nnkiboze" "gnus/nnkiboze.el"
-;;;;;; (19636 58496))
-;;; Generated autoloads from gnus/nnkiboze.el
-
-(autoload 'nnkiboze-generate-groups "nnkiboze" "\
-\"Usage: emacs -batch -l nnkiboze -f nnkiboze-generate-groups\".
-Finds out what articles are to be part of the nnkiboze groups.
-
-\(fn)" t nil)
-
-;;;***
-
;;;### (autoloads (nnml-generate-nov-databases) "nnml" "gnus/nnml.el"
-;;;;;; (19636 58496))
+;;;;;; (19695 9549))
;;; Generated autoloads from gnus/nnml.el
(autoload 'nnml-generate-nov-databases "nnml" "\
@@ -18388,29 +18451,8 @@ Generate NOV databases in all nnml directories.
;;;***
-;;;### (autoloads (nnsoup-revert-variables nnsoup-set-variables nnsoup-pack-replies)
-;;;;;; "nnsoup" "gnus/nnsoup.el" (19636 58496))
-;;; Generated autoloads from gnus/nnsoup.el
-
-(autoload 'nnsoup-pack-replies "nnsoup" "\
-Make an outbound package of SOUP replies.
-
-\(fn)" t nil)
-
-(autoload 'nnsoup-set-variables "nnsoup" "\
-Use the SOUP methods for posting news and mailing mail.
-
-\(fn)" t nil)
-
-(autoload 'nnsoup-revert-variables "nnsoup" "\
-Revert posting and mailing methods to the standard Emacs methods.
-
-\(fn)" t nil)
-
-;;;***
-
;;;### (autoloads (disable-command enable-command disabled-command-function)
-;;;;;; "novice" "novice.el" (19636 58496))
+;;;;;; "novice" "novice.el" (19687 6902))
;;; Generated autoloads from novice.el
(defvar disabled-command-function 'disabled-command-function "\
@@ -18443,7 +18485,7 @@ to future sessions.
;;;***
;;;### (autoloads (nroff-mode) "nroff-mode" "textmodes/nroff-mode.el"
-;;;;;; (19636 58496))
+;;;;;; (19604 6253))
;;; Generated autoloads from textmodes/nroff-mode.el
(autoload 'nroff-mode "nroff-mode" "\
@@ -18458,7 +18500,7 @@ closing requests for requests that are used in matched pairs.
;;;***
;;;### (autoloads (nxml-glyph-display-string) "nxml-glyph" "nxml/nxml-glyph.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34921))
;;; Generated autoloads from nxml/nxml-glyph.el
(autoload 'nxml-glyph-display-string "nxml-glyph" "\
@@ -18470,8 +18512,8 @@ Return nil if the face cannot display a glyph for N.
;;;***
-;;;### (autoloads (nxml-mode) "nxml-mode" "nxml/nxml-mode.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (nxml-mode) "nxml-mode" "nxml/nxml-mode.el" (19696
+;;;;;; 28661))
;;; Generated autoloads from nxml/nxml-mode.el
(autoload 'nxml-mode "nxml-mode" "\
@@ -18533,7 +18575,7 @@ Many aspects this mode can be customized using
;;;***
;;;### (autoloads (nxml-enable-unicode-char-name-sets) "nxml-uchnm"
-;;;;;; "nxml/nxml-uchnm.el" (19636 58496))
+;;;;;; "nxml/nxml-uchnm.el" (19691 9263))
;;; Generated autoloads from nxml/nxml-uchnm.el
(autoload 'nxml-enable-unicode-char-name-sets "nxml-uchnm" "\
@@ -18545,8 +18587,250 @@ the variable `nxml-enabled-unicode-blocks'.
;;;***
+;;;### (autoloads (org-babel-mark-block org-babel-previous-src-block
+;;;;;; org-babel-next-src-block org-babel-goto-named-result org-babel-goto-named-src-block
+;;;;;; org-babel-goto-src-block-head org-babel-hide-result-toggle-maybe
+;;;;;; org-babel-sha1-hash org-babel-execute-subtree org-babel-execute-buffer
+;;;;;; org-babel-open-src-block-result org-babel-switch-to-session-with-code
+;;;;;; org-babel-switch-to-session org-babel-initiate-session org-babel-load-in-session
+;;;;;; org-babel-expand-src-block org-babel-execute-src-block org-babel-pop-to-session-maybe
+;;;;;; org-babel-load-in-session-maybe org-babel-expand-src-block-maybe
+;;;;;; org-babel-execute-maybe org-babel-execute-safely-maybe) "ob"
+;;;;;; "org/ob.el" (19677 59043))
+;;; Generated autoloads from org/ob.el
+
+(autoload 'org-babel-execute-safely-maybe "ob" "\
+Not documented
+
+\(fn)" nil nil)
+
+(autoload 'org-babel-execute-maybe "ob" "\
+Not documented
+
+\(fn)" t nil)
+
+(autoload 'org-babel-expand-src-block-maybe "ob" "\
+Conditionally expand a source block.
+Detect if this is context for a org-babel src-block and if so
+then run `org-babel-expand-src-block'.
+
+\(fn)" t nil)
+
+(autoload 'org-babel-load-in-session-maybe "ob" "\
+Conditionally load a source block in a session.
+Detect if this is context for a org-babel src-block and if so
+then run `org-babel-load-in-session'.
+
+\(fn)" t nil)
+
+(autoload 'org-babel-pop-to-session-maybe "ob" "\
+Conditionally pop to a session.
+Detect if this is context for a org-babel src-block and if so
+then run `org-babel-pop-to-session'.
+
+\(fn)" t nil)
+
+(autoload 'org-babel-execute-src-block "ob" "\
+Execute the current source code block.
+Insert the results of execution into the buffer. Source code
+execution and the collection and formatting of results can be
+controlled through a variety of header arguments.
+
+With prefix argument ARG, force re-execution even if a an
+existing result cached in the buffer would otherwise have been
+returned.
+
+Optionally supply a value for INFO in the form returned by
+`org-babel-get-src-block-info'.
+
+Optionally supply a value for PARAMS which will be merged with
+the header arguments specified at the front of the source code
+block.
+
+\(fn &optional ARG INFO PARAMS)" t nil)
+
+(autoload 'org-babel-expand-src-block "ob" "\
+Expand the current source code block.
+Expand according to the source code block's header
+arguments and pop open the results in a preview buffer.
+
+\(fn &optional ARG INFO PARAMS)" t nil)
+
+(autoload 'org-babel-load-in-session "ob" "\
+Load the body of the current source-code block.
+Evaluate the header arguments for the source block before
+entering the session. After loading the body this pops open the
+session.
+
+\(fn &optional ARG INFO)" t nil)
+
+(autoload 'org-babel-initiate-session "ob" "\
+Initiate session for current code block.
+If called with a prefix argument then resolve any variable
+references in the header arguments and assign these variables in
+the session. Copy the body of the code block to the kill ring.
+
+\(fn &optional ARG INFO)" t nil)
+
+(autoload 'org-babel-switch-to-session "ob" "\
+Switch to the session of the current code block.
+Uses `org-babel-initiate-session' to start the session. If called
+with a prefix argument then this is passed on to
+`org-babel-initiate-session'.
+
+\(fn &optional ARG INFO)" t nil)
+
+(autoload 'org-babel-switch-to-session-with-code "ob" "\
+Switch to code buffer and display session.
+
+\(fn &optional ARG INFO)" t nil)
+
+(autoload 'org-babel-open-src-block-result "ob" "\
+If `point' is on a src block then open the results of the
+source code block, otherwise return nil. With optional prefix
+argument RE-RUN the source-code block is evaluated even if
+results already exist.
+
+\(fn &optional RE-RUN)" t nil)
+
+(autoload 'org-babel-execute-buffer "ob" "\
+Execute source code blocks in a buffer.
+Call `org-babel-execute-src-block' on every source block in
+the current buffer.
+
+\(fn &optional ARG)" t nil)
+
+(autoload 'org-babel-execute-subtree "ob" "\
+Execute source code blocks in a subtree.
+Call `org-babel-execute-src-block' on every source block in
+the current subtree.
+
+\(fn &optional ARG)" t nil)
+
+(autoload 'org-babel-sha1-hash "ob" "\
+Generate an sha1 hash based on the value of info.
+
+\(fn &optional INFO)" t nil)
+
+(autoload 'org-babel-hide-result-toggle-maybe "ob" "\
+Toggle visibility of result at point.
+
+\(fn)" t nil)
+
+(autoload 'org-babel-goto-src-block-head "ob" "\
+Go to the beginning of the current code block.
+
+\(fn)" t nil)
+
+(autoload 'org-babel-goto-named-src-block "ob" "\
+Go to a named source-code block.
+
+\(fn NAME)" t nil)
+
+(autoload 'org-babel-goto-named-result "ob" "\
+Go to a named result.
+
+\(fn NAME)" t nil)
+
+(autoload 'org-babel-next-src-block "ob" "\
+Jump to the next source block.
+With optional prefix argument ARG, jump forward ARG many source blocks.
+
+\(fn &optional ARG)" t nil)
+
+(autoload 'org-babel-previous-src-block "ob" "\
+Jump to the previous source block.
+With optional prefix argument ARG, jump backward ARG many source blocks.
+
+\(fn &optional ARG)" t nil)
+
+(autoload 'org-babel-mark-block "ob" "\
+Mark current src block
+
+\(fn)" t nil)
+
+;;;***
+
+;;;### (autoloads (org-babel-describe-bindings) "ob-keys" "org/ob-keys.el"
+;;;;;; (19676 49793))
+;;; Generated autoloads from org/ob-keys.el
+
+(autoload 'org-babel-describe-bindings "ob-keys" "\
+Describe all keybindings behind `org-babel-key-prefix'.
+
+\(fn)" t nil)
+
+;;;***
+
+;;;### (autoloads (org-babel-lob-get-info org-babel-lob-execute-maybe
+;;;;;; org-babel-lob-ingest) "ob-lob" "org/ob-lob.el" (19677 59221))
+;;; Generated autoloads from org/ob-lob.el
+
+(autoload 'org-babel-lob-ingest "ob-lob" "\
+Add all named source-blocks defined in FILE to
+`org-babel-library-of-babel'.
+
+\(fn &optional FILE)" t nil)
+
+(autoload 'org-babel-lob-execute-maybe "ob-lob" "\
+Execute a Library of Babel source block, if appropriate.
+Detect if this is context for a Library Of Babel source block and
+if so then run the appropriate source block from the Library.
+
+\(fn)" t nil)
+
+(autoload 'org-babel-lob-get-info "ob-lob" "\
+Return a Library of Babel function call as a string.
+
+\(fn)" nil nil)
+
+;;;***
+
+;;;### (autoloads (org-babel-tangle org-babel-tangle-file org-babel-load-file
+;;;;;; org-babel-tangle-lang-exts) "ob-tangle" "org/ob-tangle.el"
+;;;;;; (19676 49793))
+;;; Generated autoloads from org/ob-tangle.el
+
+(defvar org-babel-tangle-lang-exts '(("emacs-lisp" . "el")) "\
+Alist mapping languages to their file extensions.
+The key is the language name, the value is the string that should
+be inserted as the extension commonly used to identify files
+written in this language. If no entry is found in this list,
+then the name of the language is used.")
+
+(custom-autoload 'org-babel-tangle-lang-exts "ob-tangle" t)
+
+(autoload 'org-babel-load-file "ob-tangle" "\
+Load Emacs Lisp source code blocks in the Org-mode FILE.
+This function exports the source code using
+`org-babel-tangle' and then loads the resulting file using
+`load-file'.
+
+\(fn FILE)" nil nil)
+
+(autoload 'org-babel-tangle-file "ob-tangle" "\
+Extract the bodies of source code blocks in FILE.
+Source code blocks are extracted with `org-babel-tangle'.
+Optional argument TARGET-FILE can be used to specify a default
+export file for all source blocks. Optional argument LANG can be
+used to limit the exported source code blocks by language.
+
+\(fn FILE &optional TARGET-FILE LANG)" t nil)
+
+(autoload 'org-babel-tangle "ob-tangle" "\
+Write code blocks to source-specific files.
+Extract the bodies of all source code blocks from the current
+file into their own source-specific files. Optional argument
+TARGET-FILE can be used to specify a default export file for all
+source blocks. Optional argument LANG can be used to limit the
+exported source code blocks by language.
+
+\(fn &optional TARGET-FILE LANG)" t nil)
+
+;;;***
+
;;;### (autoloads (inferior-octave) "octave-inf" "progmodes/octave-inf.el"
-;;;;;; (19636 58496))
+;;;;;; (19580 19536))
;;; Generated autoloads from progmodes/octave-inf.el
(autoload 'inferior-octave "octave-inf" "\
@@ -18569,7 +18853,7 @@ startup file, `~/.emacs-octave'.
;;;***
;;;### (autoloads (octave-mode) "octave-mod" "progmodes/octave-mod.el"
-;;;;;; (19636 58496))
+;;;;;; (19687 6902))
;;; Generated autoloads from progmodes/octave-mod.el
(autoload 'octave-mode "octave-mod" "\
@@ -18600,14 +18884,6 @@ Keybindings
Variables you can use to customize Octave mode
==============================================
-`octave-auto-indent'
- Non-nil means indent current line after a semicolon or space.
- Default is nil.
-
-`octave-auto-newline'
- Non-nil means auto-insert a newline and indent after a semicolon.
- Default is nil.
-
`octave-blink-matching-block'
Non-nil means show matching begin of block when inserting a space,
newline or semicolon after an else or end keyword. Default is t.
@@ -18660,13 +18936,19 @@ including a reproducible test case and send the message.
;;;***
;;;### (autoloads (org-customize org-reload org-require-autoloaded-modules
-;;;;;; org-submit-bug-report org-cycle-agenda-files org-iswitchb
+;;;;;; org-submit-bug-report org-cycle-agenda-files org-switchb
;;;;;; org-map-entries org-open-link-from-string org-open-at-point-global
;;;;;; org-insert-link-global org-store-link org-run-like-in-org-mode
;;;;;; turn-on-orgstruct++ turn-on-orgstruct orgstruct-mode org-global-cycle
-;;;;;; org-mode) "org" "org/org.el" (19636 58496))
+;;;;;; org-mode org-babel-do-load-languages) "org" "org/org.el"
+;;;;;; (19676 49793))
;;; Generated autoloads from org/org.el
+(autoload 'org-babel-do-load-languages "org" "\
+Load the languages defined in `org-babel-load-languages'.
+
+\(fn SYM VALUE)" nil nil)
+
(autoload 'org-mode "org" "\
Outline-based notes management and organizer, alias
\"Carsten's outline-mode for keeping track of everything.\"
@@ -18692,17 +18974,17 @@ The following commands are available:
(autoload 'org-global-cycle "org" "\
Cycle the global visibility. For details see `org-cycle'.
-With C-u prefix arg, switch to startup visibility.
+With \\[universal-argument] prefix arg, switch to startup visibility.
With a numeric prefix, show all headlines up to that level.
\(fn &optional ARG)" t nil)
(autoload 'orgstruct-mode "org" "\
-Toggle the minor more `orgstruct-mode'.
-This mode is for using Org-mode structure commands in other modes.
-The following key behave as if Org-mode was active, if the cursor
-is on a headline, or on a plain list item (both in the definition
-of Org-mode).
+Toggle the minor mode `orgstruct-mode'.
+This mode is for using Org-mode structure commands in other
+modes. The following keys behave as if Org-mode were active, if
+the cursor is on a headline, or on a plain list item (both as
+defined by Org-mode).
M-up Move entry/item up
M-down Move entry/item down
@@ -18828,14 +19110,19 @@ a *different* entry, you cannot use these techniques.
\(fn FUNC &optional MATCH SCOPE &rest SKIP)" nil nil)
-(autoload 'org-iswitchb "org" "\
-Use `org-icompleting-read' to prompt for an Org buffer to switch to.
+(autoload 'org-switchb "org" "\
+Switch between Org buffers.
With a prefix argument, restrict available to files.
With two prefix arguments, restrict available buffers to agenda files.
+Defaults to `iswitchb' for buffer name completion.
+Set `org-completion-use-ido' to make it use ido instead.
+
\(fn &optional ARG)" t nil)
-(defalias 'org-ido-switchb 'org-iswitchb)
+(defalias 'org-ido-switchb 'org-switchb)
+
+(defalias 'org-iswitchb 'org-switchb)
(autoload 'org-cycle-agenda-files "org" "\
Cycle through the files in `org-agenda-files'.
@@ -18877,7 +19164,7 @@ Call the customize function with org as argument.
;;;;;; org-diary org-agenda-list-stuck-projects org-tags-view org-todo-list
;;;;;; org-search-view org-agenda-list org-batch-store-agenda-views
;;;;;; org-store-agenda-views org-batch-agenda-csv org-batch-agenda
-;;;;;; org-agenda) "org-agenda" "org/org-agenda.el" (19641 1152))
+;;;;;; org-agenda) "org-agenda" "org/org-agenda.el" (19676 49793))
;;; Generated autoloads from org/org-agenda.el
(autoload 'org-agenda "org-agenda" "\
@@ -18921,7 +19208,7 @@ Run an agenda command in batch mode and send the result to STDOUT.
If CMD-KEY is a string of length 1, it is used as a key in
`org-agenda-custom-commands' and triggers this command. If it is a
longer string it is used as a tags/todo match string.
-Paramters are alternating variable names and values that will be bound
+Parameters are alternating variable names and values that will be bound
before running the agenda command.
\(fn CMD-KEY &rest PARAMETERS)" nil (quote macro))
@@ -18931,7 +19218,7 @@ Run an agenda command in batch mode and send the result to STDOUT.
If CMD-KEY is a string of length 1, it is used as a key in
`org-agenda-custom-commands' and triggers this command. If it is a
longer string it is used as a tags/todo match string.
-Paramters are alternating variable names and values that will be bound
+Parameters are alternating variable names and values that will be bound
before running the agenda command.
The output gives a line for each selected agenda item. Each
@@ -18993,9 +19280,7 @@ given in `org-agenda-start-on-weekday'.
\(fn &optional INCLUDE-ALL START-DAY NDAYS)" t nil)
(autoload 'org-search-view "org-agenda" "\
-Show all entries that contain words or regular expressions.
-If the first character of the search string is an asterisks,
-search only the headlines.
+Show all entries that contain a phrase or words or regular expressions.
With optional prefix argument TODO-ONLY, only consider entries that are
TODO entries. The argument STRING can be used to pass a default search
@@ -19003,28 +19288,37 @@ string into this function. If EDIT-AT is non-nil, it means that the
user should get a chance to edit this string, with cursor at position
EDIT-AT.
-The search string is broken into \"words\" by splitting at whitespace.
-Depending on the variable `org-agenda-search-view-search-words-only'
-and on whether the first character in the search string is \"+\" or \"-\",
-The string is then interpreted either as a substring with variable amounts
-of whitespace, or as a list or individual words that should be matched.
-
-The default is a substring match, where each space in the search string
-can expand to an arbitrary amount of whitespace, including newlines.
-
-If matching individual words, these words are then interpreted as a
-boolean expression with logical AND. Words prefixed with a minus must
-not occur in the entry. Words without a prefix or prefixed with a plus
-must occur in the entry. Matching is case-insensitive and the words
-are enclosed by word delimiters.
-
-Words enclosed by curly braces are interpreted as regular expressions
-that must or must not match in the entry.
-
-If the search string starts with an asterisk, search only in headlines.
-If (possibly after the leading star) the search string starts with an
-exclamation mark, this also means to look at TODO entries only, an effect
-that can also be achieved with a prefix argument.
+The search string can be viewed either as a phrase that should be found as
+is, or it can be broken into a number of snippets, each of which must match
+in a Boolean way to select an entry. The default depends on the variable
+`org-agenda-search-view-always-boolean'.
+Even if this is turned off (the default) you can always switch to
+Boolean search dynamically by preceding the first word with \"+\" or \"-\".
+
+The default is a direct search of the whole phrase, where each space in
+the search string can expand to an arbitrary amount of whitespace,
+including newlines.
+
+If using a Boolean search, the search string is split on whitespace and
+each snippet is searched separately, with logical AND to select an entry.
+Words prefixed with a minus must *not* occur in the entry. Words without
+a prefix or prefixed with a plus must occur in the entry. Matching is
+case-insensitive. Words are enclosed by word delimiters (i.e. they must
+match whole words, not parts of a word) if
+`org-agenda-search-view-force-full-words' is set (default is nil).
+
+Boolean search snippets enclosed by curly braces are interpreted as
+regular expressions that must or (when preceded with \"-\") must not
+match in the entry. Snippets enclosed into double quotes will be taken
+as a whole, to include whitespace.
+
+- If the search string starts with an asterisk, search only in headlines.
+- If (possibly after the leading star) the search string starts with an
+ exclamation mark, this also means to look at TODO entries only, an effect
+ that can also be achieved with a prefix argument.
+- If (possibly after star and exclamation mark) the search string starts
+ with a colon, this will mean that the (non-regexp) snippets of the
+ Boolean search must match as full words.
This command searches the agenda files, and in addition the files listed
in `org-agenda-text-search-extra-files'.
@@ -19032,7 +19326,7 @@ in `org-agenda-text-search-extra-files'.
\(fn &optional TODO-ONLY STRING EDIT-AT)" t nil)
(autoload 'org-todo-list "org-agenda" "\
-Show all TODO entries from all agenda file in a single list.
+Show all (not done) TODO entries from all agenda file in a single list.
The prefix arg can be used to select a specific TODO keyword and limit
the list to these. When using \\[universal-argument], you will be prompted
for a keyword. A numeric prefix directly selects the Nth keyword in
@@ -19051,7 +19345,6 @@ Create agenda view for projects that are stuck.
Stuck projects are project that have no next actions. For the definitions
of what a project is and how to check if it stuck, customize the variable
`org-stuck-projects'.
-MATCH is being ignored.
\(fn &rest IGNORE)" t nil)
@@ -19060,27 +19353,8 @@ Return diary information from org-files.
This function can be used in a \"sexp\" diary entry in the Emacs calendar.
It accesses org files and extracts information from those files to be
listed in the diary. The function accepts arguments specifying what
-items should be listed. The following arguments are allowed:
-
- :timestamp List the headlines of items containing a date stamp or
- date range matching the selected date. Deadlines will
- also be listed, on the expiration day.
-
- :sexp List entries resulting from diary-like sexps.
-
- :deadline List any deadlines past due, or due within
- `org-deadline-warning-days'. The listing occurs only
- in the diary for *today*, not at any other date. If
- an entry is marked DONE, it is no longer listed.
-
- :scheduled List all items which are scheduled for the given date.
- The diary for *today* also contains items which were
- scheduled earlier and are not yet marked DONE.
-
- :todo List all TODO items from the org-file. This may be a
- long list - so this is not turned on by default.
- Like deadlines, these entries only show up in the
- diary for *today*, not at any other date.
+items should be listed. For a list of arguments allowed here, see the
+variable `org-agenda-entry-types'.
The call in the diary file should look like this:
@@ -19104,7 +19378,7 @@ function from a program - use `org-agenda-get-day-entries' instead.
\(fn &rest ARGS)" nil nil)
(autoload 'org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item "org-agenda" "\
-Do we have a reason to ignore this todo entry because it has a time stamp?
+Do we have a reason to ignore this TODO entry because it has a time stamp?
\(fn &optional END)" nil nil)
@@ -19140,7 +19414,7 @@ belonging to the \"Work\" category.
;;;### (autoloads (org-archive-subtree-default-with-confirmation
;;;;;; org-archive-subtree-default) "org-archive" "org/org-archive.el"
-;;;;;; (19636 58496))
+;;;;;; (19676 49793))
;;; Generated autoloads from org/org-archive.el
(autoload 'org-archive-subtree-default "org-archive" "\
@@ -19158,10 +19432,32 @@ This command is set with the variable `org-archive-default-command'.
;;;***
;;;### (autoloads (org-export-as-ascii org-export-region-as-ascii
-;;;;;; org-replace-region-by-ascii org-export-as-ascii-to-buffer)
-;;;;;; "org-ascii" "org/org-ascii.el" (19636 58496))
+;;;;;; org-replace-region-by-ascii org-export-as-ascii-to-buffer
+;;;;;; org-export-as-utf8-to-buffer org-export-as-utf8 org-export-as-latin1-to-buffer
+;;;;;; org-export-as-latin1) "org-ascii" "org/org-ascii.el" (19676
+;;;;;; 49793))
;;; Generated autoloads from org/org-ascii.el
+(autoload 'org-export-as-latin1 "org-ascii" "\
+Like `org-export-as-ascii', use latin1 encoding for special symbols.
+
+\(fn &rest ARGS)" t nil)
+
+(autoload 'org-export-as-latin1-to-buffer "org-ascii" "\
+Like `org-export-as-ascii-to-buffer', use latin1 encoding for symbols.
+
+\(fn &rest ARGS)" t nil)
+
+(autoload 'org-export-as-utf8 "org-ascii" "\
+Like `org-export-as-ascii', use use encoding for special symbols.
+
+\(fn &rest ARGS)" t nil)
+
+(autoload 'org-export-as-utf8-to-buffer "org-ascii" "\
+Like `org-export-as-ascii-to-buffer', use utf8 encoding for symbols.
+
+\(fn &rest ARGS)" t nil)
+
(autoload 'org-export-as-ascii-to-buffer "org-ascii" "\
Call `org-export-as-ascii` with output to a temporary buffer.
No file is created. The prefix ARG is passed through to `org-export-as-ascii'.
@@ -19212,8 +19508,8 @@ publishing directory.
;;;***
-;;;### (autoloads (org-attach) "org-attach" "org/org-attach.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (org-attach) "org-attach" "org/org-attach.el" (19676
+;;;;;; 49793))
;;; Generated autoloads from org/org-attach.el
(autoload 'org-attach "org-attach" "\
@@ -19225,7 +19521,7 @@ Shows a list of commands and prompts for another key to execute a command.
;;;***
;;;### (autoloads (org-bbdb-anniversaries) "org-bbdb" "org/org-bbdb.el"
-;;;;;; (19636 58496))
+;;;;;; (19676 49793))
;;; Generated autoloads from org/org-bbdb.el
(autoload 'org-bbdb-anniversaries "org-bbdb" "\
@@ -19235,8 +19531,46 @@ Extract anniversaries from BBDB for display in the agenda.
;;;***
+;;;### (autoloads (org-capture-import-remember-templates org-capture-insert-template-here
+;;;;;; org-capture) "org-capture" "org/org-capture.el" (19678 1813))
+;;; Generated autoloads from org/org-capture.el
+
+(autoload 'org-capture "org-capture" "\
+Capture something.
+\\<org-capture-mode-map>
+This will let you select a template from `org-capture-templates', and then
+file the newly captured information. The text is immediately inserted
+at the target location, and an indirect buffer is shown where you can
+edit it. Pressing \\[org-capture-finalize] brings you back to the previous state
+of Emacs, so that you can continue your work.
+
+When called interactively with a \\[universal-argument] prefix argument GOTO, don't capture
+anything, just go to the file/headline where the selected template
+stores its notes. With a double prefix argument \\[universal-argument] \\[universal-argument], go to the last note
+stored.
+
+When called with a `C-0' (zero) prefix, insert a template at point.
+
+Lisp programs can set KEYS to a string associated with a template in
+`org-capture-templates'. In this case, interactive selection will be
+bypassed.
+
+\(fn &optional GOTO KEYS)" t nil)
+
+(autoload 'org-capture-insert-template-here "org-capture" "\
+Not documented
+
+\(fn)" nil nil)
+
+(autoload 'org-capture-import-remember-templates "org-capture" "\
+Set org-capture-templates to be similar to `org-remember-templates'.
+
+\(fn)" t nil)
+
+;;;***
+
;;;### (autoloads (org-clock-persistence-insinuate org-get-clocktable)
-;;;;;; "org-clock" "org/org-clock.el" (19636 58496))
+;;;;;; "org-clock" "org/org-clock.el" (19676 49793))
;;; Generated autoloads from org/org-clock.el
(autoload 'org-get-clocktable "org-clock" "\
@@ -19247,16 +19581,30 @@ fontified, and then returned.
\(fn &rest PROPS)" nil nil)
(autoload 'org-clock-persistence-insinuate "org-clock" "\
-Set up hooks for clock persistence
+Set up hooks for clock persistence.
\(fn)" nil nil)
;;;***
+;;;### (autoloads (org-datetree-find-date-create) "org-datetree"
+;;;;;; "org/org-datetree.el" (19676 49793))
+;;; Generated autoloads from org/org-datetree.el
+
+(autoload 'org-datetree-find-date-create "org-datetree" "\
+Find or create an entry for DATE.
+If KEEP-RESTRICTION is non-nil, do not widen the buffer.
+When it is nil, the buffer will be widened to make sure an existing date
+tree can be found.
+
+\(fn DATE &optional KEEP-RESTRICTION)" nil nil)
+
+;;;***
+
;;;### (autoloads (org-export-as-docbook org-export-as-docbook-pdf-and-open
;;;;;; org-export-as-docbook-pdf org-export-region-as-docbook org-replace-region-by-docbook
;;;;;; org-export-as-docbook-to-buffer org-export-as-docbook-batch)
-;;;;;; "org-docbook" "org/org-docbook.el" (19636 58496))
+;;;;;; "org-docbook" "org/org-docbook.el" (19676 49793))
;;; Generated autoloads from org/org-docbook.el
(autoload 'org-export-as-docbook-batch "org-docbook" "\
@@ -19333,7 +19681,7 @@ publishing directory.
;;;### (autoloads (org-insert-export-options-template org-export-as-org
;;;;;; org-export-visible org-export) "org-exp" "org/org-exp.el"
-;;;;;; (19652 24589))
+;;;;;; (19676 49793))
;;; Generated autoloads from org/org-exp.el
(autoload 'org-export "org-exp" "\
@@ -19343,7 +19691,7 @@ in the background. This will be done only for commands that write
to a file. For details see the docstring of `org-export-run-in-background'.
The prefix argument ARG will be passed to the exporter. However, if
-ARG is a double universal prefix `C-u C-u', that means to inverse the
+ARG is a double universal prefix \\[universal-argument] \\[universal-argument], that means to inverse the
value of `org-export-run-in-background'.
\(fn &optional ARG)" t nil)
@@ -19351,12 +19699,12 @@ value of `org-export-run-in-background'.
(autoload 'org-export-visible "org-exp" "\
Create a copy of the visible part of the current buffer, and export it.
The copy is created in a temporary buffer and removed after use.
-TYPE is the final key (as a string) that also select the export command in
-the `C-c C-e' export dispatcher.
-
-As a special case, if you type SPC at the prompt, the temporary org-mode
-file will not be removed but presented to you so that you can continue to
-use it. The prefix arg ARG is passed through to the exporting command.
+TYPE is the final key (as a string) that also selects the export command in
+the \\<org-mode-map>\\[org-export] export dispatcher.
+As a special case, if the you type SPC at the prompt, the temporary
+org-mode file will not be removed but presented to you so that you can
+continue to use it. The prefix arg ARG is passed through to the exporting
+command.
\(fn TYPE ARG)" t nil)
@@ -19390,8 +19738,8 @@ Insert into the buffer a template with information for exporting.
;;;***
;;;### (autoloads (org-feed-show-raw-feed org-feed-goto-inbox org-feed-update
-;;;;;; org-feed-update-all) "org-feed" "org/org-feed.el" (19636
-;;;;;; 58496))
+;;;;;; org-feed-update-all) "org-feed" "org/org-feed.el" (19676
+;;;;;; 49793))
;;; Generated autoloads from org/org-feed.el
(autoload 'org-feed-update-all "org-feed" "\
@@ -19419,7 +19767,7 @@ Show the raw feed buffer of a feed.
;;;***
;;;### (autoloads (org-footnote-normalize org-footnote-action) "org-footnote"
-;;;;;; "org/org-footnote.el" (19636 58496))
+;;;;;; "org/org-footnote.el" (19676 49793))
;;; Generated autoloads from org/org-footnote.el
(autoload 'org-footnote-action "org-footnote" "\
@@ -19446,13 +19794,26 @@ referenced sequence.
;;;### (autoloads (org-freemind-to-org-mode org-freemind-from-org-sparse-tree
;;;;;; org-freemind-from-org-mode org-freemind-from-org-mode-node
;;;;;; org-freemind-show org-export-as-freemind) "org-freemind"
-;;;;;; "org/org-freemind.el" (19636 58496))
+;;;;;; "org/org-freemind.el" (19676 49793))
;;; Generated autoloads from org/org-freemind.el
(autoload 'org-export-as-freemind "org-freemind" "\
-Not documented
+Export the current buffer as a Freemind file.
+If there is an active region, export only the region. HIDDEN is
+obsolete and does nothing. EXT-PLIST is a property list with
+external parameters overriding org-mode's default settings, but
+still inferior to file-local settings. When TO-BUFFER is
+non-nil, create a buffer with that name and export to that
+buffer. If TO-BUFFER is the symbol `string', don't leave any
+buffer behind but just return the resulting HTML as a string.
+When BODY-ONLY is set, don't produce the file header and footer,
+simply return the content of the document (all top level
+sections). When PUB-DIR is set, use this as the publishing
+directory.
-\(fn ARG &optional HIDDEN EXT-PLIST TO-BUFFER BODY-ONLY PUB-DIR)" t nil)
+See `org-freemind-from-org-mode' for more information.
+
+\(fn &optional HIDDEN EXT-PLIST TO-BUFFER BODY-ONLY PUB-DIR)" t nil)
(autoload 'org-freemind-show "org-freemind" "\
Show file MM-FILE in Freemind.
@@ -19461,11 +19822,21 @@ Show file MM-FILE in Freemind.
(autoload 'org-freemind-from-org-mode-node "org-freemind" "\
Convert node at line NODE-LINE to the FreeMind file MM-FILE.
+See `org-freemind-from-org-mode' for more information.
\(fn NODE-LINE MM-FILE)" t nil)
(autoload 'org-freemind-from-org-mode "org-freemind" "\
Convert the `org-mode' file ORG-FILE to the FreeMind file MM-FILE.
+All the nodes will be opened or closed in Freemind just as you
+have them in `org-mode'.
+
+Note that exporting to Freemind also gives you an alternative way
+to export from `org-mode' to html. You can create a dynamic html
+version of the your org file, by first exporting to Freemind and
+then exporting from Freemind to html. The 'As
+XHTML (JavaScript)' version in Freemind works very well (and you
+can use a CSS stylesheet to style it).
\(fn ORG-FILE MM-FILE)" t nil)
@@ -19484,7 +19855,7 @@ Convert FreeMind file MM-FILE to `org-mode' file ORG-FILE.
;;;### (autoloads (org-export-htmlize-generate-css org-export-as-html
;;;;;; org-export-region-as-html org-replace-region-by-html org-export-as-html-to-buffer
;;;;;; org-export-as-html-batch org-export-as-html-and-open) "org-html"
-;;;;;; "org/org-html.el" (19636 58496))
+;;;;;; "org/org-html.el" (19676 49793))
;;; Generated autoloads from org/org-html.el
(put 'org-export-html-style-include-default 'safe-local-variable 'booleanp)
@@ -19502,7 +19873,8 @@ headlines. The default is 3. Lower levels will become bulleted lists.
\(fn ARG)" t nil)
(autoload 'org-export-as-html-batch "org-html" "\
-Call `org-export-as-html', may be used in batch processing as
+Call the function `org-export-as-html'.
+This function can be used in batch processing as:
emacs --batch
--load=$HOME/lib/emacs/org.el
--eval \"(setq org-export-headline-levels 2)\"
@@ -19577,7 +19949,7 @@ that uses these same face definitions.
;;;### (autoloads (org-export-icalendar-combine-agenda-files org-export-icalendar-all-agenda-files
;;;;;; org-export-icalendar-this-file) "org-icalendar" "org/org-icalendar.el"
-;;;;;; (19636 58496))
+;;;;;; (19676 49793))
;;; Generated autoloads from org/org-icalendar.el
(autoload 'org-export-icalendar-this-file "org-icalendar" "\
@@ -19588,7 +19960,7 @@ file, but with extension `.ics'.
\(fn)" t nil)
(autoload 'org-export-icalendar-all-agenda-files "org-icalendar" "\
-Export all files in `org-agenda-files' to iCalendar .ics files.
+Export all files in the variable `org-agenda-files' to iCalendar .ics files.
Each iCalendar file will be located in the same directory as the Org-mode
file, but with extension `.ics'.
@@ -19602,9 +19974,10 @@ The file is stored under the name `org-combined-agenda-icalendar-file'.
;;;***
-;;;### (autoloads (org-id-find-id-file org-id-find org-id-goto org-id-get-with-outline-drilling
-;;;;;; org-id-get-with-outline-path-completion org-id-get org-id-copy
-;;;;;; org-id-get-create) "org-id" "org/org-id.el" (19636 58496))
+;;;### (autoloads (org-id-store-link org-id-find-id-file org-id-find
+;;;;;; org-id-goto org-id-get-with-outline-drilling org-id-get-with-outline-path-completion
+;;;;;; org-id-get org-id-copy org-id-get-create) "org-id" "org/org-id.el"
+;;;;;; (19676 49793))
;;; Generated autoloads from org/org-id.el
(autoload 'org-id-get-create "org-id" "\
@@ -19665,10 +20038,15 @@ Query the id database for the file in which this ID is located.
\(fn ID)" nil nil)
+(autoload 'org-id-store-link "org-id" "\
+Store a link to the current entry, using its ID.
+
+\(fn)" t nil)
+
;;;***
;;;### (autoloads (org-indent-mode) "org-indent" "org/org-indent.el"
-;;;;;; (19636 58496))
+;;;;;; (19676 49793))
;;; Generated autoloads from org/org-indent.el
(autoload 'org-indent-mode "org-indent" "\
@@ -19683,7 +20061,7 @@ FIXME: How to update when broken?
;;;***
;;;### (autoloads (org-irc-store-link) "org-irc" "org/org-irc.el"
-;;;;;; (19636 58496))
+;;;;;; (19676 49793))
;;; Generated autoloads from org/org-irc.el
(autoload 'org-irc-store-link "org-irc" "\
@@ -19696,7 +20074,7 @@ Dispatch to the appropriate function to store a link to an IRC session.
;;;### (autoloads (org-export-as-pdf-and-open org-export-as-pdf org-export-as-latex
;;;;;; org-export-region-as-latex org-replace-region-by-latex org-export-as-latex-to-buffer
;;;;;; org-export-as-latex-batch) "org-latex" "org/org-latex.el"
-;;;;;; (19636 58496))
+;;;;;; (19676 49793))
;;; Generated autoloads from org/org-latex.el
(autoload 'org-export-as-latex-batch "org-latex" "\
@@ -19757,8 +20135,8 @@ non-nil, create a buffer with that name and export to that
buffer. If TO-BUFFER is the symbol `string', don't leave any
buffer behind but just return the resulting LaTeX as a string.
When BODY-ONLY is set, don't produce the file header and footer,
-simply return the content of egin{document}...nd{document},
-without even the egin{document} and nd{document} commands.
+simply return the content of \\begin{document}...\\end{document},
+without even the \\begin{document} and \\end{document} commands.
when PUB-DIR is set, use this as the publishing directory.
\(fn ARG &optional HIDDEN EXT-PLIST TO-BUFFER BODY-ONLY PUB-DIR)" t nil)
@@ -19776,8 +20154,8 @@ Export as LaTeX, then process through to PDF, and open.
;;;***
;;;### (autoloads (org-mobile-create-sumo-agenda org-mobile-pull
-;;;;;; org-mobile-push) "org-mobile" "org/org-mobile.el" (19636
-;;;;;; 58496))
+;;;;;; org-mobile-push) "org-mobile" "org/org-mobile.el" (19676
+;;;;;; 49793))
;;; Generated autoloads from org/org-mobile.el
(autoload 'org-mobile-push "org-mobile" "\
@@ -19802,11 +20180,11 @@ Create a file that contains all custom agenda views.
;;;***
;;;### (autoloads (org-plot/gnuplot) "org-plot" "org/org-plot.el"
-;;;;;; (19636 58496))
+;;;;;; (19676 49793))
;;; Generated autoloads from org/org-plot.el
(autoload 'org-plot/gnuplot "org-plot" "\
-Plot table using gnuplot. Gnuplot options can be specified with PARAMS.
+Plot table using gnuplot. Gnuplot options can be specified with PARAMS.
If not given options will be taken from the +PLOT
line directly before or after the table.
@@ -19816,7 +20194,7 @@ line directly before or after the table.
;;;### (autoloads (org-publish-current-project org-publish-current-file
;;;;;; org-publish-all org-publish) "org-publish" "org/org-publish.el"
-;;;;;; (19636 58496))
+;;;;;; (19676 49793))
;;; Generated autoloads from org/org-publish.el
(defalias 'org-publish-project 'org-publish)
@@ -19850,7 +20228,7 @@ the project.
;;;### (autoloads (org-remember-handler org-remember org-remember-apply-template
;;;;;; org-remember-annotation org-remember-insinuate) "org-remember"
-;;;;;; "org/org-remember.el" (19636 58496))
+;;;;;; "org/org-remember.el" (19676 49793))
;;; Generated autoloads from org/org-remember.el
(autoload 'org-remember-insinuate "org-remember" "\
@@ -19878,9 +20256,9 @@ Call `remember'. If this is already a remember buffer, re-apply template.
If there is an active region, make sure remember uses it as initial content
of the remember buffer.
-When called interactively with a `C-u' prefix argument GOTO, don't remember
+When called interactively with a \\[universal-argument] prefix argument GOTO, don't remember
anything, just go to the file/headline where the selected template usually
-stores its notes. With a double prefix arg `C-u C-u', go to the last
+stores its notes. With a double prefix argument \\[universal-argument] \\[universal-argument], go to the last
note stored by remember.
Lisp programs can set ORG-FORCE-REMEMBER-TEMPLATE-CHAR to a character
@@ -19893,21 +20271,22 @@ Store stuff from remember.el into an org file.
When the template has specified a file and a headline, the entry is filed
there, or in the location defined by `org-default-notes-file' and
`org-remember-default-headline'.
-
+\\<org-remember-mode-map>
If no defaults have been defined, or if the current prefix argument
-is 1 (so you must use `C-1 C-c C-c' to exit remember), an interactive
+is 1 (using C-1 \\[org-remember-finalize] to exit remember), an interactive
process is used to select the target location.
-When the prefix is 0 (i.e. when remember is exited with `C-0 C-c C-c'),
+When the prefix is 0 (i.e. when remember is exited with C-0 \\[org-remember-finalize]),
the entry is filed to the same location as the previous note.
-When the prefix is 2 (i.e. when remember is exited with `C-2 C-c C-c'),
+When the prefix is 2 (i.e. when remember is exited with C-2 \\[org-remember-finalize]),
the entry is filed as a subentry of the entry where the clock is
currently running.
-When `C-u' has been used as prefix argument, the note is stored and emacs
-moves point to the new location of the note, so that editing can be
-continued there (similar to inserting \"%&\" into the template).
+When \\[universal-argument] has been used as prefix argument, the
+note is stored and Emacs moves point to the new location of the
+note, so that editing can be continued there (similar to
+inserting \"%&\" into the template).
Before storing the note, the function ensures that the text has an
org-mode-style headline, i.e. a first line that starts with
@@ -19925,7 +20304,7 @@ See also the variable `org-reverse-note-order'.
;;;***
;;;### (autoloads (org-table-to-lisp orgtbl-mode turn-on-orgtbl)
-;;;;;; "org-table" "org/org-table.el" (19636 58496))
+;;;;;; "org-table" "org/org-table.el" (19676 49793))
;;; Generated autoloads from org/org-table.el
(autoload 'turn-on-orgtbl "org-table" "\
@@ -19948,9 +20327,36 @@ The table is taken from the parameter TXT, or from the buffer at point.
;;;***
+;;;### (autoloads (org-export-as-taskjuggler-and-open org-export-as-taskjuggler)
+;;;;;; "org-taskjuggler" "org/org-taskjuggler.el" (19676 49793))
+;;; Generated autoloads from org/org-taskjuggler.el
+
+(autoload 'org-export-as-taskjuggler "org-taskjuggler" "\
+Export parts of the current buffer as a TaskJuggler file.
+The exporter looks for a tree with tag, property or todo that
+matches `org-export-taskjuggler-project-tag' and takes this as
+the tasks for this project. The first node of this tree defines
+the project properties such as project name and project period.
+If there is a tree with tag, property or todo that matches
+`org-export-taskjuggler-resource-tag' this three is taken as
+resources for the project. If no resources are specified, a
+default resource is created and allocated to the project. Also
+the taskjuggler project will be created with default reports as
+defined in `org-export-taskjuggler-default-reports'.
+
+\(fn)" t nil)
+
+(autoload 'org-export-as-taskjuggler-and-open "org-taskjuggler" "\
+Export the current buffer as a TaskJuggler file and open it
+with the TaskJuggler GUI.
+
+\(fn)" t nil)
+
+;;;***
+
;;;### (autoloads (org-timer-set-timer org-timer-item org-timer-change-times-in-region
;;;;;; org-timer org-timer-start) "org-timer" "org/org-timer.el"
-;;;;;; (19636 58496))
+;;;;;; (19676 49793))
;;; Generated autoloads from org/org-timer.el
(autoload 'org-timer-start "org-timer" "\
@@ -19969,12 +20375,15 @@ the region 0:00:00.
(autoload 'org-timer "org-timer" "\
Insert a H:MM:SS string from the timer into the buffer.
The first time this command is used, the timer is started. When used with
-a `C-u' prefix, force restarting the timer.
-When used with a double prefix arg `C-u C-u', change all the timer string
+a \\[universal-argument] prefix, force restarting the timer.
+When used with a double prefix argument \\[universal-argument], change all the timer string
in the region by a fixed amount. This can be used to recalibrate a timer
that was not started at the correct moment.
-\(fn &optional RESTART)" t nil)
+If NO-INSERT-P is non-nil, return the string instead of inserting
+it in the buffer.
+
+\(fn &optional RESTART NO-INSERT-P)" t nil)
(autoload 'org-timer-change-times-in-region "org-timer" "\
Change all h:mm:ss time in region by a DELTA.
@@ -19987,14 +20396,28 @@ Insert a description-type item with the current timer value.
\(fn &optional ARG)" t nil)
(autoload 'org-timer-set-timer "org-timer" "\
-Set a timer.
+Prompt for a duration and set a timer.
+
+If `org-timer-default-timer' is not zero, suggest this value as
+the default duration for the timer. If a timer is already set,
+prompt the user if she wants to replace it.
-\(fn MINUTES)" t nil)
+Called with a numeric prefix argument, use this numeric value as
+the duration of the timer.
+
+Called with a `C-u' prefix arguments, use `org-timer-default-timer'
+without prompting the user for a duration.
+
+With two `C-u' prefix arguments, use `org-timer-default-timer'
+without prompting the user for a duration and automatically
+replace any running timer.
+
+\(fn &optional OPT)" t nil)
;;;***
;;;### (autoloads (org-export-as-xoxo) "org-xoxo" "org/org-xoxo.el"
-;;;;;; (19636 58496))
+;;;;;; (19676 49793))
;;; Generated autoloads from org/org-xoxo.el
(autoload 'org-export-as-xoxo "org-xoxo" "\
@@ -20006,7 +20429,7 @@ The XOXO buffer is named *xoxo-<source buffer name>*
;;;***
;;;### (autoloads (outline-minor-mode outline-mode) "outline" "outline.el"
-;;;;;; (19636 58496))
+;;;;;; (19622 9855))
;;; Generated autoloads from outline.el
(put 'outline-regexp 'safe-local-variable 'string-or-null-p)
@@ -20063,7 +20486,72 @@ See the command `outline-mode' for more information on this mode.
;;;***
-;;;### (autoloads (show-paren-mode) "paren" "paren.el" (19636 58496))
+;;;### (autoloads (list-packages describe-package package-initialize
+;;;;;; package-install-file package-install-from-buffer package-install
+;;;;;; package-enable-at-startup) "package" "emacs-lisp/package.el"
+;;;;;; (19675 5423))
+;;; Generated autoloads from emacs-lisp/package.el
+
+(defvar package-enable-at-startup t "\
+Whether to activate installed packages when Emacs starts.
+If non-nil, packages are activated after reading the init file
+and before `after-init-hook'. Activation is not done if
+`user-init-file' is nil (e.g. Emacs was started with \"-q\").
+
+Even if the value is nil, you can type \\[package-initialize] to
+activate the package system at any time.")
+
+(custom-autoload 'package-enable-at-startup "package" t)
+
+(autoload 'package-install "package" "\
+Install the package named NAME.
+Interactively, prompt for the package name.
+The package is found on one of the archives in `package-archives'.
+
+\(fn NAME)" t nil)
+
+(autoload 'package-install-from-buffer "package" "\
+Install a package from the current buffer.
+When called interactively, the current buffer is assumed to be a
+single .el file that follows the packaging guidelines; see info
+node `(elisp)Packaging'.
+
+When called from Lisp, PKG-INFO is a vector describing the
+information, of the type returned by `package-buffer-info'; and
+TYPE is the package type (either `single' or `tar').
+
+\(fn PKG-INFO TYPE)" t nil)
+
+(autoload 'package-install-file "package" "\
+Install a package from a file.
+The file can either be a tar file or an Emacs Lisp file.
+
+\(fn FILE)" t nil)
+
+(autoload 'package-initialize "package" "\
+Load Emacs Lisp packages, and activate them.
+The variable `package-load-list' controls which packages to load.
+If optional arg NO-ACTIVATE is non-nil, don't activate packages.
+
+\(fn &optional NO-ACTIVATE)" t nil)
+
+(autoload 'describe-package "package" "\
+Display the full documentation of PACKAGE (a symbol).
+
+\(fn PACKAGE)" t nil)
+
+(autoload 'list-packages "package" "\
+Display a list of packages.
+Fetches the updated list of packages before displaying.
+The list is displayed in a buffer named `*Packages*'.
+
+\(fn)" t nil)
+
+(defalias 'package-list-packages 'list-packages)
+
+;;;***
+
+;;;### (autoloads (show-paren-mode) "paren" "paren.el" (19648 63605))
;;; Generated autoloads from paren.el
(defvar show-paren-mode nil "\
@@ -20088,7 +20576,7 @@ in `show-paren-style' after `show-paren-delay' seconds of Emacs idle time.
;;;***
;;;### (autoloads (parse-time-string) "parse-time" "calendar/parse-time.el"
-;;;;;; (19636 58496))
+;;;;;; (19582 65302))
;;; Generated autoloads from calendar/parse-time.el
(put 'parse-time-rules 'risky-local-variable t)
@@ -20101,8 +20589,8 @@ unknown are returned as nil.
;;;***
-;;;### (autoloads (pascal-mode) "pascal" "progmodes/pascal.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (pascal-mode) "pascal" "progmodes/pascal.el" (19670
+;;;;;; 1520))
;;; Generated autoloads from progmodes/pascal.el
(autoload 'pascal-mode "pascal" "\
@@ -20126,26 +20614,26 @@ Other useful functions are:
Variables controlling indentation/edit style:
- pascal-indent-level (default 3)
+ `pascal-indent-level' (default 3)
Indentation of Pascal statements with respect to containing block.
- pascal-case-indent (default 2)
+ `pascal-case-indent' (default 2)
Indentation for case statements.
- pascal-auto-newline (default nil)
+ `pascal-auto-newline' (default nil)
Non-nil means automatically newline after semicolons and the punctuation
mark after an end.
- pascal-indent-nested-functions (default t)
+ `pascal-indent-nested-functions' (default t)
Non-nil means nested functions are indented.
- pascal-tab-always-indent (default t)
+ `pascal-tab-always-indent' (default t)
Non-nil means TAB in Pascal mode should always reindent the current line,
regardless of where in the line point is when the TAB command is used.
- pascal-auto-endcomments (default t)
+ `pascal-auto-endcomments' (default t)
Non-nil means a comment { ... } is set after the ends which ends cases and
functions. The name of the function or case will be set between the braces.
- pascal-auto-lineup (default t)
+ `pascal-auto-lineup' (default t)
List of contexts where auto lineup of :'s or ='s should be done.
-See also the user variables pascal-type-keywords, pascal-start-keywords and
-pascal-separator-keywords.
+See also the user variables `pascal-type-keywords', `pascal-start-keywords' and
+`pascal-separator-keywords'.
Turning on Pascal mode calls the value of the variable pascal-mode-hook with
no args, if that value is non-nil.
@@ -20154,8 +20642,25 @@ no args, if that value is non-nil.
;;;***
+;;;### (autoloads (password-cache-expiry password-cache) "password-cache"
+;;;;;; "password-cache.el" (19582 65302))
+;;; Generated autoloads from password-cache.el
+
+(defvar password-cache t "\
+Whether to cache passwords.")
+
+(custom-autoload 'password-cache "password-cache" t)
+
+(defvar password-cache-expiry 16 "\
+How many seconds passwords are cached, or nil to disable expiring.
+Whether passwords are cached at all is controlled by `password-cache'.")
+
+(custom-autoload 'password-cache-expiry "password-cache" t)
+
+;;;***
+
;;;### (autoloads (pc-bindings-mode) "pc-mode" "emulation/pc-mode.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34919))
;;; Generated autoloads from emulation/pc-mode.el
(autoload 'pc-bindings-mode "pc-mode" "\
@@ -20173,7 +20678,7 @@ C-Escape does list-buffers.
;;;***
;;;### (autoloads (pc-selection-mode) "pc-select" "emulation/pc-select.el"
-;;;;;; (19636 58496))
+;;;;;; (19609 2166))
;;; Generated autoloads from emulation/pc-select.el
(defvar pc-selection-mode nil "\
@@ -20239,8 +20744,65 @@ but before calling PC Selection mode):
;;;***
-;;;### (autoloads (pcomplete/cvs) "pcmpl-cvs" "pcmpl-cvs.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (pcase-let pcase-let* pcase) "pcase" "emacs-lisp/pcase.el"
+;;;;;; (19693 26133))
+;;; Generated autoloads from emacs-lisp/pcase.el
+
+(autoload 'pcase "pcase" "\
+Perform ML-style pattern matching on EXP.
+CASES is a list of elements of the form (UPATTERN CODE...).
+
+UPatterns can take the following forms:
+ _ matches anything.
+ SYMBOL matches anything and binds it to SYMBOL.
+ (or UPAT...) matches if any of the patterns matches.
+ (and UPAT...) matches if all the patterns match.
+ `QPAT matches if the QPattern QPAT matches.
+ (pred PRED) matches if PRED applied to the object returns non-nil.
+ (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil.
+
+QPatterns can take the following forms:
+ (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr.
+ ,UPAT matches if the UPattern UPAT matches.
+ STRING matches if the object is `equal' to STRING.
+ ATOM matches if the object is `eq' to ATOM.
+QPatterns for vectors are not implemented yet.
+
+PRED can take the form
+ FUNCTION in which case it gets called with one argument.
+ (FUN ARG1 .. ARGN) in which case it gets called with N+1 arguments.
+A PRED of the form FUNCTION is equivalent to one of the form (FUNCTION).
+PRED patterns can refer to variables bound earlier in the pattern.
+E.g. you can match pairs where the cdr is larger than the car with a pattern
+like `(,a . ,(pred (< a))) or, with more checks:
+`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))
+
+\(fn EXP &rest CASES)" nil (quote macro))
+
+(put 'pcase 'lisp-indent-function '1)
+
+(autoload 'pcase-let* "pcase" "\
+Like `let*' but where you can use `pcase' patterns for bindings.
+BODY should be an expression, and BINDINGS should be a list of bindings
+of the form (UPAT EXP).
+
+\(fn BINDINGS &rest BODY)" nil (quote macro))
+
+(put 'pcase-let* 'lisp-indent-function '1)
+
+(autoload 'pcase-let "pcase" "\
+Like `let' but where you can use `pcase' patterns for bindings.
+BODY should be a list of expressions, and BINDINGS should be a list of bindings
+of the form (UPAT EXP).
+
+\(fn BINDINGS &rest BODY)" nil (quote macro))
+
+(put 'pcase-let 'lisp-indent-function '1)
+
+;;;***
+
+;;;### (autoloads (pcomplete/cvs) "pcmpl-cvs" "pcmpl-cvs.el" (19580
+;;;;;; 19536))
;;; Generated autoloads from pcmpl-cvs.el
(autoload 'pcomplete/cvs "pcmpl-cvs" "\
@@ -20251,7 +20813,7 @@ Completion rules for the `cvs' command.
;;;***
;;;### (autoloads (pcomplete/tar pcomplete/make pcomplete/bzip2 pcomplete/gzip)
-;;;;;; "pcmpl-gnu" "pcmpl-gnu.el" (19636 58496))
+;;;;;; "pcmpl-gnu" "pcmpl-gnu.el" (19580 19536))
;;; Generated autoloads from pcmpl-gnu.el
(autoload 'pcomplete/gzip "pcmpl-gnu" "\
@@ -20279,7 +20841,7 @@ Completion for the GNU tar utility.
;;;***
;;;### (autoloads (pcomplete/mount pcomplete/umount pcomplete/kill)
-;;;;;; "pcmpl-linux" "pcmpl-linux.el" (19636 58496))
+;;;;;; "pcmpl-linux" "pcmpl-linux.el" (19580 19536))
;;; Generated autoloads from pcmpl-linux.el
(autoload 'pcomplete/kill "pcmpl-linux" "\
@@ -20299,8 +20861,8 @@ Completion for GNU/Linux `mount'.
;;;***
-;;;### (autoloads (pcomplete/rpm) "pcmpl-rpm" "pcmpl-rpm.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (pcomplete/rpm) "pcmpl-rpm" "pcmpl-rpm.el" (19580
+;;;;;; 19536))
;;; Generated autoloads from pcmpl-rpm.el
(autoload 'pcomplete/rpm "pcmpl-rpm" "\
@@ -20312,7 +20874,7 @@ Completion for the `rpm' command.
;;;### (autoloads (pcomplete/scp pcomplete/ssh pcomplete/chgrp pcomplete/chown
;;;;;; pcomplete/which pcomplete/xargs pcomplete/rm pcomplete/rmdir
-;;;;;; pcomplete/cd) "pcmpl-unix" "pcmpl-unix.el" (19636 58496))
+;;;;;; pcomplete/cd) "pcmpl-unix" "pcmpl-unix.el" (19580 19536))
;;; Generated autoloads from pcmpl-unix.el
(autoload 'pcomplete/cd "pcmpl-unix" "\
@@ -20369,8 +20931,8 @@ Includes files as well as host names followed by a colon.
;;;### (autoloads (pcomplete-shell-setup pcomplete-comint-setup pcomplete-list
;;;;;; pcomplete-help pcomplete-expand pcomplete-continue pcomplete-expand-and-complete
-;;;;;; pcomplete-reverse pcomplete) "pcomplete" "pcomplete.el" (19636
-;;;;;; 58496))
+;;;;;; pcomplete-reverse pcomplete) "pcomplete" "pcomplete.el" (19451
+;;;;;; 17238))
;;; Generated autoloads from pcomplete.el
(autoload 'pcomplete "pcomplete" "\
@@ -20429,8 +20991,8 @@ Setup `shell-mode' to use pcomplete.
;;;### (autoloads (cvs-dired-use-hook cvs-dired-action cvs-status
;;;;;; cvs-update cvs-examine cvs-quickdir cvs-checkout) "pcvs"
-;;;;;; "pcvs.el" (19636 58496))
-;;; Generated autoloads from pcvs.el
+;;;;;; "vc/pcvs.el" (19474 36901))
+;;; Generated autoloads from vc/pcvs.el
(autoload 'cvs-checkout "pcvs" "\
Run a 'cvs checkout MODULES' in DIR.
@@ -20504,15 +21066,15 @@ The exact behavior is determined also by `cvs-dired-use-hook'." (when (stringp d
;;;***
-;;;### (autoloads nil "pcvs-defs" "pcvs-defs.el" (19636 58496))
-;;; Generated autoloads from pcvs-defs.el
+;;;### (autoloads nil "pcvs-defs" "vc/pcvs-defs.el" (19580 19536))
+;;; Generated autoloads from vc/pcvs-defs.el
(defvar cvs-global-menu (let ((m (make-sparse-keymap "PCL-CVS"))) (define-key m [status] `(menu-item ,(purecopy "Directory Status") cvs-status :help ,(purecopy "A more verbose status of a workarea"))) (define-key m [checkout] `(menu-item ,(purecopy "Checkout Module") cvs-checkout :help ,(purecopy "Check out a module from the repository"))) (define-key m [update] `(menu-item ,(purecopy "Update Directory") cvs-update :help ,(purecopy "Fetch updates from the repository"))) (define-key m [examine] `(menu-item ,(purecopy "Examine Directory") cvs-examine :help ,(purecopy "Examine the current state of a workarea"))) (fset 'cvs-global-menu m)))
;;;***
;;;### (autoloads (perl-mode) "perl-mode" "progmodes/perl-mode.el"
-;;;;;; (19636 58496))
+;;;;;; (19668 19310))
;;; Generated autoloads from progmodes/perl-mode.el
(put 'perl-indent-level 'safe-local-variable 'integerp)
(put 'perl-continued-statement-offset 'safe-local-variable 'integerp)
@@ -20576,7 +21138,7 @@ Turning on Perl mode runs the normal hook `perl-mode-hook'.
;;;### (autoloads (pgg-snarf-keys pgg-snarf-keys-region pgg-insert-key
;;;;;; pgg-verify pgg-verify-region pgg-sign pgg-sign-region pgg-decrypt
;;;;;; pgg-decrypt-region pgg-encrypt pgg-encrypt-symmetric pgg-encrypt-symmetric-region
-;;;;;; pgg-encrypt-region) "pgg" "pgg.el" (19636 58496))
+;;;;;; pgg-encrypt-region) "pgg" "pgg.el" (19635 50568))
;;; Generated autoloads from pgg.el
(autoload 'pgg-encrypt-region "pgg" "\
@@ -20710,7 +21272,7 @@ Import public keys in the current buffer.
;;;***
;;;### (autoloads (pgg-gpg-symmetric-key-p) "pgg-gpg" "pgg-gpg.el"
-;;;;;; (19636 58496))
+;;;;;; (19582 65302))
;;; Generated autoloads from pgg-gpg.el
(autoload 'pgg-gpg-symmetric-key-p "pgg-gpg" "\
@@ -20721,7 +21283,7 @@ True if decoded armor MESSAGE-KEYS has symmetric encryption indicator.
;;;***
;;;### (autoloads (picture-mode) "picture" "textmodes/picture.el"
-;;;;;; (19636 58496))
+;;;;;; (19687 6902))
;;; Generated autoloads from textmodes/picture.el
(autoload 'picture-mode "picture" "\
@@ -20802,7 +21364,7 @@ they are not defaultly assigned to keys.
;;;***
;;;### (autoloads (po-find-file-coding-system) "po" "textmodes/po.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34923))
;;; Generated autoloads from textmodes/po.el
(autoload 'po-find-file-coding-system "po" "\
@@ -20813,7 +21375,7 @@ Called through `file-coding-system-alist', before the file is visited for real.
;;;***
-;;;### (autoloads (pong) "pong" "play/pong.el" (19636 58496))
+;;;### (autoloads (pong) "pong" "play/pong.el" (19277 34922))
;;; Generated autoloads from play/pong.el
(autoload 'pong "pong" "\
@@ -20829,9 +21391,20 @@ pong-mode keybindings:\\<pong-mode-map>
;;;***
+;;;### (autoloads (pop3-movemail) "pop3" "gnus/pop3.el" (19624 59837))
+;;; Generated autoloads from gnus/pop3.el
+
+(autoload 'pop3-movemail "pop3" "\
+Transfer contents of a maildrop to the specified FILE.
+Use streaming commands.
+
+\(fn FILE)" nil nil)
+
+;;;***
+
;;;### (autoloads (pp-macroexpand-last-sexp pp-eval-last-sexp pp-macroexpand-expression
;;;;;; pp-eval-expression pp pp-buffer pp-to-string) "pp" "emacs-lisp/pp.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34919))
;;; Generated autoloads from emacs-lisp/pp.el
(autoload 'pp-to-string "pp" "\
@@ -20899,7 +21472,7 @@ Ignores leading comment characters.
;;;;;; pr-ps-buffer-print pr-ps-buffer-using-ghostscript pr-ps-buffer-preview
;;;;;; pr-ps-directory-ps-print pr-ps-directory-print pr-ps-directory-using-ghostscript
;;;;;; pr-ps-directory-preview pr-interface) "printing" "printing.el"
-;;;;;; (19636 58496))
+;;;;;; (19687 6902))
;;; Generated autoloads from printing.el
(autoload 'pr-interface "printing" "\
@@ -21486,7 +22059,7 @@ are both set to t.
;;;***
-;;;### (autoloads (proced) "proced" "proced.el" (19636 58496))
+;;;### (autoloads (proced) "proced" "proced.el" (19590 30214))
;;; Generated autoloads from proced.el
(autoload 'proced "proced" "\
@@ -21502,7 +22075,7 @@ See `proced-mode' for a description of features available in Proced buffers.
;;;***
;;;### (autoloads (switch-to-prolog prolog-mode) "prolog" "progmodes/prolog.el"
-;;;;;; (19636 58496))
+;;;;;; (19672 21006))
;;; Generated autoloads from progmodes/prolog.el
(autoload 'prolog-mode "prolog" "\
@@ -21525,8 +22098,8 @@ With prefix argument \\[universal-prefix], prompt for the program to use.
;;;***
-;;;### (autoloads (bdf-directory-list) "ps-bdf" "ps-bdf.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (bdf-directory-list) "ps-bdf" "ps-bdf.el" (19580
+;;;;;; 19536))
;;; Generated autoloads from ps-bdf.el
(defvar bdf-directory-list (if (memq system-type '(ms-dos windows-nt)) (list (expand-file-name "fonts/bdf" installation-directory)) '("/usr/local/share/emacs/fonts/bdf")) "\
@@ -21537,8 +22110,8 @@ The default value is '(\"/usr/local/share/emacs/fonts/bdf\").")
;;;***
-;;;### (autoloads (ps-mode) "ps-mode" "progmodes/ps-mode.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (ps-mode) "ps-mode" "progmodes/ps-mode.el" (19580
+;;;;;; 19536))
;;; Generated autoloads from progmodes/ps-mode.el
(autoload 'ps-mode "ps-mode" "\
@@ -21589,8 +22162,8 @@ Typing \\<ps-run-mode-map>\\[ps-run-goto-error] when the cursor is at the number
;;;;;; ps-spool-region ps-spool-buffer-with-faces ps-spool-buffer
;;;;;; ps-print-region-with-faces ps-print-region ps-print-buffer-with-faces
;;;;;; ps-print-buffer ps-print-customize ps-print-color-p ps-paper-type
-;;;;;; ps-page-dimensions-database) "ps-print" "ps-print.el" (19641
-;;;;;; 1314))
+;;;;;; ps-page-dimensions-database) "ps-print" "ps-print.el" (19648
+;;;;;; 63513))
;;; Generated autoloads from ps-print.el
(defvar ps-page-dimensions-database (purecopy (list (list 'a4 (/ (* 72 21.0) 2.54) (/ (* 72 29.7) 2.54) "A4") (list 'a3 (/ (* 72 29.7) 2.54) (/ (* 72 42.0) 2.54) "A3") (list 'letter (* 72 8.5) (* 72 11.0) "Letter") (list 'legal (* 72 8.5) (* 72 14.0) "Legal") (list 'letter-small (* 72 7.68) (* 72 10.16) "LetterSmall") (list 'tabloid (* 72 11.0) (* 72 17.0) "Tabloid") (list 'ledger (* 72 17.0) (* 72 11.0) "Ledger") (list 'statement (* 72 5.5) (* 72 8.5) "Statement") (list 'executive (* 72 7.5) (* 72 10.0) "Executive") (list 'a4small (* 72 7.47) (* 72 10.85) "A4Small") (list 'b4 (* 72 10.125) (* 72 14.33) "B4") (list 'b5 (* 72 7.16) (* 72 10.125) "B5") '(addresslarge 236.0 99.0 "AddressLarge") '(addresssmall 236.0 68.0 "AddressSmall") '(cuthanging13 90.0 222.0 "CutHanging13") '(cuthanging15 90.0 114.0 "CutHanging15") '(diskette 181.0 136.0 "Diskette") '(eurofilefolder 139.0 112.0 "EuropeanFilefolder") '(eurofoldernarrow 526.0 107.0 "EuroFolderNarrow") '(eurofolderwide 526.0 136.0 "EuroFolderWide") '(euronamebadge 189.0 108.0 "EuroNameBadge") '(euronamebadgelarge 223.0 136.0 "EuroNameBadgeLarge") '(filefolder 230.0 37.0 "FileFolder") '(jewelry 76.0 136.0 "Jewelry") '(mediabadge 180.0 136.0 "MediaBadge") '(multipurpose 126.0 68.0 "MultiPurpose") '(retaillabel 90.0 104.0 "RetailLabel") '(shipping 271.0 136.0 "Shipping") '(slide35mm 26.0 104.0 "Slide35mm") '(spine8mm 187.0 26.0 "Spine8mm") '(topcoated 425.19685 136.0 "TopCoatedPaper") '(topcoatedpaper 396.0 136.0 "TopcoatedPaper150") '(vhsface 205.0 127.0 "VHSFace") '(vhsspine 400.0 50.0 "VHSSpine") '(zipdisk 156.0 136.0 "ZipDisk"))) "\
@@ -21787,7 +22360,7 @@ If EXTENSION is any other symbol, it is ignored.
;;;***
;;;### (autoloads (python-shell jython-mode python-mode run-python)
-;;;;;; "python" "progmodes/python.el" (19672 43471))
+;;;;;; "python" "progmodes/python.el" (19691 3508))
;;; Generated autoloads from progmodes/python.el
(add-to-list 'interpreter-mode-alist (cons (purecopy "jython") 'jython-mode))
@@ -21873,7 +22446,7 @@ command is used to switch to an existing process, only when a new
process is started. If you use this, you will probably want to ensure
that the current arguments are retained (they will be included in the
prompt). This argument is ignored when this function is called
-programmatically, or when running in Emacs 19.34 or older.
+programmatically.
Note: You can toggle between using the CPython interpreter and the
JPython interpreter by hitting \\[python-toggle-shells]. This toggles
@@ -21903,7 +22476,7 @@ filter.
;;;***
;;;### (autoloads (quoted-printable-decode-region) "qp" "gnus/qp.el"
-;;;;;; (19636 58496))
+;;;;;; (19582 65302))
;;; Generated autoloads from gnus/qp.el
(autoload 'quoted-printable-decode-region "qp" "\
@@ -21926,7 +22499,7 @@ them into characters should be done separately.
;;;;;; quail-defrule quail-install-decode-map quail-install-map
;;;;;; quail-define-rules quail-show-keyboard-layout quail-set-keyboard-layout
;;;;;; quail-define-package quail-use-package quail-title) "quail"
-;;;;;; "international/quail.el" (19636 58496))
+;;;;;; "international/quail.el" (19498 12592))
;;; Generated autoloads from international/quail.el
(autoload 'quail-title "quail" "\
@@ -22157,8 +22730,8 @@ of each directory.
;;;### (autoloads (quickurl-list quickurl-list-mode quickurl-edit-urls
;;;;;; quickurl-browse-url-ask quickurl-browse-url quickurl-add-url
-;;;;;; quickurl-ask quickurl) "quickurl" "net/quickurl.el" (19636
-;;;;;; 58496))
+;;;;;; quickurl-ask quickurl) "quickurl" "net/quickurl.el" (19672
+;;;;;; 56753))
;;; Generated autoloads from net/quickurl.el
(defconst quickurl-reread-hook-postfix "\n;; Local Variables:\n;; eval: (progn (require 'quickurl) (add-hook 'local-write-file-hooks (lambda () (quickurl-read) nil)))\n;; End:\n" "\
@@ -22230,7 +22803,7 @@ Display `quickurl-list' as a formatted list using `quickurl-list-mode'.
;;;***
;;;### (autoloads (rcirc-track-minor-mode rcirc-connect rcirc) "rcirc"
-;;;;;; "net/rcirc.el" (19636 58496))
+;;;;;; "net/rcirc.el" (19599 45674))
;;; Generated autoloads from net/rcirc.el
(autoload 'rcirc "rcirc" "\
@@ -22265,8 +22838,8 @@ Global minor mode for tracking activity in rcirc buffers.
;;;***
-;;;### (autoloads (remote-compile) "rcompile" "net/rcompile.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (remote-compile) "rcompile" "net/rcompile.el" (19609
+;;;;;; 2577))
;;; Generated autoloads from net/rcompile.el
(autoload 'remote-compile "rcompile" "\
@@ -22278,7 +22851,7 @@ See \\[compile].
;;;***
;;;### (autoloads (re-builder) "re-builder" "emacs-lisp/re-builder.el"
-;;;;;; (19636 58496))
+;;;;;; (19552 37739))
;;; Generated autoloads from emacs-lisp/re-builder.el
(defalias 'regexp-builder 're-builder)
@@ -22290,7 +22863,7 @@ Construct a regexp interactively.
;;;***
-;;;### (autoloads (recentf-mode) "recentf" "recentf.el" (19636 58496))
+;;;### (autoloads (recentf-mode) "recentf" "recentf.el" (19277 34917))
;;; Generated autoloads from recentf.el
(defvar recentf-mode nil "\
@@ -22317,8 +22890,8 @@ that were operated on recently.
;;;### (autoloads (clear-rectangle string-insert-rectangle string-rectangle
;;;;;; delete-whitespace-rectangle open-rectangle insert-rectangle
;;;;;; yank-rectangle kill-rectangle extract-rectangle delete-extract-rectangle
-;;;;;; delete-rectangle move-to-column-force) "rect" "rect.el" (19636
-;;;;;; 58496))
+;;;;;; delete-rectangle move-to-column-force) "rect" "rect.el" (19580
+;;;;;; 19536))
;;; Generated autoloads from rect.el
(define-key ctl-x-r-map "c" 'clear-rectangle)
(define-key ctl-x-r-map "k" 'kill-rectangle)
@@ -22452,8 +23025,8 @@ rectangle which were empty.
;;;***
-;;;### (autoloads (refill-mode) "refill" "textmodes/refill.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (refill-mode) "refill" "textmodes/refill.el" (19277
+;;;;;; 34923))
;;; Generated autoloads from textmodes/refill.el
(autoload 'refill-mode "refill" "\
@@ -22469,7 +23042,7 @@ refilling if they would cause auto-filling.
;;;***
;;;### (autoloads (reftex-reset-scanning-information reftex-mode
-;;;;;; turn-on-reftex) "reftex" "textmodes/reftex.el" (19636 58496))
+;;;;;; turn-on-reftex) "reftex" "textmodes/reftex.el" (19594 48841))
;;; Generated autoloads from textmodes/reftex.el
(autoload 'turn-on-reftex "reftex" "\
@@ -22519,7 +23092,7 @@ This enforces rescanning the buffer on next use.
;;;***
;;;### (autoloads (reftex-citation) "reftex-cite" "textmodes/reftex-cite.el"
-;;;;;; (19636 58496))
+;;;;;; (19669 41170))
;;; Generated autoloads from textmodes/reftex-cite.el
(autoload 'reftex-citation "reftex-cite" "\
@@ -22549,7 +23122,7 @@ While entering the regexp, completion on knows citation keys is possible.
;;;***
;;;### (autoloads (reftex-isearch-minor-mode) "reftex-global" "textmodes/reftex-global.el"
-;;;;;; (19636 58496))
+;;;;;; (19580 19536))
;;; Generated autoloads from textmodes/reftex-global.el
(autoload 'reftex-isearch-minor-mode "reftex-global" "\
@@ -22566,7 +23139,7 @@ With no argument, this command toggles
;;;***
;;;### (autoloads (reftex-index-phrases-mode) "reftex-index" "textmodes/reftex-index.el"
-;;;;;; (19636 58496))
+;;;;;; (19664 56235))
;;; Generated autoloads from textmodes/reftex-index.el
(autoload 'reftex-index-phrases-mode "reftex-index" "\
@@ -22599,7 +23172,7 @@ Here are all local bindings.
;;;***
;;;### (autoloads (reftex-all-document-files) "reftex-parse" "textmodes/reftex-parse.el"
-;;;;;; (19636 58496))
+;;;;;; (19607 63447))
;;; Generated autoloads from textmodes/reftex-parse.el
(autoload 'reftex-all-document-files "reftex-parse" "\
@@ -22611,8 +23184,8 @@ of master file.
;;;***
-;;;### (autoloads nil "reftex-vars" "textmodes/reftex-vars.el" (19636
-;;;;;; 58496))
+;;;### (autoloads nil "reftex-vars" "textmodes/reftex-vars.el" (19580
+;;;;;; 19536))
;;; Generated autoloads from textmodes/reftex-vars.el
(put 'reftex-vref-is-default 'safe-local-variable (lambda (x) (or (stringp x) (symbolp x))))
(put 'reftex-fref-is-default 'safe-local-variable (lambda (x) (or (stringp x) (symbolp x))))
@@ -22622,7 +23195,7 @@ of master file.
;;;***
;;;### (autoloads (regexp-opt-depth regexp-opt) "regexp-opt" "emacs-lisp/regexp-opt.el"
-;;;;;; (19652 24589))
+;;;;;; (19645 60484))
;;; Generated autoloads from emacs-lisp/regexp-opt.el
(autoload 'regexp-opt "regexp-opt" "\
@@ -22637,6 +23210,8 @@ The returned regexp is typically more efficient than the equivalent regexp:
If PAREN is `words', then the resulting regexp is additionally surrounded
by \\=\\< and \\>.
+If PAREN is `symbols', then the resulting regexp is additionally surrounded
+by \\=\\_< and \\_>.
\(fn STRINGS &optional PAREN)" nil nil)
@@ -22651,7 +23226,7 @@ This means the number of non-shy regexp grouping constructs
;;;### (autoloads (remember-diary-extract-entries remember-clipboard
;;;;;; remember-other-frame remember) "remember" "textmodes/remember.el"
-;;;;;; (19636 58496))
+;;;;;; (19672 39537))
;;; Generated autoloads from textmodes/remember.el
(autoload 'remember "remember" "\
@@ -22682,7 +23257,7 @@ Extract diary entries from the region.
;;;***
-;;;### (autoloads (repeat) "repeat" "repeat.el" (19652 24589))
+;;;### (autoloads (repeat) "repeat" "repeat.el" (19645 60484))
;;; Generated autoloads from repeat.el
(autoload 'repeat "repeat" "\
@@ -22705,7 +23280,7 @@ recently executed command not bound to an input event\".
;;;***
;;;### (autoloads (reporter-submit-bug-report) "reporter" "mail/reporter.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34921))
;;; Generated autoloads from mail/reporter.el
(autoload 'reporter-submit-bug-report "reporter" "\
@@ -22737,7 +23312,7 @@ mail-sending package is used for editing and sending the message.
;;;***
;;;### (autoloads (reposition-window) "reposition" "reposition.el"
-;;;;;; (19636 58496))
+;;;;;; (19668 19461))
;;; Generated autoloads from reposition.el
(autoload 'reposition-window "reposition" "\
@@ -22764,7 +23339,7 @@ first comment line visible (if point is in a comment).
;;;***
;;;### (autoloads (global-reveal-mode reveal-mode) "reveal" "reveal.el"
-;;;;;; (19636 58496))
+;;;;;; (19354 34807))
;;; Generated autoloads from reveal.el
(autoload 'reveal-mode "reveal" "\
@@ -22799,7 +23374,7 @@ With zero or negative ARG turn mode off.
;;;***
;;;### (autoloads (make-ring ring-p) "ring" "emacs-lisp/ring.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34919))
;;; Generated autoloads from emacs-lisp/ring.el
(autoload 'ring-p "ring" "\
@@ -22814,7 +23389,7 @@ Make a ring that can contain SIZE elements.
;;;***
-;;;### (autoloads (rlogin) "rlogin" "net/rlogin.el" (19636 58496))
+;;;### (autoloads (rlogin) "rlogin" "net/rlogin.el" (19609 2536))
;;; Generated autoloads from net/rlogin.el
(add-hook 'same-window-regexps (purecopy "^\\*rlogin-.*\\*\\(\\|<[0-9]+>\\)"))
@@ -22864,8 +23439,8 @@ variable.
;;;;;; rmail-secondary-file-directory rmail-primary-inbox-list rmail-highlighted-headers
;;;;;; rmail-retry-ignored-headers rmail-displayed-headers rmail-ignored-headers
;;;;;; rmail-dont-reply-to-names rmail-user-mail-address-regexp
-;;;;;; rmail-movemail-variant-p) "rmail" "mail/rmail.el" (19641
-;;;;;; 1152))
+;;;;;; rmail-movemail-variant-p) "rmail" "mail/rmail.el" (19639
+;;;;;; 17158))
;;; Generated autoloads from mail/rmail.el
(autoload 'rmail-movemail-variant-p "rmail" "\
@@ -23059,7 +23634,7 @@ Set PASSWORD to be used for retrieving mail from a POP or IMAP server.
;;;***
;;;### (autoloads (rmail-output-body-to-file rmail-output-as-seen
-;;;;;; rmail-output) "rmailout" "mail/rmailout.el" (19636 58496))
+;;;;;; rmail-output) "rmailout" "mail/rmailout.el" (19580 19536))
;;; Generated autoloads from mail/rmailout.el
(put 'rmail-output-file-alist 'risky-local-variable t)
@@ -23124,7 +23699,7 @@ than appending to it. Deletes the message after writing if
;;;***
;;;### (autoloads (rng-c-load-schema) "rng-cmpct" "nxml/rng-cmpct.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34921))
;;; Generated autoloads from nxml/rng-cmpct.el
(autoload 'rng-c-load-schema "rng-cmpct" "\
@@ -23136,7 +23711,7 @@ Return a pattern.
;;;***
;;;### (autoloads (rng-nxml-mode-init) "rng-nxml" "nxml/rng-nxml.el"
-;;;;;; (19636 58496))
+;;;;;; (19696 28661))
;;; Generated autoloads from nxml/rng-nxml.el
(autoload 'rng-nxml-mode-init "rng-nxml" "\
@@ -23149,7 +23724,7 @@ Validation will be enabled if `rng-nxml-auto-validate-flag' is non-nil.
;;;***
;;;### (autoloads (rng-validate-mode) "rng-valid" "nxml/rng-valid.el"
-;;;;;; (19636 58496))
+;;;;;; (19696 28661))
;;; Generated autoloads from nxml/rng-valid.el
(autoload 'rng-validate-mode "rng-valid" "\
@@ -23179,8 +23754,8 @@ to use for finding the schema.
;;;***
-;;;### (autoloads (rng-xsd-compile) "rng-xsd" "nxml/rng-xsd.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (rng-xsd-compile) "rng-xsd" "nxml/rng-xsd.el" (19277
+;;;;;; 34921))
;;; Generated autoloads from nxml/rng-xsd.el
(put 'http://www\.w3\.org/2001/XMLSchema-datatypes 'rng-dt-compile 'rng-xsd-compile)
@@ -23208,7 +23783,7 @@ must be equal.
;;;***
;;;### (autoloads (robin-use-package robin-modify-package robin-define-package)
-;;;;;; "robin" "international/robin.el" (19636 58496))
+;;;;;; "robin" "international/robin.el" (19277 34920))
;;; Generated autoloads from international/robin.el
(autoload 'robin-define-package "robin" "\
@@ -23241,7 +23816,7 @@ Start using robin package NAME, which is a string.
;;;***
;;;### (autoloads (toggle-rot13-mode rot13-other-window rot13-region
-;;;;;; rot13-string rot13) "rot13" "rot13.el" (19636 58496))
+;;;;;; rot13-string rot13) "rot13" "rot13.el" (19277 34917))
;;; Generated autoloads from rot13.el
(autoload 'rot13 "rot13" "\
@@ -23279,7 +23854,7 @@ Toggle the use of ROT13 encoding for the current window.
;;;***
;;;### (autoloads (rst-minor-mode rst-mode) "rst" "textmodes/rst.el"
-;;;;;; (19636 58496))
+;;;;;; (19687 6902))
;;; Generated autoloads from textmodes/rst.el
(add-to-list 'auto-mode-alist (purecopy '("\\.re?st\\'" . rst-mode)))
@@ -23317,7 +23892,7 @@ for modes derived from Text mode, like Mail mode.
;;;***
;;;### (autoloads (ruby-mode) "ruby-mode" "progmodes/ruby-mode.el"
-;;;;;; (19636 58496))
+;;;;;; (19670 666))
;;; Generated autoloads from progmodes/ruby-mode.el
(autoload 'ruby-mode "ruby-mode" "\
@@ -23338,19 +23913,24 @@ The variable `ruby-indent-level' controls the amount of indentation.
;;;***
-;;;### (autoloads (ruler-mode) "ruler-mode" "ruler-mode.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (ruler-mode) "ruler-mode" "ruler-mode.el" (19502
+;;;;;; 11548))
;;; Generated autoloads from ruler-mode.el
+(defvar ruler-mode nil "\
+Non-nil if Ruler mode is enabled.
+Use the command `ruler-mode' to change this variable.")
+
(autoload 'ruler-mode "ruler-mode" "\
-Display a ruler in the header line if ARG > 0.
+Toggle Ruler mode.
+In Ruler mode, Emacs displays a ruler in the header line.
\(fn &optional ARG)" t nil)
;;;***
-;;;### (autoloads (rx rx-to-string) "rx" "emacs-lisp/rx.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (rx rx-to-string) "rx" "emacs-lisp/rx.el" (19590
+;;;;;; 30214))
;;; Generated autoloads from emacs-lisp/rx.el
(autoload 'rx-to-string "rx" "\
@@ -23656,14 +24236,16 @@ enclosed in `(and ...)'.
;;;***
-;;;### (autoloads (savehist-mode savehist-mode) "savehist" "savehist.el"
-;;;;;; (19636 58496))
+;;;### (autoloads (savehist-mode) "savehist" "savehist.el" (19423
+;;;;;; 37200))
;;; Generated autoloads from savehist.el
(defvar savehist-mode nil "\
-Mode for automatic saving of minibuffer history.
-Set this by calling the `savehist-mode' function or using the customize
-interface.")
+Non-nil if Savehist mode is enabled.
+See the command `savehist-mode' for a description of this minor mode.
+Setting this variable directly does not take effect;
+either customize it (see the info node `Easy Customization')
+or call the function `savehist-mode'.")
(custom-autoload 'savehist-mode "savehist" nil)
@@ -23678,12 +24260,12 @@ This mode should normally be turned on from your Emacs init file.
Calling it at any other time replaces your current minibuffer histories,
which is probably undesirable.
-\(fn ARG)" t nil)
+\(fn &optional ARG)" t nil)
;;;***
;;;### (autoloads (dsssl-mode scheme-mode) "scheme" "progmodes/scheme.el"
-;;;;;; (19636 58496))
+;;;;;; (19561 48711))
;;; Generated autoloads from progmodes/scheme.el
(autoload 'scheme-mode "scheme" "\
@@ -23725,7 +24307,7 @@ that variable's value is a string.
;;;***
;;;### (autoloads (gnus-score-mode) "score-mode" "gnus/score-mode.el"
-;;;;;; (19636 58496))
+;;;;;; (19582 65302))
;;; Generated autoloads from gnus/score-mode.el
(autoload 'gnus-score-mode "score-mode" "\
@@ -23739,7 +24321,7 @@ This mode is an extended emacs-lisp mode.
;;;***
;;;### (autoloads (scroll-all-mode) "scroll-all" "scroll-all.el"
-;;;;;; (19636 58496))
+;;;;;; (19433 56975))
;;; Generated autoloads from scroll-all.el
(defvar scroll-all-mode nil "\
@@ -23762,7 +24344,7 @@ apply to all visible windows in the same frame.
;;;***
;;;### (autoloads (scroll-lock-mode) "scroll-lock" "scroll-lock.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34917))
;;; Generated autoloads from scroll-lock.el
(autoload 'scroll-lock-mode "scroll-lock" "\
@@ -23776,8 +24358,15 @@ during scrolling.
;;;***
+;;;### (autoloads nil "secrets" "net/secrets.el" (19444 23363))
+;;; Generated autoloads from net/secrets.el
+(when (featurep 'dbusbind)
+ (autoload 'secrets-show-secrets "secrets" nil t))
+
+;;;***
+
;;;### (autoloads (semantic-mode semantic-default-submodes) "semantic"
-;;;;;; "cedet/semantic.el" (19636 58496))
+;;;;;; "cedet/semantic.el" (19612 4032))
;;; Generated autoloads from cedet/semantic.el
(defvar semantic-default-submodes '(global-semantic-idle-scheduler-mode global-semanticdb-minor-mode) "\
@@ -23829,7 +24418,7 @@ Semantic mode.
;;;;;; mail-alias-file mail-default-reply-to mail-archive-file-name
;;;;;; mail-header-separator send-mail-function mail-interactive
;;;;;; mail-self-blind mail-specify-envelope-from mail-from-style)
-;;;;;; "sendmail" "mail/sendmail.el" (19636 58496))
+;;;;;; "sendmail" "mail/sendmail.el" (19696 28661))
;;; Generated autoloads from mail/sendmail.el
(defvar mail-from-style 'default "\
@@ -23958,7 +24547,7 @@ instead of no action.")
(custom-autoload 'mail-citation-hook "sendmail" t)
-(defvar mail-citation-prefix-regexp (purecopy "\\([ ]*\\(\\w\\|[_.]\\)+>+\\|[ ]*[]>|}]\\)+") "\
+(defvar mail-citation-prefix-regexp (purecopy "\\([ ]*\\(\\w\\|[_.]\\)+>+\\|[ ]*[]>|]\\)+") "\
Regular expression to match a citation prefix plus whitespace.
It should match whatever sort of citation prefixes you want to handle,
with whitespace before and after; it should also match just whitespace.
@@ -24064,6 +24653,7 @@ instead use `sendmail-coding-system' to get a constant encoding
of outgoing mails regardless of the current language environment.
See also the function `select-message-coding-system'.")
(add-hook 'same-window-buffer-names (purecopy "*mail*"))
+ (add-hook 'same-window-buffer-names (purecopy "*unsent mail*"))
(autoload 'mail "sendmail" "\
Edit a message to be sent. Prefix arg means resume editing (don't erase).
@@ -24128,10 +24718,16 @@ Like `mail' command, but display mail buffer in another frame.
;;;***
;;;### (autoloads (server-save-buffers-kill-terminal server-mode
-;;;;;; server-force-delete server-start) "server" "server.el" (19662
-;;;;;; 13261))
+;;;;;; server-force-delete server-start) "server" "server.el" (19687
+;;;;;; 6902))
;;; Generated autoloads from server.el
+(put 'server-host 'risky-local-variable t)
+
+(put 'server-port 'risky-local-variable t)
+
+(put 'server-auth-dir 'risky-local-variable t)
+
(autoload 'server-start "server" "\
Allow this Emacs process to be a server for client processes.
This starts a server communications subprocess through which
@@ -24186,7 +24782,7 @@ only these files will be asked to be saved.
;;;***
-;;;### (autoloads (ses-mode) "ses" "ses.el" (19636 58496))
+;;;### (autoloads (ses-mode) "ses" "ses.el" (19277 34917))
;;; Generated autoloads from ses.el
(autoload 'ses-mode "ses" "\
@@ -24205,7 +24801,7 @@ These are active only in the minibuffer, when entering or editing a formula:
;;;***
;;;### (autoloads (html-mode sgml-mode) "sgml-mode" "textmodes/sgml-mode.el"
-;;;;;; (19636 58496))
+;;;;;; (19651 33965))
;;; Generated autoloads from textmodes/sgml-mode.el
(autoload 'sgml-mode "sgml-mode" "\
@@ -24271,7 +24867,7 @@ To work around that, do:
;;;***
;;;### (autoloads (sh-mode) "sh-script" "progmodes/sh-script.el"
-;;;;;; (19636 58496))
+;;;;;; (19672 56753))
;;; Generated autoloads from progmodes/sh-script.el
(put 'sh-shell 'safe-local-variable 'symbolp)
@@ -24335,7 +24931,7 @@ with your script for an edit-interpret-debug cycle.
;;;***
-;;;### (autoloads (sha1) "sha1" "sha1.el" (19636 58496))
+;;;### (autoloads (sha1) "sha1" "sha1.el" (19582 65302))
;;; Generated autoloads from sha1.el
(autoload 'sha1 "sha1" "\
@@ -24350,7 +24946,7 @@ If BINARY is non-nil, return a string in binary form.
;;;***
;;;### (autoloads (list-load-path-shadows) "shadow" "emacs-lisp/shadow.el"
-;;;;;; (19636 58496))
+;;;;;; (19635 50568))
;;; Generated autoloads from emacs-lisp/shadow.el
(autoload 'list-load-path-shadows "shadow" "\
@@ -24400,8 +24996,8 @@ function, `load-path-shadows-find'.
;;;***
;;;### (autoloads (shadow-initialize shadow-define-regexp-group shadow-define-literal-group
-;;;;;; shadow-define-cluster) "shadowfile" "shadowfile.el" (19636
-;;;;;; 58496))
+;;;;;; shadow-define-cluster) "shadowfile" "shadowfile.el" (19277
+;;;;;; 34917))
;;; Generated autoloads from shadowfile.el
(autoload 'shadow-define-cluster "shadowfile" "\
@@ -24440,7 +25036,7 @@ Set up file shadowing.
;;;***
;;;### (autoloads (shell shell-dumb-shell-regexp) "shell" "shell.el"
-;;;;;; (19636 58496))
+;;;;;; (19696 28661))
;;; Generated autoloads from shell.el
(defvar shell-dumb-shell-regexp (purecopy "cmd\\(proxy\\)?\\.exe") "\
@@ -24489,8 +25085,19 @@ Otherwise, one argument `-i' is passed to the shell.
;;;***
+;;;### (autoloads (shr-insert-document) "shr" "gnus/shr.el" (19696
+;;;;;; 27153))
+;;; Generated autoloads from gnus/shr.el
+
+(autoload 'shr-insert-document "shr" "\
+Not documented
+
+\(fn DOM)" nil nil)
+
+;;;***
+
;;;### (autoloads (sieve-upload-and-bury sieve-upload sieve-manage)
-;;;;;; "sieve" "gnus/sieve.el" (19636 58496))
+;;;;;; "sieve" "gnus/sieve.el" (19628 47406))
;;; Generated autoloads from gnus/sieve.el
(autoload 'sieve-manage "sieve" "\
@@ -24511,7 +25118,7 @@ Not documented
;;;***
;;;### (autoloads (sieve-mode) "sieve-mode" "gnus/sieve-mode.el"
-;;;;;; (19636 58496))
+;;;;;; (19582 65302))
;;; Generated autoloads from gnus/sieve-mode.el
(autoload 'sieve-mode "sieve-mode" "\
@@ -24526,8 +25133,8 @@ Turning on Sieve mode runs `sieve-mode-hook'.
;;;***
-;;;### (autoloads (simula-mode) "simula" "progmodes/simula.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (simula-mode) "simula" "progmodes/simula.el" (19668
+;;;;;; 19649))
;;; Generated autoloads from progmodes/simula.el
(autoload 'simula-mode "simula" "\
@@ -24576,7 +25183,7 @@ with no arguments, if that value is non-nil.
;;;***
;;;### (autoloads (skeleton-pair-insert-maybe skeleton-insert skeleton-proxy-new
-;;;;;; define-skeleton) "skeleton" "skeleton.el" (19636 58496))
+;;;;;; define-skeleton) "skeleton" "skeleton.el" (19677 38476))
;;; Generated autoloads from skeleton.el
(defvar skeleton-filter-function 'identity "\
@@ -24686,8 +25293,8 @@ symmetrical ones, and the same character twice for the others.
;;;***
;;;### (autoloads (smerge-start-session smerge-mode smerge-ediff)
-;;;;;; "smerge-mode" "smerge-mode.el" (19636 58496))
-;;; Generated autoloads from smerge-mode.el
+;;;;;; "smerge-mode" "vc/smerge-mode.el" (19677 38476))
+;;; Generated autoloads from vc/smerge-mode.el
(autoload 'smerge-ediff "smerge-mode" "\
Invoke ediff to resolve the conflicts.
@@ -24711,7 +25318,7 @@ If no conflict maker is found, turn off `smerge-mode'.
;;;***
;;;### (autoloads (smiley-buffer smiley-region) "smiley" "gnus/smiley.el"
-;;;;;; (19636 58496))
+;;;;;; (19582 65302))
;;; Generated autoloads from gnus/smiley.el
(autoload 'smiley-region "smiley" "\
@@ -24729,7 +25336,7 @@ interactively. If there's no argument, do it at the current buffer.
;;;***
;;;### (autoloads (smtpmail-send-queued-mail smtpmail-send-it) "smtpmail"
-;;;;;; "mail/smtpmail.el" (19636 58496))
+;;;;;; "mail/smtpmail.el" (19277 34921))
;;; Generated autoloads from mail/smtpmail.el
(autoload 'smtpmail-send-it "smtpmail" "\
@@ -24744,7 +25351,7 @@ Send mail that was queued as a result of setting `smtpmail-queue-mail'.
;;;***
-;;;### (autoloads (snake) "snake" "play/snake.el" (19636 58496))
+;;;### (autoloads (snake) "snake" "play/snake.el" (19277 34922))
;;; Generated autoloads from play/snake.el
(autoload 'snake "snake" "\
@@ -24768,7 +25375,7 @@ Snake mode keybindings:
;;;***
;;;### (autoloads (snmpv2-mode snmp-mode) "snmp-mode" "net/snmp-mode.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34921))
;;; Generated autoloads from net/snmp-mode.el
(autoload 'snmp-mode "snmp-mode" "\
@@ -24797,8 +25404,8 @@ then `snmpv2-mode-hook'.
;;;***
-;;;### (autoloads (sunrise-sunset) "solar" "calendar/solar.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (sunrise-sunset) "solar" "calendar/solar.el" (19612
+;;;;;; 4032))
;;; Generated autoloads from calendar/solar.el
(autoload 'sunrise-sunset "solar" "\
@@ -24813,8 +25420,8 @@ This function is suitable for execution in a .emacs file.
;;;***
-;;;### (autoloads (solitaire) "solitaire" "play/solitaire.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (solitaire) "solitaire" "play/solitaire.el" (19277
+;;;;;; 34922))
;;; Generated autoloads from play/solitaire.el
(autoload 'solitaire "solitaire" "\
@@ -24891,7 +25498,7 @@ Pick your favourite shortcuts:
;;;### (autoloads (reverse-region sort-columns sort-regexp-fields
;;;;;; sort-fields sort-numeric-fields sort-pages sort-paragraphs
-;;;;;; sort-lines sort-subr) "sort" "sort.el" (19636 58496))
+;;;;;; sort-lines sort-subr) "sort" "sort.el" (19668 19352))
;;; Generated autoloads from sort.el
(put 'sort-fold-case 'safe-local-variable 'booleanp)
@@ -25035,8 +25642,8 @@ From a program takes two point or marker arguments, BEG and END.
;;;***
-;;;### (autoloads (spam-initialize) "spam" "gnus/spam.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (spam-initialize) "spam" "gnus/spam.el" (19648
+;;;;;; 31344))
;;; Generated autoloads from gnus/spam.el
(autoload 'spam-initialize "spam" "\
@@ -25052,7 +25659,7 @@ installed through `spam-necessary-extra-headers'.
;;;### (autoloads (spam-report-deagentize spam-report-agentize spam-report-url-to-file
;;;;;; spam-report-url-ping-mm-url spam-report-process-queue) "spam-report"
-;;;;;; "gnus/spam-report.el" (19636 58496))
+;;;;;; "gnus/spam-report.el" (19626 25721))
;;; Generated autoloads from gnus/spam-report.el
(autoload 'spam-report-process-queue "spam-report" "\
@@ -25095,7 +25702,7 @@ Spam reports will be queued with the method used when
;;;***
;;;### (autoloads (speedbar-get-focus speedbar-frame-mode) "speedbar"
-;;;;;; "speedbar.el" (19658 61388))
+;;;;;; "speedbar.el" (19687 6902))
;;; Generated autoloads from speedbar.el
(defalias 'speedbar 'speedbar-frame-mode)
@@ -25120,7 +25727,7 @@ selected. If the speedbar frame is active, then select the attached frame.
;;;***
;;;### (autoloads (spell-string spell-region spell-word spell-buffer)
-;;;;;; "spell" "textmodes/spell.el" (19636 58496))
+;;;;;; "spell" "textmodes/spell.el" (19609 2713))
;;; Generated autoloads from textmodes/spell.el
(put 'spell-filter 'risky-local-variable t)
@@ -25164,8 +25771,8 @@ Check spelling of string supplied as argument.
;;;***
-;;;### (autoloads (snarf-spooks spook) "spook" "play/spook.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (snarf-spooks spook) "spook" "play/spook.el" (19277
+;;;;;; 34922))
;;; Generated autoloads from play/spook.el
(autoload 'spook "spook" "\
@@ -25182,15 +25789,15 @@ Return a vector containing the lines from `spook-phrases-file'.
;;;### (autoloads (sql-linter sql-db2 sql-interbase sql-postgres
;;;;;; sql-ms sql-ingres sql-solid sql-mysql sql-sqlite sql-informix
-;;;;;; sql-sybase sql-oracle sql-product-interactive sql-mode sql-help
-;;;;;; sql-add-product-keywords) "sql" "progmodes/sql.el" (19660
-;;;;;; 57887))
+;;;;;; sql-sybase sql-oracle sql-product-interactive sql-connect
+;;;;;; sql-mode sql-help sql-add-product-keywords) "sql" "progmodes/sql.el"
+;;;;;; (19661 46305))
;;; Generated autoloads from progmodes/sql.el
(autoload 'sql-add-product-keywords "sql" "\
Add highlighting KEYWORDS for SQL PRODUCT.
-PRODUCT should be a symbol, the name of a sql product, such as
+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
@@ -25216,24 +25823,17 @@ usually named `*SQL*'. The name of the major mode is SQLi.
Use the following commands to start a specific SQL interpreter:
- PostGres: \\[sql-postgres]
- MySQL: \\[sql-mysql]
- SQLite: \\[sql-sqlite]
+ \\\\FREE
Other non-free SQL implementations are also supported:
- Solid: \\[sql-solid]
- Oracle: \\[sql-oracle]
- Informix: \\[sql-informix]
- Sybase: \\[sql-sybase]
- Ingres: \\[sql-ingres]
- Microsoft: \\[sql-ms]
- DB2: \\[sql-db2]
- Interbase: \\[sql-interbase]
- Linter: \\[sql-linter]
+ \\\\NONFREE
But we urge you to choose a free implementation instead of these.
+You can also use \\[sql-product-interactive] to invoke the
+interpreter for the current `sql-product'.
+
Once you have the SQLi buffer, you can enter SQL statements in the
buffer. The output generated is appended to the buffer and a new prompt
is generated. See the In/Out menu in the SQLi buffer for some functions
@@ -25280,15 +25880,31 @@ you must tell Emacs. Here's how to do that in your `~/.emacs' file:
\(fn)" t nil)
+(autoload 'sql-connect "sql" "\
+Connect to an interactive session using CONNECTION settings.
+
+See `sql-connection-alist' to see how to define connections and
+their settings.
+
+The user will not be prompted for any login parameters if a value
+is specified in the connection settings.
+
+\(fn CONNECTION)" t nil)
+
(autoload 'sql-product-interactive "sql" "\
-Run product interpreter as an inferior process.
+Run PRODUCT interpreter as an inferior process.
If buffer `*SQL*' exists but no process is running, make a new process.
If buffer exists and a process is running, just switch to buffer `*SQL*'.
+To specify the SQL product, prefix the call with
+\\[universal-argument]. To set the buffer name as well, prefix
+the call to \\[sql-product-interactive] with
+\\[universal-argument] \\[universal-argument].
+
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)
-\(fn &optional PRODUCT)" t nil)
+\(fn &optional PRODUCT NEW-NAME)" t nil)
(autoload 'sql-oracle "sql" "\
Run sqlplus by Oracle as an inferior process.
@@ -25305,6 +25921,11 @@ the list `sql-oracle-options'.
The buffer is put in SQL interactive mode, giving commands for sending
input. See `sql-interactive-mode'.
+To set the buffer name directly, use \\[universal-argument]
+before \\[sql-oracle]. Once session has started,
+\\[sql-rename-buffer] can be called separately to rename the
+buffer.
+
To specify a coding system for converting non-ASCII characters
in the input and output to the process, use \\[universal-coding-system-argument]
before \\[sql-oracle]. You can also specify this with \\[set-buffer-process-coding-system]
@@ -25314,10 +25935,10 @@ The default comes from `process-coding-system-alist' and
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)
-\(fn)" t nil)
+\(fn &optional BUFFER)" t nil)
(autoload 'sql-sybase "sql" "\
-Run isql by SyBase as an inferior process.
+Run isql by Sybase as an inferior process.
If buffer `*SQL*' exists but no process is running, make a new process.
If buffer exists and a process is running, just switch to buffer
@@ -25331,6 +25952,11 @@ can be stored in the list `sql-sybase-options'.
The buffer is put in SQL interactive mode, giving commands for sending
input. See `sql-interactive-mode'.
+To set the buffer name directly, use \\[universal-argument]
+before \\[sql-sybase]. Once session has started,
+\\[sql-rename-buffer] can be called separately to rename the
+buffer.
+
To specify a coding system for converting non-ASCII characters
in the input and output to the process, use \\[universal-coding-system-argument]
before \\[sql-sybase]. You can also specify this with \\[set-buffer-process-coding-system]
@@ -25340,7 +25966,7 @@ The default comes from `process-coding-system-alist' and
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)
-\(fn)" t nil)
+\(fn &optional BUFFER)" t nil)
(autoload 'sql-informix "sql" "\
Run dbaccess by Informix as an inferior process.
@@ -25355,6 +25981,11 @@ the variable `sql-database' as default, if set.
The buffer is put in SQL interactive mode, giving commands for sending
input. See `sql-interactive-mode'.
+To set the buffer name directly, use \\[universal-argument]
+before \\[sql-informix]. Once session has started,
+\\[sql-rename-buffer] can be called separately to rename the
+buffer.
+
To specify a coding system for converting non-ASCII characters
in the input and output to the process, use \\[universal-coding-system-argument]
before \\[sql-informix]. You can also specify this with \\[set-buffer-process-coding-system]
@@ -25364,7 +25995,7 @@ The default comes from `process-coding-system-alist' and
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)
-\(fn)" t nil)
+\(fn &optional BUFFER)" t nil)
(autoload 'sql-sqlite "sql" "\
Run sqlite as an inferior process.
@@ -25383,6 +26014,11 @@ can be stored in the list `sql-sqlite-options'.
The buffer is put in SQL interactive mode, giving commands for sending
input. See `sql-interactive-mode'.
+To set the buffer name directly, use \\[universal-argument]
+before \\[sql-sqlite]. Once session has started,
+\\[sql-rename-buffer] can be called separately to rename the
+buffer.
+
To specify a coding system for converting non-ASCII characters
in the input and output to the process, use \\[universal-coding-system-argument]
before \\[sql-sqlite]. You can also specify this with \\[set-buffer-process-coding-system]
@@ -25392,7 +26028,7 @@ The default comes from `process-coding-system-alist' and
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)
-\(fn)" t nil)
+\(fn &optional BUFFER)" t nil)
(autoload 'sql-mysql "sql" "\
Run mysql by TcX as an inferior process.
@@ -25411,6 +26047,11 @@ can be stored in the list `sql-mysql-options'.
The buffer is put in SQL interactive mode, giving commands for sending
input. See `sql-interactive-mode'.
+To set the buffer name directly, use \\[universal-argument]
+before \\[sql-mysql]. Once session has started,
+\\[sql-rename-buffer] can be called separately to rename the
+buffer.
+
To specify a coding system for converting non-ASCII characters
in the input and output to the process, use \\[universal-coding-system-argument]
before \\[sql-mysql]. You can also specify this with \\[set-buffer-process-coding-system]
@@ -25420,7 +26061,7 @@ The default comes from `process-coding-system-alist' and
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)
-\(fn)" t nil)
+\(fn &optional BUFFER)" t nil)
(autoload 'sql-solid "sql" "\
Run solsql by Solid as an inferior process.
@@ -25436,6 +26077,11 @@ defaults, if set.
The buffer is put in SQL interactive mode, giving commands for sending
input. See `sql-interactive-mode'.
+To set the buffer name directly, use \\[universal-argument]
+before \\[sql-solid]. Once session has started,
+\\[sql-rename-buffer] can be called separately to rename the
+buffer.
+
To specify a coding system for converting non-ASCII characters
in the input and output to the process, use \\[universal-coding-system-argument]
before \\[sql-solid]. You can also specify this with \\[set-buffer-process-coding-system]
@@ -25445,7 +26091,7 @@ The default comes from `process-coding-system-alist' and
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)
-\(fn)" t nil)
+\(fn &optional BUFFER)" t nil)
(autoload 'sql-ingres "sql" "\
Run sql by Ingres as an inferior process.
@@ -25460,6 +26106,11 @@ the variable `sql-database' as default, if set.
The buffer is put in SQL interactive mode, giving commands for sending
input. See `sql-interactive-mode'.
+To set the buffer name directly, use \\[universal-argument]
+before \\[sql-ingres]. Once session has started,
+\\[sql-rename-buffer] can be called separately to rename the
+buffer.
+
To specify a coding system for converting non-ASCII characters
in the input and output to the process, use \\[universal-coding-system-argument]
before \\[sql-ingres]. You can also specify this with \\[set-buffer-process-coding-system]
@@ -25469,7 +26120,7 @@ The default comes from `process-coding-system-alist' and
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)
-\(fn)" t nil)
+\(fn &optional BUFFER)" t nil)
(autoload 'sql-ms "sql" "\
Run osql by Microsoft as an inferior process.
@@ -25486,6 +26137,11 @@ in the list `sql-ms-options'.
The buffer is put in SQL interactive mode, giving commands for sending
input. See `sql-interactive-mode'.
+To set the buffer name directly, use \\[universal-argument]
+before \\[sql-ms]. Once session has started,
+\\[sql-rename-buffer] can be called separately to rename the
+buffer.
+
To specify a coding system for converting non-ASCII characters
in the input and output to the process, use \\[universal-coding-system-argument]
before \\[sql-ms]. You can also specify this with \\[set-buffer-process-coding-system]
@@ -25495,7 +26151,7 @@ The default comes from `process-coding-system-alist' and
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)
-\(fn)" t nil)
+\(fn &optional BUFFER)" t nil)
(autoload 'sql-postgres "sql" "\
Run psql by Postgres as an inferior process.
@@ -25512,6 +26168,11 @@ Additional command line parameters can be stored in the list
The buffer is put in SQL interactive mode, giving commands for sending
input. See `sql-interactive-mode'.
+To set the buffer name directly, use \\[universal-argument]
+before \\[sql-postgres]. Once session has started,
+\\[sql-rename-buffer] can be called separately to rename the
+buffer.
+
To specify a coding system for converting non-ASCII characters
in the input and output to the process, use \\[universal-coding-system-argument]
before \\[sql-postgres]. You can also specify this with \\[set-buffer-process-coding-system]
@@ -25526,7 +26187,7 @@ Try to set `comint-output-filter-functions' like this:
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)
-\(fn)" t nil)
+\(fn &optional BUFFER)" t nil)
(autoload 'sql-interbase "sql" "\
Run isql by Interbase as an inferior process.
@@ -25542,6 +26203,11 @@ defaults, if set.
The buffer is put in SQL interactive mode, giving commands for sending
input. See `sql-interactive-mode'.
+To set the buffer name directly, use \\[universal-argument]
+before \\[sql-interbase]. Once session has started,
+\\[sql-rename-buffer] can be called separately to rename the
+buffer.
+
To specify a coding system for converting non-ASCII characters
in the input and output to the process, use \\[universal-coding-system-argument]
before \\[sql-interbase]. You can also specify this with \\[set-buffer-process-coding-system]
@@ -25551,7 +26217,7 @@ The default comes from `process-coding-system-alist' and
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)
-\(fn)" t nil)
+\(fn &optional BUFFER)" t nil)
(autoload 'sql-db2 "sql" "\
Run db2 by IBM as an inferior process.
@@ -25571,6 +26237,11 @@ db2, newlines will be escaped if necessary. If you don't want that, set
`comint-input-sender' back to `comint-simple-send' by writing an after
advice. See the elisp manual for more information.
+To set the buffer name directly, use \\[universal-argument]
+before \\[sql-db2]. Once session has started,
+\\[sql-rename-buffer] can be called separately to rename the
+buffer.
+
To specify a coding system for converting non-ASCII characters
in the input and output to the process, use \\[universal-coding-system-argument]
before \\[sql-db2]. You can also specify this with \\[set-buffer-process-coding-system]
@@ -25580,7 +26251,7 @@ The default comes from `process-coding-system-alist' and
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)
-\(fn)" t nil)
+\(fn &optional BUFFER)" t nil)
(autoload 'sql-linter "sql" "\
Run inl by RELEX as an inferior process.
@@ -25592,7 +26263,7 @@ If buffer exists and a process is running, just switch to buffer
Interpreter used comes from variable `sql-linter-program' - usually `inl'.
Login uses the variables `sql-user', `sql-password', `sql-database' and
`sql-server' as defaults, if set. Additional command line parameters
-can be stored in the list `sql-linter-options'. Run inl -h to get help on
+can be stored in the list `sql-linter-options'. Run inl -h to get help on
parameters.
`sql-database' is used to set the LINTER_MBX environment variable for
@@ -25604,14 +26275,19 @@ an empty password.
The buffer is put in SQL interactive mode, giving commands for sending
input. See `sql-interactive-mode'.
+To set the buffer name directly, use \\[universal-argument]
+before \\[sql-linter]. Once session has started,
+\\[sql-rename-buffer] can be called separately to rename the
+buffer.
+
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)
-\(fn)" t nil)
+\(fn &optional BUFFER)" t nil)
;;;***
;;;### (autoloads (srecode-template-mode) "srecode/srt-mode" "cedet/srecode/srt-mode.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34919))
;;; Generated autoloads from cedet/srecode/srt-mode.el
(autoload 'srecode-template-mode "srecode/srt-mode" "\
@@ -25623,12 +26299,36 @@ Major-mode for writing SRecode macros.
;;;***
+;;;### (autoloads (starttls-open-stream) "starttls" "gnus/starttls.el"
+;;;;;; (19614 24990))
+;;; Generated autoloads from gnus/starttls.el
+
+(autoload 'starttls-open-stream "starttls" "\
+Open a TLS connection for a port 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 PORT.
+NAME is name for process. It is modified if necessary to make it unique.
+BUFFER is the buffer (or `buffer-name') to associate with the process.
+ 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 PORT is an integer specifying a port to connect to.
+If `starttls-use-gnutls' is nil, this may also be a service name, but
+GNUTLS requires a port number.
+
+\(fn NAME BUFFER HOST PORT)" nil nil)
+
+;;;***
+
;;;### (autoloads (strokes-compose-complex-stroke strokes-decode-buffer
;;;;;; strokes-mode strokes-list-strokes strokes-load-user-strokes
;;;;;; strokes-help strokes-describe-stroke strokes-do-complex-stroke
;;;;;; strokes-do-stroke strokes-read-complex-stroke strokes-read-stroke
-;;;;;; strokes-global-set-stroke) "strokes" "strokes.el" (19636
-;;;;;; 58496))
+;;;;;; strokes-global-set-stroke) "strokes" "strokes.el" (19277
+;;;;;; 34917))
;;; Generated autoloads from strokes.el
(autoload 'strokes-global-set-stroke "strokes" "\
@@ -25738,7 +26438,7 @@ Read a complex stroke and insert its glyph into the current buffer.
;;;***
;;;### (autoloads (studlify-buffer studlify-word studlify-region)
-;;;;;; "studly" "play/studly.el" (19636 58496))
+;;;;;; "studly" "play/studly.el" (19267 61660))
;;; Generated autoloads from play/studly.el
(autoload 'studlify-region "studly" "\
@@ -25759,7 +26459,7 @@ Studlify-case the current buffer.
;;;***
;;;### (autoloads (global-subword-mode subword-mode) "subword" "progmodes/subword.el"
-;;;;;; (19636 58496))
+;;;;;; (19445 54332))
;;; Generated autoloads from progmodes/subword.el
(autoload 'subword-mode "subword" "\
@@ -25807,7 +26507,7 @@ See `subword-mode' for more information on Subword mode.
;;;***
;;;### (autoloads (sc-cite-original) "supercite" "mail/supercite.el"
-;;;;;; (19636 58496))
+;;;;;; (19426 22841))
;;; Generated autoloads from mail/supercite.el
(autoload 'sc-cite-original "supercite" "\
@@ -25839,8 +26539,8 @@ and `sc-post-hook' is run after the guts of this function.
;;;***
-;;;### (autoloads (gpm-mouse-mode) "t-mouse" "t-mouse.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (gpm-mouse-mode) "t-mouse" "t-mouse.el" (19277
+;;;;;; 34917))
;;; Generated autoloads from t-mouse.el
(define-obsolete-function-alias 't-mouse-mode 'gpm-mouse-mode "23.1")
@@ -25867,7 +26567,7 @@ It relies on the `gpm' daemon being activated.
;;;***
-;;;### (autoloads (tabify untabify) "tabify" "tabify.el" (19636 58496))
+;;;### (autoloads (tabify untabify) "tabify" "tabify.el" (19580 19536))
;;; Generated autoloads from tabify.el
(autoload 'untabify "tabify" "\
@@ -25902,27 +26602,27 @@ The variable `tab-width' controls the spacing of tab stops.
;;;;;; table-recognize table-insert-row-column table-insert-column
;;;;;; table-insert-row table-insert table-point-left-cell-hook
;;;;;; table-point-entered-cell-hook table-load-hook table-cell-map-hook)
-;;;;;; "table" "textmodes/table.el" (19636 58496))
+;;;;;; "table" "textmodes/table.el" (19668 19553))
;;; Generated autoloads from textmodes/table.el
(defvar table-cell-map-hook nil "\
-*Normal hooks run when finishing construction of `table-cell-map'.
+Normal hooks run when finishing construction of `table-cell-map'.
User can modify `table-cell-map' by adding custom functions here.")
(custom-autoload 'table-cell-map-hook "table" t)
(defvar table-load-hook nil "\
-*List of functions to be called after the table is first loaded.")
+List of functions to be called after the table is first loaded.")
(custom-autoload 'table-load-hook "table" t)
(defvar table-point-entered-cell-hook nil "\
-*List of functions to be called after point entered a table cell.")
+List of functions to be called after point entered a table cell.")
(custom-autoload 'table-point-entered-cell-hook "table" t)
(defvar table-point-left-cell-hook nil "\
-*List of functions to be called after point left a table cell.")
+List of functions to be called after point left a table cell.")
(custom-autoload 'table-point-left-cell-hook "table" t)
@@ -26490,7 +27190,7 @@ converts a table into plain text without frames. It is a companion to
;;;***
-;;;### (autoloads (talk talk-connect) "talk" "talk.el" (19636 58496))
+;;;### (autoloads (talk talk-connect) "talk" "talk.el" (19277 34917))
;;; Generated autoloads from talk.el
(autoload 'talk-connect "talk" "\
@@ -26505,7 +27205,7 @@ Connect to the Emacs talk group from the current X display or tty frame.
;;;***
-;;;### (autoloads (tar-mode) "tar-mode" "tar-mode.el" (19636 58496))
+;;;### (autoloads (tar-mode) "tar-mode" "tar-mode.el" (19617 12132))
;;; Generated autoloads from tar-mode.el
(autoload 'tar-mode "tar-mode" "\
@@ -26529,7 +27229,7 @@ See also: variables `tar-update-datestamp' and `tar-anal-blocksize'.
;;;***
;;;### (autoloads (tcl-help-on-word inferior-tcl tcl-mode) "tcl"
-;;;;;; "progmodes/tcl.el" (19636 58496))
+;;;;;; "progmodes/tcl.el" (19673 45510))
;;; Generated autoloads from progmodes/tcl.el
(autoload 'tcl-mode "tcl" "\
@@ -26580,7 +27280,7 @@ Prefix argument means invert sense of `tcl-use-smart-word-finder'.
;;;***
-;;;### (autoloads (rsh telnet) "telnet" "net/telnet.el" (19636 58496))
+;;;### (autoloads (rsh telnet) "telnet" "net/telnet.el" (19635 50595))
;;; Generated autoloads from net/telnet.el
(add-hook 'same-window-regexps (purecopy "\\*telnet-.*\\*\\(\\|<[0-9]+>\\)"))
@@ -26608,7 +27308,7 @@ Normally input is edited in Emacs and sent a line at a time.
;;;***
;;;### (autoloads (serial-term ansi-term term make-term) "term" "term.el"
-;;;;;; (19636 58496))
+;;;;;; (19672 56753))
;;; Generated autoloads from term.el
(autoload 'make-term "term" "\
@@ -26650,8 +27350,8 @@ use in that buffer.
;;;***
-;;;### (autoloads (terminal-emulator) "terminal" "terminal.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (terminal-emulator) "terminal" "terminal.el" (19277
+;;;;;; 34917))
;;; Generated autoloads from terminal.el
(autoload 'terminal-emulator "terminal" "\
@@ -26688,7 +27388,7 @@ subprocess started.
;;;***
;;;### (autoloads (testcover-this-defun) "testcover" "emacs-lisp/testcover.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34919))
;;; Generated autoloads from emacs-lisp/testcover.el
(autoload 'testcover-this-defun "testcover" "\
@@ -26698,7 +27398,7 @@ Start coverage on function under point.
;;;***
-;;;### (autoloads (tetris) "tetris" "play/tetris.el" (19636 58496))
+;;;### (autoloads (tetris) "tetris" "play/tetris.el" (19552 37739))
;;; Generated autoloads from play/tetris.el
(autoload 'tetris "tetris" "\
@@ -26729,16 +27429,16 @@ tetris-mode keybindings:
;;;;;; tex-start-commands tex-start-options slitex-run-command latex-run-command
;;;;;; tex-run-command tex-offer-save tex-main-file tex-first-line-header-regexp
;;;;;; tex-directory tex-shell-file-name) "tex-mode" "textmodes/tex-mode.el"
-;;;;;; (19636 58496))
+;;;;;; (19651 33965))
;;; Generated autoloads from textmodes/tex-mode.el
(defvar tex-shell-file-name nil "\
-*If non-nil, the shell file name to run in the subshell used to run TeX.")
+If non-nil, the shell file name to run in the subshell used to run TeX.")
(custom-autoload 'tex-shell-file-name "tex-mode" t)
(defvar tex-directory (purecopy ".") "\
-*Directory in which temporary files are written.
+Directory in which temporary files are written.
You can make this `/tmp' if your TEXINPUTS has no relative directories in it
and you don't try to apply \\[tex-region] or \\[tex-buffer] when there are
`\\input' commands with relative directories.")
@@ -26754,40 +27454,40 @@ if it matches the first line of the file,
(custom-autoload 'tex-first-line-header-regexp "tex-mode" t)
(defvar tex-main-file nil "\
-*The main TeX source file which includes this buffer's file.
+The main TeX source file which includes this buffer's file.
The command `tex-file' runs TeX on the file specified by `tex-main-file'
if the variable is non-nil.")
(custom-autoload 'tex-main-file "tex-mode" t)
(defvar tex-offer-save t "\
-*If non-nil, ask about saving modified buffers before \\[tex-file] is run.")
+If non-nil, ask about saving modified buffers before \\[tex-file] is run.")
(custom-autoload 'tex-offer-save "tex-mode" t)
(defvar tex-run-command (purecopy "tex") "\
-*Command used to run TeX subjob.
+Command used to run TeX subjob.
TeX Mode sets `tex-command' to this string.
See the documentation of that variable.")
(custom-autoload 'tex-run-command "tex-mode" t)
(defvar latex-run-command (purecopy "latex") "\
-*Command used to run LaTeX subjob.
+Command used to run LaTeX subjob.
LaTeX Mode sets `tex-command' to this string.
See the documentation of that variable.")
(custom-autoload 'latex-run-command "tex-mode" t)
(defvar slitex-run-command (purecopy "slitex") "\
-*Command used to run SliTeX subjob.
+Command used to run SliTeX subjob.
SliTeX Mode sets `tex-command' to this string.
See the documentation of that variable.")
(custom-autoload 'slitex-run-command "tex-mode" t)
(defvar tex-start-options (purecopy "") "\
-*TeX options to use when starting TeX.
+TeX options to use when starting TeX.
These immediately precede the commands in `tex-start-commands'
and the input file name, with no separating space and are not shell-quoted.
If nil, TeX runs with no options. See the documentation of `tex-command'.")
@@ -26795,34 +27495,34 @@ If nil, TeX runs with no options. See the documentation of `tex-command'.")
(custom-autoload 'tex-start-options "tex-mode" t)
(defvar tex-start-commands (purecopy "\\nonstopmode\\input") "\
-*TeX commands to use when starting TeX.
+TeX commands to use when starting TeX.
They are shell-quoted and precede the input file name, with a separating space.
If nil, no commands are used. See the documentation of `tex-command'.")
(custom-autoload 'tex-start-commands "tex-mode" t)
(defvar latex-block-names nil "\
-*User defined LaTeX block names.
+User defined LaTeX block names.
Combined with `latex-standard-block-names' for minibuffer completion.")
(custom-autoload 'latex-block-names "tex-mode" t)
(defvar tex-bibtex-command (purecopy "bibtex") "\
-*Command used by `tex-bibtex-file' to gather bibliographic data.
+Command used by `tex-bibtex-file' to gather bibliographic data.
If this string contains an asterisk (`*'), that is replaced by the file name;
otherwise, the file name, preceded by blank, is added at the end.")
(custom-autoload 'tex-bibtex-command "tex-mode" t)
(defvar tex-dvi-print-command (purecopy "lpr -d") "\
-*Command used by \\[tex-print] to print a .dvi file.
+Command used by \\[tex-print] to print a .dvi file.
If this string contains an asterisk (`*'), that is replaced by the file name;
otherwise, the file name, preceded by blank, is added at the end.")
(custom-autoload 'tex-dvi-print-command "tex-mode" t)
(defvar tex-alt-dvi-print-command (purecopy "lpr -d") "\
-*Command used by \\[tex-print] with a prefix arg to print a .dvi file.
+Command used by \\[tex-print] with a prefix arg to print a .dvi file.
If this string contains an asterisk (`*'), that is replaced by the file name;
otherwise, the file name, preceded by blank, is added at the end.
@@ -26839,7 +27539,7 @@ use.")
(custom-autoload 'tex-alt-dvi-print-command "tex-mode" t)
(defvar tex-dvi-view-command `(cond ((eq window-system 'x) ,(purecopy "xdvi")) ((eq window-system 'w32) ,(purecopy "yap")) (t ,(purecopy "dvi2tty * | cat -s"))) "\
-*Command used by \\[tex-view] to display a `.dvi' file.
+Command used by \\[tex-view] to display a `.dvi' file.
If it is a string, that specifies the command directly.
If this string contains an asterisk (`*'), that is replaced by the file name;
otherwise, the file name, preceded by a space, is added at the end.
@@ -26849,13 +27549,13 @@ If the value is a form, it is evaluated to get the command to use.")
(custom-autoload 'tex-dvi-view-command "tex-mode" t)
(defvar tex-show-queue-command (purecopy "lpq") "\
-*Command used by \\[tex-show-print-queue] to show the print queue.
+Command used by \\[tex-show-print-queue] to show the print queue.
Should show the queue(s) that \\[tex-print] puts jobs on.")
(custom-autoload 'tex-show-queue-command "tex-mode" t)
(defvar tex-default-mode 'latex-mode "\
-*Mode to enter for a new file that might be either TeX or LaTeX.
+Mode to enter for a new file that might be either TeX or LaTeX.
This variable is used when it can't be determined whether the file
is plain TeX or LaTeX or what because the file contains no commands.
Normally set to either `plain-tex-mode' or `latex-mode'.")
@@ -26863,12 +27563,12 @@ Normally set to either `plain-tex-mode' or `latex-mode'.")
(custom-autoload 'tex-default-mode "tex-mode" t)
(defvar tex-open-quote (purecopy "``") "\
-*String inserted by typing \\[tex-insert-quote] to open a quotation.")
+String inserted by typing \\[tex-insert-quote] to open a quotation.")
(custom-autoload 'tex-open-quote "tex-mode" t)
(defvar tex-close-quote (purecopy "''") "\
-*String inserted by typing \\[tex-insert-quote] to close a quotation.")
+String inserted by typing \\[tex-insert-quote] to close a quotation.")
(custom-autoload 'tex-close-quote "tex-mode" t)
@@ -27031,7 +27731,7 @@ Major mode to edit DocTeX files.
;;;***
;;;### (autoloads (texi2info texinfo-format-region texinfo-format-buffer)
-;;;;;; "texinfmt" "textmodes/texinfmt.el" (19636 58496))
+;;;;;; "texinfmt" "textmodes/texinfmt.el" (19673 38854))
;;; Generated autoloads from textmodes/texinfmt.el
(autoload 'texinfo-format-buffer "texinfmt" "\
@@ -27071,7 +27771,7 @@ if large. You can use `Info-split' to do this manually.
;;;***
;;;### (autoloads (texinfo-mode texinfo-close-quote texinfo-open-quote)
-;;;;;; "texinfo" "textmodes/texinfo.el" (19636 58496))
+;;;;;; "texinfo" "textmodes/texinfo.el" (19594 48841))
;;; Generated autoloads from textmodes/texinfo.el
(defvar texinfo-open-quote (purecopy "``") "\
@@ -27157,7 +27857,7 @@ value of `texinfo-mode-hook'.
;;;### (autoloads (thai-composition-function thai-compose-buffer
;;;;;; thai-compose-string thai-compose-region) "thai-util" "language/thai-util.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34921))
;;; Generated autoloads from language/thai-util.el
(autoload 'thai-compose-region "thai-util" "\
@@ -27186,7 +27886,7 @@ Not documented
;;;### (autoloads (list-at-point number-at-point symbol-at-point
;;;;;; sexp-at-point thing-at-point bounds-of-thing-at-point forward-thing)
-;;;;;; "thingatpt" "thingatpt.el" (19636 58496))
+;;;;;; "thingatpt" "thingatpt.el" (19277 34917))
;;; Generated autoloads from thingatpt.el
(autoload 'forward-thing "thingatpt" "\
@@ -27243,7 +27943,7 @@ Return the Lisp list at point, or nil if none is found.
;;;### (autoloads (thumbs-dired-setroot thumbs-dired-show thumbs-dired-show-marked
;;;;;; thumbs-show-from-dir thumbs-find-thumb) "thumbs" "thumbs.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34917))
;;; Generated autoloads from thumbs.el
(autoload 'thumbs-find-thumb "thumbs" "\
@@ -27281,8 +27981,8 @@ In dired, call the setroot program on the image at point.
;;;;;; tibetan-post-read-conversion tibetan-compose-buffer tibetan-decompose-buffer
;;;;;; tibetan-decompose-string tibetan-decompose-region tibetan-compose-region
;;;;;; tibetan-compose-string tibetan-transcription-to-tibetan tibetan-tibetan-to-transcription
-;;;;;; tibetan-char-p) "tibet-util" "language/tibet-util.el" (19636
-;;;;;; 58496))
+;;;;;; tibetan-char-p) "tibet-util" "language/tibet-util.el" (19277
+;;;;;; 34921))
;;; Generated autoloads from language/tibet-util.el
(autoload 'tibetan-char-p "tibet-util" "\
@@ -27356,7 +28056,7 @@ Not documented
;;;***
;;;### (autoloads (tildify-buffer tildify-region) "tildify" "textmodes/tildify.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34923))
;;; Generated autoloads from textmodes/tildify.el
(autoload 'tildify-region "tildify" "\
@@ -27381,7 +28081,7 @@ This function performs no refilling of the changed text.
;;;### (autoloads (emacs-init-time emacs-uptime display-time-world
;;;;;; display-time-mode display-time display-time-day-and-date)
-;;;;;; "time" "time.el" (19636 58496))
+;;;;;; "time" "time.el" (19623 51891))
;;; Generated autoloads from time.el
(defvar display-time-day-and-date nil "\
@@ -27444,7 +28144,7 @@ Return a string giving the duration of the Emacs initialization.
;;;;;; time-to-day-in-year date-leap-year-p days-between date-to-day
;;;;;; time-add time-subtract time-since days-to-time time-less-p
;;;;;; seconds-to-time date-to-time) "time-date" "calendar/time-date.el"
-;;;;;; (19636 58496))
+;;;;;; (19672 47874))
;;; Generated autoloads from calendar/time-date.el
(autoload 'date-to-time "time-date" "\
@@ -27452,8 +28152,9 @@ Parse a string DATE that represents a date-time and return a time value.
If DATE lacks timezone information, GMT is assumed.
\(fn DATE)" nil nil)
-(if (and (fboundp 'float-time)
- (subrp (symbol-function 'float-time)))
+(if (or (featurep 'emacs)
+ (and (fboundp 'float-time)
+ (subrp (symbol-function 'float-time))))
(progn
(defalias 'time-to-seconds 'float-time)
(make-obsolete 'time-to-seconds 'float-time "21.1"))
@@ -27465,7 +28166,7 @@ Convert SECONDS (a floating point number) to a time value.
\(fn SECONDS)" nil nil)
(autoload 'time-less-p "time-date" "\
-Say whether time value T1 is less than time value T2.
+Return non-nil if time value T1 is earlier than time value T2.
\(fn T1 T2)" nil nil)
@@ -27557,7 +28258,7 @@ This function does not work for SECONDS greater than `most-positive-fixnum'.
;;;***
;;;### (autoloads (time-stamp-toggle-active time-stamp) "time-stamp"
-;;;;;; "time-stamp.el" (19636 58496))
+;;;;;; "time-stamp.el" (19277 34917))
;;; Generated autoloads from time-stamp.el
(put 'time-stamp-format 'safe-local-variable 'stringp)
(put 'time-stamp-time-zone 'safe-local-variable 'string-or-null-p)
@@ -27601,7 +28302,7 @@ With ARG, turn time stamping on if and only if arg is positive.
;;;;;; timeclock-workday-remaining-string timeclock-reread-log timeclock-query-out
;;;;;; timeclock-change timeclock-status-string timeclock-out timeclock-in
;;;;;; timeclock-modeline-display) "timeclock" "calendar/timeclock.el"
-;;;;;; (19636 58496))
+;;;;;; (19674 6793))
;;; Generated autoloads from calendar/timeclock.el
(autoload 'timeclock-modeline-display "timeclock" "\
@@ -27701,7 +28402,7 @@ relative only to the time worked today, and not to past time.
;;;***
;;;### (autoloads (batch-titdic-convert titdic-convert) "titdic-cnv"
-;;;;;; "international/titdic-cnv.el" (19641 1152))
+;;;;;; "international/titdic-cnv.el" (19639 17158))
;;; Generated autoloads from international/titdic-cnv.el
(autoload 'titdic-convert "titdic-cnv" "\
@@ -27724,7 +28425,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\".
;;;***
;;;### (autoloads (tmm-prompt tmm-menubar-mouse tmm-menubar) "tmm"
-;;;;;; "tmm.el" (19636 58496))
+;;;;;; "tmm.el" (19406 15657))
;;; Generated autoloads from tmm.el
(define-key global-map "\M-`" 'tmm-menubar)
(define-key global-map [menu-bar mouse-1] 'tmm-menubar-mouse)
@@ -27764,7 +28465,7 @@ Its value should be an event that has a binding in MENU.
;;;### (autoloads (todo-show todo-cp todo-mode todo-print todo-top-priorities
;;;;;; todo-insert-item todo-add-item-non-interactively todo-add-category)
-;;;;;; "todo-mode" "calendar/todo-mode.el" (19636 58496))
+;;;;;; "todo-mode" "calendar/todo-mode.el" (19672 18325))
;;; Generated autoloads from calendar/todo-mode.el
(autoload 'todo-add-category "todo-mode" "\
@@ -27808,8 +28509,6 @@ Number of entries for each category is given by `todo-print-priorities'.
(autoload 'todo-mode "todo-mode" "\
Major mode for editing TODO lists.
-\\{todo-mode-map}
-
\(fn)" t nil)
(autoload 'todo-cp "todo-mode" "\
@@ -27826,7 +28525,7 @@ Show TODO list.
;;;### (autoloads (tool-bar-local-item-from-menu tool-bar-add-item-from-menu
;;;;;; tool-bar-local-item tool-bar-add-item toggle-tool-bar-mode-from-frame)
-;;;;;; "tool-bar" "tool-bar.el" (19636 58496))
+;;;;;; "tool-bar" "tool-bar.el" (19691 3508))
;;; Generated autoloads from tool-bar.el
(autoload 'toggle-tool-bar-mode-from-frame "tool-bar" "\
@@ -27835,8 +28534,6 @@ See `tool-bar-mode' for more information.
\(fn &optional ARG)" t nil)
-(put 'tool-bar-mode 'standard-value '(t))
-
(autoload 'tool-bar-add-item "tool-bar" "\
Add an item to the tool bar.
ICON names the image, DEF is the key definition and KEY is a symbol
@@ -27899,7 +28596,7 @@ holds a keymap.
;;;***
;;;### (autoloads (tpu-edt-on tpu-edt-mode) "tpu-edt" "emulation/tpu-edt.el"
-;;;;;; (19636 58496))
+;;;;;; (19674 8635))
;;; Generated autoloads from emulation/tpu-edt.el
(defvar tpu-edt-mode nil "\
@@ -27926,7 +28623,7 @@ Turn on TPU/edt emulation.
;;;***
;;;### (autoloads (tpu-mapper) "tpu-mapper" "emulation/tpu-mapper.el"
-;;;;;; (19636 58496))
+;;;;;; (19580 19536))
;;; Generated autoloads from emulation/tpu-mapper.el
(autoload 'tpu-mapper "tpu-mapper" "\
@@ -27960,7 +28657,7 @@ your local X guru can try to figure out why the key is being ignored.
;;;***
-;;;### (autoloads (tq-create) "tq" "emacs-lisp/tq.el" (19636 58496))
+;;;### (autoloads (tq-create) "tq" "emacs-lisp/tq.el" (19277 34919))
;;; Generated autoloads from emacs-lisp/tq.el
(autoload 'tq-create "tq" "\
@@ -27974,7 +28671,7 @@ to a tcp server on another machine.
;;;***
;;;### (autoloads (trace-function-background trace-function trace-buffer)
-;;;;;; "trace" "emacs-lisp/trace.el" (19636 58496))
+;;;;;; "trace" "emacs-lisp/trace.el" (19370 23595))
;;; Generated autoloads from emacs-lisp/trace.el
(defvar trace-buffer (purecopy "*trace-output*") "\
@@ -28011,7 +28708,7 @@ BUFFER defaults to `trace-buffer'.
;;;### (autoloads (tramp-unload-tramp tramp-completion-handle-file-name-completion
;;;;;; tramp-completion-handle-file-name-all-completions tramp-unload-file-name-handlers
;;;;;; tramp-file-name-handler tramp-syntax tramp-mode) "tramp"
-;;;;;; "net/tramp.el" (19672 43471))
+;;;;;; "net/tramp.el" (19691 3508))
;;; Generated autoloads from net/tramp.el
(defvar tramp-mode t "\
@@ -28097,9 +28794,9 @@ Also see `tramp-file-name-structure'.")
(defconst tramp-completion-file-name-handler-alist '((file-name-all-completions . tramp-completion-handle-file-name-all-completions) (file-name-completion . tramp-completion-handle-file-name-completion)) "\
Alist of completion handler functions.
-Used for file names matching `tramp-file-name-regexp'. Operations not
-mentioned here will be handled by `tramp-file-name-handler-alist' or the
-normal Emacs functions.")
+Used for file names matching `tramp-file-name-regexp'. Operations
+not mentioned here will be handled by Tramp's file name handler
+functions, or the normal Emacs functions.")
(defun tramp-run-real-handler (operation args) "\
Invoke normal file name handler for OPERATION.
@@ -28123,6 +28820,7 @@ Falls back to normal file name handler if no Tramp file name handler exists." (l
(defun tramp-register-file-name-handlers nil "\
Add Tramp file name handlers to `file-name-handler-alist'." (let ((a1 (rassq (quote tramp-file-name-handler) file-name-handler-alist))) (setq file-name-handler-alist (delq a1 file-name-handler-alist))) (let ((a1 (rassq (quote tramp-completion-file-name-handler) file-name-handler-alist))) (setq file-name-handler-alist (delq a1 file-name-handler-alist))) (add-to-list (quote file-name-handler-alist) (cons tramp-file-name-regexp (quote tramp-file-name-handler))) (put (quote tramp-file-name-handler) (quote safe-magic) t) (add-to-list (quote file-name-handler-alist) (cons tramp-completion-file-name-regexp (quote tramp-completion-file-name-handler))) (put (quote tramp-completion-file-name-handler) (quote safe-magic) t) (dolist (fnh (quote (epa-file-handler jka-compr-handler))) (let ((entry (rassoc fnh file-name-handler-alist))) (when entry (setq file-name-handler-alist (cons entry (delete entry file-name-handler-alist)))))))
+
(tramp-register-file-name-handlers)
(autoload 'tramp-unload-file-name-handlers "tramp" "\
@@ -28148,7 +28846,7 @@ Discard Tramp from loading remote files.
;;;***
;;;### (autoloads (tramp-ftp-enable-ange-ftp) "tramp-ftp" "net/tramp-ftp.el"
-;;;;;; (19636 58496))
+;;;;;; (19599 45674))
;;; Generated autoloads from net/tramp-ftp.el
(autoload 'tramp-ftp-enable-ange-ftp "tramp-ftp" "\
@@ -28158,8 +28856,8 @@ Not documented
;;;***
-;;;### (autoloads (help-with-tutorial) "tutorial" "tutorial.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (help-with-tutorial) "tutorial" "tutorial.el" (19580
+;;;;;; 19536))
;;; Generated autoloads from tutorial.el
(autoload 'help-with-tutorial "tutorial" "\
@@ -28184,7 +28882,7 @@ resumed later.
;;;***
;;;### (autoloads (tai-viet-composition-function) "tv-util" "language/tv-util.el"
-;;;;;; (19636 58496))
+;;;;;; (19515 27412))
;;; Generated autoloads from language/tv-util.el
(autoload 'tai-viet-composition-function "tv-util" "\
@@ -28195,7 +28893,7 @@ Not documented
;;;***
;;;### (autoloads (2C-split 2C-associate-buffer 2C-two-columns) "two-column"
-;;;;;; "textmodes/two-column.el" (19636 58496))
+;;;;;; "textmodes/two-column.el" (19609 2643))
;;; Generated autoloads from textmodes/two-column.el
(autoload '2C-command "two-column" () t 'keymap)
(global-set-key "\C-x6" '2C-command)
@@ -28246,7 +28944,7 @@ First column's text sSs Second column's text
;;;;;; type-break type-break-mode type-break-keystroke-threshold
;;;;;; type-break-good-break-interval type-break-good-rest-interval
;;;;;; type-break-interval type-break-mode) "type-break" "type-break.el"
-;;;;;; (19636 58496))
+;;;;;; (19668 18229))
;;; Generated autoloads from type-break.el
(defvar type-break-mode nil "\
@@ -28428,7 +29126,7 @@ FRAC should be the inverse of the fractional value; for example, a value of
;;;***
-;;;### (autoloads (uce-reply-to-uce) "uce" "mail/uce.el" (19636 58496))
+;;;### (autoloads (uce-reply-to-uce) "uce" "mail/uce.el" (19277 34921))
;;; Generated autoloads from mail/uce.el
(autoload 'uce-reply-to-uce "uce" "\
@@ -28446,7 +29144,7 @@ You might need to set `uce-mail-reader' before using this.
;;;;;; ucs-normalize-NFKC-string ucs-normalize-NFKC-region ucs-normalize-NFKD-string
;;;;;; ucs-normalize-NFKD-region ucs-normalize-NFC-string ucs-normalize-NFC-region
;;;;;; ucs-normalize-NFD-string ucs-normalize-NFD-region) "ucs-normalize"
-;;;;;; "international/ucs-normalize.el" (19636 58496))
+;;;;;; "international/ucs-normalize.el" (19600 6790))
;;; Generated autoloads from international/ucs-normalize.el
(autoload 'ucs-normalize-NFD-region "ucs-normalize" "\
@@ -28512,7 +29210,7 @@ Normalize the string STR by the Unicode NFC and Mac OS's HFS Plus.
;;;***
;;;### (autoloads (ununderline-region underline-region) "underline"
-;;;;;; "textmodes/underline.el" (19636 58496))
+;;;;;; "textmodes/underline.el" (19277 34923))
;;; Generated autoloads from textmodes/underline.el
(autoload 'underline-region "underline" "\
@@ -28533,7 +29231,7 @@ which specify the range to operate on.
;;;***
;;;### (autoloads (unrmail batch-unrmail) "unrmail" "mail/unrmail.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34921))
;;; Generated autoloads from mail/unrmail.el
(autoload 'batch-unrmail "unrmail" "\
@@ -28552,8 +29250,8 @@ Convert old-style Rmail Babyl file FILE to system inbox format file TO-FILE.
;;;***
-;;;### (autoloads (unsafep) "unsafep" "emacs-lisp/unsafep.el" (19652
-;;;;;; 24589))
+;;;### (autoloads (unsafep) "unsafep" "emacs-lisp/unsafep.el" (19645
+;;;;;; 60484))
;;; Generated autoloads from emacs-lisp/unsafep.el
(autoload 'unsafep "unsafep" "\
@@ -28566,7 +29264,7 @@ UNSAFEP-VARS is a list of symbols with local bindings.
;;;***
;;;### (autoloads (url-retrieve-synchronously url-retrieve) "url"
-;;;;;; "url/url.el" (19636 58496))
+;;;;;; "url/url.el" (19622 39471))
;;; Generated autoloads from url/url.el
(autoload 'url-retrieve "url" "\
@@ -28593,7 +29291,9 @@ The variables `url-request-data', `url-request-method' and
request; dynamic binding of other variables doesn't necessarily
take effect.
-\(fn URL CALLBACK &optional CBARGS)" nil nil)
+If SILENT, then don't message progress reports and the like.
+
+\(fn URL CALLBACK &optional CBARGS SILENT)" nil nil)
(autoload 'url-retrieve-synchronously "url" "\
Retrieve URL synchronously.
@@ -28606,7 +29306,7 @@ no further processing). URL is either a string or a parsed URL.
;;;***
;;;### (autoloads (url-register-auth-scheme url-get-authentication)
-;;;;;; "url-auth" "url/url-auth.el" (19636 58496))
+;;;;;; "url-auth" "url/url-auth.el" (19277 34923))
;;; Generated autoloads from url/url-auth.el
(autoload 'url-get-authentication "url-auth" "\
@@ -28647,9 +29347,8 @@ RATING a rating between 1 and 10 of the strength of the authentication.
;;;***
-;;;### (autoloads (url-cache-expired url-cache-extract url-is-cached
-;;;;;; url-store-in-cache) "url-cache" "url/url-cache.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (url-cache-extract url-is-cached url-store-in-cache)
+;;;;;; "url-cache" "url/url-cache.el" (19624 63510))
;;; Generated autoloads from url/url-cache.el
(autoload 'url-store-in-cache "url-cache" "\
@@ -28668,14 +29367,9 @@ Extract FNAM from the local disk cache.
\(fn FNAM)" nil nil)
-(autoload 'url-cache-expired "url-cache" "\
-Return t if a cached file has expired.
-
-\(fn URL MOD)" nil nil)
-
;;;***
-;;;### (autoloads (url-cid) "url-cid" "url/url-cid.el" (19636 58496))
+;;;### (autoloads (url-cid) "url-cid" "url/url-cid.el" (19277 34923))
;;; Generated autoloads from url/url-cid.el
(autoload 'url-cid "url-cid" "\
@@ -28686,7 +29380,7 @@ Not documented
;;;***
;;;### (autoloads (url-dav-vc-registered url-dav-supported-p) "url-dav"
-;;;;;; "url/url-dav.el" (19636 58496))
+;;;;;; "url/url-dav.el" (19277 34923))
;;; Generated autoloads from url/url-dav.el
(autoload 'url-dav-supported-p "url-dav" "\
@@ -28701,8 +29395,8 @@ Not documented
;;;***
-;;;### (autoloads (url-file) "url-file" "url/url-file.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (url-file) "url-file" "url/url-file.el" (19687
+;;;;;; 6902))
;;; Generated autoloads from url/url-file.el
(autoload 'url-file "url-file" "\
@@ -28713,7 +29407,7 @@ Handle file: and ftp: URLs.
;;;***
;;;### (autoloads (url-open-stream url-gateway-nslookup-host) "url-gw"
-;;;;;; "url/url-gw.el" (19636 58496))
+;;;;;; "url/url-gw.el" (19645 60484))
;;; Generated autoloads from url/url-gw.el
(autoload 'url-gateway-nslookup-host "url-gw" "\
@@ -28733,7 +29427,7 @@ Might do a non-blocking connection; use `process-status' to check.
;;;### (autoloads (url-insert-file-contents url-file-local-copy url-copy-file
;;;;;; url-file-handler url-handler-mode) "url-handlers" "url/url-handlers.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34923))
;;; Generated autoloads from url/url-handlers.el
(defvar url-handler-mode nil "\
@@ -28785,7 +29479,7 @@ Not documented
;;;***
;;;### (autoloads (url-http-options url-http-file-attributes url-http-file-exists-p
-;;;;;; url-http) "url-http" "url/url-http.el" (19636 58496))
+;;;;;; url-http) "url-http" "url/url-http.el" (19630 1041))
;;; Generated autoloads from url/url-http.el
(autoload 'url-http "url-http" "\
@@ -28851,7 +29545,7 @@ HTTPS retrievals are asynchronous.")
;;;***
-;;;### (autoloads (url-irc) "url-irc" "url/url-irc.el" (19636 58496))
+;;;### (autoloads (url-irc) "url-irc" "url/url-irc.el" (19594 47996))
;;; Generated autoloads from url/url-irc.el
(autoload 'url-irc "url-irc" "\
@@ -28861,8 +29555,8 @@ Not documented
;;;***
-;;;### (autoloads (url-ldap) "url-ldap" "url/url-ldap.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (url-ldap) "url-ldap" "url/url-ldap.el" (19277
+;;;;;; 34923))
;;; Generated autoloads from url/url-ldap.el
(autoload 'url-ldap "url-ldap" "\
@@ -28876,7 +29570,7 @@ URL can be a URL string, or a URL vector of the type returned by
;;;***
;;;### (autoloads (url-mailto url-mail) "url-mailto" "url/url-mailto.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34923))
;;; Generated autoloads from url/url-mailto.el
(autoload 'url-mail "url-mailto" "\
@@ -28892,7 +29586,7 @@ Handle the mailto: URL syntax.
;;;***
;;;### (autoloads (url-data url-generic-emulator-loader url-info
-;;;;;; url-man) "url-misc" "url/url-misc.el" (19636 58496))
+;;;;;; url-man) "url-misc" "url/url-misc.el" (19277 34923))
;;; Generated autoloads from url/url-misc.el
(autoload 'url-man "url-misc" "\
@@ -28924,7 +29618,7 @@ Fetch a data URL (RFC 2397).
;;;***
;;;### (autoloads (url-snews url-news) "url-news" "url/url-news.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34923))
;;; Generated autoloads from url/url-news.el
(autoload 'url-news "url-news" "\
@@ -28941,7 +29635,7 @@ Not documented
;;;### (autoloads (url-ns-user-pref url-ns-prefs isInNet isResolvable
;;;;;; dnsResolve dnsDomainIs isPlainHostName) "url-ns" "url/url-ns.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34923))
;;; Generated autoloads from url/url-ns.el
(autoload 'isPlainHostName "url-ns" "\
@@ -28982,7 +29676,7 @@ Not documented
;;;***
;;;### (autoloads (url-generic-parse-url url-recreate-url) "url-parse"
-;;;;;; "url/url-parse.el" (19636 58496))
+;;;;;; "url/url-parse.el" (19622 39471))
;;; Generated autoloads from url/url-parse.el
(autoload 'url-recreate-url "url-parse" "\
@@ -29000,7 +29694,7 @@ TYPE USER PASSWORD HOST PORTSPEC FILENAME TARGET ATTRIBUTES FULLNESS.
;;;***
;;;### (autoloads (url-setup-privacy-info) "url-privacy" "url/url-privacy.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34923))
;;; Generated autoloads from url/url-privacy.el
(autoload 'url-setup-privacy-info "url-privacy" "\
@@ -29016,11 +29710,11 @@ Setup variables that expose info about you and your system.
;;;;;; url-pretty-length url-strip-leading-spaces url-eat-trailing-space
;;;;;; url-get-normalized-date url-lazy-message url-normalize-url
;;;;;; url-insert-entities-in-string url-parse-args url-debug url-debug)
-;;;;;; "url-util" "url/url-util.el" (19636 58496))
+;;;;;; "url-util" "url/url-util.el" (19624 63510))
;;; Generated autoloads from url/url-util.el
(defvar url-debug nil "\
-*What types of debug messages from the URL library to show.
+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.
@@ -29152,7 +29846,7 @@ This uses `url-current-object', set locally to the buffer.
;;;***
;;;### (autoloads (ask-user-about-supersession-threat ask-user-about-lock)
-;;;;;; "userlock" "userlock.el" (19636 58496))
+;;;;;; "userlock" "userlock.el" (19277 34917))
;;; Generated autoloads from userlock.el
(autoload 'ask-user-about-lock "userlock" "\
@@ -29182,7 +29876,7 @@ The buffer in question is current when this function is called.
;;;### (autoloads (utf-7-imap-pre-write-conversion utf-7-pre-write-conversion
;;;;;; utf-7-imap-post-read-conversion utf-7-post-read-conversion)
-;;;;;; "utf-7" "international/utf-7.el" (19636 58496))
+;;;;;; "utf-7" "international/utf-7.el" (19451 17238))
;;; Generated autoloads from international/utf-7.el
(autoload 'utf-7-post-read-conversion "utf-7" "\
@@ -29207,9 +29901,19 @@ Not documented
;;;***
+;;;### (autoloads (utf7-encode) "utf7" "gnus/utf7.el" (19618 38629))
+;;; Generated autoloads from gnus/utf7.el
+
+(autoload 'utf7-encode "utf7" "\
+Encode UTF-7 STRING. Use IMAP modification if FOR-IMAP is non-nil.
+
+\(fn STRING &optional FOR-IMAP)" nil nil)
+
+;;;***
+
;;;### (autoloads (uudecode-decode-region uudecode-decode-region-internal
;;;;;; uudecode-decode-region-external) "uudecode" "mail/uudecode.el"
-;;;;;; (19636 58496))
+;;;;;; (19582 65302))
;;; Generated autoloads from mail/uudecode.el
(autoload 'uudecode-decode-region-external "uudecode" "\
@@ -29239,8 +29943,8 @@ If FILE-NAME is non-nil, save the result to FILE-NAME.
;;;;;; vc-print-log vc-retrieve-tag vc-create-tag vc-merge vc-insert-headers
;;;;;; vc-revision-other-window vc-root-diff vc-diff vc-version-diff
;;;;;; vc-register vc-next-action vc-before-checkin-hook vc-checkin-hook
-;;;;;; vc-checkout-hook) "vc" "vc.el" (19661 52732))
-;;; Generated autoloads from vc.el
+;;;;;; vc-checkout-hook) "vc" "vc/vc.el" (19693 26133))
+;;; Generated autoloads from vc/vc.el
(defvar vc-checkout-hook nil "\
Normal hook (list of functions) run after checking out a file.
@@ -29352,13 +30056,17 @@ the variable `vc-BACKEND-header'.
\(fn)" t nil)
(autoload 'vc-merge "vc" "\
-Merge changes between two revisions into the current buffer's file.
-This asks for two revisions to merge from in the minibuffer. If the
-first revision is a branch number, then merge all changes from that
-branch. If the first revision is empty, merge news, i.e. recent changes
-from the current branch.
+Perform a version control merge operation.
+On a distributed version control system, this runs a \"merge\"
+operation to incorporate changes from another branch onto the
+current branch, prompting for an argument list.
-See Info node `Merging'.
+On a non-distributed version control system, this merges changes
+between two revisions into the current fileset. This asks for
+two revisions to merge from in the minibuffer. If the first
+revision is a branch number, then merge all changes from that
+branch. If the first revision is empty, merge the most recent
+changes from the current branch.
\(fn)" t nil)
@@ -29430,13 +30138,20 @@ depending on the underlying version-control system.
(define-obsolete-function-alias 'vc-revert-buffer 'vc-revert "23.1")
(autoload 'vc-update "vc" "\
-Update the current fileset's files to their tip revisions.
-For each one that contains no changes, and is not locked, then this simply
-replaces the work file with the latest revision on its branch. If the file
-contains changes, and the backend supports merging news, then any recent
-changes from the current branch are merged into the working file.
+Update the current fileset or branch.
+On a distributed version control system, this runs a \"pull\"
+operation to update the current branch, prompting for an argument
+list if required. Optional prefix ARG forces a prompt.
-\(fn)" t nil)
+On a non-distributed version control system, update the current
+fileset to the tip revisions. For each unchanged and unlocked
+file, this simply replaces the work file with the latest revision
+on its branch. If the file contains changes, any changes in the
+tip revision are merged into the working file.
+
+\(fn &optional ARG)" t nil)
+
+(defalias 'vc-pull 'vc-update)
(autoload 'vc-switch-backend "vc" "\
Make BACKEND the current version control system for FILE.
@@ -29493,9 +30208,9 @@ Return the branch part of a revision number REV.
;;;***
-;;;### (autoloads (vc-annotate) "vc-annotate" "vc-annotate.el" (19636
-;;;;;; 58496))
-;;; Generated autoloads from vc-annotate.el
+;;;### (autoloads (vc-annotate) "vc-annotate" "vc/vc-annotate.el"
+;;;;;; (19580 19536))
+;;; Generated autoloads from vc/vc-annotate.el
(autoload 'vc-annotate "vc-annotate" "\
Display the edit history of the current FILE using colors.
@@ -29531,8 +30246,8 @@ mode-specific menu. `vc-annotate-color-map' and
;;;***
-;;;### (autoloads nil "vc-arch" "vc-arch.el" (19661 60124))
-;;; Generated autoloads from vc-arch.el
+;;;### (autoloads nil "vc-arch" "vc/vc-arch.el" (19662 23188))
+;;; Generated autoloads from vc/vc-arch.el
(defun vc-arch-registered (file)
(if (vc-find-root file "{arch}/=tagging-method")
(progn
@@ -29541,8 +30256,8 @@ mode-specific menu. `vc-annotate-color-map' and
;;;***
-;;;### (autoloads nil "vc-bzr" "vc-bzr.el" (19661 53001))
-;;; Generated autoloads from vc-bzr.el
+;;;### (autoloads nil "vc-bzr" "vc/vc-bzr.el" (19693 26133))
+;;; Generated autoloads from vc/vc-bzr.el
(defconst vc-bzr-admin-dirname ".bzr" "\
Name of the directory containing Bzr repository status files.")
@@ -29556,8 +30271,8 @@ Name of the directory containing Bzr repository status files.")
;;;***
-;;;### (autoloads nil "vc-cvs" "vc-cvs.el" (19661 60137))
-;;; Generated autoloads from vc-cvs.el
+;;;### (autoloads nil "vc-cvs" "vc/vc-cvs.el" (19662 23188))
+;;; Generated autoloads from vc/vc-cvs.el
(defun vc-cvs-registered (f)
(when (file-readable-p (expand-file-name
"CVS/Entries" (file-name-directory f)))
@@ -29566,8 +30281,8 @@ Name of the directory containing Bzr repository status files.")
;;;***
-;;;### (autoloads (vc-dir) "vc-dir" "vc-dir.el" (19661 53223))
-;;; Generated autoloads from vc-dir.el
+;;;### (autoloads (vc-dir) "vc-dir" "vc/vc-dir.el" (19580 19536))
+;;; Generated autoloads from vc/vc-dir.el
(autoload 'vc-dir "vc-dir" "\
Show the VC status for \"interesting\" files in and below DIR.
@@ -29590,9 +30305,9 @@ These are the commands available for use in the file status buffer:
;;;***
-;;;### (autoloads (vc-do-command) "vc-dispatcher" "vc-dispatcher.el"
-;;;;;; (19661 52495))
-;;; Generated autoloads from vc-dispatcher.el
+;;;### (autoloads (vc-do-command) "vc-dispatcher" "vc/vc-dispatcher.el"
+;;;;;; (19580 19536))
+;;; Generated autoloads from vc/vc-dispatcher.el
(autoload 'vc-do-command "vc-dispatcher" "\
Execute a slave command, notifying user and checking for errors.
@@ -29614,8 +30329,8 @@ case, and the process object in the asynchronous case.
;;;***
-;;;### (autoloads nil "vc-git" "vc-git.el" (19661 53398))
-;;; Generated autoloads from vc-git.el
+;;;### (autoloads nil "vc-git" "vc/vc-git.el" (19580 19536))
+;;; Generated autoloads from vc/vc-git.el
(defun vc-git-registered (file)
"Return non-nil if FILE is registered with git."
(if (vc-find-root file ".git") ; Short cut.
@@ -29625,8 +30340,8 @@ case, and the process object in the asynchronous case.
;;;***
-;;;### (autoloads nil "vc-hg" "vc-hg.el" (19661 52523))
-;;; Generated autoloads from vc-hg.el
+;;;### (autoloads nil "vc-hg" "vc/vc-hg.el" (19687 6902))
+;;; Generated autoloads from vc/vc-hg.el
(defun vc-hg-registered (file)
"Return non-nil if FILE is registered with hg."
(if (vc-find-root file ".hg") ; short cut
@@ -29636,8 +30351,8 @@ case, and the process object in the asynchronous case.
;;;***
-;;;### (autoloads nil "vc-mtn" "vc-mtn.el" (19672 43471))
-;;; Generated autoloads from vc-mtn.el
+;;;### (autoloads nil "vc-mtn" "vc/vc-mtn.el" (19673 45510))
+;;; Generated autoloads from vc/vc-mtn.el
(defconst vc-mtn-admin-dir "_MTN")
@@ -29650,9 +30365,9 @@ case, and the process object in the asynchronous case.
;;;***
-;;;### (autoloads (vc-rcs-master-templates) "vc-rcs" "vc-rcs.el"
-;;;;;; (19661 60165))
-;;; Generated autoloads from vc-rcs.el
+;;;### (autoloads (vc-rcs-master-templates) "vc-rcs" "vc/vc-rcs.el"
+;;;;;; (19662 23188))
+;;; Generated autoloads from vc/vc-rcs.el
(defvar vc-rcs-master-templates (purecopy '("%sRCS/%s,v" "%s%s,v" "%sRCS/%s")) "\
Where to look for RCS master files.
@@ -29664,9 +30379,9 @@ For a description of possible values, see `vc-check-master-templates'.")
;;;***
-;;;### (autoloads (vc-sccs-master-templates) "vc-sccs" "vc-sccs.el"
-;;;;;; (19661 60174))
-;;; Generated autoloads from vc-sccs.el
+;;;### (autoloads (vc-sccs-master-templates) "vc-sccs" "vc/vc-sccs.el"
+;;;;;; (19662 23188))
+;;; Generated autoloads from vc/vc-sccs.el
(defvar vc-sccs-master-templates (purecopy '("%sSCCS/s.%s" "%ss.%s" vc-sccs-search-project-dir)) "\
Where to look for SCCS master files.
@@ -29682,8 +30397,8 @@ find any project directory." (let ((project-dir (getenv "PROJECTDIR")) dirs dir)
;;;***
-;;;### (autoloads nil "vc-svn" "vc-svn.el" (19661 60185))
-;;; Generated autoloads from vc-svn.el
+;;;### (autoloads nil "vc-svn" "vc/vc-svn.el" (19631 26857))
+;;; Generated autoloads from vc/vc-svn.el
(defun vc-svn-registered (f)
(let ((admin-dir (cond ((and (eq system-type 'windows-nt)
(getenv "SVN_ASP_DOT_NET_HACK"))
@@ -29698,7 +30413,7 @@ find any project directory." (let ((project-dir (getenv "PROJECTDIR")) dirs dir)
;;;***
;;;### (autoloads (vera-mode) "vera-mode" "progmodes/vera-mode.el"
-;;;;;; (19636 58496))
+;;;;;; (19668 19680))
;;; Generated autoloads from progmodes/vera-mode.el
(add-to-list 'auto-mode-alist (cons (purecopy "\\.vr[hi]?\\'") 'vera-mode))
@@ -29756,7 +30471,7 @@ Key bindings:
;;;***
;;;### (autoloads (verilog-mode) "verilog-mode" "progmodes/verilog-mode.el"
-;;;;;; (19672 43471))
+;;;;;; (19673 45510))
;;; Generated autoloads from progmodes/verilog-mode.el
(autoload 'verilog-mode "verilog-mode" "\
@@ -29893,7 +30608,7 @@ Key bindings specific to `verilog-mode-map' are:
;;;***
;;;### (autoloads (vhdl-mode) "vhdl-mode" "progmodes/vhdl-mode.el"
-;;;;;; (19636 58496))
+;;;;;; (19672 56753))
;;; Generated autoloads from progmodes/vhdl-mode.el
(autoload 'vhdl-mode "vhdl-mode" "\
@@ -30434,7 +31149,7 @@ Key bindings:
;;;***
-;;;### (autoloads (vi-mode) "vi" "emulation/vi.el" (19636 58496))
+;;;### (autoloads (vi-mode) "vi" "emulation/vi.el" (19267 61660))
;;; Generated autoloads from emulation/vi.el
(autoload 'vi-mode "vi" "\
@@ -30489,7 +31204,7 @@ Syntax table and abbrevs while in vi mode remain as they were in Emacs.
;;;### (autoloads (viqr-pre-write-conversion viqr-post-read-conversion
;;;;;; viet-encode-viqr-buffer viet-encode-viqr-region viet-decode-viqr-buffer
;;;;;; viet-decode-viqr-region viet-encode-viscii-char) "viet-util"
-;;;;;; "language/viet-util.el" (19636 58496))
+;;;;;; "language/viet-util.el" (19277 34921))
;;; Generated autoloads from language/viet-util.el
(autoload 'viet-encode-viscii-char "viet-util" "\
@@ -30537,7 +31252,7 @@ Not documented
;;;;;; view-mode view-buffer-other-frame view-buffer-other-window
;;;;;; view-buffer view-file-other-frame view-file-other-window
;;;;;; view-file kill-buffer-if-not-modified view-remove-frame-by-deleting)
-;;;;;; "view" "view.el" (19636 58496))
+;;;;;; "view" "view.el" (19423 37200))
;;; Generated autoloads from view.el
(defvar view-remove-frame-by-deleting t "\
@@ -30783,8 +31498,8 @@ Exit View mode and make the current buffer editable.
;;;***
-;;;### (autoloads (vip-mode vip-setup) "vip" "emulation/vip.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (vip-mode vip-setup) "vip" "emulation/vip.el" (19609
+;;;;;; 2196))
;;; Generated autoloads from emulation/vip.el
(autoload 'vip-setup "vip" "\
@@ -30800,7 +31515,7 @@ Turn on VIP emulation of VI.
;;;***
;;;### (autoloads (viper-mode toggle-viper-mode) "viper" "emulation/viper.el"
-;;;;;; (19636 58496))
+;;;;;; (19580 19536))
;;; Generated autoloads from emulation/viper.el
(autoload 'toggle-viper-mode "viper" "\
@@ -30817,7 +31532,7 @@ Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'.
;;;***
;;;### (autoloads (warn lwarn display-warning) "warnings" "emacs-lisp/warnings.el"
-;;;;;; (19636 58496))
+;;;;;; (19607 38013))
;;; Generated autoloads from emacs-lisp/warnings.el
(defvar warning-prefix-function nil "\
@@ -30907,7 +31622,7 @@ this is equivalent to `display-warning', using
;;;***
;;;### (autoloads (wdired-change-to-wdired-mode) "wdired" "wdired.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34917))
;;; Generated autoloads from wdired.el
(autoload 'wdired-change-to-wdired-mode "wdired" "\
@@ -30923,7 +31638,7 @@ See `wdired-mode'.
;;;***
-;;;### (autoloads (webjump) "webjump" "net/webjump.el" (19636 58496))
+;;;### (autoloads (webjump) "webjump" "net/webjump.el" (19277 34921))
;;; Generated autoloads from net/webjump.el
(autoload 'webjump "webjump" "\
@@ -30940,7 +31655,7 @@ Please submit bug reports and other feedback to the author, Neil W. Van Dyke
;;;***
;;;### (autoloads (which-function-mode) "which-func" "progmodes/which-func.el"
-;;;;;; (19636 58496))
+;;;;;; (19552 37739))
;;; Generated autoloads from progmodes/which-func.el
(put 'which-func-format 'risky-local-variable t)
(put 'which-func-current 'risky-local-variable t)
@@ -30971,7 +31686,7 @@ and off otherwise.
;;;### (autoloads (whitespace-report-region whitespace-report whitespace-cleanup-region
;;;;;; whitespace-cleanup global-whitespace-toggle-options whitespace-toggle-options
;;;;;; global-whitespace-newline-mode global-whitespace-mode whitespace-newline-mode
-;;;;;; whitespace-mode) "whitespace" "whitespace.el" (19636 58496))
+;;;;;; whitespace-mode) "whitespace" "whitespace.el" (19580 19536))
;;; Generated autoloads from whitespace.el
(autoload 'whitespace-mode "whitespace" "\
@@ -31374,7 +32089,7 @@ cleaning up these problems.
;;;***
;;;### (autoloads (widget-minor-mode widget-browse-other-window widget-browse
-;;;;;; widget-browse-at) "wid-browse" "wid-browse.el" (19636 58496))
+;;;;;; widget-browse-at) "wid-browse" "wid-browse.el" (19580 19536))
;;; Generated autoloads from wid-browse.el
(autoload 'widget-browse-at "wid-browse" "\
@@ -31401,8 +32116,8 @@ With arg, turn widget mode on if and only if arg is positive.
;;;***
;;;### (autoloads (widget-setup widget-insert widget-delete widget-create
-;;;;;; widget-prompt-value widgetp) "wid-edit" "wid-edit.el" (19636
-;;;;;; 58496))
+;;;;;; widget-prompt-value widgetp) "wid-edit" "wid-edit.el" (19687
+;;;;;; 6902))
;;; Generated autoloads from wid-edit.el
(autoload 'widgetp "wid-edit" "\
@@ -31445,8 +32160,8 @@ Setup current buffer so editing string widgets works.
;;;***
;;;### (autoloads (windmove-default-keybindings windmove-down windmove-right
-;;;;;; windmove-up windmove-left) "windmove" "windmove.el" (19636
-;;;;;; 58496))
+;;;;;; windmove-up windmove-left) "windmove" "windmove.el" (19277
+;;;;;; 34917))
;;; Generated autoloads from windmove.el
(autoload 'windmove-left "windmove" "\
@@ -31499,7 +32214,7 @@ Default MODIFIER is 'shift.
;;;***
;;;### (autoloads (winner-mode winner-mode) "winner" "winner.el"
-;;;;;; (19636 58496))
+;;;;;; (19277 34917))
;;; Generated autoloads from winner.el
(defvar winner-mode nil "\
@@ -31517,8 +32232,8 @@ With arg, turn Winner mode on if and only if arg is positive.
;;;***
-;;;### (autoloads (woman-find-file woman-dired-find-file woman woman-locale)
-;;;;;; "woman" "woman.el" (19652 24589))
+;;;### (autoloads (woman-bookmark-jump woman-find-file woman-dired-find-file
+;;;;;; woman woman-locale) "woman" "woman.el" (19668 18093))
;;; Generated autoloads from woman.el
(defvar woman-locale nil "\
@@ -31559,10 +32274,15 @@ decompress the file if appropriate. See the documentation for the
\(fn FILE-NAME &optional REFORMAT)" t nil)
+(autoload 'woman-bookmark-jump "woman" "\
+Default bookmark handler for Woman buffers.
+
+\(fn BOOKMARK)" nil nil)
+
;;;***
;;;### (autoloads (wordstar-mode) "ws-mode" "emulation/ws-mode.el"
-;;;;;; (19636 58496))
+;;;;;; (19634 23255))
;;; Generated autoloads from emulation/ws-mode.el
(autoload 'wordstar-mode "ws-mode" "\
@@ -31674,7 +32394,7 @@ The key bindings are:
;;;***
-;;;### (autoloads (xesam-search) "xesam" "net/xesam.el" (19636 58496))
+;;;### (autoloads (xesam-search) "xesam" "net/xesam.el" (19360 14173))
;;; Generated autoloads from net/xesam.el
(autoload 'xesam-search "xesam" "\
@@ -31694,7 +32414,7 @@ Example:
;;;***
;;;### (autoloads (xml-parse-region xml-parse-file) "xml" "xml.el"
-;;;;;; (19636 58496))
+;;;;;; (19515 27412))
;;; Generated autoloads from xml.el
(autoload 'xml-parse-file "xml" "\
@@ -31720,7 +32440,7 @@ If PARSE-NS is non-nil, then QNAMES are expanded.
;;;***
;;;### (autoloads (xmltok-get-declared-encoding-position) "xmltok"
-;;;;;; "nxml/xmltok.el" (19636 58496))
+;;;;;; "nxml/xmltok.el" (19277 34921))
;;; Generated autoloads from nxml/xmltok.el
(autoload 'xmltok-get-declared-encoding-position "xmltok" "\
@@ -31738,8 +32458,8 @@ If LIMIT is non-nil, then do not consider characters beyond LIMIT.
;;;***
-;;;### (autoloads (xterm-mouse-mode) "xt-mouse" "xt-mouse.el" (19636
-;;;;;; 58496))
+;;;### (autoloads (xterm-mouse-mode) "xt-mouse" "xt-mouse.el" (19524
+;;;;;; 29717))
;;; Generated autoloads from xt-mouse.el
(defvar xterm-mouse-mode nil "\
@@ -31768,7 +32488,7 @@ down the SHIFT key while pressing the mouse button.
;;;***
;;;### (autoloads (yenc-extract-filename yenc-decode-region) "yenc"
-;;;;;; "gnus/yenc.el" (19636 58496))
+;;;;;; "gnus/yenc.el" (19582 65302))
;;; Generated autoloads from gnus/yenc.el
(autoload 'yenc-decode-region "yenc" "\
@@ -31784,7 +32504,7 @@ Extract file name from an yenc header.
;;;***
;;;### (autoloads (psychoanalyze-pinhead apropos-zippy insert-zippyism
-;;;;;; yow) "yow" "play/yow.el" (19636 58496))
+;;;;;; yow) "yow" "play/yow.el" (19277 34922))
;;; Generated autoloads from play/yow.el
(autoload 'yow "yow" "\
@@ -31810,7 +32530,7 @@ Zippy goes to the analyst.
;;;***
-;;;### (autoloads (zone) "zone" "play/zone.el" (19636 58496))
+;;;### (autoloads (zone) "zone" "play/zone.el" (19515 27412))
;;; Generated autoloads from play/zone.el
(autoload 'zone "zone" "\
@@ -31896,16 +32616,15 @@ Zone out, completely.
;;;;;; "cedet/srecode/srt-wy.el" "cedet/srecode/srt.el" "cedet/srecode/table.el"
;;;;;; "cedet/srecode/template.el" "cedet/srecode/texi.el" "cus-dep.el"
;;;;;; "dframe.el" "dired-aux.el" "dired-x.el" "dos-fns.el" "dos-vars.el"
-;;;;;; "dos-w32.el" "ediff-diff.el" "ediff-init.el" "ediff-merg.el"
-;;;;;; "ediff-ptch.el" "ediff-vers.el" "ediff-wind.el" "electric.el"
-;;;;;; "emacs-lisp/assoc.el" "emacs-lisp/authors.el" "emacs-lisp/avl-tree.el"
-;;;;;; "emacs-lisp/bindat.el" "emacs-lisp/byte-opt.el" "emacs-lisp/chart.el"
-;;;;;; "emacs-lisp/cl-extra.el" "emacs-lisp/cl-loaddefs.el" "emacs-lisp/cl-macs.el"
-;;;;;; "emacs-lisp/cl-seq.el" "emacs-lisp/cl-specs.el" "emacs-lisp/cust-print.el"
-;;;;;; "emacs-lisp/eieio-base.el" "emacs-lisp/eieio-comp.el" "emacs-lisp/eieio-custom.el"
-;;;;;; "emacs-lisp/eieio-datadebug.el" "emacs-lisp/eieio-opt.el"
-;;;;;; "emacs-lisp/eieio-speedbar.el" "emacs-lisp/eieio.el" "emacs-lisp/find-gc.el"
-;;;;;; "emacs-lisp/gulp.el" "emacs-lisp/lisp-mnt.el" "emacs-lisp/regi.el"
+;;;;;; "dos-w32.el" "dynamic-setting.el" "emacs-lisp/assoc.el" "emacs-lisp/authors.el"
+;;;;;; "emacs-lisp/avl-tree.el" "emacs-lisp/bindat.el" "emacs-lisp/byte-opt.el"
+;;;;;; "emacs-lisp/chart.el" "emacs-lisp/cl-extra.el" "emacs-lisp/cl-loaddefs.el"
+;;;;;; "emacs-lisp/cl-macs.el" "emacs-lisp/cl-seq.el" "emacs-lisp/cl-specs.el"
+;;;;;; "emacs-lisp/cust-print.el" "emacs-lisp/eieio-base.el" "emacs-lisp/eieio-comp.el"
+;;;;;; "emacs-lisp/eieio-custom.el" "emacs-lisp/eieio-datadebug.el"
+;;;;;; "emacs-lisp/eieio-opt.el" "emacs-lisp/eieio-speedbar.el"
+;;;;;; "emacs-lisp/eieio.el" "emacs-lisp/find-gc.el" "emacs-lisp/gulp.el"
+;;;;;; "emacs-lisp/lisp-mnt.el" "emacs-lisp/package-x.el" "emacs-lisp/regi.el"
;;;;;; "emacs-lisp/smie.el" "emacs-lisp/sregex.el" "emacs-lisp/tcover-ses.el"
;;;;;; "emacs-lisp/tcover-unsafep.el" "emacs-lock.el" "emulation/cua-gmrk.el"
;;;;;; "emulation/cua-rect.el" "emulation/edt-lk201.el" "emulation/edt-mapper.el"
@@ -31922,32 +32641,29 @@ Zone out, completely.
;;;;;; "eshell/esh-arg.el" "eshell/esh-cmd.el" "eshell/esh-ext.el"
;;;;;; "eshell/esh-io.el" "eshell/esh-module.el" "eshell/esh-opt.el"
;;;;;; "eshell/esh-proc.el" "eshell/esh-util.el" "eshell/esh-var.el"
-;;;;;; "ezimage.el" "foldout.el" "font-setting.el" "format-spec.el"
-;;;;;; "forms-d2.el" "forms-pass.el" "fringe.el" "generic-x.el"
-;;;;;; "gnus/auth-source.el" "gnus/compface.el" "gnus/gnus-async.el"
-;;;;;; "gnus/gnus-bcklg.el" "gnus/gnus-cite.el" "gnus/gnus-cus.el"
-;;;;;; "gnus/gnus-demon.el" "gnus/gnus-dup.el" "gnus/gnus-eform.el"
-;;;;;; "gnus/gnus-ems.el" "gnus/gnus-int.el" "gnus/gnus-logic.el"
-;;;;;; "gnus/gnus-mh.el" "gnus/gnus-salt.el" "gnus/gnus-score.el"
-;;;;;; "gnus/gnus-setup.el" "gnus/gnus-srvr.el" "gnus/gnus-sum.el"
-;;;;;; "gnus/gnus-topic.el" "gnus/gnus-undo.el" "gnus/gnus-util.el"
-;;;;;; "gnus/gnus-uu.el" "gnus/gnus-vm.el" "gnus/ietf-drums.el"
+;;;;;; "ezimage.el" "foldout.el" "format-spec.el" "forms-d2.el"
+;;;;;; "forms-pass.el" "fringe.el" "generic-x.el" "gnus/auth-source.el"
+;;;;;; "gnus/color.el" "gnus/compface.el" "gnus/gnus-async.el" "gnus/gnus-bcklg.el"
+;;;;;; "gnus/gnus-cite.el" "gnus/gnus-cus.el" "gnus/gnus-demon.el"
+;;;;;; "gnus/gnus-dup.el" "gnus/gnus-eform.el" "gnus/gnus-ems.el"
+;;;;;; "gnus/gnus-int.el" "gnus/gnus-logic.el" "gnus/gnus-mh.el"
+;;;;;; "gnus/gnus-salt.el" "gnus/gnus-score.el" "gnus/gnus-setup.el"
+;;;;;; "gnus/gnus-srvr.el" "gnus/gnus-topic.el" "gnus/gnus-undo.el"
+;;;;;; "gnus/gnus-util.el" "gnus/gnus-uu.el" "gnus/gnus-vm.el" "gnus/ietf-drums.el"
;;;;;; "gnus/legacy-gnus-agent.el" "gnus/mail-parse.el" "gnus/mail-prsvr.el"
;;;;;; "gnus/mail-source.el" "gnus/mailcap.el" "gnus/messcompat.el"
;;;;;; "gnus/mm-bodies.el" "gnus/mm-decode.el" "gnus/mm-encode.el"
;;;;;; "gnus/mm-util.el" "gnus/mm-view.el" "gnus/mml-sec.el" "gnus/mml-smime.el"
-;;;;;; "gnus/mml.el" "gnus/nnagent.el" "gnus/nnbabyl.el" "gnus/nndb.el"
-;;;;;; "gnus/nndir.el" "gnus/nndraft.el" "gnus/nneething.el" "gnus/nngateway.el"
-;;;;;; "gnus/nnheader.el" "gnus/nnimap.el" "gnus/nnir.el" "gnus/nnlistserv.el"
-;;;;;; "gnus/nnmail.el" "gnus/nnmaildir.el" "gnus/nnmairix.el" "gnus/nnmbox.el"
-;;;;;; "gnus/nnmh.el" "gnus/nnnil.el" "gnus/nnoo.el" "gnus/nnrss.el"
-;;;;;; "gnus/nnslashdot.el" "gnus/nnspool.el" "gnus/nntp.el" "gnus/nnultimate.el"
-;;;;;; "gnus/nnvirtual.el" "gnus/nnwarchive.el" "gnus/nnweb.el"
-;;;;;; "gnus/nnwfm.el" "gnus/pop3.el" "gnus/rfc1843.el" "gnus/rfc2045.el"
-;;;;;; "gnus/rfc2047.el" "gnus/rfc2104.el" "gnus/rfc2231.el" "gnus/sieve-manage.el"
-;;;;;; "gnus/smime.el" "gnus/spam-stat.el" "gnus/spam-wash.el" "gnus/starttls.el"
-;;;;;; "gnus/utf7.el" "gnus/webmail.el" "hex-util.el" "hfy-cmap.el"
-;;;;;; "ibuf-ext.el" "international/charprop.el" "international/cp51932.el"
+;;;;;; "gnus/mml.el" "gnus/nnagent.el" "gnus/nnbabyl.el" "gnus/nndir.el"
+;;;;;; "gnus/nndraft.el" "gnus/nneething.el" "gnus/nngateway.el"
+;;;;;; "gnus/nnheader.el" "gnus/nnimap.el" "gnus/nnir.el" "gnus/nnmail.el"
+;;;;;; "gnus/nnmaildir.el" "gnus/nnmairix.el" "gnus/nnmbox.el" "gnus/nnmh.el"
+;;;;;; "gnus/nnnil.el" "gnus/nnoo.el" "gnus/nnregistry.el" "gnus/nnrss.el"
+;;;;;; "gnus/nnspool.el" "gnus/nntp.el" "gnus/nnvirtual.el" "gnus/nnweb.el"
+;;;;;; "gnus/rfc1843.el" "gnus/rfc2045.el" "gnus/rfc2047.el" "gnus/rfc2104.el"
+;;;;;; "gnus/rfc2231.el" "gnus/shr-color.el" "gnus/sieve-manage.el"
+;;;;;; "gnus/smime.el" "gnus/spam-stat.el" "gnus/spam-wash.el" "hex-util.el"
+;;;;;; "hfy-cmap.el" "ibuf-ext.el" "international/charprop.el" "international/cp51932.el"
;;;;;; "international/eucjp-ms.el" "international/fontset.el" "international/iso-ascii.el"
;;;;;; "international/ja-dic-cnv.el" "international/ja-dic-utl.el"
;;;;;; "international/ogonek.el" "international/uni-bidi.el" "international/uni-category.el"
@@ -31972,27 +32688,37 @@ Zone out, completely.
;;;;;; "mh-e/mh-utils.el" "mh-e/mh-xface.el" "mouse-copy.el" "mouse.el"
;;;;;; "mwheel.el" "net/dns.el" "net/eudc-vars.el" "net/eudcb-bbdb.el"
;;;;;; "net/eudcb-ldap.el" "net/eudcb-mab.el" "net/eudcb-ph.el"
-;;;;;; "net/hmac-def.el" "net/hmac-md5.el" "net/imap-hash.el" "net/imap.el"
-;;;;;; "net/ldap.el" "net/mairix.el" "net/netrc.el" "net/newsticker.el"
+;;;;;; "net/gnutls.el" "net/hmac-def.el" "net/hmac-md5.el" "net/imap-hash.el"
+;;;;;; "net/imap.el" "net/ldap.el" "net/mairix.el" "net/newsticker.el"
;;;;;; "net/ntlm.el" "net/sasl-cram.el" "net/sasl-digest.el" "net/sasl-ntlm.el"
;;;;;; "net/sasl.el" "net/socks.el" "net/tls.el" "net/tramp-cache.el"
-;;;;;; "net/tramp-cmds.el" "net/tramp-compat.el" "net/tramp-fish.el"
-;;;;;; "net/tramp-gvfs.el" "net/tramp-gw.el" "net/tramp-imap.el"
-;;;;;; "net/tramp-smb.el" "net/tramp-uu.el" "net/trampver.el" "net/zeroconf.el"
-;;;;;; "nxml/nxml-enc.el" "nxml/nxml-maint.el" "nxml/nxml-ns.el"
-;;;;;; "nxml/nxml-outln.el" "nxml/nxml-parse.el" "nxml/nxml-rap.el"
-;;;;;; "nxml/nxml-util.el" "nxml/rng-dt.el" "nxml/rng-loc.el" "nxml/rng-maint.el"
-;;;;;; "nxml/rng-match.el" "nxml/rng-parse.el" "nxml/rng-pttrn.el"
-;;;;;; "nxml/rng-uri.el" "nxml/rng-util.el" "nxml/xsd-regexp.el"
-;;;;;; "org/org-bibtex.el" "org/org-colview.el" "org/org-compat.el"
-;;;;;; "org/org-crypt.el" "org/org-datetree.el" "org/org-exp-blocks.el"
-;;;;;; "org/org-faces.el" "org/org-gnus.el" "org/org-habit.el" "org/org-info.el"
-;;;;;; "org/org-inlinetask.el" "org/org-install.el" "org/org-jsinfo.el"
-;;;;;; "org/org-list.el" "org/org-mac-message.el" "org/org-macs.el"
-;;;;;; "org/org-mew.el" "org/org-mhe.el" "org/org-mouse.el" "org/org-protocol.el"
+;;;;;; "net/tramp-cmds.el" "net/tramp-compat.el" "net/tramp-gvfs.el"
+;;;;;; "net/tramp-gw.el" "net/tramp-imap.el" "net/tramp-loaddefs.el"
+;;;;;; "net/tramp-sh.el" "net/tramp-smb.el" "net/tramp-uu.el" "net/trampver.el"
+;;;;;; "net/zeroconf.el" "notifications.el" "nxml/nxml-enc.el" "nxml/nxml-maint.el"
+;;;;;; "nxml/nxml-ns.el" "nxml/nxml-outln.el" "nxml/nxml-parse.el"
+;;;;;; "nxml/nxml-rap.el" "nxml/nxml-util.el" "nxml/rng-dt.el" "nxml/rng-loc.el"
+;;;;;; "nxml/rng-maint.el" "nxml/rng-match.el" "nxml/rng-parse.el"
+;;;;;; "nxml/rng-pttrn.el" "nxml/rng-uri.el" "nxml/rng-util.el"
+;;;;;; "nxml/xsd-regexp.el" "org/ob-C.el" "org/ob-R.el" "org/ob-asymptote.el"
+;;;;;; "org/ob-calc.el" "org/ob-clojure.el" "org/ob-comint.el" "org/ob-css.el"
+;;;;;; "org/ob-ditaa.el" "org/ob-dot.el" "org/ob-emacs-lisp.el"
+;;;;;; "org/ob-eval.el" "org/ob-exp.el" "org/ob-gnuplot.el" "org/ob-haskell.el"
+;;;;;; "org/ob-js.el" "org/ob-latex.el" "org/ob-ledger.el" "org/ob-lisp.el"
+;;;;;; "org/ob-matlab.el" "org/ob-mscgen.el" "org/ob-ocaml.el" "org/ob-octave.el"
+;;;;;; "org/ob-org.el" "org/ob-perl.el" "org/ob-plantuml.el" "org/ob-python.el"
+;;;;;; "org/ob-ref.el" "org/ob-ruby.el" "org/ob-sass.el" "org/ob-scheme.el"
+;;;;;; "org/ob-screen.el" "org/ob-sh.el" "org/ob-sql.el" "org/ob-sqlite.el"
+;;;;;; "org/ob-table.el" "org/org-beamer.el" "org/org-bibtex.el"
+;;;;;; "org/org-colview.el" "org/org-compat.el" "org/org-crypt.el"
+;;;;;; "org/org-ctags.el" "org/org-docview.el" "org/org-entities.el"
+;;;;;; "org/org-exp-blocks.el" "org/org-faces.el" "org/org-gnus.el"
+;;;;;; "org/org-habit.el" "org/org-info.el" "org/org-inlinetask.el"
+;;;;;; "org/org-install.el" "org/org-jsinfo.el" "org/org-list.el"
+;;;;;; "org/org-mac-message.el" "org/org-macs.el" "org/org-mew.el"
+;;;;;; "org/org-mhe.el" "org/org-mks.el" "org/org-mouse.el" "org/org-protocol.el"
;;;;;; "org/org-rmail.el" "org/org-src.el" "org/org-vm.el" "org/org-w3m.el"
-;;;;;; "org/org-wl.el" "password-cache.el" "patcomp.el" "pcvs-info.el"
-;;;;;; "pcvs-parse.el" "pcvs-util.el" "pgg-def.el" "pgg-parse.el"
+;;;;;; "org/org-wl.el" "patcomp.el" "pgg-def.el" "pgg-parse.el"
;;;;;; "pgg-pgp.el" "pgg-pgp5.el" "play/gamegrid.el" "play/gametree.el"
;;;;;; "play/meese.el" "progmodes/ada-prj.el" "progmodes/cc-align.el"
;;;;;; "progmodes/cc-awk.el" "progmodes/cc-bytecomp.el" "progmodes/cc-cmds.el"
@@ -32002,8 +32728,8 @@ Zone out, completely.
;;;;;; "progmodes/ebnf-otz.el" "progmodes/ebnf-yac.el" "progmodes/idlw-complete-structtag.el"
;;;;;; "progmodes/idlw-help.el" "progmodes/idlw-toolbar.el" "progmodes/mantemp.el"
;;;;;; "progmodes/xscheme.el" "ps-def.el" "ps-mule.el" "ps-samp.el"
-;;;;;; "s-region.el" "saveplace.el" "sb-image.el" "scroll-bar.el"
-;;;;;; "select.el" "soundex.el" "subdirs.el" "tempo.el" "textmodes/bib-mode.el"
+;;;;;; "saveplace.el" "sb-image.el" "scroll-bar.el" "select.el"
+;;;;;; "soundex.el" "subdirs.el" "tempo.el" "textmodes/bib-mode.el"
;;;;;; "textmodes/makeinfo.el" "textmodes/page-ext.el" "textmodes/refbib.el"
;;;;;; "textmodes/refer.el" "textmodes/reftex-auc.el" "textmodes/reftex-dcr.el"
;;;;;; "textmodes/reftex-ref.el" "textmodes/reftex-sel.el" "textmodes/reftex-toc.el"
@@ -32011,13 +32737,14 @@ Zone out, completely.
;;;;;; "uniquify.el" "url/url-about.el" "url/url-cookie.el" "url/url-dired.el"
;;;;;; "url/url-expand.el" "url/url-ftp.el" "url/url-history.el"
;;;;;; "url/url-imap.el" "url/url-methods.el" "url/url-nfs.el" "url/url-proxy.el"
-;;;;;; "url/url-vars.el" "vc-dav.el" "vcursor.el" "vt-control.el"
-;;;;;; "vt100-led.el" "w32-fns.el" "w32-vars.el" "x-dnd.el") (19672
-;;;;;; 46342 903499))
+;;;;;; "url/url-vars.el" "vc/ediff-diff.el" "vc/ediff-init.el" "vc/ediff-merg.el"
+;;;;;; "vc/ediff-ptch.el" "vc/ediff-vers.el" "vc/ediff-wind.el"
+;;;;;; "vc/pcvs-info.el" "vc/pcvs-parse.el" "vc/pcvs-util.el" "vc/vc-dav.el"
+;;;;;; "vcursor.el" "vt-control.el" "vt100-led.el" "w32-fns.el"
+;;;;;; "w32-vars.el" "x-dnd.el") (19696 28874 906463))
;;;***
-(provide 'loaddefs)
;; Local Variables:
;; version-control: never
;; no-byte-compile: t
diff --git a/lisp/linum.el b/lisp/linum.el
index 3d70c254775..4ab4b10a7c9 100644
--- a/lisp/linum.el
+++ b/lisp/linum.el
@@ -5,6 +5,7 @@
;; Author: Markus Triska <markus.triska@gmx.at>
;; Maintainer: FSF
;; Keywords: convenience
+;; Version: 0.9x
;; This file is part of GNU Emacs.
diff --git a/lisp/loadup.el b/lisp/loadup.el
index 85222ce7d9e..d13e38c0b36 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -5,6 +5,7 @@
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -54,7 +55,7 @@
(equal (nth 3 command-line-args) "unidata-gen.el")
(equal (nth 4 command-line-args) "unidata-gen-files")
;; In case CANNOT_DUMP.
- (equal (nth 0 command-line-args) "../src/bootstrap-emacs"))
+ (string-match "src/bootstrap-emacs" (nth 0 command-line-args)))
(let ((dir (car load-path)))
;; We'll probably overflow the pure space.
(setq purify-flag nil)
@@ -64,6 +65,10 @@
(expand-file-name "international" dir)
(expand-file-name "textmodes" dir)))))
+(if (eq t purify-flag)
+ ;; Hash consing saved around 11% of pure space in my tests.
+ (setq purify-flag (make-hash-table :test 'equal)))
+
(message "Using load-path %s" load-path)
(if (or (member (nth 3 command-line-args) '("dump" "bootstrap"))
@@ -199,8 +204,8 @@
(load "dnd")
(load "tool-bar")))
-(if (or (featurep 'system-font-setting) (featurep 'font-render-setting))
- (load "font-setting"))
+(if (featurep 'dynamic-setting)
+ (load "dynamic-setting"))
(if (featurep 'x)
(progn
@@ -229,18 +234,17 @@
(load "disp-table"))) ; needed to setup ibm-pc char set, see internal.el
(if (featurep 'ns)
(progn
- (load "emacs-lisp/easymenu") ;; for platform-related menu adjustments
+ (load "term/common-win")
(load "term/ns-win")))
(if (fboundp 'x-create-frame)
;; Do it after loading term/foo-win.el since the value of the
;; mouse-wheel-*-event vars depends on those files being loaded or not.
(load "mwheel"))
-(if (fboundp 'atan) ; preload some constants and
- (progn ; floating pt. functions if we have float support.
- (load "emacs-lisp/float-sup")))
+;; Preload some constants and floating point functions.
+(load "emacs-lisp/float-sup")
-(load "vc-hooks")
-(load "ediff-hook")
+(load "vc/vc-hooks")
+(load "vc/ediff-hook")
(if (fboundp 'x-show-tip) (load "tooltip"))
;If you want additional libraries to be preloaded and their
@@ -345,6 +349,10 @@
;; At this point, we're ready to resume undo recording for scratch.
(buffer-enable-undo "*scratch*")
+;; Avoid error if user loads some more libraries now and make sure the
+;; hash-consing hash table is GC'd.
+(setq purify-flag nil)
+
(if (null (garbage-collect))
(setq pure-space-overflow t))
@@ -378,9 +386,6 @@
(add-name-to-file "emacs" name t)))
(kill-emacs)))
-;; Avoid error if user loads some more libraries now.
-(setq purify-flag nil)
-
;; For machines with CANNOT_DUMP defined in config.h,
;; this file must be loaded each time Emacs is run.
;; So run the startup code now. First, remove `-l loadup' from args.
@@ -397,5 +402,4 @@
;; no-update-autoloads: t
;; End:
-;; arch-tag: 121e1dd4-36e1-45ac-860e-239f577a6335
;;; loadup.el ends here
diff --git a/lisp/locate.el b/lisp/locate.el
index d5caf8615cd..4c4312b9598 100644
--- a/lisp/locate.el
+++ b/lisp/locate.el
@@ -97,7 +97,7 @@
;; (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)))
+;; (memq system-type '(windows-nt ms-dos)))
;; (ad-set-arg 2 t)
;; ))
;;
@@ -335,7 +335,7 @@ then `locate-post-command-hook'."
(locate-do-setup search-string)))
(and (not (string-equal (buffer-name) locate-buffer-name))
- (switch-to-buffer-other-window locate-buffer-name))
+ (pop-to-buffer locate-buffer-name))
(run-hooks 'dired-mode-hook)
(dired-next-line 3) ;move to first matching file.
diff --git a/lisp/lpr.el b/lisp/lpr.el
index 812db4c2630..3b91172a7ef 100644
--- a/lisp/lpr.el
+++ b/lisp/lpr.el
@@ -301,7 +301,7 @@ The characters tab, linefeed, space, return and formfeed are not affected."
(let (c)
(while (re-search-forward "[\^@-\^h\^k\^n-\^_\177-\377]" nil t)
(setq c (preceding-char))
- (delete-backward-char 1)
+ (delete-char -1)
(insert (if (< c ?\s)
(format "\\^%c" (+ c ?@))
(format "\\%02x" c))))))))
diff --git a/lisp/ls-lisp.el b/lisp/ls-lisp.el
index c7023add59b..58ed6685dc2 100644
--- a/lisp/ls-lisp.el
+++ b/lisp/ls-lisp.el
@@ -1,12 +1,13 @@
;;; ls-lisp.el --- emulate insert-directory completely in Emacs Lisp
-;; Copyright (C) 1992, 1994, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 1994, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Sebastian Kremer <sk@thp.uni-koeln.de>
;; Modified by: Francis J. Wright <F.J.Wright@maths.qmw.ac.uk>
;; Maintainer: FSF
;; Keywords: unix, dired
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -69,21 +70,37 @@
:version "21.1"
:group 'dired)
+(defun ls-lisp-set-options ()
+ "Reset the ls-lisp options that depend on `ls-lisp-emulation'."
+ (mapc 'custom-reevaluate-setting
+ '(ls-lisp-ignore-case ls-lisp-dirs-first ls-lisp-verbosity)))
+
(defcustom ls-lisp-emulation
(cond ;; ((eq system-type 'windows-nt) 'MS-Windows)
- ((memq system-type
- '(hpux usg-unix-v irix berkeley-unix))
- 'UNIX)) ; very similar to GNU
+ ((memq system-type '(hpux usg-unix-v irix berkeley-unix))
+ 'UNIX)) ; very similar to GNU
;; Anything else defaults to nil, meaning GNU.
"Platform to emulate: GNU (default), MacOS, MS-Windows, UNIX.
-Corresponding value is one of the atoms: nil, MacOS, MS-Windows, UNIX.
-Sets default values for: `ls-lisp-ignore-case', `ls-lisp-dirs-first',
-`ls-lisp-verbosity'. Need not match actual platform. Changing this
-option will have no effect until you restart Emacs."
+Corresponding value is one of: nil, `MacOS', `MS-Windows', `UNIX'.
+Set this to your preferred value; it need not match the actual platform
+you are using.
+
+This variable does not affect the behavior of ls-lisp directly.
+Rather, it controls the default values for some variables that do:
+`ls-lisp-ignore-case', `ls-lisp-dirs-first', and `ls-lisp-verbosity'.
+
+If you change this variable directly (without using customize)
+after loading `ls-lisp', you should use `ls-lisp-set-options' to
+update the dependent variables."
:type '(choice (const :tag "GNU" nil)
(const MacOS)
(const MS-Windows)
(const UNIX))
+ :initialize 'custom-initialize-default
+ :set (lambda (symbol value)
+ (unless (equal value (eval symbol))
+ (custom-set-default symbol value)
+ (ls-lisp-set-options)))
:group 'ls-lisp)
;; Only made an obsolete alias in 23.3. Before that, the initial
@@ -97,6 +114,7 @@ option will have no effect until you restart Emacs."
(defcustom ls-lisp-ignore-case
(memq ls-lisp-emulation '(MS-Windows MacOS))
"Non-nil causes ls-lisp alphabetic sorting to ignore case."
+ :set-after '(ls-lisp-emulation)
:type 'boolean
:group 'ls-lisp)
@@ -104,6 +122,7 @@ option will have no effect until you restart Emacs."
"Non-nil causes ls-lisp to sort directories first in any ordering.
\(Or last if it is reversed.) Follows Microsoft Windows Explorer."
;; Functionality suggested by Chris McMahan <cmcmahan@one.net>
+ :set-after '(ls-lisp-emulation)
:type 'boolean
:group 'ls-lisp)
@@ -119,14 +138,15 @@ It should contain none or more of the symbols: links, uid, gid.
A value of nil (or an empty list) means display none of them.
Concepts come from UNIX: `links' means count of names associated with
-the file\; `uid' means user (owner) identifier\; `gid' means group
+the file; `uid' means user (owner) identifier; `gid' means group
identifier.
-If emulation is MacOS then default is nil\;
+If emulation is MacOS then default is nil;
if emulation is MS-Windows then default is `(links)' if platform is
-Windows NT/2K, nil otherwise\;
-if emulation is UNIX then default is `(links uid)'\;
+Windows NT/2K, nil otherwise;
+if emulation is UNIX then default is `(links uid)';
if emulation is GNU then default is `(links uid gid)'."
+ :set-after '(ls-lisp-emulation)
;; Functionality suggested by Howard Melman <howard@silverstream.com>
:type '(set (const :tag "Show Link Count" links)
(const :tag "Show User" uid)
@@ -162,7 +182,7 @@ regardless of whether the locale can be determined.
Syntax: (EARLY-TIME-FORMAT OLD-TIME-FORMAT)
The EARLY-TIME-FORMAT is used if file has been modified within the
-current year. The OLD-TIME-FORMAT is used for older files. To use ISO
+current year. The OLD-TIME-FORMAT is used for older files. To use ISO
8601 dates, you could set:
\(setq ls-lisp-format-time-list
@@ -173,11 +193,11 @@ current year. The OLD-TIME-FORMAT is used for older files. To use ISO
:group 'ls-lisp)
(defcustom ls-lisp-use-localized-time-format nil
- "Non-nil causes ls-lisp to use `ls-lisp-format-time-list' even if
-a valid locale is specified.
+ "Non-nil means to always use `ls-lisp-format-time-list' for time stamps.
+This applies even if a valid locale is specified.
WARNING: Using localized date/time format might cause Dired columns
-to fail to lign up, e.g. if month names are not all of the same length."
+to fail to line up, e.g. if month names are not all of the same length."
:type 'boolean
:group 'ls-lisp)
@@ -307,7 +327,6 @@ not contain `d', so that a full listing is expected."
(if (memq ?n switches)
'integer
'string)))
- (now (current-time))
(sum 0)
(max-uid-len 0)
(max-gid-len 0)
@@ -378,7 +397,7 @@ not contain `d', so that a full listing is expected."
sum
(float sum))))
(insert (ls-lisp-format short attr file-size
- switches time-index now))))
+ switches time-index))))
;; Insert total size of all files:
(save-excursion
(goto-char (car total-line))
@@ -417,7 +436,7 @@ not contain `d', so that a full listing is expected."
(ls-lisp-classify-file file fattr)
file)
fattr (nth 7 fattr)
- switches time-index (current-time)))
+ switches time-index))
(message "%s: doesn't exist or is inaccessible" file)
(ding) (sit-for 2))))) ; to show user the message!
@@ -491,8 +510,8 @@ SWITCHES is a list of characters. Default sorting is alphabetic."
(nth 7 (cdr x)))))
((setq index (ls-lisp-time-index switches))
(lambda (x y) ; sorted on time
- (ls-lisp-time-lessp (nth index (cdr y))
- (nth index (cdr x)))))
+ (time-less-p (nth index (cdr y))
+ (nth index (cdr x)))))
((memq ?X switches)
(lambda (x y) ; sorted on extension
(ls-lisp-string-lessp
@@ -590,18 +609,10 @@ FOLLOWED by null and full filename, SOLELY for full alpha sort."
(substring filename (1+ i) end))))
)) "\0" filename))
-;; From Roland McGrath. Can use this to sort on time.
-(defun ls-lisp-time-lessp (time0 time1)
- "Return t if time TIME0 is earlier than time TIME1."
- (let ((hi0 (car time0)) (hi1 (car time1)))
- (or (< hi0 hi1)
- (and (= hi0 hi1)
- (< (cadr time0) (cadr time1))))))
-
-(defun ls-lisp-format (file-name file-attr file-size switches time-index now)
+(defun ls-lisp-format (file-name file-attr file-size switches time-index)
"Format one line of long ls output for file FILE-NAME.
FILE-ATTR and FILE-SIZE give the file's attributes and size.
-SWITCHES, TIME-INDEX and NOW give the full switch list and time data."
+SWITCHES and TIME-INDEX give the full switch list and time data."
(let ((file-type (nth 0 file-attr))
;; t for directory, string (name linked to)
;; for symbolic link, or nil.
@@ -659,7 +670,7 @@ SWITCHES, TIME-INDEX and NOW give the full switch list and time data."
gid))))
(ls-lisp-format-file-size file-size (memq ?h switches))
" "
- (ls-lisp-format-time file-attr time-index now)
+ (ls-lisp-format-time file-attr time-index)
" "
(if (not (memq ?F switches)) ; ls-lisp-classify already did that
(propertize file-name 'dired-filename t)
@@ -677,20 +688,13 @@ Return nil if no time switch found."
((memq ?t switches) 5) ; last modtime
((memq ?u switches) 4))) ; last access
-(defun ls-lisp-time-to-seconds (time)
- "Convert TIME to a floating point number."
- (+ (* (car time) 65536.0)
- (cadr time)
- (/ (or (nth 2 time) 0) 1000000.0)))
-
-(defun ls-lisp-format-time (file-attr time-index now)
+(defun ls-lisp-format-time (file-attr time-index)
"Format time for file with attributes FILE-ATTR according to TIME-INDEX.
Use the same method as ls to decide whether to show time-of-day or year,
-depending on distance between file date and NOW.
+depending on distance between file date and the current time.
All ls time options, namely c, t and u, are handled."
(let* ((time (nth (or time-index 5) file-attr)) ; default is last modtime
- (diff (- (ls-lisp-time-to-seconds time)
- (ls-lisp-time-to-seconds now)))
+ (diff (- (float-time time) (float-time)))
;; Consider a time to be recent if it is within the past six
;; months. A Gregorian year has 365.2425 * 24 * 60 * 60 ==
;; 31556952 seconds on the average, and half of that is 15778476.
@@ -733,5 +737,4 @@ All ls time options, namely c, t and u, are handled."
(provide 'ls-lisp)
-;; arch-tag: e55f399b-05ec-425c-a6d5-f5e349c35ab4
;;; ls-lisp.el ends here
diff --git a/lisp/macros.el b/lisp/macros.el
index fa45d8c6108..cbceb96fade 100644
--- a/lisp/macros.el
+++ b/lisp/macros.el
@@ -5,6 +5,7 @@
;; Maintainer: FSF
;; Keywords: abbrev
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/mail/binhex.el b/lisp/mail/binhex.el
index e131db76af8..42d2f35baed 100644
--- a/lisp/mail/binhex.el
+++ b/lisp/mail/binhex.el
@@ -221,7 +221,8 @@ If HEADER-ONLY is non-nil only decode header and return filename."
(goto-char start)
(when (re-search-forward binhex-begin-line end t)
(setq work-buffer (generate-new-buffer " *binhex-work*"))
- (with-current-buffer work-buffer (set-buffer-multibyte nil))
+ (unless (featurep 'xemacs)
+ (with-current-buffer work-buffer (set-buffer-multibyte nil)))
(beginning-of-line)
(setq bits 0 counter 0)
(while tmp
@@ -327,5 +328,4 @@ If HEADER-ONLY is non-nil only decode header and return filename."
(provide 'binhex)
-;; arch-tag: 8476badd-1e76-4f1d-a640-f9a38c72eed8
;;; binhex.el ends here
diff --git a/lisp/mail/blessmail.el b/lisp/mail/blessmail.el
index 4520ea61d03..545350170ec 100644
--- a/lisp/mail/blessmail.el
+++ b/lisp/mail/blessmail.el
@@ -5,6 +5,7 @@
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el
index 373e2231e94..a00f4c3a46e 100644
--- a/lisp/mail/emacsbug.el
+++ b/lisp/mail/emacsbug.el
@@ -7,6 +7,7 @@
;; Author: K. Shane Hartman
;; Maintainer: FSF
;; Keywords: maint mail
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -37,17 +38,14 @@
:group 'maint
:group 'mail)
+(define-obsolete-variable-alias 'report-emacs-bug-pretest-address
+ 'report-emacs-bug-address "24.1")
+
(defcustom report-emacs-bug-address "bug-gnu-emacs@gnu.org"
"Address of mailing list for GNU Emacs bugs."
:group 'emacsbug
:type 'string)
-(defcustom report-emacs-bug-pretest-address "bug-gnu-emacs@gnu.org"
- "Address of mailing list for GNU Emacs pretest bugs."
- :group 'emacsbug
- :type 'string
- :version "23.2") ; emacs-pretest-bug -> bug-gnu-emacs
-
(defcustom report-emacs-bug-no-confirmation nil
"If non-nil, suppress the confirmations asked for the sake of novice users."
:group 'emacsbug
@@ -60,6 +58,9 @@
;; User options end here.
+(defvar report-emacs-bug-tracker-url "http://debbugs.gnu.org/cgi/"
+ "Base URL of the GNU bugtracker.
+Used for querying duplicates and linking to existing bugs.")
(defvar report-emacs-bug-orig-text nil
"The automatically-created initial text of the bug report.")
@@ -75,6 +76,52 @@
(declare-function x-server-vendor "xfns.c" (&optional terminal))
(declare-function x-server-version "xfns.c" (&optional terminal))
(declare-function message-sort-headers "message" ())
+(defvar message-strip-special-text-properties)
+
+(defun report-emacs-bug-can-use-xdg-email ()
+ "Check if xdg-email can be used, i.e. we are on Gnome, KDE or xfce4."
+ (and (getenv "DISPLAY")
+ (executable-find "xdg-email")
+ (or (getenv "GNOME_DESKTOP_SESSION_ID")
+ ;; GNOME_DESKTOP_SESSION_ID is deprecated, check on Dbus also.
+ (condition-case nil
+ (eq 0 (call-process
+ "dbus-send" nil nil nil
+ "--dest=org.gnome.SessionManager"
+ "--print-reply"
+ "/org/gnome/SessionManager"
+ "org.gnome.SessionManager.CanShutdown"))
+ (error nil))
+ (equal (getenv "KDE_FULL_SESSION") "true")
+ (condition-case nil
+ (eq 0 (call-process
+ "/bin/sh" nil nil nil
+ "-c"
+ "xprop -root _DT_SAVE_MODE|grep xfce4"))
+ (error nil)))))
+
+(defun report-emacs-bug-insert-to-mailer ()
+ (interactive)
+ (save-excursion
+ (let* ((to (progn
+ (goto-char (point-min))
+ (forward-line)
+ (and (looking-at "^To: \\(.*\\)")
+ (match-string-no-properties 1))))
+ (subject (progn
+ (forward-line)
+ (and (looking-at "^Subject: \\(.*\\)")
+ (match-string-no-properties 1))))
+ (body (progn
+ (forward-line 2)
+ (if (> (point-max) (point))
+ (buffer-substring-no-properties (point) (point-max))))))
+ (if (and to subject body)
+ (start-process "xdg-email" nil "xdg-email"
+ "--subject" subject
+ "--body" body
+ (concat "mailto:" to))
+ (error "Subject, To or body not found")))))
;;;###autoload
(defun report-emacs-bug (topic &optional recent-keys)
@@ -89,32 +136,26 @@ Prompts for bug subject. Leaves you in a mail buffer."
(setq topic (concat emacs-version "; " topic))
(when (string-match "^\\(\\([.0-9]+\\)*\\)\\.[0-9]+$" emacs-version)
(setq topic (concat (match-string 1 emacs-version) "; " topic))))
- ;; If there are four numbers in emacs-version (three for MS-DOS),
- ;; this is a pretest version.
- (let* ((pretest-p (string-match (if (eq system-type 'ms-dos)
- "\\..*\\."
- "\\..*\\..*\\.")
- emacs-version))
- (from-buffer (current-buffer))
- (reporting-address (if pretest-p
- report-emacs-bug-pretest-address
- report-emacs-bug-address))
- ;; Put these properties on semantically-void text.
- ;; report-emacs-bug-hook deletes these regions before sending.
- (prompt-properties '(field emacsbug-prompt
- intangible but-helpful
- rear-nonsticky t))
- user-point message-end-point)
+ (let ((from-buffer (current-buffer))
+ ;; Put these properties on semantically-void text.
+ ;; report-emacs-bug-hook deletes these regions before sending.
+ (prompt-properties '(field emacsbug-prompt
+ intangible but-helpful
+ rear-nonsticky t))
+ (can-xdg-email (report-emacs-bug-can-use-xdg-email))
+ user-point message-end-point)
(setq message-end-point
(with-current-buffer (get-buffer-create "*Messages*")
(point-max-marker)))
- (compose-mail reporting-address topic)
+ (compose-mail report-emacs-bug-address topic)
;; The rest of this does not execute if the user was asked to
;; confirm and said no.
- ;; Message-mode sorts the headers before sending. We sort now so
- ;; that report-emacs-bug-orig-text remains valid. (Bug#5178)
- (if (eq major-mode 'message-mode)
- (message-sort-headers))
+ (when (eq major-mode 'message-mode)
+ ;; Message-mode sorts the headers before sending. We sort now so
+ ;; that report-emacs-bug-orig-text remains valid. (Bug#5178)
+ (message-sort-headers)
+ ;; Stop message-mode stealing the properties we will add.
+ (set (make-local-variable 'message-strip-special-text-properties) nil))
(rfc822-goto-eoh)
(forward-line 1)
(let ((signature (buffer-substring (point) (point-max))))
@@ -123,7 +164,7 @@ Prompts for bug subject. Leaves you in a mail buffer."
(backward-char (length signature)))
(unless report-emacs-bug-no-explanations
;; Insert warnings for novice users.
- (when (string-match "@gnu\\.org$" reporting-address)
+ (when (string-match "@gnu\\.org$" report-emacs-bug-address)
(insert "This bug report will be sent to the Free Software Foundation,\n")
(let ((pos (point)))
(insert "not to your local site managers!")
@@ -135,17 +176,12 @@ Prompts for bug subject. Leaves you in a mail buffer."
(insert " if possible, because the Emacs maintainers
usually do not have translators to read other languages for them.\n\n")
(insert (format "Your report will be posted to the %s mailing list"
- reporting-address))
- ;; Nowadays all bug reports end up there.
-;;; (if pretest-p (insert ".\n\n")
- (insert "\nand the gnu.emacs.bug news group, and at http://debbugs.gnu.org.\n\n"))
+ report-emacs-bug-address))
+ (insert "\nand the gnu.emacs.bug news group, and at http://debbugs.gnu.org.\n\n"))
(insert "Please describe exactly what actions triggered the bug\n"
"and the precise symptoms of the bug. If you can, give\n"
"a recipe starting from `emacs -Q':\n\n")
- ;; Stop message-mode stealing the properties we are about to add.
- (if (boundp 'message-strip-special-text-properties)
- (set (make-local-variable 'message-strip-special-text-properties) nil))
(add-text-properties (save-excursion
(rfc822-goto-eoh)
(line-beginning-position 2))
@@ -240,6 +276,9 @@ usually do not have translators to read other languages for them.\n\n")
;; This is so the user has to type something in order to send easily.
(use-local-map (nconc (make-sparse-keymap) (current-local-map)))
(define-key (current-local-map) "\C-c\C-i" 'report-emacs-bug-info)
+ (if can-xdg-email
+ (define-key (current-local-map) "\C-cm"
+ 'report-emacs-bug-insert-to-mailer))
;; Could test major-mode instead.
(cond ((memq mail-user-agent '(message-user-agent gnus-user-agent))
(setq report-emacs-bug-send-command "message-send-and-exit"
@@ -259,6 +298,9 @@ usually do not have translators to read other languages for them.\n\n")
report-emacs-bug-send-command))))
(princ (substitute-command-keys
" Type \\[kill-buffer] RET to cancel (don't send it).\n"))
+ (if can-xdg-email
+ (princ (substitute-command-keys
+ " Type \\[report-emacs-bug-insert-to-mailer] to insert text to you preferred mail program.\n")))
(terpri)
(princ (substitute-command-keys
" Type \\[report-emacs-bug-info] to visit in Info the Emacs Manual section
@@ -335,6 +377,87 @@ and send the mail again%s."
'field 'emacsbug-prompt))
(delete-region pos (field-end (1+ pos)))))))
+
+;; Querying the bug database
+
+(defun report-emacs-bug-create-existing-bugs-buffer (bugs keywords)
+ (switch-to-buffer (get-buffer-create "*Existing Emacs Bugs*"))
+ (setq buffer-read-only t)
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (make-local-variable 'bug-alist)
+ (setq bug-alist bugs)
+ (make-local-variable 'bug-choice-widget)
+ (widget-insert (propertize (concat "Already known bugs ("
+ keywords "):\n\n")
+ 'face 'bold))
+ (if bugs
+ (setq bug-choice-widget
+ (apply 'widget-create 'radio-button-choice
+ :value (caar bugs)
+ (let (items)
+ (dolist (bug bugs)
+ (push (list
+ 'url-link
+ :format (concat "Bug#" (number-to-string (third bug))
+ ": " (cadr bug) "\n %[%v%]\n")
+ ;; FIXME: Why is only the link of the
+ ;; active item clickable?
+ (first bug))
+ items))
+ (nreverse items))))
+ (widget-insert "No bugs maching your keywords found.\n"))
+ (widget-insert "\n")
+ (widget-create 'push-button
+ :notify (lambda (&rest ignore)
+ ;; TODO: Do something!
+ (message "Reporting new bug!"))
+ "Report new bug")
+ (when bugs
+ (widget-insert " ")
+ (widget-create 'push-button
+ :notify (lambda (&rest ignore)
+ (let ((val (widget-value bug-choice-widget)))
+ ;; TODO: Do something!
+ (message "Appending to bug %s!"
+ (nth 2 (assoc val bug-alist)))))
+ "Append to chosen bug"))
+ (widget-insert " ")
+ (widget-create 'push-button
+ :notify (lambda (&rest ignore)
+ (kill-buffer))
+ "Quit reporting bug")
+ (widget-insert "\n"))
+ (use-local-map widget-keymap)
+ (widget-setup)
+ (goto-char (point-min)))
+
+(defun report-emacs-bug-parse-query-results (status keywords)
+ (goto-char (point-min))
+ (let (buglist)
+ (while (re-search-forward "<a href=\"bugreport\\.cgi\\?bug=\\([[:digit:]]+\\)\">\\([^<]+\\)</a>" nil t)
+ (let ((number (match-string 1))
+ (subject (match-string 2)))
+ (when (not (string-match "^#" subject))
+ (push (list
+ ;; first the bug URL
+ (concat report-emacs-bug-tracker-url
+ "bugreport.cgi?bug=" number)
+ ;; then the subject and number
+ subject (string-to-number number))
+ buglist))))
+ (report-emacs-bug-create-existing-bugs-buffer (nreverse buglist) keywords)))
+
+(defun report-emacs-bug-query-existing-bugs (keywords)
+ "Query for KEYWORDS at `report-emacs-bug-tracker-url', and return the result.
+The result is an alist with items of the form (URL SUBJECT NO)."
+ (interactive "sBug keywords (comma separated): ")
+ (url-retrieve (concat report-emacs-bug-tracker-url
+ "pkgreport.cgi?include=subject%3A"
+ (replace-regexp-in-string "[[:space:]]+" "+" keywords)
+ ";package=emacs")
+ 'report-emacs-bug-parse-query-results (list keywords)))
+
(provide 'emacsbug)
;;; emacsbug.el ends here
diff --git a/lisp/mail/feedmail.el b/lisp/mail/feedmail.el
index 77d82f6076f..5c6da623fed 100644
--- a/lisp/mail/feedmail.el
+++ b/lisp/mail/feedmail.el
@@ -314,7 +314,7 @@
(defcustom feedmail-confirm-outgoing nil
- "*If non-nil, give a y-or-n confirmation prompt before sending mail.
+ "If non-nil, give a y-or-n confirmation prompt before sending mail.
This is done after the message is completely prepped, and you'll be
looking at the top of the message in a buffer when you get the prompt.
If set to the symbol 'queued, give the confirmation prompt only while
@@ -330,7 +330,7 @@ cases. You can give a timeout for the prompt; see variable
(defcustom feedmail-confirm-outgoing-timeout nil
- "*If non-nil, a timeout in seconds at the send confirmation prompt.
+ "If non-nil, a timeout in seconds at the send confirmation prompt.
If a positive number, it's a timeout before sending. If a negative
number, it's a timeout before not sending. This will not work if your
version of Emacs doesn't include the function `y-or-n-p-with-timeout'
@@ -341,7 +341,7 @@ version of Emacs doesn't include the function `y-or-n-p-with-timeout'
(defcustom feedmail-nuke-bcc t
- "*If non-nil remove Bcc: lines from the message headers.
+ "If non-nil remove Bcc: lines from the message headers.
In any case, the Bcc: lines do participate in the composed address
list. You may want to leave them in if you're using sendmail
\(see `feedmail-buffer-eating-function'\)."
@@ -351,7 +351,7 @@ list. You may want to leave them in if you're using sendmail
(defcustom feedmail-nuke-resent-bcc t
- "*If non-nil remove Resent-Bcc: lines from the message headers.
+ "If non-nil remove Resent-Bcc: lines from the message headers.
In any case, the Resent-Bcc: lines do participate in the composed
address list. You may want to leave them in if you're using sendmail
\(see `feedmail-buffer-eating-function'\)."
@@ -361,7 +361,7 @@ address list. You may want to leave them in if you're using sendmail
(defcustom feedmail-deduce-bcc-where nil
- "*Where Bcc:/Resent-Bcc: addresses should appear in the envelope list.
+ "Where Bcc:/Resent-Bcc: addresses should appear in the envelope list.
Addresses for the message envelope are deduced by examining
appropriate address headers in the message. Generally, they will show
up in the list of deduced addresses in the order that the headers
@@ -387,7 +387,7 @@ delivery agent that processes the addresses backwards."
(defcustom feedmail-fill-to-cc t
- "*If non-nil do smart filling of addressee header lines.
+ "If non-nil do smart filling of addressee header lines.
Smart filling means breaking long lines at appropriate points and
making continuation lines. Despite the function name, it includes
To:, Cc:, Bcc: (and their Resent-* forms), as well as From: and
@@ -399,14 +399,14 @@ as-is. The filling is done after mail address alias expansion."
(defcustom feedmail-fill-to-cc-fill-column default-fill-column
- "*Fill column used by `feedmail-fill-to-cc'."
+ "Fill column used by `feedmail-fill-to-cc'."
:group 'feedmail-headers
:type 'integer
)
(defcustom feedmail-nuke-bcc-in-fcc nil
- "*If non-nil remove [Resent-]Bcc: lines in message copies saved via Fcc:.
+ "If non-nil remove [Resent-]Bcc: lines in message copies saved via Fcc:.
This is independent of whether the Bcc: header lines are actually sent
with the message (see feedmail-nuke-bcc). Though not implied in the name,
the same Fcc: treatment applies to both Bcc: and Resent-Bcc: lines."
@@ -416,7 +416,7 @@ the same Fcc: treatment applies to both Bcc: and Resent-Bcc: lines."
(defcustom feedmail-nuke-body-in-fcc nil
- "*If non-nil remove body of message in copies saved via Fcc:.
+ "If non-nil remove body of message in copies saved via Fcc:.
If a positive integer value, leave (up to) that many lines of the
beginning of the body intact. The result is that the Fcc: copy will
consist only of the message headers, serving as a sort of an outgoing
@@ -427,7 +427,7 @@ message log."
(defcustom feedmail-force-expand-mail-aliases nil
- "*If non-nil, force the calling of `expand-mail-aliases'.
+ "If non-nil, force the calling of `expand-mail-aliases'.
Normally, feedmail tries to figure out if you're using mailalias or
mailabbrevs and only calls `expand-mail-aliases' if it thinks you're
using the mailalias package. This user option can be used to force
@@ -439,7 +439,7 @@ out."
(defcustom feedmail-nuke-empty-headers t
- "*If non-nil, remove header lines which have no contents.
+ "If non-nil, remove header lines which have no contents.
A completely empty Subject: header is always removed, regardless of
the setting of this variable. The only time you would want them left
in would be if you used some headers whose presence indicated
@@ -457,7 +457,7 @@ but common in some proprietary systems."
;; RFC-822 and RFC-1123, but are you *really* one of those cases
;; they're talking about? I doubt it.)
(defcustom feedmail-sender-line nil
- "*If non-nil and the email has no Sender: header, use this value.
+ "If non-nil and the email has no Sender: header, use this value.
May be nil, in which case nothing in particular is done with respect
to Sender: lines. By design, will not replace an existing Sender:
line, but you can achieve that with a fiddle-plex 'replace action.
@@ -484,7 +484,7 @@ header is fiddled after the From: header is fiddled."
(defcustom feedmail-force-binary-write t
- "*If non-nil, force writing file as binary (this applies to queues and Fcc:).
+ "If non-nil, force writing file as binary (this applies to queues and Fcc:).
On systems where there is a difference between binary and text files,
feedmail will temporarily manipulate the value of `buffer-file-type'
to make the writing as binary. If nil, writing will be in text mode.
@@ -496,7 +496,7 @@ variables or other means, this option has no effect."
(defcustom feedmail-from-line t
- "*If non-nil and the email has no From: header, use this value.
+ "If non-nil and the email has no From: header, use this value.
May be t, in which case a default is computed (and you probably won't
be happy with it). May be nil, in which case nothing in particular is
done with respect to From: lines. By design, will not replace an
@@ -526,7 +526,7 @@ to arrange for the message to get a From: line."
(defcustom feedmail-deduce-envelope-from t
- "*If non-nil, deduce message envelope \"from\" from header From: or Sender:.
+ "If non-nil, deduce message envelope \"from\" from header From: or Sender:.
In other words, if there is a Sender: header in the message, temporarily
change the value of `user-mail-address' to be the same while the message
is being sent. If there is no Sender: header, use the From: header,
@@ -555,14 +555,14 @@ influence what they will use as the envelope."
(defcustom feedmail-x-mailer-line-user-appendage nil
- "*See feedmail-x-mailer-line."
+ "See feedmail-x-mailer-line."
:group 'feedmail-headers
:type '(choice (const nil) (const t) string)
)
(defcustom feedmail-x-mailer-line t
- "*Control the form of an X-Mailer: header in an outgoing message.
+ "Control the form of an X-Mailer: header in an outgoing message.
Moderately useful for debugging, keeping track of your correspondents'
mailer preferences, or just wearing your MUA on your sleeve. You
should probably know that some people are fairly emotional about the
@@ -592,7 +592,7 @@ by feedmail to either \"X-Mailer\" or \"X-Resent-Mailer\"."
(defcustom feedmail-message-id-generator t
- "*Specifies the creation of a Message-Id: header field.
+ "Specifies the creation of a Message-Id: header field.
If nil, nothing is done about Message-Id:.
@@ -622,7 +622,7 @@ in the saved message if you use Fcc:."
(defcustom feedmail-message-id-suffix nil
- "*If non-nil, used as a suffix for generating unique Message-Id: headers.
+ "If non-nil, used as a suffix for generating unique Message-Id: headers.
The function `feedmail-default-message-id-generator' creates its work based
on a formatted date-time string, a random number, and a domain-looking suffix.
You can control the suffix used by assigning a string value to this variable.
@@ -637,7 +637,7 @@ automatically."
;; this was suggested in various forms by several people; first was
;; Tony DeSimone in Oct 1992; sorry to be so tardy
(defcustom feedmail-date-generator t
- "*Specifies the creation of a Date: header field.
+ "Specifies the creation of a Date: header field.
If nil, nothing is done about Date:.
@@ -671,7 +671,7 @@ in the saved message if you use Fcc:."
(defcustom feedmail-fiddle-headers-upwardly t
- "*Non-nil means fiddled header fields should go at the top of the header.
+ "Non-nil means fiddled header fields should go at the top of the header.
nil means insert them at the bottom. This is mostly a novelty issue since
the standards define the ordering of header fields to be immaterial and it's
fairly likely that some MTA along the way will have its own idea of what the
@@ -777,7 +777,7 @@ you are at accomplishing inherently inefficient things."
(defcustom feedmail-enable-queue nil
- "*If non-nil, provide for stashing outgoing messages in a queue.
+ "If non-nil, provide for stashing outgoing messages in a queue.
This is the master on/off switch for feedmail message queuing.
Queuing is quite handy for laptop-based users. It's also handy if you
get a lot of mail and process it more or less sequentially. For
@@ -804,7 +804,7 @@ To transmit all the messages in the queue, invoke the command
(defcustom feedmail-queue-runner-confirm-global nil
- "*If non-nil, give a y-or-n confirmation prompt before running the queue.
+ "If non-nil, give a y-or-n confirmation prompt before running the queue.
Prompt even if the queue is about to be processed as a result of a call to
`feedmail-run-the-queue-no-prompts'. This gives you a way to bail out
without having to answer no to the individual message prompts."
@@ -814,7 +814,7 @@ without having to answer no to the individual message prompts."
(defcustom feedmail-queue-directory
(concat (getenv "HOME") "/mail/q")
- "*Name of a directory where messages will be queued.
+ "Name of a directory where messages will be queued.
Directory will be created if necessary. Should be a string that
doesn't end with a slash. Default is \"$HOME/mail/q\"."
:group 'feedmail-queue
@@ -824,7 +824,7 @@ doesn't end with a slash. Default is \"$HOME/mail/q\"."
(defcustom feedmail-queue-draft-directory
(concat (getenv "HOME") "/mail/draft")
- "*Name of a directory where draft messages will be queued.
+ "Name of a directory where draft messages will be queued.
Directory will be created if necessary. Should be a string that
doesn't end with a slash. Default is \"$HOME/mail/draft\"."
:group 'feedmail-queue
@@ -833,7 +833,7 @@ doesn't end with a slash. Default is \"$HOME/mail/draft\"."
(defcustom feedmail-ask-before-queue t
- "*If non-nil, feedmail will ask what you want to do with the message.
+ "If non-nil, feedmail will ask what you want to do with the message.
Default choices for the message action prompt will include sending it
immediately, putting it in the main queue, putting it in the draft
queue, or returning to the buffer to continue editing. Only matters if
@@ -845,7 +845,7 @@ without a prompt."
(defcustom feedmail-ask-before-queue-prompt "FQM: Message action (q, i, d, e, ?)? [%s]: "
- "*A string which will be used for the message action prompt.
+ "A string which will be used for the message action prompt.
If it contains a \"%s\", that will be replaced with the value of
`feedmail-ask-before-queue-default'."
:group 'feedmail-queue
@@ -854,7 +854,7 @@ If it contains a \"%s\", that will be replaced with the value of
(defcustom feedmail-ask-before-queue-reprompt "FQM: Please type q, i, d, or e; or ? for help [%s]: "
- "*A string which will be used for repompting after invalid input.
+ "A string which will be used for repompting after invalid input.
If it contains a \"%s\", that will be replaced with the value of
`feedmail-ask-before-queue-default'."
:group 'feedmail-queue
@@ -863,7 +863,7 @@ If it contains a \"%s\", that will be replaced with the value of
(defcustom feedmail-ask-before-queue-default "queue"
- "*Meaning if user hits return in response to the message action prompt.
+ "Meaning if user hits return in response to the message action prompt.
Should be a character or a string; if a string, only the first
character is significant. Useful values are those described in
the help for the message action prompt."
@@ -947,7 +947,7 @@ It may contain embedded line breaks. It will be printed via `princ'."
(defcustom feedmail-queue-chatty t
- "*If non-nil, blat a few status messages and such in the mini-buffer.
+ "If non-nil, blat a few status messages and such in the mini-buffer.
If nil, just do the work and don't pester people about what's going on.
In some cases, though, specific options inspire mini-buffer prompting.
That's not affected by this variable setting. Also does not control
@@ -958,7 +958,7 @@ reporting of error/abnormal conditions."
(defcustom feedmail-queue-chatty-sit-for 2
- "*Duration of pause after most queue-related messages.
+ "Duration of pause after most queue-related messages.
After some messages are divulged, it is prudent to pause before
something else obliterates them. This value controls the duration of
the pause."
@@ -968,7 +968,7 @@ the pause."
(defcustom feedmail-queue-run-orderer nil
- "*If non-nil, name a function which will sort the queued messages.
+ "If non-nil, name a function which will sort the queued messages.
The function is called during a running of the queue for sending, and
takes one argument, a list of the files in the queue directory. It
may contain the names of non-message files, and it's okay to leave
@@ -982,7 +982,7 @@ they were placed in the queue."
(defcustom feedmail-queue-use-send-time-for-date nil
- "*If non-nil, use send time for the Date: header value.
+ "If non-nil, use send time for the Date: header value.
This variable is used by the default date generating function,
feedmail-default-date-generator. If nil, the default, the
last-modified timestamp of the queue file is used to create the
@@ -994,7 +994,7 @@ used."
(defcustom feedmail-queue-use-send-time-for-message-id nil
- "*If non-nil, use send time for the Message-Id: header value.
+ "If non-nil, use send time for the Message-Id: header value.
This variable is used by the default Message-Id: generating function,
`feedmail-default-message-id-generator'. If nil, the default, the
last-modified timestamp of the queue file is used to create the
@@ -1006,7 +1006,7 @@ used."
(defcustom feedmail-ask-for-queue-slug nil
- "*If non-nil, prompt user for part of the queue file name.
+ "If non-nil, prompt user for part of the queue file name.
The file will automatically get the FQM suffix and an embedded
sequence number for uniqueness, so don't specify that. feedmail will
get rid of all characters other than alphanumeric and hyphen in the
@@ -1023,7 +1023,7 @@ based on the subjects of the messages."
(defcustom feedmail-queue-slug-maker 'feedmail-queue-subject-slug-maker
- "*If non-nil, a function which creates part of the queued file name.
+ "If non-nil, a function which creates part of the queued file name.
Takes a single argument giving the name of the directory into
which the message will be queued. The returned string should be just
the non-directory filename part, without FQM suffix or uniquifying
@@ -1036,7 +1036,7 @@ any."
(defcustom feedmail-queue-default-file-slug t
- "*Indicates what to use for subject-less messages when forming a file name.
+ "Indicates what to use for subject-less messages when forming a file name.
When feedmail queues a message, it creates a unique file name. By default,
the file name is based in part on the subject of the message being queued.
If there is no subject, consult this variable. See documentation for the
@@ -1059,7 +1059,7 @@ it's not expected to be a complete filename."
(defcustom feedmail-queue-fqm-suffix ".fqm"
- "*The FQM suffix used to distinguish feedmail queued message files.
+ "The FQM suffix used to distinguish feedmail queued message files.
You probably want this to be a period followed by some letters and/or
digits. The distinction is to be able to tell them from other random
files that happen to be in the `feedmail-queue-directory' or
@@ -1071,7 +1071,7 @@ queued message."
(defcustom feedmail-nuke-buffer-after-queue nil
- "*If non-nil, silently kill the buffer after a message is queued.
+ "If non-nil, silently kill the buffer after a message is queued.
You might like that since a side-effect of queueing the message is
that its buffer name gets changed to the filename. That means that
the buffer won't be reused for the next message you compose. If you
@@ -1084,7 +1084,7 @@ message buffers."
(defcustom feedmail-queue-auto-file-nuke nil
- "*If non-nil, automatically delete queue files when a message is sent.
+ "If non-nil, automatically delete queue files when a message is sent.
Normally, feedmail will notice such files when you send a message in
immediate mode (i.e., not when you're running the queue) and will ask if
you want to delete them. Since the answer is usually yes, setting this
@@ -1154,7 +1154,7 @@ It shows the simple addresses and gets a confirmation. Use as:
(defcustom feedmail-last-chance-hook nil
- "*User's last opportunity to modify the message on its way out.
+ "User's last opportunity to modify the message on its way out.
It has already had all the header prepping from the standard package.
The next step after running the hook will be to push the buffer into a
subprocess that mails the mail. The hook might be interested in
@@ -1172,7 +1172,7 @@ reused and things will get confused."
(defcustom feedmail-before-fcc-hook nil
- "*User's last opportunity to modify the message before Fcc action.
+ "User's last opportunity to modify the message before Fcc action.
It has already had all the header prepping from the standard package.
The next step after running the hook will be to save the message via
Fcc: processing. The hook might be interested in these: (1)
@@ -1189,7 +1189,7 @@ internal buffers will be reused and things will get confused."
(defcustom feedmail-queue-runner-mode-setter
'(lambda (&optional arg) (mail-mode))
- "*A function to set the proper mode of a message file.
+ "A function to set the proper mode of a message file.
Called when the message is read back out of the queue directory with a single
argument, the optional argument used in the call to
`feedmail-run-the-queue' or `feedmail-run-the-queue-no-prompts'.
@@ -1204,7 +1204,7 @@ Called with funcall, not `call-interactively'."
(defcustom feedmail-queue-alternative-mail-header-separator nil
- "*Alternative header demarcation for queued messages.
+ "Alternative header demarcation for queued messages.
If you sometimes get alternative values for `mail-header-separator' in
queued messages, set the value of this variable to whatever it is.
For example, `rmail-resend' uses a `mail-header-separator' value of empty
@@ -1221,7 +1221,7 @@ set `mail-header-separator' to the value of
(defcustom feedmail-queue-runner-message-sender 'mail-send-and-exit
- "*Function to initiate sending a message file.
+ "Function to initiate sending a message file.
Called for each message read back out of the queue directory with a
single argument, the optional argument used in the call to
`feedmail-run-the-queue' or `feedmail-run-the-queue-no-prompts'.
@@ -1238,7 +1238,7 @@ your chance to have something different. Called with `funcall', not
'(lambda (fqm-file &optional arg)
(delete-file fqm-file)
(if (and arg feedmail-queue-chatty) (message "FQM: Nuked %s" fqm-file)))
- "*Function that will be called after a message has been sent.
+ "Function that will be called after a message has been sent.
Not called in the case of errors. This function is called with two
arguments: the name of the message queue file for the message just sent,
and the optional argument used in the call to `feedmail-run-the-queue'
@@ -1265,7 +1265,7 @@ variable, but may depend on its value as described here.")
(defcustom feedmail-buffer-eating-function 'feedmail-buffer-to-binmail
- "*Function used to send the prepped buffer to a subprocess.
+ "Function used to send the prepped buffer to a subprocess.
The function's three (mandatory) arguments are: (1) the buffer
containing the prepped message; (2) a buffer where errors should be
directed; and (3) a list containing the addresses individually as
@@ -1281,7 +1281,7 @@ to nil. If you use the binmail form, check the value of
(defcustom feedmail-binmail-template (if mail-interactive "/bin/mail %s" "/bin/rmail %s")
- "*Command template for the subprocess which will get rid of the mail.
+ "Command template for the subprocess which will get rid of the mail.
It can result in any command understandable by /bin/sh. Might not
work at all in non-Unix environments. The single '%s', if present,
gets replaced by the space-separated, simplified list of addressees.
@@ -1446,7 +1446,7 @@ with various lower-level mechanisms to provide features such as queueing."
;; From a VM mailing list discussion and some suggestions from Samuel Mikes <smikes@alumni.hmc.edu>
(defun feedmail-queue-express-to-queue ()
- "*Send message directly to the queue, with a minimum of fuss and bother."
+ "Send message directly to the queue, with a minimum of fuss and bother."
(interactive)
(let ((feedmail-enable-queue t)
(feedmail-ask-before-queue nil)
@@ -1458,7 +1458,7 @@ with various lower-level mechanisms to provide features such as queueing."
(defun feedmail-queue-express-to-draft ()
- "*Send message directly to the draft queue, with a minimum of fuss and bother."
+ "Send message directly to the draft queue, with a minimum of fuss and bother."
(interactive)
(let ((feedmail-queue-directory feedmail-queue-draft-directory))
(feedmail-queue-express-to-queue)
diff --git a/lisp/mail/hashcash.el b/lisp/mail/hashcash.el
index 86364ab7835..efa27c3305d 100644
--- a/lisp/mail/hashcash.el
+++ b/lisp/mail/hashcash.el
@@ -1,6 +1,7 @@
;;; hashcash.el --- Add hashcash payments to email
-;; Copyright (C) 2003, 2004, 2005, 2007, 2008, 2009, 2010 Free Software Foundation
+;; Copyright (C) 2003, 2004, 2005, 2007, 2008, 2009, 2010
+;; Free Software Foundation
;; Written by: Paul Foley <mycroft@actrix.gen.nz> (1997-2002)
;; Maintainer: Paul Foley <mycroft@actrix.gen.nz>
@@ -47,6 +48,7 @@
;;; Code:
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
@@ -115,8 +117,6 @@ For example, you may want to set this to '(\"-Z2\") to reduce header length."
(require 'mail-utils)
(eval-and-compile
- (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
-
(if (fboundp 'point-at-bol)
(defalias 'hashcash-point-at-bol 'point-at-bol)
(defalias 'hashcash-point-at-bol 'line-beginning-position))
@@ -131,10 +131,10 @@ For example, you may want to set this to '(\"-Z2\") to reduce header length."
(concat (match-string 1 addr) (match-string 2 addr))
addr))
-(declare-function message-narrow-to-headers-or-head "message" ())
-(declare-function message-fetch-field "message" (header &optional not-all))
-(declare-function message-goto-eoh "message" ())
-(declare-function message-narrow-to-headers "message" ())
+(declare-function message-narrow-to-headers-or-head "message" ())
+(declare-function message-fetch-field "message" (header &optional not-all))
+(declare-function message-goto-eoh "message" ())
+(declare-function message-narrow-to-headers "message" ())
(defun hashcash-token-substring ()
(save-excursion
@@ -277,7 +277,7 @@ BUFFER defaults to the current buffer."
(unless buffer (setq buffer (current-buffer)))
(let (entry)
(while (setq entry (rassq buffer hashcash-process-alist))
- (accept-process-output (car entry)))))
+ (accept-process-output (car entry) 1))))
(defun hashcash-processes-running-p (buffer)
"Return non-nil if hashcash processes in BUFFER are still running."
@@ -287,7 +287,7 @@ BUFFER defaults to the current buffer."
"Ask user whether to wait for hashcash processes to finish."
(interactive)
(when (hashcash-processes-running-p (current-buffer))
- (if (y-or-n-p
+ (if (y-or-n-p
"Hashcash process(es) still running; wait for them to finish? ")
(hashcash-wait-async)
(hashcash-cancel-async))))
@@ -376,4 +376,4 @@ Prefix arg sets default accept amount temporarily."
(provide 'hashcash)
-;; arch-tag: 0e7fe983-a124-4392-9788-0dbcbd2c4d62
+;;; hashcash.el ends here
diff --git a/lisp/mail/mail-extr.el b/lisp/mail/mail-extr.el
index 51c490da7ab..9b958e41b05 100644
--- a/lisp/mail/mail-extr.el
+++ b/lisp/mail/mail-extr.el
@@ -1,11 +1,13 @@
;;; mail-extr.el --- extract full name and address from RFC 822 mail header -*- coding: utf-8 -*-
;; Copyright (C) 1991, 1992, 1993, 1994, 1997, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Joe Wells <jbw@cs.bu.edu>
;; Maintainer: FSF
;; Keywords: mail
+;; Package: mail-utils
;; This file is part of GNU Emacs.
@@ -690,8 +692,8 @@ Unless NO-REPLACE is true, at each of the positions in LIST-SYMBOL
;;
(defvar disable-initial-guessing-flag) ; dynamic assignment
-(defvar cbeg) ; dynamic assignment
-(defvar cend) ; dynamic assignment
+(defvar mailextr-cbeg) ; dynamic assignment
+(defvar mailextr-cend) ; dynamic assignment
(defvar mail-extr-all-top-level-domains) ; Defined below.
;;;###autoload
@@ -761,7 +763,8 @@ consing a string.)"
record-pos-symbol
first-real-pos last-real-pos
phrase-beg phrase-end
- cbeg cend ; dynamically set from -voodoo
+ ;; Dynamically set in mail-extr-voodoo.
+ mailextr-cbeg mailextr-cend
quote-beg quote-end
atom-beg atom-end
mbox-beg mbox-end
@@ -795,19 +798,19 @@ consing a string.)"
((eq char ?\()
(set-syntax-table mail-extr-address-comment-syntax-table)
;; only record the first non-empty comment's position
- (if (and (not cbeg)
+ (if (and (not mailextr-cbeg)
(save-excursion
(forward-char 1)
(mail-extr-skip-whitespace-forward)
(not (eq ?\) (char-after (point))))))
- (setq cbeg (point)))
+ (setq mailextr-cbeg (point)))
;; TODO: don't record if unbalanced
(or (mail-extr-safe-move-sexp 1)
(forward-char 1))
(set-syntax-table mail-extr-address-syntax-table)
- (if (and cbeg
- (not cend))
- (setq cend (point))))
+ (if (and mailextr-cbeg
+ (not mailextr-cend))
+ (setq mailextr-cend (point))))
;; quoted text
((eq char ?\")
;; only record the first non-empty quote's position
@@ -993,10 +996,10 @@ consing a string.)"
(> last-real-pos (1+ group-\;-pos))
(setq last-real-pos (1+ group-\;-pos)))
;; *** This may be wrong:
- (and cend
- (> cend group-\;-pos)
- (setq cend nil
- cbeg nil))
+ (and mailextr-cend
+ (> mailextr-cend group-\;-pos)
+ (setq mailextr-cend nil
+ mailextr-cbeg nil))
(and quote-end
(> quote-end group-\;-pos)
(setq quote-end nil
@@ -1227,8 +1230,8 @@ consing a string.)"
(narrow-to-region phrase-beg phrase-end))
;; Example: fml@foo.bar.dom (First M. Last)
- (cbeg
- (narrow-to-region (1+ cbeg) (1- cend))
+ (mailextr-cbeg
+ (narrow-to-region (1+ mailextr-cbeg) (1- mailextr-cend))
(mail-extr-undo-backslash-quoting (point-min) (point-max))
;; Deal with spacing problems
@@ -1471,7 +1474,6 @@ place. It affects how `mail-extract-address-components' works."
(case-fold-search nil)
mixed-case-flag lower-case-flag ;;upper-case-flag
suffix-flag last-name-comma-flag
- ;;cbeg cend
initial
begin-again-flag
drop-this-word-if-trailing-flag
@@ -1617,7 +1619,7 @@ place. It affects how `mail-extract-address-components' works."
;; Delete parenthesized/quoted comment/nickname
((memq (following-char) '(?\( ?\{ ?\[ ?\" ?\' ?\`))
- (setq cbeg (point))
+ (setq mailextr-cbeg (point))
(set-syntax-table mail-extr-address-text-comment-syntax-table)
(cond ((memq (following-char) '(?\' ?\`))
(or (search-forward "'" nil t
@@ -1627,23 +1629,23 @@ place. It affects how `mail-extract-address-components' works."
(or (mail-extr-safe-move-sexp 1)
(goto-char (point-max)))))
(set-syntax-table mail-extr-address-text-syntax-table)
- (setq cend (point))
+ (setq mailextr-cend (point))
(cond
;; Handle case of entire name being quoted
((and (eq word-count 0)
(looking-at " *\\'")
- (>= (- cend cbeg) 2))
- (narrow-to-region (1+ cbeg) (1- cend))
+ (>= (- mailextr-cend mailextr-cbeg) 2))
+ (narrow-to-region (1+ mailextr-cbeg) (1- mailextr-cend))
(goto-char (point-min)))
(t
;; Handle case of quoted initial
- (if (and (or (= 3 (- cend cbeg))
- (and (= 4 (- cend cbeg))
- (eq ?. (char-after (+ 2 cbeg)))))
+ (if (and (or (= 3 (- mailextr-cend mailextr-cbeg))
+ (and (= 4 (- mailextr-cend mailextr-cbeg))
+ (eq ?. (char-after (+ 2 mailextr-cbeg)))))
(not (looking-at " *\\'")))
- (setq initial (char-after (1+ cbeg)))
+ (setq initial (char-after (1+ mailextr-cbeg)))
(setq initial nil))
- (delete-region cbeg cend)
+ (delete-region mailextr-cbeg mailextr-cend)
(if initial
(insert initial ". ")))))
@@ -2173,5 +2175,4 @@ place. It affects how `mail-extract-address-components' works."
(provide 'mail-extr)
-;; arch-tag: 7785fade-1073-4ed6-b4f6-28db34a7982d
;;; mail-extr.el ends here
diff --git a/lisp/mail/mail-hist.el b/lisp/mail/mail-hist.el
index 6700d6d2733..f129f29ea33 100644
--- a/lisp/mail/mail-hist.el
+++ b/lisp/mail/mail-hist.el
@@ -6,6 +6,7 @@
;; Author: Karl Fogel <kfogel@red-bean.com>
;; Created: March, 1994
;; Keywords: mail, history
+;; Package: mail-utils
;; This file is part of GNU Emacs.
diff --git a/lisp/mail/mailclient.el b/lisp/mail/mailclient.el
index dd5ec2dd388..2a5d77d4f74 100644
--- a/lisp/mail/mailclient.el
+++ b/lisp/mail/mailclient.el
@@ -46,6 +46,7 @@
(require 'sendmail) ;; for mail-sendmail-undelimit-header
(require 'mail-utils) ;; for mail-fetch-field
+(require 'browse-url)
(defcustom mailclient-place-body-on-clipboard-flag
(fboundp 'w32-set-clipboard-data)
@@ -122,7 +123,10 @@ The mail client is taken to be the handler of mailto URLs."
(while (and (re-search-forward "\n\n\n*" delimline t)
(< (point) delimline))
(replace-match "\n"))
- (let ((case-fold-search t))
+ (let ((case-fold-search t)
+ ;; Use the external browser function to send the
+ ;; message.
+ (browse-url-mailto-function nil))
;; initialize limiter
(setq mailclient-delim-static "?")
;; construct and call up mailto URL
diff --git a/lisp/mail/mailheader.el b/lisp/mail/mailheader.el
index 44967b05bc8..939e499a024 100644
--- a/lisp/mail/mailheader.el
+++ b/lisp/mail/mailheader.el
@@ -1,10 +1,11 @@
;;; mailheader.el --- mail header parsing, merging, formatting
-;; Copyright (C) 1996, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+;; 2009, 2010 Free Software Foundation, Inc.
;; Author: Erik Naggum <erik@naggum.no>
;; Keywords: tools, mail, news
+;; Package: mail-utils
;; This file is part of GNU Emacs.
@@ -48,9 +49,6 @@
(eval-when-compile
(require 'cl))
-;; Make the byte-compiler shut up.
-(defvar headers)
-
(defun mail-header-extract ()
"Extract headers from current buffer after point.
Returns a header alist, where each element is a cons cell (name . value),
@@ -104,6 +102,9 @@ value."
(cons (cdr header) (funcall (cdr rule) (cdr header))))))))
headers)
+;; Advertized part of the interface; see mail-header, mail-header-set.
+(defvar headers)
+
(defsubst mail-header (header &optional header-alist)
"Return the value associated with header HEADER in HEADER-ALIST.
If the value is a string, it is the original value of the header. If the
@@ -190,5 +191,4 @@ A key of nil has as its value a list of defaulted headers to ignore."
(provide 'mailheader)
-;; arch-tag: 6e7aa221-80b5-4b3d-b46f-fd66ab567be0
;;; mailheader.el ends here
diff --git a/lisp/mail/metamail.el b/lisp/mail/metamail.el
index 64c7c57f8db..47326b636a1 100644
--- a/lisp/mail/metamail.el
+++ b/lisp/mail/metamail.el
@@ -40,7 +40,6 @@
(defgroup metamail nil
"Metamail interface for Emacs."
:group 'mail
- :group 'hypermedia
:group 'processes)
(defcustom metamail-program-name "metamail"
diff --git a/lisp/mail/mspools.el b/lisp/mail/mspools.el
index 705c06977bb..3ca0750aaf6 100644
--- a/lisp/mail/mspools.el
+++ b/lisp/mail/mspools.el
@@ -1,7 +1,7 @@
;;; mspools.el --- show mail spools waiting to be read
-;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+;; 2009, 2010 Free Software Foundation, Inc.
;; Author: Stephen Eglen <stephen@gnu.org>
;; Maintainer: Stephen Eglen <stephen@gnu.org>
@@ -172,7 +172,17 @@ your primary spool is. If this fails, set it to something like
(defvar mspools-buffer "*spools*"
"Name of buffer for displaying spool info.")
-(defvar mspools-mode-map nil
+(defvar mspools-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\C-c\C-c" 'mspools-visit-spool)
+ (define-key map "\C-m" 'mspools-visit-spool)
+ (define-key map " " 'mspools-visit-spool)
+ (define-key map "?" 'mspools-help)
+ (define-key map "q" 'mspools-quit)
+ (define-key map "n" 'next-line)
+ (define-key map "p" 'previous-line)
+ (define-key map "g" 'revert-buffer)
+ map)
"Keymap for the *spools* buffer.")
;;; Code
@@ -270,10 +280,7 @@ Buffer is not displayed if SHOW is non-nil."
))
(message "folder %s spool %s" folder-name spool-name)
- (if (eq (count-lines (point-min)
- (save-excursion
- (end-of-line)
- (point)))
+ (if (eq (count-lines (point-min) (point-at-eol))
mspools-files-len)
(forward-line (- 1 mspools-files-len)) ;back to top of list
;; else just on to next line
@@ -313,28 +320,9 @@ Buffer is not displayed if SHOW is non-nil."
(defun mspools-get-spool-name ()
"Return the name of the spool on the current line."
- (let ((line-num (1- (count-lines (point-min)
- (save-excursion
- (end-of-line)
- (point))
- ))))
+ (let ((line-num (1- (count-lines (point-min) (point-at-eol)))))
(car (nth line-num mspools-files))))
-;;; Keymap
-
-(if mspools-mode-map
- ()
- (setq mspools-mode-map (make-sparse-keymap))
-
- (define-key mspools-mode-map "\C-c\C-c" 'mspools-visit-spool)
- (define-key mspools-mode-map "\C-m" 'mspools-visit-spool)
- (define-key mspools-mode-map " " 'mspools-visit-spool)
- (define-key mspools-mode-map "?" 'mspools-help)
- (define-key mspools-mode-map "q" 'mspools-quit)
- (define-key mspools-mode-map "n" 'next-line)
- (define-key mspools-mode-map "p" 'previous-line)
- (define-key mspools-mode-map "g" 'revert-buffer))
-
;;; Spools mode functions
(defun mspools-revert-buffer (ignore noconfirm)
@@ -416,5 +404,4 @@ nil."
(provide 'mspools)
-;; arch-tag: 8990b3ee-68c8-4892-98f1-51a735c8bac6
;;; mspools.el ends here
diff --git a/lisp/mail/rfc2368.el b/lisp/mail/rfc2368.el
index f04cf3fc466..0c91fcd8394 100644
--- a/lisp/mail/rfc2368.el
+++ b/lisp/mail/rfc2368.el
@@ -92,13 +92,11 @@ Note: make sure MAILTO-URL has been 'unhtmlized' (e.g. &amp; -> &), before
calling this function."
(let ((case-fold-search t)
prequery query headers-alist)
-
+ (setq mailto-url (replace-regexp-in-string "\n" " " mailto-url))
(if (string-match rfc2368-mailto-regexp mailto-url)
(progn
-
(setq prequery
(match-string rfc2368-mailto-prequery-index mailto-url))
-
(setq query
(match-string rfc2368-mailto-query-index mailto-url))
@@ -131,10 +129,8 @@ calling this function."
headers-alist)
- (error "Failed to match a mailto: url"))
- ))
+ (error "Failed to match a mailto: url"))))
(provide 'rfc2368)
-;; arch-tag: ea804934-ad96-4f69-957b-857a76e4fd95
;;; rfc2368.el ends here
diff --git a/lisp/mail/rmail-spam-filter.el b/lisp/mail/rmail-spam-filter.el
index a3eee899a68..33f3be30cc2 100644
--- a/lisp/mail/rmail-spam-filter.el
+++ b/lisp/mail/rmail-spam-filter.el
@@ -4,6 +4,7 @@
;; Free Software Foundation, Inc.
;; Keywords: email, spam, filter, rmail
;; Author: Eli Tziperman <eli AT deas.harvard.edu>
+;; Package: rmail
;; This file is part of GNU Emacs.
diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el
index ff04b76bf82..a2629dfe1c7 100644
--- a/lisp/mail/rmail.el
+++ b/lisp/mail/rmail.el
@@ -3834,9 +3834,7 @@ The message should be narrowed to just the headers."
(1- (point))
(point-max)))))))
-(declare-function mail-sendmail-delimit-header "sendmail" ())
-(declare-function mail-header-end "sendmail" ())
-(declare-function mail-position-on-field "sendmail" (field &optional soft))
+(autoload 'mail-position-on-field "sendmail")
(defun rmail-retry-failure ()
"Edit a mail message which is based on the contents of the current message.
@@ -3922,18 +3920,19 @@ specifying headers which should not be copied into the new message."
;; Insert original text as initial text of new draft message.
;; Bind inhibit-read-only since the header delimiter
;; of the previous message was probably read-only.
- (let ((inhibit-read-only t))
+ (let ((inhibit-read-only t)
+ eoh)
(erase-buffer)
(insert-buffer-substring rmail-this-buffer
bounce-start bounce-end)
(goto-char (point-min))
(if bounce-indent
(indent-rigidly (point-min) (point-max) bounce-indent))
- ;; FIXME better to replace sendmail functions.
- (require 'sendmail)
- (mail-sendmail-delimit-header)
+ (rfc822-goto-eoh)
+ (setq eoh (point))
+ (insert mail-header-separator)
(save-restriction
- (narrow-to-region (point-min) (mail-header-end))
+ (narrow-to-region (point-min) eoh)
(rmail-delete-headers rmail-retry-ignored-headers)
(rmail-delete-headers "^\\(sender\\|return-path\\|received\\):")
(setq resending (mail-fetch-field "resent-to"))
@@ -4235,7 +4234,7 @@ encoded string (and the same mask) will decode the string."
;;; Start of automatically extracted autoloads.
;;;### (autoloads (rmail-edit-current-message) "rmailedit" "rmailedit.el"
-;;;;;; "60db8013bf16d7999914a16cda435287")
+;;;;;; "4bf8a5cdfc921b9e30680ee71b7f9ca6")
;;; Generated autoloads from rmailedit.el
(autoload 'rmail-edit-current-message "rmailedit" "\
@@ -4247,7 +4246,7 @@ Edit the contents of this message.
;;;### (autoloads (rmail-next-labeled-message rmail-previous-labeled-message
;;;;;; rmail-read-label rmail-kill-label rmail-add-label) "rmailkwd"
-;;;;;; "rmailkwd.el" "7027ce1ac922c0dd51262b641e4d42c1")
+;;;;;; "rmailkwd.el" "112240cbb53c402294013cc49987771a")
;;; Generated autoloads from rmailkwd.el
(autoload 'rmail-add-label "rmailkwd" "\
@@ -4290,7 +4289,7 @@ With prefix argument N moves forward N messages with these labels.
;;;***
-;;;### (autoloads (rmail-mime) "rmailmm" "rmailmm.el" "4a7502b4aeb3bd5f2111b48cc6512924")
+;;;### (autoloads (rmail-mime) "rmailmm" "rmailmm.el" "9f67f3b67de9b700b128b73c52abfefa")
;;; Generated autoloads from rmailmm.el
(autoload 'rmail-mime "rmailmm" "\
@@ -4306,7 +4305,7 @@ attachments as specfied by `rmail-mime-attachment-dirs-alist'.
;;;***
;;;### (autoloads (set-rmail-inbox-list) "rmailmsc" "rmailmsc.el"
-;;;;;; "b2a72d4e370f2d2b31b6f8f0794820e4")
+;;;;;; "c3575020691d5769bcf08ecc932304c3")
;;; Generated autoloads from rmailmsc.el
(autoload 'set-rmail-inbox-list "rmailmsc" "\
@@ -4322,7 +4321,7 @@ This applies only to the current session.
;;;### (autoloads (rmail-sort-by-labels rmail-sort-by-lines rmail-sort-by-correspondent
;;;;;; rmail-sort-by-recipient rmail-sort-by-author rmail-sort-by-subject
-;;;;;; rmail-sort-by-date) "rmailsort" "rmailsort.el" "5a3b5ee477d2fbf79d0c566d776a7fd4")
+;;;;;; rmail-sort-by-date) "rmailsort" "rmailsort.el" "b96e85edd736f23f1e9d54a299268d1e")
;;; Generated autoloads from rmailsort.el
(autoload 'rmail-sort-by-date "rmailsort" "\
@@ -4381,7 +4380,7 @@ If prefix argument REVERSE is non-nil, sorts in reverse order.
;;;### (autoloads (rmail-summary-by-senders rmail-summary-by-topic
;;;;;; rmail-summary-by-regexp rmail-summary-by-recipients rmail-summary-by-labels
-;;;;;; rmail-summary) "rmailsum" "rmailsum.el" "26b95919c7e1f8c5609ce7323aee77ae")
+;;;;;; rmail-summary) "rmailsum" "rmailsum.el" "4715fb58fb191bf6b192458ea75524b2")
;;; Generated autoloads from rmailsum.el
(autoload 'rmail-summary "rmailsum" "\
@@ -4452,5 +4451,4 @@ following the containing message.
(provide 'rmail)
-;; arch-tag: 65d257d3-c281-4a65-9c38-e61af95af2f0
;;; rmail.el ends here
diff --git a/lisp/mail/rmailedit.el b/lisp/mail/rmailedit.el
index d01773fe6c9..02f36fd47e7 100644
--- a/lisp/mail/rmailedit.el
+++ b/lisp/mail/rmailedit.el
@@ -5,6 +5,7 @@
;; Maintainer: FSF
;; Keywords: mail
+;; Package: rmail
;; This file is part of GNU Emacs.
diff --git a/lisp/mail/rmailkwd.el b/lisp/mail/rmailkwd.el
index 5b9b95e5bbb..5c44b5cafa2 100644
--- a/lisp/mail/rmailkwd.el
+++ b/lisp/mail/rmailkwd.el
@@ -5,6 +5,7 @@
;; Maintainer: FSF
;; Keywords: mail
+;; Package: rmail
;; This file is part of GNU Emacs.
diff --git a/lisp/mail/rmailmm.el b/lisp/mail/rmailmm.el
index 2c1269ee3f1..918d2dfc365 100644
--- a/lisp/mail/rmailmm.el
+++ b/lisp/mail/rmailmm.el
@@ -6,6 +6,7 @@
;; Alex Schroeder
;; Maintainer: FSF
;; Keywords: mail
+;; Package: rmail
;; This file is part of GNU Emacs.
diff --git a/lisp/mail/rmailmsc.el b/lisp/mail/rmailmsc.el
index fe8a627fe6b..bbb8233d89c 100644
--- a/lisp/mail/rmailmsc.el
+++ b/lisp/mail/rmailmsc.el
@@ -5,6 +5,7 @@
;; Maintainer: FSF
;; Keywords: mail
+;; Package: rmail
;; This file is part of GNU Emacs.
diff --git a/lisp/mail/rmailout.el b/lisp/mail/rmailout.el
index a6ff75e4efe..93d512336dc 100644
--- a/lisp/mail/rmailout.el
+++ b/lisp/mail/rmailout.el
@@ -5,6 +5,7 @@
;; Maintainer: FSF
;; Keywords: mail
+;; Package: rmail
;; This file is part of GNU Emacs.
diff --git a/lisp/mail/rmailsort.el b/lisp/mail/rmailsort.el
index f44f36bd5ee..f4fd52c10c7 100644
--- a/lisp/mail/rmailsort.el
+++ b/lisp/mail/rmailsort.el
@@ -6,6 +6,7 @@
;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp>
;; Maintainer: FSF
;; Keywords: mail
+;; Package: rmail
;; This file is part of GNU Emacs.
diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el
index 2d8019b6834..f1efb33e6cb 100644
--- a/lisp/mail/rmailsum.el
+++ b/lisp/mail/rmailsum.el
@@ -5,6 +5,7 @@
;; Maintainer: FSF
;; Keywords: mail
+;; Package: rmail
;; This file is part of GNU Emacs.
diff --git a/lisp/mail/sendmail.el b/lisp/mail/sendmail.el
index 3cc1bf5fe19..7a9ab601bcc 100644
--- a/lisp/mail/sendmail.el
+++ b/lisp/mail/sendmail.el
@@ -285,14 +285,14 @@ regardless of what part of it (if any) is included in the cited text.")
;;;###autoload
(defcustom mail-citation-prefix-regexp
- (purecopy "\\([ \t]*\\(\\w\\|[_.]\\)+>+\\|[ \t]*[]>|}]\\)+")
+ (purecopy "\\([ \t]*\\(\\w\\|[_.]\\)+>+\\|[ \t]*[]>|]\\)+")
"Regular expression to match a citation prefix plus whitespace.
It should match whatever sort of citation prefixes you want to handle,
with whitespace before and after; it should also match just whitespace.
The default value matches citations like `foo-bar>' plus whitespace."
:type 'regexp
:group 'sendmail
- :version "20.3")
+ :version "24.1")
(defvar mail-abbrevs-loaded nil)
(defvar mail-mode-map
@@ -383,15 +383,8 @@ The default value matches citations like `foo-bar>' plus whitespace."
map))
(autoload 'build-mail-aliases "mailalias"
- "Read mail aliases from user's personal aliases file and set `mail-aliases'."
- nil)
-
-(autoload 'expand-mail-aliases "mailalias"
- "Expand all mail aliases in suitable header fields found between BEG and END.
-Suitable header fields are `To', `Cc' and `Bcc' and their `Resent-' variants.
-Optional second arg EXCLUDE may be a regular expression defining text to be
-removed from alias expansions."
- nil)
+ "Read mail aliases from personal aliases file and set `mail-aliases'.
+By default, this is the file specified by `mail-personal-alias-file'.")
;;;###autoload
(defcustom mail-signature t
@@ -718,7 +711,7 @@ Leave point at the start of the delimiter line."
"Carry out Auto Fill for Mail mode.
If within the headers, this makes the new lines into continuation lines."
(if (< (point) (mail-header-end))
- (let ((old-line-start (save-excursion (beginning-of-line) (point))))
+ (let ((old-line-start (line-beginning-position)))
(if (do-auto-fill)
(save-excursion
(beginning-of-line)
@@ -1096,23 +1089,23 @@ external program defined by `sendmail-program'."
;; Delete Resent-BCC ourselves
(if (save-excursion (beginning-of-line)
(looking-at "resent-bcc"))
- (delete-region (save-excursion (beginning-of-line) (point))
- (save-excursion (end-of-line) (1+ (point))))))
-;;; Apparently this causes a duplicate Sender.
-;;; ;; If the From is different than current user, insert Sender.
-;;; (goto-char (point-min))
-;;; (and (re-search-forward "^From:" delimline t)
-;;; (progn
-;;; (require 'mail-utils)
-;;; (not (string-equal
-;;; (mail-strip-quoted-names
-;;; (save-restriction
-;;; (narrow-to-region (point-min) delimline)
-;;; (mail-fetch-field "From")))
-;;; (user-login-name))))
-;;; (progn
-;;; (forward-line 1)
-;;; (insert "Sender: " (user-login-name) "\n")))
+ (delete-region (line-beginning-position)
+ (line-beginning-position 2))))
+ ;; Apparently this causes a duplicate Sender.
+ ;; ;; If the From is different than current user, insert Sender.
+ ;; (goto-char (point-min))
+ ;; (and (re-search-forward "^From:" delimline t)
+ ;; (progn
+ ;; (require 'mail-utils)
+ ;; (not (string-equal
+ ;; (mail-strip-quoted-names
+ ;; (save-restriction
+ ;; (narrow-to-region (point-min) delimline)
+ ;; (mail-fetch-field "From")))
+ ;; (user-login-name))))
+ ;; (progn
+ ;; (forward-line 1)
+ ;; (insert "Sender: " (user-login-name) "\n")))
;; Don't send out a blank subject line
(goto-char (point-min))
(if (re-search-forward "^Subject:\\([ \t]*\n\\)+\\b" delimline t)
@@ -1149,8 +1142,7 @@ external program defined by `sendmail-program'."
;; should override any specified in the message itself.
(when where-content-type
(goto-char where-content-type)
- (beginning-of-line)
- (delete-region (point)
+ (delete-region (point-at-bol)
(progn (forward-line 1) (point)))))))
;; Insert an extra newline if we need it to work around
;; Sun's bug that swallows newlines.
@@ -1179,9 +1171,9 @@ external program defined by `sendmail-program'."
nil errbuf nil "-oi")
(and envelope-from
(list "-f" envelope-from))
-;;; ;; Don't say "from root" if running under su.
-;;; (and (equal (user-real-login-name) "root")
-;;; (list "-f" (user-login-name)))
+ ;; ;; Don't say "from root" if running under su.
+ ;; (and (equal (user-real-login-name) "root")
+ ;; (list "-f" (user-login-name)))
(and mail-alias-file
(list (concat "-oA" mail-alias-file)))
(if mail-interactive
@@ -1663,6 +1655,7 @@ If the current line has `mail-yank-prefix', insert it on the new line."
;; in middle of loading the file.
;;;###autoload (add-hook 'same-window-buffer-names (purecopy "*mail*"))
+;;;###autoload (add-hook 'same-window-buffer-names (purecopy "*unsent mail*"))
;;;###autoload
(defun mail (&optional noerase to subject in-reply-to cc replybuffer actions)
@@ -1713,48 +1706,48 @@ The seventh argument ACTIONS is a list of actions to take
when the message is sent, we apply FUNCTION to ARGS.
This is how Rmail arranges to mark messages `answered'."
(interactive "P")
-;;; This is commented out because I found it was confusing in practice.
-;;; It is easy enough to rename *mail* by hand with rename-buffer
-;;; if you want to have multiple mail buffers.
-;;; And then you can control which messages to save. --rms.
-;;; (let ((index 1)
-;;; buffer)
-;;; ;; If requested, look for a mail buffer that is modified and go to it.
-;;; (if noerase
-;;; (progn
-;;; (while (and (setq buffer
-;;; (get-buffer (if (= 1 index) "*mail*"
-;;; (format "*mail*<%d>" index))))
-;;; (not (buffer-modified-p buffer)))
-;;; (setq index (1+ index)))
-;;; (if buffer (switch-to-buffer buffer)
-;;; ;; If none exists, start a new message.
-;;; ;; This will never re-use an existing unmodified mail buffer
-;;; ;; (since index is not 1 anymore). Perhaps it should.
-;;; (setq noerase nil))))
-;;; ;; Unless we found a modified message and are happy, start a new message.
-;;; (if (not noerase)
-;;; (progn
-;;; ;; Look for existing unmodified mail buffer.
-;;; (while (and (setq buffer
-;;; (get-buffer (if (= 1 index) "*mail*"
-;;; (format "*mail*<%d>" index))))
-;;; (buffer-modified-p buffer))
-;;; (setq index (1+ index)))
-;;; ;; If none, make a new one.
-;;; (or buffer
-;;; (setq buffer (generate-new-buffer "*mail*")))
-;;; ;; Go there and initialize it.
-;;; (switch-to-buffer buffer)
-;;; (erase-buffer)
-;;; (setq default-directory (expand-file-name "~/"))
-;;; (auto-save-mode auto-save-default)
-;;; (mail-mode)
-;;; (mail-setup to subject in-reply-to cc replybuffer actions)
-;;; (if (and buffer-auto-save-file-name
-;;; (file-exists-p buffer-auto-save-file-name))
-;;; (message "Auto save file for draft message exists; consider M-x mail-recover"))
-;;; t))
+ ;; This is commented out because I found it was confusing in practice.
+ ;; It is easy enough to rename *mail* by hand with rename-buffer
+ ;; if you want to have multiple mail buffers.
+ ;; And then you can control which messages to save. --rms.
+ ;; (let ((index 1)
+ ;; buffer)
+ ;; ;; If requested, look for a mail buffer that is modified and go to it.
+ ;; (if noerase
+ ;; (progn
+ ;; (while (and (setq buffer
+ ;; (get-buffer (if (= 1 index) "*mail*"
+ ;; (format "*mail*<%d>" index))))
+ ;; (not (buffer-modified-p buffer)))
+ ;; (setq index (1+ index)))
+ ;; (if buffer (switch-to-buffer buffer)
+ ;; ;; If none exists, start a new message.
+ ;; ;; This will never re-use an existing unmodified mail buffer
+ ;; ;; (since index is not 1 anymore). Perhaps it should.
+ ;; (setq noerase nil))))
+ ;; ;; Unless we found a modified message and are happy, start a new message.
+ ;; (if (not noerase)
+ ;; (progn
+ ;; ;; Look for existing unmodified mail buffer.
+ ;; (while (and (setq buffer
+ ;; (get-buffer (if (= 1 index) "*mail*"
+ ;; (format "*mail*<%d>" index))))
+ ;; (buffer-modified-p buffer))
+ ;; (setq index (1+ index)))
+ ;; ;; If none, make a new one.
+ ;; (or buffer
+ ;; (setq buffer (generate-new-buffer "*mail*")))
+ ;; ;; Go there and initialize it.
+ ;; (switch-to-buffer buffer)
+ ;; (erase-buffer)
+ ;; (setq default-directory (expand-file-name "~/"))
+ ;; (auto-save-mode auto-save-default)
+ ;; (mail-mode)
+ ;; (mail-setup to subject in-reply-to cc replybuffer actions)
+ ;; (if (and buffer-auto-save-file-name
+ ;; (file-exists-p buffer-auto-save-file-name))
+ ;; (message "Auto save file for draft message exists; consider M-x mail-recover"))
+ ;; t))
(if (eq noerase 'new)
(pop-to-buffer (generate-new-buffer "*mail*"))
@@ -1775,7 +1768,7 @@ The seventh argument ACTIONS is a list of actions to take
(mail-mode)
;; Disconnect the buffer from its visited file
;; (in case the user has actually visited a file *mail*).
-;;; (set-visited-file-name nil)
+ ;; (set-visited-file-name nil)
(let (initialized)
(and (not (and noerase
(not (eq noerase 'new))))
@@ -1954,5 +1947,4 @@ you can move to one of them and type C-c C-c to recover that one."
(provide 'sendmail)
-;; arch-tag: 48bc1025-d993-4d31-8d81-2a29491f0626
;;; sendmail.el ends here
diff --git a/lisp/mail/supercite.el b/lisp/mail/supercite.el
index f3636c6504f..1660721fe21 100644
--- a/lisp/mail/supercite.el
+++ b/lisp/mail/supercite.el
@@ -34,7 +34,6 @@
(require 'regi)
-(require 'sendmail) ;; For mail-header-end.
;; start user configuration variables
;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
@@ -1484,18 +1483,22 @@ non-nil."
"Does nothing. Use this instead of nil to get a blank header."
())
-(defun sc-no-blank-line-or-header()
+(declare-function mh-in-header-p "mh-utils" ())
+
+(defun sc-no-blank-line-or-header ()
"Similar to `sc-no-header' except it removes the preceding blank line."
- (if (not (bobp))
- (if (and (eolp)
- (progn (forward-line -1)
- (or (= (point) (mail-header-end))
- (and (eq major-mode 'mh-letter-mode)
- (with-no-warnings
- (mh-in-header-p))))))
- (progn (forward-line)
- (let ((kill-lines-magic t))
- (kill-line))))))
+ (and (not (bobp))
+ (eolp)
+ (progn (forward-line -1)
+ (or (= (point)
+ (save-excursion
+ (rfc822-goto-eoh)
+ (line-beginning-position 2)))
+ (and (eq major-mode 'mh-letter-mode)
+ (mh-in-header-p))))
+ (progn
+ (forward-line)
+ (kill-line))))
(defun sc-header-on-said ()
"\"On <date>, <from> said:\" unless:
@@ -1616,21 +1619,20 @@ error occurs."
(cadr err) sc-eref-style)
(beep))))))
-(defun sc-electric-mode (&optional arg)
- "
-Mode for viewing Supercite reference headers. Commands are:
+(defun sc-electric-mode (&optional style)
+ "Mode for viewing Supercite reference headers. Commands are:
\n\\{sc-electric-mode-map}
`sc-electric-mode' is not intended to be run interactively, but rather
accessed through Supercite's electric reference feature. See
-`sc-insert-reference' for more details. Optional ARG is the initial
+`sc-insert-reference' for more details. Optional STYLE is the initial
header style to use, unless not supplied or invalid, in which case
`sc-preferred-header-style' is used."
(let ((info sc-mail-info))
(setq sc-eref-style
- (or (sc-valid-index-p arg)
+ (or (sc-valid-index-p style)
(sc-valid-index-p sc-preferred-header-style)
0))
diff --git a/lisp/mail/uudecode.el b/lisp/mail/uudecode.el
index 335e1e10c47..7ab2fcd1c62 100644
--- a/lisp/mail/uudecode.el
+++ b/lisp/mail/uudecode.el
@@ -216,7 +216,7 @@ If FILE-NAME is non-nil, save the result to FILE-NAME."
(skip-chars-forward non-data-chars end))
(if file-name
(with-temp-file file-name
- (set-buffer-multibyte nil)
+ (unless (featurep 'xemacs) (set-buffer-multibyte nil))
(insert (apply 'concat (nreverse result))))
(or (markerp end) (setq end (set-marker (make-marker) end)))
(goto-char start)
@@ -236,5 +236,4 @@ If FILE-NAME is non-nil, save the result to FILE-NAME."
(provide 'uudecode)
-;; arch-tag: e1f09ed5-62b4-4677-9f13-4e81c4fe8ce3
;;; uudecode.el ends here
diff --git a/lisp/makefile.w32-in b/lisp/makefile.w32-in
index aebb8b352e7..cd76ffa290a 100644
--- a/lisp/makefile.w32-in
+++ b/lisp/makefile.w32-in
@@ -32,10 +32,9 @@ srcdir = $(CURDIR)/..
EMACS = $(THISDIR)/../bin/emacs.exe
-# Command line flags for Emacs. This must include --multibyte,
-# otherwise some files will not compile.
+# Command line flags for Emacs.
-EMACSOPT = -batch --no-init-file --no-site-file --multibyte
+EMACSOPT = -batch --no-init-file --no-site-file
# Extra flags to pass to the byte compiler
BYTE_COMPILE_EXTRA_FLAGS =
@@ -51,12 +50,16 @@ LC_ALL = C
lisptagsfiles1 = $(lisp)/*.el
lisptagsfiles2 = $(lisp)/*/*.el
-ETAGS = "../lib-src/$(BLD)/etags"
+lisptagsfiles3 = $(lisp)/*/*/*.el
+lisptagsfiles4 = $(lisp)/*/*/*/*.el
+ETAGS = "../lib-src/$(BLD)/etags.exe"
+## $(DEST) is overridden by ../src/makefile.w32-in.
+DEST=$(lisp)
# Automatically generated autoload files, apart from lisp/loaddefs.el.
LOADDEFS = $(lisp)/calendar/cal-loaddefs.el \
$(lisp)/calendar/diary-loaddefs.el $(lisp)/calendar/hol-loaddefs.el \
- $(lisp)/mh-e/mh-loaddefs.el
+ $(lisp)/mh-e/mh-loaddefs.el $(lisp)/net/tramp-loaddefs.el
AUTOGENEL = $(lisp)/loaddefs.el $(LOADDEFS) $(lisp)/cus-load.el \
$(lisp)/finder-inf.el $(lisp)/subdirs.el $(lisp)/eshell/esh-groups.el \
@@ -114,7 +117,8 @@ WINS_BASIC=\
play \
progmodes \
textmodes \
- url
+ url \
+ vc
# Directories with lisp files to compile, and to extract data from
# (customs, autoloads, etc.)
@@ -244,11 +248,42 @@ cvs-update: bzr-update
update-authors:
$(emacs) -l authors -f batch-update-authors $(srcdir)/etc/AUTHORS $(srcdir)
-TAGS: $(lisptagsfiles1) $(lisptagsfiles2)
- $(ETAGS) $(lisptagsfiles1) $(lisptagsfiles2)
+TAGS: TAGS-$(MAKETYPE)
-TAGS-LISP: $(lisptagsfiles1) $(lisptagsfiles2)
- $(ETAGS) -o TAGS-LISP $(lisptagsfiles1) $(lisptagsfiles2)
+TAGS-LISP: TAGS-LISP-$(MAKETYPE)
+
+TAGS-nmake:
+ echo This target is not supported with NMake
+ exit -1
+
+TAGS-LISP-nmake:
+ echo This target is not supported with NMake
+ exit -1
+
+TAGS-gmake: TAGS-$(SHELLTYPE)
+
+TAGS-LISP-gmake: TAGS-LISP-$(SHELLTYPE)
+
+TAGS-SH: $(lisptagsfiles1) $(lisptagsfiles2) $(lisptagsfiles3) $(lisptagsfiles4)
+ - $(DEL) TAGS
+ for dir in . $(WINS_UPDATES); do \
+ $(ETAGS) -a $(lisp)/$$dir/*.el; \
+ done
+
+TAGS-LISP-SH: $(lisptagsfiles1) $(lisptagsfiles2) $(lisptagsfiles3) $(lisptagsfiles4)
+ - $(DEL) $(DEST)/TAGS-LISP
+ for dir in . $(WINS_UPDATES); do \
+ $(ETAGS) -a -o $(DEST)/TAGS-LISP $(lisp)/$$dir/*.el; \
+ done
+
+TAGS-CMD: $(lisptagsfiles1) $(lisptagsfiles2) $(lisptagsfiles3) $(lisptagsfiles4)
+ - $(DEL) TAGS
+ for %%d in (. $(WINS_UPDATES)) do $(ETAGS) -a $(lisp)/%%d/*.el
+
+TAGS-LISP-CMD: $(lisptagsfiles1) $(lisptagsfiles2) $(lisptagsfiles3) $(lisptagsfiles4)
+ - $(DEL) $(DEST)/TAGS-LISP
+ for %%d in (. $(WINS_UPDATES)) do \
+ $(ETAGS) -a -o $(DEST)/TAGS-LISP $(lisp)/%%d/*.el
.SUFFIXES: .elc .el
@@ -403,6 +438,25 @@ $(lisp)/mh-e/mh-loaddefs.el: $(MH_E_SRC)
-f w32-batch-update-autoloads \
$(ARGQUOTE)$(lisp)/mh-e/mh-loaddefs.el$(ARGQUOTE) $(MAKE) ./mh-e
+# Update TRAMP internal autoloads. Maybe we could move tramp*.el into
+# its own subdirectory. OTOH, it does not hurt to keep them in
+# lisp/net.
+TRAMP_SRC = $(lisp)/net/tramp.el $(lisp)/net/tramp-cache.el \
+ $(lisp)/net/tramp-cmds.el $(lisp)/net/tramp-compat.el \
+ $(lisp)/net/tramp-ftp.el $(lisp)/net/tramp-gvfs.el \
+ $(lisp)/net/tramp-gw.el $(lisp)/net/tramp-imap.el \
+ $(lisp)/net/tramp-sh.el $(lisp)/net/tramp-smb.el \
+ $(lisp)/net/tramp-uu.el $(lisp)/net/trampver.el
+
+$(lisp)/net/tramp-loaddefs.el: $(TRAMP_SRC)
+ "$(EMACS)" $(EMACSOPT) \
+ -l autoload \
+ --eval $(ARGQUOTE)(setq generate-autoload-cookie $(DQUOTE);;;###tramp-autoload$(DQUOTE))$(ARGQUOTE) \
+ --eval $(ARGQUOTE)(setq find-file-suppress-same-file-warnings t)$(ARGQUOTE) \
+ --eval $(ARGQUOTE)(setq make-backup-files nil)$(ARGQUOTE) \
+ -f w32-batch-update-autoloads \
+ $(ARGQUOTE)$(lisp)/net/tramp-loaddefs.el$(ARGQUOTE) $(MAKE) ./net
+
# Prepare a bootstrap in the lisp subdirectory.
#
# Build loaddefs.el to make sure it's up-to-date. If it's not, that
diff --git a/lisp/makesum.el b/lisp/makesum.el
index c77a248eb45..4b5cd036f94 100644
--- a/lisp/makesum.el
+++ b/lisp/makesum.el
@@ -1,7 +1,7 @@
;;; makesum.el --- generate key binding summary for Emacs
-;; Copyright (C) 1985, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+;; 2009, 2010 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: help
@@ -98,7 +98,7 @@ Previous contents of that buffer are killed first."
(forward-line half)
(while (< half nlines)
(setq half (1+ half))
- (setq line (buffer-substring (point) (save-excursion (end-of-line) (point))))
+ (setq line (buffer-substring (point) (line-end-position)))
(setq lines (cons line lines))
(delete-region (point) (progn (forward-line 1) (point)))))
(setq lines (nreverse lines))
@@ -112,5 +112,4 @@ Previous contents of that buffer are killed first."
(provide 'makesum)
-;; arch-tag: c2383336-fc89-46ad-8110-ded42bffaee3
;;; makesum.el ends here
diff --git a/lisp/man.el b/lisp/man.el
index 6dde5d7c178..b1c5f37bc70 100644
--- a/lisp/man.el
+++ b/lisp/man.el
@@ -221,6 +221,11 @@ the associated section number."
:type '(repeat string)
:group 'man)
+(defcustom Man-name-local-regexp (concat "^" (regexp-opt '("NOM" "NAME")) "$")
+ "Regexp that matches the text that precedes the command's name.
+Used in `bookmark-set' to get the default bookmark name."
+ :type 'string :group 'bookmark)
+
(defvar manual-program "man"
"The name of the program that produces man pages.")
@@ -886,7 +891,8 @@ names or descriptions. The pattern argument is usually an
(man man-args)))
(defun Man-getpage-in-background (topic)
- "Use TOPIC to build and fire off the manpage and cleaning command."
+ "Use TOPIC to build and fire off the manpage and cleaning command.
+Return the buffer in which the manpage will appear."
(let* ((man-args topic)
(bufname (concat "*Man " man-args "*"))
(buffer (get-buffer bufname)))
@@ -964,15 +970,16 @@ names or descriptions. The pattern argument is usually an
(format "exited abnormally with code %d"
exit-status)))
(setq msg exit-status))
- (Man-bgproc-sentinel bufname msg)))))))
+ (Man-bgproc-sentinel bufname msg)))))
+ buffer))
(defun Man-notify-when-ready (man-buffer)
"Notify the user when MAN-BUFFER is ready.
See the variable `Man-notify-method' for the different notification behaviors."
(let ((saved-frame (with-current-buffer man-buffer
Man-original-frame)))
- (cond
- ((eq Man-notify-method 'newframe)
+ (case Man-notify-method
+ (newframe
;; Since we run asynchronously, perhaps while Emacs is waiting
;; for input, we must not leave a different buffer current. We
;; can't rely on the editor command loop to reselect the
@@ -983,28 +990,27 @@ See the variable `Man-notify-method' for the different notification behaviors."
(set-window-dedicated-p (frame-selected-window frame) t)
(or (display-multi-frame-p frame)
(select-frame frame)))))
- ((eq Man-notify-method 'pushy)
+ (pushy
(switch-to-buffer man-buffer))
- ((eq Man-notify-method 'bully)
+ (bully
(and (frame-live-p saved-frame)
(select-frame saved-frame))
(pop-to-buffer man-buffer)
(delete-other-windows))
- ((eq Man-notify-method 'aggressive)
+ (aggressive
(and (frame-live-p saved-frame)
(select-frame saved-frame))
(pop-to-buffer man-buffer))
- ((eq Man-notify-method 'friendly)
+ (friendly
(and (frame-live-p saved-frame)
(select-frame saved-frame))
(display-buffer man-buffer 'not-this-window))
- ((eq Man-notify-method 'polite)
+ (polite
(beep)
(message "Manual buffer %s is ready" (buffer-name man-buffer)))
- ((eq Man-notify-method 'quiet)
+ (quiet
(message "Manual buffer %s is ready" (buffer-name man-buffer)))
- ((or (eq Man-notify-method 'meek)
- t)
+ (t ;; meek
(message ""))
)))
@@ -1272,6 +1278,8 @@ manpage command."
;; ======================================================================
;; set up manual mode in buffer and build alists
+(defvar bookmark-make-record-function)
+
(put 'Man-mode 'mode-class 'special)
(defun Man-mode ()
@@ -1328,6 +1336,8 @@ The following key bindings are currently in effect in the buffer:
(setq imenu-generic-expression (list (list nil Man-heading-regexp 0)))
(set (make-local-variable 'outline-regexp) Man-heading-regexp)
(set (make-local-variable 'outline-level) (lambda () 1))
+ (set (make-local-variable 'bookmark-make-record-function)
+ 'Man-bookmark-make-record)
(Man-build-page-list)
(Man-strip-page-headers)
(Man-unindent)
@@ -1662,6 +1672,46 @@ Specify which REFERENCE to use; default is based on word at point."
(setq path nil))
(setq complete-path nil)))
complete-path))
+
+;;; Bookmark Man Support
+(declare-function bookmark-make-record-default
+ "bookmark" (&optional no-file no-context posn))
+(declare-function bookmark-prop-get "bookmark" (bookmark prop))
+(declare-function bookmark-default-handler "bookmark" (bmk))
+(declare-function bookmark-get-bookmark-record "bookmark" (bmk))
+
+(defun Man-default-bookmark-title ()
+ "Default bookmark name for Man or WoMan pages.
+Uses `Man-name-local-regexp'."
+ (save-excursion
+ (goto-char (point-min))
+ (when (re-search-forward Man-name-local-regexp nil t)
+ (skip-chars-forward "\n\t ")
+ (buffer-substring-no-properties (point) (line-end-position)))))
+
+(defun Man-bookmark-make-record ()
+ "Make a bookmark entry for a Man buffer."
+ `(,(Man-default-bookmark-title)
+ ,@(bookmark-make-record-default 'no-file)
+ (location . ,(concat "man " Man-arguments))
+ (man-args . ,Man-arguments)
+ (handler . Man-bookmark-jump)))
+
+;;;###autoload
+(defun Man-bookmark-jump (bookmark)
+ "Default bookmark handler for Man buffers."
+ (let* ((man-args (bookmark-prop-get bookmark 'man-args))
+ ;; Let bookmark.el do the window handling.
+ ;; This let-binding needs to be active during the call to both
+ ;; Man-getpage-in-background and accept-process-output.
+ (Man-notify-method 'meek)
+ (buf (Man-getpage-in-background man-args))
+ (proc (get-buffer-process buf)))
+ (while (and proc (eq (process-status proc) 'run))
+ (accept-process-output proc))
+ (bookmark-default-handler
+ `("" (buffer . ,buf) . ,(bookmark-get-bookmark-record bookmark)))))
+
;; Init the man package variables, if not already done.
(Man-init-defvars)
diff --git a/lisp/md4.el b/lisp/md4.el
index 32e3f376b13..6b28f757dbd 100644
--- a/lisp/md4.el
+++ b/lisp/md4.el
@@ -225,5 +225,4 @@ integers (cons high low)."
(provide 'md4)
-;; arch-tag: 99d706fe-089b-42ea-9507-67ae41091e6e
;;; md4.el ends here
diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el
index d25de5b385c..a3a28c3dcfc 100644
--- a/lisp/menu-bar.el
+++ b/lisp/menu-bar.el
@@ -6,6 +6,7 @@
;; Author: RMS
;; Maintainer: FSF
;; Keywords: internal, mouse
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -34,14 +35,33 @@
(define-key global-map [menu-bar] (make-sparse-keymap "menu-bar")))
(defvar menu-bar-help-menu (make-sparse-keymap "Help"))
-;; Force Help item to come last, after the major mode's own items.
-;; The symbol used to be called `help', but that gets confused with the
-;; help key.
-(setq menu-bar-final-items '(help-menu))
+(if (not (featurep 'ns))
+ ;; Force Help item to come last, after the major mode's own items.
+ ;; The symbol used to be called `help', but that gets confused with the
+ ;; help key.
+ (setq menu-bar-final-items '(help-menu))
+ (if (eq system-type 'darwin)
+ (setq menu-bar-final-items '(buffer services help-menu))
+ (setq menu-bar-final-items '(buffer services hide-app quit))
+ ;; Add standard top-level items to GNUstep menu.
+ (define-key global-map [menu-bar quit]
+ `(menu-item ,(purecopy "Quit") save-buffers-kill-emacs
+ :help ,(purecopy "Save unsaved buffers, then exit")))
+ (define-key global-map [menu-bar hide-app]
+ `(menu-item ,(purecopy "Hide") ns-do-hide-emacs
+ :help ,(purecopy "Hide Emacs"))))
+ (define-key global-map [menu-bar services] ; set-up in ns-win
+ (cons (purecopy "Services") (make-sparse-keymap "Services"))))
+
+;; If running under GNUstep, "Help" is moved and renamed "Info" (see below).
+(or (and (featurep 'ns)
+ (not (eq system-type 'darwin)))
+ (define-key global-map [menu-bar help-menu]
+ (cons (purecopy "Help") menu-bar-help-menu)))
-(define-key global-map [menu-bar help-menu] (cons (purecopy "Help") menu-bar-help-menu))
(defvar menu-bar-tools-menu (make-sparse-keymap "Tools"))
-(define-key global-map [menu-bar tools] (cons (purecopy "Tools") menu-bar-tools-menu))
+(define-key global-map [menu-bar tools]
+ (cons (purecopy "Tools") menu-bar-tools-menu))
;; This definition is just to show what this looks like.
;; It gets modified in place when menu-bar-update-buffers is called.
(defvar global-buffers-menu-map (make-sparse-keymap "Buffers"))
@@ -51,9 +71,17 @@
(define-key global-map [menu-bar options]
(cons (purecopy "Options") menu-bar-options-menu))
(defvar menu-bar-edit-menu (make-sparse-keymap "Edit"))
-(define-key global-map [menu-bar edit] (cons (purecopy "Edit") menu-bar-edit-menu))
+(define-key global-map [menu-bar edit]
+ (cons (purecopy "Edit") menu-bar-edit-menu))
(defvar menu-bar-file-menu (make-sparse-keymap "File"))
-(define-key global-map [menu-bar file] (cons (purecopy "File") menu-bar-file-menu))
+(define-key global-map [menu-bar file]
+ (cons (purecopy "File") menu-bar-file-menu))
+
+;; Put "Help" menu at the front, called "Info".
+(and (featurep 'ns)
+ (not (eq system-type 'darwin))
+ (define-key global-map [menu-bar help-menu]
+ (cons (purecopy "Info") menu-bar-help-menu)))
;; Only declared obsolete (and only made a proper alias) in 23.3.
(define-obsolete-variable-alias 'menu-bar-files-menu 'menu-bar-file-menu "22.1")
@@ -360,6 +388,11 @@
(define-key menu-bar-edit-menu [props]
`(menu-item ,(purecopy "Text Properties") facemenu-menu))
+;; ns-win.el said: Add spell for platorm consistency.
+(if (featurep 'ns)
+ (define-key menu-bar-edit-menu [spell]
+ `(menu-item ,(purecopy "Spell") ispell-menu-map)))
+
(define-key menu-bar-edit-menu [fill]
`(menu-item ,(purecopy "Fill") fill-region
:enable (and mark-active (not buffer-read-only))
@@ -452,30 +485,45 @@
,(purecopy "Delete the text in region between mark and current position")))
(defvar yank-menu (cons (purecopy "Select Yank") nil))
(fset 'yank-menu (cons 'keymap yank-menu))
-(define-key menu-bar-edit-menu [paste-from-menu]
- `(menu-item ,(purecopy "Paste from Kill Menu") yank-menu
+(define-key menu-bar-edit-menu (if (featurep 'ns) [select-paste]
+ [paste-from-menu])
+ ;; ns-win.el said: Change text to be more consistent with
+ ;; surrounding menu items `paste', etc."
+ `(menu-item ,(purecopy (if (featurep 'ns) "Select and Paste"
+ "Paste from Kill Menu")) yank-menu
:enable (and (cdr yank-menu) (not buffer-read-only))
:help ,(purecopy "Choose a string from the kill ring and paste it")))
(define-key menu-bar-edit-menu [paste]
`(menu-item ,(purecopy "Paste") yank
:enable (and (or
- ;; Emacs compiled --without-x doesn't have
- ;; x-selection-exists-p.
+ ;; Emacs compiled --without-x (or --with-ns)
+ ;; doesn't have x-selection-exists-p.
(and (fboundp 'x-selection-exists-p)
- (x-selection-exists-p))
- kill-ring)
+ (x-selection-exists-p 'CLIPBOARD))
+ (if (featurep 'ns) ; like paste-from-menu
+ (cdr yank-menu)
+ kill-ring))
(not buffer-read-only))
:help ,(purecopy "Paste (yank) text most recently cut/copied")))
(define-key menu-bar-edit-menu [copy]
- `(menu-item ,(purecopy "Copy") menu-bar-kill-ring-save
- :enable mark-active
- :help ,(purecopy "Copy text in region between mark and current position")
- :keys ,(purecopy "\\[kill-ring-save]")))
+ ;; ns-win.el said: Substitute a Copy function that works better
+ ;; under X (for GNUstep).
+ `(menu-item ,(purecopy "Copy") ,(if (featurep 'ns)
+ 'ns-copy-including-secondary
+ 'menu-bar-kill-ring-save)
+ :enable mark-active
+ :help ,(purecopy "Copy text in region between mark and current position")
+ :keys ,(purecopy (if (featurep 'ns)
+ "\\[ns-copy-including-secondary]"
+ "\\[kill-ring-save]"))))
(define-key menu-bar-edit-menu [cut]
`(menu-item ,(purecopy "Cut") kill-region
:enable (and mark-active (not buffer-read-only))
:help
,(purecopy "Cut (kill) text in region between mark and current position")))
+;; ns-win.el said: Separate undo from cut/paste section.
+(if (featurep 'ns)
+ (define-key menu-bar-edit-menu [separator-undo] `(,(purecopy "--"))))
(define-key menu-bar-edit-menu [undo]
`(menu-item ,(purecopy "Undo") undo
:enable (and (not buffer-read-only)
@@ -485,7 +533,6 @@
(consp buffer-undo-list)))
:help ,(purecopy "Undo last operation")))
-
(defun menu-bar-kill-ring-save (beg end)
(interactive "r")
(if (mouse-region-match)
@@ -526,17 +573,6 @@
"Make CUT, PASTE and COPY (keys and menu bar items) use the clipboard.
Do the same for the keys of the same name."
(interactive)
- ;; We can't use constant list structure here because it becomes pure,
- ;; and because it gets modified with cache data.
- (define-key menu-bar-edit-menu [paste]
- (cons "Paste" (cons "Paste text from clipboard" 'clipboard-yank)))
- (define-key menu-bar-edit-menu [copy]
- (cons "Copy" (cons "Copy text in region to the clipboard"
- 'clipboard-kill-ring-save)))
- (define-key menu-bar-edit-menu [cut]
- (cons "Cut" (cons "Delete text in region and copy it to the clipboard"
- 'clipboard-kill-region)))
-
;; These are Sun server keysyms for the Cut, Copy and Paste keys
;; (also for XFree86 on Sun keyboard):
(define-key global-map [f20] 'clipboard-kill-region)
@@ -701,7 +737,7 @@ by \"Save Options\" in Custom buffers.")
;; Nonetheless, not saving it would like be confuse
;; more often.
;; -- Per Abrahamsen <abraham@dina.kvl.dk> 2002-02-11.
- text-mode-hook))
+ text-mode-hook tool-bar-position))
(and (get elt 'customized-value)
(customize-mark-to-save elt)
(setq need-save t)))
@@ -713,6 +749,10 @@ by \"Save Options\" in Custom buffers.")
(when need-save
(custom-save-all))))
+(define-key menu-bar-options-menu [package]
+ '(menu-item "Manage Emacs Packages" package-list-packages
+ :help "Install or uninstall additional Emacs packages"))
+
(define-key menu-bar-options-menu [save]
`(menu-item ,(purecopy "Save Options") menu-bar-options-save
:help ,(purecopy "Save options set from the menu above")))
@@ -985,11 +1025,93 @@ mail status in mode line"))
:help ,(purecopy "Turn menu-bar on/off")
:button (:toggle . (> (frame-parameter nil 'menu-bar-lines) 0))))
-(define-key menu-bar-showhide-menu [showhide-tool-bar]
- `(menu-item ,(purecopy "Tool-bar") toggle-tool-bar-mode-from-frame
- :help ,(purecopy "Turn tool-bar on/off")
- :visible (display-graphic-p)
- :button (:toggle . (> (frame-parameter nil 'tool-bar-lines) 0))))
+(defun menu-bar-set-tool-bar-position (position)
+ (customize-set-variable 'tool-bar-mode t)
+ (customize-set-variable 'tool-bar-position position))
+(defun menu-bar-showhide-tool-bar-menu-customize-disable ()
+ "Do not display tool bars."
+ (interactive)
+ (customize-set-variable 'tool-bar-mode nil))
+(defun menu-bar-showhide-tool-bar-menu-customize-enable-left ()
+ "Display tool bars on the left side."
+ (interactive)
+ (menu-bar-set-tool-bar-position 'left))
+(defun menu-bar-showhide-tool-bar-menu-customize-enable-right ()
+ "Display tool bars on the right side."
+ (interactive)
+ (menu-bar-set-tool-bar-position 'right))
+(defun menu-bar-showhide-tool-bar-menu-customize-enable-top ()
+ "Display tool bars on the top side."
+ (interactive)
+ (menu-bar-set-tool-bar-position 'top))
+(defun menu-bar-showhide-tool-bar-menu-customize-enable-bottom ()
+ "Display tool bars on the bottom side."
+ (interactive)
+ (menu-bar-set-tool-bar-position 'bottom))
+
+(if (featurep 'move-toolbar)
+ (progn
+ (defvar menu-bar-showhide-tool-bar-menu (make-sparse-keymap "Tool-bar"))
+
+ (define-key menu-bar-showhide-tool-bar-menu [showhide-tool-bar-left]
+ `(menu-item ,(purecopy "On the left")
+ menu-bar-showhide-tool-bar-menu-customize-enable-left
+ :help ,(purecopy "Tool-bar at the left side")
+ :visible (display-graphic-p)
+ :button
+ (:radio . (and tool-bar-mode
+ (eq (frame-parameter nil 'tool-bar-position)
+ 'left)))))
+
+ (define-key menu-bar-showhide-tool-bar-menu [showhide-tool-bar-right]
+ `(menu-item ,(purecopy "On the right")
+ menu-bar-showhide-tool-bar-menu-customize-enable-right
+ :help ,(purecopy "Tool-bar at the right side")
+ :visible (display-graphic-p)
+ :button
+ (:radio . (and tool-bar-mode
+ (eq (frame-parameter nil 'tool-bar-position)
+ 'right)))))
+
+ (define-key menu-bar-showhide-tool-bar-menu [showhide-tool-bar-bottom]
+ `(menu-item ,(purecopy "On the bottom")
+ menu-bar-showhide-tool-bar-menu-customize-enable-bottom
+ :help ,(purecopy "Tool-bar at the bottom")
+ :visible (display-graphic-p)
+ :button
+ (:radio . (and tool-bar-mode
+ (eq (frame-parameter nil 'tool-bar-position)
+ 'bottom)))))
+
+ (define-key menu-bar-showhide-tool-bar-menu [showhide-tool-bar-top]
+ `(menu-item ,(purecopy "On the top")
+ menu-bar-showhide-tool-bar-menu-customize-enable-top
+ :help ,(purecopy "Tool-bar at the top")
+ :visible (display-graphic-p)
+ :button
+ (:radio . (and tool-bar-mode
+ (eq (frame-parameter nil 'tool-bar-position)
+ 'top)))))
+
+ (define-key menu-bar-showhide-tool-bar-menu [showhide-tool-bar-none]
+ `(menu-item ,(purecopy "None")
+ menu-bar-showhide-tool-bar-menu-customize-disable
+ :help ,(purecopy "Turn tool-bar off")
+ :visible (display-graphic-p)
+ :button (:radio . (eq tool-bar-mode nil))))
+
+ (define-key menu-bar-showhide-menu [showhide-tool-bar]
+ `(menu-item ,(purecopy "Tool-bar") ,menu-bar-showhide-tool-bar-menu
+ :visible (display-graphic-p)))
+
+ )
+ ;; else not tool bar that can move.
+ (define-key menu-bar-showhide-menu [showhide-tool-bar]
+ `(menu-item ,(purecopy "Tool-bar") toggle-tool-bar-mode-from-frame
+ :help ,(purecopy "Turn tool-bar on/off")
+ :visible (display-graphic-p)
+ :button (:toggle . (> (frame-parameter nil 'tool-bar-lines) 0))))
+)
(define-key menu-bar-options-menu [showhide]
`(menu-item ,(purecopy "Show/Hide") ,menu-bar-showhide-menu))
@@ -1065,7 +1187,7 @@ mail status in mode line"))
(define-key menu-bar-options-menu [cua-emulation-mode]
(menu-bar-make-mm-toggle cua-mode
"Shift movement mark region (CUA)"
- "Use shifted movement keys to set and extend the region."
+ "Use shifted movement keys to set and extend the region"
(:visible (and (boundp 'cua-enable-cua-keys)
(not cua-enable-cua-keys)))))
@@ -1413,6 +1535,9 @@ mail status in mode line"))
(define-key menu-bar-describe-menu [describe-current-display-table]
`(menu-item ,(purecopy "Describe Display Table") describe-current-display-table
:help ,(purecopy "Describe the current display table")))
+(define-key menu-bar-describe-menu [describe-package]
+ `(menu-item ,(purecopy "Describe Package...") describe-package
+ :help ,(purecopy "Display documentation of a Lisp package")))
(define-key menu-bar-describe-menu [describe-face]
`(menu-item ,(purecopy "Describe Face...") describe-face
:help ,(purecopy "Display the properties of a face")))
@@ -1544,11 +1669,11 @@ key, a click, or a menu-item")))
(define-key menu-bar-help-menu [sep2]
menu-bar-separator)
(define-key menu-bar-help-menu [external-packages]
- `(menu-item ,(purecopy "External Packages") menu-bar-help-extra-packages
+ `(menu-item ,(purecopy "Finding Extra Packages") menu-bar-help-extra-packages
:help ,(purecopy "Lisp packages distributed separately for use in Emacs")))
(define-key menu-bar-help-menu [find-emacs-packages]
- `(menu-item ,(purecopy "Find Emacs Packages") finder-by-keyword
- :help ,(purecopy "Find packages and features by keyword")))
+ `(menu-item ,(purecopy "Search Built-in Packages") finder-by-keyword
+ :help ,(purecopy "Find built-in packages and features by keyword")))
(define-key menu-bar-help-menu [more-manuals]
`(menu-item ,(purecopy "More Manuals") ,menu-bar-manuals-menu))
(define-key menu-bar-help-menu [emacs-manual]
@@ -1589,6 +1714,13 @@ key, a click, or a menu-item")))
`(menu-item ,(purecopy "Emacs Tutorial") help-with-tutorial
:help ,(purecopy "Learn how to use Emacs")))
+;; In OS X it's in the app menu already.
+;; FIXME? There already is an "About Emacs" (sans ...) entry in the Help menu.
+(and (featurep 'ns)
+ (not (eq system-type 'darwin))
+ (define-key menu-bar-help-menu [info-panel]
+ `(menu-item ,(purecopy "About Emacs...") ns-do-emacs-info-panel)))
+
(defun menu-bar-menu-frame-live-and-visible-p ()
"Return non-nil if the menu frame is alive and visible.
The menu frame is the frame for which we are updating the menu."
@@ -1939,21 +2071,28 @@ This command applies to all frames that exist and frames to be
created in the future.
With a numeric argument, if the argument is positive,
turn on menu bars; otherwise, turn off menu bars."
- :init-value nil
+ :init-value t
:global t
- :group 'frames
-
- ;; Make menu-bar-mode and default-frame-alist consistent.
- (modify-all-frames-parameters (list (cons 'menu-bar-lines
- (if menu-bar-mode 1 0))))
-
+ ;; It's defined in C/cus-start, this stops the d-m-m macro defining it again.
+ :variable menu-bar-mode
+
+ ;; Turn the menu-bars on all frames on or off.
+ (let ((val (if menu-bar-mode 1 0)))
+ (dolist (frame (frame-list))
+ (set-frame-parameter frame 'menu-bar-lines val))
+ ;; If the user has given `default-frame-alist' a `menu-bar-lines'
+ ;; parameter, replace it.
+ (if (assq 'menu-bar-lines default-frame-alist)
+ (setq default-frame-alist
+ (cons (cons 'menu-bar-lines val)
+ (assq-delete-all 'menu-bar-lines
+ default-frame-alist)))))
;; Make the message appear when Emacs is idle. We can not call message
;; directly. The minor-mode message "Menu-bar mode disabled" comes
;; after this function returns, overwriting any message we do here.
(when (and (called-interactively-p 'interactive) (not menu-bar-mode))
(run-with-idle-timer 0 nil 'message
- "Menu-bar mode disabled. Use M-x menu-bar-mode to make the menu bar appear."))
- menu-bar-mode)
+ "Menu-bar mode disabled. Use M-x menu-bar-mode to make the menu bar appear.")))
;;;###autoload
;; (This does not work right unless it comes after the above definition.)
diff --git a/lisp/mh-e/.arch-inventory b/lisp/mh-e/.arch-inventory
deleted file mode 100644
index 2fada52b96f..00000000000
--- a/lisp/mh-e/.arch-inventory
+++ /dev/null
@@ -1,4 +0,0 @@
-# Auto-generated lisp files, which ignore
-precious ^(mh-loaddefs)\.el$
-
-# arch-tag: 03c1cf02-6c80-44af-b4ec-b41b53fbf8f2
diff --git a/lisp/mh-e/ChangeLog b/lisp/mh-e/ChangeLog
index b72478a32bd..336fd0100c1 100644
--- a/lisp/mh-e/ChangeLog
+++ b/lisp/mh-e/ChangeLog
@@ -1,8 +1,28 @@
+2010-11-07 Glenn Morris <rgm@gnu.org>
+
+ * mh-seq.el (mh-read-msg-list): Use point-at-eol.
+
+2010-11-03 Glenn Morris <rgm@gnu.org>
+
+ * mh-mime.el (dots, type, ov): Avoid unnecessary declaration.
+
+2010-05-14 Peter S Galbraith <psg@debian.org>
+
+ * mh-mime.el (mh-decode-message-subject): New function to decode
+ RFC2047 encoded Subject lines. Used for reply drafts.
+ * mh-comp.el (mh-compose-and-send-mail): Call
+ `mh-decode-message-subject' on (reply or forward) message drafts.
+
2010-05-07 Chong Yidong <cyd@stupidchicken.com>
* Version 23.2 released.
-2010-03-22 Juanma Barranquero <lekktu@gmail.com>
+2010-05-03 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * mh-show.el (mh-showing-mode): Move function to mh-e.el.
+ * mh-e.el (mh-showing-mode): Use define-minor-mode.
+
+2010-03-24 Juanma Barranquero <lekktu@gmail.com>
* mh-scan.el (mh-scan-cmd-note-width): Doc fix.
(mh-scan-format-mh, mh-scan-body-regexp, mh-scan-cur-msg-number-regexp)
@@ -14,6 +34,10 @@
(mh-scan-subject-regexp, mh-update-scan-format)
(mh-msg-num-width-to-column): Fix typos in docstrings.
+2010-03-10 Chong Yidong <cyd@stupidchicken.com>
+
+ * Branch for 23.2.
+
2009-12-01 Bill Wohler <wohler@newt.com>
* mh-search.el (mh-mairix-execute-search): Use mh vfolder_format.
@@ -488,8 +512,8 @@
2006-06-02 Bill Wohler <wohler@newt.com>
- (mh-folder-exists-p): Change test from an empty buffer, to one
- that contains the actual folder, since GNU mailutils' folder
+ * mh-search.el (mh-folder-exists-p): Change test from an empty buffer,
+ to one that contains the actual folder, since GNU mailutils' folder
command displays output if the folder doesn't exist (closes SF
#1499712).
@@ -1399,7 +1423,7 @@
(mh-get-field): Delete ancient alias.
* mh-xface.el (mh-face-foreground-compat): Move to mh-compat.el
- and rename to mh-face-foreground
+ and rename to mh-face-foreground.
(mh-face-background-compat): Move to mh-compat.el
and rename to mh-face-background.
(mh-face-display-function): Use the new names.
@@ -1716,7 +1740,7 @@
(mh-identity-make-menu-no-autoload): New alias for
mh-identity-make-menu which can be called from mh-e.el.
(mh-identity-list-set): Move to mh-e.el.
- (mh-identity-add-menu): New function
+ (mh-identity-add-menu): New function.
(mh-insert-identity): Add optional argument maybe-insert so that
local variable mh-identity-local does not have to be visible.
@@ -1875,7 +1899,7 @@
(mh-find-path-run, mh-find-path): Move here from deprecated file
mh-init.el.
(mh-help-messages): Now an alist of modes to an alist of messages.
- (mh-set-help): New function used to set mh-help-messages
+ (mh-set-help): New function used to set mh-help-messages.
(mh-help): Adjust for new format of mh-help-messages. Add
help-messages argument.
(mh-prefix-help): Refactor to use mh-help.
@@ -2444,7 +2468,7 @@
(mh-scan-good-msg-regexp, mh-scan-deleted-msg-regexp)
(mh-scan-refiled-msg-regexp, mh-scan-cur-msg-number-regexp)
(mh-scan-date-regexp, mh-scan-rcpt-regexp, mh-scan-body-regexp)
- (mh-scan-subject-regexp): Sync docstrings with manual
+ (mh-scan-subject-regexp): Sync docstrings with manual.
(mh-scan-format-regexp): Rename to
mh-scan-sent-to-me-sender-regexp. Drop date parenthesized
expression. Make expression more like the others (anchored at the
@@ -2744,7 +2768,7 @@
(mh-mime-save-parts-default-directory, mh-print-background-flag)
(mh-show-maximum-size, mh-show-use-goto-addr-flag)
(mh-show-use-xface-flag, mh-store-default-directory)
- (mh-summary-height, mh-delete-msg-hook
+ (mh-summary-height, mh-delete-msg-hook)
(mh-show-hook, mh-show-mode-hook): Sync docstrings with manual.
* mh-e.el (mh-scan-format-mh, mh-scan-good-msg-regexp)
diff --git a/lisp/mh-e/ChangeLog.1 b/lisp/mh-e/ChangeLog.1
index c2c9a2df181..7492f9600b3 100644
--- a/lisp/mh-e/ChangeLog.1
+++ b/lisp/mh-e/ChangeLog.1
@@ -195,11 +195,11 @@
2005-05-28 Bill Wohler <wohler@newt.com>
- Released MH-E version 7.84.
+ Released MH-E version 7.84.
- * MH-E-NEWS, README: Updated for release 7.84.
+ * MH-E-NEWS, README: Updated for release 7.84.
- * mh-e.el (Version, mh-version): Updated for release 7.84.
+ * mh-e.el (Version, mh-version): Updated for release 7.84.
2005-05-28 Bill Wohler <wohler@newt.com>
@@ -333,9 +333,9 @@
Synced with manual.
(mh-junk-program): Use double-quotes on non-symbols.
- * mh-pick.el: (mh-search-folder): Synced docstrings with manual.
+ * mh-pick.el (mh-search-folder): Synced docstrings with manual.
- * mh-index.el: (mh-index-search, mh-pick-execute-search)
+ * mh-index.el (mh-index-search, mh-pick-execute-search)
(mh-grep-execute-search, mh-mairix-execute-search)
(mh-swish-execute-search, mh-swish++-execute-search)
(mh-namazu-execute-search): Synced docstrings with manual. Note
@@ -659,13 +659,13 @@
* mh-mime.el (mh-display-with-external-viewer): Checkdoc fixes.
- * mh-identity.el: (mh-identity-attribution-verb-end): Stripped
+ * mh-identity.el (mh-identity-attribution-verb-end): Stripped
trailing space; checkdoc fixes.
* mh-e.el (mh-restore-desktop-buffer): Checkdoc fixes.
- * mh-customize.el: (mh-inc-spool-list,
- mh-compose-forward-as-mime-flag, defcustom): Stripped trailing
+ * mh-customize.el (mh-inc-spool-list)
+ (mh-compose-forward-as-mime-flag, defcustom): Stripped trailing
space; checkdoc fixes.
* mh-comp.el (mh-reply): Stripped trailing space.
@@ -825,7 +825,7 @@
(MH-E-XEMACS-OBJ): New variable to hold XEmacs object files.
(clean): Moved XEmacs-specific code to clean-xemacs.
(xemacs): Added clean-xemacs prerequisite. Moved down to XEmacs
- section of file. Add target to build mh-loaddefs.el in XEmacs
+ section of file. Add target to build mh-loaddefs.el in XEmacs.
(loaddefs-xemacs): New rule to build mh-loaddefs.el in XEmacs.
(clean-xemacs): New target to remove XEmacs-specific files.
(compile-xemacs): New. It allows for the '-no-autoloads' option
@@ -1156,8 +1156,8 @@
mh-loaddefs.el in XEmacs.
(XEMACS_LOADDEFS_COOKIE): Ditto.
(XEMACS_LOADDEFS_PKG_NAME): Ditto.
- (xemacs): Add target to build mh-loaddefs.el in XEmacs
- (clean-xemacs): Remove `mh-loaddefs.el*'
+ (xemacs): Add target to build mh-loaddefs.el in XEmacs.
+ (clean-xemacs): Remove `mh-loaddefs.el*'.
(loaddefs-xemacs): New rule to build mh-loaddefs.el in XEmacs.
2003-11-02 Peter S Galbraith <psg@debian.org>
@@ -1214,7 +1214,7 @@
* mh-loaddefs.el: Regenerated.
* mh-index.el (mh-indexer-choices): Remove option for the non-free
- glimpse indexer (closes SF #831276).
+ glimpse indexer (closes SF #831276).
(mh-glimpse-binary, mh-glimpse-directory)
(mh-glimpse-execute-search, mh-glimpse-next-result): Functions
and variables to implement glimpse support are removed.
@@ -1432,7 +1432,7 @@
(mh-mml-secure-message-signencrypt): Ditto.
(mh-mml-secure-message-sign): Ditto.
- * mh-comp.el (mh-letter-menu, mh-letter-mode-help-messages,
+ * mh-comp.el (mh-letter-menu, mh-letter-mode-help-messages)
(mh-letter-mode-map): Update to use new functions.
2003-09-26 Satyaki Das <satyakid@stanford.edu>
@@ -1485,7 +1485,7 @@
(mh-alias-system-aliases): Moved here from mh-customize.el. By
definition, "system" definitions are not user-visible, and user
filenames are in the the Aliasfile: profile component, so this
- variable really shouldn't be a defcustom
+ variable really shouldn't be a defcustom.
(mh-alias-tstamp, mh-alias-filenames, mh-alias-reload)
(mh-alias-add-alias, mh-alias-grab-from-field)
(mh-alias-add-address-under-point, mh-alias-apropos): Merge
@@ -1819,7 +1819,7 @@
2003-08-19 Bill Wohler <wohler@newt.com>
- * mh-seq.el: (mh-edit-pick-expr): Renamed from mh-read-pick-regexp
+ * mh-seq.el (mh-edit-pick-expr): Renamed from mh-read-pick-regexp
since the new name is more indicative of what the function does.
Prompt now says "Pick expression" instead of "Pick regexp".
(mh-narrow-to-subject): Rewrote function to behave like other
@@ -1980,7 +1980,7 @@
* mh-comp.el (mh-send-letter): Go to the top of the draft so that
the user can see which header fields have been inserted. I think
this is more important than leaving point alone or going to the
- end to see the signature since Mail-Followup-To or Bcc or cc could
+ end to see the signature since Mail-Followup-To or Bcc or cc could
have some deleterious effects.
* mh-customize.el (mh-auto-fields-prompt-flag): New variable.
@@ -2763,7 +2763,7 @@
replacement text.
(mh-index-parse-search-regexp): Preserve case of search terms.
This is needed to take advantage of the acronym indexing in
- swish++ (closes SF #755718).
+ swish++ (closes SF #755718).
2003-06-13 Satyaki Das <satyakid@stanford.edu>
@@ -3988,7 +3988,7 @@
fixes germaine to the change whereby we now check for MIME
directives before sending.
- * mh-xemacs-toolbar.el: Fixed copyright. Added Change Log comment
+ * mh-xemacs-toolbar.el: Fixed copyright. Added Change Log comment.
(lm-verify fix). Added standard MH-E local variables. Removed
time-stamp stuff.
@@ -4396,7 +4396,6 @@
mh-xemacs-toolbar.el: Removed RCS keywords per Emacs conventions
(closes SF #680731).
-
2003-03-26 Satyaki Das <satyaki@theforce.stanford.edu>
* mh-index.el: Fix commentary to mention that mairix is supported
@@ -5384,7 +5383,7 @@
* import-emacs: MH-E now has its own directory in Emacs.
- * mh-e.el: (mh-version): Set to 7.2+cvs.
+ * mh-e.el (mh-version): Set to 7.2+cvs.
2003-02-03 Bill Wohler <wohler@newt.com>
@@ -5453,7 +5452,7 @@
from mh-exec-cmd.
* mh-utils.el (mh-temp-folders-buffer): Sequences and folders
- loose the -temp from their buffer names as they are interesting to
+ lose the -temp from their buffer names as they are interesting to
the user.
* mh-seq.el (mh-list-sequences): New name, mh-sequences-buffer as
@@ -5808,8 +5807,8 @@
(mh-default-folder-prefix, mh-default-folder-must-exist-flag): In
docstring, refer to documentation for mh-prompt-for-refile-folder
and mh-folder-from-address.
- (mh-highlight-citation-p, mh-compose-insertion,
- (mh-insert-mail-followup-to-list, mh-index-program,
+ (mh-highlight-citation-p, mh-compose-insertion)
+ (mh-insert-mail-followup-to-list, mh-index-program)
(mh-identity-default): Fixed case of tags.
* mh-e.el (mh-folder-from-address): Use new variable
@@ -6311,7 +6310,7 @@
(mh-alias-insert-file): New function. Return the alias file to
write a new entry in.
(mh-alias-address-to-alias): New function. Return the ADDRESS
- alias if defined, or nil."
+ alias if defined, or nil.
(mh-alias-from-has-no-alias-p): New function. Return t is From has
no current alias set. Used as tool-bar button enable function.
(mh-alias-add-alias-to-file): New function. Add ALIAS for ADDRESS
@@ -6884,7 +6883,7 @@
* mh-e.el (mh-add-cur-notation): New function to mark the
current message with the mh-note-cur character.
(mh-get-new-mail): Use mh-add-cur-notation to undo the work of
- mh-remove-cur-notation if there was no new mail (closes SF #647681).
+ mh-remove-cur-notation if there was no new mail (closes SF #647681).
* mh-e.el (mh-set-cmd-note): Do not update the default mh-cmd-note
value (closes SF #643701).
@@ -6903,7 +6902,7 @@
(mh-alias-translate): New function. Return translation for alias,
checking if in blind or passwd list.
(mh-alias-letter-expand-alias): Rewrite using
- mail-abbrev-complete-alias from mailabbrev.el
+ mail-abbrev-complete-alias from mailabbrev.el.
(mh-alias-expand-alias-map): New variable.
(mh-alias-ali): New function. Return formatted string of
translated ALIAS from ali.
@@ -7085,7 +7084,7 @@
mh-thread-generate-scan-lines.
* mh-mime.el (font-lock): Font-lock required at compile time to
- avoid warning about font-lock-maximum-size
+ avoid warning about font-lock-maximum-size.
(mh-display-smileys, mh-display-emphasis): Show graphical smileys
and emphasis only if message isn't too large.
@@ -7446,7 +7445,7 @@
This addresses part of SF #627015.
* mh-utils.el (mh-decode-quoted-printable-flag): Renamed from
- mh-decode-quoted-printable
+ mh-decode-quoted-printable.
(mh-display-msg, mh-decode-quoted-printable-have-mimedecode):
Use it.
This addresses part of SF #627015.
@@ -7556,10 +7555,10 @@
the MH pick command to give the user more information when
choosing between mh-search-folder and mh-index-folder.
- * mh-index.el (mh-index-search): Edited the docstring. Direct the
- user to mh-index-program if necessary.
- (mh-index-program): Edited this docstring too. Viewing the help
- in a *Help* buffer really exposes grammatical flaws.
+ * mh-index.el (mh-index-search): Edited the docstring. Direct the
+ user to mh-index-program if necessary.
+ (mh-index-program): Edited this docstring too. Viewing the help
+ in a *Help* buffer really exposes grammatical flaws.
2002-11-05 Peter S Galbraith <psg@debian.org>
@@ -7839,7 +7838,6 @@
(.PHONY): Added emacs, xemacs, autoloads, custom-loads. Broke up
target and moved pieces into their own sections.
-
2002-10-30 Peter S Galbraith <psg@debian.org>
* mh-utils.el (mh-show-font-lock-keywords): Wrap an
@@ -7908,7 +7906,7 @@
2002-10-28 Peter S Galbraith <psg@debian.org>
* mh-e.el (mh-scan-subject-regexp): Add an expression to match an
- optional bracketed number after "Re", such as in "Re[2]:"
+ optional bracketed number after "Re", such as in "Re[2]:".
(Patch by Satyaki; I checked it and applied).
(mh-folder-font-lock-subject): Adapt to new mh-scan-subject-regexp.
* mh-seq.el (mh-subject-to-sequence): Ditto.
@@ -8494,11 +8492,10 @@
2002-10-22 Mark D. Baushke <mdb@gnu.org>
* mh-mime.el (mh-graphical-smileys-flag): Renamed from
- mh-graphical-smileys-p.
- (mh-display-smileys): Use it.
- (mh-graphical-emphasis-flag): Renamed from
- mh-graphical-emphasis-p.
- (mh-display-emphasis): Use it. This addresses part of SF #627015.
+ mh-graphical-smileys-p.
+ (mh-display-smileys): Use it.
+ (mh-graphical-emphasis-flag): Renamed from mh-graphical-emphasis-p.
+ (mh-display-emphasis): Use it. This addresses part of SF #627015.
2002-10-22 Satyaki Das <satyaki@theforce.stanford.edu>
@@ -8885,7 +8882,7 @@
(mh-pick-mode): Set local buffer variable mh-help-messages to
mh-pick-mode-help-messages.
- * mh-index.el (mh-index-keymap): Added binding for mh-help
+ * mh-index.el (mh-index-keymap): Added binding for mh-help.
(mh-index-folder-mode-help-messages): New variable that contains
help messages for MH Index buffer.
(mh-index-folder-mode): Set local buffer variable mh-help-messages
@@ -9283,7 +9280,7 @@
2002-09-17 Peter S Galbraith <psg@debian.org>
* mh-mime.el (mh-store-mime-parts-default-directory): Renamed from
- mh-store-mime-parts-directory
+ mh-store-mime-parts-directory.
(mh-store-mime-parts-directory): Renamed from
mh-store-mime-parts-directory-default.
@@ -9301,7 +9298,7 @@
* mh-mime.el (mh-store-mime-parts-directory): New defcustom.
Default directory to use for mh-store-mime-parts.
(mh-store-mime-parts): New Command. Store the MIME parts of the
- current message.
+ current message.
(mh-store-mime-parts-directory-default): New internal working
variable. Default to use for mh-store-mime-parts-directory, set
from last use.
@@ -9309,7 +9306,6 @@
* mh-e.el (mh-folder-seq-tool-bar-map): Add mh-store-mime-parts to
toolbar.
-
2002-08-22 Satyaki Das <satyaki@theforce.stanford.edu>
* mh-seq.el (mh-thread-generate-scan-lines): In threaded view,
@@ -9944,7 +9940,7 @@
compiler warnings.
* mh-e.el (compilation): Code rearrangement and extra autoloads to
- remove compiler warnings
+ remove compiler warnings.
(mh-quit): Add call to mh-destroy-postponed-handles to remove
handles that are associated with external viewers. Also fixed a
bug that I accidentally introduced by adding an extra line when
@@ -10487,7 +10483,6 @@
(clean): New target that blows away MH-E-OBJ.
(dist): Added $(MH-E-OBJ) to tarball.
-
Attempt to quiet compilation errors to a dull roar.
* mh-e.el: Require easymenu, added autoload of info.
@@ -10506,8 +10501,7 @@
* mh-comp.el: Require mh-e and easymenu, moved autoloads to top of
file.
-
- * Makefile: (EMACS): New constant to hold emacs calling sequence.
+ * Makefile (EMACS): New constant to hold emacs calling sequence.
(install): Renamed to install-emacs.
(compile): New target to compile all files.
(dist): Make dependent on compile.
@@ -10713,7 +10707,7 @@
2001-11-29 Peter S Galbraith <psg@debian.org>
* mh-e.el (mh-folder-font-lock-subject): New fontifier function
- for subject lines in folder-mode
+ for subject lines in folder-mode.
(mh-scan-followup-regexp): Deleted obsolete regexp. Use
mh-scan-subject-regexp instead.
(mh-folder-font-lock-keywords): Use mh-folder-font-lock-subject
@@ -10744,7 +10738,7 @@
2001-11-29 Jeffrey C Honig <jch@honig.net>
- * mh-utils.el: (mh-find-progs): Change mh-find-progs to rely on
+ * mh-utils.el (mh-find-progs): Change mh-find-progs to rely on
the existence of mhparam. The location of mhparam is used to find
`mh-progs'. It uses the libdir and etcdir to find the
`mh-lib-progs' and `mh-lib' directories. If etcdir doesn't return
@@ -10801,7 +10795,7 @@
set mh-page-to-next-msg-p to t. The second time the end of page is
hit, go to the next message.
- * mh-utils.el: (mh-show-msg): Initialize mh-page-to-next-msg-p to
+ * mh-utils.el (mh-show-msg): Initialize mh-page-to-next-msg-p to
nil.
2001-11-27 Bill Wohler <wohler@newt.com>
@@ -11285,7 +11279,7 @@
* mh-e.el (mh-refile-msg): Mark messages in region for refiling if
mark is active and in transient-mark-mode.
* mh-e.el (mh-undo): Undo message marks for refile or deletion if
- region if mark is active and in transient-mark-mode.
+ region if mark is active and in transient-mark-mode.
2001-11-06 Peter S Galbraith <psg@debian.org>
@@ -11406,7 +11400,8 @@
(dist): Leave release in current directory.
- Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+ Free Software Foundation, Inc.
This file is part of GNU Emacs.
@@ -11423,4 +11418,3 @@
You should have received a copy of the GNU General Public License
along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-;; arch-tag: 2577172b-b1bf-4d87-acfb-c9d8780e8851
diff --git a/lisp/mh-e/mh-alias.el b/lisp/mh-e/mh-alias.el
index 5f472322ff9..2856c630fd0 100644
--- a/lisp/mh-e/mh-alias.el
+++ b/lisp/mh-e/mh-alias.el
@@ -234,7 +234,7 @@ returns the string unchanged if not defined. The same is done here."
(let ((user-arg (if user "-user" "-nouser")))
(mh-exec-cmd-quiet t "ali" user-arg "-nolist" alias))
(goto-char (point-max))
- (if (looking-at "^$") (delete-backward-char 1))
+ (if (looking-at "^$") (delete-char -1))
(buffer-substring (point-min)(point-max)))
(error (progn
(message "%s" (error-message-string err))
diff --git a/lisp/mh-e/mh-comp.el b/lisp/mh-e/mh-comp.el
index 3bb1e343253..762aad86080 100644
--- a/lisp/mh-e/mh-comp.el
+++ b/lisp/mh-e/mh-comp.el
@@ -905,6 +905,9 @@ letter."
(mh-identity-make-menu)
(mh-identity-add-menu)
+ ;; Cleanup possibly RFC2047 encoded subject header
+ (mh-decode-message-subject)
+
;; Insert extra fields.
(mh-insert-x-mailer)
(mh-insert-x-face)
diff --git a/lisp/mh-e/mh-e.el b/lisp/mh-e/mh-e.el
index 3639920f514..9a2bccbc967 100644
--- a/lisp/mh-e/mh-e.el
+++ b/lisp/mh-e/mh-e.el
@@ -287,8 +287,10 @@ Elements have the form (SEQUENCE . MESSAGES).")
(defvar mh-show-buffer nil
"Buffer that displays message for this folder.")
-(defvar mh-showing-mode nil
- "If non-nil, show the message in a separate window.")
+(define-minor-mode mh-showing-mode
+ "Minor mode to show the message in a separate window."
+ ;; FIXME: maybe this should be moved to mh-show.el.
+ :lighter " Show")
(defvar mh-view-ops nil
"Stack of operations that change the folder view.
diff --git a/lisp/mh-e/mh-mime.el b/lisp/mh-e/mh-mime.el
index a60f31e3ac2..860256e236a 100644
--- a/lisp/mh-e/mh-mime.el
+++ b/lisp/mh-e/mh-mime.el
@@ -1,8 +1,7 @@
;;; mh-mime.el --- MH-E MIME support
-;; Copyright (C) 1993, 1995,
-;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1995, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Bill Wohler <wohler@newt.com>
;; Maintainer: Bill Wohler <wohler@newt.com>
@@ -508,6 +507,15 @@ decoding the same message multiple times."
(rfc2047-decode-region (point-min) (mh-mail-header-end)))))
;;;###mh-autoload
+(defun mh-decode-message-subject ()
+ "Decode RFC2047 encoded message header fields."
+ (when mh-decode-mime-flag
+ (save-excursion
+ (let ((buffer-read-only nil))
+ (rfc2047-decode-region (progn (mh-goto-header-field "subject:") (point))
+ (progn (mh-header-field-end) (point)))))))
+
+;;;###mh-autoload
(defun mh-mime-display (&optional pre-dissected-handles)
"Display (and possibly decode) MIME handles.
Optional argument, PRE-DISSECTED-HANDLES is a list of MIME
@@ -828,9 +836,10 @@ being used to highlight the signature in a MIME part."
;;; Button Display
;; Shush compiler.
-(defvar dots) ; XEmacs
-(defvar type) ; XEmacs
-(defvar ov) ; XEmacs
+(when (featurep 'xemacs)
+ (defvar dots)
+ (defvar type)
+ (defvar ov))
(defun mh-insert-mime-button (handle index displayed)
"Insert MIME button for HANDLE.
@@ -1825,5 +1834,4 @@ initialized. Always use the command `mh-have-file-command'.")
;; sentence-end-double-space: nil
;; End:
-;; arch-tag: 0dd36518-1b64-4a84-8f4e-59f422d3f002
;;; mh-mime.el ends here
diff --git a/lisp/mh-e/mh-search.el b/lisp/mh-e/mh-search.el
index f361e049efb..7a1f41bf932 100644
--- a/lisp/mh-e/mh-search.el
+++ b/lisp/mh-e/mh-search.el
@@ -1511,7 +1511,7 @@ construct the base name."
(delete-char 1))
(goto-char (point-max))
(while (and (not (bobp)) (memq (char-before) '(? ?\t ?\n ?\r ?_)))
- (delete-backward-char 1))
+ (delete-char -1))
(subst-char-in-region (point-min) (point-max) ? ?_ t)
(subst-char-in-region (point-min) (point-max) ?\t ?_ t)
(subst-char-in-region (point-min) (point-max) ?\n ?_ t)
diff --git a/lisp/mh-e/mh-seq.el b/lisp/mh-e/mh-seq.el
index f8ea12f9e08..09dce2f32da 100644
--- a/lisp/mh-e/mh-seq.el
+++ b/lisp/mh-e/mh-seq.el
@@ -1,8 +1,7 @@
;;; mh-seq.el --- MH-E sequences support
-;; Copyright (C) 1993, 1995,
-;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1995, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Bill Wohler <wohler@newt.com>
;; Maintainer: Bill Wohler <wohler@newt.com>
@@ -819,7 +818,7 @@ that note messages to be refiled."
"Return a list of message numbers from point to the end of the line.
Expands ranges into set of individual numbers."
(let ((msgs ())
- (end-of-line (save-excursion (end-of-line) (point)))
+ (end-of-line (point-at-eol))
num)
(while (re-search-forward "[0-9]+" end-of-line t)
(setq num (string-to-number (buffer-substring (match-beginning 0)
@@ -1017,5 +1016,4 @@ removed."
;; sentence-end-double-space: nil
;; End:
-;; arch-tag: 8e952711-01a2-485b-bf21-c9e3ad4de942
;;; mh-seq.el ends here
diff --git a/lisp/mh-e/mh-show.el b/lisp/mh-e/mh-show.el
index 766b6982d98..58d52205079 100644
--- a/lisp/mh-e/mh-show.el
+++ b/lisp/mh-e/mh-show.el
@@ -170,16 +170,6 @@ displayed."
(run-hooks 'mh-show-hook)))
;;;###mh-autoload
-(defun mh-showing-mode (&optional arg)
- "Change whether messages should be displayed.
-
-With ARG, display messages if ARG is positive, otherwise don't display them."
- (setq mh-showing-mode
- (if (null arg)
- (not mh-showing-mode)
- (> (prefix-numeric-value arg) 0))))
-
-;;;###mh-autoload
(defun mh-start-of-uncleaned-message ()
"Position uninteresting headers off the top of the window."
(let ((case-fold-search t))
diff --git a/lisp/midnight.el b/lisp/midnight.el
index 5887a3445bc..5ff1ecc9b07 100644
--- a/lisp/midnight.el
+++ b/lisp/midnight.el
@@ -3,8 +3,8 @@
;; Copyright (C) 1998, 2001, 2002, 2003, 2004, 2005,
;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-;; Author: Sam Steingold <sds@usa.net>
-;; Maintainer: Sam Steingold <sds@usa.net>
+;; Author: Sam Steingold <sds@gnu.org>
+;; Maintainer: Sam Steingold <sds@gnu.org>
;; Created: 1998-05-18
;; Keywords: utilities
@@ -205,7 +205,7 @@ The default value is `clean-buffer-list'."
(defun midnight-next ()
"Return the number of seconds till the next midnight."
- (multiple-value-bind (sec min hrs)
+ (multiple-value-bind (sec min hrs)
(values-list (decode-time))
(- (* 24 60 60) (* 60 60 hrs) (* 60 min) sec)))
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index 006e873ac57..78580c86e45 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -3,6 +3,7 @@
;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -76,6 +77,9 @@
;; the provided string (as is the case in filecache.el), in which
;; case partial-completion (for example) doesn't make any sense
;; and neither does the completions-first-difference highlight.
+;; - indicate how to display the completions in *Completions* (turn
+;; \n into something else, add special boundaries between
+;; completions). E.g. when completing from the kill-ring.
;; - make partial-completion-mode obsolete:
;; - (?) <foo.h> style completion for file names.
@@ -407,6 +411,12 @@ Furthermore, for completions that are done step by step in subfields,
the method is applied to all the preceding fields that do not yet match.
E.g. C-x C-f /u/mo/s TAB could complete to /usr/monnier/src.
Additionally the user can use the char \"*\" as a glob pattern.")
+ (substring
+ completion-substring-try-completion completion-substring-all-completions
+ "Completion of the string taken as a substring.
+I.e. when completing \"foo_bar\" (where _ is the position of point),
+it will consider all completions candidates matching the glob
+pattern \"*foo*bar*\".")
(initials
completion-initials-try-completion completion-initials-all-completions
"Completion of acronyms and initialisms.
@@ -504,6 +514,25 @@ Moves point to the end of the new text."
(delete-region (point) (+ (point) (- end beg)))
(forward-char suffix-len)))
+(defcustom completion-cycle-threshold nil
+ "Number of completion candidates below which cycling is used.
+Depending on this setting `minibuffer-complete' may use cycling,
+like `minibuffer-force-complete'.
+If nil, cycling is never used.
+If t, cycling is always used.
+If an integer, cycling is used as soon as there are fewer completion
+candidates than this number."
+ :type '(choice (const :tag "No cycling" nil)
+ (const :tag "Always cycle" t)
+ (integer :tag "Threshold")))
+
+(defvar completion-all-sorted-completions nil)
+(make-variable-buffer-local 'completion-all-sorted-completions)
+(defvar completion-cycling nil)
+
+(defvar completion-fail-discreetly nil
+ "If non-nil, stay quiet when there is no match.")
+
(defun completion--do-completion (&optional try-completion-function)
"Do the completion and return a summary of what happened.
M = completion was performed, the text was Modified.
@@ -532,11 +561,13 @@ E = after completion we now have an Exact match.
(cond
((null comp)
(minibuffer-hide-completions)
- (ding) (minibuffer-message "No match") (minibuffer--bitset nil nil nil))
+ (unless completion-fail-discreetly
+ (ding) (minibuffer-message "No match"))
+ (minibuffer--bitset nil nil nil))
((eq t comp)
(minibuffer-hide-completions)
(goto-char (field-end))
- (minibuffer--bitset nil nil t)) ;Exact and unique match.
+ (minibuffer--bitset nil nil t)) ;Exact and unique match.
(t
;; `completed' should be t if some completion was done, which doesn't
;; include simply changing the case of the entered string. However,
@@ -556,34 +587,62 @@ E = after completion we now have an Exact match.
(forward-char (- comp-pos (length completion)))
(if (not (or unchanged completed))
- ;; The case of the string changed, but that's all. We're not sure
- ;; whether this is a unique completion or not, so try again using
- ;; the real case (this shouldn't recurse again, because the next
- ;; time try-completion will return either t or the exact string).
- (completion--do-completion try-completion-function)
+ ;; The case of the string changed, but that's all. We're not sure
+ ;; whether this is a unique completion or not, so try again using
+ ;; the real case (this shouldn't recurse again, because the next
+ ;; time try-completion will return either t or the exact string).
+ (completion--do-completion try-completion-function)
;; It did find a match. Do we match some possibility exactly now?
(let ((exact (test-completion completion
minibuffer-completion-table
- minibuffer-completion-predicate)))
- (if completed
- ;; We could also decide to refresh the completions,
- ;; if they're displayed (and assuming there are
- ;; completions left).
- (minibuffer-hide-completions)
- ;; Show the completion table, if requested.
- (cond
- ((not exact)
- (if (case completion-auto-help
- (lazy (eq this-command last-command))
- (t completion-auto-help))
- (minibuffer-completion-help)
- (minibuffer-message "Next char not unique")))
- ;; If the last exact completion and this one were the same, it
- ;; means we've already given a "Next char not unique" message
- ;; and the user's hit TAB again, so now we give him help.
- ((eq this-command last-command)
- (if completion-auto-help (minibuffer-completion-help)))))
+ minibuffer-completion-predicate))
+ (comps
+ ;; Check to see if we want to do cycling. We do it
+ ;; here, after having performed the normal completion,
+ ;; so as to take advantage of the difference between
+ ;; try-completion and all-completions, for things
+ ;; like completion-ignored-extensions.
+ (when (and completion-cycle-threshold
+ ;; Check that the completion didn't make
+ ;; us jump to a different boundary.
+ (or (not completed)
+ (< (car (completion-boundaries
+ (substring completion 0 comp-pos)
+ minibuffer-completion-table
+ minibuffer-completion-predicate
+ ""))
+ comp-pos)))
+ (completion-all-sorted-completions))))
+ (completion--flush-all-sorted-completions)
+ (cond
+ ((and (consp (cdr comps)) ;; There's something to cycle.
+ (not (ignore-errors
+ ;; This signal an (intended) error if comps is too
+ ;; short or if completion-cycle-threshold is t.
+ (consp (nthcdr completion-cycle-threshold comps)))))
+ ;; Fewer than completion-cycle-threshold remaining
+ ;; completions: let's cycle.
+ (setq completed t exact t)
+ (setq completion-all-sorted-completions comps)
+ (minibuffer-force-complete))
+ (completed
+ ;; We could also decide to refresh the completions,
+ ;; if they're displayed (and assuming there are
+ ;; completions left).
+ (minibuffer-hide-completions))
+ ;; Show the completion table, if requested.
+ ((not exact)
+ (if (case completion-auto-help
+ (lazy (eq this-command last-command))
+ (t completion-auto-help))
+ (minibuffer-completion-help)
+ (minibuffer-message "Next char not unique")))
+ ;; If the last exact completion and this one were the same, it
+ ;; means we've already given a "Next char not unique" message
+ ;; and the user's hit TAB again, so now we give him help.
+ ((eq this-command last-command)
+ (if completion-auto-help (minibuffer-completion-help))))
(minibuffer--bitset completed t exact))))))))
@@ -597,21 +656,26 @@ scroll the window of possible completions."
;; If the previous command was not this,
;; mark the completion buffer obsolete.
(unless (eq this-command last-command)
+ (completion--flush-all-sorted-completions)
(setq minibuffer-scroll-window nil))
- (let ((window minibuffer-scroll-window))
+ (cond
;; If there's a fresh completion window with a live buffer,
;; and this command is repeated, scroll that window.
- (if (window-live-p window)
+ ((window-live-p minibuffer-scroll-window)
+ (let ((window minibuffer-scroll-window))
(with-current-buffer (window-buffer window)
(if (pos-visible-in-window-p (point-max) window)
;; If end is in view, scroll up to the beginning.
(set-window-start window (point-min) nil)
;; Else scroll down one screen.
(scroll-other-window))
- nil)
-
- (case (completion--do-completion)
+ nil)))
+ ;; If we're cycling, keep on cycling.
+ ((and completion-cycling completion-all-sorted-completions)
+ (minibuffer-force-complete)
+ t)
+ (t (case (completion--do-completion)
(#b000 nil)
(#b001 (minibuffer-message "Sole completion")
t)
@@ -619,10 +683,8 @@ scroll the window of possible completions."
t)
(t t)))))
-(defvar completion-all-sorted-completions nil)
-(make-variable-buffer-local 'completion-all-sorted-completions)
-
(defun completion--flush-all-sorted-completions (&rest ignore)
+ (setq completion-cycling nil)
(setq completion-all-sorted-completions nil))
(defun completion-all-sorted-completions ()
@@ -664,6 +726,7 @@ Repeated uses step through the possible completions."
(all (completion-all-sorted-completions)))
(if (not (consp all))
(minibuffer-message (if all "No more completions" "No completions"))
+ (setq completion-cycling t)
(goto-char end)
(insert (car all))
(delete-region (+ start (cdr (last all))) end)
@@ -859,13 +922,13 @@ Return nil if there is no valid completion, else t."
(defface completions-annotations '((t :inherit italic))
"Face to use for annotations in the *Completions* buffer.")
-(defcustom completions-format nil
+(defcustom completions-format 'horizontal
"Define the appearance and sorting of completions.
If the value is `vertical', display completions sorted vertically
in columns in the *Completions* buffer.
-If the value is `horizontal' or nil, display completions sorted
+If the value is `horizontal', display completions sorted
horizontally in alphabetical order, rather than down the screen."
- :type '(choice (const nil) (const horizontal) (const vertical))
+ :type '(choice (const horizontal) (const vertical))
:group 'minibuffer
:version "23.2")
@@ -1176,7 +1239,7 @@ Point needs to be somewhere between START and END."
(call-interactively 'minibuffer-complete)
(delete-overlay ol)))))
-(defvar completion-at-point-functions nil
+(defvar completion-at-point-functions '(tags-completion-at-point-function)
"Special hook to find the completion table for the thing at point.
It is called without any argument and should return either nil,
or a function of no argument to perform completion (discouraged),
@@ -1188,24 +1251,31 @@ Currently supported properties are:
`:predicate' a predicate that completion candidates need to satisfy.
`:annotation-function' the value to use for `completion-annotate-function'.")
-(defun completion-at-point ()
- "Complete the thing at point according to local mode.
-This runs the hook `completion-at-point-functions' until a member returns
-non-nil."
- (interactive)
- (let ((res (run-hook-with-args-until-success
- 'completion-at-point-functions)))
- (cond
- ((functionp res) (funcall res))
- (res
- (let* ((plist (nthcdr 3 res))
- (start (nth 0 res))
- (end (nth 1 res))
- (completion-annotate-function
- (or (plist-get plist :annotation-function)
- completion-annotate-function)))
- (completion-in-region start end (nth 2 res)
- (plist-get plist :predicate)))))))
+(defun completion-at-point (&optional arg)
+ "Perform completion on the text around point.
+The completion method is determined by `completion-at-point-functions'.
+
+With a prefix argument, this command does completion within
+the collection of symbols listed in the index of the manual for the
+language you are using."
+ (interactive "P")
+ (if arg
+ (info-complete-symbol)
+ (let ((res (run-hook-with-args-until-success
+ 'completion-at-point-functions)))
+ (cond
+ ((functionp res) (funcall res))
+ (res
+ (let* ((plist (nthcdr 3 res))
+ (start (nth 0 res))
+ (end (nth 1 res))
+ (completion-annotate-function
+ (or (plist-get plist :annotation-function)
+ completion-annotate-function)))
+ (completion-in-region start end (nth 2 res)
+ (plist-get plist :predicate))))))))
+
+(define-obsolete-function-alias 'complete-symbol 'completion-at-point "24.1")
;;; Key bindings.
@@ -1305,12 +1375,19 @@ same as `substitute-in-file-name'."
((eq (car-safe action) 'boundaries)
(let ((start (length (file-name-directory string)))
(end (string-match-p "/" (cdr action))))
- (list* 'boundaries start end)))
-
- ((eq action 'lambda)
- (if (zerop (length string))
- nil ;Not sure why it's here, but it probably doesn't harm.
- (funcall (or pred 'file-exists-p) string)))
+ (list* 'boundaries
+ ;; if `string' is "C:" in w32, (file-name-directory string)
+ ;; returns "C:/", so `start' is 3 rather than 2.
+ ;; Not quite sure what is The Right Fix, but clipping it
+ ;; back to 2 will work for this particular case. We'll
+ ;; see if we can come up with a better fix when we bump
+ ;; into more such problematic cases.
+ (min start (length string)) end)))
+
+ ((eq action 'lambda)
+ (if (zerop (length string))
+ nil ;Not sure why it's here, but it probably doesn't harm.
+ (funcall (or pred 'file-exists-p) string)))
(t
(let* ((name (file-name-nondirectory string))
@@ -1358,19 +1435,20 @@ except that it passes the file name through `substitute-in-file-name'."
(cond
((eq (car-safe action) 'boundaries)
;; For the boundaries, we can't really delegate to
- ;; completion-file-name-table and then fix them up, because it
- ;; would require us to track the relationship between `str' and
+ ;; substitute-in-file-name+completion-file-name-table and then fix
+ ;; them up (as we do for the other actions), because it would
+ ;; require us to track the relationship between `str' and
;; `string', which is difficult. And in any case, if
- ;; substitute-in-file-name turns "fo-$TO-ba" into "fo-o/b-ba", there's
- ;; no way for us to return proper boundaries info, because the
- ;; boundary is not (yet) in `string'.
- ;; FIXME: Actually there is a way to return correct boundaries info,
- ;; at the condition of modifying the all-completions return accordingly.
- (let ((start (length (file-name-directory string)))
- (end (string-match-p "/" (cdr action))))
- (list* 'boundaries start end)))
+ ;; substitute-in-file-name turns "fo-$TO-ba" into "fo-o/b-ba",
+ ;; there's no way for us to return proper boundaries info, because
+ ;; the boundary is not (yet) in `string'.
+ ;;
+ ;; FIXME: Actually there is a way to return correct boundaries
+ ;; info, at the condition of modifying the all-completions
+ ;; return accordingly. But for now, let's not bother.
+ (completion-file-name-table string pred action))
- (t
+ (t
(let* ((default-directory
(if (stringp pred)
;; It used to be that `pred' was abused to pass `dir'
@@ -1382,7 +1460,9 @@ except that it passes the file name through `substitute-in-file-name'."
(substitute-in-file-name string)
(error string)))
(comp (completion-file-name-table
- str (or pred read-file-name-predicate) action)))
+ str
+ (with-no-warnings (or pred read-file-name-predicate))
+ action)))
(cond
((stringp comp)
@@ -1712,6 +1792,12 @@ Return the new suffix."
;; Nothing to merge.
suffix))
+(defun completion-basic--pattern (beforepoint afterpoint bounds)
+ (delete
+ "" (list (substring beforepoint (car bounds))
+ 'point
+ (substring afterpoint 0 (cdr bounds)))))
+
(defun completion-basic-try-completion (string table pred point)
(lexical-let*
((beforepoint (substring string 0 point))
@@ -1782,6 +1868,14 @@ expression (not containing character ranges like `a-z')."
:group 'minibuffer
:type 'string)
+(defcustom completion-pcm-complete-word-inserts-delimiters nil
+ "Treat the SPC or - inserted by `minibuffer-complete-word' as delimiters.
+Those chars are treated as delimiters iff this variable is non-nil.
+I.e. if non-nil, M-x SPC will just insert a \"-\" in the minibuffer, whereas
+if nil, it will list all possible commands in *Completions* because none of
+the commands start with a \"-\" or a SPC."
+ :type 'boolean)
+
(defun completion-pcm--pattern-trivial-p (pattern)
(and (stringp (car pattern))
;; It can be followed by `point' and "" and still be trivial.
@@ -1794,7 +1888,7 @@ expression (not containing character ranges like `a-z')."
(defun completion-pcm--string->pattern (string &optional point)
"Split STRING into a pattern.
A pattern is a list where each element is either a string
-or a symbol chosen among `any', `star', `point'."
+or a symbol chosen among `any', `star', `point', `prefix'."
(if (and point (< point (length string)))
(let ((prefix (substring string 0 point))
(suffix (substring string point)))
@@ -1807,11 +1901,12 @@ or a symbol chosen among `any', `star', `point'."
(while (and (setq p (string-match completion-pcm--delim-wild-regex
string p))
- ;; If the char was added by minibuffer-complete-word, then
- ;; don't treat it as a delimiter, otherwise "M-x SPC"
- ;; ends up inserting a "-" rather than listing
- ;; all completions.
- (not (get-text-property p 'completion-try-word string)))
+ (or completion-pcm-complete-word-inserts-delimiters
+ ;; If the char was added by minibuffer-complete-word,
+ ;; then don't treat it as a delimiter, otherwise
+ ;; "M-x SPC" ends up inserting a "-" rather than listing
+ ;; all completions.
+ (not (get-text-property p 'completion-try-word string))))
;; Usually, completion-pcm--delim-wild-regex matches a delimiter,
;; meaning that something can be added *before* it, but it can also
;; match a prefix and postfix, in which case something can be added
@@ -1837,11 +1932,10 @@ or a symbol chosen among `any', `star', `point'."
(concat "\\`"
(mapconcat
(lambda (x)
- (case x
- ((star any point)
- (if (if (consp group) (memq x group) group)
- "\\(.*?\\)" ".*?"))
- (t (regexp-quote x))))
+ (cond
+ ((stringp x) (regexp-quote x))
+ ((if (consp group) (memq x group) group) "\\(.*?\\)")
+ (t ".*?")))
pattern
""))))
;; Avoid pathological backtracking.
@@ -1997,6 +2091,17 @@ filter out additional entries (because TABLE migth not obey PRED)."
(nconc (completion-pcm--hilit-commonality pattern all)
(length prefix)))))
+(defun completion--sreverse (str)
+ "Like `reverse' but for a string STR rather than a list."
+ (apply 'string (nreverse (mapcar 'identity str))))
+
+(defun completion--common-suffix (strs)
+ "Return the common suffix of the strings STRS."
+ (completion--sreverse
+ (try-completion
+ ""
+ (mapcar 'completion--sreverse strs))))
+
(defun completion-pcm--merge-completions (strs pattern)
"Extract the commonality in STRS, with the help of PATTERN."
;; When completing while ignoring case, we want to try and avoid
@@ -2058,7 +2163,17 @@ filter out additional entries (because TABLE migth not obey PRED)."
;; `any' into a `star' because the surrounding context has
;; changed such that string->pattern wouldn't add an `any'
;; here any more.
- (unless unique (push elem res))
+ (unless unique
+ (push elem res)
+ (when (memq elem '(star point prefix))
+ ;; Extract common suffix additionally to common prefix.
+ ;; Only do it for `point', `star', and `prefix' since for
+ ;; `any' it could lead to a merged completion that
+ ;; doesn't itself match the candidates.
+ (let ((suffix (completion--common-suffix comps)))
+ (assert (stringp suffix))
+ (unless (equal suffix "")
+ (push suffix res)))))
(setq fixed "")))))
;; We return it in reverse order.
res)))))
@@ -2067,8 +2182,7 @@ filter out additional entries (because TABLE migth not obey PRED)."
(mapconcat (lambda (x) (cond
((stringp x) x)
((eq x 'star) "*")
- ((eq x 'any) "")
- ((eq x 'point) "")))
+ (t ""))) ;any, point, prefix.
pattern
""))
@@ -2110,6 +2224,7 @@ filter out additional entries (because TABLE migth not obey PRED)."
(pointpat (or (memq 'point mergedpat)
(memq 'any mergedpat)
(memq 'star mergedpat)
+ ;; Not `prefix'.
mergedpat))
;; New pos from the start.
(newpos (length (completion-pcm--pattern->string pointpat)))
@@ -2127,7 +2242,38 @@ filter out additional entries (because TABLE migth not obey PRED)."
'completion-pcm--filename-try-filter))
(completion-pcm--merge-try pattern all prefix suffix)))
-;;; Initials completion
+;;; Substring completion
+;; Mostly derived from the code of `basic' completion.
+
+(defun completion-substring--all-completions (string table pred point)
+ (let* ((beforepoint (substring string 0 point))
+ (afterpoint (substring string point))
+ (bounds (completion-boundaries beforepoint table pred afterpoint))
+ (suffix (substring afterpoint (cdr bounds)))
+ (prefix (substring beforepoint 0 (car bounds)))
+ (basic-pattern (completion-basic--pattern
+ beforepoint afterpoint bounds))
+ (pattern (if (not (stringp (car basic-pattern)))
+ basic-pattern
+ (cons 'prefix basic-pattern)))
+ (all (completion-pcm--all-completions prefix pattern table pred)))
+ (list all pattern prefix suffix (car bounds))))
+
+(defun completion-substring-try-completion (string table pred point)
+ (destructuring-bind (all pattern prefix suffix carbounds)
+ (completion-substring--all-completions string table pred point)
+ (if minibuffer-completing-file-name
+ (setq all (completion-pcm--filename-try-filter all)))
+ (completion-pcm--merge-try pattern all prefix suffix)))
+
+(defun completion-substring-all-completions (string table pred point)
+ (destructuring-bind (all pattern prefix suffix carbounds)
+ (completion-substring--all-completions string table pred point)
+ (when all
+ (nconc (completion-pcm--hilit-commonality pattern all)
+ (length prefix)))))
+
+;; Initials completion
;; Complete /ums to /usr/monnier/src or lch to list-command-history.
(defun completion-initials-expand (str table pred)
diff --git a/lisp/misc.el b/lisp/misc.el
index 4b2e78a3137..55b685fe2b7 100644
--- a/lisp/misc.el
+++ b/lisp/misc.el
@@ -1,10 +1,11 @@
;;; misc.el --- some nonstandard basic editing commands for Emacs
-;; Copyright (C) 1989, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1989, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+;; 2009, 2010 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: convenience
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -53,7 +54,7 @@ The characters copied are inserted in the buffer before point."
(setq string (concat string
(buffer-substring
(point)
- (min (save-excursion (end-of-line) (point))
+ (min (line-end-position)
(+ n (point)))))))
(insert string)))
@@ -131,5 +132,4 @@ variation of `C-x M-c M-butterfly' from url `http://xkcd.com/378/'."
(provide 'misc)
-;; arch-tag: 908f7884-c19e-4388-920c-9cfa425e449b
;;; misc.el ends here
diff --git a/lisp/mouse-drag.el b/lisp/mouse-drag.el
index 4dc57529385..e024b2aa551 100644
--- a/lisp/mouse-drag.el
+++ b/lisp/mouse-drag.el
@@ -1,7 +1,7 @@
;;; mouse-drag.el --- use mouse-2 to do a new style of scrolling
-;; Copyright (C) 1996, 1997, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: John Heidemann <johnh@ISI.EDU>
;; Keywords: mouse
@@ -163,7 +163,7 @@ Basically, we check for existing horizontal scrolling."
mouse-drag-electric-col-scrolling
(save-excursion ;; on a long line?
(let
- ((beg (progn (beginning-of-line) (point)))
+ ((beg (line-beginning-position))
(end (progn (end-of-line) (point))))
(if (> (- end beg) (window-width))
(setq truncate-lines t)
@@ -326,5 +326,4 @@ To test this function, evaluate:
(provide 'mouse-drag)
-;; arch-tag: e47354ff-82f5-42c4-b3dc-88dd9c04b770
;;; mouse-drag.el ends here
diff --git a/lisp/mouse-sel.el b/lisp/mouse-sel.el
index b057e41e78a..9b4a048131e 100644
--- a/lisp/mouse-sel.el
+++ b/lisp/mouse-sel.el
@@ -98,7 +98,7 @@
;;
;; Selection/kill-ring interaction is retained
;; interprogram-cut-function = x-select-text
-;; interprogram-paste-function = x-cut-buffer-or-selection-value
+;; interprogram-paste-function = x-selection-value
;;
;; What you lose is the ability to select some text in
;; delete-selection-mode and yank over the top of it.
@@ -129,11 +129,6 @@
;; that the X primary selection is used. Under other windowing systems,
;; alternate functions are used, which simply store the selection value
;; in a variable.
-;;
-;; * You can change the selection highlight face by altering the properties
-;; of mouse-drag-overlay, eg.
-;;
-;; (overlay-put mouse-drag-overlay 'face 'bold)
;;; Code:
@@ -293,8 +288,7 @@ primary selection and region."
(overlay-put mouse-secondary-overlay 'face 'secondary-selection))
(defconst mouse-sel-selection-alist
- '((PRIMARY mouse-drag-overlay mouse-sel-primary-thing)
- (SECONDARY mouse-secondary-overlay mouse-sel-secondary-thing))
+ '((SECONDARY mouse-secondary-overlay mouse-sel-secondary-thing))
"Alist associating selections with variables.
Each element is of the form:
@@ -305,7 +299,7 @@ where SELECTION-NAME = name of selection
SELECTION-THING-SYMBOL = name of variable where the current selection
type for this selection should be stored.")
-(declare-function x-select-text "term/x-win" (text &optional push))
+(declare-function x-select-text "term/common-win" (text))
(defvar mouse-sel-set-selection-function
(if (eq mouse-sel-default-bindings 'interprogram-cut-paste)
@@ -320,15 +314,15 @@ Called with two arguments:
SELECTION, the name of the selection concerned, and
VALUE, the text to store.
-This sets the selection as well as the cut buffer for the older applications,
-unless `mouse-sel-default-bindings' is `interprogram-cut-paste'.")
+This sets the selection, unless `mouse-sel-default-bindings'
+is `interprogram-cut-paste'.")
-(declare-function x-cut-buffer-or-selection-value "term/x-win" ())
+(declare-function x-selection-value "term/x-win" ())
(defvar mouse-sel-get-selection-function
(lambda (selection)
(if (eq selection 'PRIMARY)
- (or (x-cut-buffer-or-selection-value)
+ (or (x-selection-value)
(bound-and-true-p x-last-selected-text)
(bound-and-true-p x-last-selected-text-primary))
(x-get-selection selection)))
diff --git a/lisp/mouse.el b/lisp/mouse.el
index e88c2669714..40e0c14c064 100644
--- a/lisp/mouse.el
+++ b/lisp/mouse.el
@@ -5,6 +5,7 @@
;; Maintainer: FSF
;; Keywords: hardware, mouse
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -41,10 +42,13 @@
:type 'boolean
:group 'mouse)
-(defcustom mouse-drag-copy-region t
- "If non-nil, mouse drag copies region to kill-ring."
+(defcustom mouse-drag-copy-region nil
+ "If non-nil, copy to kill-ring upon mouse adjustments of the region.
+
+This affects `mouse-save-then-kill' (\\[mouse-save-then-kill]) in
+addition to mouse drags."
:type 'boolean
- :version "22.1"
+ :version "24.1"
:group 'mouse)
(defcustom mouse-1-click-follows-link 450
@@ -697,9 +701,6 @@ This should be bound to a mouse drag event."
(window-system)
(sit-for 1))
(push-mark)
- ;; If `select-active-regions' is non-nil, `set-mark' sets the
- ;; primary selection to the buffer's region, overriding the role
- ;; of `copy-region-as-kill'; that's why we did the copy first.
(set-mark (point))
(if (numberp end) (goto-char end))
(mouse-set-region-1)))
@@ -772,13 +773,6 @@ Upon exit, point is at the far edge of the newly visible text."
(or (eq window (selected-window))
(goto-char opoint))))
-;; Create an overlay and immediately delete it, to get "overlay in no buffer".
-(defconst mouse-drag-overlay
- (let ((ol (make-overlay (point-min) (point-min))))
- (delete-overlay ol)
- (overlay-put ol 'face 'region)
- ol))
-
(defvar mouse-selection-click-count 0)
(defvar mouse-selection-click-count-buffer nil)
@@ -904,33 +898,14 @@ at the same position."
"mouse-1" (substring msg 7)))))))
msg)
-(defun mouse-move-drag-overlay (ol start end mode)
- (unless (= start end)
- ;; Go to START first, so that when we move to END, if it's in the middle
- ;; of intangible text, point jumps in the direction away from START.
- ;; Don't do it if START=END otherwise a single click risks selecting
- ;; a region if it's on intangible text. This exception was originally
- ;; only applied on entry to mouse-drag-region, which had the problem
- ;; that a tiny move during a single-click would cause the intangible
- ;; text to be selected.
- (goto-char start)
- (goto-char end)
- (setq end (point)))
- (let ((range (mouse-start-end start end mode)))
- (move-overlay ol (car range) (nth 1 range))))
-
(defun mouse-drag-track (start-event &optional
do-mouse-drag-region-post-process)
"Track mouse drags by highlighting area between point and cursor.
-The region will be defined with mark and point, and the overlay
-will be deleted after return. DO-MOUSE-DRAG-REGION-POST-PROCESS
-should only be used by mouse-drag-region."
+The region will be defined with mark and point.
+DO-MOUSE-DRAG-REGION-POST-PROCESS should only be used by
+`mouse-drag-region'."
(mouse-minibuffer-check start-event)
(setq mouse-selection-click-count-buffer (current-buffer))
- ;; We must call deactivate-mark before repositioning point.
- ;; Otherwise, for select-active-regions non-nil, we get the wrong
- ;; selection if the user drags a region, clicks elsewhere to
- ;; reposition point, then middle-clicks to paste the selection.
(deactivate-mark)
(let* ((original-window (selected-window))
;; We've recorded what we needed from the current buffer and
@@ -964,165 +939,146 @@ should only be used by mouse-drag-region."
;; Suppress automatic hscrolling, because that is a nuisance
;; when setting point near the right fringe (but see below).
(automatic-hscrolling-saved automatic-hscrolling)
- (automatic-hscrolling nil))
+ (automatic-hscrolling nil)
+ event end end-point)
+
(setq mouse-selection-click-count click-count)
;; In case the down click is in the middle of some intangible text,
;; use the end of that text, and put it in START-POINT.
(if (< (point) start-point)
(goto-char start-point))
(setq start-point (point))
- (if remap-double-click ;; Don't expand mouse overlay in links
+ (if remap-double-click
(setq click-count 0))
- (mouse-move-drag-overlay mouse-drag-overlay start-point start-point
- click-count)
- (overlay-put mouse-drag-overlay 'window start-window)
- (let (event end end-point last-end-point)
- (track-mouse
- (while (progn
- (setq event (read-event))
- (or (mouse-movement-p event)
- (memq (car-safe event) '(switch-frame select-window))))
- (if (memq (car-safe event) '(switch-frame select-window))
- nil
- ;; Automatic hscrolling did not occur during the call to
- ;; `read-event'; but if the user subsequently drags the
- ;; mouse, go ahead and hscroll.
- (let ((automatic-hscrolling automatic-hscrolling-saved))
- (redisplay))
- (setq end (event-end event)
- end-point (posn-point end))
- (if (numberp end-point)
- (setq last-end-point end-point))
-
- (cond
- ;; Are we moving within the original window?
- ((and (eq (posn-window end) start-window)
+
+ ;; Activate the region, using `mouse-start-end' to determine where
+ ;; to put point and mark (e.g., double-click will select a word).
+ (setq transient-mark-mode
+ (if (eq transient-mark-mode 'lambda)
+ '(only)
+ (cons 'only transient-mark-mode)))
+ (let ((range (mouse-start-end start-point start-point click-count)))
+ (push-mark (nth 0 range) t t)
+ (goto-char (nth 1 range)))
+
+ ;; Track the mouse until we get a non-movement event.
+ (track-mouse
+ (while (progn
+ (setq event (read-event))
+ (or (mouse-movement-p event)
+ (memq (car-safe event) '(switch-frame select-window))))
+ (unless (memq (car-safe event) '(switch-frame select-window))
+ ;; Automatic hscrolling did not occur during the call to
+ ;; `read-event'; but if the user subsequently drags the
+ ;; mouse, go ahead and hscroll.
+ (let ((automatic-hscrolling automatic-hscrolling-saved))
+ (redisplay))
+ (setq end (event-end event)
+ end-point (posn-point end))
+ (if (and (eq (posn-window end) start-window)
(integer-or-marker-p end-point))
- (mouse-move-drag-overlay mouse-drag-overlay start-point end-point click-count))
-
- (t
- (let ((mouse-row (cdr (cdr (mouse-position)))))
- (cond
- ((null mouse-row))
- ((< mouse-row top)
- (mouse-scroll-subr start-window (- mouse-row top)
- mouse-drag-overlay start-point))
- ((>= mouse-row bottom)
- (mouse-scroll-subr start-window (1+ (- mouse-row bottom))
- mouse-drag-overlay start-point)))))))))
-
- ;; In case we did not get a mouse-motion event
- ;; for the final move of the mouse before a drag event
- ;; pretend that we did get one.
- (when (and (memq 'drag (event-modifiers (car-safe event)))
- (setq end (event-end event)
- end-point (posn-point end))
+ (mouse--drag-set-mark-and-point start-point
+ end-point click-count)
+ (let ((mouse-row (cdr (cdr (mouse-position)))))
+ (cond
+ ((null mouse-row))
+ ((< mouse-row top)
+ (mouse-scroll-subr start-window (- mouse-row top)
+ nil start-point))
+ ((>= mouse-row bottom)
+ (mouse-scroll-subr start-window (1+ (- mouse-row bottom))
+ nil start-point))))))))
+
+ ;; Handle the terminating event if possible.
+ (when (consp event)
+ ;; Ensure that point is on the end of the last event.
+ (when (and (setq end-point (posn-point (event-end event)))
(eq (posn-window end) start-window)
- (integer-or-marker-p end-point))
- (mouse-move-drag-overlay mouse-drag-overlay start-point end-point click-count))
-
- ;; Handle the terminating event
- (if (consp event)
- (let* ((fun (key-binding (vector (car event))))
- (do-multi-click (and (> (event-click-count event) 0)
- (functionp fun)
- (not (memq fun
- '(mouse-set-point
- mouse-set-region))))))
- ;; Run the binding of the terminating up-event, if possible.
- (if (and (not (= (overlay-start mouse-drag-overlay)
- (overlay-end mouse-drag-overlay)))
- (not do-multi-click))
- (let* ((stop-point
- (if (numberp (posn-point (event-end event)))
- (posn-point (event-end event))
- last-end-point))
- ;; The end that comes from where we ended the drag.
- ;; Point goes here.
- (region-termination
- (if (and stop-point (< stop-point start-point))
- (overlay-start mouse-drag-overlay)
- (overlay-end mouse-drag-overlay)))
- ;; The end that comes from where we started the drag.
- ;; Mark goes there.
- (region-commencement
- (- (+ (overlay-end mouse-drag-overlay)
- (overlay-start mouse-drag-overlay))
- region-termination))
- last-command this-command)
- ;; We copy the region before setting the mark so
- ;; that `select-active-regions' can override
- ;; `copy-region-as-kill'.
- (and mouse-drag-copy-region
- do-mouse-drag-region-post-process
- (let (deactivate-mark)
- (copy-region-as-kill region-commencement
- region-termination)))
- (push-mark region-commencement t t)
- (goto-char region-termination)
- (if (not do-mouse-drag-region-post-process)
- ;; Skip all post-event handling, return immediately.
- (delete-overlay mouse-drag-overlay)
- (let ((buffer (current-buffer)))
- (mouse-show-mark)
- ;; mouse-show-mark can call read-event,
- ;; and that means the Emacs server could switch buffers
- ;; under us. If that happened,
- ;; avoid trying to use the region.
- (and (mark t) mark-active
- (eq buffer (current-buffer))
- (mouse-set-region-1)))))
- ;; Run the binding of the terminating up-event.
- ;; If a multiple click is not bound to mouse-set-point,
- ;; cancel the effects of mouse-move-drag-overlay to
- ;; avoid producing wrong results.
- (if do-multi-click (goto-char start-point))
- (delete-overlay mouse-drag-overlay)
- (when (and (functionp fun)
- (= start-hscroll (window-hscroll start-window))
- ;; Don't run the up-event handler if the
- ;; window start changed in a redisplay after
- ;; the mouse-set-point for the down-mouse
- ;; event at the beginning of this function.
- ;; When the window start has changed, the
- ;; up-mouse event will contain a different
- ;; position due to the new window contents,
- ;; and point is set again.
- (or end-point
- (= (window-start start-window)
- start-window-start)))
- (when (and on-link
- (or (not end-point) (= end-point start-point))
- (consp event)
- (or remap-double-click
- (and
- (not (eq mouse-1-click-follows-link 'double))
- (= click-count 0)
- (= (event-click-count event) 1)
- (or (not (integerp mouse-1-click-follows-link))
- (let ((t0 (posn-timestamp (event-start start-event)))
- (t1 (posn-timestamp (event-end event))))
- (and (integerp t0) (integerp t1)
- (if (> mouse-1-click-follows-link 0)
- (<= (- t1 t0) mouse-1-click-follows-link)
- (< (- t0 t1) mouse-1-click-follows-link))))))))
- ;; If we rebind to mouse-2, reselect previous selected window,
- ;; so that the mouse-2 event runs in the same
- ;; situation as if user had clicked it directly.
- ;; Fixes the bug reported by juri@jurta.org on 2005-12-27.
- (if (or (vectorp on-link) (stringp on-link))
- (setq event (aref on-link 0))
- (select-window original-window)
- (setcar event 'mouse-2)
- ;; If this mouse click has never been done by
- ;; the user, it doesn't have the necessary
- ;; property to be interpreted correctly.
- (put 'mouse-2 'event-kind 'mouse-click)))
- (push event unread-command-events))))
-
- ;; Case where the end-event is not a cons cell (it's just a boring
- ;; char-key-press).
- (delete-overlay mouse-drag-overlay)))))
+ (integer-or-marker-p end-point)
+ (/= start-point end-point))
+ (mouse--drag-set-mark-and-point start-point
+ end-point click-count))
+
+ ;; Find its binding.
+ (let* ((fun (key-binding (vector (car event))))
+ (do-multi-click (and (> (event-click-count event) 0)
+ (functionp fun)
+ (not (memq fun '(mouse-set-point
+ mouse-set-region))))))
+ (if (and (/= (mark) (point))
+ (not do-multi-click))
+
+ ;; If point has moved, finish the drag.
+ (let* (last-command this-command)
+ (and mouse-drag-copy-region
+ do-mouse-drag-region-post-process
+ (let (deactivate-mark)
+ (copy-region-as-kill (mark) (point)))))
+
+ ;; If point hasn't moved, run the binding of the
+ ;; terminating up-event.
+ (if do-multi-click
+ (goto-char start-point)
+ (deactivate-mark))
+ (when (and (functionp fun)
+ (= start-hscroll (window-hscroll start-window))
+ ;; Don't run the up-event handler if the window
+ ;; start changed in a redisplay after the
+ ;; mouse-set-point for the down-mouse event at
+ ;; the beginning of this function. When the
+ ;; window start has changed, the up-mouse event
+ ;; contains a different position due to the new
+ ;; window contents, and point is set again.
+ (or end-point
+ (= (window-start start-window)
+ start-window-start)))
+ (when (and on-link
+ (= start-point (point))
+ (mouse--remap-link-click-p start-event event))
+ ;; If we rebind to mouse-2, reselect previous selected
+ ;; window, so that the mouse-2 event runs in the same
+ ;; situation as if user had clicked it directly. Fixes
+ ;; the bug reported by juri@jurta.org on 2005-12-27.
+ (if (or (vectorp on-link) (stringp on-link))
+ (setq event (aref on-link 0))
+ (select-window original-window)
+ (setcar event 'mouse-2)
+ ;; If this mouse click has never been done by the
+ ;; user, it doesn't have the necessary property to be
+ ;; interpreted correctly.
+ (put 'mouse-2 'event-kind 'mouse-click)))
+ (push event unread-command-events)))))))
+
+(defun mouse--drag-set-mark-and-point (start click click-count)
+ (let* ((range (mouse-start-end start click click-count))
+ (beg (nth 0 range))
+ (end (nth 1 range)))
+ (cond ((eq (mark) beg)
+ (goto-char end))
+ ((eq (mark) end)
+ (goto-char beg))
+ ((< click (mark))
+ (set-mark end)
+ (goto-char beg))
+ (t
+ (set-mark beg)
+ (goto-char end)))))
+
+(defun mouse--remap-link-click-p (start-event end-event)
+ (or (and (eq mouse-1-click-follows-link 'double)
+ (= (event-click-count start-event) 2))
+ (and
+ (not (eq mouse-1-click-follows-link 'double))
+ (= (event-click-count start-event) 1)
+ (= (event-click-count end-event) 1)
+ (or (not (integerp mouse-1-click-follows-link))
+ (let ((t0 (posn-timestamp (event-start start-event)))
+ (t1 (posn-timestamp (event-end end-event))))
+ (and (integerp t0) (integerp t1)
+ (if (> mouse-1-click-follows-link 0)
+ (<= (- t1 t0) mouse-1-click-follows-link)
+ (< (- t0 t1) mouse-1-click-follows-link))))))))
+
;; Commands to handle xterm-style multiple clicks.
(defun mouse-skip-word (dir)
@@ -1223,8 +1179,7 @@ If MODE is 2 then do the same for lines."
((= mode 2)
(list (save-excursion
(goto-char start)
- (beginning-of-line 1)
- (point))
+ (line-beginning-position 1))
(save-excursion
(goto-char end)
(forward-line 1)
@@ -1262,74 +1217,6 @@ If MODE is 2 then do the same for lines."
;; Momentarily show where the mark is, if highlighting doesn't show it.
-(defcustom mouse-region-delete-keys '([delete] [deletechar] [backspace])
- "List of keys that should cause the mouse region to be deleted."
- :group 'mouse
- :type '(repeat key-sequence))
-
-(defun mouse-show-mark ()
- (let ((inhibit-quit t)
- (echo-keystrokes 0)
- event events key ignore
- (x-lost-selection-functions
- (when (boundp 'x-lost-selection-functions)
- (copy-sequence x-lost-selection-functions))))
- (add-hook 'x-lost-selection-functions
- (lambda (seltype)
- (when (eq seltype 'PRIMARY)
- (setq ignore t)
- (throw 'mouse-show-mark t))))
- (if transient-mark-mode
- (delete-overlay mouse-drag-overlay)
- (move-overlay mouse-drag-overlay (point) (mark t)))
- (catch 'mouse-show-mark
- ;; In this loop, execute scroll bar and switch-frame events.
- ;; Should we similarly handle `select-window' events? --Stef
- ;; Also ignore down-events that are undefined.
- (while (progn (setq event (read-event))
- (setq events (append events (list event)))
- (setq key (apply 'vector events))
- (or (and (consp event)
- (eq (car event) 'switch-frame))
- (and (consp event)
- (eq (posn-point (event-end event))
- 'vertical-scroll-bar))
- (and (memq 'down (event-modifiers event))
- (not (key-binding key))
- (not (mouse-undouble-last-event events))
- (not (member key mouse-region-delete-keys)))))
- (and (consp event)
- (or (eq (car event) 'switch-frame)
- (eq (posn-point (event-end event))
- 'vertical-scroll-bar))
- (let ((keys (vector 'vertical-scroll-bar event)))
- (and (key-binding keys)
- (progn
- (call-interactively (key-binding keys)
- nil keys)
- (setq events nil)))))))
- ;; If we lost the selection, just turn off the highlighting.
- (unless ignore
- ;; For certain special keys, delete the region.
- (if (member key mouse-region-delete-keys)
- (progn
- ;; Since notionally this is a separate command,
- ;; run all the hooks that would be run if it were
- ;; executed separately.
- (run-hooks 'post-command-hook)
- (setq last-command this-command)
- (setq this-original-command 'delete-region)
- (setq this-command (or (command-remapping this-original-command)
- this-original-command))
- (run-hooks 'pre-command-hook)
- (call-interactively this-command))
- ;; Otherwise, unread the key so it gets executed normally.
- (setq unread-command-events
- (nconc events unread-command-events))))
- (setq quit-flag nil)
- (unless transient-mark-mode
- (delete-overlay mouse-drag-overlay))))
-
(defun mouse-set-mark (click)
"Set mark at the position clicked on with the mouse.
Display cursor at that position for a second.
@@ -1364,9 +1251,7 @@ Also move point to one end of the text thus inserted (normally the end),
and set mark at the beginning.
Prefix arguments are interpreted as with \\[yank].
If `mouse-yank-at-point' is non-nil, insert at point
-regardless of where you click.
-If `select-active-regions' is non-nil, the mark is deactivated
-before inserting the text."
+regardless of where you click."
(interactive "e\nP")
;; Give temporary modes such as isearch a chance to turn off.
(run-hooks 'mouse-leave-buffer-hook)
@@ -1387,15 +1272,23 @@ regardless of where you click."
(interactive "e")
;; Give temporary modes such as isearch a chance to turn off.
(run-hooks 'mouse-leave-buffer-hook)
+ ;; Without this, confusing things happen upon e.g. inserting into
+ ;; the middle of an active region.
(when select-active-regions
- ;; Without this, confusing things happen upon e.g. inserting into
- ;; the middle of an active region.
- (deactivate-mark))
+ (let (select-active-regions)
+ (deactivate-mark)))
(or mouse-yank-at-point (mouse-set-point click))
- (let ((primary (x-get-selection 'PRIMARY)))
+ (let ((primary
+ (cond
+ ((fboundp 'x-get-selection-value) ; MS-DOS, MS-Windows and X.
+ (or (x-get-selection-value)
+ (x-get-selection 'PRIMARY)))
+ ;; FIXME: What about xterm-mouse-mode etc.?
+ (t
+ (x-get-selection 'PRIMARY)))))
(if primary
- (insert (x-get-selection 'PRIMARY))
- (error "No primary selection"))))
+ (insert primary)
+ (error "No selection is available"))))
(defun mouse-kill-ring-save (click)
"Copy the region between point and the mouse click in the kill ring.
@@ -1403,15 +1296,13 @@ This does not delete the region; it acts like \\[kill-ring-save]."
(interactive "e")
(mouse-set-mark-fast click)
(let (this-command last-command)
- (kill-ring-save (point) (mark t)))
- (mouse-show-mark))
+ (kill-ring-save (point) (mark t))))
;; This function used to delete the text between point and the mouse
;; whenever it was equal to the front of the kill ring, but some
;; people found that confusing.
-;; A list (TEXT START END), describing the text and position of the last
-;; invocation of mouse-save-then-kill.
+;; The position of the last invocation of `mouse-save-then-kill'.
(defvar mouse-save-then-kill-posn nil)
(defun mouse-save-then-kill-delete-region (beg end)
@@ -1449,100 +1340,90 @@ This does not delete the region; it acts like \\[kill-ring-save]."
(undo-boundary))
(defun mouse-save-then-kill (click)
- "Save text to point in kill ring; the second time, kill the text.
-If the text between point and the mouse is the same as what's
-at the front of the kill ring, this deletes the text.
-Otherwise, it adds the text to the kill ring, like \\[kill-ring-save],
-which prepares for a second click to delete the text.
-
-If you have selected words or lines, this command extends the
-selection through the word or line clicked on. If you do this
-again in a different position, it extends the selection again.
-If you do this twice in the same position, the selection is killed."
+ "Set the region according to CLICK; the second time, kill it.
+CLICK should be a mouse click event.
+
+If the region is inactive, activate it temporarily. Set mark at
+the original point, and move point to the position of CLICK.
+
+If the region is already active, adjust it. Normally, do this by
+moving point or mark, whichever is closer, to CLICK. But if you
+have selected whole words or lines, move point or mark to the
+word or line boundary closest to CLICK instead.
+
+If `mouse-drag-copy-region' is non-nil, this command also saves the
+new region to the kill ring (replacing the previous kill if the
+previous region was just saved to the kill ring).
+
+If this command is called a second consecutive time with the same
+CLICK position, kill the region (or delete it
+if `mouse-drag-copy-region' is non-nil)"
(interactive "e")
- (let ((before-scroll
- (with-current-buffer (window-buffer (posn-window (event-start click)))
- point-before-scroll)))
- (mouse-minibuffer-check click)
- (let ((click-posn (posn-point (event-start click)))
- ;; Don't let a subsequent kill command append to this one:
- ;; prevent setting this-command to kill-region.
- (this-command this-command))
- (if (and (with-current-buffer
- (window-buffer (posn-window (event-start click)))
- (and (mark t) (> (mod mouse-selection-click-count 3) 0)
- ;; Don't be fooled by a recent click in some other buffer.
- (eq mouse-selection-click-count-buffer
- (current-buffer)))))
- (if (not (and (eq last-command 'mouse-save-then-kill)
- (equal click-posn
- (car (cdr-safe (cdr-safe mouse-save-then-kill-posn))))))
- ;; Find both ends of the object selected by this click.
- (let* ((range
- (mouse-start-end click-posn click-posn
- mouse-selection-click-count)))
- ;; Move whichever end is closer to the click.
- ;; That's what xterm does, and it seems reasonable.
- (if (< (abs (- click-posn (mark t)))
- (abs (- click-posn (point))))
- (set-mark (car range))
- (goto-char (nth 1 range)))
- ;; We have already put the old region in the kill ring.
- ;; Replace it with the extended region.
- ;; (It would be annoying to make a separate entry.)
- (kill-new (buffer-substring (point) (mark t)) t)
- (mouse-set-region-1)
- ;; Arrange for a repeated mouse-3 to kill this region.
- (setq mouse-save-then-kill-posn
- (list (car kill-ring) (point) click-posn))
- (mouse-show-mark))
- ;; If we click this button again without moving it,
- ;; that time kill.
- (mouse-save-then-kill-delete-region (mark) (point))
- (setq mouse-selection-click-count 0)
- (setq mouse-save-then-kill-posn nil))
- (if (and (eq last-command 'mouse-save-then-kill)
- mouse-save-then-kill-posn
- (eq (car mouse-save-then-kill-posn) (car kill-ring))
- (equal (cdr mouse-save-then-kill-posn) (list (point) click-posn)))
- ;; If this is the second time we've called
- ;; mouse-save-then-kill, delete the text from the buffer.
- (progn
- (mouse-save-then-kill-delete-region (point) (mark))
- ;; After we kill, another click counts as "the first time".
- (setq mouse-save-then-kill-posn nil))
- ;; This is not a repetition.
- ;; We are adjusting an old selection or creating a new one.
- (if (or (and (eq last-command 'mouse-save-then-kill)
- mouse-save-then-kill-posn)
- (and mark-active transient-mark-mode)
- (and (memq last-command
- '(mouse-drag-region mouse-set-region))
- (or mark-even-if-inactive
- (not transient-mark-mode))))
- ;; We have a selection or suitable region, so adjust it.
- (let* ((posn (event-start click))
- (new (posn-point posn)))
- (select-window (posn-window posn))
- (if (numberp new)
- (progn
- ;; Move whichever end of the region is closer to the click.
- ;; That is what xterm does, and it seems reasonable.
- (if (<= (abs (- new (point))) (abs (- new (mark t))))
- (goto-char new)
- (set-mark new))
- (setq deactivate-mark nil)))
- (kill-new (buffer-substring (point) (mark t)) t))
- ;; Set the mark where point is, then move where clicked.
- (mouse-set-mark-fast click)
- (if before-scroll
- (goto-char before-scroll))
- (exchange-point-and-mark) ;Why??? --Stef
- (kill-new (buffer-substring (point) (mark t))))
- (mouse-show-mark)
- (mouse-set-region-1)
- (setq mouse-save-then-kill-posn
- (list (car kill-ring) (point) click-posn)))))))
+ (mouse-minibuffer-check click)
+ (let* ((posn (event-start click))
+ (click-pt (posn-point posn))
+ (window (posn-window posn))
+ (buf (window-buffer window))
+ ;; Don't let a subsequent kill command append to this one.
+ (this-command this-command)
+ ;; Check if the user has multi-clicked to select words/lines.
+ (click-count
+ (if (and (eq mouse-selection-click-count-buffer buf)
+ (with-current-buffer buf (mark t)))
+ mouse-selection-click-count
+ 0)))
+ (cond
+ ((not (numberp click-pt)) nil)
+ ;; If the user clicked without moving point, kill the region.
+ ;; This also resets `mouse-selection-click-count'.
+ ((and (eq last-command 'mouse-save-then-kill)
+ (eq click-pt mouse-save-then-kill-posn)
+ (eq window (selected-window)))
+ (if mouse-drag-copy-region
+ ;; Region already saved in the previous click;
+ ;; don't make a duplicate entry, just delete.
+ (delete-region (mark t) (point))
+ (kill-region (mark t) (point)))
+ (setq mouse-selection-click-count 0)
+ (setq mouse-save-then-kill-posn nil))
+
+ ;; Otherwise, if there is a suitable region, adjust it by moving
+ ;; one end (whichever is closer) to CLICK-PT.
+ ((or (with-current-buffer buf (region-active-p))
+ (and (eq window (selected-window))
+ (mark t)
+ (or (and (eq last-command 'mouse-save-then-kill)
+ mouse-save-then-kill-posn)
+ (and (memq last-command '(mouse-drag-region
+ mouse-set-region))
+ (or mark-even-if-inactive
+ (not transient-mark-mode))))))
+ (select-window window)
+ (let* ((range (mouse-start-end click-pt click-pt click-count)))
+ (if (< (abs (- click-pt (mark t)))
+ (abs (- click-pt (point))))
+ (set-mark (car range))
+ (goto-char (nth 1 range)))
+ (setq deactivate-mark nil)
+ (mouse-set-region-1)
+ (when mouse-drag-copy-region
+ ;; Region already copied to kill-ring once, so replace.
+ (kill-new (filter-buffer-substring (mark t) (point)) t))
+ ;; Arrange for a repeated mouse-3 to kill the region.
+ (setq mouse-save-then-kill-posn click-pt)))
+
+ ;; Otherwise, set the mark where point is and move to CLICK-PT.
+ (t
+ (select-window window)
+ (mouse-set-mark-fast click)
+ (let ((before-scroll (with-current-buffer buf point-before-scroll)))
+ (if before-scroll (goto-char before-scroll)))
+ (exchange-point-and-mark)
+ (mouse-set-region-1)
+ (when mouse-drag-copy-region
+ (kill-new (filter-buffer-substring (mark t) (point))))
+ (setq mouse-save-then-kill-posn click-pt)))))
+
(global-set-key [M-mouse-1] 'mouse-start-secondary)
(global-set-key [M-drag-mouse-1] 'mouse-set-secondary)
@@ -1622,9 +1503,6 @@ The function returns a non-nil value if it creates a secondary selection."
;; of one word or line.
(let ((range (mouse-start-end start-point start-point click-count)))
(set-marker mouse-secondary-start nil)
- ;; Why the double move? --Stef
- ;; (move-overlay mouse-secondary-overlay 1 1
- ;; (window-buffer start-window))
(move-overlay mouse-secondary-overlay (car range) (nth 1 range)
(window-buffer start-window)))
;; Single-press: cancel any preexisting secondary selection.
@@ -1692,7 +1570,7 @@ regardless of where you click."
(or mouse-yank-at-point (mouse-set-point click))
(let ((secondary (x-get-selection 'SECONDARY)))
(if secondary
- (insert (x-get-selection 'SECONDARY))
+ (insert secondary)
(error "No secondary selection"))))
(defun mouse-kill-secondary ()
@@ -1718,117 +1596,99 @@ is to prevent accidents."
(delete-overlay mouse-secondary-overlay))
(defun mouse-secondary-save-then-kill (click)
- "Save text to point in kill ring; the second time, kill the text.
-You must use this in a buffer where you have recently done \\[mouse-start-secondary].
-If the text between where you did \\[mouse-start-secondary] and where
-you use this command matches the text at the front of the kill ring,
-this command deletes the text.
-Otherwise, it adds the text to the kill ring, like \\[kill-ring-save],
-which prepares for a second click with this command to delete the text.
-
-If you have already made a secondary selection in that buffer,
-this command extends or retracts the selection to where you click.
-If you do this again in a different position, it extends or retracts
-again. If you do this twice in the same position, it kills the selection."
+ "Set the secondary selection and save it to the kill ring.
+The second time, kill it. CLICK should be a mouse click event.
+
+If you have not called `mouse-start-secondary' in the clicked
+buffer, activate the secondary selection and set it between point
+and the click position CLICK.
+
+Otherwise, adjust the bounds of the secondary selection.
+Normally, do this by moving its beginning or end, whichever is
+closer, to CLICK. But if you have selected whole words or lines,
+adjust to the word or line boundary closest to CLICK instead.
+
+If this command is called a second consecutive time with the same
+CLICK position, kill the secondary selection."
(interactive "e")
(mouse-minibuffer-check click)
- (let ((posn (event-start click))
- (click-posn (posn-point (event-start click)))
- ;; Don't let a subsequent kill command append to this one:
- ;; prevent setting this-command to kill-region.
- (this-command this-command))
- (or (eq (window-buffer (posn-window posn))
- (or (overlay-buffer mouse-secondary-overlay)
- (if mouse-secondary-start
- (marker-buffer mouse-secondary-start))))
- (error "Wrong buffer"))
- (with-current-buffer (window-buffer (posn-window posn))
- (if (> (mod mouse-secondary-click-count 3) 0)
- (if (not (and (eq last-command 'mouse-secondary-save-then-kill)
- (equal click-posn
- (car (cdr-safe (cdr-safe mouse-save-then-kill-posn))))))
- ;; Find both ends of the object selected by this click.
- (let* ((range
- (mouse-start-end click-posn click-posn
- mouse-secondary-click-count)))
- ;; Move whichever end is closer to the click.
- ;; That's what xterm does, and it seems reasonable.
- (if (< (abs (- click-posn (overlay-start mouse-secondary-overlay)))
- (abs (- click-posn (overlay-end mouse-secondary-overlay))))
- (move-overlay mouse-secondary-overlay (car range)
- (overlay-end mouse-secondary-overlay))
- (move-overlay mouse-secondary-overlay
- (overlay-start mouse-secondary-overlay)
- (nth 1 range)))
- ;; We have already put the old region in the kill ring.
- ;; Replace it with the extended region.
- ;; (It would be annoying to make a separate entry.)
- (kill-new (buffer-substring
- (overlay-start mouse-secondary-overlay)
- (overlay-end mouse-secondary-overlay)) t)
- ;; Arrange for a repeated mouse-3 to kill this region.
- (setq mouse-save-then-kill-posn
- (list (car kill-ring) (point) click-posn)))
- ;; If we click this button again without moving it,
- ;; that time kill.
- (progn
- (mouse-save-then-kill-delete-region
- (overlay-start mouse-secondary-overlay)
- (overlay-end mouse-secondary-overlay))
- (setq mouse-save-then-kill-posn nil)
- (setq mouse-secondary-click-count 0)
- (delete-overlay mouse-secondary-overlay)))
- (if (and (eq last-command 'mouse-secondary-save-then-kill)
- mouse-save-then-kill-posn
- (eq (car mouse-save-then-kill-posn) (car kill-ring))
- (equal (cdr mouse-save-then-kill-posn) (list (point) click-posn)))
- ;; If this is the second time we've called
- ;; mouse-secondary-save-then-kill, delete the text from the buffer.
- (progn
- (mouse-save-then-kill-delete-region
- (overlay-start mouse-secondary-overlay)
- (overlay-end mouse-secondary-overlay))
- (setq mouse-save-then-kill-posn nil)
- (delete-overlay mouse-secondary-overlay))
- (if (overlay-start mouse-secondary-overlay)
- ;; We have a selection, so adjust it.
- (progn
- (if (numberp click-posn)
- (progn
- ;; Move whichever end of the region is closer to the click.
- ;; That is what xterm does, and it seems reasonable.
- (if (< (abs (- click-posn (overlay-start mouse-secondary-overlay)))
- (abs (- click-posn (overlay-end mouse-secondary-overlay))))
- (move-overlay mouse-secondary-overlay click-posn
- (overlay-end mouse-secondary-overlay))
- (move-overlay mouse-secondary-overlay
- (overlay-start mouse-secondary-overlay)
- click-posn))
- (setq deactivate-mark nil)))
- (if (eq last-command 'mouse-secondary-save-then-kill)
- ;; If the front of the kill ring comes from
- ;; an immediately previous use of this command,
- ;; replace it with the extended region.
- ;; (It would be annoying to make a separate entry.)
- (kill-new (buffer-substring
- (overlay-start mouse-secondary-overlay)
- (overlay-end mouse-secondary-overlay)) t)
- (let (deactivate-mark)
- (copy-region-as-kill (overlay-start mouse-secondary-overlay)
- (overlay-end mouse-secondary-overlay)))))
- (if mouse-secondary-start
- ;; All we have is one end of a selection,
- ;; so put the other end here.
- (let ((start (+ 0 mouse-secondary-start)))
- (kill-ring-save start click-posn)
- (move-overlay mouse-secondary-overlay start click-posn))))
- (setq mouse-save-then-kill-posn
- (list (car kill-ring) (point) click-posn))))
- (if (overlay-buffer mouse-secondary-overlay)
- (x-set-selection 'SECONDARY
- (buffer-substring
- (overlay-start mouse-secondary-overlay)
- (overlay-end mouse-secondary-overlay)))))))
+ (let* ((posn (event-start click))
+ (click-pt (posn-point posn))
+ (window (posn-window posn))
+ (buf (window-buffer window))
+ ;; Don't let a subsequent kill command append to this one.
+ (this-command this-command)
+ ;; Check if the user has multi-clicked to select words/lines.
+ (click-count
+ (if (eq (overlay-buffer mouse-secondary-overlay) buf)
+ mouse-secondary-click-count
+ 0))
+ (beg (overlay-start mouse-secondary-overlay))
+ (end (overlay-end mouse-secondary-overlay)))
+
+ (cond
+ ((not (numberp click-pt)) nil)
+
+ ;; If the secondary selection is not active in BUF, activate it.
+ ((not (eq buf (or (overlay-buffer mouse-secondary-overlay)
+ (if mouse-secondary-start
+ (marker-buffer mouse-secondary-start)))))
+ (select-window window)
+ (setq mouse-secondary-start (make-marker))
+ (move-marker mouse-secondary-start (point))
+ (move-overlay mouse-secondary-overlay (point) click-pt buf)
+ (kill-ring-save (point) click-pt))
+
+ ;; If the user clicked without moving point, delete the secondary
+ ;; selection. This also resets `mouse-secondary-click-count'.
+ ((and (eq last-command 'mouse-secondary-save-then-kill)
+ (eq click-pt mouse-save-then-kill-posn)
+ (eq window (selected-window)))
+ (mouse-save-then-kill-delete-region beg end)
+ (delete-overlay mouse-secondary-overlay)
+ (setq mouse-secondary-click-count 0)
+ (setq mouse-save-then-kill-posn nil))
+
+ ;; Otherwise, if there is a suitable secondary selection overlay,
+ ;; adjust it by moving one end (whichever is closer) to CLICK-PT.
+ ((and beg (eq buf (overlay-buffer mouse-secondary-overlay)))
+ (let* ((range (mouse-start-end click-pt click-pt click-count)))
+ (if (< (abs (- click-pt beg))
+ (abs (- click-pt end)))
+ (move-overlay mouse-secondary-overlay (car range) end)
+ (move-overlay mouse-secondary-overlay beg (nth 1 range))))
+ (setq deactivate-mark nil)
+ (if (eq last-command 'mouse-secondary-save-then-kill)
+ ;; If the front of the kill ring comes from an immediately
+ ;; previous use of this command, replace the entry.
+ (kill-new
+ (buffer-substring (overlay-start mouse-secondary-overlay)
+ (overlay-end mouse-secondary-overlay))
+ t)
+ (let (deactivate-mark)
+ (copy-region-as-kill (overlay-start mouse-secondary-overlay)
+ (overlay-end mouse-secondary-overlay))))
+ (setq mouse-save-then-kill-posn click-pt))
+
+ ;; Otherwise, set the secondary selection overlay.
+ (t
+ (select-window window)
+ (if mouse-secondary-start
+ ;; All we have is one end of a selection, so put the other
+ ;; end here.
+ (let ((start (+ 0 mouse-secondary-start)))
+ (kill-ring-save start click-pt)
+ (move-overlay mouse-secondary-overlay start click-pt)))
+ (setq mouse-save-then-kill-posn click-pt))))
+
+ ;; Finally, set the window system's secondary selection.
+ (let (str)
+ (and (overlay-buffer mouse-secondary-overlay)
+ (setq str (buffer-substring (overlay-start mouse-secondary-overlay)
+ (overlay-end mouse-secondary-overlay)))
+ (> (length str) 0)
+ (x-set-selection 'SECONDARY str))))
+
(defcustom mouse-buffer-menu-maxlen 20
"Number of buffers in one pane (submenu) of the buffer menu.
@@ -2009,332 +1869,6 @@ and selects that window."
;; Few buffers--put them all in one pane.
(list (cons title alist))))
-;; These need to be rewritten for the new scroll bar implementation.
-
-;;!! ;; Commands for the scroll bar.
-;;!!
-;;!! (defun mouse-scroll-down (click)
-;;!! (interactive "@e")
-;;!! (scroll-down (1+ (cdr (mouse-coords click)))))
-;;!!
-;;!! (defun mouse-scroll-up (click)
-;;!! (interactive "@e")
-;;!! (scroll-up (1+ (cdr (mouse-coords click)))))
-;;!!
-;;!! (defun mouse-scroll-down-full ()
-;;!! (interactive "@")
-;;!! (scroll-down nil))
-;;!!
-;;!! (defun mouse-scroll-up-full ()
-;;!! (interactive "@")
-;;!! (scroll-up nil))
-;;!!
-;;!! (defun mouse-scroll-move-cursor (click)
-;;!! (interactive "@e")
-;;!! (move-to-window-line (1+ (cdr (mouse-coords click)))))
-;;!!
-;;!! (defun mouse-scroll-absolute (event)
-;;!! (interactive "@e")
-;;!! (let* ((pos (car event))
-;;!! (position (car pos))
-;;!! (length (car (cdr pos))))
-;;!! (if (<= length 0) (setq length 1))
-;;!! (let* ((scale-factor (max 1 (/ length (/ 8000000 (buffer-size)))))
-;;!! (newpos (* (/ (* (/ (buffer-size) scale-factor)
-;;!! position)
-;;!! length)
-;;!! scale-factor)))
-;;!! (goto-char newpos)
-;;!! (recenter '(4)))))
-;;!!
-;;!! (defun mouse-scroll-left (click)
-;;!! (interactive "@e")
-;;!! (scroll-left (1+ (car (mouse-coords click)))))
-;;!!
-;;!! (defun mouse-scroll-right (click)
-;;!! (interactive "@e")
-;;!! (scroll-right (1+ (car (mouse-coords click)))))
-;;!!
-;;!! (defun mouse-scroll-left-full ()
-;;!! (interactive "@")
-;;!! (scroll-left nil))
-;;!!
-;;!! (defun mouse-scroll-right-full ()
-;;!! (interactive "@")
-;;!! (scroll-right nil))
-;;!!
-;;!! (defun mouse-scroll-move-cursor-horizontally (click)
-;;!! (interactive "@e")
-;;!! (move-to-column (1+ (car (mouse-coords click)))))
-;;!!
-;;!! (defun mouse-scroll-absolute-horizontally (event)
-;;!! (interactive "@e")
-;;!! (let* ((pos (car event))
-;;!! (position (car pos))
-;;!! (length (car (cdr pos))))
-;;!! (set-window-hscroll (selected-window) 33)))
-;;!!
-;;!! (global-set-key [scroll-bar mouse-1] 'mouse-scroll-up)
-;;!! (global-set-key [scroll-bar mouse-2] 'mouse-scroll-absolute)
-;;!! (global-set-key [scroll-bar mouse-3] 'mouse-scroll-down)
-;;!!
-;;!! (global-set-key [vertical-slider mouse-1] 'mouse-scroll-move-cursor)
-;;!! (global-set-key [vertical-slider mouse-2] 'mouse-scroll-move-cursor)
-;;!! (global-set-key [vertical-slider mouse-3] 'mouse-scroll-move-cursor)
-;;!!
-;;!! (global-set-key [thumbup mouse-1] 'mouse-scroll-up-full)
-;;!! (global-set-key [thumbup mouse-2] 'mouse-scroll-up-full)
-;;!! (global-set-key [thumbup mouse-3] 'mouse-scroll-up-full)
-;;!!
-;;!! (global-set-key [thumbdown mouse-1] 'mouse-scroll-down-full)
-;;!! (global-set-key [thumbdown mouse-2] 'mouse-scroll-down-full)
-;;!! (global-set-key [thumbdown mouse-3] 'mouse-scroll-down-full)
-;;!!
-;;!! (global-set-key [horizontal-scroll-bar mouse-1] 'mouse-scroll-left)
-;;!! (global-set-key [horizontal-scroll-bar mouse-2]
-;;!! 'mouse-scroll-absolute-horizontally)
-;;!! (global-set-key [horizontal-scroll-bar mouse-3] 'mouse-scroll-right)
-;;!!
-;;!! (global-set-key [horizontal-slider mouse-1]
-;;!! 'mouse-scroll-move-cursor-horizontally)
-;;!! (global-set-key [horizontal-slider mouse-2]
-;;!! 'mouse-scroll-move-cursor-horizontally)
-;;!! (global-set-key [horizontal-slider mouse-3]
-;;!! 'mouse-scroll-move-cursor-horizontally)
-;;!!
-;;!! (global-set-key [thumbleft mouse-1] 'mouse-scroll-left-full)
-;;!! (global-set-key [thumbleft mouse-2] 'mouse-scroll-left-full)
-;;!! (global-set-key [thumbleft mouse-3] 'mouse-scroll-left-full)
-;;!!
-;;!! (global-set-key [thumbright mouse-1] 'mouse-scroll-right-full)
-;;!! (global-set-key [thumbright mouse-2] 'mouse-scroll-right-full)
-;;!! (global-set-key [thumbright mouse-3] 'mouse-scroll-right-full)
-;;!!
-;;!! (global-set-key [horizontal-scroll-bar S-mouse-2]
-;;!! 'mouse-split-window-horizontally)
-;;!! (global-set-key [mode-line S-mouse-2]
-;;!! 'mouse-split-window-horizontally)
-;;!! (global-set-key [vertical-scroll-bar S-mouse-2]
-;;!! 'mouse-split-window)
-
-;;!! ;;;;
-;;!! ;;;; Here are experimental things being tested. Mouse events
-;;!! ;;;; are of the form:
-;;!! ;;;; ((x y) window screen-part key-sequence timestamp)
-;;!! ;;
-;;!! ;;;;
-;;!! ;;;; Dynamically track mouse coordinates
-;;!! ;;;;
-;;!! ;;
-;;!! ;;(defun track-mouse (event)
-;;!! ;; "Track the coordinates, absolute and relative, of the mouse."
-;;!! ;; (interactive "@e")
-;;!! ;; (while mouse-grabbed
-;;!! ;; (let* ((pos (read-mouse-position (selected-screen)))
-;;!! ;; (abs-x (car pos))
-;;!! ;; (abs-y (cdr pos))
-;;!! ;; (relative-coordinate (coordinates-in-window-p
-;;!! ;; (list (car pos) (cdr pos))
-;;!! ;; (selected-window))))
-;;!! ;; (if (consp relative-coordinate)
-;;!! ;; (message "mouse: [%d %d], (%d %d)" abs-x abs-y
-;;!! ;; (car relative-coordinate)
-;;!! ;; (car (cdr relative-coordinate)))
-;;!! ;; (message "mouse: [%d %d]" abs-x abs-y)))))
-;;!!
-;;!! ;;
-;;!! ;; Dynamically put a box around the line indicated by point
-;;!! ;;
-;;!! ;;
-;;!! ;;(require 'backquote)
-;;!! ;;
-;;!! ;;(defun mouse-select-buffer-line (event)
-;;!! ;; (interactive "@e")
-;;!! ;; (let ((relative-coordinate
-;;!! ;; (coordinates-in-window-p (car event) (selected-window)))
-;;!! ;; (abs-y (car (cdr (car event)))))
-;;!! ;; (if (consp relative-coordinate)
-;;!! ;; (progn
-;;!! ;; (save-excursion
-;;!! ;; (move-to-window-line (car (cdr relative-coordinate)))
-;;!! ;; (x-draw-rectangle
-;;!! ;; (selected-screen)
-;;!! ;; abs-y 0
-;;!! ;; (save-excursion
-;;!! ;; (move-to-window-line (car (cdr relative-coordinate)))
-;;!! ;; (end-of-line)
-;;!! ;; (push-mark nil t)
-;;!! ;; (beginning-of-line)
-;;!! ;; (- (region-end) (region-beginning))) 1))
-;;!! ;; (sit-for 1)
-;;!! ;; (x-erase-rectangle (selected-screen))))))
-;;!! ;;
-;;!! ;;(defvar last-line-drawn nil)
-;;!! ;;(defvar begin-delim "[^ \t]")
-;;!! ;;(defvar end-delim "[^ \t]")
-;;!! ;;
-;;!! ;;(defun mouse-boxing (event)
-;;!! ;; (interactive "@e")
-;;!! ;; (save-excursion
-;;!! ;; (let ((screen (selected-screen)))
-;;!! ;; (while (= (x-mouse-events) 0)
-;;!! ;; (let* ((pos (read-mouse-position screen))
-;;!! ;; (abs-x (car pos))
-;;!! ;; (abs-y (cdr pos))
-;;!! ;; (relative-coordinate
-;;!! ;; (coordinates-in-window-p `(,abs-x ,abs-y)
-;;!! ;; (selected-window)))
-;;!! ;; (begin-reg nil)
-;;!! ;; (end-reg nil)
-;;!! ;; (end-column nil)
-;;!! ;; (begin-column nil))
-;;!! ;; (if (and (consp relative-coordinate)
-;;!! ;; (or (not last-line-drawn)
-;;!! ;; (not (= last-line-drawn abs-y))))
-;;!! ;; (progn
-;;!! ;; (move-to-window-line (car (cdr relative-coordinate)))
-;;!! ;; (if (= (following-char) 10)
-;;!! ;; ()
-;;!! ;; (progn
-;;!! ;; (setq begin-reg (1- (re-search-forward end-delim)))
-;;!! ;; (setq begin-column (1- (current-column)))
-;;!! ;; (end-of-line)
-;;!! ;; (setq end-reg (1+ (re-search-backward begin-delim)))
-;;!! ;; (setq end-column (1+ (current-column)))
-;;!! ;; (message "%s" (buffer-substring begin-reg end-reg))
-;;!! ;; (x-draw-rectangle screen
-;;!! ;; (setq last-line-drawn abs-y)
-;;!! ;; begin-column
-;;!! ;; (- end-column begin-column) 1))))))))))
-;;!! ;;
-;;!! ;;(defun mouse-erase-box ()
-;;!! ;; (interactive)
-;;!! ;; (if last-line-drawn
-;;!! ;; (progn
-;;!! ;; (x-erase-rectangle (selected-screen))
-;;!! ;; (setq last-line-drawn nil))))
-;;!!
-;;!! ;;; (defun test-x-rectangle ()
-;;!! ;;; (use-local-mouse-map (setq rectangle-test-map (make-sparse-keymap)))
-;;!! ;;; (define-key rectangle-test-map mouse-motion-button-left 'mouse-boxing)
-;;!! ;;; (define-key rectangle-test-map mouse-button-left-up 'mouse-erase-box))
-;;!!
-;;!! ;;
-;;!! ;; Here is how to do double clicking in lisp. About to change.
-;;!! ;;
-;;!!
-;;!! (defvar double-start nil)
-;;!! (defconst double-click-interval 300
-;;!! "Max ticks between clicks")
-;;!!
-;;!! (defun double-down (event)
-;;!! (interactive "@e")
-;;!! (if double-start
-;;!! (let ((interval (- (nth 4 event) double-start)))
-;;!! (if (< interval double-click-interval)
-;;!! (progn
-;;!! (backward-up-list 1)
-;;!! ;; (message "Interval %d" interval)
-;;!! (sleep-for 1)))
-;;!! (setq double-start nil))
-;;!! (setq double-start (nth 4 event))))
-;;!!
-;;!! (defun double-up (event)
-;;!! (interactive "@e")
-;;!! (and double-start
-;;!! (> (- (nth 4 event ) double-start) double-click-interval)
-;;!! (setq double-start nil)))
-;;!!
-;;!! ;;; (defun x-test-doubleclick ()
-;;!! ;;; (use-local-mouse-map (setq doubleclick-test-map (make-sparse-keymap)))
-;;!! ;;; (define-key doubleclick-test-map mouse-button-left 'double-down)
-;;!! ;;; (define-key doubleclick-test-map mouse-button-left-up 'double-up))
-;;!!
-;;!! ;;
-;;!! ;; This scrolls while button is depressed. Use preferable in scroll bar.
-;;!! ;;
-;;!!
-;;!! (defvar scrolled-lines 0)
-;;!! (defconst scroll-speed 1)
-;;!!
-;;!! (defun incr-scroll-down (event)
-;;!! (interactive "@e")
-;;!! (setq scrolled-lines 0)
-;;!! (incremental-scroll scroll-speed))
-;;!!
-;;!! (defun incr-scroll-up (event)
-;;!! (interactive "@e")
-;;!! (setq scrolled-lines 0)
-;;!! (incremental-scroll (- scroll-speed)))
-;;!!
-;;!! (defun incremental-scroll (n)
-;;!! (while (= (x-mouse-events) 0)
-;;!! (setq scrolled-lines (1+ (* scroll-speed scrolled-lines)))
-;;!! (scroll-down n)
-;;!! (sit-for 300 t)))
-;;!!
-;;!! (defun incr-scroll-stop (event)
-;;!! (interactive "@e")
-;;!! (message "Scrolled %d lines" scrolled-lines)
-;;!! (setq scrolled-lines 0)
-;;!! (sleep-for 1))
-;;!!
-;;!! ;;; (defun x-testing-scroll ()
-;;!! ;;; (let ((scrolling-map (function mouse-vertical-scroll-bar-prefix)))
-;;!! ;;; (define-key scrolling-map mouse-button-left 'incr-scroll-down)
-;;!! ;;; (define-key scrolling-map mouse-button-right 'incr-scroll-up)
-;;!! ;;; (define-key scrolling-map mouse-button-left-up 'incr-scroll-stop)
-;;!! ;;; (define-key scrolling-map mouse-button-right-up 'incr-scroll-stop)))
-;;!!
-;;!! ;;
-;;!! ;; Some playthings suitable for picture mode? They need work.
-;;!! ;;
-;;!!
-;;!! (defun mouse-kill-rectangle (event)
-;;!! "Kill the rectangle between point and the mouse cursor."
-;;!! (interactive "@e")
-;;!! (let ((point-save (point)))
-;;!! (save-excursion
-;;!! (mouse-set-point event)
-;;!! (push-mark nil t)
-;;!! (if (> point-save (point))
-;;!! (kill-rectangle (point) point-save)
-;;!! (kill-rectangle point-save (point))))))
-;;!!
-;;!! (defun mouse-open-rectangle (event)
-;;!! "Kill the rectangle between point and the mouse cursor."
-;;!! (interactive "@e")
-;;!! (let ((point-save (point)))
-;;!! (save-excursion
-;;!! (mouse-set-point event)
-;;!! (push-mark nil t)
-;;!! (if (> point-save (point))
-;;!! (open-rectangle (point) point-save)
-;;!! (open-rectangle point-save (point))))))
-;;!!
-;;!! ;; Must be a better way to do this.
-;;!!
-;;!! (defun mouse-multiple-insert (n char)
-;;!! (while (> n 0)
-;;!! (insert char)
-;;!! (setq n (1- n))))
-;;!!
-;;!! ;; What this could do is not finalize until button was released.
-;;!!
-;;!! (defun mouse-move-text (event)
-;;!! "Move text from point to cursor position, inserting spaces."
-;;!! (interactive "@e")
-;;!! (let* ((relative-coordinate
-;;!! (coordinates-in-window-p (car event) (selected-window))))
-;;!! (if (consp relative-coordinate)
-;;!! (cond ((> (current-column) (car relative-coordinate))
-;;!! (delete-char
-;;!! (- (car relative-coordinate) (current-column))))
-;;!! ((< (current-column) (car relative-coordinate))
-;;!! (mouse-multiple-insert
-;;!! (- (car relative-coordinate) (current-column)) " "))
-;;!! ((= (current-column) (car relative-coordinate)) (ding))))))
-
(define-obsolete-function-alias
'mouse-choose-completion 'choose-completion "23.2")
@@ -2556,7 +2090,7 @@ choose a font."
(global-set-key [left-fringe mouse-1] 'mouse-set-point)
(global-set-key [right-fringe mouse-1] 'mouse-set-point)
-(global-set-key [mouse-2] 'mouse-yank-at-click)
+(global-set-key [mouse-2] 'mouse-yank-primary)
;; Allow yanking also when the corresponding cursor is "in the fringe".
(global-set-key [right-fringe mouse-2] 'mouse-yank-at-click)
(global-set-key [left-fringe mouse-2] 'mouse-yank-at-click)
@@ -2577,10 +2111,6 @@ choose a font."
(mouse-menu-bar-map)
(mouse-menu-major-mode-map)))))
-
-;; Replaced with dragging mouse-1
-;; (global-set-key [S-mouse-1] 'mouse-set-mark)
-
;; Binding mouse-1 to mouse-select-window when on mode-, header-, or
;; vertical-line prevents Emacs from signaling an error when the mouse
;; button is released after dragging these lines, on non-toolkit
@@ -2600,12 +2130,5 @@ choose a font."
(provide 'mouse)
-;; This file contains the functionality of the old mldrag.el.
-(defalias 'mldrag-drag-mode-line 'mouse-drag-mode-line)
-(defalias 'mldrag-drag-vertical-line 'mouse-drag-vertical-line)
-(make-obsolete 'mldrag-drag-mode-line 'mouse-drag-mode-line "21.1")
-(make-obsolete 'mldrag-drag-vertical-line 'mouse-drag-vertical-line "21.1")
-(provide 'mldrag)
-
;; arch-tag: 9a710ce1-914a-4923-9b81-697f7bf82ab3
;;; mouse.el ends here
diff --git a/lisp/mpc.el b/lisp/mpc.el
index 23157635d98..97c5573face 100644
--- a/lisp/mpc.el
+++ b/lisp/mpc.el
@@ -94,54 +94,17 @@
(eval-when-compile (require 'cl))
-;;; Backward compatibility.
-;; This code is meant for Emacs-CVS, so to get it to run on anything else,
-;; we need to define some more things.
-
-(unless (fboundp 'tool-bar-local-item)
- (defun tool-bar-local-item (icon def key map &rest props)
- (define-key-after map (vector key)
- `(menu-item ,(symbol-name key) ,def
- :image ,(find-image
- `((:type xpm :file ,(concat icon ".xpm"))))
- ,@props))))
-
-(unless (fboundp 'process-put)
- (defconst mpc-process-hash (make-hash-table :weakness 'key))
- (defun process-put (proc prop val)
- (let ((sym (gethash proc mpc-process-hash)))
- (unless sym
- (setq sym (puthash proc (make-symbol "mpc-proc-sym") mpc-process-hash)))
- (put sym prop val)))
- (defun process-get (proc prop)
- (let ((sym (gethash proc mpc-process-hash)))
- (when sym (get sym prop))))
- (defun process-plist (proc)
- (let ((sym (gethash proc mpc-process-hash)))
- (when sym (symbol-plist sym)))))
-(unless (fboundp 'with-local-quit)
- (defmacro with-local-quit (&rest body)
- `(condition-case nil (let ((inhibit-quit nil)) ,@body)
- (quit (setq quit-flag t) nil))))
-(unless (fboundp 'balance-windows-area)
- (defalias 'balance-windows-area 'balance-windows))
-(unless (fboundp 'posn-object) (defalias 'posn-object 'ignore))
-(unless (fboundp 'buffer-local-value)
- (defun buffer-local-value (var buf)
- (with-current-buffer buf (symbol-value var))))
-
-
-;;; Main code starts here.
-
(defgroup mpc ()
"A Client for the Music Player Daemon."
:prefix "mpc-"
:group 'multimedia
:group 'applications)
-(defcustom mpc-browser-tags '(Genre Artist Album Playlist)
+(defcustom mpc-browser-tags '(Genre Artist|Composer|Performer
+ Album|Playlist)
"Tags for which a browser buffer should be created by default."
- :type '(repeat string))
+ ;; FIXME: provide a list of tags, for completion.
+ :type '(repeat symbol))
;;; Misc utils ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -620,6 +583,19 @@ Any call to `mpc-status-refresh' may cause it to be restarted."
;; (mpc--queue-head)))
;; (message "MPC's queue is out of sync"))))))
+(defvar mpc--find-memoize-union-tags nil)
+
+(defun mpc-cmd-flush (tag value)
+ (puthash (cons tag value) nil mpc--find-memoize)
+ (dolist (uniontag mpc--find-memoize-union-tags)
+ (if (member (symbol-name tag) (split-string (symbol-name uniontag) "|"))
+ (puthash (cons uniontag value) nil mpc--find-memoize))))
+
+
+(defun mpc-cmd-special-tag-p (tag)
+ (or (memq tag '(Playlist Search Directory))
+ (string-match "|" (symbol-name tag))))
+
(defun mpc-cmd-find (tag value)
"Return a list of all songs whose tag TAG has value VALUE.
The songs are returned as alists."
@@ -628,8 +604,12 @@ The songs are returned as alists."
(cond
((eq tag 'Playlist)
;; Special case for pseudo-tag playlist.
- (let ((l (mpc-proc-buf-to-alists
- (mpc-proc-cmd (list "listplaylistinfo" value))))
+ (let ((l (condition-case err
+ (mpc-proc-buf-to-alists
+ (mpc-proc-cmd (list "listplaylistinfo" value)))
+ (mpc-proc-error
+ ;; "[50@0] {listplaylistinfo} No such playlist"
+ nil)))
(i 0))
(mapcar (lambda (s)
(prog1 (cons (cons 'Pos (number-to-string i)) s)
@@ -648,6 +628,14 @@ The songs are returned as alists."
(if (eq (car pair) 'directory)
nil pair))
pairs)))))
+ ((string-match "|" (symbol-name tag))
+ (add-to-list 'mpc--find-memoize-union-tags tag)
+ (let ((tag1 (intern (substring (symbol-name tag)
+ 0 (match-beginning 0))))
+ (tag2 (intern (substring (symbol-name tag)
+ (match-end 0)))))
+ (mpc-union (mpc-cmd-find tag1 value)
+ (mpc-cmd-find tag2 value))))
(t
(condition-case err
(mpc-proc-buf-to-alists
@@ -675,7 +663,7 @@ The songs are returned as alists."
(when other-tag
(dolist (pl (prog1 pls (setq pls nil)))
(let ((plsongs (mpc-cmd-find 'Playlist pl)))
- (if (not (member other-tag '(Playlist Search Directory)))
+ (if (not (mpc-cmd-special-tag-p other-tag))
(when (member (cons other-tag value)
(apply 'append plsongs))
(push pl pls))
@@ -743,6 +731,14 @@ The songs are returned as alists."
;; useful that would be tho.
((eq tag 'Search) (error "Not supported"))
+ ((string-match "|" (symbol-name tag))
+ (let ((tag1 (intern (substring (symbol-name tag)
+ 0 (match-beginning 0))))
+ (tag2 (intern (substring (symbol-name tag)
+ (match-end 0)))))
+ (mpc-union (mpc-cmd-list tag1 other-tag value)
+ (mpc-cmd-list tag2 other-tag value))))
+
((null other-tag)
(condition-case nil
(mapcar 'cdr (mpc-proc-cmd-to-alist (list "list" (symbol-name tag))))
@@ -754,7 +750,7 @@ The songs are returned as alists."
(mpc-assq-all tag (mpc-proc-cmd-to-alist "listallinfo")))))
(t
(condition-case nil
- (if (member other-tag '(Search Playlist Directory))
+ (if (mpc-cmd-special-tag-p other-tag)
(signal 'mpc-proc-error "Not implemented")
(mapcar 'cdr
(mpc-proc-cmd-to-alist
@@ -801,7 +797,7 @@ If PLAYLIST is t or nil or missing, use the main playlist."
(list "add" file)))
files)))
(if (stringp playlist)
- (puthash (cons 'Playlist playlist) nil mpc--find-memoize)))
+ (mpc-cmd-flush 'Playlist playlist)))
(defun mpc-cmd-delete (song-poss &optional playlist)
"Delete the songs at positions SONG-POSS from PLAYLIST.
@@ -928,6 +924,10 @@ If PLAYLIST is t or nil or missing, use the main playlist."
;;; Formatter ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun mpc-secs-to-time (secs)
+ ;; We could use `format-seconds', but it doesn't seem worth the trouble
+ ;; because we'd still need to check (>= secs (* 60 100)) since the special
+ ;; %z only allows us to drop the large units for small values but
+ ;; not to drop the small units for large values.
(if (stringp secs) (setq secs (string-to-number secs)))
(if (>= secs (* 60 100)) ;More than 100 minutes.
(format "%dh%02d" ;"%d:%02d:%02d"
@@ -1432,6 +1432,20 @@ when constructing the set of constraints."
(with-current-buffer buf (with-local-quit (mpc-tagbrowser-refresh)))))
(with-local-quit (mpc-songs-refresh))))
+(defun mpc-tagbrowser-tag-name (tag)
+ (cond
+ ((string-match "|" (symbol-name tag))
+ (let ((tag1 (intern (substring (symbol-name tag)
+ 0 (match-beginning 0))))
+ (tag2 (intern (substring (symbol-name tag)
+ (match-end 0)))))
+ (concat (mpc-tagbrowser-tag-name tag1)
+ " | "
+ (mpc-tagbrowser-tag-name tag2))))
+ ((string-match "y\\'" (symbol-name tag))
+ (concat (substring (symbol-name tag) 0 -1) "ies"))
+ (t (concat (symbol-name tag) "s"))))
+
(defun mpc-tagbrowser-buf (tag)
(let ((buf (mpc-proc-buffer (mpc-proc) tag)))
(if (buffer-live-p buf) buf
@@ -1446,10 +1460,7 @@ when constructing the set of constraints."
(insert mpc-tagbrowser-all-name "\n"))
(forward-line -1)
(setq mpc-tag tag)
- (setq mpc-tag-name
- (if (string-match "y\\'" (symbol-name tag))
- (concat (substring (symbol-name tag) 0 -1) "ies")
- (concat (symbol-name tag) "s")))
+ (setq mpc-tag-name (mpc-tagbrowser-tag-name tag))
(mpc-tagbrowser-all-select)
(mpc-tagbrowser-refresh)
buf))))
@@ -1858,20 +1869,22 @@ This is used so that they can be compared with `eq', which is needed for
(mapcar (lambda (val)
(mpc-cmd-find (car cst) val))
(cdr cst)))))
- (setq active (if (null active)
- (progn
+ (setq active (cond
+ ((null active)
(if (eq (car cst) 'Playlist)
(setq dontsort t))
vals)
- (if (or dontsort
+ ((or dontsort
;; Try to preserve ordering and
;; repetitions from playlists.
(not (eq (car cst) 'Playlist)))
(mpc-intersection active vals
- (lambda (x) (assq 'file x)))
+ (lambda (x) (assq 'file x))))
+ (t
(setq dontsort t)
(mpc-intersection vals active
- (lambda (x) (assq 'file x)))))))))
+ (lambda (x)
+ (assq 'file x)))))))))
(mpc-select-save
(erase-buffer)
;; Sorting songs is surprisingly difficult: when comparing two
@@ -1902,9 +1915,10 @@ This is used so that they can be compared with `eq', which is needed for
))
(goto-char (point-min))
(forward-line (car curline))
- (when (or (search-forward (cdr curline) nil t)
+ (if (or (search-forward (cdr curline) nil t)
(search-backward (cdr curline) nil t))
- (beginning-of-line))
+ (beginning-of-line)
+ (goto-char (point-min)))
(set (make-local-variable 'mpc-songs-totaltime)
(unless (zerop totaltime)
(list " " (mpc-secs-to-time totaltime))))
diff --git a/lisp/mwheel.el b/lisp/mwheel.el
index c505833502a..2fc84c06245 100644
--- a/lisp/mwheel.el
+++ b/lisp/mwheel.el
@@ -4,6 +4,7 @@
;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Maintainer: William M. Perry <wmperry@gnu.org>
;; Keywords: mouse
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -246,6 +247,8 @@ This should only be bound to mouse buttons 4 and 5."
(run-with-timer mouse-wheel-inhibit-click-time nil
'mwheel-inhibit-click-timeout))))
+(put 'mwheel-scroll 'scroll-command t)
+
(defvar mwheel-installed-bindings nil)
;; preloaded ;;;###autoload
diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el
index 6e468386749..07091663471 100644
--- a/lisp/net/ange-ftp.el
+++ b/lisp/net/ange-ftp.el
@@ -676,6 +676,7 @@
"Accessing remote files and directories using FTP
made as simple and transparent as possible."
:group 'files
+ :group 'comm
:prefix "ange-ftp-")
(defcustom ange-ftp-name-format
@@ -721,6 +722,7 @@ parenthesized expressions in REGEXP for the components (in that order)."
"^Data connection \\|"
"^local:\\|^Trying\\|^125 \\|^550-\\|^221 .*oodbye\\|"
"^500 .*AUTH\\|^KERBEROS\\|"
+ "^504 Unknown security mechanism\\|"
"^530 Please login with USER and PASS\\|" ; non kerberised vsFTPd
"^534 Kerberos Authentication not enabled\\|"
"^22[789] .*[Pp]assive\\|^200 EPRT\\|^500 .*EPRT")
@@ -1733,7 +1735,10 @@ good, skip, fatal, or unknown."
ange-ftp-gateway-tmp-name-template
ange-ftp-tmp-name-template)))
-(defalias 'ange-ftp-del-tmp-name 'delete-file)
+(defun ange-ftp-del-tmp-name (filename)
+ "Force to delete temporary file."
+ (delete-file filename))
+
;;;; ------------------------------------------------------------
;;;; Interactive gateway program support.
@@ -3503,8 +3508,9 @@ system TYPE.")
(file-exists-p file)
(ange-ftp-real-file-executable-p file))))
-(defun ange-ftp-delete-file (file)
- (interactive "fDelete file: ")
+(defun ange-ftp-delete-file (file &optional trash)
+ (interactive (list (read-file-name "Delete file: " nil default-directory)
+ (null current-prefix-arg)))
(setq file (expand-file-name file))
(let ((parsed (ange-ftp-ftp-name file)))
(if parsed
@@ -3522,7 +3528,7 @@ system TYPE.")
(format "FTP Error: \"%s\"" (cdr result))
file)))
(ange-ftp-delete-file-entry file))
- (ange-ftp-real-delete-file file))))
+ (ange-ftp-real-delete-file file trash))))
(defun ange-ftp-file-modtime (file)
"Return the modification time of remote file FILE.
@@ -3826,7 +3832,8 @@ so return the size on the remote host exactly. See RFC 3659."
(ange-ftp-call-cont cont result line)))
(defun ange-ftp-copy-file (filename newname &optional ok-if-already-exists
- keep-date preserve-uid-gid)
+ keep-date preserve-uid-gid
+ preserve-selinux-context)
(interactive "fCopy file: \nFCopy %s to file: \np")
(ange-ftp-copy-file-internal filename
newname
@@ -4894,7 +4901,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
;; ;; This is the Unix dl version.
;; (let ((opoint (point))
;; case-fold-search hidden)
-;; (or eol (setq eol (save-excursion (end-of-line) (point))))
+;; (or eol (setq eol (line-end-position)))
;; (setq hidden (and selective-display
;; (save-excursion
;; (search-forward "\r" eol t))))
@@ -5293,7 +5300,7 @@ Other orders of $ and _ seem to all work just fine.")
;; ;; This is the VMS version.
;; (let (opoint hidden case-fold-search)
;; (setq opoint (point))
-;; (or eol (setq eol (save-excursion (end-of-line) (point))))
+;; (or eol (setq eol (line-end-position)))
;; (setq hidden (and selective-display
;; (save-excursion (search-forward "\r" eol t))))
;; (if hidden
@@ -5651,7 +5658,7 @@ Other orders of $ and _ seem to all work just fine.")
;; ;; This is the MTS version.
;; (let (opoint hidden case-fold-search)
;; (setq opoint (point)
-;; eol (save-excursion (end-of-line) (point))
+;; eol (line-end-position)
;; hidden (and selective-display
;; (save-excursion (search-forward "\r" eol t))))
;; (if hidden
@@ -5872,7 +5879,7 @@ Other orders of $ and _ seem to all work just fine.")
;; ;; This is the CMS version.
;; (let ((opoint (point))
;; case-fold-search hidden)
-;; (or eol (setq eol (save-excursion (end-of-line) (point))))
+;; (or eol (setq eol (line-end-position)))
;; (setq hidden (and selective-display
;; (save-excursion
;; (search-forward "\r" eol t))))
@@ -6146,5 +6153,4 @@ be recognized automatically (they are all valid BS2000 hosts too)."
(provide 'ange-ftp)
-;; arch-tag: 2987ef88-cb56-4ec1-87a9-79132572e316
;;; ange-ftp.el ends here
diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el
index 3a5fa8c30a6..35b70ffefb5 100644
--- a/lisp/net/browse-url.el
+++ b/lisp/net/browse-url.el
@@ -1,7 +1,8 @@
;;; browse-url.el --- pass a URL to a WWW browser
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+;; 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Denis Howe <dbh@doc.ic.ac.uk>
;; Maintainer: FSF
@@ -204,26 +205,24 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Variables
-(eval-when-compile (require 'cl)
- (require 'thingatpt)
- (require 'term)
- (require 'dired)
- (require 'executable)
- (require 'w3-auto nil t))
+(eval-when-compile (require 'cl))
(defgroup browse-url nil
"Use a web browser to look at a URL."
:prefix "browse-url-"
:link '(emacs-commentary-link "browse-url")
- :group 'hypermedia)
+ :group 'external
+ :group 'comm)
;;;###autoload
(defcustom browse-url-browser-function
(cond
((memq system-type '(windows-nt ms-dos cygwin))
'browse-url-default-windows-browser)
- ((memq system-type '(darwin)) 'browse-url-default-macosx-browser)
- (t 'browse-url-default-browser))
+ ((memq system-type '(darwin))
+ 'browse-url-default-macosx-browser)
+ (t
+ 'browse-url-default-browser))
"Function to display the current buffer in a WWW browser.
This is used by the `browse-url-at-point', `browse-url-at-mouse', and
`browse-url-of-file' commands.
@@ -263,7 +262,19 @@ regexp should probably be \".\" to specify a default browser."
(function :tag "Your own function")
(alist :tag "Regexp/function association list"
:key-type regexp :value-type function))
- :version "21.1"
+ :version "24.1"
+ :group 'browse-url)
+
+(defcustom browse-url-mailto-function 'browse-url-mail
+ "Function to display mailto: links.
+This variable uses the same syntax as the
+`browse-url-browser-function' variable. If the
+`browse-url-mailto-function' variable is nil, that variable will
+be used instead."
+ :type '(choice
+ (function-item :tag "Emacs Mail" :value browse-url-mail)
+ (function-item :tag "None" nil))
+ :version "24.1"
:group 'browse-url)
(defcustom browse-url-netscape-program "netscape"
@@ -312,8 +323,11 @@ Defaults to the value of `browse-url-mozilla-arguments' at the time
:type '(repeat (string :tag "Argument"))
:group 'browse-url)
-;;;###autoload
-(defcustom browse-url-firefox-program (purecopy "firefox")
+(defcustom browse-url-firefox-program
+ (let ((candidates '("firefox" "iceweasel")))
+ (while (and candidates (not (executable-find (car candidates))))
+ (setq candidates (cdr candidates)))
+ (or (car candidates) "firefox"))
"The name by which to invoke Firefox."
:type 'string
:group 'browse-url)
@@ -330,8 +344,7 @@ Defaults to the value of `browse-url-firefox-arguments' at the time
:type '(repeat (string :tag "Argument"))
:group 'browse-url)
-;;;###autoload
-(defcustom browse-url-galeon-program (purecopy "galeon")
+(defcustom browse-url-galeon-program "galeon"
"The name by which to invoke Galeon."
:type 'string
:group 'browse-url)
@@ -604,7 +617,7 @@ down (this *won't* always work)."
:group 'browse-url)
(defcustom browse-url-elinks-wrapper '("xterm" "-e")
- "*Wrapper command prepended to the Elinks command-line."
+ "Wrapper command prepended to the Elinks command-line."
:type '(repeat (string :tag "Wrapper"))
:group 'browse-url)
@@ -752,6 +765,9 @@ narrowed."
(add-hook 'kill-buffer-hook 'browse-url-delete-temp-file)
+(declare-function dired-get-filename "dired"
+ (&optional localp no-error-if-not-filep))
+
;;;###autoload
(defun browse-url-of-dired-file ()
"In Dired, ask a WWW browser to display the file named on this line."
@@ -776,22 +792,27 @@ narrowed."
(defun browse-url (url &rest args)
"Ask a WWW browser to load URL.
Prompts for a URL, defaulting to the URL at or before point. Variable
-`browse-url-browser-function' says which browser to use."
+`browse-url-browser-function' says which browser to use.
+If the URL is a mailto: URL, consult `browse-url-mailto-function'
+first, if that exists."
(interactive (browse-url-interactive-arg "URL: "))
(unless (called-interactively-p 'interactive)
(setq args (or args (list browse-url-new-window-flag))))
- (let ((process-environment (copy-sequence process-environment)))
+ (let ((process-environment (copy-sequence process-environment))
+ (function (or (and (string-match "\\`mailto:" url)
+ browse-url-mailto-function)
+ browse-url-browser-function)))
;; When connected to various displays, be careful to use the display of
;; the currently selected frame, rather than the original start display,
;; which may not even exist any more.
(if (stringp (frame-parameter (selected-frame) 'display))
(setenv "DISPLAY" (frame-parameter (selected-frame) 'display)))
- (if (and (consp browse-url-browser-function)
- (not (functionp browse-url-browser-function)))
+ (if (and (consp function)
+ (not (functionp function)))
;; The `function' can be an alist; look down it for first match
;; and apply the function (which might be a lambda).
(catch 'done
- (dolist (bf browse-url-browser-function)
+ (dolist (bf function)
(when (string-match (car bf) url)
(apply (cdr bf) url args)
(throw 'done t)))
@@ -799,7 +820,7 @@ Prompts for a URL, defaulting to the URL at or before point. Variable
url))
;; Unbound symbols go down this leg, since void-function from
;; apply is clearer than wrong-type-argument from dolist.
- (apply browse-url-browser-function url args))))
+ (apply function url args))))
;;;###autoload
(defun browse-url-at-point (&optional arg)
@@ -889,6 +910,7 @@ The order attempted is gnome-moz-remote, Mozilla, Firefox,
Galeon, Konqueror, Netscape, Mosaic, Lynx in an xterm, and then W3."
(apply
(cond
+ ((browse-url-can-use-xdg-open) 'browse-url-xdg-open)
((executable-find browse-url-gnome-moz-program) 'browse-url-gnome-moz)
((executable-find browse-url-mozilla-program) 'browse-url-mozilla)
((executable-find browse-url-firefox-program) 'browse-url-firefox)
@@ -902,6 +924,38 @@ Galeon, Konqueror, Netscape, Mosaic, Lynx in an xterm, and then W3."
(lambda (&rest ignore) (error "No usable browser found"))))
url args))
+(defun browse-url-can-use-xdg-open ()
+ "Check if xdg-open can be used, i.e. we are on Gnome, KDE or xfce4."
+ (and (getenv "DISPLAY")
+ (executable-find "xdg-open")
+ ;; xdg-open may call gnome-open and that does not wait for its child
+ ;; to finish. This child may then be killed when the parent dies.
+ ;; Use nohup to work around.
+ (executable-find "nohup")
+ (or (getenv "GNOME_DESKTOP_SESSION_ID")
+ ;; GNOME_DESKTOP_SESSION_ID is deprecated, check on Dbus also.
+ (condition-case nil
+ (eq 0 (call-process
+ "dbus-send" nil nil nil
+ "--dest=org.gnome.SessionManager"
+ "--print-reply"
+ "/org/gnome/SessionManager"
+ "org.gnome.SessionManager.CanShutdown"))
+ (error nil))
+ (equal (getenv "KDE_FULL_SESSION") "true")
+ (condition-case nil
+ (eq 0 (call-process
+ "/bin/sh" nil nil nil
+ "-c"
+ "xprop -root _DT_SAVE_MODE|grep xfce4"))
+ (error nil)))))
+
+
+;;;###autoload
+(defun browse-url-xdg-open (url &optional new-window)
+ (interactive (browse-url-interactive-arg "URL: "))
+ (call-process "nohup" nil nil nil "xdg-open" url))
+
;;;###autoload
(defun browse-url-netscape (url &optional new-window)
"Ask the Netscape WWW browser to load URL.
@@ -1347,6 +1401,10 @@ with possible additional arguments `browse-url-xterm-args'."
;; --- Lynx in an Emacs "term" window ---
+(declare-function term-char-mode "term" ())
+(declare-function term-send-down "term" ())
+(declare-function term-send-string "term" (proc str))
+
;;;###autoload
(defun browse-url-text-emacs (url &optional new-buffer)
"Ask a text browser to load URL.
@@ -1367,6 +1425,7 @@ used instead of `browse-url-new-window-flag'."
(buf (get-buffer "*text browser*"))
(proc (and buf (get-buffer-process buf)))
(n browse-url-text-input-attempts))
+ (require 'term)
(if (and (browse-url-maybe-new-window new-buffer) buf)
;; Rename away the OLD buffer. This isn't very polite, but
;; term insists on working in a buffer named *lynx* and would
@@ -1439,20 +1498,27 @@ used instead of `browse-url-new-window-flag'."
(to (assoc "To" alist))
(subject (assoc "Subject" alist))
(body (assoc "Body" alist))
- (rest (delete to (delete subject (delete body alist))))
+ (rest (delq to (delq subject (delq body alist))))
(to (cdr to))
(subject (cdr subject))
(body (cdr body))
(mail-citation-hook (unless body mail-citation-hook)))
(if (browse-url-maybe-new-window new-window)
(compose-mail-other-window to subject rest nil
- (if body
- (list 'insert body)
- (list 'insert-buffer (current-buffer))))
+ (list 'insert-buffer (current-buffer)))
(compose-mail to subject rest nil nil
- (if body
- (list 'insert body)
- (list 'insert-buffer (current-buffer))))))))
+ (list 'insert-buffer (current-buffer))))
+ (when body
+ (goto-char (point-min))
+ (unless (or (search-forward (concat "\n" mail-header-separator "\n")
+ nil 'move)
+ (bolp))
+ (insert "\n"))
+ (goto-char (prog1
+ (point)
+ (insert (replace-regexp-in-string "\r\n" "\n" body))
+ (unless (bolp)
+ (insert "\n"))))))))
;; --- Random browser ---
@@ -1531,5 +1597,4 @@ from `browse-url-elinks-wrapper'."
(provide 'browse-url)
-;; arch-tag: d2079573-5c06-4097-9598-f550fba19430
;;; browse-url.el ends here
diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el
index 46cbb723d76..c9adec5d7b8 100644
--- a/lisp/net/dbus.el
+++ b/lisp/net/dbus.el
@@ -39,6 +39,7 @@
(declare-function dbus-method-error-internal "dbusbind.c")
(declare-function dbus-register-signal "dbusbind.c")
(declare-function dbus-register-method "dbusbind.c")
+(declare-function dbus-send-signal "dbusbind.c")
(defvar dbus-debug)
(defvar dbus-registered-objects-table)
@@ -91,12 +92,10 @@
(defmacro dbus-ignore-errors (&rest body)
"Execute BODY; signal D-Bus error when `dbus-debug' is non-nil.
Otherwise, return result of last form in BODY, or all other errors."
+ (declare (indent 0) (debug t))
`(condition-case err
(progn ,@body)
(dbus-error (when dbus-debug (signal (car err) (cdr err))))))
-
-(put 'dbus-ignore-errors 'lisp-indent-function 0)
-(put 'dbus-ignore-errors 'edebug-form-spec '(form body))
(font-lock-add-keywords 'emacs-lisp-mode '("\\<dbus-ignore-errors\\>"))
(defvar dbus-event-error-hooks nil
@@ -107,15 +106,12 @@ catched in `condition-case' by `dbus-error'.")
;;; Hash table of registered functions.
-;; We create it here. So we have a simple test in dbusbind.c, whether
-;; the Lisp code has been loaded.
-(setq dbus-registered-objects-table (make-hash-table :test 'equal))
-
(defvar dbus-return-values-table (make-hash-table :test 'equal)
"Hash table for temporary storing arguments of reply messages.
-A key in this hash table is a list (BUS SERIAL). BUS is either the
-symbol `:system' or the symbol `:session'. SERIAL is the serial number
-of the reply message. See `dbus-call-method-non-blocking-handler' and
+A key in this hash table is a list (BUS SERIAL). BUS is either a
+Lisp symbol, `:system' or `:session', or a string denoting the
+bus address. SERIAL is the serial number of the reply message.
+See `dbus-call-method-non-blocking-handler' and
`dbus-call-method-non-blocking'.")
(defun dbus-list-hash-table ()
@@ -186,8 +182,8 @@ association to the service from D-Bus."
(defun dbus-unregister-service (bus service)
"Unregister all objects related to SERVICE from D-Bus BUS.
-BUS must be either the symbol `:system' or the symbol `:session'.
-SERVICE must be a known service name."
+BUS is either a Lisp symbol, `:system' or `:session', or a string
+denoting the bus address. SERVICE must be a known service name."
(maphash
(lambda (key value)
(dolist (elt value)
@@ -243,7 +239,7 @@ This handler is applied when a \"NameOwnerChanged\" signal has
arrived. SERVICE is the object name for which the name owner has
been changed. OLD-OWNER is the previous owner of SERVICE, or the
empty string if SERVICE was not owned yet. NEW-OWNER is the new
-owner of SERVICE, or the empty string if SERVICE looses any name owner.
+owner of SERVICE, or the empty string if SERVICE loses any name owner.
usage: (dbus-name-owner-changed-handler service old-owner new-owner)"
(save-match-data
@@ -352,15 +348,15 @@ EVENT is a list which starts with symbol `dbus-event':
(dbus-event BUS TYPE SERIAL SERVICE PATH INTERFACE MEMBER HANDLER &rest ARGS)
BUS identifies the D-Bus the message is coming from. It is
-either the symbol `:system' or the symbol `:session'. TYPE is
-the D-Bus message type which has caused the event, SERIAL is the
-serial number of the received D-Bus message. SERVICE and PATH
-are the unique name and the object path of the D-Bus object
-emitting the message. INTERFACE and MEMBER denote the message
-which has been sent. HANDLER is the function which has been
-registered for this message. ARGS are the arguments passed to
-HANDLER, when it is called during event handling in
-`dbus-handle-event'.
+either a Lisp symbol, `:system' or `:session', or a string
+denoting the bus address. TYPE is the D-Bus message type which
+has caused the event, SERIAL is the serial number of the received
+D-Bus message. SERVICE and PATH are the unique name and the
+object path of the D-Bus object emitting the message. INTERFACE
+and MEMBER denote the message which has been sent. HANDLER is
+the function which has been registered for this message. ARGS
+are the arguments passed to HANDLER, when it is called during
+event handling in `dbus-handle-event'.
This function raises a `dbus-error' signal in case the event is
not well formed."
@@ -368,7 +364,8 @@ not well formed."
(unless (and (listp event)
(eq (car event) 'dbus-event)
;; Bus symbol.
- (symbolp (nth 1 event))
+ (or (symbolp (nth 1 event))
+ (stringp (nth 1 event)))
;; Type.
(and (natnump (nth 2 event))
(< dbus-message-type-invalid (nth 2 event)))
@@ -433,9 +430,10 @@ If the HANDLER returns a `dbus-error', it is propagated as return message."
(defun dbus-event-bus-name (event)
"Return the bus name the event is coming from.
-The result is either the symbol `:system' or the symbol `:session'.
-EVENT is a D-Bus event, see `dbus-check-event'. This function
-raises a `dbus-error' signal in case the event is not well formed."
+The result is either a Lisp symbol, `:system' or `:session', or a
+string denoting the bus address. EVENT is a D-Bus event, see
+`dbus-check-event'. This function raises a `dbus-error' signal
+in case the event is not well formed."
(dbus-check-event event)
(nth 1 event))
@@ -565,10 +563,11 @@ apply
"Return all interfaces and sub-nodes of SERVICE,
registered at object path PATH at bus BUS.
-BUS must be either the symbol `:system' or the symbol `:session'.
-SERVICE must be a known service name, and PATH must be a valid
-object path. The last two parameters are strings. The result,
-the introspection data, is a string in XML format."
+BUS is either a Lisp symbol, `:system' or `:session', or a string
+denoting the bus address. SERVICE must be a known service name,
+and PATH must be a valid object path. The last two parameters
+are strings. The result, the introspection data, is a string in
+XML format."
;; We don't want to raise errors. `dbus-call-method-non-blocking'
;; is used, because the handler can be registered in our Emacs
;; instance; caller an callee would block each other.
@@ -869,10 +868,11 @@ name of the property, and its value. If there are no properties,
(add-to-list 'result (cons (car dict) (caadr dict)) 'append)))))
(defun dbus-register-property
- (bus service path interface property access value)
+ (bus service path interface property access value &optional emits-signal)
"Register property PROPERTY on the D-Bus BUS.
-BUS is either the symbol `:system' or the symbol `:session'.
+BUS is either a Lisp symbol, `:system' or `:session', or a string
+denoting the bus address.
SERVICE is the D-Bus service name of the D-Bus. It must be a
known name.
@@ -892,7 +892,9 @@ can be changed by `dbus-set-property'.
The interface \"org.freedesktop.DBus.Properties\" is added to
PATH, including a default handler for the \"Get\", \"GetAll\" and
-\"Set\" methods of this interface."
+\"Set\" methods of this interface. When EMITS-SIGNAL is non-nil,
+the signal \"PropertiesChanged\" is sent when the property is
+changed by `dbus-set-property'."
(unless (member access '(:read :readwrite))
(signal 'dbus-error (list "Access type invalid" access)))
@@ -911,10 +913,23 @@ PATH, including a default handler for the \"Get\", \"GetAll\" and
(dbus-register-method
bus service path dbus-interface-properties "Set" 'dbus-property-handler)
+ ;; Send the PropertiesChanged signal.
+ (when emits-signal
+ (dbus-send-signal
+ bus service path dbus-interface-properties "PropertiesChanged"
+ (list (list :dict-entry property (list :variant value)))
+ '(:array)))
+
;; Create a hash table entry. We use nil for the unique name,
;; because the property might be accessed from anybody.
(let ((key (list bus interface property))
- (val (list (list nil service path (cons access value)))))
+ (val
+ (list
+ (list
+ nil service path
+ (cons
+ (if emits-signal (list access :emits-signal) (list access))
+ value)))))
(puthash key val dbus-registered-objects-table)
;; Return the object.
@@ -924,6 +939,7 @@ PATH, including a default handler for the \"Get\", \"GetAll\" and
"Default handler for the \"org.freedesktop.DBus.Properties\" interface.
It will be registered for all objects created by `dbus-register-object'."
(let ((bus (dbus-event-bus-name last-input-event))
+ (service (dbus-event-service-name last-input-event))
(path (dbus-event-path-name last-input-event))
(method (dbus-event-member-name last-input-event))
(interface (car args))
@@ -931,25 +947,40 @@ It will be registered for all objects created by `dbus-register-object'."
(cond
;; "Get" returns a variant.
((string-equal method "Get")
- (let ((val (gethash (list bus interface property)
- dbus-registered-objects-table)))
- (when (string-equal path (nth 2 (car val)))
- (list (list :variant (cdar (last (car val))))))))
+ (let ((entry (gethash (list bus interface property)
+ dbus-registered-objects-table)))
+ (when (string-equal path (nth 2 (car entry)))
+ (list (list :variant (cdar (last (car entry))))))))
;; "Set" expects a variant.
((string-equal method "Set")
- (let ((val (gethash (list bus interface property)
- dbus-registered-objects-table)))
- (unless (consp (car (last (car val))))
+ (let* ((value (caar (cddr args)))
+ (entry (gethash (list bus interface property)
+ dbus-registered-objects-table))
+ ;; The value of the hash table is a list; in case of
+ ;; properties it contains just one element (UNAME SERVICE
+ ;; PATH OBJECT). OBJECT is a cons cell of a list, which
+ ;; contains a list of annotations (like :read,
+ ;; :read-write, :emits-signal), and the value of the
+ ;; property.
+ (object (car (last (car entry)))))
+ (unless (consp object)
(signal 'dbus-error
(list "Property not registered at path" property path)))
- (unless (equal (caar (last (car val))) :readwrite)
+ (unless (member :readwrite (car object))
(signal 'dbus-error
(list "Property not writable at path" property path)))
(puthash (list bus interface property)
- (list (append (butlast (car val))
- (list (cons :readwrite (caar (cddr args))))))
+ (list (append (butlast (car entry))
+ (list (cons (car object) value))))
dbus-registered-objects-table)
+ ;; Send the "PropertiesChanged" signal.
+ (when (member :emits-signal (car object))
+ (dbus-send-signal
+ bus service path dbus-interface-properties "PropertiesChanged"
+ (list (list :dict-entry property (list :variant value)))
+ '(:array)))
+ ;; Return empty reply.
:ignore))
;; "GetAll" returns "a{sv}".
@@ -979,5 +1010,4 @@ It will be registered for all objects created by `dbus-register-object'."
(provide 'dbus)
-;; arch-tag: a47caf84-9162-4811-90cc-5d388e37b9bd
;;; dbus.el ends here
diff --git a/lisp/net/dig.el b/lisp/net/dig.el
index add3c2f7a0d..d36247a1d1f 100644
--- a/lisp/net/dig.el
+++ b/lisp/net/dig.el
@@ -129,12 +129,11 @@ Buffer should contain output generated by `dig-invoke'."
(put 'dig-mode 'mode-class 'special)
-(defvar dig-mode-map nil)
-(unless dig-mode-map
- (setq dig-mode-map (make-sparse-keymap))
- (suppress-keymap dig-mode-map)
-
- (define-key dig-mode-map "q" 'dig-exit))
+(defvar dig-mode-map
+ (let ((map (make-sparse-keymap)))
+ (suppress-keymap map)
+ (define-key map "q" 'dig-exit)
+ map))
(define-derived-mode dig-mode nil "Dig"
"Major mode for displaying dig output."
@@ -184,5 +183,4 @@ Returns nil for domain/class/type queries that result in no data."
(provide 'dig)
-;; arch-tag: 1d61726e-9400-4013-9ae7-4035e0c7f7d6
;;; dig.el ends here
diff --git a/lisp/net/dns.el b/lisp/net/dns.el
index 17973cfd94f..2d4c2d8cd8b 100644
--- a/lisp/net/dns.el
+++ b/lisp/net/dns.el
@@ -101,7 +101,7 @@ If nil, /etc/resolv.conf and nslookup will be consulted.")
(defun dns-read-string-name (string buffer)
(with-temp-buffer
- (set-buffer-multibyte nil)
+ (unless (featurep 'xemacs) (set-buffer-multibyte nil))
(insert string)
(goto-char (point-min))
(dns-read-name buffer)))
@@ -135,7 +135,7 @@ If nil, /etc/resolv.conf and nslookup will be consulted.")
"Write a DNS packet according to SPEC.
If TCP-P, the first two bytes of the package with be the length field."
(with-temp-buffer
- (set-buffer-multibyte nil)
+ (unless (featurep 'xemacs) (set-buffer-multibyte nil))
(dns-write-bytes (dns-get 'id spec) 2)
(dns-write-bytes
(logior
@@ -151,7 +151,7 @@ If TCP-P, the first two bytes of the package with be the length field."
(lsh (if (dns-get 'truncated-p spec) 1 0) -1)
(lsh (if (dns-get 'recursion-desired-p spec) 1 0) 0)))
(dns-write-bytes
- (cond
+ (cond
((eq (dns-get 'response-code spec) 'no-error) 0)
((eq (dns-get 'response-code spec) 'format-error) 1)
((eq (dns-get 'response-code spec) 'server-failure) 2)
@@ -186,7 +186,7 @@ If TCP-P, the first two bytes of the package with be the length field."
(defun dns-read (packet)
(with-temp-buffer
- (set-buffer-multibyte nil)
+ (unless (featurep 'xemacs) (set-buffer-multibyte nil))
(let ((spec nil)
queries answers authorities additionals)
(insert packet)
@@ -263,7 +263,7 @@ If TCP-P, the first two bytes of the package with be the length field."
(point (point)))
(prog1
(with-temp-buffer
- (set-buffer-multibyte nil)
+ (unless (featurep 'xemacs) (set-buffer-multibyte nil))
(insert string)
(goto-char (point-min))
(cond
@@ -391,7 +391,7 @@ If REVERSEP, look up an IP address."
(if (not dns-servers)
(message "No DNS server configuration found")
(with-temp-buffer
- (set-buffer-multibyte nil)
+ (unless (featurep 'xemacs) (set-buffer-multibyte nil))
(let ((process (condition-case ()
(dns-make-network-process (car dns-servers))
(error
@@ -438,5 +438,4 @@ If REVERSEP, look up an IP address."
(provide 'dns)
-;; arch-tag: d0edd0c4-4cce-4538-ae92-06c3356ee80a
;;; dns.el ends here
diff --git a/lisp/net/eudc-bob.el b/lisp/net/eudc-bob.el
index fe41d70a090..962020f2b30 100644
--- a/lisp/net/eudc-bob.el
+++ b/lisp/net/eudc-bob.el
@@ -6,6 +6,7 @@
;; Author: Oscar Figueiredo <oscar@cpe.fr>
;; Maintainer: Pavel Jank <Pavel@Janik.cz>
;; Keywords: comm
+;; Package: eudc
;; This file is part of GNU Emacs.
diff --git a/lisp/net/eudc-export.el b/lisp/net/eudc-export.el
index 7aa30cfcb66..91abac571b8 100644
--- a/lisp/net/eudc-export.el
+++ b/lisp/net/eudc-export.el
@@ -6,6 +6,7 @@
;; Author: Oscar Figueiredo <oscar@cpe.fr>
;; Maintainer: Pavel Jank <Pavel@Janik.cz>
;; Keywords: comm
+;; Package: eudc
;; This file is part of GNU Emacs.
diff --git a/lisp/net/eudc-hotlist.el b/lisp/net/eudc-hotlist.el
index 5f165ad2e25..5862384bd4d 100644
--- a/lisp/net/eudc-hotlist.el
+++ b/lisp/net/eudc-hotlist.el
@@ -6,6 +6,7 @@
;; Author: Oscar Figueiredo <oscar@cpe.fr>
;; Maintainer: Pavel Jank <Pavel@Janik.cz>
;; Keywords: comm
+;; Package: eudc
;; This file is part of GNU Emacs.
@@ -32,9 +33,18 @@
(require 'eudc)
(defvar eudc-hotlist-menu nil)
-(defvar eudc-hotlist-mode-map nil)
(defvar eudc-hotlist-list-beginning nil)
+(defvar eudc-hotlist-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "a" 'eudc-hotlist-add-server)
+ (define-key map "d" 'eudc-hotlist-delete-server)
+ (define-key map "s" 'eudc-hotlist-select-server)
+ (define-key map "t" 'eudc-hotlist-transpose-servers)
+ (define-key map "q" 'eudc-hotlist-quit-edit)
+ (define-key map "x" 'kill-this-buffer)
+ map))
+
(defun eudc-hotlist-mode ()
"Major mode used to edit the hotlist of servers.
@@ -168,16 +178,6 @@ These are the special commands of this mode:
(forward-line 1)
(transpose-lines 1))))))
-(setq eudc-hotlist-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map "a" 'eudc-hotlist-add-server)
- (define-key map "d" 'eudc-hotlist-delete-server)
- (define-key map "s" 'eudc-hotlist-select-server)
- (define-key map "t" 'eudc-hotlist-transpose-servers)
- (define-key map "q" 'eudc-hotlist-quit-edit)
- (define-key map "x" 'kill-this-buffer)
- map))
-
(defconst eudc-hotlist-menu
'("EUDC Hotlist Edit"
["---" nil nil]
diff --git a/lisp/net/eudc-vars.el b/lisp/net/eudc-vars.el
index 5f8de5ec751..e5e231a3744 100644
--- a/lisp/net/eudc-vars.el
+++ b/lisp/net/eudc-vars.el
@@ -1,11 +1,12 @@
;;; eudc-vars.el --- Emacs Unified Directory Client
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Oscar Figueiredo <oscar@cpe.fr>
;; Maintainer: Pavel Jank <Pavel@Janik.cz>
;; Keywords: comm
+;; Package: eudc
;; This file is part of GNU Emacs.
@@ -38,7 +39,7 @@
:group 'comm)
(defcustom eudc-server nil
- "*The name or IP address of the directory server.
+ "The name or IP address of the directory server.
A port number may be specified by appending a colon and a
number to the name of the server. Use `localhost' if the directory
server resides on your computer (BBDB backend)."
@@ -55,7 +56,7 @@ This variable is updated when protocol-specific libraries
are loaded, *do not change manually*.")
(defcustom eudc-protocol nil
- "*The directory protocol to use to query the server.
+ "The directory protocol to use to query the server.
Supported protocols are specified by `eudc-supported-protocols'."
:type `(choice :menu-tag "Protocol"
,@(mapcar (lambda (s)
@@ -66,13 +67,13 @@ Supported protocols are specified by `eudc-supported-protocols'."
(defcustom eudc-strict-return-matches t
- "*Ignore or allow entries not containing all requested return attributes.
+ "Ignore or allow entries not containing all requested return attributes.
If non-nil, such entries are ignored."
:type 'boolean
:group 'eudc)
(defcustom eudc-default-return-attributes nil
- "*A list of default attributes to extract from directory entries.
+ "A list of default attributes to extract from directory entries.
If set to the symbol `all', return all attributes.
A value of nil means return the default attributes as configured in the
server."
@@ -86,7 +87,7 @@ server."
:group 'eudc)
(defcustom eudc-multiple-match-handling-method 'select
- "*What to do when multiple entries match an inline expansion query.
+ "What to do when multiple entries match an inline expansion query.
Possible values are:
`first' (equivalent to nil) which means keep the first match only,
`select' pop-up a selection buffer,
@@ -106,7 +107,7 @@ Possible values are:
:group 'eudc)
(defcustom eudc-duplicate-attribute-handling-method '((email . duplicate))
- "*A method to handle entries containing duplicate attributes.
+ "A method to handle entries containing duplicate attributes.
This is either an alist (ATTR . METHOD) or a symbol METHOD.
The alist form of the variable associates a method to an individual attribute,
the second form specifies a method applicable to all attributes.
@@ -135,7 +136,7 @@ different values."
(defcustom eudc-inline-query-format '((name)
(firstname name))
- "*Format of an inline expansion query.
+ "Format of an inline expansion query.
This is a list of FORMATs. A FORMAT is itself a list of one or more
EUDC attribute names. A FORMAT applies if it contains as many attributes as
there are individual words in the inline query string.
@@ -163,12 +164,12 @@ must be set in a protocol/server-local fashion, see `eudc-server-set' and
:group 'eudc)
(defcustom eudc-expansion-overwrites-query t
- "*If non-nil, expanding a query overwrites the query string."
+ "If non-nil, expanding a query overwrites the query string."
:type 'boolean
:group 'eudc)
(defcustom eudc-inline-expansion-format '("%s" email)
- "*A list specifying the format of the expansion of inline queries.
+ "A list specifying the format of the expansion of inline queries.
This variable controls what `eudc-expand-inline' actually inserts in
the buffer. First element is a string passed to `format'. Remaining
elements are symbols indicating attribute names; the corresponding values
@@ -188,7 +189,7 @@ are passed as additional arguments to `format'."
:group 'eudc)
(defcustom eudc-inline-expansion-servers 'server-then-hotlist
- "*Which servers to contact for the expansion of inline queries.
+ "Which servers to contact for the expansion of inline queries.
Possible values are:
`current-server': the EUDC current server.
`hotlist': the servers of the hotlist in the order they appear,
@@ -202,7 +203,7 @@ Possible values are:
:group 'eudc)
(defcustom eudc-max-servers-to-query nil
- "*Maximum number of servers to query for an inline expansion.
+ "Maximum number of servers to query for an inline expansion.
If nil, query all servers available from `eudc-inline-expansion-servers'."
:tag "Max Number of Servers to Query"
:type '(choice :tag "Max. Servers"
@@ -217,7 +218,7 @@ If nil, query all servers available from `eudc-inline-expansion-servers'."
:group 'eudc)
(defcustom eudc-query-form-attributes '(name firstname email phone)
- "*A list of attributes presented in the query form."
+ "A list of attributes presented in the query form."
:tag "Attributes in Query Forms"
:type '(repeat
(choice
@@ -248,7 +249,7 @@ If nil, query all servers available from `eudc-inline-expansion-servers'."
(telephonenumber . "Phone")
(uniqueidentifier . "ID")
(objectclass . "Object Class"))
- "*Alist of user-defined names for directory attributes.
+ "Alist of user-defined names for directory attributes.
These names are used as prompt strings in query/response forms
instead of the raw directory attribute names.
Prompt strings for attributes that are not listed here
@@ -261,14 +262,14 @@ at `_' characters and capitalizing the individual words."
:group 'eudc)
(defcustom eudc-use-raw-directory-names nil
- "*If non-nil, use attributes names as defined in the directory.
+ "If non-nil, use attributes names as defined in the directory.
Otherwise, directory query/response forms display the user attribute
names defined in `eudc-user-attribute-names-alist'."
:type 'boolean
:group 'eudc)
(defcustom eudc-attribute-display-method-alist nil
- "*An alist specifying methods to display attribute values.
+ "An alist specifying methods to display attribute values.
Each member of the list is of the form (NAME . FUNC) where NAME is a lowercased
string naming a directory attribute (translated according to
`eudc-user-attribute-names-alist' if `eudc-use-raw-directory-names' is
@@ -282,7 +283,7 @@ attribute values for display."
(defcustom eudc-external-viewers '(("ImageMagick" "display" "-")
("ShowAudio" "showaudio"))
- "*A list of viewer program specifications.
+ "A list of viewer program specifications.
Viewers are programs which can be piped a directory attribute value for
display or arbitrary processing. Each specification is a list whose
first element is a string naming the viewer. The second element is the
@@ -299,12 +300,12 @@ arguments that should be passed to the program."
:group 'eudc)
(defcustom eudc-options-file "~/.eudc-options"
- "*A file where the `servers' hotlist is stored."
+ "A file where the `servers' hotlist is stored."
:type '(file :Tag "File Name:")
:group 'eudc)
(defcustom eudc-mode-hook nil
- "*Normal hook run on entry to EUDC mode."
+ "Normal hook run on entry to EUDC mode."
:type '(repeat (sexp :tag "Hook definition"))
:group 'eudc)
@@ -322,7 +323,7 @@ arguments that should be passed to the program."
(address . (eudc-bbdbify-address address "Address"))
(phone . ((eudc-bbdbify-phone phone "Phone")
(eudc-bbdbify-phone office_phone "Office Phone"))))
- "*A mapping from BBDB to PH/QI fields.
+ "A mapping from BBDB to PH/QI fields.
This is a list of cons cells (BBDB-FIELD . SPEC-OR-LIST) where
BBDB-FIELD is the name of a field that must be defined in your BBDB
environment (standard field names are `name', `company', `net', `phone',
@@ -357,7 +358,7 @@ BBDB fields. SPECs are sexps which are evaluated:
(net . mail)
(address . (eudc-bbdbify-address postaladdress "Address"))
(phone . ((eudc-bbdbify-phone telephonenumber "Phone"))))
- "*A mapping from BBDB to LDAP attributes.
+ "A mapping from BBDB to LDAP attributes.
This is a list of cons cells (BBDB-FIELD . SPEC-OR-LIST) where
BBDB-FIELD is the name of a field that must be defined in your BBDB
environment (standard field names are `name', `company', `net', `phone',
diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el
index 384ddbbecf2..282a60a8288 100644
--- a/lisp/net/eudc.el
+++ b/lisp/net/eudc.el
@@ -830,10 +830,7 @@ see `eudc-inline-expansion-servers'"
(let* ((end (point))
(beg (save-excursion
(if (re-search-backward "\\([:,]\\|^\\)[ \t]*"
- (save-excursion
- (beginning-of-line)
- (point))
- 'move)
+ (point-at-bol) 'move)
(goto-char (match-end 0)))
(point)))
(query-words (split-string (buffer-substring beg end) "[ \t]+"))
@@ -1295,5 +1292,4 @@ This does nothing except loading eudc by autoload side-effect."
(provide 'eudc)
-;; arch-tag: e18872b6-db83-400b-869d-be54e9a4160c
;;; eudc.el ends here
diff --git a/lisp/net/eudcb-bbdb.el b/lisp/net/eudcb-bbdb.el
index 0ddfa81a501..aa4315077e4 100644
--- a/lisp/net/eudcb-bbdb.el
+++ b/lisp/net/eudcb-bbdb.el
@@ -6,6 +6,7 @@
;; Author: Oscar Figueiredo <oscar@cpe.fr>
;; Maintainer: Pavel Jank <Pavel@Janik.cz>
;; Keywords: comm
+;; Package: eudc
;; This file is part of GNU Emacs.
diff --git a/lisp/net/eudcb-ldap.el b/lisp/net/eudcb-ldap.el
index fc90be96b5d..e2ca2acaddb 100644
--- a/lisp/net/eudcb-ldap.el
+++ b/lisp/net/eudcb-ldap.el
@@ -6,6 +6,7 @@
;; Author: Oscar Figueiredo <oscar@cpe.fr>
;; Maintainer: Pavel Jank <Pavel@Janik.cz>
;; Keywords: comm
+;; Package: eudc
;; This file is part of GNU Emacs.
diff --git a/lisp/net/eudcb-mab.el b/lisp/net/eudcb-mab.el
index 8705be81b04..d848b9953a3 100644
--- a/lisp/net/eudcb-mab.el
+++ b/lisp/net/eudcb-mab.el
@@ -6,6 +6,7 @@
;; Author: John Wiegley <johnw@newartisans.com>
;; Maintainer: FSF
;; Keywords: comm
+;; Package: eudc
;; This file is part of GNU Emacs.
diff --git a/lisp/net/eudcb-ph.el b/lisp/net/eudcb-ph.el
index bd2e75ced0a..c0e4f81d31c 100644
--- a/lisp/net/eudcb-ph.el
+++ b/lisp/net/eudcb-ph.el
@@ -6,6 +6,7 @@
;; Author: Oscar Figueiredo <oscar@cpe.fr>
;; Maintainer: Pavel Jank <Pavel@Janik.cz>
;; Keywords: comm
+;; Package: eudc
;; This file is part of GNU Emacs.
diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el
new file mode 100644
index 00000000000..85c546ffd3f
--- /dev/null
+++ b/lisp/net/gnutls.el
@@ -0,0 +1,115 @@
+;;; gnutls.el --- Support SSL/TLS connections through GnuTLS
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Ted Zlatanov <tzz@lifelogs.com>
+;; Keywords: comm, tls, ssl, encryption
+;; Originally-By: Simon Josefsson (See http://josefsson.org/emacs-security/)
+;; Thanks-To: Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package provides language bindings for the GnuTLS library
+;; using the corresponding core functions in gnutls.c.
+
+;; Simple test:
+;;
+;; (open-gnutls-stream "tls" "tls-buffer" "yourserver.com" "https")
+;; (open-gnutls-stream "tls" "tls-buffer" "imap.gmail.com" "imaps")
+
+;;; Code:
+
+(defgroup gnutls nil
+ "Emacs interface to the GnuTLS library."
+ :prefix "gnutls-"
+ :group 'net-utils)
+
+(defcustom gnutls-log-level 0
+ "Logging level to be used by `starttls-negotiate' and GnuTLS."
+ :type 'integer
+ :group 'gnutls)
+
+(defun open-gnutls-stream (name buffer host service)
+ "Open a SSL/TLS 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.
+ 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.
+
+This is a very simple wrapper around `gnutls-negotiate'. See its
+documentation for the specific parameters you can use to open a
+GnuTLS connection, including specifying the credential type,
+trust and key files, and priority string."
+ (let ((proc (open-network-stream name buffer host service)))
+ (gnutls-negotiate proc 'gnutls-x509pki)))
+
+(declare-function gnutls-boot "gnutls.c" (proc type proplist))
+
+(defun gnutls-negotiate (proc type &optional priority-string
+ trustfiles keyfiles)
+ "Negotiate a SSL/TLS connection.
+TYPE is `gnutls-x509pki' (default) or `gnutls-anon'. Use nil for the default.
+PROC is a process returned by `open-network-stream'.
+PRIORITY-STRING is as per the GnuTLS docs, default is \"NORMAL\".
+TRUSTFILES is a list of CA bundles.
+KEYFILES is a list of client keys."
+ (let* ((type (or type 'gnutls-x509pki))
+ (trusfiles (or trustfiles
+ '("/etc/ssl/certs/ca-certificates.crt")))
+ (priority-string (or priority-string
+ (cond
+ ((eq type 'gnutls-anon)
+ "NORMAL:+ANON-DH:!ARCFOUR-128")
+ ((eq type 'gnutls-x509pki)
+ "NORMAL"))))
+ (params `(:priority ,priority-string
+ :loglevel ,gnutls-log-level
+ :trustfiles ,trustfiles
+ :keyfiles ,keyfiles
+ :callbacks nil))
+ ret)
+
+ (gnutls-message-maybe
+ (setq ret (gnutls-boot proc type params))
+ "boot: %s")
+
+ proc))
+
+(declare-function gnutls-errorp "gnutls.c" (error))
+(declare-function gnutls-error-string "gnutls.c" (error))
+
+(defun gnutls-message-maybe (doit format &rest params)
+ "When DOIT, message with the caller name followed by FORMAT on PARAMS."
+ ;; (apply 'debug format (or params '(nil)))
+ (when (gnutls-errorp doit)
+ (message "%s: (err=[%s] %s) %s"
+ "gnutls.el"
+ doit (gnutls-error-string doit)
+ (apply 'format format (or params '(nil))))))
+
+(provide 'gnutls)
+
+;;; gnutls.el ends here
diff --git a/lisp/net/goto-addr.el b/lisp/net/goto-addr.el
index fd8c1061bcb..182758aaffb 100644
--- a/lisp/net/goto-addr.el
+++ b/lisp/net/goto-addr.el
@@ -76,7 +76,7 @@
(defgroup goto-address nil
"Click to browse URL or to send to e-mail address."
:group 'mouse
- :group 'hypermedia)
+ :group 'comm)
;; I don't expect users to want fontify'ing without highlighting.
diff --git a/lisp/net/hmac-def.el b/lisp/net/hmac-def.el
index 9cbb919abcc..c16fffc8de4 100644
--- a/lisp/net/hmac-def.el
+++ b/lisp/net/hmac-def.el
@@ -3,7 +3,7 @@
;; Copyright (C) 1999, 2001, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
-;; Keywords: HMAC, RFC-2104
+;; Keywords: HMAC, RFC2104
;; This file is part of GNU Emacs.
@@ -22,7 +22,7 @@
;;; Commentary:
-;; This program is implemented from RFC 2104,
+;; This program is implemented from RFC2104,
;; "HMAC: Keyed-Hashing for Message Authentication".
;;; Code:
@@ -80,5 +80,4 @@ If BIT is non-nil, truncate output to specified bits."
(provide 'hmac-def)
-;; arch-tag: 645adcef-b835-4900-a10a-11f636c982b9
;;; hmac-def.el ends here
diff --git a/lisp/net/hmac-md5.el b/lisp/net/hmac-md5.el
index 9bda79d36f0..a0bfd36ea69 100644
--- a/lisp/net/hmac-md5.el
+++ b/lisp/net/hmac-md5.el
@@ -3,7 +3,7 @@
;; Copyright (C) 1999, 2001, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
-;; Keywords: HMAC, RFC-2104, HMAC-MD5, MD5, KEYED-MD5, CRAM-MD5
+;; Keywords: HMAC, RFC2104, HMAC-MD5, MD5, KEYED-MD5, CRAM-MD5
;; This file is part of GNU Emacs.
@@ -79,5 +79,4 @@
(provide 'hmac-md5)
-;; arch-tag: 0ab3f4f6-3d4b-4167-a9fa-635b7fed7f27
;;; hmac-md5.el ends here
diff --git a/lisp/net/imap.el b/lisp/net/imap.el
index a47822533e5..9265e962b38 100644
--- a/lisp/net/imap.el
+++ b/lisp/net/imap.el
@@ -139,6 +139,7 @@
(eval-when-compile (require 'cl))
(eval-and-compile
+ ;; For Emacs <22.2 and XEmacs.
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
(autoload 'starttls-open-stream "starttls")
(autoload 'starttls-negotiate "starttls")
@@ -267,7 +268,7 @@ See also `imap-log'."
:type 'string)
(defcustom imap-read-timeout (if (string-match
- "windows-nt\\|os/2\\|emx\\|cygwin"
+ "windows-nt\\|os/2\\|cygwin"
(symbol-name system-type))
1.0
0.1)
@@ -475,10 +476,10 @@ sure of changing the value of `foo'."
(setcdr alist (imap-remassoc key (cdr alist)))
alist)))
-(defsubst imap-disable-multibyte ()
+(defmacro imap-disable-multibyte ()
"Enable multibyte in the current buffer."
- (when (fboundp 'set-buffer-multibyte)
- (set-buffer-multibyte nil)))
+ (unless (featurep 'xemacs)
+ '(set-buffer-multibyte nil)))
(defsubst imap-utf7-encode (string)
(if imap-use-utf7
@@ -515,6 +516,16 @@ sure of changing the value of `foo'."
;; Server functions; stream stuff:
+(defun imap-log (string-or-buffer)
+ (when imap-log
+ (with-current-buffer (get-buffer-create imap-log-buffer)
+ (imap-disable-multibyte)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (if (bufferp string-or-buffer)
+ (insert-buffer-substring string-or-buffer)
+ (insert string-or-buffer)))))
+
(defun imap-kerberos4-stream-p (buffer)
(imap-capability 'AUTH=KERBEROS_V4 buffer))
@@ -569,12 +580,6 @@ sure of changing the value of `foo'."
(setq response (match-string 1)))))
(accept-process-output process 1)
(sit-for 1))
- (and imap-log
- (with-current-buffer (get-buffer-create imap-log-buffer)
- (imap-disable-multibyte)
- (buffer-disable-undo)
- (goto-char (point-max))
- (insert-buffer-substring buffer)))
(erase-buffer)
(message "Opening Kerberos 4 IMAP connection with `%s'...%s" cmd
(if response (concat "done, " response) "failed"))
@@ -645,12 +650,7 @@ sure of changing the value of `foo'."
(setq response (match-string 1)))))
(accept-process-output process 1)
(sit-for 1))
- (and imap-log
- (with-current-buffer (get-buffer-create imap-log-buffer)
- (imap-disable-multibyte)
- (buffer-disable-undo)
- (goto-char (point-max))
- (insert-buffer-substring buffer)))
+ (imap-log buffer)
(erase-buffer)
(message "GSSAPI IMAP connection: %s" (or response "failed"))
(if (and response (let ((case-fold-search nil))
@@ -701,12 +701,7 @@ sure of changing the value of `foo'."
(not (imap-parse-greeting)))
(accept-process-output process 1)
(sit-for 1))
- (and imap-log
- (with-current-buffer (get-buffer-create imap-log-buffer)
- (imap-disable-multibyte)
- (buffer-disable-undo)
- (goto-char (point-max))
- (insert-buffer-substring buffer)))
+ (imap-log buffer)
(erase-buffer)
(when (memq (process-status process) '(open run))
(setq done process))))))
@@ -740,12 +735,7 @@ sure of changing the value of `foo'."
(not (imap-parse-greeting)))
(accept-process-output process 1)
(sit-for 1))
- (and imap-log
- (with-current-buffer (get-buffer-create imap-log-buffer)
- (imap-disable-multibyte)
- (buffer-disable-undo)
- (goto-char (point-max))
- (insert-buffer-substring buffer)))
+ (imap-log buffer)
(when (memq (process-status process) '(open run))
process))))
@@ -764,12 +754,7 @@ sure of changing the value of `foo'."
(not (imap-parse-greeting)))
(accept-process-output process 1)
(sit-for 1))
- (and imap-log
- (with-current-buffer (get-buffer-create imap-log-buffer)
- (imap-disable-multibyte)
- (buffer-disable-undo)
- (goto-char (point-max))
- (insert-buffer-substring buffer)))
+ (imap-log buffer)
(when (memq (process-status process) '(open run))
process))))
@@ -803,12 +788,7 @@ sure of changing the value of `foo'."
(not (imap-parse-greeting)))
(accept-process-output process 1)
(sit-for 1))
- (and imap-log
- (with-current-buffer (get-buffer-create imap-log-buffer)
- (imap-disable-multibyte)
- (buffer-disable-undo)
- (goto-char (point-max))
- (insert-buffer-substring buffer)))
+ (imap-log buffer)
(erase-buffer)
(when (memq (process-status process) '(open run))
(setq done process)))))
@@ -845,11 +825,7 @@ sure of changing the value of `foo'."
(not (re-search-forward "[0-9]+ OK.*\r?\n" nil t)))
(accept-process-output process 1)
(sit-for 1))
- (and imap-log
- (with-current-buffer (get-buffer-create imap-log-buffer)
- (buffer-disable-undo)
- (goto-char (point-max))
- (insert-buffer-substring buffer)))
+ (imap-log buffer)
(when (and (setq tls-info (starttls-negotiate process))
(memq (process-status process) '(open run)))
(setq done process)))
@@ -1227,7 +1203,7 @@ password is remembered in the buffer."
(when user (setq imap-username user))
(when passwd (setq imap-password passwd))
(if imap-auth
- (and (setq imap-last-authenticator
+ (and (setq imap-last-authenticator
(assq imap-auth imap-authenticator-alist))
(funcall (nth 2 imap-last-authenticator) (current-buffer))
(setq imap-state 'auth))
@@ -1959,12 +1935,7 @@ on failure."
(defun imap-send-command-1 (cmdstr)
(setq cmdstr (concat cmdstr imap-client-eol))
- (and imap-log
- (with-current-buffer (get-buffer-create imap-log-buffer)
- (imap-disable-multibyte)
- (buffer-disable-undo)
- (goto-char (point-max))
- (insert cmdstr)))
+ (imap-log cmdstr)
(process-send-string imap-process cmdstr))
(defun imap-send-command (command &optional buffer)
@@ -2002,13 +1973,7 @@ on failure."
(stream imap-stream)
(eol imap-client-eol))
(with-current-buffer cmd
- (and imap-log
- (with-current-buffer (get-buffer-create
- imap-log-buffer)
- (imap-disable-multibyte)
- (buffer-disable-undo)
- (goto-char (point-max))
- (insert-buffer-substring cmd)))
+ (imap-log cmd)
(process-send-region process (point-min)
(point-max)))
(process-send-string process imap-client-eol))))
@@ -2084,18 +2049,13 @@ Return nil if no complete line has arrived."
(with-current-buffer (process-buffer proc)
(goto-char (point-max))
(insert string)
- (and imap-log
- (with-current-buffer (get-buffer-create imap-log-buffer)
- (imap-disable-multibyte)
- (buffer-disable-undo)
- (goto-char (point-max))
- (insert string)))
+ (imap-log string)
(let (end)
(goto-char (point-min))
(while (setq end (imap-find-next-line))
(save-restriction
(narrow-to-region (point-min) end)
- (delete-backward-char (length imap-server-eol))
+ (delete-char (- (length imap-server-eol)))
(goto-char (point-min))
(unwind-protect
(cond ((eq imap-state 'initial)
@@ -3093,5 +3053,4 @@ Return nil if no complete line has arrived."
(provide 'imap)
-;; arch-tag: 27369ed6-33e4-482f-96f1-8bb906ba70f7
;;; imap.el ends here
diff --git a/lisp/net/ldap.el b/lisp/net/ldap.el
index 4676aba2d9a..066dbd8bea0 100644
--- a/lisp/net/ldap.el
+++ b/lisp/net/ldap.el
@@ -1,7 +1,7 @@
;;; ldap.el --- client interface to LDAP for Emacs
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Oscar Figueiredo <oscar@cpe.fr>
;; Maintainer: FSF
@@ -43,7 +43,7 @@
:group 'comm)
(defcustom ldap-default-host nil
- "*Default LDAP server.
+ "Default LDAP server.
A TCP port number can be appended to that name using a colon as
a separator."
:type '(choice (string :tag "Host name")
@@ -51,14 +51,14 @@ a separator."
:group 'ldap)
(defcustom ldap-default-port nil
- "*Default TCP port for LDAP connections.
+ "Default TCP port for LDAP connections.
Initialized from the LDAP library at build time. Default value is 389."
:type '(choice (const :tag "Use library default" nil)
(integer :tag "Port number"))
:group 'ldap)
(defcustom ldap-default-base nil
- "*Default base for LDAP searches.
+ "Default base for LDAP searches.
This is a string using the syntax of RFC 1779.
For instance, \"o=ACME, c=US\" limits the search to the
Acme organization in the United States."
@@ -68,7 +68,7 @@ Acme organization in the United States."
(defcustom ldap-host-parameters-alist nil
- "*Alist of host-specific options for LDAP transactions.
+ "Alist of host-specific options for LDAP transactions.
The format of each list element is (HOST PROP1 VAL1 PROP2 VAL2 ...).
HOST is the hostname of an LDAP server (with an optional TCP port number
appended to it using a colon as a separator).
@@ -148,28 +148,28 @@ Valid properties include:
:group 'ldap)
(defcustom ldap-ldapsearch-prog "ldapsearch"
- "*The name of the ldapsearch command line program."
+ "The name of the ldapsearch command line program."
:type '(string :tag "`ldapsearch' Program")
:group 'ldap)
(defcustom ldap-ldapsearch-args '("-LL" "-tt")
- "*A list of additional arguments to pass to `ldapsearch'."
+ "A list of additional arguments to pass to `ldapsearch'."
:type '(repeat :tag "`ldapsearch' Arguments"
(string :tag "Argument"))
:group 'ldap)
(defcustom ldap-ignore-attribute-codings nil
- "*If non-nil, do not encode/decode LDAP attribute values."
+ "If non-nil, do not encode/decode LDAP attribute values."
:type 'boolean
:group 'ldap)
(defcustom ldap-default-attribute-decoder nil
- "*Decoder function to use for attributes whose syntax is unknown."
+ "Decoder function to use for attributes whose syntax is unknown."
:type 'symbol
:group 'ldap)
(defcustom ldap-coding-system 'utf-8
- "*Coding system of LDAP string values.
+ "Coding system of LDAP string values.
LDAP v3 specifies the coding system of strings to be UTF-8."
:type 'symbol
:group 'ldap)
@@ -579,9 +579,7 @@ an alist of attribute/value pairs."
(while (progn
(skip-chars-forward " \t\n")
(not (eobp)))
- (setq dn (buffer-substring (point) (save-excursion
- (end-of-line)
- (point))))
+ (setq dn (buffer-substring (point) (point-at-eol)))
(forward-line 1)
(while (looking-at "^\\([A-Za-z][-A-Za-z0-9]*\
\\|[0-9]+\\(?:\\.[0-9]+\\)*\\)\\(;[-A-Za-z0-9]+\\)*[=:\t ]+\
@@ -617,5 +615,4 @@ an alist of attribute/value pairs."
(provide 'ldap)
-;; arch-tag: 47913a76-6155-42e6-ac58-6d28b5d50eb0
;;; ldap.el ends here
diff --git a/lisp/net/mairix.el b/lisp/net/mairix.el
index 1974427c829..bfac633c580 100644
--- a/lisp/net/mairix.el
+++ b/lisp/net/mairix.el
@@ -735,23 +735,21 @@ VALUES may contain values for editable fields from current article."
;;;; Major mode for editing/deleting/saving searches
-(defvar mairix-searches-mode-map nil "'mairix-searches-mode' keymap.")
-
-;; Keymap
-(if (not mairix-searches-mode-map)
- (let ((map (make-keymap)))
- (define-key map [(return)] 'mairix-select-search)
- (define-key map [(down)] 'mairix-next-search)
- (define-key map [(up)] 'mairix-previous-search)
- (define-key map [(right)] 'mairix-next-search)
- (define-key map [(left)] 'mairix-previous-search)
- (define-key map "\C-p" 'mairix-previous-search)
- (define-key map "\C-n" 'mairix-next-search)
- (define-key map [(q)] 'mairix-select-quit)
- (define-key map [(e)] 'mairix-select-edit)
- (define-key map [(d)] 'mairix-select-delete)
- (define-key map [(s)] 'mairix-select-save)
- (setq mairix-searches-mode-map map)))
+(defvar mairix-searches-mode-map
+ (let ((map (make-keymap)))
+ (define-key map [(return)] 'mairix-select-search)
+ (define-key map [(down)] 'mairix-next-search)
+ (define-key map [(up)] 'mairix-previous-search)
+ (define-key map [(right)] 'mairix-next-search)
+ (define-key map [(left)] 'mairix-previous-search)
+ (define-key map "\C-p" 'mairix-previous-search)
+ (define-key map "\C-n" 'mairix-next-search)
+ (define-key map [(q)] 'mairix-select-quit)
+ (define-key map [(e)] 'mairix-select-edit)
+ (define-key map [(d)] 'mairix-select-delete)
+ (define-key map [(s)] 'mairix-select-save)
+ map)
+ "'mairix-searches-mode' keymap.")
(defvar mairix-searches-mode-font-lock-keywords)
diff --git a/lisp/net/net-utils.el b/lisp/net/net-utils.el
index b69c571ddf5..60829f300b5 100644
--- a/lisp/net/net-utils.el
+++ b/lisp/net/net-utils.el
@@ -55,8 +55,7 @@
:group 'comm
:version "20.3")
-(defcustom net-utils-remove-ctl-m
- (member system-type (list 'windows-nt 'msdos))
+(defcustom net-utils-remove-ctl-m (memq system-type '(windows-nt msdos))
"If non-nil, remove control-Ms from output."
:group 'net-utils
:type 'boolean)
@@ -82,7 +81,7 @@
;; On GNU/Linux and Irix, the system's ping program seems to send packets
;; indefinitely unless told otherwise
(defcustom ping-program-options
- (and (memq system-type (list 'linux 'gnu/linux 'irix))
+ (and (memq system-type '(gnu/linux irix))
(list "-c" "4"))
"Options for the ping program.
These options can be used to limit how many ICMP packets are emitted."
@@ -889,5 +888,4 @@ from SEARCH-STRING. With argument, prompt for whois server."
(provide 'net-utils)
-;; arch-tag: 97119e91-9edb-4376-838b-bf7058fa1314
;;; net-utils.el ends here
diff --git a/lisp/net/netrc.el b/lisp/net/netrc.el
index 3445b840df8..ff0b52c2b96 100644
--- a/lisp/net/netrc.el
+++ b/lisp/net/netrc.el
@@ -4,6 +4,7 @@
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
+;;
;; Modularized by Ted Zlatanov <tzz@lifelogs.com>
;; when it was part of Gnus.
@@ -33,14 +34,10 @@
;;; .netrc and .authinfo rc parsing
;;;
-;; use encrypt if loaded (encrypt-file-alist has to be set as well)
-(autoload 'encrypt-find-model "encrypt")
-(autoload 'encrypt-insert-file-contents "encrypt")
(defalias 'netrc-point-at-eol
(if (fboundp 'point-at-eol)
'point-at-eol
'line-end-position))
-(defvar encrypt-file-alist)
(eval-when-compile
;; This is unnecessary in the compiled version as it is a macro.
(if (fboundp 'bound-and-true-p)
@@ -53,12 +50,19 @@
"Netrc configuration."
:group 'comm)
+(defcustom netrc-file "~/.authinfo"
+ "File where user credentials are stored."
+ :type 'file
+ :group 'netrc)
+
(defvar netrc-services-file "/etc/services"
"The name of the services file.")
-(defun netrc-parse (file)
+(defun netrc-parse (&optional file)
(interactive "fFile to Parse: ")
"Parse FILE and return a list of all entries in the file."
+ (unless file
+ (setq file netrc-file))
(if (listp file)
file
(when (file-exists-p file)
@@ -66,12 +70,8 @@
(let ((tokens '("machine" "default" "login"
"password" "account" "macdef" "force"
"port"))
- (encryption-model (when (netrc-bound-and-true-p encrypt-file-alist)
- (encrypt-find-model file)))
alist elem result pair)
- (if encryption-model
- (encrypt-insert-file-contents file encryption-model)
- (insert-file-contents file))
+ (insert-file-contents file)
(goto-char (point-min))
;; Go through the file, line by line.
(while (not (eobp))
@@ -131,19 +131,23 @@ Entries without port tokens default to DEFAULTPORT."
;; No machine name matches, so we look for default entries.
(while rest
(when (assoc "default" (car rest))
- (push (car rest) result))
+ (let ((elem (car rest)))
+ (setq elem (delete (assoc "default" elem) elem))
+ (push elem result)))
(pop rest)))
(when result
(setq result (nreverse result))
- (while (and result
- (not (netrc-port-equal
- (or port defaultport "nntp")
- ;; when port is not given in the netrc file,
- ;; it should mean "any port"
- (or (netrc-get (car result) "port")
- defaultport port))))
- (pop result))
- (car result))))
+ (if (not port)
+ (car result)
+ (while (and result
+ (not (netrc-port-equal
+ (or port defaultport "nntp")
+ ;; when port is not given in the netrc file,
+ ;; it should mean "any port"
+ (or (netrc-get (car result) "port")
+ defaultport port))))
+ (pop result))
+ (car result)))))
(defun netrc-machine-user-or-password (mode authinfo-file-or-list machines ports defaults)
"Get the user name or password according to MODE from AUTHINFO-FILE-OR-LIST.
@@ -159,9 +163,9 @@ MODE can be \"login\" or \"password\", suitable for passing to
(defaults (or defaults '(nil)))
info)
(if (listp mode)
- (setq info
- (mapcar
- (lambda (mode-element)
+ (setq info
+ (mapcar
+ (lambda (mode-element)
(netrc-machine-user-or-password
mode-element
authinfo-list
@@ -220,7 +224,33 @@ MODE can be \"login\" or \"password\", suitable for passing to
(eq type (car (cddr service)))))))
(cadr service)))
+(defun netrc-store-data (file host port user password)
+ (with-temp-buffer
+ (when (file-exists-p file)
+ (insert-file-contents file))
+ (goto-char (point-max))
+ (unless (bolp)
+ (insert "\n"))
+ (insert (format "machine %s login %s password %s port %s\n"
+ host user password port))
+ (write-region (point-min) (point-max) file nil 'silent)))
+
+;;;###autoload
+(defun netrc-credentials (machine &rest ports)
+ "Return a user name/password pair.
+Port specifications will be prioritised in the order they are
+listed in the PORTS list."
+ (let ((list (netrc-parse))
+ found)
+ (if (not ports)
+ (setq found (netrc-machine list machine))
+ (while (and ports
+ (not found))
+ (setq found (netrc-machine list machine (pop ports)))))
+ (when found
+ (list (cdr (assoc "login" found))
+ (cdr (assoc "password" found))))))
+
(provide 'netrc)
-;; arch-tag: af9929cc-2d12-482f-936e-eb4366f9fa55
;;; netrc.el ends here
diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el
index 5a8f1dff5c0..590363a1f65 100644
--- a/lisp/net/newst-backend.el
+++ b/lisp/net/newst-backend.el
@@ -8,6 +8,7 @@
;; URL: http://www.nongnu.org/newsticker
;; Keywords: News, RSS, Atom
;; Time-stamp: "6. Dezember 2009, 19:15:32 (ulf)"
+;; Package: newsticker
;; ======================================================================
diff --git a/lisp/net/newst-plainview.el b/lisp/net/newst-plainview.el
index e1bdc2cade2..a6629a40721 100644
--- a/lisp/net/newst-plainview.el
+++ b/lisp/net/newst-plainview.el
@@ -7,6 +7,7 @@
;; Filename: newst-plainview.el
;; URL: http://www.nongnu.org/newsticker
;; Time-stamp: "6. Dezember 2009, 19:17:02 (ulf)"
+;; Package: newsticker
;; ======================================================================
diff --git a/lisp/net/newst-reader.el b/lisp/net/newst-reader.el
index ce468235b46..25ed65d04ae 100644
--- a/lisp/net/newst-reader.el
+++ b/lisp/net/newst-reader.el
@@ -7,6 +7,7 @@
;; Filename: newst-reader.el
;; URL: http://www.nongnu.org/newsticker
;; Time-stamp: "6. Dezember 2009, 19:16:38 (ulf)"
+;; Package: newsticker
;; ======================================================================
diff --git a/lisp/net/newst-ticker.el b/lisp/net/newst-ticker.el
index 694d2cbc200..80df1a14f23 100644
--- a/lisp/net/newst-ticker.el
+++ b/lisp/net/newst-ticker.el
@@ -8,6 +8,7 @@
;; URL: http://www.nongnu.org/newsticker
;; Keywords: News, RSS, Atom
;; Time-stamp: "6. Dezember 2009, 19:16:00 (ulf)"
+;; Package: newsticker
;; ======================================================================
diff --git a/lisp/net/newst-treeview.el b/lisp/net/newst-treeview.el
index 80bc2c70a1e..6bf0b593de3 100644
--- a/lisp/net/newst-treeview.el
+++ b/lisp/net/newst-treeview.el
@@ -8,6 +8,7 @@
;; Created: 2007
;; Keywords: News, RSS, Atom
;; Time-stamp: "6. Dezember 2009, 19:17:28 (ulf)"
+;; Package: newsticker
;; ======================================================================
diff --git a/lisp/net/newsticker.el b/lisp/net/newsticker.el
index 1d4b35bb61c..2566529d421 100644
--- a/lisp/net/newsticker.el
+++ b/lisp/net/newsticker.el
@@ -9,6 +9,7 @@
;; Created: 17. June 2003
;; Keywords: News, RSS, Atom
;; Time-stamp: "6. Dezember 2009, 19:15:18 (ulf)"
+;; Version: 1.99
;; ======================================================================
diff --git a/lisp/net/ntlm.el b/lisp/net/ntlm.el
index 91e40e3d018..517e97efe6c 100644
--- a/lisp/net/ntlm.el
+++ b/lisp/net/ntlm.el
@@ -27,9 +27,9 @@
;; This library is a direct translation of the Samba release 2.2.0
;; implementation of Windows NT and LanManager compatible password
;; encryption.
-;;
+;;
;; Interface functions:
-;;
+;;
;; ntlm-build-auth-request
;; This will return a binary string, which should be used in the
;; base64 encoded form and it is the caller's responsibility to encode
@@ -40,7 +40,7 @@
;; (which will be a binary string) as the first argument and to
;; encode the returned string with base64. The second argument user
;; should be given in user@domain format.
-;;
+;;
;; ntlm-get-password-hashes
;;
;;
@@ -534,5 +534,4 @@ into a Unicode string. PASSWD is truncated to 128 bytes if longer."
(provide 'ntlm)
-;; arch-tag: 348ace18-f8e2-4176-8fe9-d9ab4e96f296
;;; ntlm.el ends here
diff --git a/lisp/net/quickurl.el b/lisp/net/quickurl.el
index 93e0aca541f..4e99f542b32 100644
--- a/lisp/net/quickurl.el
+++ b/lisp/net/quickurl.el
@@ -1,7 +1,7 @@
;;; quickurl.el --- insert an URL based on text at point in buffer
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Dave Pearson <davep@davep.org>
;; Maintainer: Dave Pearson <davep@davep.org>
@@ -173,7 +173,20 @@ in your ~/.emacs (after loading/requiring quickurl).")
(defvar quickurl-urls nil
"URL alist for use with `quickurl' and `quickurl-ask'.")
-(defvar quickurl-list-mode-map nil
+(defvar quickurl-list-mode-map
+ (let ((map (make-sparse-keymap)))
+ (suppress-keymap map t)
+ (define-key map "a" #'quickurl-list-add-url)
+ (define-key map [(control m)] #'quickurl-list-insert-url)
+ (define-key map "u" #'quickurl-list-insert-naked-url)
+ (define-key map " " #'quickurl-list-insert-with-lookup)
+ (define-key map "l" #'quickurl-list-insert-lookup)
+ (define-key map "d" #'quickurl-list-insert-with-desc)
+ (define-key map [(control g)] #'quickurl-list-quit)
+ (define-key map "q" #'quickurl-list-quit)
+ (define-key map [mouse-2] #'quickurl-list-mouse-select)
+ (define-key map "?" #'describe-mode)
+ map)
"Local keymap for a `quickurl-list-mode' buffer.")
(defvar quickurl-list-buffer-name "*quickurl-list*"
@@ -420,21 +433,6 @@ current buffer, this default action can be modifed via
;; quickurl-list mode.
-(unless quickurl-list-mode-map
- (let ((map (make-sparse-keymap)))
- (suppress-keymap map t)
- (define-key map "a" #'quickurl-list-add-url)
- (define-key map [(control m)] #'quickurl-list-insert-url)
- (define-key map "u" #'quickurl-list-insert-naked-url)
- (define-key map " " #'quickurl-list-insert-with-lookup)
- (define-key map "l" #'quickurl-list-insert-lookup)
- (define-key map "d" #'quickurl-list-insert-with-desc)
- (define-key map [(control g)] #'quickurl-list-quit)
- (define-key map "q" #'quickurl-list-quit)
- (define-key map [mouse-2] #'quickurl-list-mouse-select)
- (define-key map "?" #'describe-mode)
- (setq quickurl-list-mode-map map)))
-
(put 'quickurl-list-mode 'mode-class 'special)
;;;###autoload
@@ -508,9 +506,7 @@ TYPE dictates what will be inserted, options are:
`with-lookup' - Insert \"lookup <URL:url>\"
`with-desc' - Insert \"description <URL:url>\"
`lookup' - Insert the lookup for that URL"
- (let ((url (nth (save-excursion
- (beginning-of-line)
- (count-lines (point-min) (point)))
+ (let ((url (nth (count-lines (point-min) (line-beginning-position))
quickurl-urls)))
(if url
(with-current-buffer quickurl-list-last-buffer
@@ -544,5 +540,4 @@ TYPE dictates what will be inserted, options are:
(provide 'quickurl)
-;; arch-tag: a8183ea5-80c2-4082-a7d1-b0fdf2da467e
;;; quickurl.el ends here
diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el
index 500f27851f6..093892a1100 100644
--- a/lisp/net/rcirc.el
+++ b/lisp/net/rcirc.el
@@ -1,6 +1,7 @@
;;; rcirc.el --- default, simple IRC client.
-;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Ryan Yeske
;; URL: http://www.nongnu.org/rcirc
@@ -114,15 +115,15 @@ connected to automatically."
:type 'string
:group 'rcirc)
-(defcustom rcirc-default-user-name (user-login-name)
+(defcustom rcirc-default-user-name "user"
"Your user name sent to the server when connecting."
+ :version "24.1" ; changed default
:type 'string
:group 'rcirc)
-(defcustom rcirc-default-full-name (if (string= (user-full-name) "")
- rcirc-default-user-name
- (user-full-name))
+(defcustom rcirc-default-full-name "unknown"
"The full name sent to the server when connecting."
+ :version "24.1" ; changed default
:type 'string
:group 'rcirc)
@@ -375,6 +376,9 @@ and the cdr part is used for encoding."
(defvar rcirc-nick-name-history nil
"History variable for \\[rcirc] call.")
+(defvar rcirc-user-name-history nil
+ "History variable for \\[rcirc] call.")
+
;;;###autoload
(defun rcirc (arg)
"Connect to all servers in `rcirc-server-alist'.
@@ -399,8 +403,12 @@ If ARG is non-nil, instead prompt for connection parameters."
(or (plist-get server-plist :nick)
rcirc-default-nick)
'rcirc-nick-name-history))
- (password (read-passwd "IRC Password: "
- (plist-get server-plist 'password)))
+ (user-name (read-string "IRC Username: "
+ (or (plist-get server-plist :user-name)
+ rcirc-default-user-name)
+ 'rcirc-user-name-history))
+ (password (read-passwd "IRC Password: " nil
+ (plist-get server-plist :password)))
(channels (split-string
(read-string "IRC Channels: "
(mapconcat 'identity
@@ -408,11 +416,7 @@ If ARG is non-nil, instead prompt for connection parameters."
:channels)
" "))
"[, ]+" t)))
-
- (when (= 0 (length password))
- (setq password nil))
-
- (rcirc-connect server port nick rcirc-default-user-name
+ (rcirc-connect server port nick user-name
rcirc-default-full-name
channels password))
;; connect to servers in `rcirc-server-alist'
@@ -466,8 +470,8 @@ If ARG is non-nil, instead prompt for connection parameters."
(defvar rcirc-process nil)
;;;###autoload
-(defun rcirc-connect (server &optional port nick user-name full-name
- startup-channels password)
+(defun rcirc-connect (server &optional port nick user-name
+ full-name startup-channels password)
(save-excursion
(message "Connecting to %s..." server)
(let* ((inhibit-eol-conversion)
@@ -520,8 +524,7 @@ If ARG is non-nil, instead prompt for connection parameters."
(rcirc-send-string process (concat "PASS " password)))
(rcirc-send-string process (concat "NICK " nick))
(rcirc-send-string process (concat "USER " user-name
- " hostname servername :"
- full-name))
+ " 0 * :" full-name))
;; setup ping timer if necessary
(unless rcirc-keepalive-timer
@@ -771,42 +774,64 @@ If SILENT is non-nil, do not print the message in any irc buffer."
(setq rcirc-input-ring-index (1- rcirc-input-ring-index))
(insert (rcirc-prev-input-string -1))))
-(defvar rcirc-nick-completions nil)
-(defvar rcirc-nick-completion-start-offset nil)
-
-(defun rcirc-complete-nick ()
- "Cycle through nick completions from list of nicks in channel."
+(defvar rcirc-server-commands
+ '("/admin" "/away" "/connect" "/die" "/error" "/info"
+ "/invite" "/ison" "/join" "/kick" "/kill" "/links"
+ "/list" "/lusers" "/mode" "/motd" "/names" "/nick"
+ "/notice" "/oper" "/part" "/pass" "/ping" "/pong"
+ "/privmsg" "/quit" "/rehash" "/restart" "/service" "/servlist"
+ "/server" "/squery" "/squit" "/stats" "/summon" "/time"
+ "/topic" "/trace" "/user" "/userhost" "/users" "/version"
+ "/wallops" "/who" "/whois" "/whowas")
+ "A list of user commands by IRC server.
+The value defaults to RFCs 1459 and 2812.")
+
+;; /me and /ctcp are not defined by `defun-rcirc-command'.
+(defvar rcirc-client-commands '("/me" "/ctcp")
+ "A list of user commands defined by IRC client rcirc.
+The list is updated automatically by `defun-rcirc-command'.")
+
+(defun rcirc-completion-at-point ()
+ "Function used for `completion-at-point-functions' in `rcirc-mode'."
+ (let* ((beg (save-excursion
+ (if (re-search-backward " " rcirc-prompt-end-marker t)
+ (1+ (point))
+ rcirc-prompt-end-marker)))
+ (table (if (and (= beg rcirc-prompt-end-marker)
+ (eq (char-after beg) ?/))
+ (delete-dups
+ (nconc
+ (sort (copy-sequence rcirc-client-commands) 'string-lessp)
+ (sort (copy-sequence rcirc-server-commands) 'string-lessp)))
+ (rcirc-channel-nicks (rcirc-buffer-process) rcirc-target))))
+ (list beg (point) table)))
+
+(defvar rcirc-completions nil)
+(defvar rcirc-completion-start nil)
+
+(defun rcirc-complete ()
+ "Cycle through completions from list of nicks in channel or IRC commands.
+IRC command completion is performed only if '/' is the first input char."
(interactive)
(if (eq last-command this-command)
- (setq rcirc-nick-completions
- (append (cdr rcirc-nick-completions)
- (list (car rcirc-nick-completions))))
- (setq rcirc-nick-completion-start-offset
- (- (save-excursion
- (if (re-search-backward " " rcirc-prompt-end-marker t)
- (1+ (point))
- rcirc-prompt-end-marker))
- rcirc-prompt-end-marker))
- (setq rcirc-nick-completions
- (let ((completion-ignore-case t))
- (all-completions
- (buffer-substring
- (+ rcirc-prompt-end-marker
- rcirc-nick-completion-start-offset)
- (point))
- (mapcar (lambda (x) (cons x nil))
- (rcirc-channel-nicks (rcirc-buffer-process)
- rcirc-target))))))
- (let ((completion (car rcirc-nick-completions)))
+ (setq rcirc-completions
+ (append (cdr rcirc-completions) (list (car rcirc-completions))))
+ (let ((completion-ignore-case t)
+ (table (rcirc-completion-at-point)))
+ (setq rcirc-completion-start (car table))
+ (setq rcirc-completions
+ (all-completions (buffer-substring rcirc-completion-start
+ (cadr table))
+ (nth 2 table)))))
+ (let ((completion (car rcirc-completions)))
(when completion
- (delete-region (+ rcirc-prompt-end-marker
- rcirc-nick-completion-start-offset)
- (point))
- (insert (concat completion
- (if (= (+ rcirc-prompt-end-marker
- rcirc-nick-completion-start-offset)
- rcirc-prompt-end-marker)
- ": "))))))
+ (delete-region rcirc-completion-start (point))
+ (insert
+ (concat completion
+ (cond
+ ((= (aref completion 0) ?/) " ")
+ ((= rcirc-completion-start rcirc-prompt-end-marker) ": ")
+ (t "")))))))
(defun set-rcirc-decode-coding-system (coding-system)
"Set the decode coding system used in this channel."
@@ -824,7 +849,7 @@ If SILENT is non-nil, do not print the message in any irc buffer."
(define-key rcirc-mode-map (kbd "RET") 'rcirc-send-input)
(define-key rcirc-mode-map (kbd "M-p") 'rcirc-insert-prev-input)
(define-key rcirc-mode-map (kbd "M-n") 'rcirc-insert-next-input)
-(define-key rcirc-mode-map (kbd "TAB") 'rcirc-complete-nick)
+(define-key rcirc-mode-map (kbd "TAB") 'rcirc-complete)
(define-key rcirc-mode-map (kbd "C-c C-b") 'rcirc-browse-url)
(define-key rcirc-mode-map (kbd "C-c C-c") 'rcirc-edit-multiline)
(define-key rcirc-mode-map (kbd "C-c C-j") 'rcirc-cmd-join)
@@ -945,6 +970,9 @@ This number is independent of the number of lines in the buffer.")
rcirc-buffer-alist))))
(rcirc-update-short-buffer-names))
+ (add-hook 'completion-at-point-functions
+ 'rcirc-completion-at-point nil 'local)
+
(run-hooks 'rcirc-mode-hook))
(defun rcirc-update-prompt (&optional all)
@@ -1339,6 +1367,12 @@ Logfiles are kept in `rcirc-log-directory'."
:type 'integer
:group 'rcirc)
+(defcustom rcirc-log-process-buffers nil
+ "Non-nil if rcirc process buffers should be logged to disk."
+ :group 'rcirc
+ :type 'boolean
+ :version "24.1")
+
(defun rcirc-last-quit-line (process nick target)
"Return the line number where NICK left TARGET.
Returns nil if the information is not recorded."
@@ -1504,14 +1538,21 @@ record activity."
(when (not (rcirc-channel-p rcirc-target))
'nick)))
- (when rcirc-log-flag
+ (when (and rcirc-log-flag
+ (or target
+ rcirc-log-process-buffers))
(rcirc-log process sender response target text))
(sit-for 0) ; displayed text before hook
(run-hook-with-args 'rcirc-print-hooks
process sender response target text)))))
-(defcustom rcirc-log-filename-function 'rcirc-generate-new-buffer-name
+(defun rcirc-generate-log-filename (process target)
+ (if target
+ (rcirc-generate-new-buffer-name process target)
+ (process-name process)))
+
+(defcustom rcirc-log-filename-function 'rcirc-generate-log-filename
"A function to generate the filename used by rcirc's logging facility.
It is called with two arguments, PROCESS and TARGET (see
@@ -1648,6 +1689,31 @@ if NICK is also on `rcirc-ignore-list-automatic'."
rcirc-ignore-list
(delete nick rcirc-ignore-list))))
+(defun rcirc-nickname< (s1 s2)
+ "Return t if IRC nickname S1 is less than S2, and nil otherwise.
+Operator nicknames (@) are considered less than voiced
+nicknames (+). Any other nicknames are greater than voiced
+nicknames. The comparison is case-insensitive."
+ (setq s1 (downcase s1)
+ s2 (downcase s2))
+ (let* ((s1-op (eq ?@ (string-to-char s1)))
+ (s2-op (eq ?@ (string-to-char s2))))
+ (if s1-op
+ (if s2-op
+ (string< (substring s1 1) (substring s2 1))
+ t)
+ (if s2-op
+ nil
+ (string< s1 s2)))))
+
+(defun rcirc-sort-nicknames-join (input sep)
+ "Return a string of sorted nicknames.
+INPUT is a string containing nicknames separated by SEP.
+This function does not alter the INPUT string."
+ (let* ((parts (split-string input sep t))
+ (sorted (sort parts 'rcirc-nickname<)))
+ (mapconcat 'identity sorted sep)))
+
;;; activity tracking
(defvar rcirc-track-minor-mode-map (make-sparse-keymap)
"Keymap for rcirc track minor mode.")
@@ -1963,16 +2029,18 @@ activity. Only run if the buffer is not visible and
;; containing the text following the /cmd.
(defmacro defun-rcirc-command (command argument docstring interactive-form
- &rest body)
+ &rest body)
"Define a command."
- `(defun ,(intern (concat "rcirc-cmd-" (symbol-name command)))
- (,@argument &optional process target)
- ,(concat docstring "\n\nNote: If PROCESS or TARGET are nil, the values given"
- "\nby `rcirc-buffer-process' and `rcirc-target' will be used.")
- ,interactive-form
- (let ((process (or process (rcirc-buffer-process)))
- (target (or target rcirc-target)))
- ,@body)))
+ `(progn
+ (add-to-list 'rcirc-client-commands ,(concat "/" (symbol-name command)))
+ (defun ,(intern (concat "rcirc-cmd-" (symbol-name command)))
+ (,@argument &optional process target)
+ ,(concat docstring "\n\nNote: If PROCESS or TARGET are nil, the values given"
+ "\nby `rcirc-buffer-process' and `rcirc-target' will be used.")
+ ,interactive-form
+ (let ((process (or process (rcirc-buffer-process)))
+ (target (or target rcirc-target)))
+ ,@body))))
(defun-rcirc-command msg (message)
"Send private MESSAGE to TARGET."
@@ -2561,7 +2629,8 @@ keywords when no KEYWORD is given."
(buffer (rcirc-get-temp-buffer-create process channel)))
(with-current-buffer buffer
(rcirc-print process sender "NAMES" channel
- (buffer-substring (point-min) (point-max))))
+ (let ((content (buffer-substring (point-min) (point-max))))
+ (rcirc-sort-nicknames-join content " "))))
(kill-buffer buffer)))
(defun rcirc-handler-433 (process sender args text)
diff --git a/lisp/net/rcompile.el b/lisp/net/rcompile.el
index 88f4771d23f..3addcf73d74 100644
--- a/lisp/net/rcompile.el
+++ b/lisp/net/rcompile.el
@@ -1,7 +1,7 @@
;;; rcompile.el --- run a compilation on a remote machine
-;; Copyright (C) 1993, 1994, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1994, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Albert <alon@milcse.rtsg.mot.com>
;; Maintainer: FSF
@@ -75,7 +75,7 @@
(defcustom remote-compile-host nil
- "*Host for remote compilations."
+ "Host for remote compilations."
:type '(choice string (const nil))
:group 'remote-compile)
@@ -86,7 +86,7 @@ nil means use the value returned by \\[user-login-name]."
:group 'remote-compile)
(defcustom remote-compile-run-before nil
- "*Command to run before compilation.
+ "Command to run before compilation.
This can be used for setting up environment variables,
since rsh does not invoke the shell as a login shell and files like .login
\(tcsh\) and .bash_profile \(bash\) are not run.
@@ -95,12 +95,12 @@ nil means run no commands."
:group 'remote-compile)
(defcustom remote-compile-prompt-for-host nil
- "*Non-nil means prompt for host if not available from filename."
+ "Non-nil means prompt for host if not available from filename."
:type 'boolean
:group 'remote-compile)
(defcustom remote-compile-prompt-for-user nil
- "*Non-nil means prompt for user if not available from filename."
+ "Non-nil means prompt for user if not available from filename."
:type 'boolean
:group 'remote-compile)
diff --git a/lisp/net/rlogin.el b/lisp/net/rlogin.el
index 1406abecdcb..77f3296751a 100644
--- a/lisp/net/rlogin.el
+++ b/lisp/net/rlogin.el
@@ -1,7 +1,8 @@
;;; rlogin.el --- remote login interface
;; Copyright (C) 1992, 1993, 1994, 1995, 1997, 1998, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Noah Friedman
;; Maintainer: Noah Friedman <friedman@splode.com>
@@ -45,17 +46,17 @@
:group 'unix)
(defcustom rlogin-program "rlogin"
- "*Name of program to invoke rlogin"
+ "Name of program to invoke rlogin"
:type 'string
:group 'rlogin)
(defcustom rlogin-explicit-args nil
- "*List of arguments to pass to rlogin on the command line."
+ "List of arguments to pass to rlogin on the command line."
:type '(repeat (string :tag "Argument"))
:group 'rlogin)
(defcustom rlogin-mode-hook nil
- "*Hooks to run after setting current buffer to rlogin-mode."
+ "Hooks to run after setting current buffer to rlogin-mode."
:type 'hook
:group 'rlogin)
@@ -68,7 +69,7 @@
(string-match "-solaris2" system-configuration))
t)
(t nil)))
- "*If non-nil, use a pty for the local rlogin process.
+ "If non-nil, use a pty for the local rlogin process.
If nil, use a pipe (if pipes are supported on the local system).
Generally it is better not to waste ptys on systems which have a static
@@ -79,7 +80,7 @@ a pty is being used, and errors will result from using a pipe instead."
:group 'rlogin)
(defcustom rlogin-directory-tracking-mode 'local
- "*Control whether and how to do directory tracking in an rlogin buffer.
+ "Control whether and how to do directory tracking in an rlogin buffer.
nil means don't do directory tracking.
@@ -103,12 +104,12 @@ re-synching of directories."
(make-variable-buffer-local 'rlogin-directory-tracking-mode)
(defcustom rlogin-host nil
- "*The name of the remote host. This variable is buffer-local."
+ "The name of the remote host. This variable is buffer-local."
:type '(choice (const nil) string)
:group 'rlogin)
(defcustom rlogin-remote-user nil
- "*The username used on the remote host.
+ "The username used on the remote host.
This variable is buffer-local and defaults to your local user name.
If rlogin is invoked with the `-l' option to specify the remote username,
this variable is set from that."
@@ -249,7 +250,7 @@ If called with a positive, numeric prefix argument, e.g.
``\\[universal-argument] 1 M-x rlogin-directory-tracking-mode\'',
then do directory tracking but assume the remote filesystem is the same as
the local system. This only works in general if the remote machine and the
-local one share the same directories (through NFS)."
+local one share the same directories (e.g. through NFS)."
(interactive "P")
(cond
((or (null prefix)
diff --git a/lisp/net/sasl-cram.el b/lisp/net/sasl-cram.el
index 9faeded5c3b..38d7ff4e11d 100644
--- a/lisp/net/sasl-cram.el
+++ b/lisp/net/sasl-cram.el
@@ -5,6 +5,7 @@
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Kenichi OKADA <okada@opaopa.org>
;; Keywords: SASL, CRAM-MD5
+;; Package: sasl
;; This file is part of GNU Emacs.
@@ -46,5 +47,4 @@
(provide 'sasl-cram)
-;; arch-tag: 46cb281b-975a-4fe0-a39f-3018691b1b05
;;; sasl-cram.el ends here
diff --git a/lisp/net/sasl-digest.el b/lisp/net/sasl-digest.el
index 4d839296c9f..8559c8f3fa9 100644
--- a/lisp/net/sasl-digest.el
+++ b/lisp/net/sasl-digest.el
@@ -5,6 +5,7 @@
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Kenichi OKADA <okada@opaopa.org>
;; Keywords: SASL, DIGEST-MD5
+;; Package: sasl
;; This file is part of GNU Emacs.
@@ -94,10 +95,10 @@ charset algorithm cipher-opts auth-param)."
(md5-binary
(concat
(encode-hex-string
- (md5-binary (concat (md5-binary
+ (md5-binary (concat (md5-binary
(concat username ":" realm ":" passphrase))
":" nonce ":" cnonce
- (if authzid
+ (if authzid
(concat ":" authzid)))))
":" nonce
":" (format "%08x" nonce-count) ":" cnonce ":" qop ":"
@@ -153,5 +154,4 @@ charset algorithm cipher-opts auth-param)."
(provide 'sasl-digest)
-;; arch-tag: 786e02ed-1bc4-4b3c-bf34-96c27e31084d
;;; sasl-digest.el ends here
diff --git a/lisp/net/sasl-ntlm.el b/lisp/net/sasl-ntlm.el
index 94366f1a52a..ace50528acb 100644
--- a/lisp/net/sasl-ntlm.el
+++ b/lisp/net/sasl-ntlm.el
@@ -6,6 +6,7 @@
;; Keywords: SASL, NTLM
;; Version: 1.00
;; Created: February 2001
+;; Package: sasl
;; This file is part of GNU Emacs.
@@ -62,5 +63,4 @@ challenge stored in the 2nd element of STEP. Called from `sasl-next-step'."
(provide 'sasl-ntlm)
-;; arch-tag: 1d9164c1-1df0-418f-b7ab-360157fd05dc
;;; sasl-ntlm.el ends here
diff --git a/lisp/net/sasl.el b/lisp/net/sasl.el
index c2a3f10e3d0..7f864390a52 100644
--- a/lisp/net/sasl.el
+++ b/lisp/net/sasl.el
@@ -267,5 +267,4 @@ It contain at least 64 bits of entropy."
(provide 'sasl)
-;; arch-tag: 8b3326fa-4978-4fda-93e2-cb2c6255f887
;;; sasl.el ends here
diff --git a/lisp/net/secrets.el b/lisp/net/secrets.el
new file mode 100644
index 00000000000..4487407971f
--- /dev/null
+++ b/lisp/net/secrets.el
@@ -0,0 +1,862 @@
+;;; secrets.el --- Client interface to gnome-keyring and kwallet.
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Michael Albinus <michael.albinus@gmx.de>
+;; Keywords: comm password passphrase
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package provides an implementation of the Secret Service API
+;; <http://www.freedesktop.org/wiki/Specifications/secret-storage-spec>.
+;; This API is meant to make GNOME-Keyring- and KWallet-like daemons
+;; available under a common D-BUS interface and thus increase
+;; interoperability between GNOME, KDE and other applications having
+;; the need to securely store passwords and other confidential
+;; information.
+
+;; In order to activate this package, you must add the following code
+;; into your .emacs:
+;;
+;; (require 'secrets)
+;;
+;; Afterwards, the variable `secrets-enabled' is non-nil when there is
+;; a daemon providing this interface.
+
+;; The atomic objects to be managed by the Secret Service API are
+;; secret items, which are something an application wishes to store
+;; securely. A good example is a password that an application needs
+;; to save and use at a later date.
+
+;; Secret items are grouped in collections. A collection is similar
+;; in concept to the terms 'keyring' or 'wallet'. A common collection
+;; is called "login". A collection is stored permanently under the
+;; user's permissions, and can be accessed in a user session context.
+
+;; A collection can have an alias name. The use case for this is to
+;; set the alias "default" for a given collection, making it
+;; transparent for clients, which collection is used. Other aliases
+;; are not supported (yet). Since an alias is visible to all
+;; applications, this setting shall be performed with care.
+
+;; A list of all available collections is available by
+;;
+;; (secrets-list-collections)
+;; => ("session" "login" "ssh keys")
+
+;; The "default" alias could be set to the "login" collection by
+;;
+;; (secrets-set-alias "login" "default")
+
+;; An alias can also be dereferenced
+;;
+;; (secrets-get-alias "default")
+;; => "login"
+
+;; Collections can be created and deleted. As already said,
+;; collections are used by different applications. Therefore, those
+;; operations shall also be performed with care. Common collections,
+;; like "login", shall not be changed except adding or deleting secret
+;; items.
+;;
+;; (secrets-delete-collection "my collection")
+;; (secrets-create-collection "my collection")
+
+;; There exists a special collection called "session", which has the
+;; lifetime of the corrresponding client session (aka Emacs'
+;; lifetime). It is created automatically when Emacs uses the Secret
+;; Service interface, and it is deleted when Emacs is killed.
+;; Therefore, it can be used to store and retrieve secret items
+;; temporarily. This shall be preferred over creation of a persistent
+;; collection, when the information shall not live longer than Emacs.
+;; The session collection can be addressed either by the string
+;; "session", or by `nil', whenever a collection parameter is needed.
+
+;; As already said, a collection is a group of secret items. A secret
+;; item has a label, the "secret" (which is a string), and a set of
+;; lookup attributes. The attributes can be used to search and
+;; retrieve a secret item at a later date.
+
+;; A list of all available secret items of a collection is available by
+;;
+;; (secrets-list-items "my collection")
+;; => ("this item" "another item")
+
+;; Secret items can be added or deleted to a collection. In the
+;; following examples, we use the special collection "session", which
+;; is bound to Emacs' lifetime.
+;;
+;; (secrets-delete-item "session" "my item")
+;; (secrets-create-item "session" "my item" "geheim"
+;; :user "joe" :host "remote-host")
+
+;; The string "geheim" is the secret of the secret item "my item".
+;; The secret string can be retrieved from items:
+;;
+;; (secrets-get-secret "session" "my item")
+;; => "geheim"
+
+;; The lookup attributes, which are specified during creation of a
+;; secret item, must be a key-value pair. Keys are keyword symbols,
+;; starting with a colon; values are strings. They can be retrieved
+;; from a given secret item:
+;;
+;; (secrets-get-attribute "session" "my item" :host)
+;; => "remote-host"
+;;
+;; (secrets-get-attributes "session" "my item")
+;; => ((:user . "joe") (:host ."remote-host"))
+
+;; The lookup attributes can be used for searching of items. If you,
+;; for example, are looking for all secret items for the user "joe",
+;; you would perform
+;;
+;; (secrets-search-items "session" :user "joe")
+;; => ("my item" "another item")
+
+;; Interactively, collections, items and their attributes could be
+;; inspected by the command `secrets-show-secrets'.
+
+;;; Code:
+
+;; It has been tested with GNOME Keyring 2.29.92. An implementation
+;; for KWallet will be available at
+;; svn://anonsvn.kde.org/home/kde/trunk/playground/base/ksecretservice;
+;; not tested yet.
+
+;; Pacify byte-compiler. D-Bus support in the Emacs core can be
+;; disabled with configuration option "--without-dbus". Declare used
+;; subroutines and variables of `dbus' therefore.
+(eval-when-compile
+ (require 'cl))
+
+(declare-function dbus-call-method "dbusbind.c")
+(declare-function dbus-register-signal "dbusbind.c")
+(defvar dbus-debug)
+
+(require 'dbus)
+
+(autoload 'tree-widget-set-theme "tree-widget")
+(autoload 'widget-create-child-and-convert "wid-edit")
+(autoload 'widget-default-value-set "wid-edit")
+(autoload 'widget-field-end "wid-edit")
+(autoload 'widget-member "wid-edit")
+(defvar tree-widget-after-toggle-functions)
+
+(defvar secrets-enabled nil
+ "Whether there is a daemon offering the Secret Service API.")
+
+(defvar secrets-debug t
+ "Write debug messages")
+
+(defconst secrets-service "org.freedesktop.secrets"
+ "The D-Bus name used to talk to Secret Service.")
+
+(defconst secrets-path "/org/freedesktop/secrets"
+ "The D-Bus root object path used to talk to Secret Service.")
+
+(defconst secrets-empty-path "/"
+ "The D-Bus object path representing an empty object.")
+
+(defsubst secrets-empty-path (path)
+ "Check, whether PATH is a valid object path.
+It returns t if not."
+ (or (not (stringp path))
+ (string-equal path secrets-empty-path)))
+
+(defconst secrets-interface-service "org.freedesktop.Secret.Service"
+ "The D-Bus interface managing sessions and collections.")
+
+;; <interface name="org.freedesktop.Secret.Service">
+;; <property name="Collections" type="ao" access="read"/>
+;; <method name="OpenSession">
+;; <arg name="algorithm" type="s" direction="in"/>
+;; <arg name="input" type="v" direction="in"/>
+;; <arg name="output" type="v" direction="out"/>
+;; <arg name="result" type="o" direction="out"/>
+;; </method>
+;; <method name="CreateCollection">
+;; <arg name="props" type="a{sv}" direction="in"/>
+;; <arg name="collection" type="o" direction="out"/>
+;; <arg name="prompt" type="o" direction="out"/>
+;; </method>
+;; <method name="SearchItems">
+;; <arg name="attributes" type="a{ss}" direction="in"/>
+;; <arg name="unlocked" type="ao" direction="out"/>
+;; <arg name="locked" type="ao" direction="out"/>
+;; </method>
+;; <method name="Unlock">
+;; <arg name="objects" type="ao" direction="in"/>
+;; <arg name="unlocked" type="ao" direction="out"/>
+;; <arg name="prompt" type="o" direction="out"/>
+;; </method>
+;; <method name="Lock">
+;; <arg name="objects" type="ao" direction="in"/>
+;; <arg name="locked" type="ao" direction="out"/>
+;; <arg name="Prompt" type="o" direction="out"/>
+;; </method>
+;; <method name="GetSecrets">
+;; <arg name="items" type="ao" direction="in"/>
+;; <arg name="session" type="o" direction="in"/>
+;; <arg name="secrets" type="a{o(oayay)}" direction="out"/>
+;; </method>
+;; <method name="ReadAlias">
+;; <arg name="name" type="s" direction="in"/>
+;; <arg name="collection" type="o" direction="out"/>
+;; </method>
+;; <method name="SetAlias">
+;; <arg name="name" type="s" direction="in"/>
+;; <arg name="collection" type="o" direction="in"/>
+;; </method>
+;; <signal name="CollectionCreated">
+;; <arg name="collection" type="o"/>
+;; </signal>
+;; <signal name="CollectionDeleted">
+;; <arg name="collection" type="o"/>
+;; </signal>
+;; </interface>
+
+(defconst secrets-interface-collection "org.freedesktop.Secret.Collection"
+ "A collection of items containing secrets.")
+
+;; <interface name="org.freedesktop.Secret.Collection">
+;; <property name="Items" type="ao" access="read"/>
+;; <property name="Label" type="s" access="readwrite"/>
+;; <property name="Locked" type="s" access="read"/>
+;; <property name="Created" type="t" access="read"/>
+;; <property name="Modified" type="t" access="read"/>
+;; <method name="Delete">
+;; <arg name="prompt" type="o" direction="out"/>
+;; </method>
+;; <method name="SearchItems">
+;; <arg name="attributes" type="a{ss}" direction="in"/>
+;; <arg name="results" type="ao" direction="out"/>
+;; </method>
+;; <method name="CreateItem">
+;; <arg name="props" type="a{sv}" direction="in"/>
+;; <arg name="secret" type="(oayay)" direction="in"/>
+;; <arg name="replace" type="b" direction="in"/>
+;; <arg name="item" type="o" direction="out"/>
+;; <arg name="prompt" type="o" direction="out"/>
+;; </method>
+;; <signal name="ItemCreated">
+;; <arg name="item" type="o"/>
+;; </signal>
+;; <signal name="ItemDeleted">
+;; <arg name="item" type="o"/>
+;; </signal>
+;; <signal name="ItemChanged">
+;; <arg name="item" type="o"/>
+;; </signal>
+;; </interface>
+
+(defconst secrets-session-collection-path
+ "/org/freedesktop/secrets/collection/session"
+ "The D-Bus temporary session collection object path.")
+
+(defconst secrets-interface-prompt "org.freedesktop.Secret.Prompt"
+ "A session tracks state between the service and a client application.")
+
+;; <interface name="org.freedesktop.Secret.Prompt">
+;; <method name="Prompt">
+;; <arg name="window-id" type="s" direction="in"/>
+;; </method>
+;; <method name="Dismiss"></method>
+;; <signal name="Completed">
+;; <arg name="dismissed" type="b"/>
+;; <arg name="result" type="v"/>
+;; </signal>
+;; </interface>
+
+(defconst secrets-interface-item "org.freedesktop.Secret.Item"
+ "A collection of items containing secrets.")
+
+;; <interface name="org.freedesktop.Secret.Item">
+;; <property name="Locked" type="b" access="read"/>
+;; <property name="Attributes" type="a{ss}" access="readwrite"/>
+;; <property name="Label" type="s" access="readwrite"/>
+;; <property name="Created" type="t" access="read"/>
+;; <property name="Modified" type="t" access="read"/>
+;; <method name="Delete">
+;; <arg name="prompt" type="o" direction="out"/>
+;; </method>
+;; <method name="GetSecret">
+;; <arg name="session" type="o" direction="in"/>
+;; <arg name="secret" type="(oayay)" direction="out"/>
+;; </method>
+;; <method name="SetSecret">
+;; <arg name="secret" type="(oayay)" direction="in"/>
+;; </method>
+;; </interface>
+;;
+;; STRUCT secret
+;; OBJECT PATH session
+;; ARRAY BYTE parameters
+;; ARRAY BYTE value
+
+(defconst secrets-interface-item-type-generic "org.freedesktop.Secret.Generic"
+ "The default item type we are using.")
+
+(defconst secrets-interface-session "org.freedesktop.Secret.Session"
+ "A session tracks state between the service and a client application.")
+
+;; <interface name="org.freedesktop.Secret.Session">
+;; <method name="Close"></method>
+;; </interface>
+
+;;; Sessions.
+
+(defvar secrets-session-path secrets-empty-path
+ "The D-Bus session path of the active session.
+A session path `secrets-empty-path' indicates there is no open session.")
+
+(defun secrets-close-session ()
+ "Close the secret service session, if any."
+ (dbus-ignore-errors
+ (dbus-call-method
+ :session secrets-service secrets-session-path
+ secrets-interface-session "Close"))
+ (setq secrets-session-path secrets-empty-path))
+
+(defun secrets-open-session (&optional reopen)
+ "Open a new session with \"plain\" algorithm.
+If there exists another active session, and REOPEN is nil, that
+session will be used. The object path of the session will be
+returned, and it will be stored in `secrets-session-path'."
+ (when reopen (secrets-close-session))
+ (when (secrets-empty-path secrets-session-path)
+ (setq secrets-session-path
+ (cadr
+ (dbus-call-method
+ :session secrets-service secrets-path
+ secrets-interface-service "OpenSession" "plain" '(:variant "")))))
+ (when secrets-debug
+ (message "Secret Service session: %s" secrets-session-path))
+ secrets-session-path)
+
+;;; Prompts.
+
+(defvar secrets-prompt-signal nil
+ "Internal variable to catch signals from `secrets-interface-prompt'.")
+
+(defun secrets-prompt (prompt)
+ "Handle the prompt identified by object path PROMPT."
+ (unless (secrets-empty-path prompt)
+ (let ((object
+ (dbus-register-signal
+ :session secrets-service prompt
+ secrets-interface-prompt "Completed" 'secrets-prompt-handler)))
+ (dbus-call-method
+ :session secrets-service prompt
+ secrets-interface-prompt "Prompt" (frame-parameter nil 'window-id))
+ (unwind-protect
+ (progn
+ ;; Wait until the returned prompt signal has put the
+ ;; result into `secrets-prompt-signal'.
+ (while (null secrets-prompt-signal)
+ (read-event nil nil 0.1))
+ ;; Return the object(s). It is a variant, so we must use a car.
+ (car secrets-prompt-signal))
+ ;; Cleanup.
+ (setq secrets-prompt-signal nil)
+ (dbus-unregister-object object)))))
+
+(defun secrets-prompt-handler (&rest args)
+ "Handler for signals emitted by `secrets-interface-prompt'."
+ ;; An empty object path is always identified as `secrets-empty-path'
+ ;; or `nil'. Either we set it explicitely, or it is returned by the
+ ;; "Completed" signal.
+ (if (car args) ;; dismissed
+ (setq secrets-prompt-signal (list secrets-empty-path))
+ (setq secrets-prompt-signal (cadr args))))
+
+;;; Collections.
+
+(defvar secrets-collection-paths nil
+ "Cached D-Bus object paths of available collections.")
+
+(defun secrets-collection-handler (&rest args)
+ "Handler for signals emitted by `secrets-interface-service'."
+ (cond
+ ((string-equal (dbus-event-member-name last-input-event) "CollectionCreated")
+ (add-to-list 'secrets-collection-paths (car args)))
+ ((string-equal (dbus-event-member-name last-input-event) "CollectionDeleted")
+ (setq secrets-collection-paths
+ (delete (car args) secrets-collection-paths)))))
+
+(defun secrets-get-collections ()
+ "Return the object paths of all available collections."
+ (setq secrets-collection-paths
+ (or secrets-collection-paths
+ (dbus-get-property
+ :session secrets-service secrets-path
+ secrets-interface-service "Collections"))))
+
+(defun secrets-get-collection-properties (collection-path)
+ "Return all properties of collection identified by COLLECTION-PATH."
+ (unless (secrets-empty-path collection-path)
+ (dbus-get-all-properties
+ :session secrets-service collection-path
+ secrets-interface-collection)))
+
+(defun secrets-get-collection-property (collection-path property)
+ "Return property PROPERTY of collection identified by COLLECTION-PATH."
+ (unless (or (secrets-empty-path collection-path) (not (stringp property)))
+ (dbus-get-property
+ :session secrets-service collection-path
+ secrets-interface-collection property)))
+
+(defun secrets-list-collections ()
+ "Return a list of collection names."
+ (mapcar
+ (lambda (collection-path)
+ (if (string-equal collection-path secrets-session-collection-path)
+ "session"
+ (secrets-get-collection-property collection-path "Label")))
+ (secrets-get-collections)))
+
+(defun secrets-collection-path (collection)
+ "Return the object path of collection labelled COLLECTION.
+If COLLECTION is nil, return the session collection path.
+If there is no such COLLECTION, return nil."
+ (or
+ ;; The "session" collection.
+ (if (or (null collection) (string-equal "session" collection))
+ secrets-session-collection-path)
+ ;; Check for an alias.
+ (let ((collection-path
+ (dbus-call-method
+ :session secrets-service secrets-path
+ secrets-interface-service "ReadAlias" collection)))
+ (unless (secrets-empty-path collection-path)
+ collection-path))
+ ;; Check the collections.
+ (catch 'collection-found
+ (dolist (collection-path (secrets-get-collections) nil)
+ (when
+ (string-equal
+ collection
+ (secrets-get-collection-property collection-path "Label"))
+ (throw 'collection-found collection-path))))))
+
+(defun secrets-create-collection (collection)
+ "Create collection labelled COLLECTION if it doesn't exist.
+Return the D-Bus object path for collection."
+ (let ((collection-path (secrets-collection-path collection)))
+ ;; Create the collection.
+ (when (secrets-empty-path collection-path)
+ (setq collection-path
+ (secrets-prompt
+ (cadr
+ ;; "CreateCollection" returns the prompt path as second arg.
+ (dbus-call-method
+ :session secrets-service secrets-path
+ secrets-interface-service "CreateCollection"
+ `(:array (:dict-entry "Label" (:variant ,collection))))))))
+ ;; Return object path of the collection.
+ collection-path))
+
+(defun secrets-get-alias (alias)
+ "Return the collection name ALIAS is referencing to.
+For the time being, only the alias \"default\" is supported."
+ (secrets-get-collection-property
+ (dbus-call-method
+ :session secrets-service secrets-path
+ secrets-interface-service "ReadAlias" alias)
+ "Label"))
+
+(defun secrets-set-alias (collection alias)
+ "Set ALIAS as alias of collection labelled COLLECTION.
+For the time being, only the alias \"default\" is supported."
+ (let ((collection-path (secrets-collection-path collection)))
+ (unless (secrets-empty-path collection-path)
+ (dbus-call-method
+ :session secrets-service secrets-path
+ secrets-interface-service "SetAlias"
+ alias :object-path collection-path))))
+
+(defun secrets-unlock-collection (collection)
+ "Unlock collection labelled COLLECTION.
+If successful, return the object path of the collection."
+ (let ((collection-path (secrets-collection-path collection)))
+ (unless (secrets-empty-path collection-path)
+ (secrets-prompt
+ (cadr
+ (dbus-call-method
+ :session secrets-service secrets-path secrets-interface-service
+ "Unlock" `(:array :object-path ,collection-path)))))
+ collection-path))
+
+(defun secrets-delete-collection (collection)
+ "Delete collection labelled COLLECTION."
+ (let ((collection-path (secrets-collection-path collection)))
+ (unless (secrets-empty-path collection-path)
+ (secrets-prompt
+ (dbus-call-method
+ :session secrets-service collection-path
+ secrets-interface-collection "Delete")))))
+
+;;; Items.
+
+(defun secrets-get-items (collection-path)
+ "Return the object paths of all available items in COLLECTION-PATH."
+ (unless (secrets-empty-path collection-path)
+ (secrets-open-session)
+ (dbus-get-property
+ :session secrets-service collection-path
+ secrets-interface-collection "Items")))
+
+(defun secrets-get-item-properties (item-path)
+ "Return all properties of item identified by ITEM-PATH."
+ (unless (secrets-empty-path item-path)
+ (dbus-get-all-properties
+ :session secrets-service item-path
+ secrets-interface-item)))
+
+(defun secrets-get-item-property (item-path property)
+ "Return property PROPERTY of item identified by ITEM-PATH."
+ (unless (or (secrets-empty-path item-path) (not (stringp property)))
+ (dbus-get-property
+ :session secrets-service item-path
+ secrets-interface-item property)))
+
+(defun secrets-list-items (collection)
+ "Return a list of all item labels of COLLECTION."
+ (let ((collection-path (secrets-unlock-collection collection)))
+ (unless (secrets-empty-path collection-path)
+ (mapcar
+ (lambda (item-path)
+ (secrets-get-item-property item-path "Label"))
+ (secrets-get-items collection-path)))))
+
+(defun secrets-search-items (collection &rest attributes)
+ "Search items in COLLECTION with ATTRIBUTES.
+ATTRIBUTES are key-value pairs. The keys are keyword symbols,
+starting with a colon. Example:
+
+ \(secrets-create-item \"Tramp collection\" \"item\" \"geheim\"
+ :method \"sudo\" :user \"joe\" :host \"remote-host\"\)
+
+The object paths of the found items are returned as list."
+ (let ((collection-path (secrets-unlock-collection collection))
+ result props)
+ (unless (secrets-empty-path collection-path)
+ ;; Create attributes list.
+ (while (consp (cdr attributes))
+ (unless (keywordp (car attributes))
+ (error 'wrong-type-argument (car attributes)))
+ (setq props (add-to-list
+ 'props
+ (list :dict-entry
+ (substring (symbol-name (car attributes)) 1)
+ (cadr attributes))
+ 'append)
+ attributes (cddr attributes)))
+ ;; Search. The result is a list of two lists, the object paths
+ ;; of the unlocked and the locked items.
+ (setq result
+ (dbus-call-method
+ :session secrets-service collection-path
+ secrets-interface-collection "SearchItems"
+ (if props
+ (cons :array props)
+ '(:array :signature "{ss}"))))
+ ;; Return the found items.
+ (mapcar
+ (lambda (item-path) (secrets-get-item-property item-path "Label"))
+ (append (car result) (cadr result))))))
+
+(defun secrets-create-item (collection item password &rest attributes)
+ "Create a new item in COLLECTION with label ITEM and password PASSWORD.
+ATTRIBUTES are key-value pairs set for the created item. The
+keys are keyword symbols, starting with a colon. Example:
+
+ \(secrets-create-item \"Tramp collection\" \"item\" \"geheim\"
+ :method \"sudo\" :user \"joe\" :host \"remote-host\"\)
+
+The object path of the created item is returned."
+ (unless (member item (secrets-list-items collection))
+ (let ((collection-path (secrets-unlock-collection collection))
+ result props)
+ (unless (secrets-empty-path collection-path)
+ ;; Create attributes list.
+ (while (consp (cdr attributes))
+ (unless (keywordp (car attributes))
+ (error 'wrong-type-argument (car attributes)))
+ (setq props (add-to-list
+ 'props
+ (list :dict-entry
+ (substring (symbol-name (car attributes)) 1)
+ (cadr attributes))
+ 'append)
+ attributes (cddr attributes)))
+ ;; Create the item.
+ (setq result
+ (dbus-call-method
+ :session secrets-service collection-path
+ secrets-interface-collection "CreateItem"
+ ;; Properties.
+ (append
+ `(:array
+ (:dict-entry "Label" (:variant ,item))
+ (:dict-entry
+ "Type" (:variant ,secrets-interface-item-type-generic)))
+ (when props
+ `((:dict-entry
+ "Attributes" (:variant ,(append '(:array) props))))))
+ ;; Secret.
+ `(:struct :object-path ,secrets-session-path
+ (:array :signature "y") ;; no parameters.
+ ,(dbus-string-to-byte-array password))
+ ;; Do not replace. Replace does not seem to work.
+ nil))
+ (secrets-prompt (cadr result))
+ ;; Return the object path.
+ (car result)))))
+
+(defun secrets-item-path (collection item)
+ "Return the object path of item labelled ITEM in COLLECTION.
+If there is no such item, return nil."
+ (let ((collection-path (secrets-unlock-collection collection)))
+ (catch 'item-found
+ (dolist (item-path (secrets-get-items collection-path))
+ (when (string-equal item (secrets-get-item-property item-path "Label"))
+ (throw 'item-found item-path))))))
+
+(defun secrets-get-secret (collection item)
+ "Return the secret of item labelled ITEM in COLLECTION.
+If there is no such item, return nil."
+ (let ((item-path (secrets-item-path collection item)))
+ (unless (secrets-empty-path item-path)
+ (dbus-byte-array-to-string
+ (caddr
+ (dbus-call-method
+ :session secrets-service item-path secrets-interface-item
+ "GetSecret" :object-path secrets-session-path))))))
+
+(defun secrets-get-attributes (collection item)
+ "Return the lookup attributes of item labelled ITEM in COLLECTION.
+If there is no such item, or the item has no attributes, return nil."
+ (unless (stringp collection) (setq collection "default"))
+ (let ((item-path (secrets-item-path collection item)))
+ (unless (secrets-empty-path item-path)
+ (mapcar
+ (lambda (attribute)
+ (cons (intern (concat ":" (car attribute))) (cadr attribute)))
+ (dbus-get-property
+ :session secrets-service item-path
+ secrets-interface-item "Attributes")))))
+
+(defun secrets-get-attribute (collection item attribute)
+ "Return the value of ATTRIBUTE of item labelled ITEM in COLLECTION.
+If there is no such item, or the item doesn't own this attribute, return nil."
+ (cdr (assoc attribute (secrets-get-attributes collection item))))
+
+(defun secrets-delete-item (collection item)
+ "Delete ITEM in COLLECTION."
+ (let ((item-path (secrets-item-path collection item)))
+ (unless (secrets-empty-path item-path)
+ (secrets-prompt
+ (dbus-call-method
+ :session secrets-service item-path
+ secrets-interface-item "Delete")))))
+
+;;; Visualization.
+
+(define-derived-mode secrets-mode nil "Secrets"
+ "Major mode for presenting password entries retrieved by Security Service.
+In this mode, widgets represent the search results.
+
+\\{secrets-mode-map}"
+ ;; Keymap.
+ (setq secrets-mode-map (copy-keymap special-mode-map))
+ (set-keymap-parent secrets-mode-map widget-keymap)
+ (define-key secrets-mode-map "z" 'kill-this-buffer)
+
+ ;; When we toggle, we must set temporary widgets.
+ (set (make-local-variable 'tree-widget-after-toggle-functions)
+ '(secrets-tree-widget-after-toggle-function))
+
+ (when (not (called-interactively-p 'interactive))
+ ;; Initialize buffer.
+ (setq buffer-read-only t)
+ (let ((inhibit-read-only t))
+ (erase-buffer))))
+
+;; It doesn't make sense to call it interactively.
+(put 'secrets-mode 'disabled t)
+
+;; The very first buffer created with `secrets-mode' does not have the
+;; keymap etc. So we create a dummy buffer. Stupid.
+(with-temp-buffer (secrets-mode))
+
+;; We autoload `secrets-show-secrets' only on systems with D-Bus support.
+;;;###autoload(when (featurep 'dbusbind)
+;;;###autoload (autoload 'secrets-show-secrets "secrets" nil t))
+
+(defun secrets-show-secrets ()
+ "Display a list of collections from the Secret Service API.
+The collections are in tree view, that means they can be expanded
+to the corresponding secret items, which could also be expanded
+to their attributes."
+ (interactive)
+
+ ;; Check, whether the Secret Service API is enabled.
+ (if (null secrets-enabled)
+ (message "Secret Service not available")
+
+ ;; Create the search buffer.
+ (with-current-buffer (get-buffer-create "*Secrets*")
+ (switch-to-buffer-other-window (current-buffer))
+ ;; Inialize buffer with `secrets-mode'.
+ (secrets-mode)
+ (secrets-show-collections))))
+
+(defun secrets-show-collections ()
+ "Show all available collections."
+ (let ((inhibit-read-only t)
+ (alias (secrets-get-alias "default")))
+ (erase-buffer)
+ (tree-widget-set-theme "folder")
+ (dolist (coll (secrets-list-collections))
+ (widget-create
+ `(tree-widget
+ :tag ,coll
+ :collection ,coll
+ :open nil
+ :sample-face bold
+ :expander secrets-expand-collection)))))
+
+(defun secrets-expand-collection (widget)
+ "Expand items of collection shown as WIDGET."
+ (let ((coll (widget-get widget :collection)))
+ (mapcar
+ (lambda (item)
+ `(tree-widget
+ :tag ,item
+ :collection ,coll
+ :item ,item
+ :open nil
+ :sample-face bold
+ :expander secrets-expand-item))
+ (secrets-list-items coll))))
+
+(defun secrets-expand-item (widget)
+ "Expand password and attributes of item shown as WIDGET."
+ (let* ((coll (widget-get widget :collection))
+ (item (widget-get widget :item))
+ (attributes (secrets-get-attributes coll item))
+ ;; padding is needed to format attribute names.
+ (padding
+ (apply
+ 'max
+ (cons
+ (1+ (length "password"))
+ (mapcar
+ ;; Atribute names have a leading ":", which will be suppressed.
+ (lambda (attribute) (length (symbol-name (car attribute))))
+ attributes)))))
+ (cons
+ ;; The password widget.
+ `(editable-field :tag "password"
+ :secret ?*
+ :value ,(secrets-get-secret coll item)
+ :sample-face widget-button-pressed
+ ;; We specify :size in order to limit the field.
+ :size 0
+ :format ,(concat
+ "%{%t%}:"
+ (make-string (- padding (length "password")) ? )
+ "%v\n"))
+ (mapcar
+ (lambda (attribute)
+ (let ((name (substring (symbol-name (car attribute)) 1))
+ (value (cdr attribute)))
+ ;; The attribute widget.
+ `(editable-field :tag ,name
+ :value ,value
+ :sample-face widget-documentation
+ ;; We specify :size in order to limit the field.
+ :size 0
+ :format ,(concat
+ "%{%t%}:"
+ (make-string (- padding (length name)) ? )
+ "%v\n"))))
+ attributes))))
+
+(defun secrets-tree-widget-after-toggle-function (widget &rest ignore)
+ "Add a temporary widget to show the password."
+ (dolist (child (widget-get widget :children))
+ (when (widget-member child :secret)
+ (goto-char (widget-field-end child))
+ (widget-insert " ")
+ (widget-create-child-and-convert
+ child 'push-button
+ :notify 'secrets-tree-widget-show-password
+ "Show password")))
+ (widget-setup))
+
+(defun secrets-tree-widget-show-password (widget &rest ignore)
+ "Show password, and remove temporary widget."
+ (let ((parent (widget-get widget :parent)))
+ (widget-put parent :secret nil)
+ (widget-default-value-set parent (widget-get parent :value))
+ (widget-setup)))
+
+;;; Initialization.
+
+(when (dbus-ping :session secrets-service 100)
+
+ ;; We must reset all variables, when there is a new instance of the
+ ;; "org.freedesktop.secrets" service.
+ (dbus-register-signal
+ :session dbus-service-dbus dbus-path-dbus
+ dbus-interface-dbus "NameOwnerChanged"
+ (lambda (&rest args)
+ (when secrets-debug (message "Secret Service has changed: %S" args))
+ (setq secrets-session-path secrets-empty-path
+ secrets-prompt-signal nil
+ secrets-collection-paths nil))
+ secrets-service)
+
+ ;; We want to refresh our cache, when there is a change in
+ ;; collections.
+ (dbus-register-signal
+ :session secrets-service secrets-path
+ secrets-interface-service "CollectionCreated"
+ 'secrets-collection-handler)
+
+ (dbus-register-signal
+ :session secrets-service secrets-path
+ secrets-interface-service "CollectionDeleted"
+ 'secrets-collection-handler)
+
+ ;; We shall inform, whether the secret service is enabled on this
+ ;; machine.
+ (setq secrets-enabled t))
+
+(provide 'secrets)
+
+;;; TODO:
+
+;; * secrets-debug should be structured like auth-source-debug to
+;; prevent leaking sensitive information. Right now I don't see
+;; anything sensitive though.
+;; * Check, whether the dh-ietf1024-aes128-cbc-pkcs7 algorithm can be
+;; used for the transfer of the secrets. Currently, we use the
+;; plain algorithm.
diff --git a/lisp/net/telnet.el b/lisp/net/telnet.el
index 2c408f64264..25bf7db7612 100644
--- a/lisp/net/telnet.el
+++ b/lisp/net/telnet.el
@@ -61,7 +61,15 @@ PROGRAM says which program to run, to talk to that machine.
LOGIN-NAME, which is optional, says what to log in as on that machine.")
(defvar telnet-new-line "\r")
-(defvar telnet-mode-map nil)
+(defvar telnet-mode-map
+ (let ((map (nconc (make-sparse-keymap) comint-mode-map)))
+ (define-key map "\C-m" 'telnet-send-input)
+ ;; (define-key map "\C-j" 'telnet-send-input)
+ (define-key map "\C-c\C-q" 'send-process-next-char)
+ (define-key map "\C-c\C-c" 'telnet-interrupt-subjob)
+ (define-key map "\C-c\C-z" 'telnet-c-z)
+ map))
+
(defvar telnet-prompt-pattern "^[^#$%>\n]*[#$%>] *")
(defvar telnet-replace-c-g nil)
(make-variable-buffer-local
@@ -104,16 +112,6 @@ rejecting one login and prompting again for a username and password.")
(prog1 (read-char)
(setq quit-flag nil))))))
-; initialization on first load.
-(if telnet-mode-map
- nil
- (setq telnet-mode-map (nconc (make-sparse-keymap) comint-mode-map))
- (define-key telnet-mode-map "\C-m" 'telnet-send-input)
-; (define-key telnet-mode-map "\C-j" 'telnet-send-input)
- (define-key telnet-mode-map "\C-c\C-q" 'send-process-next-char)
- (define-key telnet-mode-map "\C-c\C-c" 'telnet-interrupt-subjob)
- (define-key telnet-mode-map "\C-c\C-z" 'telnet-c-z))
-
;;maybe should have a flag for when have found type
(defun telnet-check-software-type-initialize (string)
"Tries to put correct initializations in. Needs work."
diff --git a/lisp/net/tls.el b/lisp/net/tls.el
index 9a1b0bb6610..0ab4293f0d6 100644
--- a/lisp/net/tls.el
+++ b/lisp/net/tls.el
@@ -75,8 +75,8 @@ and `gnutls-cli' (version 2.0.1) output."
:type 'regexp
:group 'tls)
-(defcustom tls-program '("gnutls-cli -p %p %h"
- "gnutls-cli -p %p %h --protocols ssl3"
+(defcustom tls-program '("gnutls-cli --insecure -p %p %h"
+ "gnutls-cli --insecure -p %p %h --protocols ssl3"
"openssl s_client -connect %h:%p -no_ssl2 -ign_eof")
"List of strings containing commands to start TLS stream to a host.
Each entry in the list is tried until a connection is successful.
@@ -238,6 +238,10 @@ Fourth arg PORT is an integer specifying a port to connect to."
(setq process (start-process
name buffer shell-file-name shell-command-switch
formatted-cmd))
+ (funcall (if (fboundp 'set-process-query-on-exit-flag)
+ 'set-process-query-on-exit-flag
+ 'process-kill-without-query)
+ process nil)
(while (and process
(memq (process-status process) '(open run))
(progn
@@ -298,5 +302,4 @@ match `%s'. Connect anyway? " host))))))
(provide 'tls)
-;; arch-tag: 5596d1c4-facc-4bc4-94a9-9863b928d7ac
;;; tls.el ends here
diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el
index ac86fabe3a9..7885d143cc2 100644
--- a/lisp/net/tramp-cache.el
+++ b/lisp/net/tramp-cache.el
@@ -6,6 +6,7 @@
;; Author: Daniel Pittman <daniel@inanna.danann.net>
;; Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, processes
+;; Package: tramp
;; This file is part of GNU Emacs.
@@ -49,34 +50,15 @@
;;; Code:
-;; Pacify byte-compiler.
-(eval-when-compile
- (require 'cl)
- (autoload 'tramp-message "tramp")
- (autoload 'tramp-tramp-file-p "tramp")
- ;; We cannot autoload macro `with-parsed-tramp-file-name', it
- ;; results in problems of byte-compiled code.
- (autoload 'tramp-dissect-file-name "tramp")
- (autoload 'tramp-file-name-method "tramp")
- (autoload 'tramp-file-name-user "tramp")
- (autoload 'tramp-file-name-host "tramp")
- (autoload 'tramp-file-name-localname "tramp")
- (autoload 'tramp-run-real-handler "tramp")
- (autoload 'tramp-time-less-p "tramp")
- (autoload 'time-stamp-string "time-stamp"))
+(require 'tramp)
+(autoload 'time-stamp-string "time-stamp")
;;; -- Cache --
+;;;###tramp-autoload
(defvar tramp-cache-data (make-hash-table :test 'equal)
"Hash table for remote files properties.")
-(defvar tramp-cache-inhibit-cache nil
- "Inhibit cache read access, when `t'.
-`nil' means to accept cache entries unconditionally. If the
-value is a timestamp (as returned by `current-time'), cache
-entries are not used when they have been written before this
-time.")
-
(defcustom tramp-persistency-file-name
(cond
;; GNU Emacs.
@@ -102,6 +84,7 @@ time.")
(defvar tramp-cache-data-changed nil
"Whether persistent cache data have been changed.")
+;;;###tramp-autoload
(defun tramp-get-file-property (vec file property default)
"Get the PROPERTY of FILE from the cache context of VEC.
Returns DEFAULT if not set."
@@ -114,21 +97,28 @@ Returns DEFAULT if not set."
(value (when (hash-table-p hash) (gethash property hash))))
(if
;; We take the value only if there is any, and
- ;; `tramp-cache-inhibit-cache' indicates that it is still
+ ;; `remote-file-name-inhibit-cache' indicates that it is still
;; valid. Otherwise, DEFAULT is set.
(and (consp value)
- (or (null tramp-cache-inhibit-cache)
- (and (consp tramp-cache-inhibit-cache)
+ (or (null remote-file-name-inhibit-cache)
+ (and (integerp remote-file-name-inhibit-cache)
+ (<=
+ (tramp-time-diff (current-time) (car value))
+ remote-file-name-inhibit-cache))
+ (and (consp remote-file-name-inhibit-cache)
(tramp-time-less-p
- tramp-cache-inhibit-cache (car value)))))
+ remote-file-name-inhibit-cache (car value)))))
(setq value (cdr value))
(setq value default))
- (if (consp tramp-cache-inhibit-cache)
- (tramp-message vec 1 "%s %s %s" file property value))
(tramp-message vec 8 "%s %s %s" file property value)
+ (when (>= tramp-verbose 10)
+ (let* ((var (intern (concat "tramp-cache-get-count-" property)))
+ (val (or (ignore-errors (symbol-value var)) 0)))
+ (set var (1+ val))))
value))
+;;;###tramp-autoload
(defun tramp-set-file-property (vec file property value)
"Set the PROPERTY of FILE to VALUE, in the cache context of VEC.
Returns VALUE."
@@ -141,8 +131,34 @@ Returns VALUE."
;; We put the timestamp there.
(puthash property (cons (current-time) value) hash)
(tramp-message vec 8 "%s %s %s" file property value)
+ (when (>= tramp-verbose 10)
+ (let* ((var (intern (concat "tramp-cache-set-count-" property)))
+ (val (or (ignore-errors (symbol-value var)) 0)))
+ (set var (1+ val))))
value))
+;;;###tramp-autoload
+(defmacro with-file-property (vec file property &rest body)
+ "Check in Tramp cache for PROPERTY, otherwise execute BODY and set cache.
+FILE must be a local file name on a connection identified via VEC."
+ `(if (file-name-absolute-p ,file)
+ (let ((value (tramp-get-file-property ,vec ,file ,property 'undef)))
+ (when (eq value 'undef)
+ ;; We cannot pass @body as parameter to
+ ;; `tramp-set-file-property' because it mangles our
+ ;; debug messages.
+ (setq value (progn ,@body))
+ (tramp-set-file-property ,vec ,file ,property value))
+ value)
+ ,@body))
+
+;;;###tramp-autoload
+(put 'with-file-property 'lisp-indent-function 3)
+(put 'with-file-property 'edebug-form-spec t)
+(tramp-compat-font-lock-add-keywords
+ 'emacs-lisp-mode '("\\<with-file-property\\>"))
+
+;;;###tramp-autoload
(defun tramp-flush-file-property (vec file)
"Remove all properties of FILE in the cache context of VEC."
;; Unify localname.
@@ -151,6 +167,7 @@ Returns VALUE."
(tramp-message vec 8 "%s" file)
(remhash vec tramp-cache-data))
+;;;###tramp-autoload
(defun tramp-flush-directory-property (vec directory)
"Remove all properties of DIRECTORY in the cache context of VEC.
Remove also properties of all files in subdirectories."
@@ -174,8 +191,7 @@ Remove also properties of all files in subdirectories."
(buffer-file-name)
default-directory)))
(when (tramp-tramp-file-p bfn)
- (let* ((v (tramp-dissect-file-name bfn))
- (localname (tramp-file-name-localname v)))
+ (with-parsed-tramp-file-name bfn nil
(tramp-flush-file-property v localname)))))
(add-hook 'before-revert-hook 'tramp-flush-file-function)
@@ -192,6 +208,7 @@ Remove also properties of all files in subdirectories."
;;; -- Properties --
+;;;###tramp-autoload
(defun tramp-get-connection-property (key property default)
"Get the named PROPERTY for the connection.
KEY identifies the connection, it is either a process or a vector.
@@ -208,6 +225,7 @@ If the value is not set for the connection, returns DEFAULT."
(tramp-message key 7 "%s %s" property value)
value))
+;;;###tramp-autoload
(defun tramp-set-connection-property (key property value)
"Set the named PROPERTY of a connection to VALUE.
KEY identifies the connection, it is either a process or a vector.
@@ -222,14 +240,28 @@ PROPERTY is set persistent when KEY is a vector."
tramp-cache-data))))
(puthash property value hash)
(setq tramp-cache-data-changed t)
- ;; This function is called also during initialization of
- ;; tramp-cache.el. `tramp-message is not defined yet at this
- ;; time, so we ignore the corresponding error.
- (condition-case nil
- (tramp-message key 7 "%s %s" property value)
- (error nil))
+ (tramp-message key 7 "%s %s" property value)
+ value))
+
+;;;###tramp-autoload
+(defmacro with-connection-property (key property &rest body)
+ "Check in Tramp for property PROPERTY, otherwise executes BODY and set."
+ `(let ((value (tramp-get-connection-property ,key ,property 'undef)))
+ (when (eq value 'undef)
+ ;; We cannot pass ,@body as parameter to
+ ;; `tramp-set-connection-property' because it mangles our debug
+ ;; messages.
+ (setq value (progn ,@body))
+ (tramp-set-connection-property ,key ,property value))
value))
+;;;###tramp-autoload
+(put 'with-connection-property 'lisp-indent-function 2)
+(put 'with-connection-property 'edebug-form-spec t)
+(tramp-compat-font-lock-add-keywords
+ 'emacs-lisp-mode '("\\<with-connection-property\\>"))
+
+;;;###tramp-autoload
(defun tramp-flush-connection-property (key)
"Remove all properties identified by KEY.
KEY identifies the connection, it is either a process or a vector."
@@ -250,6 +282,7 @@ KEY identifies the connection, it is either a process or a vector."
(setq tramp-cache-data-changed t)
(remhash key tramp-cache-data))
+;;;###tramp-autoload
(defun tramp-cache-print (table)
"Print hash table TABLE."
(when (hash-table-p table)
@@ -270,6 +303,7 @@ KEY identifies the connection, it is either a process or a vector."
table)
result)))
+;;;###tramp-autoload
(defun tramp-list-connections ()
"Return a list of all known connection vectors according to `tramp-cache'."
(let (result)
@@ -283,41 +317,40 @@ KEY identifies the connection, it is either a process or a vector."
(defun tramp-dump-connection-properties ()
"Write persistent connection properties into file `tramp-persistency-file-name'."
;; We shouldn't fail, otherwise (X)Emacs might not be able to be closed.
- (condition-case nil
- (when (and (hash-table-p tramp-cache-data)
- (not (zerop (hash-table-count tramp-cache-data)))
- tramp-cache-data-changed
- (stringp tramp-persistency-file-name))
- (let ((cache (copy-hash-table tramp-cache-data)))
- ;; Remove temporary data.
- (maphash
- '(lambda (key value)
- (if (and (vectorp key) (not (tramp-file-name-localname key)))
- (progn
- (remhash "process-name" value)
- (remhash "process-buffer" value)
- (remhash "first-password-request" value))
- (remhash key cache)))
- cache)
- ;; Dump it.
- (with-temp-buffer
- (insert
- ";; -*- emacs-lisp -*-"
- ;; `time-stamp-string' might not exist in all (X)Emacs flavors.
- (condition-case nil
- (progn
- (format
- " <%s %s>\n"
- (time-stamp-string "%02y/%02m/%02d %02H:%02M:%02S")
- tramp-persistency-file-name))
- (error "\n"))
- ";; Tramp connection history. Don't change this file.\n"
- ";; You can delete it, forcing Tramp to reapply the checks.\n\n"
- (with-output-to-string
- (pp (read (format "(%s)" (tramp-cache-print cache))))))
- (write-region
- (point-min) (point-max) tramp-persistency-file-name))))
- (error nil)))
+ (ignore-errors
+ (when (and (hash-table-p tramp-cache-data)
+ (not (zerop (hash-table-count tramp-cache-data)))
+ tramp-cache-data-changed
+ (stringp tramp-persistency-file-name))
+ (let ((cache (copy-hash-table tramp-cache-data)))
+ ;; Remove temporary data.
+ (maphash
+ '(lambda (key value)
+ (if (and (vectorp key) (not (tramp-file-name-localname key)))
+ (progn
+ (remhash "process-name" value)
+ (remhash "process-buffer" value)
+ (remhash "first-password-request" value))
+ (remhash key cache)))
+ cache)
+ ;; Dump it.
+ (with-temp-buffer
+ (insert
+ ";; -*- emacs-lisp -*-"
+ ;; `time-stamp-string' might not exist in all (X)Emacs flavors.
+ (condition-case nil
+ (progn
+ (format
+ " <%s %s>\n"
+ (time-stamp-string "%02y/%02m/%02d %02H:%02M:%02S")
+ tramp-persistency-file-name))
+ (error "\n"))
+ ";; Tramp connection history. Don't change this file.\n"
+ ";; You can delete it, forcing Tramp to reapply the checks.\n\n"
+ (with-output-to-string
+ (pp (read (format "(%s)" (tramp-cache-print cache))))))
+ (write-region
+ (point-min) (point-max) tramp-persistency-file-name))))))
(add-hook 'kill-emacs-hook 'tramp-dump-connection-properties)
(add-hook 'tramp-cache-unload-hook
@@ -325,6 +358,7 @@ KEY identifies the connection, it is either a process or a vector."
(remove-hook 'kill-emacs-hook
'tramp-dump-connection-properties)))
+;;;###tramp-autoload
(defun tramp-parse-connection-properties (method)
"Return a list of (user host) tuples allowed to access for METHOD.
This function is added always in `tramp-get-completion-function'
@@ -363,6 +397,10 @@ for all methods. Resulting data are derived from connection history."
tramp-persistency-file-name (error-message-string err))
(clrhash tramp-cache-data))))
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (unload-feature 'tramp-cache 'force)))
+
(provide 'tramp-cache)
;; arch-tag: ee1739b7-7628-408c-9b96-d11a74b05d26
diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el
index 0e31360a416..f4290f6faf3 100644
--- a/lisp/net/tramp-cmds.el
+++ b/lisp/net/tramp-cmds.el
@@ -4,6 +4,7 @@
;; Author: Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, processes
+;; Package: tramp
;; This file is part of GNU Emacs.
@@ -49,6 +50,7 @@
x)))
(buffer-list))))
+;;;###tramp-autoload
(defun tramp-cleanup-connection (vec)
"Flush all connection related objects.
This includes password cache, file cache, connection cache, buffers.
@@ -97,6 +99,7 @@ When called interactively, a Tramp connection has to be selected."
(tramp-get-connection-property vec "process-buffer" nil)))
(when (bufferp buf) (kill-buffer buf)))))
+;;;###tramp-autoload
(defun tramp-cleanup-all-connections ()
"Flush all Tramp internal objects.
This includes password cache, file cache, connection cache, buffers."
@@ -115,6 +118,7 @@ This includes password cache, file cache, connection cache, buffers."
(dolist (name (tramp-list-tramp-buffers))
(when (bufferp (get-buffer name)) (kill-buffer name))))
+;;;###tramp-autoload
(defun tramp-cleanup-all-buffers ()
"Kill all remote buffers."
(interactive)
@@ -128,6 +132,7 @@ This includes password cache, file cache, connection cache, buffers."
;; Tramp version is useful in a number of situations.
+;;;###tramp-autoload
(defun tramp-version (arg)
"Print version number of tramp.el in minibuffer or current buffer."
(interactive "P")
@@ -138,6 +143,7 @@ This includes password cache, file cache, connection cache, buffers."
(autoload 'reporter-submit-bug-report "reporter")
+;;;###tramp-autoload
(defun tramp-bug ()
"Submit a bug report to the Tramp developers."
(interactive)
@@ -147,65 +153,25 @@ This includes password cache, file cache, connection cache, buffers."
(reporter-submit-bug-report
tramp-bug-report-address ; to-address
(format "tramp (%s)" tramp-version) ; package name and version
- (delq nil
- `(;; Current state
- tramp-current-method
- tramp-current-user
- tramp-current-host
-
- ;; System defaults
- tramp-auto-save-directory ; vars to dump
- tramp-default-method
- tramp-default-method-alist
- tramp-default-host
- tramp-default-proxies-alist
- tramp-default-user
- tramp-default-user-alist
- tramp-rsh-end-of-line
- tramp-default-password-end-of-line
- tramp-login-prompt-regexp
- ;; Mask non-7bit characters
- (tramp-password-prompt-regexp . tramp-reporter-dump-variable)
- tramp-wrong-passwd-regexp
- tramp-yesno-prompt-regexp
- tramp-yn-prompt-regexp
- tramp-terminal-prompt-regexp
- tramp-temp-name-prefix
- tramp-file-name-structure
- tramp-file-name-regexp
- tramp-methods
- tramp-end-of-output
- tramp-local-coding-commands
- tramp-remote-coding-commands
- tramp-actions-before-shell
- tramp-actions-copy-out-of-band
- tramp-terminal-type
- ;; Mask non-7bit characters
- (tramp-shell-prompt-pattern . tramp-reporter-dump-variable)
- ,(when (boundp 'tramp-backup-directory-alist)
- 'tramp-backup-directory-alist)
- ,(when (boundp 'tramp-bkup-backup-directory-info)
- 'tramp-bkup-backup-directory-info)
- ;; Dump cache.
- (tramp-cache-data . tramp-reporter-dump-variable)
-
- ;; Non-tramp variables of interest
- ;; Mask non-7bit characters
- (shell-prompt-pattern . tramp-reporter-dump-variable)
- backup-by-copying
- backup-by-copying-when-linked
- 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))
+ (sort
+ (delq nil (mapcar
+ (lambda (x)
+ (and x (boundp x) (cons x 'tramp-reporter-dump-variable)))
+ (append
+ (mapcar 'intern (all-completions "tramp-" obarray 'boundp))
+ ;; Non-tramp variables of interest.
+ '(shell-prompt-pattern
+ backup-by-copying
+ backup-by-copying-when-linked
+ backup-by-copying-when-mismatch
+ backup-by-copying-when-privileged-mismatch
+ backup-directory-alist
+ bkup-backup-directory-info
+ password-cache
+ password-cache-expiry
+ remote-file-name-inhibit-cache
+ file-name-handler-alist))))
+ (lambda (x y) (string< (symbol-name (car x)) (symbol-name (car y)))))
'tramp-load-report-modules ; pre-hook
'tramp-append-tramp-buffers ; post-hook
@@ -235,8 +201,7 @@ buffer in your bug report.
"))))
(defun tramp-reporter-dump-variable (varsym mailbuf)
- "Pretty-print the value of the variable in symbol VARSYM.
-Used for non-7bit chars in strings."
+ "Pretty-print the value of the variable in symbol VARSYM."
(let* ((reporter-eval-buffer (symbol-value 'reporter-eval-buffer))
(val (with-current-buffer reporter-eval-buffer
(symbol-value varsym))))
@@ -244,12 +209,13 @@ Used for non-7bit chars in strings."
(if (hash-table-p val)
;; Pretty print the cache.
(set varsym (read (format "(%s)" (tramp-cache-print val))))
- ;; There are characters to be masked.
+ ;; There are non-7bit characters to be masked.
(when (and (boundp 'mm-7bit-chars)
+ (stringp val)
(string-match
(concat "[^" (symbol-value 'mm-7bit-chars) "]") val))
(with-current-buffer reporter-eval-buffer
- (set varsym (format "(base64-decode-string \"%s\""
+ (set varsym (format "(base64-decode-string \"%s\")"
(base64-encode-string val))))))
;; Dump variable.
@@ -265,7 +231,7 @@ Used for non-7bit chars in strings."
"\\(\")\\)" "\"$")) ;; \4 "
(replace-match "\\1\\2\\3\\4")
(beginning-of-line)
- (insert " ;; variable encoded due to non-printable characters\n"))
+ (insert " ;; Variable encoded due to non-printable characters.\n"))
(forward-line 1))
;; Reset VARSYM to old value.
@@ -274,7 +240,6 @@ Used for non-7bit chars in strings."
(defun tramp-load-report-modules ()
"Load needed modules for reporting."
-
;; We load message.el and mml.el from Gnus.
(if (featurep 'xemacs)
(progn
@@ -287,7 +252,6 @@ Used for non-7bit chars in strings."
(defun tramp-append-tramp-buffers ()
"Append Tramp buffers and buffer local variables into the bug report."
-
(goto-char (point-max))
;; Dump buffer local variables.
@@ -334,8 +298,7 @@ Used for non-7bit chars in strings."
(setq buffer-read-only nil)
(goto-char (point-min))
(while (not (eobp))
- (if (re-search-forward
- tramp-buf-regexp (tramp-compat-line-end-position) t)
+ (if (re-search-forward tramp-buf-regexp (point-at-eol) t)
(forward-line 1)
(forward-line 0)
(let ((start (point)))
@@ -386,6 +349,9 @@ please ensure that the buffers are attached to your email.\n\n")
(defalias 'tramp-submit-bug 'tramp-bug)
+(add-hook 'tramp-unload-hook
+ (lambda () (unload-feature 'tramp-cmds 'force)))
+
(provide 'tramp-cmds)
;;; TODO:
@@ -394,7 +360,7 @@ please ensure that the buffers are attached to your email.\n\n")
;; * WIBNI there was an interactive command prompting for Tramp
;; method, hostname, username and filename and translates the user
;; input into the correct filename syntax (depending on the Emacs
-;; flavor) (Reiner Steib)
+;; flavor) (Reiner Steib)
;; * Let the user edit the connection properties interactively.
;; Something like `gnus-server-edit-server' in Gnus' *Server* buffer.
;; * It's just that when I come to Customize `tramp-default-user-alist'
@@ -403,7 +369,6 @@ please ensure that the buffers are attached to your email.\n\n")
;; Option and should not be modified by the code. add-to-list is
;; called in several places. One way to handle that is to have a new
;; ordinary variable that gets its initial value from
-;; tramp-default-user-alist and then is added to. (Pete Forman)
+;; tramp-default-user-alist and then is added to. (Pete Forman)
-;; arch-tag: 190d4c33-76bb-4e99-8b6f-71741f23d98c
;;; tramp-cmds.el ends here
diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el
index 484d2be7abe..852ee8fa45d 100644
--- a/lisp/net/tramp-compat.el
+++ b/lisp/net/tramp-compat.el
@@ -4,6 +4,7 @@
;; Author: Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, processes
+;; Package: tramp
;; This file is part of GNU Emacs.
@@ -28,6 +29,8 @@
;;; Code:
+(require 'tramp-loaddefs)
+
(eval-when-compile
;; Pacify byte-compiler.
@@ -35,40 +38,41 @@
(eval-and-compile
+ (require 'advice)
(require 'custom)
+ (require 'format-spec)
+
+ ;; As long as password.el is not part of (X)Emacs, it shouldn't be
+ ;; mandatory.
+ (if (featurep 'xemacs)
+ (load "password" 'noerror)
+ (or (require 'password-cache nil 'noerror)
+ (require 'password nil 'noerror))) ; Part of contrib.
+
+ ;; auth-source is relatively new.
+ (if (featurep 'xemacs)
+ (load "auth-source" 'noerror)
+ (require 'auth-source nil 'noerror))
;; Load the appropriate timer package.
(if (featurep 'xemacs)
(require 'timer-funcs)
(require 'timer))
- (autoload 'tramp-tramp-file-p "tramp")
- (autoload 'tramp-file-name-handler "tramp")
-
;; We check whether `start-file-process' is bound.
(unless (fboundp 'start-file-process)
;; tramp-util offers integration into other (X)Emacs packages like
;; compile.el, gud.el etc. Not necessary in Emacs 23.
(eval-after-load "tramp"
- '(progn
- (require 'tramp-util)
- (add-hook 'tramp-unload-hook
- '(lambda ()
- (when (featurep 'tramp-util)
- (unload-feature 'tramp-util 'force))))))
+ '(require 'tramp-util))
;; Make sure that we get integration with the VC package. When it
;; is loaded, we need to pull in the integration module. Not
;; necessary in Emacs 23.
(eval-after-load "vc"
(eval-after-load "tramp"
- '(progn
- (require 'tramp-vc)
- (add-hook 'tramp-unload-hook
- '(lambda ()
- (when (featurep 'tramp-vc)
- (unload-feature 'tramp-vc 'force))))))))
+ '(require 'tramp-vc))))
;; Avoid byte-compiler warnings if the byte-compiler supports this.
;; Currently, XEmacs supports this.
@@ -84,18 +88,18 @@
;; `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.
- (unless (boundp 'byte-compile-not-obsolete-var)
- (defvar byte-compile-not-obsolete-var nil))
- (setq byte-compile-not-obsolete-var 'directory-sep-char)
- ;; Emacs 23.2.
- (unless (boundp 'byte-compile-not-obsolete-vars)
- (defvar byte-compile-not-obsolete-vars nil))
- (setq byte-compile-not-obsolete-vars '(directory-sep-char))
-
- ;; `with-temp-message' does not exists in XEmacs.
- (condition-case nil
- (with-temp-message (current-message) nil)
- (error (defmacro with-temp-message (message &rest body) `(progn ,@body))))
+ ;; Note that it was removed altogether in Emacs 24.1.
+ (when (boundp 'directory-sep-char)
+ (defvar byte-compile-not-obsolete-var nil)
+ (setq byte-compile-not-obsolete-var 'directory-sep-char)
+ ;; Emacs 23.2.
+ (defvar byte-compile-not-obsolete-vars nil)
+ (setq byte-compile-not-obsolete-vars '(directory-sep-char)))
+
+ ;; `remote-file-name-inhibit-cache' has been introduced with Emacs 24.1.
+ ;; Besides `t', `nil', and integer, we use also timestamps (as
+ ;; returned by `current-time') internally.
+ (defvar remote-file-name-inhibit-cache nil)
;; For not existing functions, or functions with a changed argument
;; list, there are compiler warnings. We want to avoid them in
@@ -110,10 +114,6 @@
(unless (fboundp 'set-buffer-multibyte)
(defalias 'set-buffer-multibyte 'ignore))
- ;; `font-lock-add-keywords' does not exist in XEmacs.
- (unless (fboundp 'font-lock-add-keywords)
- (defalias 'font-lock-add-keywords 'ignore))
-
;; The following functions cannot be aliases of the corresponding
;; `tramp-handle-*' functions, because this would bypass the locking
;; mechanism.
@@ -186,24 +186,18 @@
'file-expand-wildcards 'around 'tramp-advice-file-expand-wildcards)
(ad-activate 'file-expand-wildcards)))))
-(defsubst tramp-compat-line-beginning-position ()
- "Return point at beginning of line (compat function).
-Calls `line-beginning-position' or `point-at-bol' if defined, else
-own implementation."
- (cond
- ((fboundp 'line-beginning-position)
- (tramp-compat-funcall 'line-beginning-position))
- ((fboundp 'point-at-bol) (tramp-compat-funcall 'point-at-bol))
- (t (save-excursion (beginning-of-line) (point)))))
-
-(defsubst tramp-compat-line-end-position ()
- "Return point at end of line (compat function).
-Calls `line-end-position' or `point-at-eol' if defined, else
-own implementation."
- (cond
- ((fboundp 'line-end-position) (tramp-compat-funcall 'line-end-position))
- ((fboundp 'point-at-eol) (tramp-compat-funcall 'point-at-eol))
- (t (save-excursion (end-of-line) (point)))))
+;; `with-temp-message' does not exists in XEmacs.
+(if (fboundp 'with-temp-message)
+ (defalias 'tramp-compat-with-temp-message 'with-temp-message)
+ (defmacro tramp-compat-with-temp-message (message &rest body)
+ "Display MESSAGE temporarily if non-nil while BODY is evaluated."
+ `(progn ,@body)))
+
+;; `font-lock-add-keywords' does not exist in XEmacs.
+(defun tramp-compat-font-lock-add-keywords (mode keywords &optional how)
+ "Add highlighting KEYWORDS for MODE."
+ (ignore-errors
+ (tramp-compat-funcall 'font-lock-add-keywords mode keywords how)))
(defsubst tramp-compat-temporary-file-directory ()
"Return name of directory for temporary files (compat function).
@@ -262,6 +256,24 @@ Add the extension of FILENAME, if existing."
;; Default value in XEmacs.
(t 134217727)))
+(defun tramp-compat-decimal-to-octal (i)
+ "Return a string consisting of the octal digits of I.
+Not actually used. Use `(format \"%o\" i)' instead?"
+ (cond ((< i 0) (error "Cannot convert negative number to octal"))
+ ((not (integerp i)) (error "Cannot convert non-integer to octal"))
+ ((zerop i) "0")
+ (t (concat (tramp-compat-decimal-to-octal (/ i 8))
+ (number-to-string (% i 8))))))
+
+;; Kudos to Gerd Moellmann for this suggestion.
+(defun tramp-compat-octal-to-decimal (ostr)
+ "Given a string of octal digits, return a decimal number."
+ (let ((x (or ostr "")))
+ ;; `save-match' is in `tramp-mode-string-to-int' which calls this.
+ (unless (string-match "\\`[0-7]*\\'" x)
+ (error "Non-octal junk in string `%s'" x))
+ (string-to-number ostr 8)))
+
;; ID-FORMAT does not exists in XEmacs.
(defun tramp-compat-file-attributes (filename &optional id-format)
"Like `file-attributes' for Tramp files (compat function)."
@@ -396,6 +408,20 @@ This is, the first, empty, element is omitted. In XEmacs, the first
element is not omitted."
(delete "" (split-string string pattern)))
+(defun tramp-compat-call-process
+ (program &optional infile destination display &rest args)
+ "Calls `call-process' on the local host.
+This is needed because for some Emacs flavors Tramp has
+defadviced `call-process' to behave like `process-file'. The
+Lisp error raised when PROGRAM is nil is trapped also, returning 1."
+ (let ((default-directory
+ (if (file-remote-p default-directory)
+ (tramp-compat-temporary-file-directory)
+ default-directory)))
+ (if (executable-find program)
+ (apply 'call-process program infile destination display args)
+ 1)))
+
(defun tramp-compat-process-running-p (process-name)
"Returns `t' if system process PROCESS-NAME is running for `user-login-name'."
(when (stringp process-name)
@@ -438,9 +464,50 @@ element is not omitted."
(setenv "UNIX95" unix95)
result)))))
+;; The following functions do not exist in XEmacs. We ignore this;
+;; they are used for checking a remote tty.
+(defun tramp-compat-process-get (process propname)
+ "Return the value of PROCESS' PROPNAME property.
+This is the last value stored with `(process-put PROCESS PROPNAME VALUE)'."
+ (ignore-errors (tramp-compat-funcall 'process-get process propname)))
+
+(defun tramp-compat-process-put (process propname value)
+ "Change PROCESS' PROPNAME property to VALUE.
+It can be retrieved with `(process-get PROCESS PROPNAME)'."
+ (ignore-errors (tramp-compat-funcall 'process-put process propname value)))
+
+(defun tramp-compat-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)
+ (tramp-compat-funcall 'set-process-query-on-exit-flag process flag)
+ (tramp-compat-funcall 'process-kill-without-query process flag)))
+
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (unload-feature 'tramp-compat 'force)))
+
+(defun tramp-compat-coding-system-change-eol-conversion (coding-system eol-type)
+ "Return a coding system like CODING-SYSTEM but with given EOL-TYPE.
+EOL-TYPE can be one of `dos', `unix', or `mac'."
+ (cond ((fboundp 'coding-system-change-eol-conversion)
+ (tramp-compat-funcall
+ 'coding-system-change-eol-conversion coding-system eol-type))
+ ((fboundp 'subsidiary-coding-system)
+ (tramp-compat-funcall
+ 'subsidiary-coding-system coding-system
+ (cond ((eq eol-type 'dos) 'crlf)
+ ((eq eol-type 'unix) 'lf)
+ ((eq eol-type 'mac) 'cr)
+ (t
+ (error "Unknown EOL-TYPE `%s', must be %s"
+ eol-type
+ "`dos', `unix', or `mac'")))))
+ (t (error "Can't change EOL conversion -- is MULE missing?"))))
+
(provide 'tramp-compat)
;;; TODO:
-;; arch-tag: 0e724b18-6699-4f87-ad96-640b272e5c85
;;; tramp-compat.el ends here
diff --git a/lisp/net/tramp-fish.el b/lisp/net/tramp-fish.el
deleted file mode 100644
index 44e2ab8b392..00000000000
--- a/lisp/net/tramp-fish.el
+++ /dev/null
@@ -1,1180 +0,0 @@
-;;; tramp-fish.el --- Tramp access functions for FISH protocol
-
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Author: Michael Albinus <michael.albinus@gmx.de>
-;; Keywords: comm, 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 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Access functions for FIles transferred over SHell protocol from Tramp.
-
-;; FISH is a protocol developped for the GNU Midnight Commander
-;; <https://savannah.gnu.org/projects/mc>. A client connects to a
-;; remote host via ssh (or rsh, shall be configurable), and starts
-;; there a fish server via the command "start_fish_server". All
-;; commands from the client have the form "#FISH_COMMAND\n" (always
-;; one line), followed by equivalent shell commands in case there is
-;; no fish server running.
-
-;; The fish server (or the equivalent shell commands) must return the
-;; response, which is finished by a line "### xxx <optional text>\n".
-;; "xxx" stands for 3 digits, representing a return code. Return
-;; codes "# 000" and "# 001" are reserved for fallback implementation
-;; with native shell commands; they are not used inside the server. See
-;; <http://cvs.savannah.gnu.org/viewvc/mc/vfs/README.fish?root=mc&view=markup>
-;; for details of original specification.
-
-;; The GNU Midnight Commander implements the original fish protocol
-;; version 0.0.2. The KDE Konqueror has its own implementation, which
-;; can be found at
-;; <http://websvn.kde.org/branches/KDE/3.5/kdebase/kioslave/fish>. It
-;; implements an extended protocol version 0.0.3. Additionally, it
-;; provides a fish server implementation in Perl (which is the only
-;; implementation I've heard of). The following command reference is
-;; based on that implementation.
-
-;; All commands return either "### 2xx\n" (OK) or "### 5xx <optional text>\n"
-;; (NOK). Return codes are mentioned only if they are different from this.
-;; Spaces in any parameter must be escaped by "\ ".
-
-;; Command/Return Code Comment
-;;
-;; #FISH initial connection, not used
-;; in .fishsrv.pl
-;; ### 100 transfer fish server missing server, or wrong checksum
-;; version 0.0.3 only
-
-;; #VER a.b.c <commands requested>
-;; VER x.y.z <commands offered> .fishsrv.pl response is not uptodate
-
-;; #PWD
-;; /path/to/file
-
-;; #CWD /some/path
-
-;; #COPY /path/a /path/b version 0.0.3 only
-
-;; #RENAME /path/a /path/b
-
-;; #SYMLINK /path/a /path/b
-
-;; #LINK /path/a /path/b
-
-;; #DELE /some/path
-
-;; #MKD /some/path
-
-;; #RMD /some/path
-
-;; #CHOWN user /file/name
-
-;; #CHGRP group /file/name
-
-;; #CHMOD 1234 file
-
-;; #READ <offset> <size> /path/and/filename
-;; ### 291 successful exit when reading
-;; ended at eof
-;; ### 292 successful exit when reading
-;; did not end at eof
-
-;; #WRITE <offset> <size> /path/and/filename
-
-;; #APPEND <size> /path/and/filename version 0.0.3 only
-
-;; #LIST /directory
-;; <number of entries> version 0.0.3 only
-;; ### 100 version 0.0.3 only
-;; P<unix permissions> <owner>.<group>
-;; S<size>
-;; d<3-letters month name> <day> <year or HH:MM>
-;; D<year> <month> <day> <hour> <minute> <second>[.1234]
-;; E<major-of-device>,<minor>
-;; :<filename>
-;; L<filename symlink points to>
-;; M<mimetype> version 0.0.3 only
-;; <blank line to separate items>
-
-;; #STAT /file version 0.0.3 only
-;; like #LIST except for directories
-;; <number of entries>
-;; ### 100
-;; P<unix permissions> <owner>.<group>
-;; S<size>
-;; d<3-letters month name> <day> <year or HH:MM>
-;; D<year> <month> <day> <hour> <minute> <second>[.1234]
-;; E<major-of-device>,<minor>
-;; :<filename>
-;; L<filename symlink points to>
-;; <blank line to separate items>
-
-;; #RETR /some/name
-;; <filesize>
-;; ### 100
-;; <binary data> exactly filesize bytes
-;; ### 200 with no preceding newline
-
-;; #STOR <size> /file/name
-;; ### 100
-;; <data> exactly size bytes
-;; ### 001 partial success
-
-;; #EXEC <command> <tmpfile> version 0.0.3 only
-;; <tmpfile> must not exists. It contains the output of <command>.
-;; It can be retrieved afterwards. Last line is
-;; ###RESULT: <returncode>
-
-;; This implementation is meant as proof of the concept, whether there
-;; is a better performance compared with the native ssh method. It
-;; looks like the file information retrieval is slower, especially the
-;; #LIST command. On the other hand, the file contents transmission
-;; seems to perform better than other inline methods, because there is
-;; no need for data encoding/decoding, and it supports the APPEND
-;; parameter of `write-region'. Transfer of binary data fails due to
-;; Emacs' process input/output handling.
-
-;;; Code:
-
-(eval-when-compile
- ;; Pacify byte-compiler.
- (require 'cl))
-
-(require 'tramp)
-(require 'tramp-cache)
-(require 'tramp-compat)
-
-;; Define FISH method ...
-(defcustom tramp-fish-method "fish"
- "*Method to connect via FISH protocol."
- :group 'tramp
- :type 'string)
-
-;; ... and add it to the method list.
-(add-to-list 'tramp-methods (cons tramp-fish-method nil))
-
-;; Add a default for `tramp-default-user-alist'. Default is the local user.
-(add-to-list 'tramp-default-user-alist
- `(,tramp-fish-method nil ,(user-login-name)))
-
-;; Add completion function for FISH method.
-(tramp-set-completion-function
- tramp-fish-method tramp-completion-function-alist-ssh)
-
-(defconst tramp-fish-continue-prompt-regexp "^### 100.*\n"
- "FISH return code OK.")
-
-;; It cannot be a defconst, occasionally we bind it locally.
-(defvar tramp-fish-ok-prompt-regexp "^### 200\n"
- "FISH return code OK.")
-
-(defconst tramp-fish-error-prompt-regexp "^### \\(4\\|5\\)[0-9]+.*\n"
- "Regexp for possible error strings of FISH servers.
-Used instead of analyzing error codes of commands.")
-
-(defcustom tramp-fish-start-fish-server-command
- (concat "stty intr \"\" quit \"\" erase \"\" kill \"\" eof \"\" eol \"\" eol2 \"\" swtch \"\" start \"\" stop \"\" susp \"\" rprnt \"\" werase \"\" lnext \"\" flush \"\"; "
- "perl .fishsrv.pl "
- "`grep 'ARGV\\[0\\]' .fishsrv.pl | "
- "sed -e 's/^[^\"]*\"//' -e 's/\"[^\"]*$//'`; "
- "exit")
- "*Command to connect via FISH protocol."
- :group 'tramp
- :type 'string)
-
-;; New handlers should be added here.
-(defconst tramp-fish-file-name-handler-alist
- '(
- ;; `access-file' performed by default handler
- (add-name-to-file . tramp-fish-handle-add-name-to-file)
- ;; `byte-compiler-base-file-name' performed by default handler
- (copy-file . tramp-fish-handle-copy-file)
- (delete-directory . tramp-fish-handle-delete-directory)
- (delete-file . tramp-fish-handle-delete-file)
- ;; `diff-latest-backup-file' performed by default handler
- (directory-file-name . tramp-handle-directory-file-name)
- (directory-files . tramp-handle-directory-files)
- (directory-files-and-attributes . tramp-fish-handle-directory-files-and-attributes)
- ;; `dired-call-process' performed by default handler
- ;; `dired-compress-file' performed by default handler
- (dired-uncache . tramp-handle-dired-uncache)
- (expand-file-name . tramp-fish-handle-expand-file-name)
- ;; `file-accessible-directory-p' performed by default handler
- (file-attributes . tramp-fish-handle-file-attributes)
- (file-directory-p . tramp-fish-handle-file-directory-p)
- (file-executable-p . tramp-fish-handle-file-executable-p)
- (file-exists-p . tramp-fish-handle-file-exists-p)
- (file-local-copy . tramp-fish-handle-file-local-copy)
- (file-modes . tramp-handle-file-modes)
- (file-name-all-completions . tramp-fish-handle-file-name-all-completions)
- (file-name-as-directory . tramp-handle-file-name-as-directory)
- (file-name-completion . tramp-handle-file-name-completion)
- (file-name-directory . tramp-handle-file-name-directory)
- (file-name-nondirectory . tramp-handle-file-name-nondirectory)
- ;; `file-name-sans-versions' performed by default handler
- (file-newer-than-file-p . tramp-fish-handle-file-newer-than-file-p)
- (file-ownership-preserved-p . ignore)
- (file-readable-p . tramp-fish-handle-file-readable-p)
- (file-regular-p . tramp-handle-file-regular-p)
- (file-remote-p . tramp-handle-file-remote-p)
- ;; `file-selinux-context' performed by default handler.
- (file-symlink-p . tramp-handle-file-symlink-p)
- ;; `file-truename' performed by default handler
- (file-writable-p . tramp-fish-handle-file-writable-p)
- (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-fish-handle-insert-directory)
- (insert-file-contents . tramp-fish-handle-insert-file-contents)
- (load . tramp-handle-load)
- (make-directory . tramp-fish-handle-make-directory)
- (make-directory-internal . tramp-fish-handle-make-directory-internal)
- (make-symbolic-link . tramp-fish-handle-make-symbolic-link)
- (rename-file . tramp-fish-handle-rename-file)
- (set-file-modes . tramp-fish-handle-set-file-modes)
- ;; `set-file-selinux-context' performed by default handler.
- (set-file-times . tramp-fish-handle-set-file-times)
- (set-visited-file-modtime . ignore)
- (shell-command . tramp-handle-shell-command)
- (substitute-in-file-name . tramp-handle-substitute-in-file-name)
- (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory)
- (vc-registered . ignore)
- (verify-visited-file-modtime . ignore)
- (write-region . tramp-fish-handle-write-region)
- (executable-find . tramp-fish-handle-executable-find)
- (start-file-process . ignore)
- (process-file . tramp-fish-handle-process-file)
-)
- "Alist of handler functions for Tramp FISH method.
-Operations not mentioned here will be handled by the default Emacs primitives.")
-
-(defun tramp-fish-file-name-p (filename)
- "Check if it's a filename for FISH protocol."
- (let ((v (tramp-dissect-file-name filename)))
- (string= (tramp-file-name-method v) tramp-fish-method)))
-
-(defun tramp-fish-file-name-handler (operation &rest args)
- "Invoke the FISH related OPERATION.
-First arg specifies the OPERATION, second arg is a list of arguments to
-pass to the OPERATION."
- (let ((fn (assoc operation tramp-fish-file-name-handler-alist)))
- (if fn
- (save-match-data (apply (cdr fn) args))
- (tramp-run-real-handler operation args))))
-
-(add-to-list 'tramp-foreign-file-name-handler-alist
- (cons 'tramp-fish-file-name-p 'tramp-fish-file-name-handler))
-
-
-;; File name primitives
-
-(defun tramp-fish-handle-add-name-to-file
- (filename newname &optional ok-if-already-exists)
- "Like `add-name-to-file' for Tramp files."
- (unless (tramp-equal-remote filename newname)
- (with-parsed-tramp-file-name
- (if (tramp-tramp-file-p filename) filename newname) nil
- (tramp-error
- v 'file-error
- "add-name-to-file: %s"
- "only implemented for same method, same user, same host")))
- (with-parsed-tramp-file-name filename v1
- (with-parsed-tramp-file-name newname v2
- (when (and (not ok-if-already-exists)
- (file-exists-p newname)
- (not (numberp ok-if-already-exists))
- (y-or-n-p
- (format
- "File %s already exists; make it a new name anyway? "
- newname)))
- (tramp-error
- v2 'file-error
- "add-name-to-file: file %s already exists" newname))
- (tramp-flush-file-property v2 v2-localname)
- (unless (tramp-fish-send-command-and-check
- v1 (format "#LINK %s %s" v1-localname v2-localname))
- (tramp-error
- v1 'file-error "Error with add-name-to-file %s" newname)))))
-
-(defun tramp-fish-handle-copy-file
- (filename newname &optional ok-if-already-exists keep-date
- preserve-uid-gid preserve-selinux-context)
- "Like `copy-file' for Tramp files."
- (tramp-fish-do-copy-or-rename-file
- 'copy filename newname ok-if-already-exists keep-date preserve-uid-gid))
-
-(defun tramp-fish-handle-delete-directory (directory &optional recursive)
- "Like `delete-directory' for Tramp files."
- (when (file-exists-p directory)
- (if recursive
- (mapc
- (lambda (file)
- (if (file-directory-p file)
- (tramp-compat-delete-directory file recursive)
- (delete-file file)))
- ;; We do not want to delete "." and "..".
- (directory-files
- directory 'full "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")))
- (with-parsed-tramp-file-name
- (directory-file-name (expand-file-name directory)) nil
- (tramp-flush-directory-property v localname)
- (tramp-fish-send-command-and-check v (format "#RMD %s" localname)))))
-
-(defun tramp-fish-handle-delete-file (filename &optional trash)
- "Like `delete-file' for Tramp files."
- (when (file-exists-p filename)
- (with-parsed-tramp-file-name (expand-file-name filename) nil
- (tramp-flush-file-property v localname)
- (tramp-fish-send-command-and-check v (format "#DELE %s" localname)))))
-
-(defun tramp-fish-handle-directory-files-and-attributes
- (directory &optional full match nosort id-format)
- "Like `directory-files-and-attributes' for Tramp files."
- (mapcar
- (lambda (x)
- (cons x
- (tramp-compat-file-attributes
- (if full x (expand-file-name x directory))
- id-format)))
- (directory-files directory full match nosort)))
-
-(defun tramp-fish-handle-expand-file-name (name &optional dir)
- "Like `expand-file-name' for Tramp files."
- ;; If DIR is not given, use DEFAULT-DIRECTORY or "/".
- (setq dir (or dir default-directory "/"))
- ;; Unless NAME is absolute, concat DIR and NAME.
- (unless (file-name-absolute-p name)
- (setq name (concat (file-name-as-directory dir) name)))
- ;; If NAME is not a Tramp file, run the real handler,
- (if (or (tramp-completion-mode-p) (not (tramp-tramp-file-p name)))
- (tramp-drop-volume-letter
- (tramp-run-real-handler 'expand-file-name (list name nil)))
- ;; Dissect NAME.
- (with-parsed-tramp-file-name name nil
- (unless (tramp-run-real-handler 'file-name-absolute-p (list localname))
- (setq localname (concat "~/" localname)))
- ;; Tilde expansion if necessary.
- (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname)
- (let ((uname (match-string 1 localname))
- (fname (match-string 2 localname)))
- ;; We cannot apply "~user/", because this is not supported
- ;; by the FISH protocol.
- (unless (string-equal uname "~")
- (tramp-error
- v 'file-error "Tilde expansion not supported for %s" name))
- (setq uname
- (with-connection-property v uname
- (tramp-fish-send-command-and-check v "#PWD")
- (with-current-buffer (tramp-get-buffer v)
- (goto-char (point-min))
- (buffer-substring (point) (tramp-compat-line-end-position)))))
- (setq localname (concat uname fname))))
- ;; There might be a double slash, for example when "~/"
- ;; expands to "/". Remove this.
- (while (string-match "//" localname)
- (setq localname (replace-match "/" t t localname)))
- ;; No tilde characters in file name, do normal
- ;; expand-file-name (this does "/./" and "/../"). We bind
- ;; `directory-sep-char' here for XEmacs on Windows, which
- ;; would otherwise use backslash. `default-directory' is
- ;; bound, because on Windows there would be problems with UNC
- ;; shares or Cygwin mounts.
- (let ((directory-sep-char ?/)
- (default-directory (tramp-compat-temporary-file-directory)))
- (tramp-make-tramp-file-name
- method user host
- (tramp-drop-volume-letter
- (tramp-run-real-handler
- 'expand-file-name (list localname))))))))
-
-(defun tramp-fish-handle-file-attributes (filename &optional id-format)
- "Like `file-attributes' for Tramp files."
- (with-parsed-tramp-file-name (expand-file-name filename) nil
- (with-file-property v localname (format "file-attributes-%s" id-format)
- (cdr (car (tramp-fish-get-file-entries v localname nil))))))
-
-(defun tramp-fish-handle-file-directory-p (filename)
- "Like `file-directory-p' for Tramp files."
- (let ((attributes (file-attributes filename)))
- (and attributes
- (or (string-match "d" (nth 8 attributes))
- (and (file-symlink-p filename)
- (with-parsed-tramp-file-name filename nil
- (file-directory-p
- (tramp-make-tramp-file-name
- method user host (nth 0 attributes))))))
- t)))
-
-(defun tramp-fish-handle-file-exists-p (filename)
- "Like `file-exists-p' for Tramp files."
- (and (file-attributes filename) t))
-
-(defun tramp-fish-handle-file-executable-p (filename)
- "Like `file-executable-p' for Tramp files."
- (with-parsed-tramp-file-name (expand-file-name filename) nil
- (with-file-property v localname "file-executable-p"
- (when (file-exists-p filename)
- (let ((mode-chars (string-to-vector (nth 8 (file-attributes filename))))
- (home-directory
- (tramp-make-tramp-file-name
- method user host
- (tramp-get-connection-property v "home-directory" nil))))
- (or (and (char-equal (aref mode-chars 3) ?x)
- (equal (nth 2 (file-attributes filename))
- (nth 2 (file-attributes home-directory))))
- (and (char-equal (aref mode-chars 6) ?x)
- (equal (nth 3 (file-attributes filename))
- (nth 3 (file-attributes home-directory))))
- (char-equal (aref mode-chars 9) ?x)))))))
-
-(defun tramp-fish-handle-file-readable-p (filename)
- "Like `file-readable-p' for Tramp files."
- (with-parsed-tramp-file-name (expand-file-name filename) nil
- (with-file-property v localname "file-readable-p"
- (when (file-exists-p filename)
- (let ((mode-chars (string-to-vector (nth 8 (file-attributes filename))))
- (home-directory
- (tramp-make-tramp-file-name
- method user host
- (tramp-get-connection-property v "home-directory" nil))))
- (or (and (char-equal (aref mode-chars 1) ?r)
- (equal (nth 2 (file-attributes filename))
- (nth 2 (file-attributes home-directory))))
- (and (char-equal (aref mode-chars 4) ?r)
- (equal (nth 3 (file-attributes filename))
- (nth 3 (file-attributes home-directory))))
- (char-equal (aref mode-chars 7) ?r)))))))
-
-(defun tramp-fish-handle-file-writable-p (filename)
- "Like `file-writable-p' for Tramp files."
- (with-parsed-tramp-file-name (expand-file-name filename) nil
- (with-file-property v localname "file-writable-p"
- (if (not (file-exists-p filename))
- ;; If file doesn't exist, check if directory is writable.
- (and (file-directory-p (file-name-directory filename))
- (file-writable-p (file-name-directory filename)))
- ;; Existing files must be writable.
- (let ((mode-chars (string-to-vector (nth 8 (file-attributes filename))))
- (home-directory
- (tramp-make-tramp-file-name
- method user host
- (tramp-get-connection-property v "home-directory" nil))))
- (or (and (char-equal (aref mode-chars 2) ?w)
- (equal (nth 2 (file-attributes filename))
- (nth 2 (file-attributes home-directory))))
- (and (char-equal (aref mode-chars 5) ?w)
- (equal (nth 3 (file-attributes filename))
- (nth 3 (file-attributes home-directory))))
- (char-equal (aref mode-chars 8) ?w)))))))
-
-(defun tramp-fish-handle-file-local-copy (filename)
- "Like `file-local-copy' for Tramp files."
- (with-parsed-tramp-file-name (expand-file-name filename) nil
- (unless (file-exists-p filename)
- (tramp-error
- v 'file-error
- "Cannot make local copy of non-existing file `%s'" filename))
- (let ((tmpfile (tramp-compat-make-temp-file filename)))
- (with-progress-reporter
- v 3 (format "Fetching %s to tmp file %s" filename tmpfile)
- (when (tramp-fish-retrieve-data v)
- ;; Save file
- (with-current-buffer (tramp-get-buffer v)
- (write-region (point-min) (point-max) tmpfile))
- tmpfile)))))
-
-;; This function should return "foo/" for directories and "bar" for
-;; files.
-(defun tramp-fish-handle-file-name-all-completions (filename directory)
- "Like `file-name-all-completions' for Tramp files."
- (all-completions
- filename
- (with-parsed-tramp-file-name (expand-file-name directory) nil
- (with-file-property v localname "file-name-all-completions"
- (save-match-data
- (let ((entries
- (with-file-property v localname "file-entries"
- (tramp-fish-get-file-entries v localname t))))
- (mapcar
- (lambda (x)
- (list
- (if (string-match "d" (nth 9 x))
- (file-name-as-directory (nth 0 x))
- (nth 0 x))))
- entries)))))))
-
-(defun tramp-fish-handle-file-newer-than-file-p (file1 file2)
- "Like `file-newer-than-file-p' for Tramp files."
- (cond
- ((not (file-exists-p file1)) nil)
- ((not (file-exists-p file2)) t)
- (t (tramp-time-less-p (nth 5 (file-attributes file2))
- (nth 5 (file-attributes file1))))))
-
-(defun tramp-fish-handle-insert-directory
- (filename switches &optional wildcard full-directory-p)
- "Like `insert-directory' for Tramp files.
-WILDCARD and FULL-DIRECTORY-P are not handled."
- (setq filename (expand-file-name filename))
- (when (file-directory-p filename)
- ;; This check is a little bit strange, but in `dired-add-entry'
- ;; this function is called with a non-directory ...
- (setq filename (file-name-as-directory filename)))
-
- (with-parsed-tramp-file-name filename nil
- (tramp-flush-file-property v localname)
- (save-match-data
- (let ((entries
- (with-file-property v localname "file-entries"
- (tramp-fish-get-file-entries v localname t))))
-
- ;; Sort entries
- (setq entries
- (sort
- entries
- (lambda (x y)
- (if (string-match "t" switches)
- ;; Sort by date.
- (tramp-time-less-p (nth 6 y) (nth 6 x))
- ;; Sort by name.
- (string-lessp (nth 0 x) (nth 0 y))))))
-
- ;; Print entries.
- (mapcar
- (lambda (x)
- (insert
- (format
- "%10s %3d %-8s %-8s %8s %s %s%s\n"
- (nth 9 x) ; mode
- 1 ; hardlinks
- (nth 3 x) ; uid
- (nth 4 x) ; gid
- (nth 8 x) ; size
- (format-time-string
- (if (tramp-time-less-p
- (tramp-time-subtract (current-time) (nth 6 x))
- tramp-half-a-year)
- "%b %e %R"
- "%b %e %Y")
- (nth 6 x)) ; date
- (nth 0 x) ; file name
- (if (stringp (nth 1 x)) (format " -> %s" (nth 1 x)) "")))
- (forward-line)
- (beginning-of-line))
- entries)))))
-
-(defun tramp-fish-handle-insert-file-contents
- (filename &optional visit beg end replace)
- "Like `insert-file-contents' for Tramp files."
- (barf-if-buffer-read-only)
- (when visit
- (setq buffer-file-name (expand-file-name filename))
- (set-visited-file-modtime)
- (set-buffer-modified-p nil))
-
- (with-parsed-tramp-file-name filename nil
- (if (not (file-exists-p filename))
- (tramp-error
- v 'file-error "File %s not found on remote host" filename)
-
- (let ((point (point))
- size)
- (with-progress-reporter v 3 (format "Fetching file %s" filename)
- (when (tramp-fish-retrieve-data v)
- ;; Insert file
- (insert
- (with-current-buffer (tramp-get-buffer v)
- (let ((beg (or beg (point-min)))
- (end (min (or end (point-max)) (point-max))))
- (setq size (- end beg))
- (buffer-substring beg end))))
- (goto-char point)))
-
- (list (expand-file-name filename) size)))))
-
-(defun tramp-fish-handle-make-directory (dir &optional parents)
- "Like `make-directory' for Tramp files."
- (setq dir (directory-file-name (expand-file-name dir)))
- (unless (file-name-absolute-p dir)
- (setq dir (expand-file-name dir default-directory)))
- (with-parsed-tramp-file-name dir nil
- (save-match-data
- (let ((ldir (file-name-directory dir)))
- ;; Make missing directory parts
- (when (and parents (not (file-directory-p ldir)))
- (make-directory ldir parents))
- ;; Just do it
- (when (file-directory-p ldir)
- (make-directory-internal dir))
- (unless (file-directory-p dir)
- (tramp-error v 'file-error "Couldn't make directory %s" dir))))))
-
-(defun tramp-fish-handle-make-directory-internal (directory)
- "Like `make-directory-internal' for Tramp files."
- (setq directory (directory-file-name (expand-file-name directory)))
- (unless (file-name-absolute-p directory)
- (setq directory (expand-file-name directory default-directory)))
- (when (file-directory-p (file-name-directory directory))
- (with-parsed-tramp-file-name directory nil
- (save-match-data
- (unless
- (tramp-fish-send-command-and-check v (format "#MKD %s" localname))
- (tramp-error
- v 'file-error "Couldn't make directory %s" directory))))))
-
-(defun tramp-fish-handle-make-symbolic-link
- (filename linkname &optional ok-if-already-exists)
- "Like `make-symbolic-link' for Tramp files.
-If LINKNAME is a non-Tramp file, it is used verbatim as the target of
-the symlink. If LINKNAME is a Tramp file, only the localname component is
-used as the target of the symlink.
-
-If LINKNAME is a Tramp file and the localname component is relative, then
-it is expanded first, before the localname component is taken. Note that
-this can give surprising results if the user/host for the source and
-target of the symlink differ."
- (with-parsed-tramp-file-name linkname nil
- ;; Do the 'confirm if exists' thing.
- (when (file-exists-p linkname)
- ;; What to do?
- (if (or (null ok-if-already-exists) ; not allowed to exist
- (and (numberp ok-if-already-exists)
- (not (yes-or-no-p
- (format
- "File %s already exists; make it a link anyway? "
- localname)))))
- (tramp-error
- v 'file-already-exists "File %s already exists" localname)
- (delete-file linkname)))
-
- ;; If FILENAME is a Tramp name, use just the localname component.
- (when (tramp-tramp-file-p filename)
- (setq filename (tramp-file-name-localname
- (tramp-dissect-file-name (expand-file-name filename)))))
-
- ;; Right, they are on the same host, regardless of user, method, etc.
- ;; We now make the link on the remote machine. This will occur as the user
- ;; that FILENAME belongs to.
- (unless
- (tramp-fish-send-command-and-check
- v (format "#SYMLINK %s %s" filename localname))
- (tramp-error v 'file-error "Error creating symbolic link %s" linkname))))
-
-(defun tramp-fish-handle-rename-file
- (filename newname &optional ok-if-already-exists)
- "Like `rename-file' for Tramp files."
- (tramp-fish-do-copy-or-rename-file
- 'rename filename newname ok-if-already-exists t))
-
-(defun tramp-fish-handle-set-file-modes (filename mode)
- "Like `set-file-modes' for Tramp files."
- (with-parsed-tramp-file-name filename nil
- (tramp-flush-file-property v localname)
- (unless (tramp-fish-send-command-and-check
- v (format "#CHMOD %s %s"
- (tramp-decimal-to-octal mode)
- (tramp-shell-quote-argument localname)))
- (tramp-error
- v 'file-error "Error while changing file's mode %s" filename))))
-
-(defun tramp-fish-handle-set-file-times (filename &optional time)
- "Like `set-file-times' for Tramp files."
- (with-parsed-tramp-file-name filename nil
- (let ((time (if (or (null time) (equal time '(0 0))) (current-time) time)))
- (zerop (process-file
- "touch" nil nil nil "-t"
- (format-time-string "%Y%m%d%H%M.%S" time)
- (tramp-shell-quote-argument localname))))))
-
-(defun tramp-fish-handle-write-region
- (start end filename &optional append visit lockname confirm)
- "Like `write-region' for Tramp files."
- (setq filename (expand-file-name filename))
- (with-parsed-tramp-file-name filename nil
- ;; XEmacs takes a coding system as the seventh argument, not `confirm'
- (when (and (not (featurep 'xemacs))
- confirm (file-exists-p filename))
- (unless (y-or-n-p (format "File %s exists; overwrite anyway? "
- filename))
- (tramp-error v 'file-error "File not overwritten")))
-
- (tramp-flush-file-property v localname)
-
- ;; Send command
- (let ((tramp-fish-ok-prompt-regexp
- (concat
- tramp-fish-ok-prompt-regexp "\\|"
- tramp-fish-continue-prompt-regexp)))
- (tramp-fish-send-command
- v (format "%s %d %s\n### 100"
- (if append "#APPEND" "#STOR") (- end start) localname)))
-
- ;; Send data, if there are any.
- (when (> end start)
- (tramp-fish-send-command v (buffer-substring-no-properties start end)))
-
- (when (eq visit t)
- (set-visited-file-modtime))))
-
-(defun tramp-fish-handle-executable-find (command)
- "Like `executable-find' for Tramp files."
- (with-temp-buffer
- (if (zerop (process-file "which" nil t nil command))
- (progn
- (goto-char (point-min))
- (buffer-substring (point-min) (tramp-compat-line-end-position))))))
-
-(defun tramp-fish-handle-process-file
- (program &optional infile destination display &rest args)
- "Like `process-file' for Tramp files."
- ;; The implementation is not complete yet.
- (when (and (numberp destination) (zerop destination))
- (error "Implementation does not handle immediate return"))
-
- (with-parsed-tramp-file-name default-directory nil
- (let (command input tmpinput output tmpoutput stderr tmpstderr
- outbuf tmpfile ret)
- ;; Compute command.
- (setq command (mapconcat 'tramp-shell-quote-argument
- (cons program args) " "))
- ;; Determine input.
- (if (null infile)
- (setq input "/dev/null")
- (setq infile (expand-file-name infile))
- (if (tramp-equal-remote default-directory infile)
- ;; INFILE is on the same remote host.
- (setq input (with-parsed-tramp-file-name infile nil localname))
- ;; INFILE must be copied to remote host.
- (setq input (tramp-make-tramp-temp-file v)
- tmpinput (tramp-make-tramp-file-name method user host input))
- (copy-file infile tmpinput t)))
- (when input (setq command (format "%s <%s" command input)))
-
- ;; Determine output.
- (setq output (tramp-make-tramp-temp-file v)
- tmpoutput (tramp-make-tramp-file-name method user host output))
- (cond
- ;; Just a buffer
- ((bufferp destination)
- (setq outbuf destination))
- ;; A buffer name
- ((stringp destination)
- (setq outbuf (get-buffer-create destination)))
- ;; (REAL-DESTINATION ERROR-DESTINATION)
- ((consp destination)
- ;; output
- (cond
- ((bufferp (car destination))
- (setq outbuf (car destination)))
- ((stringp (car destination))
- (setq outbuf (get-buffer-create (car destination)))))
- ;; stderr
- (cond
- ((stringp (cadr destination))
- (setcar (cdr destination) (expand-file-name (cadr destination)))
- (if (tramp-equal-remote default-directory (cadr destination))
- ;; stderr is on the same remote host.
- (setq stderr (with-parsed-tramp-file-name
- (cadr destination) nil localname))
- ;; stderr must be copied to remote host. The temporary
- ;; file must be deleted after execution.
- (setq stderr (tramp-make-tramp-temp-file v)
- tmpstderr (tramp-make-tramp-file-name
- method user host stderr))))
- ;; stderr to be discarded
- ((null (cadr destination))
- (setq stderr "/dev/null"))))
- ;; 't
- (destination
- (setq outbuf (current-buffer))))
- (when stderr (setq command (format "%s 2>%s" command stderr)))
-
- ;; Goto working directory.
- (unless
- (tramp-fish-send-command-and-check
- v (format "#CWD %s" (tramp-shell-quote-argument localname)))
- (tramp-error v 'file-error "No such directory: %s" default-directory))
- ;; Send the command. It might not return in time, so we protect it.
- (condition-case nil
- (unwind-protect
- (unless (tramp-fish-send-command-and-check
- v (format
- "#EXEC %s %s"
- (tramp-shell-quote-argument command) output))
- (error nil))
- ;; Check return code.
- (setq tmpfile
- (file-local-copy
- (tramp-make-tramp-file-name method user host output)))
- (with-temp-buffer
- (insert-file-contents tmpfile)
- (goto-char (point-max))
- (forward-line -1)
- (looking-at "^###RESULT: \\([0-9]+\\)")
- (setq ret (string-to-number (match-string 1)))
- (delete-region (point) (point-max))
- (write-region (point-min) (point-max) tmpfile))
- ;; We should show the output anyway.
- (when outbuf
- (with-current-buffer outbuf (insert-file-contents tmpfile))
- (when display (display-buffer outbuf))))
- ;; When the user did interrupt, we should do it also.
- (error (setq ret 1)))
-
- ;; Provide error file.
- (when tmpstderr (rename-file tmpstderr (cadr destination) t))
- ;; Cleanup.
- (when tmpinput (delete-file tmpinput))
- (when tmpoutput (delete-file tmpoutput))
- ;; Return exit status.
- ret)))
-
-
-;; Internal file name functions
-
-(defun tramp-fish-do-copy-or-rename-file
- (op filename newname &optional ok-if-already-exists keep-date preserve-uid-gid)
- "Copy or rename a remote file.
-OP must be `copy' or `rename' and indicates the operation to
-perform. FILENAME specifies the file to copy or rename, NEWNAME
-is the name of the new file (for copy) or the new name of the
-file (for rename). OK-IF-ALREADY-EXISTS means don't barf if
-NEWNAME exists already. KEEP-DATE means to make sure that
-NEWNAME has the same timestamp as FILENAME.
-
-This function is invoked by `tramp-fish-handle-copy-file' and
-`tramp-fish-handle-rename-file'. It is an error if OP is neither
-of `copy' and `rename'. FILENAME and NEWNAME must be absolute
-file names."
- (unless (memq op '(copy rename))
- (error "Unknown operation `%s', must be `copy' or `rename'" op))
- (let ((t1 (tramp-tramp-file-p filename))
- (t2 (tramp-tramp-file-p newname)))
-
- (unless ok-if-already-exists
- (when (and t2 (file-exists-p newname))
- (with-parsed-tramp-file-name newname nil
- (tramp-error
- v 'file-already-exists "File %s already exists" newname))))
-
- (prog1
- (cond
- ;; Both are Tramp files.
- ((and t1 t2)
- (cond
- ;; Shortcut: if method, host, user are the same for both
- ;; files, we invoke `cp' or `mv' on the remote host
- ;; directly.
- ((tramp-equal-remote filename newname)
- (tramp-fish-do-copy-or-rename-file-directly
- op filename newname keep-date preserve-uid-gid))
- ;; No shortcut was possible. So we copy the
- ;; file first. If the operation was `rename', we go
- ;; back and delete the original file (if the copy was
- ;; successful). The approach is simple-minded: we
- ;; create a new buffer, insert the contents of the
- ;; source file into it, then write out the buffer to
- ;; the target file. The advantage is that it doesn't
- ;; matter which filename handlers are used for the
- ;; source and target file.
- (t
- (tramp-do-copy-or-rename-file-via-buffer
- op filename newname keep-date))))
-
- ;; One file is a Tramp file, the other one is local.
- ((or t1 t2)
- ;; Use the generic method via a Tramp buffer.
- (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")))
- ;; When newname did exist, we have wrong cached values.
- (when t2
- (with-parsed-tramp-file-name newname nil
- (tramp-flush-file-property v localname)
- (tramp-flush-file-property v (file-name-directory localname)))))))
-
-(defun tramp-fish-do-copy-or-rename-file-directly
- (op filename newname keep-date preserve-uid-gid)
- "Invokes `COPY' or `RENAME' on the remote system.
-OP must be one of `copy' or `rename', indicating `cp' or `mv',
-respectively. VEC specifies the connection. LOCALNAME1 and
-LOCALNAME2 specify the two arguments of `cp' or `mv'. If
-KEEP-DATE is non-nil, preserve the time stamp when copying.
-PRESERVE-UID-GID is completely ignored."
- (with-parsed-tramp-file-name filename v1
- (with-parsed-tramp-file-name newname v2
- (tramp-fish-send-command
- v1
- (format "%s %s %s"
- (if (eq op 'copy) "#COPY" "#RENAME")
- (tramp-shell-quote-argument v1-localname)
- (tramp-shell-quote-argument v2-localname)))))
- ;; KEEP-DATE handling.
- (when (and keep-date (functionp 'set-file-times))
- (set-file-times newname (nth 5 (file-attributes filename))))
- ;; Set the mode.
- (set-file-modes newname (tramp-default-file-modes filename)))
-
-(defun tramp-fish-get-file-entries (vec localname list)
- "Read entries returned by FISH server.
-When LIST is true, a #LIST command will be sent, including all entries
-of a directory. Otherwise, #STAT is sent for just one entry.
-Result is a list of (LOCALNAME LINK COUNT UID GID ATIME MTIME CTIME
-SIZE MODE WEIRD INODE DEVICE)."
- (block nil
- (with-current-buffer (tramp-get-buffer vec)
- ;; #LIST does not work properly with trailing "/", at least in
- ;; .fishsrv.pl.
- (when (string-match "/$" localname)
- (setq localname (concat localname ".")))
-
- (let ((command (format "%s %s" (if list "#LIST" "#STAT") localname))
- buffer-read-only num res)
-
- ;; Send command
- (tramp-fish-send-command vec command)
-
- ;; Read number of entries
- (goto-char (point-min))
- (condition-case nil
- (unless (integerp (setq num (read (current-buffer)))) (error nil))
- (error (return nil)))
- (forward-line)
- (delete-region (point-min) (point))
-
- ;; Read return code
- (goto-char (point-min))
- (condition-case nil
- (unless (looking-at tramp-fish-continue-prompt-regexp) (error nil))
- (error (return nil)))
- (forward-line)
- (delete-region (point-min) (point))
-
- ;; Loop the listing
- (dotimes (i num)
- (let ((item (tramp-fish-read-file-entry)))
- ;; Add inode and device.
- (add-to-list
- 'res (append item
- (list (tramp-get-inode vec)
- (tramp-get-device vec))))))
-
- ;; Read return code
- (goto-char (point-min))
- (condition-case nil
- (unless (looking-at tramp-fish-ok-prompt-regexp) (error nil))
- (error (tramp-error
- vec 'file-error
- "`%s' does not return a valid Lisp expression: `%s'"
- command (buffer-string))))
- (forward-line)
- (delete-region (point-min) (point))
-
- res))))
-
-(defun tramp-fish-read-file-entry ()
- "Parse entry in output buffer.
-Result is the list (LOCALNAME LINK COUNT UID GID ATIME MTIME CTIME
-SIZE MODE WEIRD)."
- ;; We are called from `tramp-fish-get-file-entries', which sets the
- ;; current buffer.
- (let (buffer-read-only localname link uid gid mtime size mode)
- (block nil
- (while t
- (cond
- ;; P<unix permissions> <owner>.<group>
- ((looking-at "^P\\(.+\\)\\s-\\(.+\\)\\.\\(.+\\)$")
- (setq mode (match-string 1))
- (setq uid (match-string 2))
- (setq gid (match-string 3))
- (when (string-match "^d" mode) (setq link t)))
- ;; S<size>
- ((looking-at "^S\\([0-9]+\\)$")
- (setq size (string-to-number (match-string 1))))
- ;; D<year> <month> <day> <hour> <minute> <second>[.1234]
- ((looking-at
- "^D\\([0-9]+\\)\\s-\\([0-9]+\\)\\s-\\([0-9]+\\)\\s-\\([0-9]+\\)\\s-\\([0-9]+\\)\\s-\\(\\S-+\\)$")
- (setq mtime
- (encode-time
- (string-to-number (match-string 6))
- (string-to-number (match-string 5))
- (string-to-number (match-string 4))
- (string-to-number (match-string 3))
- (string-to-number (match-string 2))
- (string-to-number (match-string 1)))))
- ;; d<3-letters month name> <day> <year or HH:MM>
- ((looking-at "^d") nil)
- ;; E<major-of-device>,<minor>
- ((looking-at "^E") nil)
- ;; :<filename>
- ((looking-at "^:\\(.+\\)$")
- (setq localname (match-string 1)))
- ;; L<filename symlink points to>
- ((looking-at "^L\\(.+\\)$")
- (setq link (match-string 1)))
- ;; M<mimetype>
- ((looking-at "^M\\(.+\\)$") nil)
- ;; last line
- ((looking-at "^$")
- (return)))
- ;; Delete line.
- (forward-line)
- (delete-region (point-min) (point))))
-
- ;; Delete trailing empty line.
- (forward-line)
- (delete-region (point-min) (point))
-
- ;; Return entry in `file-attributes' format.
- (list localname link -1 uid gid '(0 0) mtime '(0 0) size mode nil)))
-
-(defun tramp-fish-retrieve-data (vec)
- "Reads remote data for FISH protocol.
-The data are left in the connection buffer of VEC for further processing.
-Returns the size of the data."
- (block nil
- (with-current-buffer (tramp-get-buffer vec)
- ;; The retrieved data might be in binary format, without
- ;; trailing newline. Therefore, the OK prompt might not start
- ;; at the beginning of a line.
- (let ((tramp-fish-ok-prompt-regexp "### 200\n")
- size)
-
- ;; Send command
- (tramp-fish-send-command
- vec (format "#RETR %s" (tramp-file-name-localname vec)))
-
- ;; Read filesize
- (goto-char (point-min))
- (condition-case nil
- (unless (integerp (setq size (read (current-buffer)))) (error nil))
- (error (return nil)))
- (forward-line)
- (delete-region (point-min) (point))
-
- ;; Read return code
- (goto-char (point-min))
- (condition-case nil
- (unless (looking-at tramp-fish-continue-prompt-regexp) (error nil))
- (error (return nil)))
- (forward-line)
- (delete-region (point-min) (point))
-
- ;; The received data might contain the OK prompt already, so
- ;; there might be outstanding data.
- (while (/= (+ size (length tramp-fish-ok-prompt-regexp))
- (- (point-max) (point-min)))
- (tramp-wait-for-regexp
- (tramp-get-connection-process vec) nil
- (concat tramp-fish-ok-prompt-regexp "$")))
-
- ;; Read return code
- (goto-char (+ (point-min) size))
- (condition-case nil
- (unless (looking-at tramp-fish-ok-prompt-regexp) (error nil))
- (error (return nil)))
- (delete-region (+ (point-min) size) (point-max))
- size))))
-
-
-;; Connection functions
-
-(defun tramp-fish-maybe-open-connection (vec)
- "Maybe open a connection VEC.
-Does not do anything if a connection is already open, but re-opens the
-connection if a previous connection has died for some reason."
- (let ((process-connection-type tramp-process-connection-type)
- (p (get-buffer-process (tramp-get-buffer vec))))
-
- ;; New connection must be opened.
- (unless (and p (processp p) (memq (process-status p) '(run open)))
-
- ;; Set variables for computing the prompt for reading password.
- (setq tramp-current-method (tramp-file-name-method vec)
- tramp-current-user (tramp-file-name-user vec)
- tramp-current-host (tramp-file-name-host vec))
-
- ;; Start new process.
- (when (and p (processp p))
- (delete-process p))
- (setenv "TERM" tramp-terminal-type)
- (setenv "PS1" tramp-initial-end-of-output)
- (with-progress-reporter
- vec 3
- (format "Opening connection for %s@%s using %s"
- tramp-current-user tramp-current-host tramp-current-method)
-
- (let* ((process-connection-type tramp-process-connection-type)
- (inhibit-eol-conversion nil)
- (coding-system-for-read 'binary)
- (coding-system-for-write 'binary)
- ;; This must be done in order to avoid our file name handler.
- (p (let ((default-directory
- (tramp-compat-temporary-file-directory)))
- (start-process
- (or (tramp-get-connection-property vec "process-name" nil)
- (tramp-buffer-name vec))
- (tramp-get-connection-buffer vec)
- "ssh" "-l"
- (tramp-file-name-user vec)
- (tramp-file-name-host vec)))))
- (tramp-message
- vec 6 "%s" (mapconcat 'identity (process-command p) " "))
-
- ;; Check whether process is alive.
- (tramp-set-process-query-on-exit-flag p nil)
-
- (tramp-process-actions p vec tramp-actions-before-shell 60)
- (tramp-fish-send-command vec tramp-fish-start-fish-server-command)
- (tramp-message
- vec 3
- "Found remote shell prompt on `%s'" (tramp-file-name-host vec)))))))
-
-(defun tramp-fish-send-command (vec command)
- "Send the COMMAND to connection VEC."
- (tramp-fish-maybe-open-connection vec)
- (tramp-message vec 6 "%s" command)
- (tramp-send-string vec command)
- (tramp-wait-for-regexp
- (tramp-get-connection-process vec) nil
- (concat tramp-fish-ok-prompt-regexp "\\|" tramp-fish-error-prompt-regexp)))
-
-(defun tramp-fish-send-command-and-check (vec command)
- "Send the COMMAND to connection VEC.
-Returns nil if there has been an error message."
-
- ;; Send command.
- (tramp-fish-send-command vec command)
-
- ;; Read return code.
- (with-current-buffer (tramp-get-buffer vec)
- (goto-char (point-min))
- (looking-at tramp-fish-ok-prompt-regexp)))
-
-(provide 'tramp-fish)
-;
-;;;; TODO:
-;
-;; * Evaluate the MIME information with #LIST or #STAT.
-;
-
-;; arch-tag: a66df7df-5f29-42a7-a921-643ceb29db49
-;;;; tramp-fish.el ends here
diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el
index 4c373cbcd82..7f8b7454caf 100644
--- a/lisp/net/tramp-ftp.el
+++ b/lisp/net/tramp-ftp.el
@@ -5,6 +5,7 @@
;; Author: Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, processes
+;; Package: tramp
;; This file is part of GNU Emacs.
@@ -29,7 +30,6 @@
;;; Code:
(require 'tramp)
-(autoload 'tramp-set-connection-property "tramp-cache")
(eval-when-compile
@@ -98,13 +98,14 @@ present for backward compatibility."
(add-hook 'tramp-ftp-unload-hook 'tramp-ftp-enable-ange-ftp)
;; Define FTP method ...
-(defcustom tramp-ftp-method "ftp"
- "*When this method name is used, forward all calls to Ange-FTP."
- :group 'tramp
- :type 'string)
+;;;###tramp-autoload
+(defconst tramp-ftp-method "ftp"
+ "*When this method name is used, forward all calls to Ange-FTP.")
;; ... and add it to the method list.
-(add-to-list 'tramp-methods (cons tramp-ftp-method nil))
+;;;###tramp-autoload
+(unless (featurep 'xemacs)
+ (add-to-list 'tramp-methods (cons tramp-ftp-method nil)))
;; Add some defaults for `tramp-default-method-alist'
(add-to-list 'tramp-default-method-alist
@@ -128,6 +129,7 @@ present for backward compatibility."
(symbol-plist
'substitute-in-file-name))))))
+;;;###tramp-autoload
(defun tramp-ftp-file-name-handler (operation &rest args)
"Invoke the Ange-FTP handler for OPERATION.
First arg specifies the OPERATION, second arg is a list of arguments to
@@ -198,23 +200,26 @@ pass to the OPERATION."
(inhibit-file-name-operation operation))
(apply 'ange-ftp-hook-function operation args)))))))
-(defun tramp-ftp-file-name-p (filename)
+;;;###tramp-autoload
+(defsubst tramp-ftp-file-name-p (filename)
"Check if it's a filename that should be forwarded to Ange-FTP."
(let ((v (tramp-dissect-file-name filename)))
(string= (tramp-file-name-method v) tramp-ftp-method)))
-(add-to-list 'tramp-foreign-file-name-handler-alist
- (cons 'tramp-ftp-file-name-p 'tramp-ftp-file-name-handler))
+;;;###tramp-autoload
+(unless (featurep 'xemacs)
+ (add-to-list 'tramp-foreign-file-name-handler-alist
+ (cons 'tramp-ftp-file-name-p 'tramp-ftp-file-name-handler)))
+
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (unload-feature 'tramp-ftp 'force)))
(provide 'tramp-ftp)
;;; TODO:
-;; * In case of "/ftp:host:file" this works only for functions which
-;; are defined in `tramp-file-name-handler-alist'. Call has to be
-;; pretended in `tramp-file-name-handler' otherwise.
-;; Furthermore, there are no backup files on FTP hosts.
-;; Worth further investigations.
+;; * There are no backup files on FTP hosts.
;; arch-tag: 759fb338-5c63-4b99-bd36-b4d59db91cff
;;; tramp-ftp.el ends here
diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el
index 202eaf59835..32322680f14 100644
--- a/lisp/net/tramp-gvfs.el
+++ b/lisp/net/tramp-gvfs.el
@@ -4,6 +4,7 @@
;; Author: Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, processes
+;; Package: tramp
;; This file is part of GNU Emacs.
@@ -102,11 +103,13 @@
(require 'custom))
(require 'tramp)
+
(require 'dbus)
(require 'url-parse)
(require 'url-util)
(require 'zeroconf)
+;;;###tramp-autoload
(defcustom tramp-gvfs-methods '("dav" "davs" "obex" "synce")
"*List of methods for remote files, accessed with GVFS."
:group 'tramp
@@ -132,11 +135,11 @@
;; Add the methods to `tramp-methods', in order to allow minibuffer
;; completion.
-(eval-after-load "tramp-gvfs"
- '(when (featurep 'tramp-gvfs)
- (dolist (elt tramp-gvfs-methods)
- (unless (assoc elt tramp-methods)
- (add-to-list 'tramp-methods (cons elt nil))))))
+;;;###tramp-autoload
+(when (featurep 'dbusbind)
+ (dolist (elt tramp-gvfs-methods)
+ (unless (assoc elt tramp-methods)
+ (add-to-list 'tramp-methods (cons elt nil)))))
(defconst tramp-gvfs-path-tramp (concat dbus-path-emacs "/Tramp")
"The preceeding object path for own objects.")
@@ -144,9 +147,12 @@
(defconst tramp-gvfs-service-daemon "org.gtk.vfs.Daemon"
"The well known name of the GVFS daemon.")
-;; Check that GVFS is available.
-(unless (dbus-ping :session tramp-gvfs-service-daemon 100)
- (throw 'tramp-loading nil))
+;; Check that GVFS is available. D-Bus integration is available since
+;; Emacs 23 on some system types. We don't call `dbus-ping', because
+;; this would load dbus.el.
+(unless (and (tramp-compat-funcall 'dbus-get-unique-name :session)
+ (tramp-compat-process-running-p "gvfs-fuse-daemon"))
+ (error "Package `tramp-gvfs' not supported"))
(defconst tramp-gvfs-path-mounttracker "/org/gtk/vfs/mounttracker"
"The object path of the GVFS daemon.")
@@ -384,7 +390,7 @@ Every entry is a list (NAME ADDRESS).")
(expand-file-name . tramp-gvfs-handle-expand-file-name)
;; `file-accessible-directory-p' performed by default handler.
(file-attributes . tramp-gvfs-handle-file-attributes)
- (file-directory-p . tramp-smb-handle-file-directory-p)
+ (file-directory-p . tramp-gvfs-handle-file-directory-p)
(file-executable-p . tramp-gvfs-handle-file-executable-p)
(file-exists-p . tramp-gvfs-handle-file-exists-p)
(file-local-copy . tramp-gvfs-handle-file-local-copy)
@@ -430,13 +436,15 @@ Every entry is a list (NAME ADDRESS).")
"Alist of handler functions for Tramp GVFS method.
Operations not mentioned here will be handled by the default Emacs primitives.")
-(defun tramp-gvfs-file-name-p (filename)
+;;;###tramp-autoload
+(defsubst tramp-gvfs-file-name-p (filename)
"Check if it's a filename handled by the GVFS daemon."
(and (tramp-tramp-file-p filename)
(let ((method
(tramp-file-name-method (tramp-dissect-file-name filename))))
(and (stringp method) (member method tramp-gvfs-methods)))))
+;;;###tramp-autoload
(defun tramp-gvfs-file-name-handler (operation &rest args)
"Invoke the GVFS related OPERATION.
First arg specifies the OPERATION, second arg is a list of arguments to
@@ -448,8 +456,10 @@ pass to the OPERATION."
;; This might be moved to tramp.el. It shall be the first file name
;; handler.
-(add-to-list 'tramp-foreign-file-name-handler-alist
- (cons 'tramp-gvfs-file-name-p 'tramp-gvfs-file-name-handler))
+;;;###tramp-autoload
+(when (featurep 'dbusbind)
+ (add-to-list 'tramp-foreign-file-name-handler-alist
+ (cons 'tramp-gvfs-file-name-p 'tramp-gvfs-file-name-handler)))
(defun tramp-gvfs-stringify-dbus-message (message)
"Convert a D-Bus message into readable UTF8 strings, used for traces."
@@ -484,7 +494,8 @@ will be traced by Tramp with trace level 6."
(put 'with-tramp-dbus-call-method 'lisp-indent-function 2)
(put 'with-tramp-dbus-call-method 'edebug-form-spec '(form symbolp body))
-(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-call-method\\>"))
+(tramp-compat-font-lock-add-keywords
+ 'emacs-lisp-mode '("\\<with-tramp-dbus-call-method\\>"))
(defmacro with-tramp-gvfs-error-message (filename handler &rest args)
"Apply a Tramp GVFS `handler'.
@@ -493,7 +504,7 @@ In case of an error, modify the error message by replacing
`(let ((fuse-file-name (regexp-quote (tramp-gvfs-fuse-file-name ,filename)))
elt)
(condition-case err
- (funcall ,handler ,@args)
+ (tramp-compat-funcall ,handler ,@args)
(error
(setq elt (cdr err))
(while elt
@@ -505,7 +516,8 @@ In case of an error, modify the error message by replacing
(put 'with-tramp-gvfs-error-message 'lisp-indent-function 2)
(put 'with-tramp-gvfs-error-message 'edebug-form-spec '(form symbolp body))
-(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-gvfs-error-message\\>"))
+(tramp-compat-font-lock-add-keywords
+ 'emacs-lisp-mode '("\\<with-tramp-gvfs-error-message\\>"))
(defvar tramp-gvfs-dbus-event-vector nil
"Current Tramp file name to be used, as vector.
@@ -515,7 +527,6 @@ is no information where to trace the message.")
(defun tramp-gvfs-dbus-event-error (event err)
"Called when a D-Bus error message arrives, see `dbus-event-error-hooks'."
(when tramp-gvfs-dbus-event-vector
- ;(tramp-cleanup-connection tramp-gvfs-dbus-event-vector)
(tramp-message tramp-gvfs-dbus-event-vector 10 "%S" event)
(tramp-error tramp-gvfs-dbus-event-vector 'file-error "%s" (cadr err))))
@@ -646,6 +657,10 @@ is no information where to trace the message.")
"Like `file-attributes' for Tramp files."
(file-attributes (tramp-gvfs-fuse-file-name filename) id-format))
+(defun tramp-gvfs-handle-file-directory-p (filename)
+ "Like `file-directory-p' for Tramp files."
+ (file-directory-p (tramp-gvfs-fuse-file-name filename)))
+
(defun tramp-gvfs-handle-file-executable-p (filename)
"Like `file-executable-p' for Tramp files."
(file-executable-p (tramp-gvfs-fuse-file-name filename)))
@@ -955,7 +970,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
;; host signature.
(with-temp-buffer
;; Preserve message for `progress-reporter'.
- (with-temp-message ""
+ (tramp-compat-with-temp-message ""
(insert message)
(pop-to-buffer (current-buffer))
(setq choice (if (yes-or-no-p (concat (car choices) " ")) 0 1))
@@ -1178,7 +1193,7 @@ connection if a previous connection has died for some reason."
:name (tramp-buffer-name vec)
:buffer (tramp-get-buffer vec)
:server t :host 'local :service t)))
- (tramp-set-process-query-on-exit-flag p nil)))
+ (tramp-compat-set-process-query-on-exit-flag p nil)))
(unless (tramp-gvfs-connection-mounted-p vec)
(let* ((method (tramp-file-name-method vec))
@@ -1402,6 +1417,10 @@ They are retrieved from the hal daemon."
(tramp-set-completion-function
"synce" '((tramp-synce-parse-device-names "")))
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (unload-feature 'tramp-gvfs 'force)))
+
(provide 'tramp-gvfs)
;;; TODO:
diff --git a/lisp/net/tramp-gw.el b/lisp/net/tramp-gw.el
index d76cd3b3bce..71a23fd2d07 100644
--- a/lisp/net/tramp-gw.el
+++ b/lisp/net/tramp-gw.el
@@ -4,6 +4,7 @@
;; Author: Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, processes
+;; Package: tramp
;; This file is part of GNU Emacs.
@@ -37,11 +38,6 @@
(require 'cl)
(require 'custom))
-;; Autoload the socks library. It is used only when we access a SOCKS server.
-(autoload 'socks-open-network-stream "socks")
-(defvar socks-username (user-login-name))
-(defvar socks-server (list "Default server" "socks" 1080 5))
-
;; Avoid byte-compiler warnings if the byte-compiler supports this.
;; Currently, XEmacs supports this.
(eval-when-compile
@@ -49,21 +45,29 @@
(byte-compiler-options (warnings (- unused-vars)))))
;; Define HTTP tunnel method ...
-(defvar tramp-gw-tunnel-method "tunnel"
+;;;###tramp-autoload
+(defconst tramp-gw-tunnel-method "tunnel"
"*Method to connect HTTP gateways.")
;; ... and port.
-(defvar tramp-gw-default-tunnel-port 8080
+(defconst tramp-gw-default-tunnel-port 8080
"*Default port for HTTP gateways.")
;; Define SOCKS method ...
-(defvar tramp-gw-socks-method "socks"
+;;;###tramp-autoload
+(defconst tramp-gw-socks-method "socks"
"*Method to connect SOCKS servers.")
;; ... and port.
-(defvar tramp-gw-default-socks-port 1080
+(defconst tramp-gw-default-socks-port 1080
"*Default port for SOCKS servers.")
+;; Autoload the socks library. It is used only when we access a SOCKS server.
+(autoload 'socks-open-network-stream "socks")
+(defvar socks-username (user-login-name))
+(defvar socks-server
+ (list "Default server" "socks" tramp-gw-default-socks-port 5))
+
;; Add a default for `tramp-default-user-alist'. Default is the local user.
(add-to-list 'tramp-default-user-alist
`(,tramp-gw-tunnel-method nil ,(user-login-name)))
@@ -103,7 +107,7 @@
tramp-gw-vector 4
"Opening auxiliary process `%s', speaking with process `%s'"
proc tramp-gw-gw-proc)
- (tramp-set-process-query-on-exit-flag proc nil)
+ (tramp-compat-set-process-query-on-exit-flag proc nil)
;; We don't want debug messages, because the corresponding debug
;; buffer might be undecided.
(let (tramp-verbose)
@@ -124,6 +128,7 @@
(process-send-string
(tramp-get-connection-property proc "process" nil) string)))
+;;;###tramp-autoload
(defun tramp-gw-open-connection (vec gw-vec target-vec)
"Open a remote connection to VEC (see `tramp-file-name' structure).
Take GW-VEC as SOCKS or HTTP gateway, i.e. its method must be a
@@ -149,7 +154,7 @@ instead of the host name declared in TARGET-VEC."
:name (tramp-buffer-name aux-vec) :buffer nil :host 'local
:server t :noquery t :service t :coding 'binary))
(set-process-sentinel tramp-gw-aux-proc 'tramp-gw-aux-proc-sentinel)
- (tramp-set-process-query-on-exit-flag tramp-gw-aux-proc nil)
+ (tramp-compat-set-process-query-on-exit-flag tramp-gw-aux-proc nil)
(tramp-message
vec 4 "Opening auxiliary process `%s', listening on port %d"
tramp-gw-aux-proc (process-contact tramp-gw-aux-proc :service))))
@@ -194,7 +199,7 @@ instead of the host name declared in TARGET-VEC."
(tramp-file-name-real-host target-vec)
(tramp-file-name-port target-vec)))
(set-process-sentinel tramp-gw-gw-proc 'tramp-gw-gw-proc-sentinel)
- (tramp-set-process-query-on-exit-flag tramp-gw-gw-proc nil)
+ (tramp-compat-set-process-query-on-exit-flag tramp-gw-gw-proc nil)
(tramp-message
vec 4 "Opened %s process `%s'"
(case gw-method ('tunnel "HTTP tunnel") ('socks "SOCKS"))
@@ -225,7 +230,7 @@ authentication is requested from proxy server, provide it."
(setq proc (open-network-stream
name buffer (nth 1 socks-server) (nth 2 socks-server)))
(set-process-coding-system proc 'binary 'binary)
- (tramp-set-process-query-on-exit-flag proc nil)
+ (tramp-compat-set-process-query-on-exit-flag proc nil)
;; Send CONNECT command.
(process-send-string proc (format "%s%s\r\n" command authentication))
(tramp-message
@@ -238,10 +243,9 @@ authentication is requested from proxy server, provide it."
;; Trap errors to be traced in the right trace buffer. Often,
;; proxies have a timeout of 60". We wait 65" in order to
;; receive an answer this case.
- (condition-case nil
- (let (tramp-verbose)
- (tramp-wait-for-regexp proc 65 "\r?\n\r?\n"))
- (error nil))
+ (ignore-errors
+ (let (tramp-verbose)
+ (tramp-wait-for-regexp proc 65 "\r?\n\r?\n")))
;; Check return code.
(goto-char (point-min))
(narrow-to-region
@@ -309,6 +313,9 @@ password in password cache. This is done for the first try only."
(format
"Password for %s@[%s]: " socks-username (read (current-buffer)))))))))
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (unload-feature 'tramp-gw 'force)))
(provide 'tramp-gw)
diff --git a/lisp/net/tramp-imap.el b/lisp/net/tramp-imap.el
index 3e8883d2e07..dade2052126 100644
--- a/lisp/net/tramp-imap.el
+++ b/lisp/net/tramp-imap.el
@@ -4,6 +4,7 @@
;; Author: Teodor Zlatanov <tzz@lifelogs.com>
;; Keywords: mail, comm
+;; Package: tramp
;; This file is part of GNU Emacs.
@@ -54,7 +55,6 @@
(require 'assoc)
(require 'tramp)
-(require 'tramp-compat)
(autoload 'auth-source-user-or-password "auth-source")
(autoload 'epg-context-operation "epg")
@@ -75,21 +75,29 @@
'(add-to-list 'imap-hash-headers 'X-Size 'append))
;; Define Tramp IMAP method ...
+;;;###tramp-autoload
(defconst tramp-imap-method "imap"
"*Method to connect via IMAP protocol.")
-(add-to-list 'tramp-methods (list tramp-imap-method '(tramp-default-port 143)))
+;;;###tramp-autoload
+(when (and (locate-library "epa") (locate-library "imap-hash"))
+ (add-to-list 'tramp-methods
+ (list tramp-imap-method '(tramp-default-port 143))))
;; Add a default for `tramp-default-user-alist'. Default is the local user.
(add-to-list 'tramp-default-user-alist
`(,tramp-imap-method nil ,(user-login-name)))
;; Define Tramp IMAPS method ...
+;;;###tramp-autoload
(defconst tramp-imaps-method "imaps"
"*Method to connect via secure IMAP protocol.")
;; ... and add it to the method list.
-(add-to-list 'tramp-methods (list tramp-imaps-method '(tramp-default-port 993)))
+;;;###tramp-autoload
+(when (and (locate-library "epa") (locate-library "imap-hash"))
+ (add-to-list 'tramp-methods
+ (list tramp-imaps-method '(tramp-default-port 993))))
;; Add a default for `tramp-default-user-alist'. Default is the local user.
(add-to-list 'tramp-default-user-alist
@@ -114,7 +122,7 @@
(directory-file-name . tramp-handle-directory-file-name)
(directory-files . tramp-handle-directory-files)
(directory-files-and-attributes
- . tramp-imap-handle-directory-files-and-attributes)
+ . tramp-handle-directory-files-and-attributes)
(dired-call-process . ignore)
;; `dired-compress-file' performed by default handler
;; `dired-uncache' performed by default handler
@@ -122,8 +130,8 @@
;; `file-accessible-directory-p' performed by default handler
(file-attributes . tramp-imap-handle-file-attributes)
(file-directory-p . tramp-imap-handle-file-directory-p)
- (file-executable-p . tramp-imap-handle-file-executable-p)
- (file-exists-p . tramp-imap-handle-file-exists-p)
+ (file-executable-p . ignore)
+ (file-exists-p . tramp-handle-file-exists-p)
(file-local-copy . tramp-imap-handle-file-local-copy)
(file-modes . tramp-handle-file-modes)
(file-name-all-completions . tramp-imap-handle-file-name-all-completions)
@@ -132,9 +140,9 @@
(file-name-directory . tramp-handle-file-name-directory)
(file-name-nondirectory . tramp-handle-file-name-nondirectory)
;; `file-name-sans-versions' performed by default handler
- (file-newer-than-file-p . tramp-imap-handle-file-newer-than-file-p)
+ (file-newer-than-file-p . tramp-handle-file-newer-than-file-p)
(file-ownership-preserved-p . ignore)
- (file-readable-p . tramp-imap-handle-file-readable-p)
+ (file-readable-p . tramp-handle-file-exists-p)
(file-regular-p . tramp-handle-file-regular-p)
(file-remote-p . tramp-handle-file-remote-p)
;; `file-selinux-context' performed by default handler.
@@ -183,13 +191,15 @@ Operations not mentioned here will be handled by the default Emacs primitives.")
(defvar tramp-imap-passphrase-cache nil) ;; can be t or 'never
(defvar tramp-imap-passphrase nil)
-(defun tramp-imap-file-name-p (filename)
+;;;###tramp-autoload
+(defsubst tramp-imap-file-name-p (filename)
"Check if it's a filename for IMAP protocol."
(let ((v (tramp-dissect-file-name filename)))
(or
(string= (tramp-file-name-method v) tramp-imap-method)
(string= (tramp-file-name-method v) tramp-imaps-method))))
+;;;###tramp-autoload
(defun tramp-imap-file-name-handler (operation &rest args)
"Invoke the IMAP related OPERATION.
First arg specifies the OPERATION, second arg is a list of arguments to
@@ -199,8 +209,10 @@ pass to the OPERATION."
(save-match-data (apply (cdr fn) args))
(tramp-run-real-handler operation args))))
-(add-to-list 'tramp-foreign-file-name-handler-alist
- (cons 'tramp-imap-file-name-p 'tramp-imap-file-name-handler))
+;;;###tramp-autoload
+(when (and (locate-library "epa") (locate-library "imap-hash"))
+ (add-to-list 'tramp-foreign-file-name-handler-alist
+ (cons 'tramp-imap-file-name-p 'tramp-imap-file-name-handler)))
(defun tramp-imap-handle-copy-file
(filename newname &optional ok-if-already-exists keep-date
@@ -514,10 +526,6 @@ SIZE MODE WEIRD INODE DEVICE)."
(goto-char point)
(list (expand-file-name filename) size))))))
-(defun tramp-imap-handle-file-exists-p (filename)
- "Like `file-exists-p' for Tramp files."
- (and (file-attributes filename) t))
-
(defun tramp-imap-handle-file-directory-p (filename)
"Like `file-directory-p' for Tramp-IMAP files."
;; We allow only mailboxes to be a directory.
@@ -537,14 +545,6 @@ SIZE MODE WEIRD INODE DEVICE)."
"Get inode equivalent \(actually the UID) for Tramp-IMAP FILENAME."
(nth 10 (tramp-compat-file-attributes filename id-format)))
-(defun tramp-imap-handle-file-executable-p (filename)
- "Like `file-executable-p' for Tramp files. False for IMAP."
- nil)
-
-(defun tramp-imap-handle-file-readable-p (filename)
- "Like `file-readable-p' for Tramp files. True for IMAP."
- (file-exists-p filename))
-
(defun tramp-imap-handle-file-writable-p (filename)
"Like `file-writable-p' for Tramp files. True for IMAP."
;; `file-exists-p' does not work yet for directories.
@@ -559,24 +559,6 @@ SIZE MODE WEIRD INODE DEVICE)."
(let ((iht (tramp-imap-make-iht v)))
(imap-hash-rem (tramp-imap-get-file-inode filename) iht))))))
-(defun tramp-imap-handle-directory-files-and-attributes
- (directory &optional full match nosort id-format)
- "Like `directory-files-and-attributes' for Tramp files."
- (mapcar
- (lambda (x)
- (cons x (tramp-compat-file-attributes
- (if full x (expand-file-name x directory)) id-format)))
- (directory-files directory full match nosort)))
-
-;; TODO: fix this in tramp-imap-get-file-entries.
-(defun tramp-imap-handle-file-newer-than-file-p (file1 file2)
- "Like `file-newer-than-file-p' for Tramp files."
- (cond
- ((not (file-exists-p file1)) nil)
- ((not (file-exists-p file2)) t)
- (t (tramp-time-less-p (nth 5 (file-attributes file2))
- (nth 5 (file-attributes file1))))))
-
(defun tramp-imap-handle-file-local-copy (filename)
"Like `file-local-copy' for Tramp files."
(with-parsed-tramp-file-name (expand-file-name filename) nil
@@ -775,6 +757,10 @@ With NEEDED-SUBJECT, alters the imap-hash test accordingly."
tramp-imap-subject-marker
(if needed-subject needed-subject "")))))
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (unload-feature 'tramp-imap 'force)))
+
;;; TODO:
;; * Implement `tramp-imap-handle-delete-directory',
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
new file mode 100644
index 00000000000..3f503836177
--- /dev/null
+++ b/lisp/net/tramp-sh.el
@@ -0,0 +1,5040 @@
+;;; tramp-sh.el --- Tramp access functions for (s)sh-like connections
+
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; (copyright statements below in code to be updated with the above notice)
+
+;; Author: Kai Großjohann <kai.grossjohann@gmx.net>
+;; Michael Albinus <michael.albinus@gmx.de>
+;; Keywords: comm, processes
+;; Package: tramp
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(eval-when-compile (require 'cl)) ; ignore-errors
+(require 'tramp)
+(require 'shell)
+
+;; Pacify byte-compiler. The function is needed on XEmacs only. I'm
+;; not sure at all that this is the right way to do it, but let's hope
+;; it works for now, and wait for a guru to point out the Right Way to
+;; achieve this.
+;;(eval-when-compile
+;; (unless (fboundp 'dired-insert-set-properties)
+;; (fset 'dired-insert-set-properties 'ignore)))
+;; Gerd suggests this:
+(eval-when-compile (require 'dired))
+;; Note that dired is required at run-time, too, when it is needed.
+;; It is only needed on XEmacs for the function
+;; `dired-insert-set-properties'.
+
+(defcustom tramp-inline-compress-start-size 4096
+ "*The minimum size of compressing where inline transfer.
+When inline transfer, compress transfered data of file
+whose size is this value or above (up to `tramp-copy-size-limit').
+If it is nil, no compression at all will be applied."
+ :group 'tramp
+ :type '(choice (const nil) integer))
+
+(defcustom tramp-copy-size-limit 10240
+ "*The maximum file size where inline copying is preferred over an out-of-the-band copy.
+If it is nil, inline out-of-the-band copy will be used without a check."
+ :group 'tramp
+ :type '(choice (const nil) integer))
+
+;;;###tramp-autoload
+(defcustom tramp-terminal-type "dumb"
+ "*Value of TERM environment variable for logging in to remote host.
+Because Tramp wants to parse the output of the remote shell, it is easily
+confused by ANSI color escape sequences and suchlike. Often, shell init
+files conditionalize this setup based on the TERM environment variable."
+ :group 'tramp
+ :type 'string)
+
+;; ksh on OpenBSD 4.5 requires, that $PS1 contains a `#' character for
+;; root users. It uses the `$' character for other users. In order
+;; to guarantee a proper prompt, we use "#$" for the prompt.
+
+(defvar tramp-end-of-output
+ (format
+ "///%s#$"
+ (md5 (concat (prin1-to-string process-environment) (current-time-string))))
+ "String used to recognize end of output.
+The '$' character at the end is quoted; the string cannot be
+detected as prompt when being sent on echoing hosts, therefore.")
+
+;;;###tramp-autoload
+(defconst tramp-initial-end-of-output "#$ "
+ "Prompt when establishing a connection.")
+
+;; Initialize `tramp-methods' with the supported methods.
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("rcp"
+ (tramp-login-program "rsh")
+ (tramp-login-args (("%h") ("-l" "%u")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-copy-program "rcp")
+ (tramp-copy-args (("-p" "%k") ("-r")))
+ (tramp-copy-keep-date t)
+ (tramp-copy-recursive t)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("remcp"
+ (tramp-login-program "remsh")
+ (tramp-login-args (("%h") ("-l" "%u")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-copy-program "rcp")
+ (tramp-copy-args (("-p" "%k")))
+ (tramp-copy-keep-date t)))
+;;;###tramp-autoload
+(add-to-list
+ 'tramp-methods
+ '("scp"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p") ("-e" "none") ("%h")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-copy-program "scp")
+ (tramp-copy-args (("-P" "%p") ("-p" "%k") ("-q") ("-r")))
+ (tramp-copy-keep-date t)
+ (tramp-copy-recursive t)
+ (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null")
+ ("-o" "UserKnownHostsFile=/dev/null")
+ ("-o" "StrictHostKeyChecking=no")))
+ (tramp-default-port 22)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("scp1"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p")
+ ("-1") ("-e" "none") ("%h")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-copy-program "scp")
+ (tramp-copy-args (("-1") ("-P" "%p") ("-p" "%k") ("-q") ("-r")))
+ (tramp-copy-keep-date t)
+ (tramp-copy-recursive t)
+ (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null")
+ ("-o" "UserKnownHostsFile=/dev/null")
+ ("-o" "StrictHostKeyChecking=no")))
+ (tramp-default-port 22)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("scp2"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p")
+ ("-2") ("-e" "none") ("%h")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-copy-program "scp")
+ (tramp-copy-args (("-2") ("-P" "%p") ("-p" "%k") ("-q") ("-r")))
+ (tramp-copy-keep-date t)
+ (tramp-copy-recursive t)
+ (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null")
+ ("-o" "UserKnownHostsFile=/dev/null")
+ ("-o" "StrictHostKeyChecking=no")))
+ (tramp-default-port 22)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("scpc"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p")
+ ("-o" "ControlPath=%t.%%r@%%h:%%p")
+ ("-o" "ControlMaster=yes")
+ ("-e" "none") ("%h")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-copy-program "scp")
+ (tramp-copy-args (("-P" "%p") ("-p" "%k") ("-q")
+ ("-o" "ControlPath=%t.%%r@%%h:%%p")
+ ("-o" "ControlMaster=auto")))
+ (tramp-copy-keep-date t)
+ (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null")
+ ("-o" "UserKnownHostsFile=/dev/null")
+ ("-o" "StrictHostKeyChecking=no")))
+ (tramp-default-port 22)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("scpx"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p")
+ ("-e" "none") ("-t" "-t")
+ ("%h") ("/bin/sh")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-copy-program "scp")
+ (tramp-copy-args (("-p" "%k")))
+ (tramp-copy-keep-date t)
+ (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null")
+ ("-o" "UserKnownHostsFile=/dev/null")
+ ("-o" "StrictHostKeyChecking=no")))
+ (tramp-default-port 22)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("sftp"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p") ("-e" "none") ("%h")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-copy-program "sftp")))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("rsync"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p") ("-e" "none") ("%h")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-copy-program "rsync")
+ (tramp-copy-args (("-e" "ssh") ("-t" "%k") ("-r")))
+ (tramp-copy-keep-date t)
+ (tramp-copy-keep-tmpfile t)
+ (tramp-copy-recursive t)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ `("rsyncc"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p")
+ ("-o" "ControlPath=%t.%%r@%%h:%%p")
+ ("-o" "ControlMaster=yes")
+ ("-e" "none") ("%h")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-copy-program "rsync")
+ (tramp-copy-args (("-t" "%k") ("-r")))
+ (tramp-copy-env (("RSYNC_RSH")
+ (,(concat
+ "ssh"
+ " -o ControlPath=%t.%%r@%%h:%%p"
+ " -o ControlMaster=auto"))))
+ (tramp-copy-keep-date t)
+ (tramp-copy-keep-tmpfile t)
+ (tramp-copy-recursive t)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("rsh"
+ (tramp-login-program "rsh")
+ (tramp-login-args (("%h") ("-l" "%u")))
+ (tramp-remote-sh "/bin/sh")))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("remsh"
+ (tramp-login-program "remsh")
+ (tramp-login-args (("%h") ("-l" "%u")))
+ (tramp-remote-sh "/bin/sh")))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("ssh"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p") ("-e" "none") ("%h")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null")
+ ("-o" "UserKnownHostsFile=/dev/null")
+ ("-o" "StrictHostKeyChecking=no")))
+ (tramp-default-port 22)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("ssh1"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p")
+ ("-1") ("-e" "none") ("%h")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null")
+ ("-o" "UserKnownHostsFile=/dev/null")
+ ("-o" "StrictHostKeyChecking=no")))
+ (tramp-default-port 22)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("ssh2"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p")
+ ("-2") ("-e" "none") ("%h")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null")
+ ("-o" "UserKnownHostsFile=/dev/null")
+ ("-o" "StrictHostKeyChecking=no")))
+ (tramp-default-port 22)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("sshx"
+ (tramp-login-program "ssh")
+ (tramp-login-args (("-l" "%u") ("-p" "%p")
+ ("-e" "none") ("-t" "-t")
+ ("%h") ("/bin/sh")))
+ (tramp-async-args (("-q")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null")
+ ("-o" "UserKnownHostsFile=/dev/null")
+ ("-o" "StrictHostKeyChecking=no")))
+ (tramp-default-port 22)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("telnet"
+ (tramp-login-program "telnet")
+ (tramp-login-args (("%h") ("%p")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-default-port 23)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("su"
+ (tramp-login-program "su")
+ (tramp-login-args (("-") ("%u")))
+ (tramp-remote-sh "/bin/sh")))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("sudo"
+ (tramp-login-program "sudo")
+ (tramp-login-args (("-u" "%u") ("-s") ("-H") ("-p" "Password:")))
+ (tramp-remote-sh "/bin/sh")))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("krlogin"
+ (tramp-login-program "krlogin")
+ (tramp-login-args (("%h") ("-l" "%u") ("-x")))
+ (tramp-remote-sh "/bin/sh")))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("plink"
+ (tramp-login-program "plink")
+ (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%h")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-password-end-of-line "xy") ;see docstring for "xy"
+ (tramp-default-port 22)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("plink1"
+ (tramp-login-program "plink")
+ (tramp-login-args (("-l" "%u") ("-P" "%p") ("-1" "-ssh") ("%h")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-password-end-of-line "xy") ;see docstring for "xy"
+ (tramp-default-port 22)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ `("plinkx"
+ (tramp-login-program "plink")
+ ;; ("%h") must be a single element, see
+ ;; `tramp-compute-multi-hops'.
+ (tramp-login-args (("-load") ("%h") ("-t")
+ (,(format
+ "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'"
+ tramp-terminal-type
+ tramp-initial-end-of-output))
+ ("/bin/sh")))
+ (tramp-remote-sh "/bin/sh")))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("pscp"
+ (tramp-login-program "plink")
+ (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%h")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-copy-program "pscp")
+ (tramp-copy-args (("-P" "%p") ("-scp") ("-p" "%k")))
+ (tramp-copy-keep-date t)
+ (tramp-password-end-of-line "xy") ;see docstring for "xy"
+ (tramp-default-port 22)))
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("psftp"
+ (tramp-login-program "plink")
+ (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%h")))
+ (tramp-remote-sh "/bin/sh")
+ (tramp-copy-program "pscp")
+ (tramp-copy-args (("-P" "%p") ("-sftp") ("-p" "%k")))
+ (tramp-copy-keep-date t)
+ (tramp-password-end-of-line "xy"))) ;see docstring for "xy"
+;;;###tramp-autoload
+(add-to-list 'tramp-methods
+ '("fcp"
+ (tramp-login-program "fsh")
+ (tramp-login-args (("%h") ("-l" "%u") ("sh" "-i")))
+ (tramp-remote-sh "/bin/sh -i")
+ (tramp-copy-program "fcp")
+ (tramp-copy-args (("-p" "%k")))
+ (tramp-copy-keep-date t)))
+
+(add-to-list 'tramp-default-method-alist
+ `(,tramp-local-host-regexp "\\`root\\'" "su"))
+
+(add-to-list 'tramp-default-user-alist
+ '("\\`su\\(do\\)?\\'" nil "root"))
+(add-to-list 'tramp-default-user-alist
+ `("\\`r\\(em\\)?\\(cp\\|sh\\)\\|telnet\\|plink1?\\'"
+ nil ,(user-login-name)))
+
+(defconst tramp-completion-function-alist-rsh
+ '((tramp-parse-rhosts "/etc/hosts.equiv")
+ (tramp-parse-rhosts "~/.rhosts"))
+ "Default list of (FUNCTION FILE) pairs to be examined for rsh methods.")
+
+(defconst tramp-completion-function-alist-ssh
+ '((tramp-parse-rhosts "/etc/hosts.equiv")
+ (tramp-parse-rhosts "/etc/shosts.equiv")
+ (tramp-parse-shosts "/etc/ssh_known_hosts")
+ (tramp-parse-sconfig "/etc/ssh_config")
+ (tramp-parse-shostkeys "/etc/ssh2/hostkeys")
+ (tramp-parse-sknownhosts "/etc/ssh2/knownhosts")
+ (tramp-parse-rhosts "~/.rhosts")
+ (tramp-parse-rhosts "~/.shosts")
+ (tramp-parse-shosts "~/.ssh/known_hosts")
+ (tramp-parse-sconfig "~/.ssh/config")
+ (tramp-parse-shostkeys "~/.ssh2/hostkeys")
+ (tramp-parse-sknownhosts "~/.ssh2/knownhosts"))
+ "Default list of (FUNCTION FILE) pairs to be examined for ssh methods.")
+
+(defconst tramp-completion-function-alist-telnet
+ '((tramp-parse-hosts "/etc/hosts"))
+ "Default list of (FUNCTION FILE) pairs to be examined for telnet methods.")
+
+(defconst tramp-completion-function-alist-su
+ '((tramp-parse-passwd "/etc/passwd"))
+ "Default list of (FUNCTION FILE) pairs to be examined for su methods.")
+
+(defconst tramp-completion-function-alist-putty
+ '((tramp-parse-putty
+ "HKEY_CURRENT_USER\\Software\\SimonTatham\\PuTTY\\Sessions"))
+ "Default list of (FUNCTION REGISTRY) pairs to be examined for putty methods.")
+
+(tramp-set-completion-function "rcp" tramp-completion-function-alist-rsh)
+(tramp-set-completion-function "remcp" tramp-completion-function-alist-rsh)
+(tramp-set-completion-function "scp" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "scp1" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "scp2" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "scpc" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "scpx" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "sftp" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "rsync" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "rsyncc" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "rsh" tramp-completion-function-alist-rsh)
+(tramp-set-completion-function "remsh" tramp-completion-function-alist-rsh)
+(tramp-set-completion-function "ssh" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "ssh1" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "ssh2" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "ssh1_old" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "ssh2_old" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "sshx" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "telnet" tramp-completion-function-alist-telnet)
+(tramp-set-completion-function "su" tramp-completion-function-alist-su)
+(tramp-set-completion-function "sudo" tramp-completion-function-alist-su)
+(tramp-set-completion-function "krlogin" tramp-completion-function-alist-rsh)
+(tramp-set-completion-function "plink" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "plink1" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "plinkx" tramp-completion-function-alist-putty)
+(tramp-set-completion-function "pscp" tramp-completion-function-alist-ssh)
+(tramp-set-completion-function "fcp" tramp-completion-function-alist-ssh)
+
+;; "getconf PATH" yields:
+;; HP-UX: /usr/bin:/usr/ccs/bin:/opt/ansic/bin:/opt/langtools/bin:/opt/fortran/bin
+;; Solaris: /usr/xpg4/bin:/usr/ccs/bin:/usr/bin:/opt/SUNWspro/bin
+;; GNU/Linux (Debian, Suse): /bin:/usr/bin
+;; FreeBSD: /usr/bin:/bin:/usr/sbin:/sbin: - beware trailing ":"!
+;; IRIX64: /usr/bin
+(defcustom tramp-remote-path
+ '(tramp-default-remote-path "/usr/sbin" "/usr/local/bin"
+ "/local/bin" "/local/freeware/bin" "/local/gnu/bin"
+ "/usr/freeware/bin" "/usr/pkg/bin" "/usr/contrib/bin")
+ "*List of directories to search for executables on remote host.
+For every remote host, this variable will be set buffer local,
+keeping the list of existing directories on that host.
+
+You can use `~' in this list, but when searching for a shell which groks
+tilde expansion, all directory names starting with `~' will be ignored.
+
+`Default Directories' represent the list of directories given by
+the command \"getconf PATH\". It is recommended to use this
+entry on top of this list, because these are the default
+directories for POSIX compatible commands.
+
+`Private Directories' are the settings of the $PATH environment,
+as given in your `~/.profile'."
+ :group 'tramp
+ :type '(repeat (choice
+ (const :tag "Default Directories" tramp-default-remote-path)
+ (const :tag "Private Directories" tramp-own-remote-path)
+ (string :tag "Directory"))))
+
+(defcustom tramp-remote-process-environment
+ `("HISTFILE=$HOME/.tramp_history" "HISTSIZE=1" "LC_ALL=C"
+ ,(format "TERM=%s" tramp-terminal-type)
+ "EMACS=t" ;; Deprecated.
+ ,(format "INSIDE_EMACS='%s,tramp:%s'" emacs-version tramp-version)
+ "CDPATH=" "HISTORY=" "MAIL=" "MAILCHECK=" "MAILPATH="
+ "autocorrect=" "correct=")
+
+ "*List of environment variables to be set on the remote host.
+
+Each element should be a string of the form ENVVARNAME=VALUE. An
+entry ENVVARNAME= diables the corresponding environment variable,
+which might have been set in the init files like ~/.profile.
+
+Special handling is applied to the PATH environment, which should
+not be set here. Instead of, it should be set via `tramp-remote-path'."
+ :group 'tramp
+ :type '(repeat string))
+
+(defcustom tramp-sh-extra-args '(("/bash\\'" . "-norc -noprofile"))
+ "*Alist specifying extra arguments to pass to the remote shell.
+Entries are (REGEXP . ARGS) where REGEXP is a regular expression
+matching the shell file name and ARGS is a string specifying the
+arguments.
+
+This variable is only used when Tramp needs to start up another shell
+for tilde expansion. The extra arguments should typically prevent the
+shell from reading its init file."
+ :group 'tramp
+ ;; This might be the wrong way to test whether the widget type
+ ;; `alist' is available. Who knows the right way to test it?
+ :type (if (get 'alist 'widget-type)
+ '(alist :key-type string :value-type string)
+ '(repeat (cons string string))))
+
+(defconst tramp-actions-before-shell
+ '((tramp-login-prompt-regexp tramp-action-login)
+ (tramp-password-prompt-regexp tramp-action-password)
+ (tramp-wrong-passwd-regexp tramp-action-permission-denied)
+ (shell-prompt-pattern tramp-action-succeed)
+ (tramp-shell-prompt-pattern tramp-action-succeed)
+ (tramp-yesno-prompt-regexp tramp-action-yesno)
+ (tramp-yn-prompt-regexp tramp-action-yn)
+ (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).
+
+The PATTERN should be a symbol, a variable. The value of this
+variable gives the regular expression to search for. Note that the
+regexp must match at the end of the buffer, \"\\'\" is implicitly
+appended to it.
+
+The ACTION should also be a symbol, but a function. When the
+corresponding PATTERN matches, the ACTION function is called.")
+
+(defconst tramp-actions-copy-out-of-band
+ '((tramp-password-prompt-regexp tramp-action-password)
+ (tramp-wrong-passwd-regexp tramp-action-permission-denied)
+ (tramp-copy-failed-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.")
+
+(defconst tramp-uudecode
+ "(echo begin 600 /tmp/tramp.$$; tail +2) | uudecode
+cat /tmp/tramp.$$
+rm -f /tmp/tramp.$$"
+ "Shell function to implement `uudecode' to standard output.
+Many systems support `uudecode -o /dev/stdout' or `uudecode -o -'
+for this or `uudecode -p', but some systems don't, and for them
+we have this shell function.")
+
+(defconst tramp-perl-file-truename
+ "%s -e '
+use File::Spec;
+use Cwd \"realpath\";
+
+sub recursive {
+ my ($volume, @dirs) = @_;
+ my $real = realpath(File::Spec->catpath(
+ $volume, File::Spec->catdir(@dirs), \"\"));
+ if ($real) {
+ my ($vol, $dir) = File::Spec->splitpath($real, 1);
+ return ($vol, File::Spec->splitdir($dir));
+ }
+ else {
+ my $last = pop(@dirs);
+ ($volume, @dirs) = recursive($volume, @dirs);
+ push(@dirs, $last);
+ return ($volume, @dirs);
+ }
+}
+
+$result = realpath($ARGV[0]);
+if (!$result) {
+ my ($vol, $dir) = File::Spec->splitpath($ARGV[0], 1);
+ ($vol, @dirs) = recursive($vol, File::Spec->splitdir($dir));
+
+ $result = File::Spec->catpath($vol, File::Spec->catdir(@dirs), \"\");
+}
+
+if ($ARGV[0] =~ /\\/$/) {
+ $result = $result . \"/\";
+}
+
+print \"\\\"$result\\\"\\n\";
+' \"$1\" 2>/dev/null"
+ "Perl script to produce output suitable for use with `file-truename'
+on the remote file system.
+Escape sequence %s is replaced with name of Perl binary.
+This string is passed to `format', so percent characters need to be doubled.")
+
+(defconst tramp-perl-file-name-all-completions
+ "%s -e 'sub case {
+ my $str = shift;
+ if ($ARGV[2]) {
+ return lc($str);
+ }
+ else {
+ return $str;
+ }
+}
+opendir(d, $ARGV[0]) || die(\"$ARGV[0]: $!\\nfail\\n\");
+@files = readdir(d); closedir(d);
+foreach $f (@files) {
+ if (case(substr($f, 0, length($ARGV[1]))) eq case($ARGV[1])) {
+ if (-d \"$ARGV[0]/$f\") {
+ print \"$f/\\n\";
+ }
+ else {
+ print \"$f\\n\";
+ }
+ }
+}
+print \"ok\\n\"
+' \"$1\" \"$2\" \"$3\" 2>/dev/null"
+ "Perl script to produce output suitable for use with
+`file-name-all-completions' on the remote file system. Escape
+sequence %s is replaced with name of Perl binary. This string is
+passed to `format', so percent characters need to be doubled.")
+
+;; Perl script to implement `file-attributes' in a Lisp `read'able
+;; output. If you are hacking on this, note that you get *no* output
+;; unless this spits out a complete line, including the '\n' at the
+;; end.
+;; The device number is returned as "-1", because there will be a virtual
+;; device number set in `tramp-sh-handle-file-attributes'.
+(defconst tramp-perl-file-attributes
+ "%s -e '
+@stat = lstat($ARGV[0]);
+if (!@stat) {
+ print \"nil\\n\";
+ exit 0;
+}
+if (($stat[2] & 0170000) == 0120000)
+{
+ $type = readlink($ARGV[0]);
+ $type = \"\\\"$type\\\"\";
+}
+elsif (($stat[2] & 0170000) == 040000)
+{
+ $type = \"t\";
+}
+else
+{
+ $type = \"nil\"
+};
+$uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\";
+$gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\";
+printf(
+ \"(%%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u.0 %%u t (%%u . %%u) -1)\\n\",
+ $type,
+ $stat[3],
+ $uid,
+ $gid,
+ $stat[8] >> 16 & 0xffff,
+ $stat[8] & 0xffff,
+ $stat[9] >> 16 & 0xffff,
+ $stat[9] & 0xffff,
+ $stat[10] >> 16 & 0xffff,
+ $stat[10] & 0xffff,
+ $stat[7],
+ $stat[2],
+ $stat[1] >> 16 & 0xffff,
+ $stat[1] & 0xffff
+);' \"$1\" \"$2\" 2>/dev/null"
+ "Perl script to produce output suitable for use with `file-attributes'
+on the remote file system.
+Escape sequence %s is replaced with name of Perl binary.
+This string is passed to `format', so percent characters need to be doubled.")
+
+(defconst tramp-perl-directory-files-and-attributes
+ "%s -e '
+chdir($ARGV[0]) or printf(\"\\\"Cannot change to $ARGV[0]: $''!''\\\"\\n\"), exit();
+opendir(DIR,\".\") or printf(\"\\\"Cannot open directory $ARGV[0]: $''!''\\\"\\n\"), exit();
+@list = readdir(DIR);
+closedir(DIR);
+$n = scalar(@list);
+printf(\"(\\n\");
+for($i = 0; $i < $n; $i++)
+{
+ $filename = $list[$i];
+ @stat = lstat($filename);
+ if (($stat[2] & 0170000) == 0120000)
+ {
+ $type = readlink($filename);
+ $type = \"\\\"$type\\\"\";
+ }
+ elsif (($stat[2] & 0170000) == 040000)
+ {
+ $type = \"t\";
+ }
+ else
+ {
+ $type = \"nil\"
+ };
+ $uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\";
+ $gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\";
+ printf(
+ \"(\\\"%%s\\\" %%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u.0 %%u t (%%u . %%u) (%%u . %%u))\\n\",
+ $filename,
+ $type,
+ $stat[3],
+ $uid,
+ $gid,
+ $stat[8] >> 16 & 0xffff,
+ $stat[8] & 0xffff,
+ $stat[9] >> 16 & 0xffff,
+ $stat[9] & 0xffff,
+ $stat[10] >> 16 & 0xffff,
+ $stat[10] & 0xffff,
+ $stat[7],
+ $stat[2],
+ $stat[1] >> 16 & 0xffff,
+ $stat[1] & 0xffff,
+ $stat[0] >> 16 & 0xffff,
+ $stat[0] & 0xffff);
+}
+printf(\")\\n\");' \"$1\" \"$2\" 2>/dev/null"
+ "Perl script implementing `directory-files-attributes' as Lisp `read'able
+output.
+Escape sequence %s is replaced with name of Perl binary.
+This string is passed to `format', so percent characters need to be doubled.")
+
+;; These two use base64 encoding.
+(defconst tramp-perl-encode-with-module
+ "%s -MMIME::Base64 -0777 -ne 'print encode_base64($_)' 2>/dev/null"
+ "Perl program to use for encoding a file.
+Escape sequence %s is replaced with name of Perl binary.
+This string is passed to `format', so percent characters need to be doubled.
+This implementation requires the MIME::Base64 Perl module to be installed
+on the remote host.")
+
+(defconst tramp-perl-decode-with-module
+ "%s -MMIME::Base64 -0777 -ne 'print decode_base64($_)' 2>/dev/null"
+ "Perl program to use for decoding a file.
+Escape sequence %s is replaced with name of Perl binary.
+This string is passed to `format', so percent characters need to be doubled.
+This implementation requires the MIME::Base64 Perl module to be installed
+on the remote host.")
+
+(defconst tramp-perl-encode
+ "%s -e '
+# This script contributed by Juanma Barranquero <lektu@terra.es>.
+# Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+# Free Software Foundation, Inc.
+use strict;
+
+my %%trans = do {
+ my $i = 0;
+ map {(substr(unpack(q(B8), chr $i++), 2, 6), $_)}
+ split //, q(ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/);
+};
+
+binmode(\\*STDIN);
+
+# We read in chunks of 54 bytes, to generate output lines
+# of 72 chars (plus end of line)
+$/ = \\54;
+
+while (my $data = <STDIN>) {
+ my $pad = q();
+
+ # Only for the last chunk, and only if did not fill the last three-byte packet
+ if (eof) {
+ my $mod = length($data) %% 3;
+ $pad = q(=) x (3 - $mod) if $mod;
+ }
+
+ # Not the fastest method, but it is simple: unpack to binary string, split
+ # by groups of 6 bits and convert back from binary to byte; then map into
+ # the translation table
+ print
+ join q(),
+ map($trans{$_},
+ (substr(unpack(q(B*), $data) . q(00000), 0, 432) =~ /....../g)),
+ $pad,
+ qq(\\n);
+}' 2>/dev/null"
+ "Perl program to use for encoding a file.
+Escape sequence %s is replaced with name of Perl binary.
+This string is passed to `format', so percent characters need to be doubled.")
+
+(defconst tramp-perl-decode
+ "%s -e '
+# This script contributed by Juanma Barranquero <lektu@terra.es>.
+# Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+# Free Software Foundation, Inc.
+use strict;
+
+my %%trans = do {
+ my $i = 0;
+ map {($_, substr(unpack(q(B8), chr $i++), 2, 6))}
+ split //, q(ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/)
+};
+
+my %%bytes = map {(unpack(q(B8), chr $_), chr $_)} 0 .. 255;
+
+binmode(\\*STDOUT);
+
+# We are going to accumulate into $pending to accept any line length
+# (we do not check they are <= 76 chars as the RFC says)
+my $pending = q();
+
+while (my $data = <STDIN>) {
+ chomp $data;
+
+ # If we find one or two =, we have reached the end and
+ # any following data is to be discarded
+ my $finished = $data =~ s/(==?).*/$1/;
+ $pending .= $data;
+
+ my $len = length($pending);
+ my $chunk = substr($pending, 0, $len & ~3);
+ $pending = substr($pending, $len & ~3 + 1);
+
+ # Easy method: translate from chars to (pregenerated) six-bit packets, join,
+ # split in 8-bit chunks and convert back to char.
+ print join q(),
+ map $bytes{$_},
+ ((join q(), map {$trans{$_} || q()} split //, $chunk) =~ /......../g);
+
+ last if $finished;
+}' 2>/dev/null"
+ "Perl program to use for decoding a file.
+Escape sequence %s is replaced with name of Perl binary.
+This string is passed to `format', so percent characters need to be doubled.")
+
+(defconst tramp-vc-registered-read-file-names
+ "echo \"(\"
+while read file; do
+ if %s \"$file\"; then
+ echo \"(\\\"$file\\\" \\\"file-exists-p\\\" t)\"
+ else
+ echo \"(\\\"$file\\\" \\\"file-exists-p\\\" nil)\"
+ fi
+ if %s \"$file\"; then
+ echo \"(\\\"$file\\\" \\\"file-readable-p\\\" t)\"
+ else
+ echo \"(\\\"$file\\\" \\\"file-readable-p\\\" nil)\"
+ fi
+done
+echo \")\""
+ "Script to check existence of VC related files.
+It must be send formatted with two strings; the tests for file
+existence, and file readability. Input shall be read via
+here-document, otherwise the command could exceed maximum length
+of command line.")
+
+(defconst tramp-file-mode-type-map
+ '((0 . "-") ; Normal file (SVID-v2 and XPG2)
+ (1 . "p") ; fifo
+ (2 . "c") ; character device
+ (3 . "m") ; multiplexed character device (v7)
+ (4 . "d") ; directory
+ (5 . "?") ; Named special file (XENIX)
+ (6 . "b") ; block device
+ (7 . "?") ; multiplexed block device (v7)
+ (8 . "-") ; regular file
+ (9 . "n") ; network special file (HP-UX)
+ (10 . "l") ; symlink
+ (11 . "?") ; ACL shadow inode (Solaris, not userspace)
+ (12 . "s") ; socket
+ (13 . "D") ; door special (Solaris)
+ (14 . "w")) ; whiteout (BSD)
+ "A list of file types returned from the `stat' system call.
+This is used to map a mode number to a permission string.")
+
+;; New handlers should be added here. The following operations can be
+;; handled using the normal primitives: file-name-sans-versions,
+;; get-file-buffer.
+(defconst tramp-sh-file-name-handler-alist
+ '((load . tramp-handle-load)
+ (make-symbolic-link . tramp-sh-handle-make-symbolic-link)
+ (file-name-as-directory . tramp-handle-file-name-as-directory)
+ (file-name-directory . tramp-handle-file-name-directory)
+ (file-name-nondirectory . tramp-handle-file-name-nondirectory)
+ (file-truename . tramp-sh-handle-file-truename)
+ (file-exists-p . tramp-sh-handle-file-exists-p)
+ (file-directory-p . tramp-sh-handle-file-directory-p)
+ (file-executable-p . tramp-sh-handle-file-executable-p)
+ (file-readable-p . tramp-sh-handle-file-readable-p)
+ (file-regular-p . tramp-handle-file-regular-p)
+ (file-symlink-p . tramp-handle-file-symlink-p)
+ (file-writable-p . tramp-sh-handle-file-writable-p)
+ (file-ownership-preserved-p . tramp-sh-handle-file-ownership-preserved-p)
+ (file-newer-than-file-p . tramp-sh-handle-file-newer-than-file-p)
+ (file-attributes . tramp-sh-handle-file-attributes)
+ (file-modes . tramp-handle-file-modes)
+ (directory-files . tramp-handle-directory-files)
+ (directory-files-and-attributes
+ . tramp-sh-handle-directory-files-and-attributes)
+ (file-name-all-completions . tramp-sh-handle-file-name-all-completions)
+ (file-name-completion . tramp-handle-file-name-completion)
+ (add-name-to-file . tramp-sh-handle-add-name-to-file)
+ (copy-file . tramp-sh-handle-copy-file)
+ (copy-directory . tramp-sh-handle-copy-directory)
+ (rename-file . tramp-sh-handle-rename-file)
+ (set-file-modes . tramp-sh-handle-set-file-modes)
+ (set-file-times . tramp-sh-handle-set-file-times)
+ (make-directory . tramp-sh-handle-make-directory)
+ (delete-directory . tramp-sh-handle-delete-directory)
+ (delete-file . tramp-sh-handle-delete-file)
+ (directory-file-name . tramp-handle-directory-file-name)
+ ;; `executable-find' is not official yet.
+ (executable-find . tramp-sh-handle-executable-find)
+ (start-file-process . tramp-sh-handle-start-file-process)
+ (process-file . tramp-sh-handle-process-file)
+ (shell-command . tramp-sh-handle-shell-command)
+ (insert-directory . tramp-sh-handle-insert-directory)
+ (expand-file-name . tramp-sh-handle-expand-file-name)
+ (substitute-in-file-name . tramp-handle-substitute-in-file-name)
+ (file-local-copy . tramp-sh-handle-file-local-copy)
+ (file-remote-p . tramp-handle-file-remote-p)
+ (insert-file-contents . tramp-handle-insert-file-contents)
+ (insert-file-contents-literally
+ . tramp-sh-handle-insert-file-contents-literally)
+ (write-region . tramp-sh-handle-write-region)
+ (find-backup-file-name . tramp-handle-find-backup-file-name)
+ (make-auto-save-file-name . tramp-sh-handle-make-auto-save-file-name)
+ (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory)
+ (dired-compress-file . tramp-sh-handle-dired-compress-file)
+ (dired-recursive-delete-directory
+ . tramp-sh-handle-dired-recursive-delete-directory)
+ (dired-uncache . tramp-handle-dired-uncache)
+ (set-visited-file-modtime . tramp-sh-handle-set-visited-file-modtime)
+ (verify-visited-file-modtime . tramp-sh-handle-verify-visited-file-modtime)
+ (file-selinux-context . tramp-sh-handle-file-selinux-context)
+ (set-file-selinux-context . tramp-sh-handle-set-file-selinux-context)
+ (vc-registered . tramp-sh-handle-vc-registered))
+ "Alist of handler functions.
+Operations not mentioned here will be handled by the normal Emacs functions.")
+
+;; This must be the last entry, because `identity' always matches.
+;;;###tramp-autoload
+(add-to-list 'tramp-foreign-file-name-handler-alist
+ '(identity . tramp-sh-file-name-handler) 'append)
+
+;;; File Name Handler Functions:
+
+(defun tramp-sh-handle-make-symbolic-link
+ (filename linkname &optional ok-if-already-exists)
+ "Like `make-symbolic-link' for Tramp files.
+If LINKNAME is a non-Tramp file, it is used verbatim as the target of
+the symlink. If LINKNAME is a Tramp file, only the localname component is
+used as the target of the symlink.
+
+If LINKNAME is a Tramp file and the localname component is relative, then
+it is expanded first, before the localname component is taken. Note that
+this can give surprising results if the user/host for the source and
+target of the symlink differ."
+ (with-parsed-tramp-file-name linkname l
+ (let ((ln (tramp-get-remote-ln l))
+ (cwd (tramp-run-real-handler
+ 'file-name-directory (list l-localname))))
+ (unless ln
+ (tramp-error
+ l 'file-error
+ "Making a symbolic link. ln(1) does not exist on the remote host."))
+
+ ;; Do the 'confirm if exists' thing.
+ (when (file-exists-p linkname)
+ ;; What to do?
+ (if (or (null ok-if-already-exists) ; not allowed to exist
+ (and (numberp ok-if-already-exists)
+ (not (yes-or-no-p
+ (format
+ "File %s already exists; make it a link anyway? "
+ l-localname)))))
+ (tramp-error
+ l 'file-already-exists "File %s already exists" l-localname)
+ (delete-file linkname)))
+
+ ;; If FILENAME is a Tramp name, use just the localname component.
+ (when (tramp-tramp-file-p filename)
+ (setq filename
+ (tramp-file-name-localname
+ (tramp-dissect-file-name (expand-file-name filename)))))
+
+ (tramp-flush-file-property l (file-name-directory l-localname))
+ (tramp-flush-file-property l l-localname)
+
+ ;; Right, they are on the same host, regardless of user, method, etc.
+ ;; We now make the link on the remote machine. This will occur as the user
+ ;; that FILENAME belongs to.
+ (tramp-send-command-and-check
+ l
+ (format
+ "cd %s && %s -sf %s %s"
+ (tramp-shell-quote-argument cwd)
+ ln
+ (tramp-shell-quote-argument filename)
+ (tramp-shell-quote-argument l-localname))
+ t))))
+
+(defun tramp-sh-handle-file-truename (filename &optional counter prev-dirs)
+ "Like `file-truename' for Tramp files."
+ (with-parsed-tramp-file-name (expand-file-name filename) nil
+ (with-file-property v localname "file-truename"
+ (let ((result nil)) ; result steps in reverse order
+ (tramp-message v 4 "Finding true name for `%s'" filename)
+ (cond
+ ;; Use GNU readlink --canonicalize-missing where available.
+ ((tramp-get-remote-readlink v)
+ (setq result
+ (tramp-send-command-and-read
+ v
+ (format "echo \"\\\"`%s --canonicalize-missing %s`\\\"\""
+ (tramp-get-remote-readlink v)
+ (tramp-shell-quote-argument localname)))))
+
+ ;; Use Perl implementation.
+ ((and (tramp-get-remote-perl v)
+ (tramp-get-connection-property v "perl-file-spec" nil)
+ (tramp-get-connection-property v "perl-cwd-realpath" nil))
+ (tramp-maybe-send-script
+ v tramp-perl-file-truename "tramp_perl_file_truename")
+ (setq result
+ (tramp-send-command-and-read
+ v
+ (format "tramp_perl_file_truename %s"
+ (tramp-shell-quote-argument localname)))))
+
+ ;; Do it yourself. We bind `directory-sep-char' here for
+ ;; XEmacs on Windows, which would otherwise use backslash.
+ (t (let* ((directory-sep-char ?/)
+ (steps (tramp-compat-split-string localname "/"))
+ (localnamedir (tramp-run-real-handler
+ 'file-name-as-directory (list localname)))
+ (is-dir (string= localname localnamedir))
+ (thisstep nil)
+ (numchase 0)
+ ;; Don't make the following value larger than
+ ;; necessary. People expect an error message in a
+ ;; timely fashion when something is wrong;
+ ;; otherwise they might think that Emacs is hung.
+ ;; Of course, correctness has to come first.
+ (numchase-limit 20)
+ symlink-target)
+ (while (and steps (< numchase numchase-limit))
+ (setq thisstep (pop steps))
+ (tramp-message
+ v 5 "Check %s"
+ (mapconcat 'identity
+ (append '("") (reverse result) (list thisstep))
+ "/"))
+ (setq symlink-target
+ (nth 0 (file-attributes
+ (tramp-make-tramp-file-name
+ method user host
+ (mapconcat 'identity
+ (append '("")
+ (reverse result)
+ (list thisstep))
+ "/")))))
+ (cond ((string= "." thisstep)
+ (tramp-message v 5 "Ignoring step `.'"))
+ ((string= ".." thisstep)
+ (tramp-message v 5 "Processing step `..'")
+ (pop result))
+ ((stringp symlink-target)
+ ;; It's a symlink, follow it.
+ (tramp-message v 5 "Follow symlink to %s" symlink-target)
+ (setq numchase (1+ numchase))
+ (when (file-name-absolute-p symlink-target)
+ (setq result nil))
+ ;; If the symlink was absolute, we'll get a string like
+ ;; "/user@host:/some/target"; extract the
+ ;; "/some/target" part from it.
+ (when (tramp-tramp-file-p symlink-target)
+ (unless (tramp-equal-remote filename symlink-target)
+ (tramp-error
+ v 'file-error
+ "Symlink target `%s' on wrong host" symlink-target))
+ (setq symlink-target localname))
+ (setq steps
+ (append (tramp-compat-split-string
+ symlink-target "/")
+ steps)))
+ (t
+ ;; It's a file.
+ (setq result (cons thisstep result)))))
+ (when (>= numchase numchase-limit)
+ (tramp-error
+ v 'file-error
+ "Maximum number (%d) of symlinks exceeded" numchase-limit))
+ (setq result (reverse result))
+ ;; Combine list to form string.
+ (setq result
+ (if result
+ (mapconcat 'identity (cons "" result) "/")
+ "/"))
+ (when (and is-dir (or (string= "" result)
+ (not (string= (substring result -1) "/"))))
+ (setq result (concat result "/"))))))
+
+ (tramp-message v 4 "True name of `%s' is `%s'" filename result)
+ (tramp-make-tramp-file-name method user host result)))))
+
+;; Basic functions.
+
+(defun tramp-sh-handle-file-exists-p (filename)
+ "Like `file-exists-p' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (with-file-property v localname "file-exists-p"
+ (or (not (null (tramp-get-file-property
+ v localname "file-attributes-integer" nil)))
+ (not (null (tramp-get-file-property
+ v localname "file-attributes-string" nil)))
+ (tramp-send-command-and-check
+ v
+ (format
+ "%s %s"
+ (tramp-get-file-exists-command v)
+ (tramp-shell-quote-argument localname)))))))
+
+;; CCC: This should check for an error condition and signal failure
+;; when something goes wrong.
+;; Daniel Pittman <daniel@danann.net>
+(defun tramp-sh-handle-file-attributes (filename &optional id-format)
+ "Like `file-attributes' for Tramp files."
+ (unless id-format (setq id-format 'integer))
+ ;; Don't modify `last-coding-system-used' by accident.
+ (let ((last-coding-system-used last-coding-system-used))
+ (with-parsed-tramp-file-name (expand-file-name filename) nil
+ (with-file-property v localname (format "file-attributes-%s" id-format)
+ (save-excursion
+ (tramp-convert-file-attributes
+ v
+ (cond
+ ((tramp-get-remote-stat v)
+ (tramp-do-file-attributes-with-stat v localname id-format))
+ ((tramp-get-remote-perl v)
+ (tramp-do-file-attributes-with-perl v localname id-format))
+ (t
+ (tramp-do-file-attributes-with-ls v localname id-format)))))))))
+
+(defun tramp-do-file-attributes-with-ls (vec localname &optional id-format)
+ "Implement `file-attributes' for Tramp files using the ls(1) command."
+ (let (symlinkp dirp
+ res-inode res-filemodes res-numlinks
+ res-uid res-gid res-size res-symlink-target)
+ (tramp-message vec 5 "file attributes with ls: %s" localname)
+ (tramp-send-command
+ vec
+ (format "(%s %s || %s -h %s) && %s %s %s"
+ (tramp-get-file-exists-command vec)
+ (tramp-shell-quote-argument localname)
+ (tramp-get-test-command vec)
+ (tramp-shell-quote-argument localname)
+ (tramp-get-ls-command vec)
+ (if (eq id-format 'integer) "-ildn" "-ild")
+ (tramp-shell-quote-argument localname)))
+ ;; parse `ls -l' output ...
+ (with-current-buffer (tramp-get-buffer vec)
+ (when (> (buffer-size) 0)
+ (goto-char (point-min))
+ ;; ... inode
+ (setq res-inode
+ (condition-case err
+ (read (current-buffer))
+ (invalid-read-syntax
+ (when (and (equal (cadr err)
+ "Integer constant overflow in reader")
+ (string-match
+ "^[0-9]+\\([0-9][0-9][0-9][0-9][0-9]\\)\\'"
+ (car (cddr err))))
+ (let* ((big (read (substring (car (cddr err)) 0
+ (match-beginning 1))))
+ (small (read (match-string 1 (car (cddr err)))))
+ (twiddle (/ small 65536)))
+ (cons (+ big twiddle)
+ (- small (* twiddle 65536))))))))
+ ;; ... file mode flags
+ (setq res-filemodes (symbol-name (read (current-buffer))))
+ ;; ... number links
+ (setq res-numlinks (read (current-buffer)))
+ ;; ... uid and gid
+ (setq res-uid (read (current-buffer)))
+ (setq res-gid (read (current-buffer)))
+ (if (eq id-format 'integer)
+ (progn
+ (unless (numberp res-uid) (setq res-uid -1))
+ (unless (numberp res-gid) (setq res-gid -1)))
+ (progn
+ (unless (stringp res-uid) (setq res-uid (symbol-name res-uid)))
+ (unless (stringp res-gid) (setq res-gid (symbol-name res-gid)))))
+ ;; ... size
+ (setq res-size (read (current-buffer)))
+ ;; From the file modes, figure out other stuff.
+ (setq symlinkp (eq ?l (aref res-filemodes 0)))
+ (setq dirp (eq ?d (aref res-filemodes 0)))
+ ;; if symlink, find out file name pointed to
+ (when symlinkp
+ (search-forward "-> ")
+ (setq res-symlink-target (buffer-substring (point) (point-at-eol))))
+ ;; return data gathered
+ (list
+ ;; 0. t for directory, string (name linked to) for symbolic
+ ;; link, or nil.
+ (or dirp res-symlink-target)
+ ;; 1. Number of links to file.
+ res-numlinks
+ ;; 2. File uid.
+ res-uid
+ ;; 3. File gid.
+ res-gid
+ ;; 4. Last access time, as a list of two integers. First
+ ;; integer has high-order 16 bits of time, second has low 16
+ ;; bits.
+ ;; 5. Last modification time, likewise.
+ ;; 6. Last status change time, likewise.
+ '(0 0) '(0 0) '(0 0) ;CCC how to find out?
+ ;; 7. Size in bytes (-1, if number is out of range).
+ res-size
+ ;; 8. File modes, as a string of ten letters or dashes as in ls -l.
+ res-filemodes
+ ;; 9. t if file's gid would change if file were deleted and
+ ;; recreated. Will be set in `tramp-convert-file-attributes'
+ t
+ ;; 10. inode number.
+ res-inode
+ ;; 11. Device number. Will be replaced by a virtual device number.
+ -1
+ )))))
+
+(defun tramp-do-file-attributes-with-perl
+ (vec localname &optional id-format)
+ "Implement `file-attributes' for Tramp files using a Perl script."
+ (tramp-message vec 5 "file attributes with perl: %s" localname)
+ (tramp-maybe-send-script
+ vec tramp-perl-file-attributes "tramp_perl_file_attributes")
+ (tramp-send-command-and-read
+ vec
+ (format "tramp_perl_file_attributes %s %s"
+ (tramp-shell-quote-argument localname) id-format)))
+
+(defun tramp-do-file-attributes-with-stat
+ (vec localname &optional id-format)
+ "Implement `file-attributes' for Tramp files using stat(1) command."
+ (tramp-message vec 5 "file attributes with stat: %s" localname)
+ (tramp-send-command-and-read
+ vec
+ (format
+ ;; On Opsware, pdksh (which is the true name of ksh there) doesn't
+ ;; parse correctly the sequence "((". Therefore, we add a space.
+ "( (%s %s || %s -h %s) && %s -c '((\"%%N\") %%h %s %s %%Xe0 %%Ye0 %%Ze0 %%se0 \"%%A\" t %%ie0 -1)' %s || echo nil)"
+ (tramp-get-file-exists-command vec)
+ (tramp-shell-quote-argument localname)
+ (tramp-get-test-command vec)
+ (tramp-shell-quote-argument localname)
+ (tramp-get-remote-stat vec)
+ (if (eq id-format 'integer) "%u" "\"%U\"")
+ (if (eq id-format 'integer) "%g" "\"%G\"")
+ (tramp-shell-quote-argument localname))))
+
+(defun tramp-sh-handle-set-visited-file-modtime (&optional time-list)
+ "Like `set-visited-file-modtime' for Tramp files."
+ (unless (buffer-file-name)
+ (error "Can't set-visited-file-modtime: buffer `%s' not visiting a file"
+ (buffer-name)))
+ (if time-list
+ (tramp-run-real-handler 'set-visited-file-modtime (list time-list))
+ (let ((f (buffer-file-name))
+ coding-system-used)
+ (with-parsed-tramp-file-name f nil
+ (let* ((attr (file-attributes f))
+ ;; '(-1 65535) means file doesn't exists yet.
+ (modtime (or (nth 5 attr) '(-1 65535))))
+ (when (boundp 'last-coding-system-used)
+ (setq coding-system-used (symbol-value 'last-coding-system-used)))
+ ;; We use '(0 0) as a don't-know value. See also
+ ;; `tramp-do-file-attributes-with-ls'.
+ (if (not (equal modtime '(0 0)))
+ (tramp-run-real-handler 'set-visited-file-modtime (list modtime))
+ (progn
+ (tramp-send-command
+ v
+ (format "%s -ild %s"
+ (tramp-get-ls-command v)
+ (tramp-shell-quote-argument localname)))
+ (setq attr (buffer-substring (point)
+ (progn (end-of-line) (point)))))
+ (tramp-set-file-property
+ v localname "visited-file-modtime-ild" attr))
+ (when (boundp 'last-coding-system-used)
+ (set 'last-coding-system-used coding-system-used))
+ nil)))))
+
+;; This function makes the same assumption as
+;; `tramp-sh-handle-set-visited-file-modtime'.
+(defun tramp-sh-handle-verify-visited-file-modtime (buf)
+ "Like `verify-visited-file-modtime' for Tramp files.
+At the time `verify-visited-file-modtime' calls this function, we
+already know that the buffer is visiting a file and that
+`visited-file-modtime' does not return 0. Do not call this
+function directly, unless those two cases are already taken care
+of."
+ (with-current-buffer buf
+ (let ((f (buffer-file-name)))
+ ;; There is no file visiting the buffer, or the buffer has no
+ ;; recorded last modification time, or there is no established
+ ;; connection.
+ (if (or (not f)
+ (eq (visited-file-modtime) 0)
+ (not (tramp-file-name-handler 'file-remote-p f nil 'connected)))
+ t
+ (with-parsed-tramp-file-name f nil
+ (let* ((remote-file-name-inhibit-cache t)
+ (attr (file-attributes f))
+ (modtime (nth 5 attr))
+ (mt (visited-file-modtime)))
+
+ (cond
+ ;; File exists, and has a known modtime.
+ ((and attr (not (equal modtime '(0 0))))
+ (< (abs (tramp-time-diff
+ modtime
+ ;; For compatibility, deal with both the old
+ ;; (HIGH . LOW) and the new (HIGH LOW) return
+ ;; values of `visited-file-modtime'.
+ (if (atom (cdr mt))
+ (list (car mt) (cdr mt))
+ mt)))
+ 2))
+ ;; Modtime has the don't know value.
+ (attr
+ (tramp-send-command
+ v
+ (format "%s -ild %s"
+ (tramp-get-ls-command v)
+ (tramp-shell-quote-argument localname)))
+ (with-current-buffer (tramp-get-buffer v)
+ (setq attr (buffer-substring
+ (point) (progn (end-of-line) (point)))))
+ (equal
+ attr
+ (tramp-get-file-property
+ v localname "visited-file-modtime-ild" "")))
+ ;; If file does not exist, say it is not modified if and
+ ;; only if that agrees with the buffer's record.
+ (t (equal mt '(-1 65535))))))))))
+
+(defun tramp-sh-handle-set-file-modes (filename mode)
+ "Like `set-file-modes' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (tramp-flush-file-property v localname)
+ ;; FIXME: extract the proper text from chmod's stderr.
+ (tramp-barf-unless-okay
+ v
+ (format "chmod %s %s"
+ (tramp-compat-decimal-to-octal mode)
+ (tramp-shell-quote-argument localname))
+ "Error while changing file's mode %s" filename)))
+
+(defun tramp-sh-handle-set-file-times (filename &optional time)
+ "Like `set-file-times' for Tramp files."
+ (if (file-remote-p filename)
+ (with-parsed-tramp-file-name filename nil
+ (tramp-flush-file-property v localname)
+ (let ((time (if (or (null time) (equal time '(0 0)))
+ (current-time)
+ time))
+ ;; With GNU Emacs, `format-time-string' has an optional
+ ;; parameter UNIVERSAL. This is preferred, because we
+ ;; could handle the case when the remote host is located
+ ;; in a different time zone as the local host.
+ (utc (not (featurep 'xemacs))))
+ (tramp-send-command-and-check
+ v (format "%s touch -t %s %s"
+ (if utc "TZ=UTC; export TZ;" "")
+ (if utc
+ (format-time-string "%Y%m%d%H%M.%S" time t)
+ (format-time-string "%Y%m%d%H%M.%S" time))
+ (tramp-shell-quote-argument localname)))))
+
+ ;; We handle also the local part, because in older Emacsen,
+ ;; without `set-file-times', this function is an alias for this.
+ ;; We are local, so we don't need the UTC settings.
+ (zerop
+ (tramp-compat-call-process
+ "touch" nil nil nil "-t"
+ (format-time-string "%Y%m%d%H%M.%S" time)
+ (tramp-shell-quote-argument filename)))))
+
+(defun tramp-set-file-uid-gid (filename &optional uid gid)
+ "Set the ownership for FILENAME.
+If UID and GID are provided, these values are used; otherwise uid
+and gid of the corresponding user is taken. Both parameters must be integers."
+ ;; Modern Unices allow chown only for root. So we might need
+ ;; another implementation, see `dired-do-chown'. OTOH, it is mostly
+ ;; working with su(do)? when it is needed, so it shall succeed in
+ ;; the majority of cases.
+ ;; Don't modify `last-coding-system-used' by accident.
+ (let ((last-coding-system-used last-coding-system-used))
+ (if (file-remote-p filename)
+ (with-parsed-tramp-file-name filename nil
+ (if (and (zerop (user-uid)) (tramp-local-host-p v))
+ ;; If we are root on the local host, we can do it directly.
+ (tramp-set-file-uid-gid localname uid gid)
+ (let ((uid (or (and (integerp uid) uid)
+ (tramp-get-remote-uid v 'integer)))
+ (gid (or (and (integerp gid) gid)
+ (tramp-get-remote-gid v 'integer))))
+ (tramp-send-command
+ v (format
+ "chown %d:%d %s" uid gid
+ (tramp-shell-quote-argument localname))))))
+
+ ;; We handle also the local part, because there doesn't exist
+ ;; `set-file-uid-gid'. On W32 "chown" might not work.
+ (let ((uid (or (and (integerp uid) uid) (tramp-get-local-uid 'integer)))
+ (gid (or (and (integerp gid) gid) (tramp-get-local-gid 'integer))))
+ (tramp-compat-call-process
+ "chown" nil nil nil
+ (format "%d:%d" uid gid) (tramp-shell-quote-argument filename))))))
+
+(defun tramp-remote-selinux-p (vec)
+ "Check, whether SELINUX is enabled on the remote host."
+ (with-connection-property (tramp-get-connection-process vec) "selinux-p"
+ (let ((result (tramp-find-executable
+ vec "getenforce" (tramp-get-remote-path vec) t t)))
+ (and result
+ (string-equal
+ (tramp-send-command-and-read
+ vec (format "echo \\\"`%S`\\\"" result))
+ "Enforcing")))))
+
+(defun tramp-sh-handle-file-selinux-context (filename)
+ "Like `file-selinux-context' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (with-file-property v localname "file-selinux-context"
+ (let ((context '(nil nil nil nil))
+ (regexp (concat "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\):"
+ "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\)")))
+ (when (and (tramp-remote-selinux-p v)
+ (tramp-send-command-and-check
+ v (format
+ "%s -d -Z %s"
+ (tramp-get-ls-command v)
+ (tramp-shell-quote-argument localname))))
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (goto-char (point-min))
+ (when (re-search-forward regexp (point-at-eol) t)
+ (setq context (list (match-string 1) (match-string 2)
+ (match-string 3) (match-string 4))))))
+ ;; Return the context.
+ context))))
+
+(defun tramp-sh-handle-set-file-selinux-context (filename context)
+ "Like `set-file-selinux-context' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (if (and (consp context)
+ (tramp-remote-selinux-p v)
+ (tramp-send-command-and-check
+ v (format "chcon %s %s %s %s %s"
+ (if (stringp (nth 0 context))
+ (format "--user=%s" (nth 0 context)) "")
+ (if (stringp (nth 1 context))
+ (format "--role=%s" (nth 1 context)) "")
+ (if (stringp (nth 2 context))
+ (format "--type=%s" (nth 2 context)) "")
+ (if (stringp (nth 3 context))
+ (format "--range=%s" (nth 3 context)) "")
+ (tramp-shell-quote-argument localname))))
+ (tramp-set-file-property v localname "file-selinux-context" context)
+ (tramp-set-file-property v localname "file-selinux-context" 'undef)))
+ ;; We always return nil.
+ nil)
+
+;; Simple functions using the `test' command.
+
+(defun tramp-sh-handle-file-executable-p (filename)
+ "Like `file-executable-p' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (with-file-property v localname "file-executable-p"
+ ;; Examine `file-attributes' cache to see if request can be
+ ;; satisfied without remote operation.
+ (or (tramp-check-cached-permissions v ?x)
+ (tramp-run-test "-x" filename)))))
+
+(defun tramp-sh-handle-file-readable-p (filename)
+ "Like `file-readable-p' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (with-file-property v localname "file-readable-p"
+ ;; Examine `file-attributes' cache to see if request can be
+ ;; satisfied without remote operation.
+ (or (tramp-check-cached-permissions v ?r)
+ (tramp-run-test "-r" filename)))))
+
+;; When the remote shell is started, it looks for a shell which groks
+;; tilde expansion. Here, we assume that all shells which grok tilde
+;; expansion will also provide a `test' command which groks `-nt' (for
+;; newer than). If this breaks, tell me about it and I'll try to do
+;; something smarter about it.
+(defun tramp-sh-handle-file-newer-than-file-p (file1 file2)
+ "Like `file-newer-than-file-p' for Tramp files."
+ (cond ((not (file-exists-p file1))
+ nil)
+ ((not (file-exists-p file2))
+ t)
+ ;; We are sure both files exist at this point.
+ (t
+ (save-excursion
+ ;; We try to get the mtime of both files. If they are not
+ ;; equal to the "dont-know" value, then we subtract the times
+ ;; and obtain the result.
+ (let ((fa1 (file-attributes file1))
+ (fa2 (file-attributes file2)))
+ (if (and (not (equal (nth 5 fa1) '(0 0)))
+ (not (equal (nth 5 fa2) '(0 0))))
+ (> 0 (tramp-time-diff (nth 5 fa2) (nth 5 fa1)))
+ ;; If one of them is the dont-know value, then we can
+ ;; still try to run a shell command on the remote host.
+ ;; However, this only works if both files are Tramp
+ ;; files and both have the same method, same user, same
+ ;; host.
+ (unless (tramp-equal-remote file1 file2)
+ (with-parsed-tramp-file-name
+ (if (tramp-tramp-file-p file1) file1 file2) nil
+ (tramp-error
+ v 'file-error
+ "Files %s and %s must have same method, user, host"
+ file1 file2)))
+ (with-parsed-tramp-file-name file1 nil
+ (tramp-run-test2
+ (tramp-get-test-nt-command v) file1 file2))))))))
+
+;; Functions implemented using the basic functions above.
+
+(defun tramp-sh-handle-file-directory-p (filename)
+ "Like `file-directory-p' for Tramp files."
+ ;; Care must be taken that this function returns `t' for symlinks
+ ;; pointing to directories. Surely the most obvious implementation
+ ;; would be `test -d', but that returns false for such symlinks.
+ ;; CCC: Stefan Monnier says that `test -d' follows symlinks. And
+ ;; I now think he's right. So we could be using `test -d', couldn't
+ ;; we?
+ ;;
+ ;; Alternatives: `cd %s', `test -d %s'
+ (with-parsed-tramp-file-name filename nil
+ (with-file-property v localname "file-directory-p"
+ (tramp-run-test "-d" filename))))
+
+(defun tramp-sh-handle-file-writable-p (filename)
+ "Like `file-writable-p' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (with-file-property v localname "file-writable-p"
+ (if (file-exists-p filename)
+ ;; Examine `file-attributes' cache to see if request can be
+ ;; satisfied without remote operation.
+ (or (tramp-check-cached-permissions v ?w)
+ (tramp-run-test "-w" filename))
+ ;; If file doesn't exist, check if directory is writable.
+ (and (tramp-run-test "-d" (file-name-directory filename))
+ (tramp-run-test "-w" (file-name-directory filename)))))))
+
+(defun tramp-sh-handle-file-ownership-preserved-p (filename)
+ "Like `file-ownership-preserved-p' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (with-file-property v localname "file-ownership-preserved-p"
+ (let ((attributes (file-attributes filename)))
+ ;; Return t if the file doesn't exist, since it's true that no
+ ;; information would be lost by an (attempted) delete and create.
+ (or (null attributes)
+ (= (nth 2 attributes) (tramp-get-remote-uid v 'integer)))))))
+
+;; Directory listings.
+
+(defun tramp-sh-handle-directory-files-and-attributes
+ (directory &optional full match nosort id-format)
+ "Like `directory-files-and-attributes' for Tramp files."
+ (unless id-format (setq id-format 'integer))
+ (when (file-directory-p directory)
+ (setq directory (expand-file-name directory))
+ (let* ((temp
+ (copy-tree
+ (with-parsed-tramp-file-name directory nil
+ (with-file-property
+ v localname
+ (format "directory-files-and-attributes-%s" id-format)
+ (save-excursion
+ (mapcar
+ (lambda (x)
+ (cons (car x)
+ (tramp-convert-file-attributes v (cdr x))))
+ (cond
+ ((tramp-get-remote-stat v)
+ (tramp-do-directory-files-and-attributes-with-stat
+ v localname id-format))
+ ((tramp-get-remote-perl v)
+ (tramp-do-directory-files-and-attributes-with-perl
+ v localname id-format)))))))))
+ result item)
+
+ (while temp
+ (setq item (pop temp))
+ (when (or (null match) (string-match match (car item)))
+ (when full
+ (setcar item (expand-file-name (car item) directory)))
+ (push item result)))
+
+ (if nosort
+ result
+ (sort result (lambda (x y) (string< (car x) (car y))))))))
+
+(defun tramp-do-directory-files-and-attributes-with-perl
+ (vec localname &optional id-format)
+ "Implement `directory-files-and-attributes' for Tramp files using a Perl script."
+ (tramp-message vec 5 "directory-files-and-attributes with perl: %s" localname)
+ (tramp-maybe-send-script
+ vec tramp-perl-directory-files-and-attributes
+ "tramp_perl_directory_files_and_attributes")
+ (let ((object
+ (tramp-send-command-and-read
+ vec
+ (format "tramp_perl_directory_files_and_attributes %s %s"
+ (tramp-shell-quote-argument localname) id-format))))
+ (when (stringp object) (tramp-error vec 'file-error object))
+ object))
+
+(defun tramp-do-directory-files-and-attributes-with-stat
+ (vec localname &optional id-format)
+ "Implement `directory-files-and-attributes' for Tramp files using stat(1) command."
+ (tramp-message vec 5 "directory-files-and-attributes with stat: %s" localname)
+ (tramp-send-command-and-read
+ vec
+ (format
+ (concat
+ ;; We must care about filenames with spaces, or starting with
+ ;; "-"; this would confuse xargs. "ls -aQ" might be a solution,
+ ;; but it does not work on all remote systems. Therefore, we
+ ;; quote the filenames via sed.
+ "cd %s; echo \"(\"; (%s -a | sed -e s/\\$/\\\"/g -e s/^/\\\"/g | xargs "
+ "%s -c '(\"%%n\" (\"%%N\") %%h %s %s %%Xe0 %%Ye0 %%Ze0 %%se0 \"%%A\" t %%ie0 -1)'); "
+ "echo \")\"")
+ (tramp-shell-quote-argument localname)
+ (tramp-get-ls-command vec)
+ (tramp-get-remote-stat vec)
+ (if (eq id-format 'integer) "%u" "\"%U\"")
+ (if (eq id-format 'integer) "%g" "\"%G\""))))
+
+;; This function should return "foo/" for directories and "bar" for
+;; files.
+(defun tramp-sh-handle-file-name-all-completions (filename directory)
+ "Like `file-name-all-completions' for Tramp files."
+ (unless (save-match-data (string-match "/" filename))
+ (with-parsed-tramp-file-name (expand-file-name directory) nil
+
+ (all-completions
+ filename
+ (mapcar
+ 'list
+ (or
+ ;; Try cache entries for filename, filename with last
+ ;; character removed, filename with last two characters
+ ;; removed, ..., and finally the empty string - all
+ ;; concatenated to the local directory name.
+ (let ((remote-file-name-inhibit-cache
+ (or remote-file-name-inhibit-cache
+ tramp-completion-reread-directory-timeout)))
+
+ ;; This is inefficient for very long filenames, pity
+ ;; `reduce' is not available...
+ (car
+ (apply
+ 'append
+ (mapcar
+ (lambda (x)
+ (let ((cache-hit
+ (tramp-get-file-property
+ v
+ (concat localname (substring filename 0 x))
+ "file-name-all-completions"
+ nil)))
+ (when cache-hit (list cache-hit))))
+ (tramp-compat-number-sequence (length filename) 0 -1)))))
+
+ ;; Cache expired or no matching cache entry found so we need
+ ;; to perform a remote operation.
+ (let (result)
+ ;; Get a list of directories and files, including reliably
+ ;; tagging the directories with a trailing '/'. Because I
+ ;; rock. --daniel@danann.net
+
+ ;; Changed to perform `cd' in the same remote op and only
+ ;; get entries starting with `filename'. Capture any `cd'
+ ;; error messages. Ensure any `cd' and `echo' aliases are
+ ;; ignored.
+ (tramp-send-command
+ v
+ (if (tramp-get-remote-perl v)
+ (progn
+ (tramp-maybe-send-script
+ v tramp-perl-file-name-all-completions
+ "tramp_perl_file_name_all_completions")
+ (format "tramp_perl_file_name_all_completions %s %s %d"
+ (tramp-shell-quote-argument localname)
+ (tramp-shell-quote-argument filename)
+ (if (symbol-value
+ ;; `read-file-name-completion-ignore-case'
+ ;; is introduced with Emacs 22.1.
+ (if (boundp
+ 'read-file-name-completion-ignore-case)
+ 'read-file-name-completion-ignore-case
+ 'completion-ignore-case))
+ 1 0)))
+
+ (format (concat
+ "(\\cd %s 2>&1 && (%s %s -a 2>/dev/null"
+ ;; `ls' with wildcard might fail with `Argument
+ ;; list too long' error in some corner cases; if
+ ;; `ls' fails after `cd' succeeded, chances are
+ ;; that's the case, so let's retry without
+ ;; wildcard. This will return "too many" entries
+ ;; but that isn't harmful.
+ " || %s -a 2>/dev/null)"
+ " | while read f; do"
+ " if %s -d \"$f\" 2>/dev/null;"
+ " then \\echo \"$f/\"; else \\echo \"$f\"; fi; done"
+ " && \\echo ok) || \\echo fail")
+ (tramp-shell-quote-argument localname)
+ (tramp-get-ls-command v)
+ ;; When `filename' is empty, just `ls' without
+ ;; filename argument is more efficient than `ls *'
+ ;; for very large directories and might avoid the
+ ;; `Argument list too long' error.
+ ;;
+ ;; With and only with wildcard, we need to add
+ ;; `-d' to prevent `ls' from descending into
+ ;; sub-directories.
+ (if (zerop (length filename))
+ "."
+ (concat (tramp-shell-quote-argument filename) "* -d"))
+ (tramp-get-ls-command v)
+ (tramp-get-test-command v))))
+
+ ;; Now grab the output.
+ (with-current-buffer (tramp-get-buffer v)
+ (goto-char (point-max))
+
+ ;; Check result code, found in last line of output
+ (forward-line -1)
+ (if (looking-at "^fail$")
+ (progn
+ ;; Grab error message from line before last line
+ ;; (it was put there by `cd 2>&1')
+ (forward-line -1)
+ (tramp-error
+ v 'file-error
+ "tramp-sh-handle-file-name-all-completions: %s"
+ (buffer-substring (point) (point-at-eol))))
+ ;; For peace of mind, if buffer doesn't end in `fail'
+ ;; then it should end in `ok'. If neither are in the
+ ;; buffer something went seriously wrong on the remote
+ ;; side.
+ (unless (looking-at "^ok$")
+ (tramp-error
+ v 'file-error
+ "\
+tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'"
+ (tramp-shell-quote-argument localname) (buffer-string))))
+
+ (while (zerop (forward-line -1))
+ (push (buffer-substring (point) (point-at-eol)) result)))
+
+ ;; Because the remote op went through OK we know the
+ ;; directory we `cd'-ed to exists
+ (tramp-set-file-property
+ v localname "file-exists-p" t)
+
+ ;; Because the remote op went through OK we know every
+ ;; file listed by `ls' exists.
+ (mapc (lambda (entry)
+ (tramp-set-file-property
+ v (concat localname entry) "file-exists-p" t))
+ result)
+
+ ;; Store result in the cache
+ (tramp-set-file-property
+ v (concat localname filename)
+ "file-name-all-completions"
+ result))))))))
+
+;; cp, mv and ln
+
+(defun tramp-sh-handle-add-name-to-file
+ (filename newname &optional ok-if-already-exists)
+ "Like `add-name-to-file' for Tramp files."
+ (unless (tramp-equal-remote filename newname)
+ (with-parsed-tramp-file-name
+ (if (tramp-tramp-file-p filename) filename newname) nil
+ (tramp-error
+ v 'file-error
+ "add-name-to-file: %s"
+ "only implemented for same method, same user, same host")))
+ (with-parsed-tramp-file-name filename v1
+ (with-parsed-tramp-file-name newname v2
+ (let ((ln (when v1 (tramp-get-remote-ln v1))))
+ (when (and (not ok-if-already-exists)
+ (file-exists-p newname)
+ (not (numberp ok-if-already-exists))
+ (y-or-n-p
+ (format
+ "File %s already exists; make it a new name anyway? "
+ newname)))
+ (tramp-error
+ v2 'file-error
+ "add-name-to-file: file %s already exists" newname))
+ (tramp-flush-file-property v2 (file-name-directory v2-localname))
+ (tramp-flush-file-property v2 v2-localname)
+ (tramp-barf-unless-okay
+ v1
+ (format "%s %s %s" ln (tramp-shell-quote-argument v1-localname)
+ (tramp-shell-quote-argument v2-localname))
+ "error with add-name-to-file, see buffer `%s' for details"
+ (buffer-name))))))
+
+(defun tramp-sh-handle-copy-file
+ (filename newname &optional ok-if-already-exists keep-date
+ preserve-uid-gid preserve-selinux-context)
+ "Like `copy-file' for Tramp files."
+ (setq filename (expand-file-name filename))
+ (setq newname (expand-file-name newname))
+ (cond
+ ;; At least one file a Tramp file?
+ ((or (tramp-tramp-file-p filename)
+ (tramp-tramp-file-p newname))
+ (tramp-do-copy-or-rename-file
+ 'copy filename newname ok-if-already-exists keep-date
+ preserve-uid-gid preserve-selinux-context))
+ ;; Compat section.
+ (preserve-selinux-context
+ (tramp-run-real-handler
+ 'copy-file
+ (list filename newname ok-if-already-exists keep-date
+ preserve-uid-gid preserve-selinux-context)))
+ (preserve-uid-gid
+ (tramp-run-real-handler
+ 'copy-file
+ (list filename newname ok-if-already-exists keep-date preserve-uid-gid)))
+ (t
+ (tramp-run-real-handler
+ 'copy-file (list filename newname ok-if-already-exists keep-date)))))
+
+(defun tramp-sh-handle-copy-directory
+ (dirname newname &optional keep-date parents)
+ "Like `copy-directory' for Tramp files."
+ (let ((t1 (tramp-tramp-file-p dirname))
+ (t2 (tramp-tramp-file-p newname)))
+ (with-parsed-tramp-file-name (if t1 dirname newname) nil
+ (if (and (tramp-get-method-parameter method 'tramp-copy-recursive)
+ ;; When DIRNAME and NEWNAME are remote, they must have
+ ;; the same method.
+ (or (null t1) (null t2)
+ (string-equal
+ (tramp-file-name-method (tramp-dissect-file-name dirname))
+ (tramp-file-name-method (tramp-dissect-file-name newname)))))
+ ;; scp or rsync DTRT.
+ (progn
+ (setq dirname (directory-file-name (expand-file-name dirname))
+ newname (directory-file-name (expand-file-name newname)))
+ (if (and (file-directory-p newname)
+ (not (string-equal (file-name-nondirectory dirname)
+ (file-name-nondirectory newname))))
+ (setq newname
+ (expand-file-name
+ (file-name-nondirectory dirname) newname)))
+ (if (not (file-directory-p (file-name-directory newname)))
+ (make-directory (file-name-directory newname) parents))
+ (tramp-do-copy-or-rename-file-out-of-band
+ 'copy dirname newname keep-date))
+ ;; We must do it file-wise.
+ (tramp-run-real-handler
+ 'copy-directory (list dirname newname keep-date parents)))
+
+ ;; When newname did exist, we have wrong cached values.
+ (when t2
+ (with-parsed-tramp-file-name newname nil
+ (tramp-flush-file-property v (file-name-directory localname))
+ (tramp-flush-file-property v localname))))))
+
+(defun tramp-sh-handle-rename-file
+ (filename newname &optional ok-if-already-exists)
+ "Like `rename-file' for Tramp files."
+ ;; Check if both files are local -- invoke normal rename-file.
+ ;; Otherwise, use Tramp from local system.
+ (setq filename (expand-file-name filename))
+ (setq newname (expand-file-name newname))
+ ;; At least one file a Tramp file?
+ (if (or (tramp-tramp-file-p filename)
+ (tramp-tramp-file-p newname))
+ (tramp-do-copy-or-rename-file
+ 'rename filename newname ok-if-already-exists t t)
+ (tramp-run-real-handler
+ 'rename-file (list filename newname ok-if-already-exists))))
+
+(defun tramp-do-copy-or-rename-file
+ (op filename newname &optional ok-if-already-exists keep-date
+ preserve-uid-gid preserve-selinux-context)
+ "Copy or rename a remote file.
+OP must be `copy' or `rename' and indicates the operation to perform.
+FILENAME specifies the file to copy or rename, NEWNAME is the name of
+the new file (for copy) or the new name of the file (for rename).
+OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already.
+KEEP-DATE means to make sure that NEWNAME has the same timestamp
+as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep
+the uid and gid if both files are on the same host.
+PRESERVE-SELINUX-CONTEXT activates selinux commands.
+
+This function is invoked by `tramp-sh-handle-copy-file' and
+`tramp-sh-handle-rename-file'. It is an error if OP is neither
+of `copy' and `rename'. FILENAME and NEWNAME must be absolute
+file names."
+ (unless (memq op '(copy rename))
+ (error "Unknown operation `%s', must be `copy' or `rename'" op))
+ (let ((t1 (tramp-tramp-file-p filename))
+ (t2 (tramp-tramp-file-p newname))
+ (context (and preserve-selinux-context
+ (apply 'file-selinux-context (list filename))))
+ pr tm)
+
+ (with-parsed-tramp-file-name (if t1 filename newname) nil
+ (when (and (not ok-if-already-exists) (file-exists-p newname))
+ (tramp-error
+ v 'file-already-exists "File %s already exists" newname))
+
+ (with-progress-reporter
+ v 0 (format "%s %s to %s"
+ (if (eq op 'copy) "Copying" "Renaming")
+ filename newname)
+
+ (cond
+ ;; Both are Tramp files.
+ ((and t1 t2)
+ (with-parsed-tramp-file-name filename v1
+ (with-parsed-tramp-file-name newname v2
+ (cond
+ ;; Shortcut: if method, host, user are the same for
+ ;; both files, we invoke `cp' or `mv' on the remote
+ ;; host directly.
+ ((tramp-equal-remote filename newname)
+ (tramp-do-copy-or-rename-file-directly
+ op filename newname
+ ok-if-already-exists keep-date preserve-uid-gid))
+
+ ;; Try out-of-band operation.
+ ((tramp-method-out-of-band-p
+ v1 (nth 7 (file-attributes filename)))
+ (tramp-do-copy-or-rename-file-out-of-band
+ op filename newname keep-date))
+
+ ;; No shortcut was possible. So we copy the file
+ ;; first. If the operation was `rename', we go back
+ ;; and delete the original file (if the copy was
+ ;; successful). The approach is simple-minded: we
+ ;; create a new buffer, insert the contents of the
+ ;; source file into it, then write out the buffer to
+ ;; the target file. The advantage is that it doesn't
+ ;; matter which filename handlers are used for the
+ ;; source and target file.
+ (t
+ (tramp-do-copy-or-rename-file-via-buffer
+ op filename newname keep-date))))))
+
+ ;; One file is a Tramp file, the other one is local.
+ ((or t1 t2)
+ (cond
+ ;; Fast track on local machine.
+ ((tramp-local-host-p v)
+ (tramp-do-copy-or-rename-file-directly
+ op filename newname
+ ok-if-already-exists keep-date preserve-uid-gid))
+
+ ;; If the Tramp file has an out-of-band method, the
+ ;; corresponding copy-program can be invoked.
+ ((tramp-method-out-of-band-p v (nth 7 (file-attributes filename)))
+ (tramp-do-copy-or-rename-file-out-of-band
+ op filename newname keep-date))
+
+ ;; Use the inline method via a Tramp buffer.
+ (t (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")))
+
+ ;; Handle `preserve-selinux-context'.
+ (when context (apply 'set-file-selinux-context (list newname context)))
+
+ ;; In case of `rename', we must flush the cache of the source file.
+ (when (and t1 (eq op 'rename))
+ (with-parsed-tramp-file-name filename v1
+ (tramp-flush-file-property v1 (file-name-directory localname))
+ (tramp-flush-file-property v1 localname)))
+
+ ;; When newname did exist, we have wrong cached values.
+ (when t2
+ (with-parsed-tramp-file-name newname v2
+ (tramp-flush-file-property v2 (file-name-directory localname))
+ (tramp-flush-file-property v2 localname)))))))
+
+(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.
+KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME."
+ (with-temp-buffer
+ ;; We must disable multibyte, because binary data shall not be
+ ;; converted.
+ (set-buffer-multibyte nil)
+ (let ((coding-system-for-read 'binary)
+ (jka-compr-inhibit t))
+ (insert-file-contents-literally filename))
+ ;; We don't want the target file to be compressed, so we let-bind
+ ;; `jka-compr-inhibit' to t.
+ (let ((coding-system-for-write 'binary)
+ (jka-compr-inhibit t))
+ (write-region (point-min) (point-max) newname)))
+ ;; KEEP-DATE handling.
+ (when keep-date (set-file-times newname (nth 5 (file-attributes filename))))
+ ;; Set the mode.
+ (set-file-modes newname (tramp-default-file-modes filename))
+ ;; If the operation was `rename', delete the original file.
+ (unless (eq op 'copy) (delete-file filename)))
+
+(defun tramp-do-copy-or-rename-file-directly
+ (op filename newname ok-if-already-exists keep-date preserve-uid-gid)
+ "Invokes `cp' or `mv' on the remote system.
+OP must be one of `copy' or `rename', indicating `cp' or `mv',
+respectively. FILENAME specifies the file to copy or rename,
+NEWNAME is the name of the new file (for copy) or the new name of
+the file (for rename). Both files must reside on the same host.
+KEEP-DATE means to make sure that NEWNAME has the same timestamp
+as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep
+the uid and gid from FILENAME."
+ (let ((t1 (tramp-tramp-file-p filename))
+ (t2 (tramp-tramp-file-p newname))
+ (file-times (nth 5 (file-attributes filename)))
+ (file-modes (tramp-default-file-modes filename)))
+ (with-parsed-tramp-file-name (if t1 filename newname) nil
+ (let* ((cmd (cond ((and (eq op 'copy) preserve-uid-gid) "cp -f -p")
+ ((eq op 'copy) "cp -f")
+ ((eq op 'rename) "mv -f")
+ (t (tramp-error
+ v 'file-error
+ "Unknown operation `%s', must be `copy' or `rename'"
+ op))))
+ (localname1
+ (if t1
+ (tramp-file-name-handler 'file-remote-p filename 'localname)
+ filename))
+ (localname2
+ (if t2
+ (tramp-file-name-handler 'file-remote-p newname 'localname)
+ newname))
+ (prefix (file-remote-p (if t1 filename newname)))
+ cmd-result)
+
+ (cond
+ ;; Both files are on a remote host, with same user.
+ ((and t1 t2)
+ (setq cmd-result
+ (tramp-send-command-and-check
+ v (format "%s %s %s" cmd
+ (tramp-shell-quote-argument localname1)
+ (tramp-shell-quote-argument localname2))))
+ (with-current-buffer (tramp-get-buffer v)
+ (goto-char (point-min))
+ (unless
+ (or
+ (and keep-date
+ ;; Mask cp -f error.
+ (re-search-forward
+ tramp-operation-not-permitted-regexp nil t))
+ cmd-result)
+ (tramp-error-with-buffer
+ nil v 'file-error
+ "Copying directly failed, see buffer `%s' for details."
+ (buffer-name)))))
+
+ ;; We are on the local host.
+ ((or t1 t2)
+ (cond
+ ;; We can do it directly.
+ ((let (file-name-handler-alist)
+ (and (file-readable-p localname1)
+ (file-writable-p (file-name-directory localname2))
+ (or (file-directory-p localname2)
+ (file-writable-p localname2))))
+ (if (eq op 'copy)
+ (tramp-compat-copy-file
+ localname1 localname2 ok-if-already-exists
+ keep-date preserve-uid-gid)
+ (tramp-run-real-handler
+ 'rename-file (list localname1 localname2 ok-if-already-exists))))
+
+ ;; We can do it directly with `tramp-send-command'
+ ((and (file-readable-p (concat prefix localname1))
+ (file-writable-p
+ (file-name-directory (concat prefix localname2)))
+ (or (file-directory-p (concat prefix localname2))
+ (file-writable-p (concat prefix localname2))))
+ (tramp-do-copy-or-rename-file-directly
+ op (concat prefix localname1) (concat prefix localname2)
+ ok-if-already-exists keep-date t)
+ ;; We must change the ownership to the local user.
+ (tramp-set-file-uid-gid
+ (concat prefix localname2)
+ (tramp-get-local-uid 'integer)
+ (tramp-get-local-gid 'integer)))
+
+ ;; We need a temporary file in between.
+ (t
+ ;; Create the temporary file.
+ (let ((tmpfile (tramp-compat-make-temp-file localname1)))
+ (unwind-protect
+ (progn
+ (cond
+ (t1
+ (tramp-barf-unless-okay
+ v (format
+ "%s %s %s" cmd
+ (tramp-shell-quote-argument localname1)
+ (tramp-shell-quote-argument tmpfile))
+ "Copying directly failed, see buffer `%s' for details."
+ (tramp-get-buffer v))
+ ;; We must change the ownership as remote user.
+ ;; Since this does not work reliable, we also
+ ;; give read permissions.
+ (set-file-modes
+ (concat prefix tmpfile)
+ (tramp-compat-octal-to-decimal "0777"))
+ (tramp-set-file-uid-gid
+ (concat prefix tmpfile)
+ (tramp-get-local-uid 'integer)
+ (tramp-get-local-gid 'integer)))
+ (t2
+ (if (eq op 'copy)
+ (tramp-compat-copy-file
+ localname1 tmpfile t
+ keep-date preserve-uid-gid)
+ (tramp-run-real-handler
+ 'rename-file
+ (list localname1 tmpfile t)))
+ ;; We must change the ownership as local user.
+ ;; Since this does not work reliable, we also
+ ;; give read permissions.
+ (set-file-modes
+ tmpfile (tramp-compat-octal-to-decimal "0777"))
+ (tramp-set-file-uid-gid
+ tmpfile
+ (tramp-get-remote-uid v 'integer)
+ (tramp-get-remote-gid v 'integer))))
+
+ ;; Move the temporary file to its destination.
+ (cond
+ (t2
+ (tramp-barf-unless-okay
+ v (format
+ "cp -f -p %s %s"
+ (tramp-shell-quote-argument tmpfile)
+ (tramp-shell-quote-argument localname2))
+ "Copying directly failed, see buffer `%s' for details."
+ (tramp-get-buffer v)))
+ (t1
+ (tramp-run-real-handler
+ 'rename-file
+ (list tmpfile localname2 ok-if-already-exists)))))
+
+ ;; Save exit.
+ (ignore-errors (delete-file tmpfile)))))))))
+
+ ;; Set the time and mode. Mask possible errors.
+ (ignore-errors
+ (when keep-date
+ (set-file-times newname file-times)
+ (set-file-modes newname file-modes))))))
+
+(defun tramp-do-copy-or-rename-file-out-of-band (op filename newname keep-date)
+ "Invoke rcp program to copy.
+The method used must be an out-of-band method."
+ (let ((t1 (tramp-tramp-file-p filename))
+ (t2 (tramp-tramp-file-p newname))
+ copy-program copy-args copy-env copy-keep-date port spec
+ source target)
+
+ (with-parsed-tramp-file-name (if t1 filename newname) nil
+ (if (and t1 t2)
+
+ ;; Both are Tramp files. We shall optimize it, when the
+ ;; methods for filename and newname are the same.
+ (let* ((dir-flag (file-directory-p filename))
+ (tmpfile (tramp-compat-make-temp-file localname dir-flag)))
+ (if dir-flag
+ (setq tmpfile
+ (expand-file-name
+ (file-name-nondirectory newname) tmpfile)))
+ (unwind-protect
+ (progn
+ (tramp-do-copy-or-rename-file-out-of-band
+ op filename tmpfile keep-date)
+ (tramp-do-copy-or-rename-file-out-of-band
+ 'rename tmpfile newname keep-date))
+ ;; Save exit.
+ (ignore-errors
+ (if dir-flag
+ (tramp-compat-delete-directory
+ (expand-file-name ".." tmpfile) 'recursive)
+ (delete-file tmpfile)))))
+
+ ;; Expand hops. Might be necessary for gateway methods.
+ (setq v (car (tramp-compute-multi-hops v)))
+ (aset v 3 localname)
+
+ ;; Check which ones of source and target are Tramp files.
+ (setq source (if t1 (tramp-make-copy-program-file-name v) filename)
+ target (funcall
+ (if (and (file-directory-p filename)
+ (string-equal
+ (file-name-nondirectory filename)
+ (file-name-nondirectory newname)))
+ 'file-name-directory
+ 'identity)
+ (if t2 (tramp-make-copy-program-file-name v) newname)))
+
+ ;; Check for port number. Until now, there's no need for handling
+ ;; like method, user, host.
+ (setq host (tramp-file-name-real-host v)
+ port (tramp-file-name-port v)
+ port (or (and port (number-to-string port)) ""))
+
+ ;; Compose copy command.
+ (setq spec (format-spec-make
+ ?h host ?u user ?p port
+ ?t (tramp-get-connection-property
+ (tramp-get-connection-process v) "temp-file" "")
+ ?k (if keep-date " " ""))
+ copy-program (tramp-get-method-parameter
+ method 'tramp-copy-program)
+ copy-keep-date (tramp-get-method-parameter
+ method 'tramp-copy-keep-date)
+ copy-args
+ (delq
+ nil
+ (mapcar
+ (lambda (x)
+ (setq
+ x
+ ;; " " is indication for keep-date argument.
+ (delete " " (mapcar (lambda (y) (format-spec y spec)) x)))
+ (unless (member "" x) (mapconcat 'identity x " ")))
+ (tramp-get-method-parameter method 'tramp-copy-args)))
+ copy-env
+ (delq
+ nil
+ (mapcar
+ (lambda (x)
+ (setq x (mapcar (lambda (y) (format-spec y spec)) x))
+ (unless (member "" x) (mapconcat 'identity x " ")))
+ (tramp-get-method-parameter method 'tramp-copy-env))))
+
+ ;; Check for program.
+ (when (and (fboundp 'executable-find)
+ (not (let ((default-directory
+ (tramp-compat-temporary-file-directory)))
+ (executable-find copy-program))))
+ (tramp-error
+ v 'file-error "Cannot find copy program: %s" copy-program))
+
+ ;; Set variables for computing the prompt for reading
+ ;; password.
+ (setq tramp-current-method (tramp-file-name-method v)
+ tramp-current-user (tramp-file-name-user v)
+ tramp-current-host (tramp-file-name-host v))
+
+ (unwind-protect
+ (with-temp-buffer
+ ;; The default directory must be remote.
+ (let ((default-directory
+ (file-name-directory (if t1 filename newname)))
+ (process-environment (copy-sequence process-environment)))
+ ;; Set the transfer process properties.
+ (tramp-set-connection-property
+ v "process-name" (buffer-name (current-buffer)))
+ (tramp-set-connection-property
+ v "process-buffer" (current-buffer))
+ (while copy-env
+ (tramp-message v 5 "%s=\"%s\"" (car copy-env) (cadr copy-env))
+ (setenv (pop copy-env) (pop copy-env)))
+
+ ;; Use an asynchronous process. By this, password can
+ ;; be handled. The default directory must be local, in
+ ;; order to apply the correct `copy-program'. We don't
+ ;; set a timeout, because the copying of large files can
+ ;; last longer than 60 secs.
+ (let ((p (let ((default-directory
+ (tramp-compat-temporary-file-directory)))
+ (apply 'start-process
+ (tramp-get-connection-property
+ v "process-name" nil)
+ (tramp-get-connection-property
+ v "process-buffer" nil)
+ copy-program
+ (append copy-args (list source target))))))
+ (tramp-message
+ v 6 "%s" (mapconcat 'identity (process-command p) " "))
+ (tramp-compat-set-process-query-on-exit-flag p nil)
+ (tramp-process-actions p v tramp-actions-copy-out-of-band))))
+
+ ;; Reset the transfer process properties.
+ (tramp-set-connection-property v "process-name" nil)
+ (tramp-set-connection-property v "process-buffer" nil))
+
+ ;; Handle KEEP-DATE argument.
+ (when (and keep-date (not copy-keep-date))
+ (set-file-times newname (nth 5 (file-attributes filename))))
+
+ ;; Set the mode.
+ (unless (and keep-date copy-keep-date)
+ (ignore-errors
+ (set-file-modes newname (tramp-default-file-modes filename)))))
+
+ ;; If the operation was `rename', delete the original file.
+ (unless (eq op 'copy)
+ (if (file-regular-p filename)
+ (delete-file filename)
+ (tramp-compat-delete-directory filename 'recursive))))))
+
+(defun tramp-sh-handle-make-directory (dir &optional parents)
+ "Like `make-directory' for Tramp files."
+ (setq dir (expand-file-name dir))
+ (with-parsed-tramp-file-name dir nil
+ (tramp-flush-directory-property v (file-name-directory localname))
+ (save-excursion
+ (tramp-barf-unless-okay
+ v (format "%s %s"
+ (if parents "mkdir -p" "mkdir")
+ (tramp-shell-quote-argument localname))
+ "Couldn't make directory %s" dir))))
+
+(defun tramp-sh-handle-delete-directory (directory &optional recursive)
+ "Like `delete-directory' for Tramp files."
+ (setq directory (expand-file-name directory))
+ (with-parsed-tramp-file-name directory nil
+ (tramp-flush-file-property v (file-name-directory localname))
+ (tramp-flush-directory-property v localname)
+ (tramp-barf-unless-okay
+ v (format "%s %s"
+ (if recursive "rm -rf" "rmdir")
+ (tramp-shell-quote-argument localname))
+ "Couldn't delete %s" directory)))
+
+(defun tramp-sh-handle-delete-file (filename &optional trash)
+ "Like `delete-file' for Tramp files."
+ (setq filename (expand-file-name filename))
+ (with-parsed-tramp-file-name filename nil
+ (tramp-flush-file-property v (file-name-directory localname))
+ (tramp-flush-file-property v localname)
+ (tramp-barf-unless-okay
+ v (format "%s %s"
+ (or (and trash (tramp-get-remote-trash v)) "rm -f")
+ (tramp-shell-quote-argument localname))
+ "Couldn't delete %s" filename)))
+
+;; Dired.
+
+;; CCC: This does not seem to be enough. Something dies when
+;; we try and delete two directories under Tramp :/
+(defun tramp-sh-handle-dired-recursive-delete-directory (filename)
+ "Recursively delete the directory given.
+This is like `dired-recursive-delete-directory' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ ;; Run a shell command 'rm -r <localname>'
+ ;; Code shamelessly stolen from the dired implementation and, um, hacked :)
+ (unless (file-exists-p filename)
+ (tramp-error v 'file-error "No such directory: %s" filename))
+ ;; Which is better, -r or -R? (-r works for me <daniel@danann.net>)
+ (tramp-send-command
+ v
+ (format "rm -rf %s" (tramp-shell-quote-argument localname))
+ ;; Don't read the output, do it explicitely.
+ nil t)
+ ;; Wait for the remote system to return to us...
+ ;; This might take a while, allow it plenty of time.
+ (tramp-wait-for-output (tramp-get-connection-process v) 120)
+ ;; Make sure that it worked...
+ (tramp-flush-file-property v (file-name-directory localname))
+ (tramp-flush-directory-property v localname)
+ (and (file-exists-p filename)
+ (tramp-error
+ v 'file-error "Failed to recursively delete %s" filename))))
+
+(defun tramp-sh-handle-dired-compress-file (file &rest ok-flag)
+ "Like `dired-compress-file' for Tramp files."
+ ;; OK-FLAG is valid for XEmacs only, but not implemented.
+ ;; Code stolen mainly from dired-aux.el.
+ (with-parsed-tramp-file-name file nil
+ (tramp-flush-file-property v localname)
+ (save-excursion
+ (let ((suffixes
+ (if (not (featurep 'xemacs))
+ ;; Emacs case
+ (symbol-value 'dired-compress-file-suffixes)
+ ;; XEmacs has `dired-compression-method-alist', which is
+ ;; transformed into `dired-compress-file-suffixes' structure.
+ (mapcar
+ (lambda (x)
+ (list (concat (regexp-quote (nth 1 x)) "\\'")
+ nil
+ (mapconcat 'identity (nth 3 x) " ")))
+ (symbol-value 'dired-compression-method-alist))))
+ suffix)
+ ;; See if any suffix rule matches this file name.
+ (while suffixes
+ (let (case-fold-search)
+ (if (string-match (car (car suffixes)) localname)
+ (setq suffix (car suffixes) suffixes nil))
+ (setq suffixes (cdr suffixes))))
+
+ (cond ((file-symlink-p file)
+ nil)
+ ((and suffix (nth 2 suffix))
+ ;; We found an uncompression rule.
+ (with-progress-reporter v 0 (format "Uncompressing %s" file)
+ (when (tramp-send-command-and-check
+ v (concat (nth 2 suffix) " "
+ (tramp-shell-quote-argument localname)))
+ ;; `dired-remove-file' is not defined in XEmacs.
+ (tramp-compat-funcall 'dired-remove-file file)
+ (string-match (car suffix) file)
+ (concat (substring file 0 (match-beginning 0))))))
+ (t
+ ;; We don't recognize the file as compressed, so compress it.
+ ;; Try gzip.
+ (with-progress-reporter v 0 (format "Compressing %s" file)
+ (when (tramp-send-command-and-check
+ v (concat "gzip -f "
+ (tramp-shell-quote-argument localname)))
+ ;; `dired-remove-file' is not defined in XEmacs.
+ (tramp-compat-funcall 'dired-remove-file file)
+ (cond ((file-exists-p (concat file ".gz"))
+ (concat file ".gz"))
+ ((file-exists-p (concat file ".z"))
+ (concat file ".z"))
+ (t nil))))))))))
+
+(defun tramp-sh-handle-insert-directory
+ (filename switches &optional wildcard full-directory-p)
+ "Like `insert-directory' for Tramp files."
+ (setq filename (expand-file-name filename))
+ (with-parsed-tramp-file-name filename nil
+ (if (and (featurep 'ls-lisp)
+ (not (symbol-value 'ls-lisp-use-insert-directory-program)))
+ (tramp-run-real-handler
+ 'insert-directory (list filename switches wildcard full-directory-p))
+ (when (stringp switches)
+ (setq switches (split-string switches)))
+ (when (and (member "--dired" switches)
+ (not (tramp-get-ls-command-with-dired v)))
+ (setq switches (delete "--dired" switches)))
+ (when wildcard
+ (setq wildcard (tramp-run-real-handler
+ 'file-name-nondirectory (list localname)))
+ (setq localname (tramp-run-real-handler
+ 'file-name-directory (list localname))))
+ (unless full-directory-p
+ (setq switches (add-to-list 'switches "-d" 'append)))
+ (setq switches (mapconcat 'tramp-shell-quote-argument switches " "))
+ (when wildcard
+ (setq switches (concat switches " " wildcard)))
+ (tramp-message
+ v 4 "Inserting directory `ls %s %s', wildcard %s, fulldir %s"
+ switches filename (if wildcard "yes" "no")
+ (if full-directory-p "yes" "no"))
+ ;; If `full-directory-p', we just say `ls -l FILENAME'.
+ ;; Else we chdir to the parent directory, then say `ls -ld BASENAME'.
+ (if full-directory-p
+ (tramp-send-command
+ v
+ (format "%s %s %s 2>/dev/null"
+ (tramp-get-ls-command v)
+ switches
+ (if wildcard
+ localname
+ (tramp-shell-quote-argument (concat localname ".")))))
+ (tramp-barf-unless-okay
+ v
+ (format "cd %s" (tramp-shell-quote-argument
+ (tramp-run-real-handler
+ 'file-name-directory (list localname))))
+ "Couldn't `cd %s'"
+ (tramp-shell-quote-argument
+ (tramp-run-real-handler 'file-name-directory (list localname))))
+ (tramp-send-command
+ v
+ (format "%s %s %s"
+ (tramp-get-ls-command v)
+ switches
+ (if (or wildcard
+ (zerop (length
+ (tramp-run-real-handler
+ 'file-name-nondirectory (list localname)))))
+ ""
+ (tramp-shell-quote-argument
+ (tramp-run-real-handler
+ 'file-name-nondirectory (list localname)))))))
+ (let ((beg (point)))
+ ;; We cannot use `insert-buffer-substring' because the Tramp
+ ;; buffer changes its contents before insertion due to calling
+ ;; `expand-file' and alike.
+ (insert
+ (with-current-buffer (tramp-get-buffer v)
+ (buffer-string)))
+
+ ;; Check for "--dired" output.
+ (forward-line -2)
+ (when (looking-at "//SUBDIRED//")
+ (forward-line -1))
+ (when (looking-at "//DIRED//\\s-+")
+ (let ((databeg (match-end 0))
+ (end (point-at-eol)))
+ ;; Now read the numeric positions of file names.
+ (goto-char databeg)
+ (while (< (point) end)
+ (let ((start (+ beg (read (current-buffer))))
+ (end (+ beg (read (current-buffer)))))
+ (if (memq (char-after end) '(?\n ?\ ))
+ ;; End is followed by \n or by " -> ".
+ (put-text-property start end 'dired-filename t))))))
+ ;; Remove trailing lines.
+ (goto-char (point-at-bol))
+ (while (looking-at "//")
+ (forward-line 1)
+ (delete-region (match-beginning 0) (point)))
+
+ ;; The inserted file could be from somewhere else.
+ (when (and (not wildcard) (not full-directory-p))
+ (goto-char (point-max))
+ (when (file-symlink-p filename)
+ (goto-char (search-backward "->" beg 'noerror)))
+ (search-backward
+ (if (zerop (length (file-name-nondirectory filename)))
+ "."
+ (file-name-nondirectory filename))
+ beg 'noerror)
+ (replace-match (file-relative-name filename) t))
+
+ (goto-char (point-max))))))
+
+;; Canonicalization of file names.
+
+(defun tramp-sh-handle-expand-file-name (name &optional dir)
+ "Like `expand-file-name' for Tramp files.
+If the localname part of the given filename starts with \"/../\" then
+the result will be a local, non-Tramp, filename."
+ ;; If DIR is not given, use DEFAULT-DIRECTORY or "/".
+ (setq dir (or dir default-directory "/"))
+ ;; Unless NAME is absolute, concat DIR and NAME.
+ (unless (file-name-absolute-p name)
+ (setq name (concat (file-name-as-directory dir) name)))
+ ;; If NAME is not a Tramp file, run the real handler.
+ (if (not (tramp-connectable-p name))
+ (tramp-run-real-handler 'expand-file-name (list name nil))
+ ;; Dissect NAME.
+ (with-parsed-tramp-file-name name nil
+ (unless (tramp-run-real-handler 'file-name-absolute-p (list localname))
+ (setq localname (concat "~/" localname)))
+ ;; Tilde expansion if necessary. This needs a shell which
+ ;; groks tilde expansion! The function `tramp-find-shell' is
+ ;; supposed to find such a shell on the remote host. Please
+ ;; tell me about it when this doesn't work on your system.
+ (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname)
+ (let ((uname (match-string 1 localname))
+ (fname (match-string 2 localname)))
+ ;; We cannot simply apply "~/", because under sudo "~/" is
+ ;; expanded to the local user home directory but to the
+ ;; root home directory. On the other hand, using always
+ ;; the default user name for tilde expansion is not
+ ;; appropriate either, because ssh and companions might
+ ;; use a user name from the config file.
+ (when (and (string-equal uname "~")
+ (string-match "\\`su\\(do\\)?\\'" method))
+ (setq uname (concat uname user)))
+ (setq uname
+ (with-connection-property v uname
+ (tramp-send-command
+ v (format "cd %s; pwd" (tramp-shell-quote-argument uname)))
+ (with-current-buffer (tramp-get-buffer v)
+ (goto-char (point-min))
+ (buffer-substring (point) (point-at-eol)))))
+ (setq localname (concat uname fname))))
+ ;; There might be a double slash, for example when "~/"
+ ;; expands to "/". Remove this.
+ (while (string-match "//" localname)
+ (setq localname (replace-match "/" t t localname)))
+ ;; No tilde characters in file name, do normal
+ ;; `expand-file-name' (this does "/./" and "/../"). We bind
+ ;; `directory-sep-char' here for XEmacs on Windows, which would
+ ;; otherwise use backslash. `default-directory' is bound,
+ ;; because on Windows there would be problems with UNC shares or
+ ;; Cygwin mounts.
+ (let ((directory-sep-char ?/)
+ (default-directory (tramp-compat-temporary-file-directory)))
+ (tramp-make-tramp-file-name
+ method user host
+ (tramp-drop-volume-letter
+ (tramp-run-real-handler
+ 'expand-file-name (list localname))))))))
+
+;;; Remote commands:
+
+(defun tramp-sh-handle-executable-find (command)
+ "Like `executable-find' for Tramp files."
+ (with-parsed-tramp-file-name default-directory nil
+ (tramp-find-executable v command (tramp-get-remote-path v) t)))
+
+(defun tramp-process-sentinel (proc event)
+ "Flush file caches."
+ (unless (memq (process-status proc) '(run open))
+ (let ((vec (tramp-get-connection-property proc "vector" nil)))
+ (when vec
+ (tramp-message vec 5 "Sentinel called: `%s' `%s'" proc event)
+ (tramp-flush-directory-property vec "")))))
+
+;; We use BUFFER also as connection buffer during setup. Because of
+;; this, its original contents must be saved, and restored once
+;; connection has been setup.
+(defun tramp-sh-handle-start-file-process (name buffer program &rest args)
+ "Like `start-file-process' for Tramp files."
+ (with-parsed-tramp-file-name default-directory nil
+ (unwind-protect
+ ;; When PROGRAM is nil, we just provide a tty.
+ (let ((command
+ (when (stringp program)
+ (format "cd %s; exec %s"
+ (tramp-shell-quote-argument localname)
+ (mapconcat 'tramp-shell-quote-argument
+ (cons program args) " "))))
+ (tramp-process-connection-type
+ (or (null program) tramp-process-connection-type))
+ (name1 name)
+ (i 0))
+ (unless buffer
+ ;; BUFFER can be nil. We use a temporary buffer.
+ (setq buffer (generate-new-buffer tramp-temp-buffer-name)))
+ (while (get-process name1)
+ ;; NAME must be unique as process name.
+ (setq i (1+ i)
+ name1 (format "%s<%d>" name i)))
+ (setq name name1)
+ ;; Set the new process properties.
+ (tramp-set-connection-property v "process-name" name)
+ (tramp-set-connection-property v "process-buffer" buffer)
+ ;; Activate narrowing in order to save BUFFER contents.
+ ;; Clear also the modification time; otherwise we might be
+ ;; interrupted by `verify-visited-file-modtime'.
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (clear-visited-file-modtime)
+ (narrow-to-region (point-max) (point-max)))
+ (if command
+ ;; Send the command.
+ (tramp-send-command v command nil t) ; nooutput
+ ;; Check, whether a pty is associated.
+ (tramp-maybe-open-connection v)
+ (unless (tramp-compat-process-get
+ (tramp-get-connection-process v) 'remote-tty)
+ (tramp-error
+ v 'file-error "pty association is not supported for `%s'" name)))
+ (let ((p (tramp-get-connection-process v)))
+ ;; Set sentinel and query flag for this process.
+ (tramp-set-connection-property p "vector" v)
+ (set-process-sentinel p 'tramp-process-sentinel)
+ (tramp-compat-set-process-query-on-exit-flag p t)
+ ;; Return process.
+ p))
+ ;; Save exit.
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (if (string-match tramp-temp-buffer-name (buffer-name))
+ (progn
+ (set-process-buffer (tramp-get-connection-process v) nil)
+ (kill-buffer (current-buffer)))
+ (widen)
+ (goto-char (point-max))))
+ (tramp-set-connection-property v "process-name" nil)
+ (tramp-set-connection-property v "process-buffer" nil))))
+
+(defun tramp-sh-handle-process-file
+ (program &optional infile destination display &rest args)
+ "Like `process-file' for Tramp files."
+ ;; The implementation is not complete yet.
+ (when (and (numberp destination) (zerop destination))
+ (error "Implementation does not handle immediate return"))
+
+ (with-parsed-tramp-file-name default-directory nil
+ (let (command input tmpinput stderr tmpstderr outbuf ret)
+ ;; Compute command.
+ (setq command (mapconcat 'tramp-shell-quote-argument
+ (cons program args) " "))
+ ;; Determine input.
+ (if (null infile)
+ (setq input "/dev/null")
+ (setq infile (expand-file-name infile))
+ (if (tramp-equal-remote default-directory infile)
+ ;; INFILE is on the same remote host.
+ (setq input (with-parsed-tramp-file-name infile nil localname))
+ ;; INFILE must be copied to remote host.
+ (setq input (tramp-make-tramp-temp-file v)
+ tmpinput (tramp-make-tramp-file-name method user host input))
+ (copy-file infile tmpinput t)))
+ (when input (setq command (format "%s <%s" command input)))
+
+ ;; Determine output.
+ (cond
+ ;; Just a buffer.
+ ((bufferp destination)
+ (setq outbuf destination))
+ ;; A buffer name.
+ ((stringp destination)
+ (setq outbuf (get-buffer-create destination)))
+ ;; (REAL-DESTINATION ERROR-DESTINATION)
+ ((consp destination)
+ ;; output.
+ (cond
+ ((bufferp (car destination))
+ (setq outbuf (car destination)))
+ ((stringp (car destination))
+ (setq outbuf (get-buffer-create (car destination))))
+ ((car destination)
+ (setq outbuf (current-buffer))))
+ ;; stderr.
+ (cond
+ ((stringp (cadr destination))
+ (setcar (cdr destination) (expand-file-name (cadr destination)))
+ (if (tramp-equal-remote default-directory (cadr destination))
+ ;; stderr is on the same remote host.
+ (setq stderr (with-parsed-tramp-file-name
+ (cadr destination) nil localname))
+ ;; stderr must be copied to remote host. The temporary
+ ;; file must be deleted after execution.
+ (setq stderr (tramp-make-tramp-temp-file v)
+ tmpstderr (tramp-make-tramp-file-name
+ method user host stderr))))
+ ;; stderr to be discarded.
+ ((null (cadr destination))
+ (setq stderr "/dev/null"))))
+ ;; 't
+ (destination
+ (setq outbuf (current-buffer))))
+ (when stderr (setq command (format "%s 2>%s" command stderr)))
+
+ ;; Send the command. It might not return in time, so we protect
+ ;; it. Call it in a subshell, in order to preserve working
+ ;; directory.
+ (condition-case nil
+ (unwind-protect
+ (setq ret
+ (if (tramp-send-command-and-check
+ v (format "\\cd %s; %s"
+ (tramp-shell-quote-argument localname)
+ command)
+ t t)
+ 0 1))
+ ;; We should show the output anyway.
+ (when outbuf
+ (with-current-buffer outbuf
+ (insert
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (buffer-string))))
+ (when display (display-buffer outbuf))))
+ ;; When the user did interrupt, we should do it also. We use
+ ;; return code -1 as marker.
+ (quit
+ (kill-buffer (tramp-get-connection-buffer v))
+ (setq ret -1))
+ ;; Handle errors.
+ (error
+ (kill-buffer (tramp-get-connection-buffer v))
+ (setq ret 1)))
+
+ ;; Provide error file.
+ (when tmpstderr (rename-file tmpstderr (cadr destination) t))
+
+ ;; Cleanup. We remove all file cache values for the connection,
+ ;; because the remote process could have changed them.
+ (when tmpinput (delete-file tmpinput))
+
+ ;; `process-file-side-effects' has been introduced with GNU
+ ;; Emacs 23.2. If set to `nil', no remote file will be changed
+ ;; by `program'. If it doesn't exist, we assume its default
+ ;; value 't'.
+ (unless (and (boundp 'process-file-side-effects)
+ (not (symbol-value 'process-file-side-effects)))
+ (tramp-flush-directory-property v ""))
+
+ ;; Return exit status.
+ (if (equal ret -1)
+ (keyboard-quit)
+ ret))))
+
+(defun tramp-sh-handle-call-process-region
+ (start end program &optional delete buffer display &rest args)
+ "Like `call-process-region' for Tramp files."
+ (let ((tmpfile (tramp-compat-make-temp-file "")))
+ (write-region start end tmpfile)
+ (when delete (delete-region start end))
+ (unwind-protect
+ (apply 'call-process program tmpfile buffer display args)
+ (delete-file tmpfile))))
+
+(defun tramp-sh-handle-shell-command
+ (command &optional output-buffer error-buffer)
+ "Like `shell-command' for Tramp files."
+ (let* ((asynchronous (string-match "[ \t]*&[ \t]*\\'" command))
+ ;; We cannot use `shell-file-name' and `shell-command-switch',
+ ;; they are variables of the local host.
+ (args (list
+ (tramp-get-method-parameter
+ (tramp-file-name-method
+ (tramp-dissect-file-name default-directory))
+ 'tramp-remote-sh)
+ "-c" (substring command 0 asynchronous)))
+ current-buffer-p
+ (output-buffer
+ (cond
+ ((bufferp output-buffer) output-buffer)
+ ((stringp output-buffer) (get-buffer-create output-buffer))
+ (output-buffer
+ (setq current-buffer-p t)
+ (current-buffer))
+ (t (get-buffer-create
+ (if asynchronous
+ "*Async Shell Command*"
+ "*Shell Command Output*")))))
+ (error-buffer
+ (cond
+ ((bufferp error-buffer) error-buffer)
+ ((stringp error-buffer) (get-buffer-create error-buffer))))
+ (buffer
+ (if (and (not asynchronous) error-buffer)
+ (with-parsed-tramp-file-name default-directory nil
+ (list output-buffer (tramp-make-tramp-temp-file v)))
+ output-buffer))
+ (p (get-buffer-process output-buffer)))
+
+ ;; Check whether there is another process running. Tramp does not
+ ;; support 2 (asynchronous) processes in parallel.
+ (when p
+ (if (yes-or-no-p "A command is running. Kill it? ")
+ (ignore-errors (kill-process p))
+ (error "Shell command in progress")))
+
+ (if current-buffer-p
+ (progn
+ (barf-if-buffer-read-only)
+ (push-mark nil t))
+ (with-current-buffer output-buffer
+ (setq buffer-read-only nil)
+ (erase-buffer)))
+
+ (if (and (not current-buffer-p) (integerp asynchronous))
+ (prog1
+ ;; Run the process.
+ (apply 'start-file-process "*Async Shell*" buffer args)
+ ;; Display output.
+ (pop-to-buffer output-buffer)
+ (setq mode-line-process '(":%s"))
+ (shell-mode))
+
+ (prog1
+ ;; Run the process.
+ (apply 'process-file (car args) nil buffer nil (cdr args))
+ ;; Insert error messages if they were separated.
+ (when (listp buffer)
+ (with-current-buffer error-buffer
+ (insert-file-contents (cadr buffer)))
+ (delete-file (cadr buffer)))
+ (if current-buffer-p
+ ;; This is like exchange-point-and-mark, but doesn't
+ ;; activate the mark. It is cleaner to avoid activation,
+ ;; even though the command loop would deactivate the mark
+ ;; because we inserted text.
+ (goto-char (prog1 (mark t)
+ (set-marker (mark-marker) (point)
+ (current-buffer))))
+ ;; There's some output, display it.
+ (when (with-current-buffer output-buffer (> (point-max) (point-min)))
+ (if (functionp 'display-message-or-buffer)
+ (tramp-compat-funcall 'display-message-or-buffer output-buffer)
+ (pop-to-buffer output-buffer))))))))
+
+(defun tramp-sh-handle-file-local-copy (filename)
+ "Like `file-local-copy' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ (unless (file-exists-p filename)
+ (tramp-error
+ v 'file-error
+ "Cannot make local copy of non-existing file `%s'" filename))
+
+ (let* ((size (nth 7 (file-attributes filename)))
+ (rem-enc (tramp-get-inline-coding v "remote-encoding" size))
+ (loc-dec (tramp-get-inline-coding v "local-decoding" size))
+ (tmpfile (tramp-compat-make-temp-file filename)))
+
+ (condition-case err
+ (cond
+ ;; `copy-file' handles direct copy and out-of-band methods.
+ ((or (tramp-local-host-p v)
+ (tramp-method-out-of-band-p v size))
+ (copy-file filename tmpfile t t))
+
+ ;; Use inline encoding for file transfer.
+ (rem-enc
+ (save-excursion
+ (with-progress-reporter
+ v 3 (format "Encoding remote file %s" filename)
+ (tramp-barf-unless-okay
+ v (format rem-enc (tramp-shell-quote-argument localname))
+ "Encoding remote file failed"))
+
+ (if (functionp loc-dec)
+ ;; If local decoding is a function, we call it. We
+ ;; must disable multibyte, because
+ ;; `uudecode-decode-region' doesn't handle it
+ ;; correctly.
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (insert-buffer-substring (tramp-get-buffer v))
+ (with-progress-reporter
+ v 3 (format "Decoding remote file %s with function %s"
+ filename loc-dec)
+ (funcall loc-dec (point-min) (point-max))
+ ;; Unset `file-name-handler-alist'. Otherwise,
+ ;; epa-file gets confused.
+ (let (file-name-handler-alist
+ (coding-system-for-write 'binary))
+ (write-region (point-min) (point-max) tmpfile))))
+
+ ;; If tramp-decoding-function is not defined for this
+ ;; method, we invoke tramp-decoding-command instead.
+ (let ((tmpfile2 (tramp-compat-make-temp-file filename)))
+ ;; Unset `file-name-handler-alist'. Otherwise,
+ ;; epa-file gets confused.
+ (let (file-name-handler-alist
+ (coding-system-for-write 'binary))
+ (write-region (point-min) (point-max) tmpfile2))
+ (with-progress-reporter
+ v 3 (format "Decoding remote file %s with command %s"
+ filename loc-dec)
+ (unwind-protect
+ (tramp-call-local-coding-command
+ loc-dec tmpfile2 tmpfile)
+ (delete-file tmpfile2)))))
+
+ ;; Set proper permissions.
+ (set-file-modes tmpfile (tramp-default-file-modes filename))
+ ;; Set local user ownership.
+ (tramp-set-file-uid-gid tmpfile)))
+
+ ;; Oops, I don't know what to do.
+ (t (tramp-error
+ v 'file-error "Wrong method specification for `%s'" method)))
+
+ ;; Error handling.
+ ((error quit)
+ (delete-file tmpfile)
+ (signal (car err) (cdr err))))
+
+ (run-hooks 'tramp-handle-file-local-copy-hook)
+ tmpfile)))
+
+;; This is needed for XEmacs only. Code stolen from files.el.
+(defun tramp-sh-handle-insert-file-contents-literally
+ (filename &optional visit beg end replace)
+ "Like `insert-file-contents-literally' for Tramp files."
+ (let ((format-alist nil)
+ (after-insert-file-functions nil)
+ (coding-system-for-read 'no-conversion)
+ (coding-system-for-write 'no-conversion)
+ (find-buffer-file-type-function
+ (if (fboundp 'find-buffer-file-type)
+ (symbol-function 'find-buffer-file-type)
+ nil))
+ (inhibit-file-name-handlers '(jka-compr-handler image-file-handler))
+ (inhibit-file-name-operation 'insert-file-contents))
+ (unwind-protect
+ (progn
+ (fset 'find-buffer-file-type (lambda (filename) t))
+ (insert-file-contents filename visit beg end replace))
+ ;; Save exit.
+ (if find-buffer-file-type-function
+ (fset 'find-buffer-file-type find-buffer-file-type-function)
+ (fmakunbound 'find-buffer-file-type)))))
+
+(defun tramp-sh-handle-make-auto-save-file-name ()
+ "Like `make-auto-save-file-name' for Tramp files.
+Returns a file name in `tramp-auto-save-directory' for autosaving this file."
+ (let ((tramp-auto-save-directory tramp-auto-save-directory)
+ (buffer-file-name
+ (tramp-subst-strs-in-string
+ '(("_" . "|")
+ ("/" . "_a")
+ (":" . "_b")
+ ("|" . "__")
+ ("[" . "_l")
+ ("]" . "_r"))
+ (buffer-file-name))))
+ ;; File name must be unique. This is ensured with Emacs 22 (see
+ ;; UNIQUIFY element of `auto-save-file-name-transforms'); but for
+ ;; all other cases we must do it ourselves.
+ (when (boundp 'auto-save-file-name-transforms)
+ (mapc
+ (lambda (x)
+ (when (and (string-match (car x) buffer-file-name)
+ (not (car (cddr x))))
+ (setq tramp-auto-save-directory
+ (or tramp-auto-save-directory
+ (tramp-compat-temporary-file-directory)))))
+ (symbol-value 'auto-save-file-name-transforms)))
+ ;; Create directory.
+ (when tramp-auto-save-directory
+ (setq buffer-file-name
+ (expand-file-name buffer-file-name tramp-auto-save-directory))
+ (unless (file-exists-p tramp-auto-save-directory)
+ (make-directory tramp-auto-save-directory t)))
+ ;; Run plain `make-auto-save-file-name'. There might be an advice when
+ ;; it is not a magic file name operation (since Emacs 22).
+ ;; We must deactivate it temporarily.
+ (if (not (ad-is-active 'make-auto-save-file-name))
+ (tramp-run-real-handler 'make-auto-save-file-name nil)
+ ;; else
+ (ad-deactivate 'make-auto-save-file-name)
+ (prog1
+ (tramp-run-real-handler 'make-auto-save-file-name nil)
+ (ad-activate 'make-auto-save-file-name)))))
+
+;; CCC grok LOCKNAME
+(defun tramp-sh-handle-write-region
+ (start end filename &optional append visit lockname confirm)
+ "Like `write-region' for Tramp files."
+ (setq filename (expand-file-name filename))
+ (with-parsed-tramp-file-name filename nil
+ ;; Following part commented out because we don't know what to do about
+ ;; file locking, and it does not appear to be a problem to ignore it.
+ ;; Ange-ftp ignores it, too.
+ ;; (when (and lockname (stringp lockname))
+ ;; (setq lockname (expand-file-name lockname)))
+ ;; (unless (or (eq lockname nil)
+ ;; (string= lockname filename))
+ ;; (error
+ ;; "tramp-sh-handle-write-region: LOCKNAME must be nil or equal FILENAME"))
+
+ ;; XEmacs takes a coding system as the seventh argument, not `confirm'.
+ (when (and (not (featurep 'xemacs)) confirm (file-exists-p filename))
+ (unless (y-or-n-p (format "File %s exists; overwrite anyway? " filename))
+ (tramp-error v 'file-error "File not overwritten")))
+
+ (let ((uid (or (nth 2 (tramp-compat-file-attributes filename 'integer))
+ (tramp-get-remote-uid v 'integer)))
+ (gid (or (nth 3 (tramp-compat-file-attributes filename 'integer))
+ (tramp-get-remote-gid v 'integer))))
+
+ (if (and (tramp-local-host-p v)
+ ;; `file-writable-p' calls `file-expand-file-name'. We
+ ;; cannot use `tramp-run-real-handler' therefore.
+ (let (file-name-handler-alist)
+ (and
+ (file-writable-p (file-name-directory localname))
+ (or (file-directory-p localname)
+ (file-writable-p localname)))))
+ ;; Short track: if we are on the local host, we can run directly.
+ (tramp-run-real-handler
+ 'write-region
+ (list start end localname append 'no-message lockname confirm))
+
+ (let ((modes (save-excursion (tramp-default-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. This
+ ;; way, any intermediary coding systems used while
+ ;; talking to the remote shell or suchlike won't hose
+ ;; this variable. This approach was snarfed from
+ ;; ange-ftp.el.
+ coding-system-used
+ ;; Write region into a tmp file. This isn't really
+ ;; needed if we use an encoding function, but currently
+ ;; we use it always because this makes the logic
+ ;; simpler.
+ (tmpfile (or tramp-temp-buffer-file-name
+ (tramp-compat-make-temp-file filename))))
+
+ ;; If `append' is non-nil, we copy the file locally, and let
+ ;; the native `write-region' implementation do the job.
+ (when append (copy-file filename tmpfile 'ok))
+
+ ;; We say `no-message' here because we don't want the
+ ;; visited file modtime data to be clobbered from the temp
+ ;; file. We call `set-visited-file-modtime' ourselves later
+ ;; on. We must ensure that `file-coding-system-alist'
+ ;; matches `tmpfile'.
+ (let (file-name-handler-alist
+ (file-coding-system-alist
+ (tramp-find-file-name-coding-system-alist filename tmpfile)))
+ (condition-case err
+ (tramp-run-real-handler
+ 'write-region
+ (list start end tmpfile append 'no-message lockname confirm))
+ ((error quit)
+ (setq tramp-temp-buffer-file-name nil)
+ (delete-file tmpfile)
+ (signal (car err) (cdr err))))
+
+ ;; Now, `last-coding-system-used' has the right value. Remember it.
+ (when (boundp 'last-coding-system-used)
+ (setq coding-system-used
+ (symbol-value 'last-coding-system-used))))
+
+ ;; 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.
+ ;; Ensure, that it is still readable.
+ (when modes
+ (set-file-modes
+ tmpfile
+ (logior (or modes 0) (tramp-compat-octal-to-decimal "0400"))))
+
+ ;; This is a bit lengthy due to the different methods
+ ;; possible for file transfer. First, we check whether the
+ ;; method uses an rcp program. If so, we call it.
+ ;; Otherwise, both encoding and decoding command must be
+ ;; specified. However, if the method _also_ specifies an
+ ;; encoding function, then that is used for encoding the
+ ;; contents of the tmp file.
+ (let* ((size (nth 7 (file-attributes tmpfile)))
+ (rem-dec (tramp-get-inline-coding v "remote-decoding" size))
+ (loc-enc (tramp-get-inline-coding v "local-encoding" size)))
+ (cond
+ ;; `copy-file' handles direct copy and out-of-band methods.
+ ((or (tramp-local-host-p v)
+ (tramp-method-out-of-band-p v size))
+ (if (and (not (stringp start))
+ (= (or end (point-max)) (point-max))
+ (= (or start (point-min)) (point-min))
+ (tramp-get-method-parameter
+ method 'tramp-copy-keep-tmpfile))
+ (progn
+ (setq tramp-temp-buffer-file-name tmpfile)
+ (condition-case err
+ ;; We keep the local file for performance
+ ;; reasons, useful for "rsync".
+ (copy-file tmpfile filename t)
+ ((error quit)
+ (setq tramp-temp-buffer-file-name nil)
+ (delete-file tmpfile)
+ (signal (car err) (cdr err)))))
+ (setq tramp-temp-buffer-file-name nil)
+ ;; Don't rename, in order to keep context in SELinux.
+ (unwind-protect
+ (copy-file tmpfile filename t)
+ (delete-file tmpfile))))
+
+ ;; Use inline file transfer.
+ (rem-dec
+ ;; Encode tmpfile.
+ (unwind-protect
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ ;; Use encoding function or command.
+ (if (functionp loc-enc)
+ (with-progress-reporter
+ v 3 (format "Encoding region using function `%s'"
+ loc-enc)
+ (let ((coding-system-for-read 'binary))
+ (insert-file-contents-literally tmpfile))
+ ;; The following `let' is a workaround for the
+ ;; base64.el that comes with pgnus-0.84. If
+ ;; both of the following conditions are
+ ;; satisfied, it tries to write to a local
+ ;; file in default-directory, but at this
+ ;; point, default-directory is remote.
+ ;; (`call-process-region' can't write to
+ ;; remote files, it seems.) The file in
+ ;; question is a tmp file anyway.
+ (let ((default-directory
+ (tramp-compat-temporary-file-directory)))
+ (funcall loc-enc (point-min) (point-max))))
+
+ (with-progress-reporter
+ v 3 (format "Encoding region using command `%s'"
+ loc-enc)
+ (unless (zerop (tramp-call-local-coding-command
+ loc-enc tmpfile t))
+ (tramp-error
+ v 'file-error
+ (concat "Cannot write to `%s', "
+ "local encoding command `%s' failed")
+ filename loc-enc))))
+
+ ;; Send buffer into remote decoding command which
+ ;; writes to remote file. Because this happens on
+ ;; the remote host, we cannot use the function.
+ (with-progress-reporter
+ v 3
+ (format "Decoding region into remote file %s" filename)
+ (goto-char (point-max))
+ (unless (bolp) (newline))
+ (tramp-send-command
+ v
+ (format
+ (concat rem-dec " <<'EOF'\n%sEOF")
+ (tramp-shell-quote-argument localname)
+ (buffer-string)))
+ (tramp-barf-unless-okay
+ v nil
+ "Couldn't write region to `%s', decode using `%s' failed"
+ filename rem-dec)
+ ;; When `file-precious-flag' is set, the region is
+ ;; written to a temporary file. Check that the
+ ;; checksum is equal to that from the local tmpfile.
+ (when file-precious-flag
+ (erase-buffer)
+ (and
+ ;; cksum runs locally, if possible.
+ (zerop (tramp-compat-call-process "cksum" tmpfile t))
+ ;; cksum runs remotely.
+ (tramp-send-command-and-check
+ v
+ (format
+ "cksum <%s" (tramp-shell-quote-argument localname)))
+ ;; ... they are different.
+ (not
+ (string-equal
+ (buffer-string)
+ (with-current-buffer (tramp-get-buffer v)
+ (buffer-string))))
+ (tramp-error
+ v 'file-error
+ (concat "Couldn't write region to `%s',"
+ " decode using `%s' failed")
+ filename rem-dec)))))
+
+ ;; Save exit.
+ (delete-file tmpfile)))
+
+ ;; That's not expected.
+ (t
+ (tramp-error
+ v 'file-error
+ (concat "Method `%s' should specify both encoding and "
+ "decoding command or an rcp program")
+ method))))
+
+ ;; Make `last-coding-system-used' have the right value.
+ (when coding-system-used
+ (set 'last-coding-system-used coding-system-used))))
+
+ (tramp-flush-file-property v (file-name-directory localname))
+ (tramp-flush-file-property v localname)
+
+ ;; We must protect `last-coding-system-used', now we have set it
+ ;; to its correct value.
+ (let (last-coding-system-used (need-chown t))
+ ;; Set file modification time.
+ (when (or (eq visit t) (stringp visit))
+ (let ((file-attr (file-attributes filename)))
+ (set-visited-file-modtime
+ ;; We must pass modtime explicitely, because filename can
+ ;; be different from (buffer-file-name), f.e. if
+ ;; `file-precious-flag' is set.
+ (nth 5 file-attr))
+ (when (and (eq (nth 2 file-attr) uid)
+ (eq (nth 3 file-attr) gid))
+ (setq need-chown nil))))
+
+ ;; Set the ownership.
+ (when need-chown
+ (tramp-set-file-uid-gid filename uid gid))
+ (when (or (eq visit t) (null visit) (stringp visit))
+ (tramp-message v 0 "Wrote %s" filename))
+ (run-hooks 'tramp-handle-write-region-hook)))))
+
+(defvar tramp-vc-registered-file-names nil
+ "List used to collect file names, which are checked during `vc-registered'.")
+
+;; VC backends check for the existence of various different special
+;; files. This is very time consuming, because every single check
+;; requires a remote command (the file cache must be invalidated).
+;; Therefore, we apply a kind of optimization. We install the file
+;; name handler `tramp-vc-file-name-handler', which does nothing but
+;; remembers all file names for which `file-exists-p' or
+;; `file-readable-p' has been applied. A first run of `vc-registered'
+;; is performed. Afterwards, a script is applied for all collected
+;; file names, using just one remote command. The result of this
+;; script is used to fill the file cache with actual values. Now we
+;; can reset the file name handlers, and we make a second run of
+;; `vc-registered', which returns the expected result without sending
+;; any other remote command.
+(defun tramp-sh-handle-vc-registered (file)
+ "Like `vc-registered' for Tramp files."
+ (tramp-compat-with-temp-message ""
+ (with-parsed-tramp-file-name file nil
+ (with-progress-reporter
+ v 3 (format "Checking `vc-registered' for %s" file)
+
+ ;; There could be new files, created by the vc backend. We
+ ;; cannot reuse the old cache entries, therefore.
+ (let (tramp-vc-registered-file-names
+ (remote-file-name-inhibit-cache (current-time))
+ (file-name-handler-alist
+ `((,tramp-file-name-regexp . tramp-vc-file-name-handler))))
+
+ ;; Here we collect only file names, which need an operation.
+ (tramp-run-real-handler 'vc-registered (list file))
+ (tramp-message v 10 "\n%s" tramp-vc-registered-file-names)
+
+ ;; Send just one command, in order to fill the cache.
+ (when tramp-vc-registered-file-names
+ (tramp-maybe-send-script
+ v
+ (format tramp-vc-registered-read-file-names
+ (tramp-get-file-exists-command v)
+ (format "%s -r" (tramp-get-test-command v)))
+ "tramp_vc_registered_read_file_names")
+
+ (dolist
+ (elt
+ (tramp-send-command-and-read
+ v
+ (format
+ "tramp_vc_registered_read_file_names <<'EOF'\n%s\nEOF\n"
+ (mapconcat 'tramp-shell-quote-argument
+ tramp-vc-registered-file-names
+ "\n"))))
+
+ (tramp-set-file-property
+ v (car elt) (cadr elt) (cadr (cdr elt))))))
+
+ ;; Second run. Now all `file-exists-p' or `file-readable-p'
+ ;; calls shall be answered from the file cache. We unset
+ ;; `process-file-side-effects' in order to keep the cache when
+ ;; `process-file' calls appear.
+ (let (process-file-side-effects)
+ (tramp-run-real-handler 'vc-registered (list file)))))))
+
+;;;###tramp-autoload
+(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."
+ (when (and tramp-locked (not tramp-locker))
+ (setq tramp-locked nil)
+ (signal 'file-error (list "Forbidden reentrant call of Tramp")))
+ (let ((tl tramp-locked))
+ (unwind-protect
+ (progn
+ (setq tramp-locked t)
+ (let ((tramp-locker t))
+ (save-match-data
+ (let ((fn (assoc operation tramp-sh-file-name-handler-alist)))
+ (if fn
+ (apply (cdr fn) args)
+ (tramp-run-real-handler operation args))))))
+ (setq tramp-locked tl))))
+
+(defun tramp-vc-file-name-handler (operation &rest args)
+ "Invoke special file name handler, which collects files to be handled."
+ (save-match-data
+ (let ((filename
+ (tramp-replace-environment-variables
+ (apply 'tramp-file-name-for-operation operation args)))
+ (fn (assoc operation tramp-sh-file-name-handler-alist)))
+ (with-parsed-tramp-file-name filename nil
+ (cond
+ ;; That's what we want: file names, for which checks are
+ ;; applied. We assume, that VC uses only `file-exists-p' and
+ ;; `file-readable-p' checks; otherwise we must extend the
+ ;; list. We do not perform any action, but return nil, in
+ ;; order to keep `vc-registered' running.
+ ((and fn (memq operation '(file-exists-p file-readable-p)))
+ (add-to-list 'tramp-vc-registered-file-names localname 'append)
+ nil)
+ ;; Tramp file name handlers like `expand-file-name'. They
+ ;; must still work.
+ (fn
+ (save-match-data (apply (cdr fn) args)))
+ ;; Default file name handlers, we don't care.
+ (t (tramp-run-real-handler operation args)))))))
+
+;;; Internal Functions:
+
+(defun tramp-maybe-send-script (vec script name)
+ "Define in remote shell function NAME implemented as SCRIPT.
+Only send the definition if it has not already been done."
+ (let* ((p (tramp-get-connection-process vec))
+ (scripts (tramp-get-connection-property p "scripts" nil)))
+ (unless (member name scripts)
+ (with-progress-reporter vec 5 (format "Sending script `%s'" name)
+ ;; The script could contain a call of Perl. This is masked with `%s'.
+ (tramp-barf-unless-okay
+ vec
+ (format "%s () {\n%s\n}" name
+ (format script (tramp-get-remote-perl vec)))
+ "Script %s sending failed" name)
+ (tramp-set-connection-property p "scripts" (cons name scripts))))))
+
+(defun tramp-set-auto-save ()
+ (when (and ;; ange-ftp has its own auto-save mechanism
+ (eq (tramp-find-foreign-file-name-handler (buffer-file-name))
+ 'tramp-sh-file-name-handler)
+ auto-save-default)
+ (auto-save-mode 1)))
+(add-hook 'find-file-hooks 'tramp-set-auto-save t)
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (remove-hook 'find-file-hooks 'tramp-set-auto-save)))
+
+(defun tramp-run-test (switch filename)
+ "Run `test' on the remote system, given a SWITCH and a FILENAME.
+Returns the exit code of the `test' program."
+ (with-parsed-tramp-file-name filename nil
+ (tramp-send-command-and-check
+ v
+ (format
+ "%s %s %s"
+ (tramp-get-test-command v)
+ switch
+ (tramp-shell-quote-argument localname)))))
+
+(defun tramp-run-test2 (format-string file1 file2)
+ "Run `test'-like program on the remote system, given FILE1, FILE2.
+FORMAT-STRING contains the program name, switches, and place holders.
+Returns the exit code of the `test' program. Barfs if the methods,
+hosts, or files, disagree."
+ (unless (tramp-equal-remote file1 file2)
+ (with-parsed-tramp-file-name (if (tramp-tramp-file-p file1) file1 file2) nil
+ (tramp-error
+ v 'file-error
+ "tramp-run-test2 only implemented for same method, user, host")))
+ (with-parsed-tramp-file-name file1 v1
+ (with-parsed-tramp-file-name file1 v2
+ (tramp-send-command-and-check
+ v1
+ (format format-string
+ (tramp-shell-quote-argument v1-localname)
+ (tramp-shell-quote-argument v2-localname))))))
+
+(defun tramp-find-executable
+ (vec progname dirlist &optional ignore-tilde ignore-path)
+ "Searches for PROGNAME in $PATH and all directories mentioned in DIRLIST.
+First arg VEC specifies the connection, PROGNAME is the program
+to search for, and DIRLIST gives the list of directories to
+search. If IGNORE-TILDE is non-nil, directory names starting
+with `~' will be ignored. If IGNORE-PATH is non-nil, searches
+only in DIRLIST.
+
+Returns the absolute file name of PROGNAME, if found, and nil otherwise.
+
+This function expects to be in the right *tramp* buffer."
+ (with-current-buffer (tramp-get-connection-buffer vec)
+ (let (result)
+ ;; Check whether the executable is in $PATH. "which(1)" does not
+ ;; report always a correct error code; therefore we check the
+ ;; number of words it returns.
+ (unless ignore-path
+ (tramp-send-command vec (format "which \\%s | wc -w" progname))
+ (goto-char (point-min))
+ (if (looking-at "^\\s-*1$")
+ (setq result (concat "\\" progname))))
+ (unless result
+ (when ignore-tilde
+ ;; Remove all ~/foo directories from dirlist. In XEmacs,
+ ;; `remove' is in CL, and we want to avoid CL dependencies.
+ (let (newdl d)
+ (while dirlist
+ (setq d (car dirlist))
+ (setq dirlist (cdr dirlist))
+ (unless (char-equal ?~ (aref d 0))
+ (setq newdl (cons d newdl))))
+ (setq dirlist (nreverse newdl))))
+ (tramp-send-command
+ vec
+ (format (concat "while read d; "
+ "do if test -x $d/%s -a -f $d/%s; "
+ "then echo tramp_executable $d/%s; "
+ "break; fi; done <<'EOF'\n"
+ "%s\nEOF")
+ progname progname progname (mapconcat 'identity dirlist "\n")))
+ (goto-char (point-max))
+ (when (search-backward "tramp_executable " nil t)
+ (skip-chars-forward "^ ")
+ (skip-chars-forward " ")
+ (setq result (buffer-substring (point) (point-at-eol)))))
+ result)))
+
+(defun tramp-set-remote-path (vec)
+ "Sets the remote environment PATH to existing directories.
+I.e., for each directory in `tramp-remote-path', it is tested
+whether it exists and if so, it is added to the environment
+variable PATH."
+ (tramp-message vec 5 (format "Setting $PATH environment variable"))
+ (tramp-send-command
+ vec (format "PATH=%s; export PATH"
+ (mapconcat 'identity (tramp-get-remote-path vec) ":"))))
+
+;; ------------------------------------------------------------
+;; -- Communication with external shell --
+;; ------------------------------------------------------------
+
+(defun tramp-find-file-exists-command (vec)
+ "Find a command on the remote host for checking if a file exists.
+Here, we are looking for a command which has zero exit status if the
+file exists and nonzero exit status otherwise."
+ (let ((existing "/")
+ (nonexisting
+ (tramp-shell-quote-argument "/ this file does not exist "))
+ result)
+ ;; The algorithm is as follows: we try a list of several commands.
+ ;; For each command, we first run `$cmd /' -- this should return
+ ;; true, as the root directory always exists. And then we run
+ ;; `$cmd /this\ file\ does\ not\ exist ', hoping that the file indeed
+ ;; does not exist. This should return false. We use the first
+ ;; command we find that seems to work.
+ ;; The list of commands to try is as follows:
+ ;; `ls -d' This works on most systems, but NetBSD 1.4
+ ;; has a bug: `ls' always returns zero exit
+ ;; status, even for files which don't exist.
+ ;; `test -e' Some Bourne shells have a `test' builtin
+ ;; which does not know the `-e' option.
+ ;; `/bin/test -e' For those, the `test' binary on disk normally
+ ;; provides the option. Alas, the binary
+ ;; is sometimes `/bin/test' and sometimes it's
+ ;; `/usr/bin/test'.
+ ;; `/usr/bin/test -e' In case `/bin/test' does not exist.
+ (unless (or
+ (and (setq result (format "%s -e" (tramp-get-test-command vec)))
+ (tramp-send-command-and-check
+ vec (format "%s %s" result existing))
+ (not (tramp-send-command-and-check
+ vec (format "%s %s" result nonexisting))))
+ (and (setq result "/bin/test -e")
+ (tramp-send-command-and-check
+ vec (format "%s %s" result existing))
+ (not (tramp-send-command-and-check
+ vec (format "%s %s" result nonexisting))))
+ (and (setq result "/usr/bin/test -e")
+ (tramp-send-command-and-check
+ vec (format "%s %s" result existing))
+ (not (tramp-send-command-and-check
+ vec (format "%s %s" result nonexisting))))
+ (and (setq result (format "%s -d" (tramp-get-ls-command vec)))
+ (tramp-send-command-and-check
+ vec (format "%s %s" result existing))
+ (not (tramp-send-command-and-check
+ vec (format "%s %s" result nonexisting)))))
+ (tramp-error
+ vec 'file-error "Couldn't find command to check if file exists"))
+ result))
+
+(defun tramp-open-shell (vec shell)
+ "Opens shell SHELL."
+ (with-progress-reporter vec 5 (format "Opening remote shell `%s'" shell)
+ ;; Find arguments for this shell.
+ (let ((tramp-end-of-output tramp-initial-end-of-output)
+ (alist tramp-sh-extra-args)
+ item extra-args)
+ (while (and alist (null extra-args))
+ (setq item (pop alist))
+ (when (string-match (car item) shell)
+ (setq extra-args (cdr item))))
+ (when extra-args (setq shell (concat shell " " extra-args)))
+ (tramp-send-command
+ vec (format "exec env ENV='' PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s"
+ (shell-quote-argument tramp-end-of-output) shell)
+ t))
+ ;; Setting prompts.
+ (tramp-send-command
+ vec (format "PS1=%s" (shell-quote-argument tramp-end-of-output)) t)
+ (tramp-send-command vec "PS2=''" t)
+ (tramp-send-command vec "PS3=''" t)
+ (tramp-send-command vec "PROMPT_COMMAND=''" t)))
+
+(defun tramp-find-shell (vec)
+ "Opens a shell on the remote host which groks tilde expansion."
+ (unless (tramp-get-connection-property vec "remote-shell" nil)
+ (let (shell)
+ (with-current-buffer (tramp-get-buffer vec)
+ (tramp-send-command vec "echo ~root" t)
+ (cond
+ ((or (string-match "^~root$" (buffer-string))
+ ;; The default shell (ksh93) of OpenSolaris is buggy.
+ (string-equal (tramp-get-connection-property vec "uname" "")
+ "SunOS 5.11"))
+ (setq shell
+ (or (tramp-find-executable
+ vec "bash" (tramp-get-remote-path vec) t t)
+ (tramp-find-executable
+ vec "ksh" (tramp-get-remote-path vec) t t)))
+ (unless shell
+ (tramp-error
+ vec 'file-error
+ "Couldn't find a shell which groks tilde expansion"))
+ (tramp-message
+ vec 5 "Starting remote shell `%s' for tilde expansion" shell)
+ (tramp-open-shell vec shell))
+
+ (t (tramp-message
+ vec 5 "Remote `%s' groks tilde expansion, good"
+ (tramp-set-connection-property
+ vec "remote-shell"
+ (tramp-get-method-parameter
+ (tramp-file-name-method vec) 'tramp-remote-sh)))))))))
+
+;; Utility functions.
+
+(defun tramp-barf-if-no-shell-prompt (proc timeout &rest error-args)
+ "Wait for shell prompt and barf if none appears.
+Looks at process PROC to see if a shell prompt appears in TIMEOUT
+seconds. If not, it produces an error message with the given ERROR-ARGS."
+ (unless
+ (tramp-wait-for-regexp
+ proc timeout
+ (format
+ "\\(%s\\|%s\\)\\'" shell-prompt-pattern tramp-shell-prompt-pattern))
+ (apply 'tramp-error-with-buffer nil proc 'file-error error-args)))
+
+(defun tramp-open-connection-setup-interactive-shell (proc vec)
+ "Set up an interactive shell.
+Mainly sets the prompt and the echo correctly. PROC is the shell
+process to set up. VEC specifies the connection."
+ (let ((tramp-end-of-output tramp-initial-end-of-output))
+ ;; It is useful to set the prompt in the following command because
+ ;; some people have a setting for $PS1 which /bin/sh doesn't know
+ ;; about and thus /bin/sh will display a strange prompt. For
+ ;; example, if $PS1 has "${CWD}" in the value, then ksh will
+ ;; display the current working directory but /bin/sh will display
+ ;; a dollar sign. The following command line sets $PS1 to a sane
+ ;; value, and works under Bourne-ish shells as well as csh-like
+ ;; shells. Daniel Pittman reports that the unusual positioning of
+ ;; the single quotes makes it work under `rc', too. We also unset
+ ;; the variable $ENV because that is read by some sh
+ ;; implementations (eg, bash when called as sh) on startup; this
+ ;; way, we avoid the startup file clobbering $PS1. $PROMPT_COMMAND
+ ;; is another way to set the prompt in /bin/bash, it must be
+ ;; discarded as well.
+ (tramp-open-shell
+ vec
+ (tramp-get-method-parameter (tramp-file-name-method vec) 'tramp-remote-sh))
+
+ ;; Disable echo.
+ (tramp-message vec 5 "Setting up remote shell environment")
+ (tramp-send-command vec "stty -inlcr -echo kill '^U' erase '^H'" t)
+ ;; Check whether the echo has really been disabled. Some
+ ;; implementations, like busybox of embedded GNU/Linux, don't
+ ;; support disabling.
+ (tramp-send-command vec "echo foo" t)
+ (with-current-buffer (process-buffer proc)
+ (goto-char (point-min))
+ (when (looking-at "echo foo")
+ (tramp-set-connection-property proc "remote-echo" t)
+ (tramp-message vec 5 "Remote echo still on. Ok.")
+ ;; Make sure backspaces and their echo are enabled and no line
+ ;; width magic interferes with them.
+ (tramp-send-command vec "stty icanon erase ^H cols 32767" t))))
+
+ (tramp-message vec 5 "Setting shell prompt")
+ (tramp-send-command
+ vec (format "PS1=%s" (shell-quote-argument tramp-end-of-output)) t)
+ (tramp-send-command vec "PS2=''" t)
+ (tramp-send-command vec "PS3=''" t)
+ (tramp-send-command vec "PROMPT_COMMAND=''" t)
+
+ ;; Try to set up the coding system correctly.
+ ;; CCC this can't be the right way to do it. Hm.
+ (tramp-message vec 5 "Determining coding system")
+ (tramp-send-command vec "echo foo ; echo bar" t)
+ (with-current-buffer (process-buffer proc)
+ (goto-char (point-min))
+ (if (featurep 'mule)
+ ;; Use MULE to select the right EOL convention for communicating
+ ;; with the process.
+ (let* ((cs (or (tramp-compat-funcall 'process-coding-system proc)
+ (cons 'undecided 'undecided)))
+ cs-decode cs-encode)
+ (when (symbolp cs) (setq cs (cons cs cs)))
+ (setq cs-decode (car cs))
+ (setq cs-encode (cdr cs))
+ (unless cs-decode (setq cs-decode 'undecided))
+ (unless cs-encode (setq cs-encode 'undecided))
+ (setq cs-encode (tramp-compat-coding-system-change-eol-conversion
+ cs-encode 'unix))
+ (when (search-forward "\r" nil t)
+ (setq cs-decode (tramp-compat-coding-system-change-eol-conversion
+ cs-decode 'dos)))
+ (tramp-compat-funcall
+ 'set-buffer-process-coding-system cs-decode cs-encode)
+ (tramp-message
+ vec 5 "Setting coding system to `%s' and `%s'" cs-decode cs-encode))
+ ;; Look for ^M and do something useful if found.
+ (when (search-forward "\r" nil t)
+ ;; We have found a ^M but cannot frob the process coding system
+ ;; because we're running on a non-MULE Emacs. Let's try
+ ;; stty, instead.
+ (tramp-send-command vec "stty -onlcr" t))))
+
+ (tramp-send-command vec "set +o vi +o emacs" t)
+
+ ;; Check whether the output of "uname -sr" has been changed. If
+ ;; yes, this is a strong indication that we must expire all
+ ;; connection properties. We start again with
+ ;; `tramp-maybe-open-connection', it will be catched there.
+ (tramp-message vec 5 "Checking system information")
+ (let ((old-uname (tramp-get-connection-property vec "uname" nil))
+ (new-uname
+ (tramp-set-connection-property
+ vec "uname"
+ (tramp-send-command-and-read vec "echo \\\"`uname -sr`\\\""))))
+ (when (and (stringp old-uname) (not (string-equal old-uname new-uname)))
+ (with-current-buffer (tramp-get-debug-buffer vec)
+ ;; Keep the debug buffer.
+ (rename-buffer
+ (generate-new-buffer-name tramp-temp-buffer-name) 'unique)
+ (tramp-cleanup-connection vec)
+ (if (= (point-min) (point-max))
+ (kill-buffer nil)
+ (rename-buffer (tramp-debug-buffer-name vec) 'unique))
+ ;; We call `tramp-get-buffer' in order to keep the debug buffer.
+ (tramp-get-buffer vec)
+ (tramp-message
+ vec 3
+ "Connection reset, because remote host changed from `%s' to `%s'"
+ old-uname new-uname)
+ (throw 'uname-changed (tramp-maybe-open-connection vec)))))
+
+ ;; Check whether the remote host suffers from buggy
+ ;; `send-process-string'. This is known for FreeBSD (see comment in
+ ;; `send_process', file process.c). I've tested sending 624 bytes
+ ;; successfully, sending 625 bytes failed. Emacs makes a hack when
+ ;; this host type is detected locally. It cannot handle remote
+ ;; hosts, though.
+ (with-connection-property proc "chunksize"
+ (cond
+ ((and (integerp tramp-chunksize) (> tramp-chunksize 0))
+ tramp-chunksize)
+ (t
+ (tramp-message
+ vec 5 "Checking remote host type for `send-process-string' bug")
+ (if (string-match
+ "^FreeBSD" (tramp-get-connection-property vec "uname" ""))
+ 500 0))))
+
+ ;; Set remote PATH variable.
+ (tramp-set-remote-path vec)
+
+ ;; Search for a good shell before searching for a command which
+ ;; checks if a file exists. This is done because Tramp wants to use
+ ;; "test foo; echo $?" to check if various conditions hold, and
+ ;; there are buggy /bin/sh implementations which don't execute the
+ ;; "echo $?" part if the "test" part has an error. In particular,
+ ;; the OpenSolaris /bin/sh is a problem. There are also other
+ ;; problems with /bin/sh of OpenSolaris, like redirection of stderr
+ ;; in function declarations, or changing HISTFILE in place.
+ ;; Therefore, OpenSolaris' /bin/sh is replaced by bash, when
+ ;; detected.
+ (tramp-find-shell vec)
+
+ ;; Disable unexpected output.
+ (tramp-send-command vec "mesg n; biff n" t)
+
+ ;; IRIX64 bash expands "!" even when in single quotes. This
+ ;; destroys our shell functions, we must disable it. See
+ ;; <http://stackoverflow.com/questions/3291692/irix-bash-shell-expands-expression-in-single-quotes-yet-shouldnt>.
+ (when (string-match "^IRIX64" (tramp-get-connection-property vec "uname" ""))
+ (tramp-send-command vec "set +H" t))
+
+ ;; On BSD-like systems, ?\t is expanded to spaces. Suppress this.
+ (when (string-match "BSD\\|Darwin"
+ (tramp-get-connection-property vec "uname" ""))
+ (tramp-send-command vec "stty -oxtabs" t))
+
+ ;; Set `remote-tty' process property.
+ (ignore-errors
+ (let ((tty (tramp-send-command-and-read vec "echo \\\"`tty`\\\"")))
+ (unless (zerop (length tty))
+ (tramp-compat-process-put proc 'remote-tty tty))))
+
+ ;; Dump stty settings in the traces.
+ (when (>= tramp-verbose 9)
+ (tramp-send-command vec "stty -a" t))
+
+ ;; Set the environment.
+ (tramp-message vec 5 "Setting default environment")
+
+ (let ((env (copy-sequence tramp-remote-process-environment))
+ unset item)
+ (while env
+ (setq item (tramp-compat-split-string (car env) "="))
+ (setcdr item (mapconcat 'identity (cdr item) "="))
+ (if (and (stringp (cdr item)) (not (string-equal (cdr item) "")))
+ (tramp-send-command
+ vec (format "%s=%s; export %s" (car item) (cdr item) (car item)) t)
+ (push (car item) unset))
+ (setq env (cdr env)))
+ (when unset
+ (tramp-send-command
+ vec (format "unset %s" (mapconcat 'identity unset " ")) t))))
+
+;; CCC: We should either implement a Perl version of base64 encoding
+;; and decoding. Then we just use that in the last item. The other
+;; alternative is to use the Perl version of UU encoding. But then
+;; we need a Lisp version of uuencode.
+;;
+;; Old text from documentation of tramp-methods:
+;; Using a uuencode/uudecode inline method is discouraged, please use one
+;; of the base64 methods instead since base64 encoding is much more
+;; reliable and the commands are more standardized between the different
+;; Unix versions. But if you can't use base64 for some reason, please
+;; note that the default uudecode command does not work well for some
+;; Unices, in particular AIX and Irix. For AIX, you might want to use
+;; the following command for uudecode:
+;;
+;; sed '/^begin/d;/^[` ]$/d;/^end/d' | iconv -f uucode -t ISO8859-1
+;;
+;; For Irix, no solution is known yet.
+
+(autoload 'uudecode-decode-region "uudecode")
+
+(defconst tramp-local-coding-commands
+ '((b64 base64-encode-region base64-decode-region)
+ (uu tramp-uuencode-region uudecode-decode-region)
+ (pack
+ "perl -e 'binmode STDIN; binmode STDOUT; print pack(q{u*}, join q{}, <>)'"
+ "perl -e 'binmode STDIN; binmode STDOUT; print unpack(q{u*}, join q{}, <>)'"))
+ "List of local coding commands for inline transfer.
+Each item is a list that looks like this:
+
+\(FORMAT ENCODING DECODING\)
+
+FORMAT is symbol describing the encoding/decoding format. It can be
+`b64' for base64 encoding, `uu' for uu encoding, or `pack' for simple packing.
+
+ENCODING and DECODING can be strings, giving commands, or symbols,
+giving functions. If they are strings, then they can contain
+the \"%s\" format specifier. If that specifier is present, the input
+filename will be put into the command line at that spot. If the
+specifier is not present, the input should be read from standard
+input.
+
+If they are functions, they will be called with two arguments, start
+and end of region, and are expected to replace the region contents
+with the encoded or decoded results, respectively.")
+
+(defconst tramp-remote-coding-commands
+ '((b64 "base64" "base64 -d -i")
+ ;; "-i" is more robust with older base64 from GNU coreutils.
+ ;; However, I don't know whether all base64 versions do supports
+ ;; this option.
+ (b64 "base64" "base64 -d")
+ (b64 "mimencode -b" "mimencode -u -b")
+ (b64 "mmencode -b" "mmencode -u -b")
+ (b64 "recode data..base64" "recode base64..data")
+ (b64 tramp-perl-encode-with-module tramp-perl-decode-with-module)
+ (b64 tramp-perl-encode tramp-perl-decode)
+ (uu "uuencode xxx" "uudecode -o /dev/stdout")
+ (uu "uuencode xxx" "uudecode -o -")
+ (uu "uuencode xxx" "uudecode -p")
+ (uu "uuencode xxx" tramp-uudecode)
+ (pack
+ "perl -e 'binmode STDIN; binmode STDOUT; print pack(q{u*}, join q{}, <>)'"
+ "perl -e 'binmode STDIN; binmode STDOUT; print unpack(q{u*}, join q{}, <>)'"))
+ "List of remote coding commands for inline transfer.
+Each item is a list that looks like this:
+
+\(FORMAT ENCODING DECODING\)
+
+FORMAT is symbol describing the encoding/decoding format. It can be
+`b64' for base64 encoding, `uu' for uu encoding, or `pack' for simple packing.
+
+ENCODING and DECODING can be strings, giving commands, or symbols,
+giving variables. If they are strings, then they can contain
+the \"%s\" format specifier. If that specifier is present, the input
+filename will be put into the command line at that spot. If the
+specifier is not present, the input should be read from standard
+input.
+
+If they are variables, this variable is a string containing a Perl
+implementation for this functionality. This Perl program will be transferred
+to the remote host, and it is available as shell function with the same name.")
+
+(defun tramp-find-inline-encoding (vec)
+ "Find an inline transfer encoding that works.
+Goes through the list `tramp-local-coding-commands' and
+`tramp-remote-coding-commands'."
+ (save-excursion
+ (let ((local-commands tramp-local-coding-commands)
+ (magic "xyzzy")
+ loc-enc loc-dec rem-enc rem-dec litem ritem found)
+ (while (and local-commands (not found))
+ (setq litem (pop local-commands))
+ (catch 'wont-work-local
+ (let ((format (nth 0 litem))
+ (remote-commands tramp-remote-coding-commands))
+ (setq loc-enc (nth 1 litem))
+ (setq loc-dec (nth 2 litem))
+ ;; If the local encoder or decoder is a string, the
+ ;; corresponding command has to work locally.
+ (if (not (stringp loc-enc))
+ (tramp-message
+ vec 5 "Checking local encoding function `%s'" loc-enc)
+ (tramp-message
+ vec 5 "Checking local encoding command `%s' for sanity" loc-enc)
+ (unless (zerop (tramp-call-local-coding-command
+ loc-enc nil nil))
+ (throw 'wont-work-local nil)))
+ (if (not (stringp loc-dec))
+ (tramp-message
+ vec 5 "Checking local decoding function `%s'" loc-dec)
+ (tramp-message
+ vec 5 "Checking local decoding command `%s' for sanity" loc-dec)
+ (unless (zerop (tramp-call-local-coding-command
+ loc-dec nil nil))
+ (throw 'wont-work-local nil)))
+ ;; Search for remote coding commands with the same format
+ (while (and remote-commands (not found))
+ (setq ritem (pop remote-commands))
+ (catch 'wont-work-remote
+ (when (equal format (nth 0 ritem))
+ (setq rem-enc (nth 1 ritem))
+ (setq rem-dec (nth 2 ritem))
+ ;; Check if remote encoding and decoding commands can be
+ ;; called remotely with null input and output. This makes
+ ;; sure there are no syntax errors and the command is really
+ ;; found. Note that we do not redirect stdout to /dev/null,
+ ;; for two reasons: when checking the decoding command, we
+ ;; actually check the output it gives. And also, when
+ ;; redirecting "mimencode" output to /dev/null, then as root
+ ;; it might change the permissions of /dev/null!
+ (when (not (stringp rem-enc))
+ (let ((name (symbol-name rem-enc)))
+ (while (string-match (regexp-quote "-") name)
+ (setq name (replace-match "_" nil t name)))
+ (tramp-maybe-send-script vec (symbol-value rem-enc) name)
+ (setq rem-enc name)))
+ (tramp-message
+ vec 5
+ "Checking remote encoding command `%s' for sanity" rem-enc)
+ (unless (tramp-send-command-and-check
+ vec (format "%s </dev/null" rem-enc) t)
+ (throw 'wont-work-remote nil))
+
+ (when (not (stringp rem-dec))
+ (let ((name (symbol-name rem-dec)))
+ (while (string-match (regexp-quote "-") name)
+ (setq name (replace-match "_" nil t name)))
+ (tramp-maybe-send-script vec (symbol-value rem-dec) name)
+ (setq rem-dec name)))
+ (tramp-message
+ vec 5
+ "Checking remote decoding command `%s' for sanity" rem-dec)
+ (unless (tramp-send-command-and-check
+ vec
+ (format "echo %s | %s | %s" magic rem-enc rem-dec)
+ t)
+ (throw 'wont-work-remote nil))
+
+ (with-current-buffer (tramp-get-buffer vec)
+ (goto-char (point-min))
+ (unless (looking-at (regexp-quote magic))
+ (throw 'wont-work-remote nil)))
+
+ ;; `rem-enc' and `rem-dec' could be a string meanwhile.
+ (setq rem-enc (nth 1 ritem))
+ (setq rem-dec (nth 2 ritem))
+ (setq found t)))))))
+
+ ;; Did we find something?
+ (unless found
+ (tramp-error
+ vec 'file-error "Couldn't find an inline transfer encoding"))
+
+ ;; Set connection properties.
+ (tramp-message vec 5 "Using local encoding `%s'" loc-enc)
+ (tramp-set-connection-property vec "local-encoding" loc-enc)
+ (tramp-message vec 5 "Using local decoding `%s'" loc-dec)
+ (tramp-set-connection-property vec "local-decoding" loc-dec)
+ (tramp-message vec 5 "Using remote encoding `%s'" rem-enc)
+ (tramp-set-connection-property vec "remote-encoding" rem-enc)
+ (tramp-message vec 5 "Using remote decoding `%s'" rem-dec)
+ (tramp-set-connection-property vec "remote-decoding" rem-dec))))
+
+(defun tramp-call-local-coding-command (cmd input output)
+ "Call the local encoding or decoding command.
+If CMD contains \"%s\", provide input file INPUT there in command.
+Otherwise, INPUT is passed via standard input.
+INPUT can also be nil which means `/dev/null'.
+OUTPUT can be a string (which specifies a filename), or t (which
+means standard output and thus the current buffer), or nil (which
+means discard it)."
+ (tramp-compat-call-process
+ tramp-encoding-shell
+ (when (and input (not (string-match "%s" cmd))) input)
+ (if (eq output t) t nil)
+ nil
+ tramp-encoding-command-switch
+ (concat
+ (if (string-match "%s" cmd) (format cmd input) cmd)
+ (if (stringp output) (concat "> " output) ""))))
+
+(defconst tramp-inline-compress-commands
+ '(("gzip" "gzip -d")
+ ("bzip2" "bzip2 -d")
+ ("compress" "compress -d"))
+ "List of compress and decompress commands for inline transfer.
+Each item is a list that looks like this:
+
+\(COMPRESS DECOMPRESS\)
+
+COMPRESS or DECOMPRESS are strings with the respective commands.")
+
+(defun tramp-find-inline-compress (vec)
+ "Find an inline transfer compress command that works.
+Goes through the list `tramp-inline-compress-commands'."
+ (save-excursion
+ (let ((commands tramp-inline-compress-commands)
+ (magic "xyzzy")
+ item compress decompress
+ found)
+ (while (and commands (not found))
+ (catch 'next
+ (setq item (pop commands)
+ compress (nth 0 item)
+ decompress (nth 1 item))
+ (tramp-message
+ vec 5
+ "Checking local compress command `%s', `%s' for sanity"
+ compress decompress)
+ (unless (zerop (tramp-call-local-coding-command
+ (format "echo %s | %s | %s"
+ magic compress decompress) nil nil))
+ (throw 'next nil))
+ (tramp-message
+ vec 5
+ "Checking remote compress command `%s', `%s' for sanity"
+ compress decompress)
+ (unless (tramp-send-command-and-check
+ vec (format "echo %s | %s | %s" magic compress decompress) t)
+ (throw 'next nil))
+ (setq found t)))
+
+ ;; Did we find something?
+ (if found
+ (progn
+ ;; Set connection properties.
+ (tramp-message
+ vec 5 "Using inline transfer compress command `%s'" compress)
+ (tramp-set-connection-property vec "inline-compress" compress)
+ (tramp-message
+ vec 5 "Using inline transfer decompress command `%s'" decompress)
+ (tramp-set-connection-property vec "inline-decompress" decompress))
+
+ (tramp-set-connection-property vec "inline-compress" nil)
+ (tramp-set-connection-property vec "inline-decompress" nil)
+ (tramp-message
+ vec 2 "Couldn't find an inline transfer compress command")))))
+
+(defun tramp-compute-multi-hops (vec)
+ "Expands VEC according to `tramp-default-proxies-alist'.
+Gateway hops are already opened."
+ (let ((target-alist `(,vec))
+ (choices tramp-default-proxies-alist)
+ item proxy)
+
+ ;; Look for proxy hosts to be passed.
+ (while choices
+ (setq item (pop choices)
+ proxy (eval (nth 2 item)))
+ (when (and
+ ;; host
+ (string-match (or (eval (nth 0 item)) "")
+ (or (tramp-file-name-host (car target-alist)) ""))
+ ;; user
+ (string-match (or (eval (nth 1 item)) "")
+ (or (tramp-file-name-user (car target-alist)) "")))
+ (if (null proxy)
+ ;; No more hops needed.
+ (setq choices nil)
+ ;; Replace placeholders.
+ (setq proxy
+ (format-spec
+ proxy
+ (format-spec-make
+ ?u (or (tramp-file-name-user (car target-alist)) "")
+ ?h (or (tramp-file-name-host (car target-alist)) ""))))
+ (with-parsed-tramp-file-name proxy l
+ ;; Add the hop.
+ (add-to-list 'target-alist l)
+ ;; Start next search.
+ (setq choices tramp-default-proxies-alist)))))
+
+ ;; Handle gateways.
+ (when (string-match
+ (format
+ "^\\(%s\\|%s\\)$" tramp-gw-tunnel-method tramp-gw-socks-method)
+ (tramp-file-name-method (car target-alist)))
+ (let ((gw (pop target-alist))
+ (hop (pop target-alist)))
+ ;; Is the method prepared for gateways?
+ (unless (tramp-get-method-parameter
+ (tramp-file-name-method hop) 'tramp-default-port)
+ (tramp-error
+ vec 'file-error
+ "Method `%s' is not supported for gateway access."
+ (tramp-file-name-method hop)))
+ ;; Add default port if needed.
+ (unless
+ (string-match
+ tramp-host-with-port-regexp (tramp-file-name-host hop))
+ (aset hop 2
+ (concat
+ (tramp-file-name-host hop) tramp-prefix-port-format
+ (number-to-string
+ (tramp-get-method-parameter
+ (tramp-file-name-method hop) 'tramp-default-port)))))
+ ;; Open the gateway connection.
+ (add-to-list
+ 'target-alist
+ (vector
+ (tramp-file-name-method hop) (tramp-file-name-user hop)
+ (tramp-compat-funcall 'tramp-gw-open-connection vec gw hop) nil))
+ ;; For the password prompt, we need the correct values.
+ ;; Therefore, we must remember the gateway vector. But we
+ ;; cannot do it as connection property, because it shouldn't
+ ;; be persistent. And we have no started process yet either.
+ (tramp-set-file-property (car target-alist) "" "gateway" hop)))
+
+ ;; Foreign and out-of-band methods are not supported for multi-hops.
+ (when (cdr target-alist)
+ (setq choices target-alist)
+ (while choices
+ (setq item (pop choices))
+ (when
+ (or
+ (not
+ (tramp-get-method-parameter
+ (tramp-file-name-method item) 'tramp-login-program))
+ (tramp-get-method-parameter
+ (tramp-file-name-method item) 'tramp-copy-program))
+ (tramp-error
+ vec 'file-error
+ "Method `%s' is not supported for multi-hops."
+ (tramp-file-name-method item)))))
+
+ ;; In case the host name is not used for the remote shell
+ ;; command, the user could be misguided by applying a random
+ ;; hostname.
+ (let* ((v (car target-alist))
+ (method (tramp-file-name-method v))
+ (host (tramp-file-name-host v)))
+ (unless
+ (or
+ ;; There are multi-hops.
+ (cdr target-alist)
+ ;; The host name is used for the remote shell command.
+ (member
+ '("%h") (tramp-get-method-parameter method 'tramp-login-args))
+ ;; The host is local. We cannot use `tramp-local-host-p'
+ ;; here, because it opens a connection as well.
+ (string-match tramp-local-host-regexp host))
+ (tramp-error
+ v 'file-error
+ "Host `%s' looks like a remote host, `%s' can only use the local host"
+ host method)))
+
+ ;; Result.
+ target-alist))
+
+(defun tramp-maybe-open-connection (vec)
+ "Maybe open a connection VEC.
+Does not do anything if a connection is already open, but re-opens the
+connection if a previous connection has died for some reason."
+ (catch 'uname-changed
+ (let ((p (tramp-get-connection-process vec))
+ (process-name (tramp-get-connection-property vec "process-name" nil))
+ (process-environment (copy-sequence process-environment)))
+
+ ;; If too much time has passed since last command was sent, look
+ ;; whether process is still alive. If it isn't, kill it. When
+ ;; using ssh, it can sometimes happen that the remote end has
+ ;; hung up but the local ssh client doesn't recognize this until
+ ;; it tries to send some data to the remote end. So that's why
+ ;; we try to send a command from time to time, then look again
+ ;; whether the process is really alive.
+ (condition-case nil
+ (when (and (> (tramp-time-diff
+ (current-time)
+ (tramp-get-connection-property
+ p "last-cmd-time" '(0 0 0)))
+ 60)
+ p (processp p) (memq (process-status p) '(run open)))
+ (tramp-send-command vec "echo are you awake" t t)
+ (unless (and (memq (process-status p) '(run open))
+ (tramp-wait-for-output p 10))
+ ;; The error will be catched locally.
+ (tramp-error vec 'file-error "Awake did fail")))
+ (file-error
+ (tramp-flush-connection-property vec)
+ (tramp-flush-connection-property p)
+ (delete-process p)
+ (setq p nil)))
+
+ ;; New connection must be opened.
+ (unless (and p (processp p) (memq (process-status p) '(run open)))
+
+ ;; We call `tramp-get-buffer' in order to get a debug buffer for
+ ;; messages from the beginning.
+ (tramp-get-buffer vec)
+ (with-progress-reporter
+ vec 3
+ (if (zerop (length (tramp-file-name-user vec)))
+ (format "Opening connection for %s using %s"
+ (tramp-file-name-host vec)
+ (tramp-file-name-method vec))
+ (format "Opening connection for %s@%s using %s"
+ (tramp-file-name-user vec)
+ (tramp-file-name-host vec)
+ (tramp-file-name-method vec)))
+
+ ;; Start new process.
+ (when (and p (processp p))
+ (delete-process p))
+ (setenv "TERM" tramp-terminal-type)
+ (setenv "LC_ALL" "C")
+ (setenv "PROMPT_COMMAND")
+ (setenv "PS1" tramp-initial-end-of-output)
+ (let* ((target-alist (tramp-compute-multi-hops vec))
+ (process-connection-type tramp-process-connection-type)
+ (process-adaptive-read-buffering nil)
+ (coding-system-for-read nil)
+ ;; This must be done in order to avoid our file name handler.
+ (p (let ((default-directory
+ (tramp-compat-temporary-file-directory)))
+ (start-process
+ (or process-name (tramp-buffer-name vec))
+ (tramp-get-connection-buffer vec)
+ tramp-encoding-shell))))
+
+ (tramp-message
+ vec 6 "%s" (mapconcat 'identity (process-command p) " "))
+
+ ;; Check whether process is alive.
+ (tramp-compat-set-process-query-on-exit-flag p nil)
+ (tramp-barf-if-no-shell-prompt
+ p 60 "Couldn't find local shell prompt %s" tramp-encoding-shell)
+
+ ;; Now do all the connections as specified.
+ (while target-alist
+ (let* ((hop (car target-alist))
+ (l-method (tramp-file-name-method hop))
+ (l-user (tramp-file-name-user hop))
+ (l-host (tramp-file-name-host hop))
+ (l-port nil)
+ (login-program
+ (tramp-get-method-parameter
+ l-method 'tramp-login-program))
+ (login-args
+ (tramp-get-method-parameter l-method 'tramp-login-args))
+ (async-args
+ (tramp-get-method-parameter l-method 'tramp-async-args))
+ (gw-args
+ (tramp-get-method-parameter l-method 'tramp-gw-args))
+ (gw (tramp-get-file-property hop "" "gateway" nil))
+ (g-method (and gw (tramp-file-name-method gw)))
+ (g-user (and gw (tramp-file-name-user gw)))
+ (g-host (and gw (tramp-file-name-host gw)))
+ (command login-program)
+ ;; We don't create the temporary file. In fact,
+ ;; it is just a prefix for the ControlPath option
+ ;; of ssh; the real temporary file has another
+ ;; name, and it is created and protected by ssh.
+ ;; It is also removed by ssh, when the connection
+ ;; is closed.
+ (tmpfile
+ (tramp-set-connection-property
+ p "temp-file"
+ (make-temp-name
+ (expand-file-name
+ tramp-temp-name-prefix
+ (tramp-compat-temporary-file-directory)))))
+ spec)
+
+ ;; Add arguments for asynchrononous processes.
+ (when (and process-name async-args)
+ (setq login-args (append async-args login-args)))
+
+ ;; Add gateway arguments if necessary.
+ (when (and gw gw-args)
+ (setq login-args (append gw-args login-args)))
+
+ ;; Check for port number. Until now, there's no need
+ ;; for handling like method, user, host.
+ (when (string-match tramp-host-with-port-regexp l-host)
+ (setq l-port (match-string 2 l-host)
+ l-host (match-string 1 l-host)))
+
+ ;; Set variables for computing the prompt for reading
+ ;; password. They can also be derived from a gateway.
+ (setq tramp-current-method (or g-method l-method)
+ tramp-current-user (or g-user l-user)
+ tramp-current-host (or g-host l-host))
+
+ ;; Replace login-args place holders.
+ (setq
+ l-host (or l-host "")
+ l-user (or l-user "")
+ l-port (or l-port "")
+ spec (format-spec-make
+ ?h l-host ?u l-user ?p l-port ?t tmpfile)
+ command
+ (concat
+ ;; We do not want to see the trailing local prompt in
+ ;; `start-file-process'.
+ (unless (memq system-type '(windows-nt)) "exec ")
+ command " "
+ (mapconcat
+ (lambda (x)
+ (setq x (mapcar (lambda (y) (format-spec y spec)) x))
+ (unless (member "" x) (mapconcat 'identity x " ")))
+ login-args " ")
+ ;; Local shell could be a Windows COMSPEC. It
+ ;; doesn't know the ";" syntax, but we must exit
+ ;; always for `start-file-process'. "exec" does not
+ ;; work either.
+ (if (memq system-type '(windows-nt)) " && exit || exit")))
+
+ ;; Send the command.
+ (tramp-message vec 3 "Sending command `%s'" command)
+ (tramp-send-command vec command t t)
+ (tramp-process-actions p vec tramp-actions-before-shell 60)
+ (tramp-message
+ vec 3 "Found remote shell prompt on `%s'" l-host))
+ ;; Next hop.
+ (setq target-alist (cdr target-alist)))
+
+ ;; Make initial shell settings.
+ (tramp-open-connection-setup-interactive-shell p vec)))))))
+
+(defun tramp-send-command (vec command &optional neveropen nooutput)
+ "Send the COMMAND to connection VEC.
+Erases temporary buffer before sending the command. If optional
+arg NEVEROPEN is non-nil, never try to open the connection. This
+is meant to be used from `tramp-maybe-open-connection' only. The
+function waits for output unless NOOUTPUT is set."
+ (unless neveropen (tramp-maybe-open-connection vec))
+ (let ((p (tramp-get-connection-process vec)))
+ (when (tramp-get-connection-property p "remote-echo" nil)
+ ;; We mark the command string that it can be erased in the output buffer.
+ (tramp-set-connection-property p "check-remote-echo" t)
+ (setq command (format "%s%s%s" tramp-echo-mark command tramp-echo-mark)))
+ (when (string-match "<<'EOF'" command)
+ ;; Unset $PS1 when using here documents, in order to avoid
+ ;; multiple prompts.
+ (setq command (concat "(PS1= ; " command "\n)")))
+ ;; Send the command.
+ (tramp-message vec 6 "%s" command)
+ (tramp-send-string vec command)
+ (unless nooutput (tramp-wait-for-output p))))
+
+(defun tramp-wait-for-output (proc &optional timeout)
+ "Wait for output from remote command."
+ (unless (buffer-live-p (process-buffer proc))
+ (delete-process proc)
+ (tramp-error proc 'file-error "Process `%s' not available, try again" proc))
+ (with-current-buffer (process-buffer proc)
+ (let* (;; Initially, `tramp-end-of-output' is "#$ ". There might
+ ;; be leading escape sequences, which must be ignored.
+ (regexp (format "[^#$\n]*%s\r?$" (regexp-quote tramp-end-of-output)))
+ ;; Sometimes, the commands do not return a newline but a
+ ;; null byte before the shell prompt, for example "git
+ ;; ls-files -c -z ...".
+ (regexp1 (format "\\(^\\|\000\\)%s" regexp))
+ (found (tramp-wait-for-regexp proc timeout regexp1)))
+ (if found
+ (let (buffer-read-only)
+ ;; A simple-minded busybox has sent " ^H" sequences.
+ ;; Delete them.
+ (goto-char (point-min))
+ (when (re-search-forward "^\\(.\b\\)+$" (point-at-eol) t)
+ (forward-line 1)
+ (delete-region (point-min) (point)))
+ ;; Delete the prompt.
+ (goto-char (point-max))
+ (re-search-backward regexp nil t)
+ (delete-region (point) (point-max)))
+ (if timeout
+ (tramp-error
+ proc 'file-error
+ "[[Remote prompt `%s' not found in %d secs]]"
+ tramp-end-of-output timeout)
+ (tramp-error
+ proc 'file-error
+ "[[Remote prompt `%s' not found]]" tramp-end-of-output)))
+ ;; Return value is whether end-of-output sentinel was found.
+ found)))
+
+(defun tramp-send-command-and-check
+ (vec command &optional subshell dont-suppress-err)
+ "Run COMMAND and check its exit status.
+Sends `echo $?' along with the COMMAND for checking the exit status. If
+COMMAND is nil, just sends `echo $?'. Returns the exit status found.
+
+If the optional argument SUBSHELL is non-nil, the command is
+executed in a subshell, ie surrounded by parentheses. If
+DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to /dev/null."
+ (tramp-send-command
+ vec
+ (concat (if subshell "( " "")
+ command
+ (if command (if dont-suppress-err "; " " 2>/dev/null; ") "")
+ "echo tramp_exit_status $?"
+ (if subshell " )" "")))
+ (with-current-buffer (tramp-get-connection-buffer vec)
+ (goto-char (point-max))
+ (unless (re-search-backward "tramp_exit_status [0-9]+" nil t)
+ (tramp-error
+ vec 'file-error "Couldn't find exit status of `%s'" command))
+ (skip-chars-forward "^ ")
+ (prog1
+ (zerop (read (current-buffer)))
+ (let (buffer-read-only)
+ (delete-region (match-beginning 0) (point-max))))))
+
+(defun tramp-barf-unless-okay (vec command fmt &rest args)
+ "Run COMMAND, check exit status, throw error if exit status not okay.
+Similar to `tramp-send-command-and-check' but accepts two more arguments
+FMT and ARGS which are passed to `error'."
+ (unless (tramp-send-command-and-check vec command)
+ (apply 'tramp-error vec 'file-error fmt args)))
+
+(defun tramp-send-command-and-read (vec command)
+ "Run COMMAND and return the output, which must be a Lisp expression.
+In case there is no valid Lisp expression, it raises an error"
+ (tramp-barf-unless-okay vec command "`%s' returns with error" command)
+ (with-current-buffer (tramp-get-connection-buffer vec)
+ ;; Read the expression.
+ (goto-char (point-min))
+ (condition-case nil
+ (prog1 (read (current-buffer))
+ ;; Error handling.
+ (when (re-search-forward "\\S-" (point-at-eol) t)
+ (error nil)))
+ (error (tramp-error
+ vec 'file-error
+ "`%s' does not return a valid Lisp expression: `%s'"
+ command (buffer-string))))))
+
+(defun tramp-convert-file-attributes (vec attr)
+ "Convert file-attributes ATTR generated by perl script, stat or ls.
+Convert file mode bits to string and set virtual device number.
+Return ATTR."
+ (when attr
+ ;; Convert last access time.
+ (unless (listp (nth 4 attr))
+ (setcar (nthcdr 4 attr)
+ (list (floor (nth 4 attr) 65536)
+ (floor (mod (nth 4 attr) 65536)))))
+ ;; Convert last modification time.
+ (unless (listp (nth 5 attr))
+ (setcar (nthcdr 5 attr)
+ (list (floor (nth 5 attr) 65536)
+ (floor (mod (nth 5 attr) 65536)))))
+ ;; Convert last status change time.
+ (unless (listp (nth 6 attr))
+ (setcar (nthcdr 6 attr)
+ (list (floor (nth 6 attr) 65536)
+ (floor (mod (nth 6 attr) 65536)))))
+ ;; Convert file size.
+ (when (< (nth 7 attr) 0)
+ (setcar (nthcdr 7 attr) -1))
+ (when (and (floatp (nth 7 attr))
+ (<= (nth 7 attr) (tramp-compat-most-positive-fixnum)))
+ (setcar (nthcdr 7 attr) (round (nth 7 attr))))
+ ;; Convert file mode bits to string.
+ (unless (stringp (nth 8 attr))
+ (setcar (nthcdr 8 attr) (tramp-file-mode-from-int (nth 8 attr)))
+ (when (stringp (car attr))
+ (aset (nth 8 attr) 0 ?l)))
+ ;; Convert directory indication bit.
+ (when (string-match "^d" (nth 8 attr))
+ (setcar attr t))
+ ;; Convert symlink from `tramp-do-file-attributes-with-stat'.
+ (when (consp (car attr))
+ (if (and (stringp (caar attr))
+ (string-match ".+ -> .\\(.+\\)." (caar attr)))
+ (setcar attr (match-string 1 (caar attr)))
+ (setcar attr nil)))
+ ;; Set file's gid change bit.
+ (setcar (nthcdr 9 attr)
+ (if (numberp (nth 3 attr))
+ (not (= (nth 3 attr)
+ (tramp-get-remote-gid vec 'integer)))
+ (not (string-equal
+ (nth 3 attr)
+ (tramp-get-remote-gid vec 'string)))))
+ ;; Convert inode.
+ (unless (listp (nth 10 attr))
+ (setcar (nthcdr 10 attr)
+ (condition-case nil
+ (cons (floor (nth 10 attr) 65536)
+ (floor (mod (nth 10 attr) 65536)))
+ ;; Inodes can be incredible huge. We must hide this.
+ (error (tramp-get-inode vec)))))
+ ;; Set virtual device number.
+ (setcar (nthcdr 11 attr)
+ (tramp-get-device vec))
+ attr))
+
+(defun tramp-check-cached-permissions (vec access)
+ "Check `file-attributes' caches for VEC.
+Return t if according to the cache access type ACCESS is known to
+be granted."
+ (let ((result nil)
+ (offset (cond
+ ((eq ?r access) 1)
+ ((eq ?w access) 2)
+ ((eq ?x access) 3))))
+ (dolist (suffix '("string" "integer") result)
+ (setq
+ result
+ (or
+ result
+ (let ((file-attr
+ (tramp-get-file-property
+ vec (tramp-file-name-localname vec)
+ (concat "file-attributes-" suffix) nil))
+ (remote-uid
+ (tramp-get-connection-property
+ vec (concat "uid-" suffix) nil))
+ (remote-gid
+ (tramp-get-connection-property
+ vec (concat "gid-" suffix) nil)))
+ (and
+ file-attr
+ (or
+ ;; Not a symlink
+ (eq t (car file-attr))
+ (null (car file-attr)))
+ (or
+ ;; World accessible.
+ (eq access (aref (nth 8 file-attr) (+ offset 6)))
+ ;; User accessible and owned by user.
+ (and
+ (eq access (aref (nth 8 file-attr) offset))
+ (equal remote-uid (nth 2 file-attr)))
+ ;; Group accessible and owned by user's
+ ;; principal group.
+ (and
+ (eq access (aref (nth 8 file-attr) (+ offset 3)))
+ (equal remote-gid (nth 3 file-attr)))))))))))
+
+(defun tramp-file-mode-from-int (mode)
+ "Turn an integer representing a file mode into an ls(1)-like string."
+ (let ((type (cdr
+ (assoc (logand (lsh mode -12) 15) tramp-file-mode-type-map)))
+ (user (logand (lsh mode -6) 7))
+ (group (logand (lsh mode -3) 7))
+ (other (logand (lsh mode -0) 7))
+ (suid (> (logand (lsh mode -9) 4) 0))
+ (sgid (> (logand (lsh mode -9) 2) 0))
+ (sticky (> (logand (lsh mode -9) 1) 0)))
+ (setq user (tramp-file-mode-permissions user suid "s"))
+ (setq group (tramp-file-mode-permissions group sgid "s"))
+ (setq other (tramp-file-mode-permissions other sticky "t"))
+ (concat type user group other)))
+
+(defun tramp-file-mode-permissions (perm suid suid-text)
+ "Convert a permission bitset into a string.
+This is used internally by `tramp-file-mode-from-int'."
+ (let ((r (> (logand perm 4) 0))
+ (w (> (logand perm 2) 0))
+ (x (> (logand perm 1) 0)))
+ (concat (or (and r "r") "-")
+ (or (and w "w") "-")
+ (or (and suid x suid-text) ; suid, execute
+ (and suid (upcase suid-text)) ; suid, !execute
+ (and x "x") "-")))) ; !suid
+
+(defun tramp-shell-case-fold (string)
+ "Converts STRING to shell glob pattern which ignores case."
+ (mapconcat
+ (lambda (c)
+ (if (equal (downcase c) (upcase c))
+ (vector c)
+ (format "[%c%c]" (downcase c) (upcase c))))
+ string
+ ""))
+
+(defun tramp-make-copy-program-file-name (vec)
+ "Create a file name suitable to be passed to `rcp' and workalikes."
+ (let ((user (tramp-file-name-user vec))
+ (host (tramp-file-name-real-host vec))
+ (localname (tramp-shell-quote-argument
+ (tramp-file-name-localname vec))))
+ (if (not (zerop (length user)))
+ (format "%s@%s:%s" user host localname)
+ (format "%s:%s" host localname))))
+
+(defun tramp-method-out-of-band-p (vec size)
+ "Return t if this is an out-of-band method, nil otherwise."
+ (and
+ ;; It shall be an out-of-band method.
+ (tramp-get-method-parameter (tramp-file-name-method vec) 'tramp-copy-program)
+ ;; Either the file size is large enough, or (in rare cases) there
+ ;; does not exist a remote encoding.
+ (or (null tramp-copy-size-limit)
+ (> size tramp-copy-size-limit)
+ (null (tramp-get-inline-coding vec "remote-encoding" size)))))
+
+;; Variables local to connection.
+
+(defun tramp-get-remote-path (vec)
+ (with-connection-property
+ ;; When `tramp-own-remote-path' is in `tramp-remote-path', we
+ ;; cache the result for the session only. Otherwise, the result
+ ;; is cached persistently.
+ (if (memq 'tramp-own-remote-path tramp-remote-path)
+ (tramp-get-connection-process vec)
+ vec)
+ "remote-path"
+ (let* ((remote-path (copy-tree tramp-remote-path))
+ (elt1 (memq 'tramp-default-remote-path remote-path))
+ (elt2 (memq 'tramp-own-remote-path remote-path))
+ (default-remote-path
+ (when elt1
+ (condition-case nil
+ (tramp-send-command-and-read
+ vec "echo \\\"`getconf PATH`\\\"")
+ ;; Default if "getconf" is not available.
+ (error
+ (tramp-message
+ vec 3
+ "`getconf PATH' not successful, using default value \"%s\"."
+ "/bin:/usr/bin")
+ "/bin:/usr/bin"))))
+ (own-remote-path
+ (when elt2
+ (condition-case nil
+ (tramp-send-command-and-read vec "echo \\\"$PATH\\\"")
+ ;; Default if "getconf" is not available.
+ (error
+ (tramp-message
+ vec 3 "$PATH not set, ignoring `tramp-own-remote-path'.")
+ nil)))))
+
+ ;; Replace place holder `tramp-default-remote-path'.
+ (when elt1
+ (setcdr elt1
+ (append
+ (tramp-compat-split-string default-remote-path ":")
+ (cdr elt1)))
+ (setq remote-path (delq 'tramp-default-remote-path remote-path)))
+
+ ;; Replace place holder `tramp-own-remote-path'.
+ (when elt2
+ (setcdr elt2
+ (append
+ (tramp-compat-split-string own-remote-path ":")
+ (cdr elt2)))
+ (setq remote-path (delq 'tramp-own-remote-path remote-path)))
+
+ ;; Remove double entries.
+ (setq elt1 remote-path)
+ (while (consp elt1)
+ (while (and (car elt1) (setq elt2 (member (car elt1) (cdr elt1))))
+ (setcar elt2 nil))
+ (setq elt1 (cdr elt1)))
+
+ ;; Remove non-existing directories.
+ (delq
+ nil
+ (mapcar
+ (lambda (x)
+ (and
+ (stringp x)
+ (file-directory-p
+ (tramp-make-tramp-file-name
+ (tramp-file-name-method vec)
+ (tramp-file-name-user vec)
+ (tramp-file-name-host vec)
+ x))
+ x))
+ remote-path)))))
+
+(defun tramp-get-remote-tmpdir (vec)
+ (with-connection-property vec "tmp-directory"
+ (let ((dir (tramp-shell-quote-argument "/tmp")))
+ (if (and (tramp-send-command-and-check
+ vec (format "%s -d %s" (tramp-get-test-command vec) dir))
+ (tramp-send-command-and-check
+ vec (format "%s -w %s" (tramp-get-test-command vec) dir)))
+ dir
+ (tramp-error vec 'file-error "Directory %s not accessible" dir)))))
+
+(defun tramp-get-ls-command (vec)
+ (with-connection-property vec "ls"
+ (tramp-message vec 5 "Finding a suitable `ls' command")
+ (or
+ (catch 'ls-found
+ (dolist (cmd '("ls" "gnuls" "gls"))
+ (let ((dl (tramp-get-remote-path vec))
+ result)
+ (while (and dl (setq result (tramp-find-executable vec cmd dl t t)))
+ ;; Check parameters. On busybox, "ls" output coloring is
+ ;; enabled by default sometimes. So we try to disable it
+ ;; when possible. $LS_COLORING is not supported there.
+ ;; Some "ls" versions are sensible wrt the order of
+ ;; arguments, they fail when "-al" is after the
+ ;; "--color=never" argument (for example on FreeBSD).
+ (when (tramp-send-command-and-check
+ vec (format "%s -lnd /" result))
+ (when (tramp-send-command-and-check
+ vec (format
+ "%s --color=never -al /dev/null" result))
+ (setq result (concat result " --color=never")))
+ (throw 'ls-found result))
+ (setq dl (cdr dl))))))
+ (tramp-error vec 'file-error "Couldn't find a proper `ls' command"))))
+
+(defun tramp-get-ls-command-with-dired (vec)
+ (save-match-data
+ (with-connection-property vec "ls-dired"
+ (tramp-message vec 5 "Checking, whether `ls --dired' works")
+ ;; Some "ls" versions are sensible wrt the order of arguments,
+ ;; they fail when "-al" is after the "--dired" argument (for
+ ;; example on FreeBSD).
+ (tramp-send-command-and-check
+ vec (format "%s --dired -al /dev/null" (tramp-get-ls-command vec))))))
+
+(defun tramp-get-test-command (vec)
+ (with-connection-property vec "test"
+ (tramp-message vec 5 "Finding a suitable `test' command")
+ (if (tramp-send-command-and-check vec "test 0")
+ "test"
+ (tramp-find-executable vec "test" (tramp-get-remote-path vec)))))
+
+(defun tramp-get-test-nt-command (vec)
+ ;; Does `test A -nt B' work? Use abominable `find' construct if it
+ ;; doesn't. BSD/OS 4.0 wants the parentheses around the command,
+ ;; for otherwise the shell crashes.
+ (with-connection-property vec "test-nt"
+ (or
+ (progn
+ (tramp-send-command
+ vec (format "( %s / -nt / )" (tramp-get-test-command vec)))
+ (with-current-buffer (tramp-get-buffer vec)
+ (goto-char (point-min))
+ (when (looking-at (regexp-quote tramp-end-of-output))
+ (format "%s %%s -nt %%s" (tramp-get-test-command vec)))))
+ (progn
+ (tramp-send-command
+ vec
+ (format
+ "tramp_test_nt () {\n%s -n \"`find $1 -prune -newer $2 -print`\"\n}"
+ (tramp-get-test-command vec)))
+ "tramp_test_nt %s %s"))))
+
+(defun tramp-get-file-exists-command (vec)
+ (with-connection-property vec "file-exists"
+ (tramp-message vec 5 "Finding command to check if file exists")
+ (tramp-find-file-exists-command vec)))
+
+(defun tramp-get-remote-ln (vec)
+ (with-connection-property vec "ln"
+ (tramp-message vec 5 "Finding a suitable `ln' command")
+ (tramp-find-executable vec "ln" (tramp-get-remote-path vec))))
+
+(defun tramp-get-remote-perl (vec)
+ (with-connection-property vec "perl"
+ (tramp-message vec 5 "Finding a suitable `perl' command")
+ (let ((result
+ (or (tramp-find-executable vec "perl5" (tramp-get-remote-path vec))
+ (tramp-find-executable
+ vec "perl" (tramp-get-remote-path vec)))))
+ ;; We must check also for some Perl modules.
+ (when result
+ (with-connection-property vec "perl-file-spec"
+ (tramp-send-command-and-check
+ vec (format "%s -e 'use File::Spec;'" result)))
+ (with-connection-property vec "perl-cwd-realpath"
+ (tramp-send-command-and-check
+ vec (format "%s -e 'use Cwd \"realpath\";'" result))))
+ result)))
+
+(defun tramp-get-remote-stat (vec)
+ (with-connection-property vec "stat"
+ (tramp-message vec 5 "Finding a suitable `stat' command")
+ (let ((result (tramp-find-executable
+ vec "stat" (tramp-get-remote-path vec)))
+ tmp)
+ ;; Check whether stat(1) returns usable syntax. %s does not
+ ;; work on older AIX systems.
+ (when result
+ (setq tmp
+ ;; We don't want to display an error message.
+ (tramp-compat-with-temp-message (or (current-message) "")
+ (ignore-errors
+ (tramp-send-command-and-read
+ vec (format "%s -c '(\"%%N\" %%s)' /" result)))))
+ (unless (and (listp tmp) (stringp (car tmp))
+ (string-match "^./.$" (car tmp))
+ (integerp (cadr tmp)))
+ (setq result nil)))
+ result)))
+
+(defun tramp-get-remote-readlink (vec)
+ (with-connection-property vec "readlink"
+ (tramp-message vec 5 "Finding a suitable `readlink' command")
+ (let ((result (tramp-find-executable
+ vec "readlink" (tramp-get-remote-path vec))))
+ (when (and result
+ ;; We don't want to display an error message.
+ (tramp-compat-with-temp-message (or (current-message) "")
+ (ignore-errors
+ (tramp-send-command-and-check
+ vec (format "%s --canonicalize-missing /" result)))))
+ result))))
+
+(defun tramp-get-remote-trash (vec)
+ (with-connection-property vec "trash"
+ (tramp-message vec 5 "Finding a suitable `trash' command")
+ (tramp-find-executable vec "trash" (tramp-get-remote-path vec))))
+
+(defun tramp-get-remote-id (vec)
+ (with-connection-property vec "id"
+ (tramp-message vec 5 "Finding POSIX `id' command")
+ (or
+ (catch 'id-found
+ (let ((dl (tramp-get-remote-path vec))
+ result)
+ (while (and dl (setq result (tramp-find-executable vec "id" dl t t)))
+ ;; Check POSIX parameter.
+ (when (tramp-send-command-and-check vec (format "%s -u" result))
+ (throw 'id-found result))
+ (setq dl (cdr dl)))))
+ (tramp-error vec 'file-error "Couldn't find a POSIX `id' command"))))
+
+(defun tramp-get-remote-uid (vec id-format)
+ (with-connection-property vec (format "uid-%s" id-format)
+ (let ((res (tramp-send-command-and-read
+ vec
+ (format "%s -u%s %s"
+ (tramp-get-remote-id vec)
+ (if (equal id-format 'integer) "" "n")
+ (if (equal id-format 'integer)
+ "" "| sed -e s/^/\\\"/ -e s/\$/\\\"/")))))
+ ;; The command might not always return a number.
+ (if (and (equal id-format 'integer) (not (integerp res))) -1 res))))
+
+(defun tramp-get-remote-gid (vec id-format)
+ (with-connection-property vec (format "gid-%s" id-format)
+ (let ((res (tramp-send-command-and-read
+ vec
+ (format "%s -g%s %s"
+ (tramp-get-remote-id vec)
+ (if (equal id-format 'integer) "" "n")
+ (if (equal id-format 'integer)
+ "" "| sed -e s/^/\\\"/ -e s/\$/\\\"/")))))
+ ;; The command might not always return a number.
+ (if (and (equal id-format 'integer) (not (integerp res))) -1 res))))
+
+(defun tramp-get-local-uid (id-format)
+ (if (equal id-format 'integer) (user-uid) (user-login-name)))
+
+(defun tramp-get-local-gid (id-format)
+ (nth 3 (tramp-compat-file-attributes "~/" id-format)))
+
+;; Some predefined connection properties.
+(defun tramp-get-inline-compress (vec prop size)
+ "Return the compress command related to PROP.
+PROP is either `inline-compress' or `inline-decompress'. SIZE is
+the length of the file to be compressed.
+
+If no corresponding command is found, nil is returned."
+ (when (and (integerp tramp-inline-compress-start-size)
+ (> size tramp-inline-compress-start-size))
+ (with-connection-property vec prop
+ (tramp-find-inline-compress vec)
+ (tramp-get-connection-property vec prop nil))))
+
+(defun tramp-get-inline-coding (vec prop size)
+ "Return the coding command related to PROP.
+PROP is either `remote-encoding', `remode-decoding',
+`local-encoding' or `local-decoding'.
+
+SIZE is the length of the file to be coded. Depending on SIZE,
+compression might be applied.
+
+If no corresponding command is found, nil is returned.
+Otherwise, either a string is returned which contains a `%s' mark
+to be used for the respective input or output file; or a Lisp
+function cell is returned to be applied on a buffer."
+ ;; We must catch the errors, because we want to return `nil', when
+ ;; no inline coding is found.
+ (ignore-errors
+ (let ((coding
+ (with-connection-property vec prop
+ (tramp-find-inline-encoding vec)
+ (tramp-get-connection-property vec prop nil)))
+ (prop1 (if (string-match "encoding" prop)
+ "inline-compress" "inline-decompress"))
+ compress)
+ ;; The connection property might have been cached. So we must
+ ;; send the script to the remote side - maybe.
+ (when (and coding (symbolp coding) (string-match "remote" prop))
+ (let ((name (symbol-name coding)))
+ (while (string-match (regexp-quote "-") name)
+ (setq name (replace-match "_" nil t name)))
+ (tramp-maybe-send-script vec (symbol-value coding) name)
+ (setq coding name)))
+ (when coding
+ ;; Check for the `compress' command.
+ (setq compress (tramp-get-inline-compress vec prop1 size))
+ ;; Return the value.
+ (cond
+ ((and compress (symbolp coding))
+ (if (string-match "decompress" prop1)
+ `(lambda (beg end)
+ (,coding beg end)
+ (let ((coding-system-for-write 'binary)
+ (coding-system-for-read 'binary))
+ (apply
+ 'call-process-region (point-min) (point-max)
+ (car (split-string ,compress)) t t nil
+ (cdr (split-string ,compress)))))
+ `(lambda (beg end)
+ (let ((coding-system-for-write 'binary)
+ (coding-system-for-read 'binary))
+ (apply
+ 'call-process-region beg end
+ (car (split-string ,compress)) t t nil
+ (cdr (split-string ,compress))))
+ (,coding (point-min) (point-max)))))
+ ((symbolp coding)
+ coding)
+ ((and compress (string-match "decoding" prop))
+ (format "(%s | %s >%%s)" coding compress))
+ (compress
+ (format "(%s <%%s | %s)" compress coding))
+ ((string-match "decoding" prop)
+ (format "%s >%%s" coding))
+ (t
+ (format "%s <%%s" coding)))))))
+
+;;; Integration of eshell.el:
+
+(eval-when-compile
+ (defvar eshell-path-env))
+
+;; eshell.el keeps the path in `eshell-path-env'. We must change it
+;; when `default-directory' points to another host.
+(defun tramp-eshell-directory-change ()
+ "Set `eshell-path-env' to $PATH of the host related to `default-directory'."
+ (setq eshell-path-env
+ (if (file-remote-p default-directory)
+ (with-parsed-tramp-file-name default-directory nil
+ (mapconcat
+ 'identity
+ (tramp-get-remote-path v)
+ ":"))
+ (getenv "PATH"))))
+
+(eval-after-load "esh-util"
+ '(progn
+ (tramp-eshell-directory-change)
+ (add-hook 'eshell-directory-change-hook
+ 'tramp-eshell-directory-change)
+ (add-hook 'tramp-unload-hook
+ (lambda ()
+ (remove-hook 'eshell-directory-change-hook
+ 'tramp-eshell-directory-change)))))
+
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (unload-feature 'tramp-sh 'force)))
+
+(provide 'tramp-sh)
+
+;;; TODO:
+
+;; * Don't use globbing for directories with many files, as this is
+;; likely to produce long command lines, and some shells choke on
+;; long command lines.
+;; * Make it work for different encodings, and for different file name
+;; encodings, too. (Daniel Pittman)
+;; * Don't search for perl5 and perl. Instead, only search for perl and
+;; then look if it's the right version (with `perl -v').
+;; * 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.
+;; * Allow out-of-band methods as _last_ multi-hop. Open a connection
+;; until the last but one hop via `start-file-process'. Apply it
+;; also for ftp and smb.
+;; * WIBNI if we had a command "trampclient"? If I was editing in
+;; some shell with root priviledges, it would be nice if I could
+;; just call
+;; trampclient filename.c
+;; as an editor, and the _current_ shell would connect to an Emacs
+;; server and would be used in an existing non-priviledged Emacs
+;; session for doing the editing in question.
+;; That way, I need not tell Emacs my password again and be afraid
+;; that it makes it into core dumps or other ugly stuff (I had Emacs
+;; once display a just typed password in the context of a keyboard
+;; sequence prompt for a question immediately following in a shell
+;; script run within Emacs -- nasty).
+;; And if I have some ssh session running to a different computer,
+;; having the possibility of passing a local file there to a local
+;; Emacs session (in case I can arrange for a connection back) would
+;; be nice.
+;; Likely the corresponding Tramp server should not allow the
+;; equivalent of the emacsclient -eval option in order to make this
+;; reasonably unproblematic. And maybe trampclient should have some
+;; way of passing credentials, like by using an SSL socket or
+;; something. (David Kastrup)
+;; * Reconnect directly to a compliant shell without first going
+;; through the user's default shell. (Pete Forman)
+;; * How can I interrupt the remote process with a signal
+;; (interrupt-process seems not to work)? (Markus Triska)
+;; * Avoid the local shell entirely for starting remote processes. If
+;; so, I think even a signal, when delivered directly to the local
+;; SSH instance, would correctly be propagated to the remote process
+;; automatically; possibly SSH would have to be started with
+;; "-t". (Markus Triska)
+;; * It makes me wonder if tramp couldn't fall back to ssh when scp
+;; isn't on the remote host. (Mark A. Hershberger)
+;; * Use lsh instead of ssh. (Alfred M. Szmidt)
+;; * Optimize out-of-band copying, when both methods are scp-like (not
+;; rsync).
+;; * Keep a second connection open for out-of-band methods like scp or
+;; rsync.
+;; * Try telnet+curl as new method. It might be useful for busybox,
+;; without built-in uuencode/uudecode.
+
+;;; tramp-sh.el ends here
diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el
index f1ec7a9b81c..b3c617ba26c 100644
--- a/lisp/net/tramp-smb.el
+++ b/lisp/net/tramp-smb.el
@@ -5,6 +5,7 @@
;; Author: Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, processes
+;; Package: tramp
;; This file is part of GNU Emacs.
@@ -29,17 +30,16 @@
(eval-when-compile (require 'cl)) ; block, return
(require 'tramp)
-(require 'tramp-cache)
-(require 'tramp-compat)
;; Define SMB method ...
-(defcustom tramp-smb-method "smb"
- "*Method to connect SAMBA and M$ SMB servers."
- :group 'tramp
- :type 'string)
+;;;###tramp-autoload
+(defconst tramp-smb-method "smb"
+ "*Method to connect SAMBA and M$ SMB servers.")
;; ... and add it to the method list.
-(add-to-list 'tramp-methods (cons tramp-smb-method nil))
+;;;###tramp-autoload
+(unless (memq system-type '(cygwin windows-nt))
+ (add-to-list 'tramp-methods (cons tramp-smb-method nil)))
;; Add a default for `tramp-default-method-alist'. Rule: If there is
;; a domain in USER, it must be the SMB method.
@@ -153,7 +153,7 @@ See `tramp-actions-before-shell' for more info.")
(directory-file-name . tramp-handle-directory-file-name)
(directory-files . tramp-smb-handle-directory-files)
(directory-files-and-attributes
- . tramp-smb-handle-directory-files-and-attributes)
+ . tramp-handle-directory-files-and-attributes)
(dired-call-process . ignore)
(dired-compress-file . ignore)
(dired-uncache . tramp-handle-dired-uncache)
@@ -161,8 +161,8 @@ See `tramp-actions-before-shell' for more info.")
(file-accessible-directory-p . tramp-smb-handle-file-directory-p)
(file-attributes . tramp-smb-handle-file-attributes)
(file-directory-p . tramp-smb-handle-file-directory-p)
- (file-executable-p . tramp-smb-handle-file-exists-p)
- (file-exists-p . tramp-smb-handle-file-exists-p)
+ (file-executable-p . tramp-handle-file-exists-p)
+ (file-exists-p . tramp-handle-file-exists-p)
(file-local-copy . tramp-smb-handle-file-local-copy)
(file-modes . tramp-handle-file-modes)
(file-name-all-completions . tramp-smb-handle-file-name-all-completions)
@@ -171,9 +171,9 @@ See `tramp-actions-before-shell' for more info.")
(file-name-directory . tramp-handle-file-name-directory)
(file-name-nondirectory . tramp-handle-file-name-nondirectory)
;; `file-name-sans-versions' performed by default handler.
- (file-newer-than-file-p . tramp-smb-handle-file-newer-than-file-p)
+ (file-newer-than-file-p . tramp-handle-file-newer-than-file-p)
(file-ownership-preserved-p . ignore)
- (file-readable-p . tramp-smb-handle-file-exists-p)
+ (file-readable-p . tramp-handle-file-exists-p)
(file-regular-p . tramp-handle-file-regular-p)
(file-remote-p . tramp-handle-file-remote-p)
;; `file-selinux-context' performed by default handler.
@@ -204,11 +204,13 @@ See `tramp-actions-before-shell' for more info.")
"Alist of handler functions for Tramp SMB method.
Operations not mentioned here will be handled by the default Emacs primitives.")
-(defun tramp-smb-file-name-p (filename)
+;;;###tramp-autoload
+(defsubst tramp-smb-file-name-p (filename)
"Check if it's a filename for SMB servers."
(let ((v (tramp-dissect-file-name filename)))
(string= (tramp-file-name-method v) tramp-smb-method)))
+;;;###tramp-autoload
(defun tramp-smb-file-name-handler (operation &rest args)
"Invoke the SMB related OPERATION.
First arg specifies the OPERATION, second arg is a list of arguments to
@@ -218,8 +220,10 @@ pass to the OPERATION."
(save-match-data (apply (cdr fn) args))
(tramp-run-real-handler operation args))))
-(add-to-list 'tramp-foreign-file-name-handler-alist
- (cons 'tramp-smb-file-name-p 'tramp-smb-file-name-handler))
+;;;###tramp-autoload
+(unless (memq system-type '(cygwin windows-nt))
+ (add-to-list 'tramp-foreign-file-name-handler-alist
+ (cons 'tramp-smb-file-name-p 'tramp-smb-file-name-handler)))
;; File name primitives.
@@ -447,15 +451,6 @@ PRESERVE-UID-GID is completely ignored."
;; That's it.
result))
-(defun tramp-smb-handle-directory-files-and-attributes
- (directory &optional full match nosort id-format)
- "Like `directory-files-and-attributes' for Tramp files."
- (mapcar
- (lambda (x)
- (cons x (tramp-compat-file-attributes
- (if full x (expand-file-name x directory)) id-format)))
- (directory-files directory full match nosort)))
-
(defun tramp-smb-handle-expand-file-name (name &optional dir)
"Like `expand-file-name' for Tramp files."
;; If DIR is not given, use DEFAULT-DIRECTORY or "/".
@@ -593,10 +588,6 @@ PRESERVE-UID-GID is completely ignored."
(and (file-exists-p filename)
(eq ?d (aref (nth 8 (file-attributes filename)) 0))))
-(defun tramp-smb-handle-file-exists-p (filename)
- "Like `file-exists-p' for Tramp files."
- (not (null (file-attributes filename))))
-
(defun tramp-smb-handle-file-local-copy (filename)
"Like `file-local-copy' for Tramp files."
(with-parsed-tramp-file-name filename nil
@@ -634,14 +625,6 @@ PRESERVE-UID-GID is completely ignored."
(nth 0 x))))
entries)))))))
-(defun tramp-smb-handle-file-newer-than-file-p (file1 file2)
- "Like `file-newer-than-file-p' for Tramp files."
- (cond
- ((not (file-exists-p file1)) nil)
- ((not (file-exists-p file2)) t)
- (t (tramp-time-less-p (nth 5 (file-attributes file2))
- (nth 5 (file-attributes file1))))))
-
(defun tramp-smb-handle-file-writable-p (filename)
"Like `file-writable-p' for Tramp files."
(if (file-exists-p filename)
@@ -783,7 +766,7 @@ PRESERVE-UID-GID is completely ignored."
(if (tramp-smb-get-cifs-capabilities v)
(format
"posix_mkdir \"%s\" %s"
- file (tramp-decimal-to-octal (default-file-modes)))
+ file (tramp-compat-decimal-to-octal (default-file-modes)))
(format "mkdir \"%s\"" file)))
;; We must also flush the cache of the directory, because
;; `file-attributes' reads the values from there.
@@ -892,7 +875,7 @@ target of the symlink differ."
(unless (tramp-smb-send-command
v (format "chmod \"%s\" %s"
(tramp-smb-get-localname v)
- (tramp-decimal-to-octal mode)))
+ (tramp-compat-decimal-to-octal mode)))
(tramp-error
v 'file-error "Error while changing file's mode %s" filename)))))
@@ -1096,7 +1079,7 @@ If SHARE is result, entries are of type dir. Otherwise, shares are listed.
Result is the list (LOCALNAME MODE SIZE MTIME)."
;; We are called from `tramp-smb-get-file-entries', which sets the
;; current buffer.
- (let ((line (buffer-substring (point) (tramp-compat-line-end-position)))
+ (let ((line (buffer-substring (point) (point-at-eol)))
localname mode size month day hour min sec year mtime)
(if (not share)
@@ -1194,8 +1177,7 @@ Result is the list (LOCALNAME MODE SIZE MTIME)."
(member
"pathnames"
(split-string
- (buffer-substring
- (point) (tramp-compat-line-end-position)) nil t)))))))))
+ (buffer-substring (point) (point-at-eol)) nil t)))))))))
(defun tramp-smb-get-stat-capability (vec)
"Check, whether the SMB server supports the STAT command."
@@ -1319,7 +1301,7 @@ connection if a previous connection has died for some reason."
(tramp-message
vec 6 "%s" (mapconcat 'identity (process-command p) " "))
- (tramp-set-process-query-on-exit-flag p nil)
+ (tramp-compat-set-process-query-on-exit-flag p nil)
;; Set variables for computing the prompt for reading password.
(setq tramp-current-method tramp-smb-method
@@ -1396,6 +1378,9 @@ Returns nil if an error message has appeared."
(tramp-message vec 6 "\n%s" (buffer-string))
(not err))))
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (unload-feature 'tramp-smb 'force)))
(provide 'tramp-smb)
@@ -1410,5 +1395,4 @@ Returns nil if an error message has appeared."
;; regular again.
;; * Make it multi-hop capable.
-;; arch-tag: fcc9dbec-7503-4d73-b638-3c8aa59575f5
;;; tramp-smb.el ends here
diff --git a/lisp/net/tramp-uu.el b/lisp/net/tramp-uu.el
index 897a87b0134..fe6862c9240 100644
--- a/lisp/net/tramp-uu.el
+++ b/lisp/net/tramp-uu.el
@@ -5,6 +5,7 @@
;; Author: Kai Großjohann <kai.grossjohann@gmx.net>
;; Keywords: comm, terminals
+;; Package: tramp
;; This file is part of GNU Emacs.
@@ -49,6 +50,7 @@
"Return the byte that is encoded as CHAR."
(cdr (assq char tramp-uu-b64-char-to-byte)))
+;;;###tramp-autoload
(defun tramp-uuencode-region (beg end)
"UU-encode the region between BEG and END."
;; First we base64 encode the region, then we transmogrify that into
@@ -86,6 +88,10 @@
(goto-char beg)
(insert "begin 600 xxx\n"))))
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (unload-feature 'tramp-uu 'force)))
+
(provide 'tramp-uu)
;; arch-tag: 7153f2c6-8be5-4cd2-8c06-0fbcf5190ef6
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index a9733fc6a0f..789677ce643 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -3,11 +3,10 @@
;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-;; (copyright statements below in code to be updated with the above notice)
-
;; Author: Kai Großjohann <kai.grossjohann@gmx.net>
;; Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, processes
+;; Package: tramp
;; This file is part of GNU Emacs.
@@ -59,117 +58,7 @@
;;; Code:
-;; Since Emacs 23.1, loading messages have been disabled during
-;; autoload. However, loading Tramp takes a while, and it could
-;; happen while typing a filename in the minibuffer. Therefore, Tramp
-;; shall inform about.
-(when (and load-in-progress (null (current-message)))
- (message "Loading tramp..."))
-
-;; The Tramp version number and bug report address, as prepared by configure.
-(require 'trampver)
-(add-hook 'tramp-unload-hook
- (lambda ()
- (when (featurep 'trampver)
- (unload-feature 'trampver 'force))))
-
(require 'tramp-compat)
-(add-hook 'tramp-unload-hook
- (lambda ()
- (when (featurep 'tramp-compat)
- (unload-feature 'tramp-compat 'force))))
-
-(require 'format-spec)
-;; As long as password.el is not part of (X)Emacs, it shouldn't
-;; be mandatory
-(if (featurep 'xemacs)
- (load "password" 'noerror)
- (or (require 'password-cache nil 'noerror)
- (require 'password nil 'noerror))) ; from No Gnus, also in tar ball
-
-(require 'shell)
-(require 'advice)
-
-(eval-and-compile
- (if (featurep 'xemacs)
- (load "auth-source" 'noerror)
- (require 'auth-source nil 'noerror)))
-
-;; Requiring 'tramp-cache results in an endless loop.
-(autoload 'tramp-get-file-property "tramp-cache")
-(autoload 'tramp-set-file-property "tramp-cache")
-(autoload 'tramp-flush-file-property "tramp-cache")
-(autoload 'tramp-flush-directory-property "tramp-cache")
-(autoload 'tramp-get-connection-property "tramp-cache")
-(autoload 'tramp-set-connection-property "tramp-cache")
-(autoload 'tramp-flush-connection-property "tramp-cache")
-(autoload 'tramp-parse-connection-properties "tramp-cache")
-(add-hook 'tramp-unload-hook
- (lambda ()
- (when (featurep 'tramp-cache)
- (unload-feature 'tramp-cache 'force))))
-
-(autoload 'tramp-uuencode-region "tramp-uu"
- "Implementation of `uuencode' in Lisp.")
-(add-hook 'tramp-unload-hook
- (lambda ()
- (when (featurep 'tramp-uu)
- (unload-feature 'tramp-uu 'force))))
-
-(autoload 'uudecode-decode-region "uudecode")
-
-;; The following Tramp packages must be loaded after tramp.el, because
-;; they require it as well.
-(eval-after-load "tramp"
- '(dolist
- (feature
- (list
-
- ;; Tramp interactive commands.
- 'tramp-cmds
-
- ;; Load foreign FTP method.
- (if (featurep 'xemacs) 'tramp-efs 'tramp-ftp)
-
- ;; tramp-smb uses "smbclient" from Samba. Not available
- ;; under Cygwin and Windows, because they don't offer
- ;; "smbclient". And even not necessary there, because Emacs
- ;; supports UNC file names like "//host/share/localname".
- (unless (memq system-type '(cygwin windows-nt)) 'tramp-smb)
-
- ;; Load foreign FISH method.
- 'tramp-fish
-
- ;; tramp-gvfs needs D-Bus messages. Available since Emacs 23
- ;; on some system types. We don't call `dbus-ping', because
- ;; this would load dbus.el.
- (when (and (featurep 'dbusbind)
- (condition-case nil
- (tramp-compat-funcall 'dbus-get-unique-name :session)
- (error nil))
- (tramp-compat-process-running-p "gvfs-fuse-daemon"))
- 'tramp-gvfs)
-
- ;; Load gateways. It needs `make-network-process' from Emacs 22.
- (when (functionp 'make-network-process) 'tramp-gw)
-
- ;; tramp-imap needs both epa (from Emacs 23.1) and imap-hash
- ;; (from Emacs 23.2).
- (when (and (locate-library "epa") (locate-library "imap-hash"))
- 'tramp-imap)))
-
- (when feature
- ;; We have used just some basic tests, whether a package shall
- ;; be added. There might still be other errors during loading,
- ;; which we will catch here.
- (catch 'tramp-loading
- (require feature)
- (add-hook 'tramp-unload-hook
- `(lambda ()
- (when (featurep (quote ,feature))
- (unload-feature (quote ,feature) 'force)))))
- (unless (featurep feature)
- (message "Loading %s failed, ignoring this package" feature)))))
;;; User Customizable Internal Variables:
@@ -286,379 +175,8 @@ See the variable `tramp-encoding-shell' for more information."
:group 'tramp
:type 'string)
-(defcustom tramp-inline-compress-start-size 4096
- "*The minimum size of compressing where inline transfer.
-When inline transfer, compress transfered data of file
-whose size is this value or above (up to `tramp-copy-size-limit').
-If it is nil, no compression at all will be applied."
- :group 'tramp
- :type '(choice (const nil) integer))
-
-(defcustom tramp-copy-size-limit 10240
- "*The maximum file size where inline copying is preferred over an out-of-the-band copy.
-If it is nil, inline out-of-the-band copy will be used without a check."
- :group 'tramp
- :type '(choice (const nil) integer))
-
-(defcustom tramp-terminal-type "dumb"
- "*Value of TERM environment variable for logging in to remote host.
-Because Tramp wants to parse the output of the remote shell, it is easily
-confused by ANSI color escape sequences and suchlike. Often, shell init
-files conditionalize this setup based on the TERM environment variable."
- :group 'tramp
- :type 'string)
-
-;; ksh on OpenBSD 4.5 requires, that PS1 contains a `#' character for
-;; root users. It uses the `$' character for other users. In order
-;; to guarantee a proper prompt, we use "#$" for the prompt.
-
-(defvar tramp-end-of-output
- (format
- "///%s#$"
- (md5 (concat (prin1-to-string process-environment) (current-time-string))))
- "String used to recognize end of output.
-The '$' character at the end is quoted; the string cannot be
-detected as prompt when being sent on echoing hosts, therefore.")
-
-(defconst tramp-initial-end-of-output "#$ "
- "Prompt when establishing a connection.")
-
-(defvar tramp-methods
- `(("rcp" (tramp-login-program "rsh")
- (tramp-login-args (("%h") ("-l" "%u")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program "rcp")
- (tramp-copy-args (("-p" "%k") ("-r")))
- (tramp-copy-keep-date t)
- (tramp-copy-recursive t)
- (tramp-password-end-of-line nil))
- ("scp" (tramp-login-program "ssh")
- (tramp-login-args (("-l" "%u") ("-p" "%p")
- ("-e" "none") ("%h")))
- (tramp-async-args (("-q")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program "scp")
- (tramp-copy-args (("-P" "%p") ("-p" "%k")
- ("-q") ("-r")))
- (tramp-copy-keep-date t)
- (tramp-copy-recursive t)
- (tramp-password-end-of-line nil)
- (tramp-gw-args (("-o"
- "GlobalKnownHostsFile=/dev/null")
- ("-o" "UserKnownHostsFile=/dev/null")
- ("-o" "StrictHostKeyChecking=no")))
- (tramp-default-port 22))
- ("scp1" (tramp-login-program "ssh")
- (tramp-login-args (("-l" "%u") ("-p" "%p")
- ("-1") ("-e" "none") ("%h")))
- (tramp-async-args (("-q")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program "scp")
- (tramp-copy-args (("-1") ("-P" "%p") ("-p" "%k")
- ("-q") ("-r")))
- (tramp-copy-keep-date t)
- (tramp-copy-recursive t)
- (tramp-password-end-of-line nil)
- (tramp-gw-args (("-o"
- "GlobalKnownHostsFile=/dev/null")
- ("-o" "UserKnownHostsFile=/dev/null")
- ("-o" "StrictHostKeyChecking=no")))
- (tramp-default-port 22))
- ("scp2" (tramp-login-program "ssh")
- (tramp-login-args (("-l" "%u") ("-p" "%p")
- ("-2") ("-e" "none") ("%h")))
- (tramp-async-args (("-q")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program "scp")
- (tramp-copy-args (("-2") ("-P" "%p") ("-p" "%k")
- ("-q") ("-r")))
- (tramp-copy-keep-date t)
- (tramp-copy-recursive t)
- (tramp-password-end-of-line nil)
- (tramp-gw-args (("-o"
- "GlobalKnownHostsFile=/dev/null")
- ("-o" "UserKnownHostsFile=/dev/null")
- ("-o" "StrictHostKeyChecking=no")))
- (tramp-default-port 22))
- ("scp1_old"
- (tramp-login-program "ssh1")
- (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p")
- ("-e" "none")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program "scp1")
- (tramp-copy-args (("-p" "%k") ("-r")))
- (tramp-copy-keep-date t)
- (tramp-copy-recursive t)
- (tramp-password-end-of-line nil))
- ("scp2_old"
- (tramp-login-program "ssh2")
- (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p")
- ("-e" "none")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program "scp2")
- (tramp-copy-args (("-p" "%k") ("-r")))
- (tramp-copy-keep-date t)
- (tramp-copy-recursive t)
- (tramp-password-end-of-line nil))
- ("sftp" (tramp-login-program "ssh")
- (tramp-login-args (("-l" "%u") ("-p" "%p")
- ("-e" "none") ("%h")))
- (tramp-async-args (("-q")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program "sftp")
- (tramp-copy-args nil)
- (tramp-copy-keep-date nil)
- (tramp-password-end-of-line nil))
- ("rsync" (tramp-login-program "ssh")
- (tramp-login-args (("-l" "%u") ("-p" "%p")
- ("-e" "none") ("%h")))
- (tramp-async-args (("-q")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program "rsync")
- (tramp-copy-args (("-e" "ssh") ("-t" "%k") ("-r")))
- (tramp-copy-keep-date t)
- (tramp-copy-keep-tmpfile t)
- (tramp-copy-recursive t)
- (tramp-password-end-of-line nil))
- ("rsyncc"
- (tramp-login-program "ssh")
- (tramp-login-args (("-l" "%u") ("-p" "%p")
- ("-o" "ControlPath=%t.%%r@%%h:%%p")
- ("-o" "ControlMaster=yes")
- ("-e" "none") ("%h")))
- (tramp-async-args (("-q")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program "rsync")
- (tramp-copy-args (("-t" "%k") ("-r")))
- (tramp-copy-env (("RSYNC_RSH")
- (,(concat
- "ssh"
- " -o ControlPath=%t.%%r@%%h:%%p"
- " -o ControlMaster=auto"))))
- (tramp-copy-keep-date t)
- (tramp-copy-keep-tmpfile t)
- (tramp-copy-recursive t)
- (tramp-password-end-of-line nil))
- ("remcp" (tramp-login-program "remsh")
- (tramp-login-args (("%h") ("-l" "%u")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program "rcp")
- (tramp-copy-args (("-p" "%k")))
- (tramp-copy-keep-date t)
- (tramp-password-end-of-line nil))
- ("rsh" (tramp-login-program "rsh")
- (tramp-login-args (("%h") ("-l" "%u")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program nil)
- (tramp-copy-args nil)
- (tramp-copy-keep-date nil)
- (tramp-password-end-of-line nil))
- ("ssh" (tramp-login-program "ssh")
- (tramp-login-args (("-l" "%u") ("-p" "%p")
- ("-e" "none") ("%h")))
- (tramp-async-args (("-q")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program nil)
- (tramp-copy-args nil)
- (tramp-copy-keep-date nil)
- (tramp-password-end-of-line nil)
- (tramp-gw-args (("-o"
- "GlobalKnownHostsFile=/dev/null")
- ("-o" "UserKnownHostsFile=/dev/null")
- ("-o" "StrictHostKeyChecking=no")))
- (tramp-default-port 22))
- ("ssh1" (tramp-login-program "ssh")
- (tramp-login-args (("-l" "%u") ("-p" "%p")
- ("-1") ("-e" "none") ("%h")))
- (tramp-async-args (("-q")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program nil)
- (tramp-copy-args nil)
- (tramp-copy-keep-date nil)
- (tramp-password-end-of-line nil)
- (tramp-gw-args (("-o"
- "GlobalKnownHostsFile=/dev/null")
- ("-o" "UserKnownHostsFile=/dev/null")
- ("-o" "StrictHostKeyChecking=no")))
- (tramp-default-port 22))
- ("ssh2" (tramp-login-program "ssh")
- (tramp-login-args (("-l" "%u") ("-p" "%p")
- ("-2") ("-e" "none") ("%h")))
- (tramp-async-args (("-q")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program nil)
- (tramp-copy-args nil)
- (tramp-copy-keep-date nil)
- (tramp-password-end-of-line nil)
- (tramp-gw-args (("-o"
- "GlobalKnownHostsFile=/dev/null")
- ("-o" "UserKnownHostsFile=/dev/null")
- ("-o" "StrictHostKeyChecking=no")))
- (tramp-default-port 22))
- ("ssh1_old"
- (tramp-login-program "ssh1")
- (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p")
- ("-e" "none")))
- (tramp-async-args (("-q")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program nil)
- (tramp-copy-args nil)
- (tramp-copy-keep-date nil)
- (tramp-password-end-of-line nil))
- ("ssh2_old"
- (tramp-login-program "ssh2")
- (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p")
- ("-e" "none")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program nil)
- (tramp-copy-args nil)
- (tramp-copy-keep-date nil)
- (tramp-password-end-of-line nil))
- ("remsh" (tramp-login-program "remsh")
- (tramp-login-args (("%h") ("-l" "%u")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program nil)
- (tramp-copy-args nil)
- (tramp-copy-keep-date nil)
- (tramp-password-end-of-line nil))
- ("telnet"
- (tramp-login-program "telnet")
- (tramp-login-args (("%h") ("%p")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program nil)
- (tramp-copy-args nil)
- (tramp-copy-keep-date nil)
- (tramp-password-end-of-line nil)
- (tramp-default-port 23))
- ("su" (tramp-login-program "su")
- (tramp-login-args (("-") ("%u")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program nil)
- (tramp-copy-args nil)
- (tramp-copy-keep-date nil)
- (tramp-password-end-of-line nil))
- ("sudo" (tramp-login-program "sudo")
- (tramp-login-args (("-u" "%u")
- ("-s") ("-H") ("-p" "Password:")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program nil)
- (tramp-copy-args nil)
- (tramp-copy-keep-date nil)
- (tramp-password-end-of-line nil))
- ("scpc" (tramp-login-program "ssh")
- (tramp-login-args (("-l" "%u") ("-p" "%p")
- ("-o" "ControlPath=%t.%%r@%%h:%%p")
- ("-o" "ControlMaster=yes")
- ("-e" "none") ("%h")))
- (tramp-async-args (("-q")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program "scp")
- (tramp-copy-args (("-P" "%p") ("-p" "%k") ("-q")
- ("-o" "ControlPath=%t.%%r@%%h:%%p")
- ("-o" "ControlMaster=auto")))
- (tramp-copy-keep-date t)
- (tramp-password-end-of-line nil)
- (tramp-gw-args (("-o"
- "GlobalKnownHostsFile=/dev/null")
- ("-o" "UserKnownHostsFile=/dev/null")
- ("-o" "StrictHostKeyChecking=no")))
- (tramp-default-port 22))
- ("scpx" (tramp-login-program "ssh")
- (tramp-login-args (("-l" "%u") ("-p" "%p")
- ("-e" "none") ("-t" "-t")
- ("%h") ("/bin/sh")))
- (tramp-async-args (("-q")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program "scp")
- (tramp-copy-args (("-p" "%k")))
- (tramp-copy-keep-date t)
- (tramp-password-end-of-line nil)
- (tramp-gw-args (("-o"
- "GlobalKnownHostsFile=/dev/null")
- ("-o" "UserKnownHostsFile=/dev/null")
- ("-o" "StrictHostKeyChecking=no")))
- (tramp-default-port 22))
- ("sshx" (tramp-login-program "ssh")
- (tramp-login-args (("-l" "%u") ("-p" "%p")
- ("-e" "none") ("-t" "-t")
- ("%h") ("/bin/sh")))
- (tramp-async-args (("-q")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program nil)
- (tramp-copy-args nil)
- (tramp-copy-keep-date nil)
- (tramp-password-end-of-line nil)
- (tramp-gw-args (("-o"
- "GlobalKnownHostsFile=/dev/null")
- ("-o" "UserKnownHostsFile=/dev/null")
- ("-o" "StrictHostKeyChecking=no")))
- (tramp-default-port 22))
- ("krlogin"
- (tramp-login-program "krlogin")
- (tramp-login-args (("%h") ("-l" "%u") ("-x")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program nil)
- (tramp-copy-args nil)
- (tramp-copy-keep-date nil)
- (tramp-password-end-of-line nil))
- ("plink" (tramp-login-program "plink")
- (tramp-login-args (("-l" "%u") ("-P" "%p")
- ("-ssh") ("%h")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program nil)
- (tramp-copy-args nil)
- (tramp-copy-keep-date nil)
- (tramp-password-end-of-line "xy") ;see docstring for "xy"
- (tramp-default-port 22))
- ("plink1"
- (tramp-login-program "plink")
- (tramp-login-args (("-l" "%u") ("-P" "%p")
- ("-1" "-ssh") ("%h")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program nil)
- (tramp-copy-args nil)
- (tramp-copy-keep-date nil)
- (tramp-password-end-of-line "xy") ;see docstring for "xy"
- (tramp-default-port 22))
- ("plinkx"
- (tramp-login-program "plink")
- ;; ("%h") must be a single element, see
- ;; `tramp-compute-multi-hops'.
- (tramp-login-args (("-load") ("%h") ("-t")
- (,(format
- "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'"
- tramp-terminal-type
- tramp-initial-end-of-output))
- ("/bin/sh")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program nil)
- (tramp-copy-args nil)
- (tramp-copy-keep-date nil)
- (tramp-password-end-of-line nil))
- ("pscp" (tramp-login-program "plink")
- (tramp-login-args (("-l" "%u") ("-P" "%p")
- ("-ssh") ("%h")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program "pscp")
- (tramp-copy-args (("-P" "%p") ("-scp") ("-p" "%k")))
- (tramp-copy-keep-date t)
- (tramp-password-end-of-line "xy") ;see docstring for "xy"
- (tramp-default-port 22))
- ("psftp" (tramp-login-program "plink")
- (tramp-login-args (("-l" "%u") ("-P" "%p")
- ("-ssh") ("%h")))
- (tramp-remote-sh "/bin/sh")
- (tramp-copy-program "pscp")
- (tramp-copy-args (("-P" "%p") ("-sftp") ("-p" "%k")))
- (tramp-copy-keep-date t)
- (tramp-password-end-of-line "xy")) ;see docstring for "xy"
- ("fcp" (tramp-login-program "fsh")
- (tramp-login-args (("%h") ("-l" "%u") ("sh" "-i")))
- (tramp-remote-sh "/bin/sh -i")
- (tramp-copy-program "fcp")
- (tramp-copy-args (("-p" "%k")))
- (tramp-copy-keep-date t)
- (tramp-password-end-of-line nil)))
+;;;###tramp-autoload
+(defvar tramp-methods nil
"*Alist of methods for remote files.
This is a list of entries of the form (NAME PARAM1 PARAM2 ...).
Each NAME stands for a remote access method. Each PARAM is a
@@ -800,8 +318,7 @@ Also see `tramp-default-method-alist'."
:group 'tramp
:type 'string)
-(defcustom tramp-default-method-alist
- '(("\\`localhost\\'" "\\`root\\'" "su"))
+(defcustom tramp-default-method-alist nil
"*Default method to use for specific host/user pairs.
This is an alist of items (HOST USER METHOD). The first matching item
specifies the method to use for a file name which does not specify a
@@ -818,8 +335,7 @@ See `tramp-methods' for a list of possibilities for METHOD."
(choice :tag "User regexp" regexp sexp)
(choice :tag "Method name" string (const nil)))))
-(defcustom tramp-default-user
- nil
+(defcustom tramp-default-user nil
"*Default user to use for transferring files.
It is nil by default; otherwise settings in configuration files like
\"~/.ssh/config\" would be overwritten. Also see `tramp-default-user-alist'.
@@ -828,10 +344,7 @@ This variable is regarded as obsolete, and will be removed soon."
:group 'tramp
:type '(choice (const nil) string))
-(defcustom tramp-default-user-alist
- `(("\\`su\\(do\\)?\\'" nil "root")
- ("\\`r\\(em\\)?\\(cp\\|sh\\)\\|telnet\\|plink1?\\'"
- nil ,(user-login-name)))
+(defcustom tramp-default-user-alist nil
"*Default user to use for specific method/host pairs.
This is an alist of items (METHOD HOST USER). The first matching item
specifies the user to use for a file name which does not specify a
@@ -846,8 +359,7 @@ empty string for the method name."
(choice :tag " Host regexp" regexp sexp)
(choice :tag " User name" string (const nil)))))
-(defcustom tramp-default-host
- (system-name)
+(defcustom tramp-default-host (system-name)
"*Default host to use for transferring files.
Useful for su and sudo methods mostly."
:group 'tramp
@@ -877,39 +389,6 @@ interpreted as a regular expression which always matches."
"^" (regexp-opt (list "localhost" (system-name) "127\.0\.0\.1" "::1") t) "$")
"*Host names which are regarded as local host.")
-(defconst tramp-completion-function-alist-rsh
- '((tramp-parse-rhosts "/etc/hosts.equiv")
- (tramp-parse-rhosts "~/.rhosts"))
- "Default list of (FUNCTION FILE) pairs to be examined for rsh methods.")
-
-(defconst tramp-completion-function-alist-ssh
- '((tramp-parse-rhosts "/etc/hosts.equiv")
- (tramp-parse-rhosts "/etc/shosts.equiv")
- (tramp-parse-shosts "/etc/ssh_known_hosts")
- (tramp-parse-sconfig "/etc/ssh_config")
- (tramp-parse-shostkeys "/etc/ssh2/hostkeys")
- (tramp-parse-sknownhosts "/etc/ssh2/knownhosts")
- (tramp-parse-rhosts "~/.rhosts")
- (tramp-parse-rhosts "~/.shosts")
- (tramp-parse-shosts "~/.ssh/known_hosts")
- (tramp-parse-sconfig "~/.ssh/config")
- (tramp-parse-shostkeys "~/.ssh2/hostkeys")
- (tramp-parse-sknownhosts "~/.ssh2/knownhosts"))
- "Default list of (FUNCTION FILE) pairs to be examined for ssh methods.")
-
-(defconst tramp-completion-function-alist-telnet
- '((tramp-parse-hosts "/etc/hosts"))
- "Default list of (FUNCTION FILE) pairs to be examined for telnet methods.")
-
-(defconst tramp-completion-function-alist-su
- '((tramp-parse-passwd "/etc/passwd"))
- "Default list of (FUNCTION FILE) pairs to be examined for su methods.")
-
-(defconst tramp-completion-function-alist-putty
- '((tramp-parse-putty
- "HKEY_CURRENT_USER\\Software\\SimonTatham\\PuTTY\\Sessions"))
- "Default list of (FUNCTION REGISTRY) pairs to be examined for putty methods.")
-
(defvar tramp-completion-function-alist nil
"*Alist of methods for remote files.
This is a list of entries of the form \(NAME PAIR1 PAIR2 ...\).
@@ -930,63 +409,6 @@ names from FILE for completion. The following predefined FUNCTIONs exists:
FUNCTION can also be a customer defined function. For more details see
the info pages.")
-(eval-after-load "tramp"
- '(progn
- (tramp-set-completion-function
- "rcp" tramp-completion-function-alist-rsh)
- (tramp-set-completion-function
- "scp" tramp-completion-function-alist-ssh)
- (tramp-set-completion-function
- "scp1" tramp-completion-function-alist-ssh)
- (tramp-set-completion-function
- "scp2" tramp-completion-function-alist-ssh)
- (tramp-set-completion-function
- "scp1_old" tramp-completion-function-alist-ssh)
- (tramp-set-completion-function
- "scp2_old" tramp-completion-function-alist-ssh)
- (tramp-set-completion-function
- "rsync" tramp-completion-function-alist-ssh)
- (tramp-set-completion-function
- "rsyncc" tramp-completion-function-alist-ssh)
- (tramp-set-completion-function
- "remcp" tramp-completion-function-alist-rsh)
- (tramp-set-completion-function
- "rsh" tramp-completion-function-alist-rsh)
- (tramp-set-completion-function
- "ssh" tramp-completion-function-alist-ssh)
- (tramp-set-completion-function
- "ssh1" tramp-completion-function-alist-ssh)
- (tramp-set-completion-function
- "ssh2" tramp-completion-function-alist-ssh)
- (tramp-set-completion-function
- "ssh1_old" tramp-completion-function-alist-ssh)
- (tramp-set-completion-function
- "ssh2_old" tramp-completion-function-alist-ssh)
- (tramp-set-completion-function
- "remsh" tramp-completion-function-alist-rsh)
- (tramp-set-completion-function
- "telnet" tramp-completion-function-alist-telnet)
- (tramp-set-completion-function
- "su" tramp-completion-function-alist-su)
- (tramp-set-completion-function
- "sudo" tramp-completion-function-alist-su)
- (tramp-set-completion-function
- "scpx" tramp-completion-function-alist-ssh)
- (tramp-set-completion-function
- "sshx" tramp-completion-function-alist-ssh)
- (tramp-set-completion-function
- "krlogin" tramp-completion-function-alist-rsh)
- (tramp-set-completion-function
- "plink" tramp-completion-function-alist-ssh)
- (tramp-set-completion-function
- "plink1" tramp-completion-function-alist-ssh)
- (tramp-set-completion-function
- "plinkx" tramp-completion-function-alist-putty)
- (tramp-set-completion-function
- "pscp" tramp-completion-function-alist-ssh)
- (tramp-set-completion-function
- "fcp" tramp-completion-function-alist-ssh)))
-
(defconst tramp-echo-mark-marker "_echo"
"String marker to surround echoed commands.")
@@ -1035,55 +457,6 @@ The default value is to use the same value as `tramp-rsh-end-of-line'."
:group 'tramp
:type 'string)
-;; "getconf PATH" yields:
-;; HP-UX: /usr/bin:/usr/ccs/bin:/opt/ansic/bin:/opt/langtools/bin:/opt/fortran/bin
-;; Solaris: /usr/xpg4/bin:/usr/ccs/bin:/usr/bin:/opt/SUNWspro/bin
-;; GNU/Linux (Debian, Suse): /bin:/usr/bin
-;; FreeBSD: /usr/bin:/bin:/usr/sbin:/sbin: - beware trailing ":"!
-;; IRIX64: /usr/bin
-(defcustom tramp-remote-path
- '(tramp-default-remote-path "/usr/sbin" "/usr/local/bin"
- "/local/bin" "/local/freeware/bin" "/local/gnu/bin"
- "/usr/freeware/bin" "/usr/pkg/bin" "/usr/contrib/bin")
- "*List of directories to search for executables on remote host.
-For every remote host, this variable will be set buffer local,
-keeping the list of existing directories on that host.
-
-You can use `~' in this list, but when searching for a shell which groks
-tilde expansion, all directory names starting with `~' will be ignored.
-
-`Default Directories' represent the list of directories given by
-the command \"getconf PATH\". It is recommended to use this
-entry on top of this list, because these are the default
-directories for POSIX compatible commands.
-
-`Private Directories' are the settings of the $PATH environment,
-as given in your `~/.profile'."
- :group 'tramp
- :type '(repeat (choice
- (const :tag "Default Directories" tramp-default-remote-path)
- (const :tag "Private Directories" tramp-own-remote-path)
- (string :tag "Directory"))))
-
-(defcustom tramp-remote-process-environment
- `("HISTFILE=$HOME/.tramp_history" "HISTSIZE=1" "LC_ALL=C"
- ,(format "TERM=%s" tramp-terminal-type)
- "EMACS=t" ;; Deprecated.
- ,(format "INSIDE_EMACS='%s,tramp:%s'" emacs-version tramp-version)
- "CDPATH=" "HISTORY=" "MAIL=" "MAILCHECK=" "MAILPATH="
- "autocorrect=" "correct=")
-
- "*List of environment variables to be set on the remote host.
-
-Each element should be a string of the form ENVVARNAME=VALUE. An
-entry ENVVARNAME= diables the corresponding environment variable,
-which might have been set in the init files like ~/.profile.
-
-Special handling is applied to the PATH environment, which should
-not be set here. Instead of, it should be set via `tramp-remote-path'."
- :group 'tramp
- :type '(repeat string))
-
(defcustom tramp-login-prompt-regexp
".*ogin\\( .*\\)?: *"
"*Regexp matching login-like prompts.
@@ -1211,15 +584,13 @@ The answer will be provided by `tramp-action-process-alive',
:group 'tramp
:type 'regexp)
-(defcustom tramp-temp-name-prefix "tramp."
+(defconst tramp-temp-name-prefix "tramp."
"*Prefix to use for temporary files.
If this is a relative file name (such as \"tramp.\"), it is considered
relative to the directory name returned by the function
`tramp-compat-temporary-file-directory' (which see). It may also be an
absolute file name; don't forget to include a prefix for the filename
-part, though."
- :group 'tramp
- :type 'string)
+part, though.")
(defconst tramp-temp-buffer-name " *tramp temp*"
"Buffer name for a temporary buffer.
@@ -1230,22 +601,6 @@ It shall be used in combination with `generate-new-buffer-name'.")
Useful for \"rsync\" like methods.")
(make-variable-buffer-local 'tramp-temp-buffer-file-name)
-(defcustom tramp-sh-extra-args '(("/bash\\'" . "-norc -noprofile"))
- "*Alist specifying extra arguments to pass to the remote shell.
-Entries are (REGEXP . ARGS) where REGEXP is a regular expression
-matching the shell file name and ARGS is a string specifying the
-arguments.
-
-This variable is only used when Tramp needs to start up another shell
-for tilde expansion. The extra arguments should typically prevent the
-shell from reading its init file."
- :group 'tramp
- ;; This might be the wrong way to test whether the widget type
- ;; `alist' is available. Who knows the right way to test it?
- :type (if (get 'alist 'widget-type)
- '(alist :key-type string :value-type string)
- '(repeat (cons string string))))
-
;; XEmacs is distributed with few Lisp packages. Further packages are
;; installed using EFS. If we use a unified filename format, then
;; Tramp is required in addition to EFS. (But why can't Tramp just
@@ -1304,8 +659,7 @@ Used in `tramp-make-tramp-file-name'.")
"*Regexp matching delimeter between method and user or host names.
Derived from `tramp-postfix-method-format'.")
-(defconst tramp-user-regexp
- "[^:/ \t]+"
+(defconst tramp-user-regexp "[^:/ \t]+"
"*Regexp matching user names.")
(defconst tramp-prefix-domain-format "%"
@@ -1316,8 +670,7 @@ Derived from `tramp-postfix-method-format'.")
"*Regexp matching delimeter between user and domain names.
Derived from `tramp-prefix-domain-format'.")
-(defconst tramp-domain-regexp
- "[-a-zA-Z0-9_.]+"
+(defconst tramp-domain-regexp "[-a-zA-Z0-9_.]+"
"*Regexp matching domain names.")
(defconst tramp-user-with-domain-regexp
@@ -1326,8 +679,7 @@ Derived from `tramp-prefix-domain-format'.")
"\\(" tramp-domain-regexp "\\)")
"*Regexp matching user names with domain names.")
-(defconst tramp-postfix-user-format
- "@"
+(defconst tramp-postfix-user-format "@"
"*String matching delimeter between user and host names.
Used in `tramp-make-tramp-file-name'.")
@@ -1336,8 +688,7 @@ Used in `tramp-make-tramp-file-name'.")
"*Regexp matching delimeter between user and host names.
Derived from `tramp-postfix-user-format'.")
-(defconst tramp-host-regexp
- "[a-zA-Z0-9_.-]+"
+(defconst tramp-host-regexp "[a-zA-Z0-9_.-]+"
"*Regexp matching host names.")
(defconst tramp-prefix-ipv6-format
@@ -1385,8 +736,7 @@ Derived from `tramp-postfix-ipv6-format'.")
"*Regexp matching delimeter between host names and port numbers.
Derived from `tramp-prefix-port-format'.")
-(defconst tramp-port-regexp
- "[0-9]+"
+(defconst tramp-port-regexp "[0-9]+"
"*Regexp matching port numbers.")
(defconst tramp-host-with-port-regexp
@@ -1408,11 +758,10 @@ Used in `tramp-make-tramp-file-name'.")
"*Regexp matching delimeter between host names and localnames.
Derived from `tramp-postfix-host-format'.")
-(defconst tramp-localname-regexp
- ".*$"
+(defconst tramp-localname-regexp ".*$"
"*Regexp matching localnames.")
-;; File name format.
+;;; File name format:
(defconst tramp-file-name-structure
(list
@@ -1457,15 +806,13 @@ Tramp. See `tramp-file-name-structure' for more explanations.
On W32 systems, the volume letter must be ignored.")
;;;###autoload
-(defconst tramp-file-name-regexp-separate
- "\\`/\\[.*\\]"
+(defconst tramp-file-name-regexp-separate "\\`/\\[.*\\]"
"Value for `tramp-file-name-regexp' for separate remoting.
XEmacs uses a separate filename syntax for Tramp and EFS.
See `tramp-file-name-structure' for more explanations.")
;;;###autoload
-(defconst tramp-file-name-regexp-url
- "\\`/[^/:]+://"
+(defconst tramp-file-name-regexp-url "\\`/[^/:]+://"
"Value for `tramp-file-name-regexp' for URL-like remoting.
See `tramp-file-name-structure' for more explanations.")
@@ -1539,38 +886,6 @@ updated after changing this variable.
Also see `tramp-file-name-structure'.")
-(defconst tramp-actions-before-shell
- '((tramp-login-prompt-regexp tramp-action-login)
- (tramp-password-prompt-regexp tramp-action-password)
- (tramp-wrong-passwd-regexp tramp-action-permission-denied)
- (shell-prompt-pattern tramp-action-succeed)
- (tramp-shell-prompt-pattern tramp-action-succeed)
- (tramp-yesno-prompt-regexp tramp-action-yesno)
- (tramp-yn-prompt-regexp tramp-action-yn)
- (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).
-
-The PATTERN should be a symbol, a variable. The value of this
-variable gives the regular expression to search for. Note that the
-regexp must match at the end of the buffer, \"\\'\" is implicitly
-appended to it.
-
-The ACTION should also be a symbol, but a function. When the
-corresponding PATTERN matches, the ACTION function is called.")
-
-(defconst tramp-actions-copy-out-of-band
- '((tramp-password-prompt-regexp tramp-action-password)
- (tramp-wrong-passwd-regexp tramp-action-permission-denied)
- (tramp-copy-failed-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.")
-
;; Chunked sending kludge. We set this to 500 for black-listed constellations
;; known to have a bug in `process-send-string'; some ssh connections appear
;; to drop bytes when data is sent too quickly. There is also a connection
@@ -1659,8 +974,8 @@ A remote directory might have changed its contents. In order to
make it visible during file name completion in the minibuffer,
Tramp flushes its cache and rereads the directory contents when
more than `tramp-completion-reread-directory-timeout' seconds
-have been gone since last remote command execution. A value of 0
-would require an immediate reread during filename completion, nil
+have been gone since last remote command execution. A value of `t'
+would require an immediate reread during filename completion, `nil'
means to use always cached values for the directory contents."
:group 'tramp
:type '(choice (const nil) integer))
@@ -1676,437 +991,269 @@ means to use always cached values for the directory contents."
(defvar tramp-current-host nil
"Remote host for this *tramp* buffer.")
-(defconst tramp-uudecode
- "(echo begin 600 /tmp/tramp.$$; tail +2) | uudecode
-cat /tmp/tramp.$$
-rm -f /tmp/tramp.$$"
- "Shell function to implement `uudecode' to standard output.
-Many systems support `uudecode -o /dev/stdout' or `uudecode -o -'
-for this or `uudecode -p', but some systems don't, and for them
-we have this shell function.")
-
-(defconst tramp-perl-file-truename
- "%s -e '
-use File::Spec;
-use Cwd \"realpath\";
-
-sub recursive {
- my ($volume, @dirs) = @_;
- my $real = realpath(File::Spec->catpath(
- $volume, File::Spec->catdir(@dirs), \"\"));
- if ($real) {
- my ($vol, $dir) = File::Spec->splitpath($real, 1);
- return ($vol, File::Spec->splitdir($dir));
- }
- else {
- my $last = pop(@dirs);
- ($volume, @dirs) = recursive($volume, @dirs);
- push(@dirs, $last);
- return ($volume, @dirs);
- }
-}
-
-$result = realpath($ARGV[0]);
-if (!$result) {
- my ($vol, $dir) = File::Spec->splitpath($ARGV[0], 1);
- ($vol, @dirs) = recursive($vol, File::Spec->splitdir($dir));
-
- $result = File::Spec->catpath($vol, File::Spec->catdir(@dirs), \"\");
-}
-
-if ($ARGV[0] =~ /\\/$/) {
- $result = $result . \"/\";
-}
-
-print \"\\\"$result\\\"\\n\";
-' \"$1\" 2>/dev/null"
- "Perl script to produce output suitable for use with `file-truename'
-on the remote file system.
-Escape sequence %s is replaced with name of Perl binary.
-This string is passed to `format', so percent characters need to be doubled.")
-
-(defconst tramp-perl-file-name-all-completions
- "%s -e 'sub case {
- my $str = shift;
- if ($ARGV[2]) {
- return lc($str);
- }
- else {
- return $str;
- }
-}
-opendir(d, $ARGV[0]) || die(\"$ARGV[0]: $!\\nfail\\n\");
-@files = readdir(d); closedir(d);
-foreach $f (@files) {
- if (case(substr($f, 0, length($ARGV[1]))) eq case($ARGV[1])) {
- if (-d \"$ARGV[0]/$f\") {
- print \"$f/\\n\";
- }
- else {
- print \"$f\\n\";
- }
- }
-}
-print \"ok\\n\"
-' \"$1\" \"$2\" \"$3\" 2>/dev/null"
- "Perl script to produce output suitable for use with
-`file-name-all-completions' on the remote file system. Escape
-sequence %s is replaced with name of Perl binary. This string is
-passed to `format', so percent characters need to be doubled.")
-
-;; Perl script to implement `file-attributes' in a Lisp `read'able
-;; output. If you are hacking on this, note that you get *no* output
-;; unless this spits out a complete line, including the '\n' at the
-;; end.
-;; 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
- "%s -e '
-@stat = lstat($ARGV[0]);
-if (!@stat) {
- print \"nil\\n\";
- exit 0;
-}
-if (($stat[2] & 0170000) == 0120000)
-{
- $type = readlink($ARGV[0]);
- $type = \"\\\"$type\\\"\";
-}
-elsif (($stat[2] & 0170000) == 040000)
-{
- $type = \"t\";
-}
-else
-{
- $type = \"nil\"
-};
-$uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\";
-$gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\";
-printf(
- \"(%%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u.0 %%u t (%%u . %%u) -1)\\n\",
- $type,
- $stat[3],
- $uid,
- $gid,
- $stat[8] >> 16 & 0xffff,
- $stat[8] & 0xffff,
- $stat[9] >> 16 & 0xffff,
- $stat[9] & 0xffff,
- $stat[10] >> 16 & 0xffff,
- $stat[10] & 0xffff,
- $stat[7],
- $stat[2],
- $stat[1] >> 16 & 0xffff,
- $stat[1] & 0xffff
-);' \"$1\" \"$2\" 2>/dev/null"
- "Perl script to produce output suitable for use with `file-attributes'
-on the remote file system.
-Escape sequence %s is replaced with name of Perl binary.
-This string is passed to `format', so percent characters need to be doubled.")
-
-(defconst tramp-perl-directory-files-and-attributes
- "%s -e '
-chdir($ARGV[0]) or printf(\"\\\"Cannot change to $ARGV[0]: $''!''\\\"\\n\"), exit();
-opendir(DIR,\".\") or printf(\"\\\"Cannot open directory $ARGV[0]: $''!''\\\"\\n\"), exit();
-@list = readdir(DIR);
-closedir(DIR);
-$n = scalar(@list);
-printf(\"(\\n\");
-for($i = 0; $i < $n; $i++)
-{
- $filename = $list[$i];
- @stat = lstat($filename);
- if (($stat[2] & 0170000) == 0120000)
- {
- $type = readlink($filename);
- $type = \"\\\"$type\\\"\";
- }
- elsif (($stat[2] & 0170000) == 040000)
- {
- $type = \"t\";
- }
- else
- {
- $type = \"nil\"
- };
- $uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\";
- $gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\";
- printf(
- \"(\\\"%%s\\\" %%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u.0 %%u t (%%u . %%u) (%%u . %%u))\\n\",
- $filename,
- $type,
- $stat[3],
- $uid,
- $gid,
- $stat[8] >> 16 & 0xffff,
- $stat[8] & 0xffff,
- $stat[9] >> 16 & 0xffff,
- $stat[9] & 0xffff,
- $stat[10] >> 16 & 0xffff,
- $stat[10] & 0xffff,
- $stat[7],
- $stat[2],
- $stat[1] >> 16 & 0xffff,
- $stat[1] & 0xffff,
- $stat[0] >> 16 & 0xffff,
- $stat[0] & 0xffff);
-}
-printf(\")\\n\");' \"$1\" \"$2\" 2>/dev/null"
- "Perl script implementing `directory-files-attributes' as Lisp `read'able
-output.
-Escape sequence %s is replaced with name of Perl binary.
-This string is passed to `format', so percent characters need to be doubled.")
-
-;; ;; These two use uu encoding.
-;; (defvar tramp-perl-encode "%s -e'\
-;; print qq(begin 644 xxx\n);
-;; my $s = q();
-;; my $res = q();
-;; while (read(STDIN, $s, 45)) {
-;; print pack(q(u), $s);
-;; }
-;; print qq(`\n);
-;; print qq(end\n);
-;; '"
-;; "Perl program to use for encoding a file.
-;; Escape sequence %s is replaced with name of Perl binary.")
-
-;; (defvar tramp-perl-decode "%s -ne '
-;; print unpack q(u), $_;
-;; '"
-;; "Perl program to use for decoding a file.
-;; Escape sequence %s is replaced with name of Perl binary.")
-
-;; These two use base64 encoding.
-(defconst tramp-perl-encode-with-module
- "%s -MMIME::Base64 -0777 -ne 'print encode_base64($_)' 2>/dev/null"
- "Perl program to use for encoding a file.
-Escape sequence %s is replaced with name of Perl binary.
-This string is passed to `format', so percent characters need to be doubled.
-This implementation requires the MIME::Base64 Perl module to be installed
-on the remote host.")
-
-(defconst tramp-perl-decode-with-module
- "%s -MMIME::Base64 -0777 -ne 'print decode_base64($_)' 2>/dev/null"
- "Perl program to use for decoding a file.
-Escape sequence %s is replaced with name of Perl binary.
-This string is passed to `format', so percent characters need to be doubled.
-This implementation requires the MIME::Base64 Perl module to be installed
-on the remote host.")
-
-(defconst tramp-perl-encode
- "%s -e '
-# This script contributed by Juanma Barranquero <lektu@terra.es>.
-# Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-# Free Software Foundation, Inc.
-use strict;
-
-my %%trans = do {
- my $i = 0;
- map {(substr(unpack(q(B8), chr $i++), 2, 6), $_)}
- split //, q(ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/);
-};
-
-binmode(\\*STDIN);
-
-# We read in chunks of 54 bytes, to generate output lines
-# of 72 chars (plus end of line)
-$/ = \\54;
-
-while (my $data = <STDIN>) {
- my $pad = q();
-
- # Only for the last chunk, and only if did not fill the last three-byte packet
- if (eof) {
- my $mod = length($data) %% 3;
- $pad = q(=) x (3 - $mod) if $mod;
- }
-
- # Not the fastest method, but it is simple: unpack to binary string, split
- # by groups of 6 bits and convert back from binary to byte; then map into
- # the translation table
- print
- join q(),
- map($trans{$_},
- (substr(unpack(q(B*), $data) . q(00000), 0, 432) =~ /....../g)),
- $pad,
- qq(\\n);
-}' 2>/dev/null"
- "Perl program to use for encoding a file.
-Escape sequence %s is replaced with name of Perl binary.
-This string is passed to `format', so percent characters need to be doubled.")
-
-(defconst tramp-perl-decode
- "%s -e '
-# This script contributed by Juanma Barranquero <lektu@terra.es>.
-# Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-# Free Software Foundation, Inc.
-use strict;
-
-my %%trans = do {
- my $i = 0;
- map {($_, substr(unpack(q(B8), chr $i++), 2, 6))}
- split //, q(ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/)
-};
-
-my %%bytes = map {(unpack(q(B8), chr $_), chr $_)} 0 .. 255;
-
-binmode(\\*STDOUT);
-
-# We are going to accumulate into $pending to accept any line length
-# (we do not check they are <= 76 chars as the RFC says)
-my $pending = q();
-
-while (my $data = <STDIN>) {
- chomp $data;
-
- # If we find one or two =, we have reached the end and
- # any following data is to be discarded
- my $finished = $data =~ s/(==?).*/$1/;
- $pending .= $data;
-
- my $len = length($pending);
- my $chunk = substr($pending, 0, $len & ~3);
- $pending = substr($pending, $len & ~3 + 1);
-
- # Easy method: translate from chars to (pregenerated) six-bit packets, join,
- # split in 8-bit chunks and convert back to char.
- print join q(),
- map $bytes{$_},
- ((join q(), map {$trans{$_} || q()} split //, $chunk) =~ /......../g);
-
- last if $finished;
-}' 2>/dev/null"
- "Perl program to use for decoding a file.
-Escape sequence %s is replaced with name of Perl binary.
-This string is passed to `format', so percent characters need to be doubled.")
-
-(defconst tramp-vc-registered-read-file-names
- "echo \"(\"
-while read file; do
- if %s \"$file\"; then
- echo \"(\\\"$file\\\" \\\"file-exists-p\\\" t)\"
- else
- echo \"(\\\"$file\\\" \\\"file-exists-p\\\" nil)\"
- fi
- if %s \"$file\"; then
- echo \"(\\\"$file\\\" \\\"file-readable-p\\\" t)\"
- else
- echo \"(\\\"$file\\\" \\\"file-readable-p\\\" nil)\"
- fi
-done
-echo \")\""
- "Script to check existence of VC related files.
-It must be send formatted with two strings; the tests for file
-existence, and file readability. Input shall be read via
-here-document, otherwise the command could exceed maximum length
-of command line.")
-
-(defconst tramp-file-mode-type-map
- '((0 . "-") ; Normal file (SVID-v2 and XPG2)
- (1 . "p") ; fifo
- (2 . "c") ; character device
- (3 . "m") ; multiplexed character device (v7)
- (4 . "d") ; directory
- (5 . "?") ; Named special file (XENIX)
- (6 . "b") ; block device
- (7 . "?") ; multiplexed block device (v7)
- (8 . "-") ; regular file
- (9 . "n") ; network special file (HP-UX)
- (10 . "l") ; symlink
- (11 . "?") ; ACL shadow inode (Solaris, not userspace)
- (12 . "s") ; socket
- (13 . "D") ; door special (Solaris)
- (14 . "w")) ; whiteout (BSD)
- "A list of file types returned from the `stat' system call.
-This is used to map a mode number to a permission string.")
-
-;; New handlers should be added here. The following operations can be
-;; handled using the normal primitives: file-name-sans-versions,
-;; get-file-buffer.
-(defconst tramp-file-name-handler-alist
- '((load . tramp-handle-load)
- (make-symbolic-link . tramp-handle-make-symbolic-link)
- (file-name-as-directory . tramp-handle-file-name-as-directory)
- (file-name-directory . tramp-handle-file-name-directory)
- (file-name-nondirectory . tramp-handle-file-name-nondirectory)
- (file-truename . tramp-handle-file-truename)
- (file-exists-p . tramp-handle-file-exists-p)
- (file-directory-p . tramp-handle-file-directory-p)
- (file-executable-p . tramp-handle-file-executable-p)
- (file-readable-p . tramp-handle-file-readable-p)
- (file-regular-p . tramp-handle-file-regular-p)
- (file-symlink-p . tramp-handle-file-symlink-p)
- (file-writable-p . tramp-handle-file-writable-p)
- (file-ownership-preserved-p . tramp-handle-file-ownership-preserved-p)
- (file-newer-than-file-p . tramp-handle-file-newer-than-file-p)
- (file-attributes . tramp-handle-file-attributes)
- (file-modes . tramp-handle-file-modes)
- (directory-files . tramp-handle-directory-files)
- (directory-files-and-attributes . tramp-handle-directory-files-and-attributes)
- (file-name-all-completions . tramp-handle-file-name-all-completions)
- (file-name-completion . tramp-handle-file-name-completion)
- (add-name-to-file . tramp-handle-add-name-to-file)
- (copy-file . tramp-handle-copy-file)
- (copy-directory . tramp-handle-copy-directory)
- (rename-file . tramp-handle-rename-file)
- (set-file-modes . tramp-handle-set-file-modes)
- (set-file-times . tramp-handle-set-file-times)
- (make-directory . tramp-handle-make-directory)
- (delete-directory . tramp-handle-delete-directory)
- (delete-file . tramp-handle-delete-file)
- (directory-file-name . tramp-handle-directory-file-name)
- ;; `executable-find' is not official yet.
- (executable-find . tramp-handle-executable-find)
- (start-file-process . tramp-handle-start-file-process)
- (process-file . tramp-handle-process-file)
- (shell-command . tramp-handle-shell-command)
- (insert-directory . tramp-handle-insert-directory)
- (expand-file-name . tramp-handle-expand-file-name)
- (substitute-in-file-name . tramp-handle-substitute-in-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)
- (insert-file-contents-literally
- . tramp-handle-insert-file-contents-literally)
- (write-region . tramp-handle-write-region)
- (find-backup-file-name . tramp-handle-find-backup-file-name)
- (make-auto-save-file-name . tramp-handle-make-auto-save-file-name)
- (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory)
- (dired-compress-file . tramp-handle-dired-compress-file)
- (dired-recursive-delete-directory
- . tramp-handle-dired-recursive-delete-directory)
- (dired-uncache . tramp-handle-dired-uncache)
- (set-visited-file-modtime . tramp-handle-set-visited-file-modtime)
- (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
- (file-selinux-context . tramp-handle-file-selinux-context)
- (set-file-selinux-context . tramp-handle-set-file-selinux-context)
- (vc-registered . tramp-handle-vc-registered))
- "Alist of handler functions.
-Operations not mentioned here will be handled by the normal Emacs functions.")
-
-;; Handlers for partial Tramp file names. For Emacs just
-;; `file-name-all-completions' is needed.
;;;###autoload
(defconst tramp-completion-file-name-handler-alist
'((file-name-all-completions . tramp-completion-handle-file-name-all-completions)
(file-name-completion . tramp-completion-handle-file-name-completion))
"Alist of completion handler functions.
-Used for file names matching `tramp-file-name-regexp'. Operations not
-mentioned here will be handled by `tramp-file-name-handler-alist' or the
-normal Emacs functions.")
+Used for file names matching `tramp-file-name-regexp'. Operations
+not mentioned here will be handled by Tramp's file name handler
+functions, or the normal Emacs functions.")
;; Handlers for foreign methods, like FTP or SMB, shall be plugged here.
-(defvar tramp-foreign-file-name-handler-alist
- ;; (identity . tramp-sh-file-name-handler) should always be the last
- ;; entry, because `identity' always matches.
- '((identity . tramp-sh-file-name-handler))
+;;;###tramp-autoload
+(defvar tramp-foreign-file-name-handler-alist nil
"Alist of elements (FUNCTION . HANDLER) for foreign methods handled specially.
If (FUNCTION FILENAME) returns non-nil, then all I/O on that file is done by
calling HANDLER.")
;;; Internal functions which must come first:
+;; Conversion functions between external representation and
+;; internal data structure. Convenience functions for internal
+;; data structure.
+
+(defun tramp-file-name-p (vec)
+ "Check, whether VEC is a Tramp object."
+ (and (vectorp vec) (= 4 (length vec))))
+
+(defun tramp-file-name-method (vec)
+ "Return method component of VEC."
+ (and (tramp-file-name-p vec) (aref vec 0)))
+
+(defun tramp-file-name-user (vec)
+ "Return user component of VEC."
+ (and (tramp-file-name-p vec) (aref vec 1)))
+
+(defun tramp-file-name-host (vec)
+ "Return host component of VEC."
+ (and (tramp-file-name-p vec) (aref vec 2)))
+
+(defun tramp-file-name-localname (vec)
+ "Return localname component of VEC."
+ (and (tramp-file-name-p vec) (aref vec 3)))
+
+;; The user part of a Tramp file name vector can be of kind
+;; "user%domain". Sometimes, we must extract these parts.
+(defun tramp-file-name-real-user (vec)
+ "Return the user name of VEC without domain."
+ (save-match-data
+ (let ((user (tramp-file-name-user vec)))
+ (if (and (stringp user)
+ (string-match tramp-user-with-domain-regexp user))
+ (match-string 1 user)
+ user))))
+
+(defun tramp-file-name-domain (vec)
+ "Return the domain name of VEC."
+ (save-match-data
+ (let ((user (tramp-file-name-user vec)))
+ (and (stringp user)
+ (string-match tramp-user-with-domain-regexp user)
+ (match-string 2 user)))))
+
+;; The host part of a Tramp file name vector can be of kind
+;; "host#port". Sometimes, we must extract these parts.
+(defun tramp-file-name-real-host (vec)
+ "Return the host name of VEC without port."
+ (save-match-data
+ (let ((host (tramp-file-name-host vec)))
+ (if (and (stringp host)
+ (string-match tramp-host-with-port-regexp host))
+ (match-string 1 host)
+ host))))
+
+(defun tramp-file-name-port (vec)
+ "Return the port number of VEC."
+ (save-match-data
+ (let ((host (tramp-file-name-host vec)))
+ (and (stringp host)
+ (string-match tramp-host-with-port-regexp host)
+ (string-to-number (match-string 2 host))))))
+
+;;;###tramp-autoload
+(defun tramp-tramp-file-p (name)
+ "Return t if NAME is a string with Tramp file name syntax."
+ (save-match-data
+ (and (stringp name) (string-match tramp-file-name-regexp name))))
+
+(defun tramp-find-method (method user host)
+ "Return the right method string to use.
+This is METHOD, if non-nil. Otherwise, do a lookup in
+`tramp-default-method-alist'."
+ (or method
+ (let ((choices tramp-default-method-alist)
+ lmethod item)
+ (while choices
+ (setq item (pop choices))
+ (when (and (string-match (or (nth 0 item) "") (or host ""))
+ (string-match (or (nth 1 item) "") (or user "")))
+ (setq lmethod (nth 2 item))
+ (setq choices nil)))
+ lmethod)
+ tramp-default-method))
+
+(defun tramp-find-user (method user host)
+ "Return the right user string to use.
+This is USER, if non-nil. Otherwise, do a lookup in
+`tramp-default-user-alist'."
+ (or user
+ (let ((choices tramp-default-user-alist)
+ luser item)
+ (while choices
+ (setq item (pop choices))
+ (when (and (string-match (or (nth 0 item) "") (or method ""))
+ (string-match (or (nth 1 item) "") (or host "")))
+ (setq luser (nth 2 item))
+ (setq choices nil)))
+ luser)
+ tramp-default-user))
+
+(defun tramp-find-host (method user host)
+ "Return the right host string to use.
+This is HOST, if non-nil. Otherwise, it is `tramp-default-host'."
+ (or (and (> (length host) 0) host)
+ tramp-default-host))
+
+(defun tramp-dissect-file-name (name &optional nodefault)
+ "Return a `tramp-file-name' structure.
+The structure consists of remote method, remote user, remote host
+and localname (file name on remote host). If NODEFAULT is
+non-nil, the file name parts are not expanded to their default
+values."
+ (save-match-data
+ (let ((match (string-match (nth 0 tramp-file-name-structure) name)))
+ (unless match (error "Not a Tramp file name: %s" name))
+ (let ((method (match-string (nth 1 tramp-file-name-structure) name))
+ (user (match-string (nth 2 tramp-file-name-structure) name))
+ (host (match-string (nth 3 tramp-file-name-structure) name))
+ (localname (match-string (nth 4 tramp-file-name-structure) name)))
+ (when host
+ (when (string-match tramp-prefix-ipv6-regexp host)
+ (setq host (replace-match "" nil t host)))
+ (when (string-match tramp-postfix-ipv6-regexp host)
+ (setq host (replace-match "" nil t host))))
+ (if nodefault
+ (vector method user host localname)
+ (vector
+ (tramp-find-method method user host)
+ (tramp-find-user method user host)
+ (tramp-find-host method user host)
+ localname))))))
+
+(defun tramp-buffer-name (vec)
+ "A name for the connection buffer VEC."
+ ;; We must use `tramp-file-name-real-host', because for gateway
+ ;; methods the default port will be expanded later on, which would
+ ;; tamper the name.
+ (let ((method (tramp-file-name-method vec))
+ (user (tramp-file-name-user vec))
+ (host (tramp-file-name-real-host vec)))
+ (if (not (zerop (length user)))
+ (format "*tramp/%s %s@%s*" method user host)
+ (format "*tramp/%s %s*" method host))))
+
+(defun tramp-make-tramp-file-name (method user host localname)
+ "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME."
+ (concat tramp-prefix-format
+ (when (not (zerop (length method)))
+ (concat method tramp-postfix-method-format))
+ (when (not (zerop (length user)))
+ (concat user tramp-postfix-user-format))
+ (when host
+ (if (string-match tramp-ipv6-regexp host)
+ (concat tramp-prefix-ipv6-format host tramp-postfix-ipv6-format)
+ host))
+ tramp-postfix-host-format
+ (when localname localname)))
+
+(defun tramp-completion-make-tramp-file-name (method user host localname)
+ "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME.
+It must not be a complete Tramp file name, but as long as there are
+necessary only. This function will be used in file name completion."
+ (concat tramp-prefix-format
+ (when (not (zerop (length method)))
+ (concat method tramp-postfix-method-format))
+ (when (not (zerop (length user)))
+ (concat user tramp-postfix-user-format))
+ (when (not (zerop (length host)))
+ (concat
+ (if (string-match tramp-ipv6-regexp host)
+ (concat
+ tramp-prefix-ipv6-format host tramp-postfix-ipv6-format)
+ host)
+ tramp-postfix-host-format))
+ (when localname localname)))
+
+(defun tramp-get-buffer (vec)
+ "Get the connection buffer to be used for VEC."
+ (or (get-buffer (tramp-buffer-name vec))
+ (with-current-buffer (get-buffer-create (tramp-buffer-name vec))
+ (setq buffer-undo-list t)
+ (setq default-directory
+ (tramp-make-tramp-file-name
+ (tramp-file-name-method vec)
+ (tramp-file-name-user vec)
+ (tramp-file-name-host vec)
+ "/"))
+ (current-buffer))))
+
+(defun tramp-get-connection-buffer (vec)
+ "Get the connection buffer to be used for VEC.
+In case a second asynchronous communication has been started, it is different
+from `tramp-get-buffer'."
+ (or (tramp-get-connection-property vec "process-buffer" nil)
+ (tramp-get-buffer vec)))
+
+(defun tramp-get-connection-process (vec)
+ "Get the connection process to be used for VEC.
+In case a second asynchronous communication has been started, it is different
+from the default one."
+ (get-process
+ (or (tramp-get-connection-property vec "process-name" nil)
+ (tramp-buffer-name vec))))
+
+(defun tramp-debug-buffer-name (vec)
+ "A name for the debug buffer for VEC."
+ ;; We must use `tramp-file-name-real-host', because for gateway
+ ;; methods the default port will be expanded later on, which would
+ ;; tamper the name.
+ (let ((method (tramp-file-name-method vec))
+ (user (tramp-file-name-user vec))
+ (host (tramp-file-name-real-host vec)))
+ (if (not (zerop (length user)))
+ (format "*debug tramp/%s %s@%s*" method user host)
+ (format "*debug tramp/%s %s*" method host))))
+
+(defconst tramp-debug-outline-regexp
+ "[0-9]+:[0-9]+:[0-9]+\\.[0-9]+ [a-z0-9-]+ (\\([0-9]+\\)) #"
+ "Used for highlighting Tramp debug buffers in `outline-mode'.")
+
+(defun tramp-debug-outline-level ()
+ "Return the depth to which a statement is nested in the outline.
+Point must be at the beginning of a header line.
+
+The outline level is equal to the verbosity of the Tramp message."
+ (1+ (string-to-number (match-string 1))))
+
+(defun tramp-get-debug-buffer (vec)
+ "Get the debug buffer for VEC."
+ (with-current-buffer
+ (get-buffer-create (tramp-debug-buffer-name vec))
+ (when (bobp)
+ (setq buffer-undo-list t)
+ ;; Activate `outline-mode'. This runs `text-mode-hook' and
+ ;; `outline-mode-hook'. We must prevent that local processes
+ ;; die. Yes: I've seen `flyspell-mode', which starts "ispell".
+ ;; Furthermore, `outline-regexp' must have the correct value
+ ;; already, because it is used by `font-lock-compile-keywords'.
+ (let ((default-directory (tramp-compat-temporary-file-directory))
+ (outline-regexp tramp-debug-outline-regexp))
+ (outline-mode))
+ (set (make-local-variable 'outline-regexp) tramp-debug-outline-regexp)
+ (set (make-local-variable 'outline-level) 'tramp-debug-outline-level))
+ (current-buffer)))
+
(defsubst tramp-debug-message (vec fmt-string &rest args)
"Append message to debug buffer.
Message is formatted with FMT-STRING as control string and the remaining
@@ -2173,36 +1320,34 @@ is greater than or equal 4.
Calls functions `message' and `tramp-debug-message' with FMT-STRING as
control string and the remaining ARGS to actually emit the message (if
applicable)."
- (condition-case nil
- (when (<= level tramp-verbose)
- ;; Match data must be preserved!
- (save-match-data
- ;; Display only when there is a minimum level.
- (when (and tramp-message-show-message (<= level 3))
- (apply 'message
- (concat
- (cond
- ((= level 0) "")
- ((= level 1) "")
- ((= level 2) "Warning: ")
- (t "Tramp: "))
- fmt-string)
- args))
- ;; Log only when there is a minimum level.
- (when (>= tramp-verbose 4)
- (when (and vec-or-proc
- (processp vec-or-proc)
- (buffer-name (process-buffer vec-or-proc)))
- (with-current-buffer (process-buffer vec-or-proc)
- ;; Translate proc to vec.
- (setq vec-or-proc (tramp-dissect-file-name default-directory))))
- (when (and vec-or-proc (vectorp vec-or-proc))
- (apply 'tramp-debug-message
- vec-or-proc
- (concat (format "(%d) # " level) fmt-string)
- args)))))
- ;; Suppress all errors.
- (error nil)))
+ (ignore-errors
+ (when (<= level tramp-verbose)
+ ;; Match data must be preserved!
+ (save-match-data
+ ;; Display only when there is a minimum level.
+ (when (and tramp-message-show-message (<= level 3))
+ (apply 'message
+ (concat
+ (cond
+ ((= level 0) "")
+ ((= level 1) "")
+ ((= level 2) "Warning: ")
+ (t "Tramp: "))
+ fmt-string)
+ args))
+ ;; Log only when there is a minimum level.
+ (when (>= tramp-verbose 4)
+ (when (and vec-or-proc
+ (processp vec-or-proc)
+ (buffer-name (process-buffer vec-or-proc)))
+ (with-current-buffer (process-buffer vec-or-proc)
+ ;; Translate proc to vec.
+ (setq vec-or-proc (tramp-dissect-file-name default-directory))))
+ (when (and vec-or-proc (vectorp vec-or-proc))
+ (apply 'tramp-debug-message
+ vec-or-proc
+ (concat (format "(%d) # " level) fmt-string)
+ args)))))))
(defsubst tramp-error (vec-or-proc signal fmt-string &rest args)
"Emit an error.
@@ -2264,46 +1409,14 @@ If VAR is nil, then we bind `v' to the structure and `method', `user',
(put 'with-parsed-tramp-file-name 'lisp-indent-function 2)
(put 'with-parsed-tramp-file-name 'edebug-form-spec '(form symbolp body))
-(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-parsed-tramp-file-name\\>"))
-
-(defmacro with-file-property (vec file property &rest body)
- "Check in Tramp cache for PROPERTY, otherwise execute BODY and set cache.
-FILE must be a local file name on a connection identified via VEC."
- `(if (file-name-absolute-p ,file)
- (let ((value (tramp-get-file-property ,vec ,file ,property 'undef)))
- (when (eq value 'undef)
- ;; We cannot pass @body as parameter to
- ;; `tramp-set-file-property' because it mangles our
- ;; debug messages.
- (setq value (progn ,@body))
- (tramp-set-file-property ,vec ,file ,property value))
- value)
- ,@body))
-
-(put 'with-file-property 'lisp-indent-function 3)
-(put 'with-file-property 'edebug-form-spec t)
-(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-file-property\\>"))
-
-(defmacro with-connection-property (key property &rest body)
- "Check in Tramp for property PROPERTY, otherwise executes BODY and set."
- `(let ((value (tramp-get-connection-property ,key ,property 'undef)))
- (when (eq value 'undef)
- ;; We cannot pass ,@body as parameter to
- ;; `tramp-set-connection-property' because it mangles our debug
- ;; messages.
- (setq value (progn ,@body))
- (tramp-set-connection-property ,key ,property value))
- value))
-
-(put 'with-connection-property 'lisp-indent-function 2)
-(put 'with-connection-property 'edebug-form-spec t)
-(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-connection-property\\>"))
+(tramp-compat-font-lock-add-keywords
+ 'emacs-lisp-mode '("\\<with-parsed-tramp-file-name\\>"))
(defun tramp-progress-reporter-update (reporter &optional value)
(let* ((parameters (cdr reporter))
(message (aref parameters 3)))
(when (string-match message (or (current-message) ""))
- (funcall 'progress-reporter-update reporter value))))
+ (tramp-compat-funcall 'progress-reporter-update reporter value))))
(defmacro with-progress-reporter (vec level message &rest body)
"Executes BODY, spinning a progress reporter with MESSAGE.
@@ -2317,11 +1430,10 @@ progress reporter."
(when (and tramp-message-show-message
;; Display only when there is a minimum level.
(<= ,level (min tramp-verbose 3)))
- (condition-case nil
- (setq pr (tramp-compat-funcall 'make-progress-reporter ,message)
- tm (when pr
- (run-at-time 3 0.1 'tramp-progress-reporter-update pr)))
- (error nil)))
+ (ignore-errors
+ (setq pr (tramp-compat-funcall 'make-progress-reporter ,message)
+ tm (when pr
+ (run-at-time 3 0.1 'tramp-progress-reporter-update pr)))))
(unwind-protect
;; Execute the body. Unset `tramp-message-show-message' when
;; the timer object is created, in order to suppress
@@ -2335,7 +1447,8 @@ progress reporter."
(put 'with-progress-reporter 'lisp-indent-function 3)
(put 'with-progress-reporter 'edebug-form-spec t)
-(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-progress-reporter\\>"))
+(tramp-compat-font-lock-add-keywords
+ 'emacs-lisp-mode '("\\<with-progress-reporter\\>"))
(eval-and-compile ;; Silence compiler.
(if (memq system-type '(cygwin windows-nt))
@@ -2352,34 +1465,6 @@ letter into the file name. This function removes it."
(defalias 'tramp-drop-volume-letter 'identity)))
-(defsubst tramp-make-tramp-temp-file (vec)
- "Create a temporary file on the remote host identified by VEC.
-Return the local name of the temporary file."
- (let ((prefix
- (tramp-make-tramp-file-name
- (tramp-file-name-method vec)
- (tramp-file-name-user vec)
- (tramp-file-name-host vec)
- (tramp-drop-volume-letter
- (expand-file-name
- tramp-temp-name-prefix (tramp-get-remote-tmpdir vec)))))
- result)
- (while (not result)
- ;; `make-temp-file' would be the natural choice for
- ;; implementation. But it calls `write-region' internally,
- ;; which also needs a temporary file - we would end in an
- ;; infinite loop.
- (setq result (make-temp-name prefix))
- (if (file-exists-p result)
- (setq result nil)
- ;; This creates the file by side effect.
- (set-file-times result)
- (set-file-modes result (tramp-octal-to-decimal "0700"))))
-
- ;; Return the local part.
- (with-parsed-tramp-file-name result nil localname)))
-
-
;;; Config Manipulation Functions:
(defun tramp-set-completion-function (method function-list)
@@ -2414,7 +1499,7 @@ Example:
;; Windows registry.
(and (memq system-type '(cygwin windows-nt))
(zerop
- (tramp-local-call-process
+ (tramp-compat-call-process
"reg" nil nil nil "query" (nth 1 (car v)))))
;; Configuration file.
(file-exists-p (nth 1 (car v)))))
@@ -2502,279 +1587,6 @@ been set up by `rfn-eshadow-setup-minibuffer'."
(remove-hook 'rfn-eshadow-update-overlay-hook
'tramp-rfn-eshadow-update-overlay))))
-
-;;; Integration of eshell.el:
-
-(eval-when-compile
- (defvar eshell-path-env))
-
-;; eshell.el keeps the path in `eshell-path-env'. We must change it
-;; when `default-directory' points to another host.
-(defun tramp-eshell-directory-change ()
- "Set `eshell-path-env' to $PATH of the host related to `default-directory'."
- (setq eshell-path-env
- (if (file-remote-p default-directory)
- (with-parsed-tramp-file-name default-directory nil
- (mapconcat
- 'identity
- (tramp-get-remote-path v)
- ":"))
- (getenv "PATH"))))
-
-(eval-after-load "esh-util"
- '(progn
- (tramp-eshell-directory-change)
- (add-hook 'eshell-directory-change-hook
- 'tramp-eshell-directory-change)
- (add-hook 'tramp-unload-hook
- (lambda ()
- (remove-hook 'eshell-directory-change-hook
- 'tramp-eshell-directory-change)))))
-
-
-;;; File Name Handler Functions:
-
-(defun tramp-handle-make-symbolic-link
- (filename linkname &optional ok-if-already-exists)
- "Like `make-symbolic-link' for Tramp files.
-If LINKNAME is a non-Tramp file, it is used verbatim as the target of
-the symlink. If LINKNAME is a Tramp file, only the localname component is
-used as the target of the symlink.
-
-If LINKNAME is a Tramp file and the localname component is relative, then
-it is expanded first, before the localname component is taken. Note that
-this can give surprising results if the user/host for the source and
-target of the symlink differ."
- (with-parsed-tramp-file-name linkname l
- (let ((ln (tramp-get-remote-ln l))
- (cwd (tramp-run-real-handler
- 'file-name-directory (list l-localname))))
- (unless ln
- (tramp-error
- l 'file-error
- "Making a symbolic link. ln(1) does not exist on the remote host."))
-
- ;; Do the 'confirm if exists' thing.
- (when (file-exists-p linkname)
- ;; What to do?
- (if (or (null ok-if-already-exists) ; not allowed to exist
- (and (numberp ok-if-already-exists)
- (not (yes-or-no-p
- (format
- "File %s already exists; make it a link anyway? "
- l-localname)))))
- (tramp-error
- l 'file-already-exists "File %s already exists" l-localname)
- (delete-file linkname)))
-
- ;; If FILENAME is a Tramp name, use just the localname component.
- (when (tramp-tramp-file-p filename)
- (setq filename
- (tramp-file-name-localname
- (tramp-dissect-file-name (expand-file-name filename)))))
-
- (tramp-flush-file-property l (file-name-directory l-localname))
- (tramp-flush-file-property l l-localname)
-
- ;; Right, they are on the same host, regardless of user, method, etc.
- ;; We now make the link on the remote machine. This will occur as the user
- ;; that FILENAME belongs to.
- (zerop
- (tramp-send-command-and-check
- l
- (format
- "cd %s && %s -sf %s %s"
- (tramp-shell-quote-argument cwd)
- ln
- (tramp-shell-quote-argument filename)
- (tramp-shell-quote-argument l-localname))
- t)))))
-
-(defun tramp-handle-load (file &optional noerror nomessage nosuffix must-suffix)
- "Like `load' for Tramp files."
- (with-parsed-tramp-file-name (expand-file-name file) nil
- (unless nosuffix
- (cond ((file-exists-p (concat file ".elc"))
- (setq file (concat file ".elc")))
- ((file-exists-p (concat file ".el"))
- (setq file (concat file ".el")))))
- (when must-suffix
- ;; The first condition is always true for absolute file names.
- ;; Included for safety's sake.
- (unless (or (file-name-directory file)
- (string-match "\\.elc?\\'" file))
- (tramp-error
- v 'file-error
- "File `%s' does not include a `.el' or `.elc' suffix" file)))
- (unless noerror
- (when (not (file-exists-p file))
- (tramp-error v 'file-error "Cannot load nonexistent file `%s'" file)))
- (if (not (file-exists-p file))
- nil
- (let ((tramp-message-show-message (not nomessage)))
- (with-progress-reporter v 0 (format "Loading %s" file)
- (let ((local-copy (file-local-copy file)))
- ;; MUST-SUFFIX doesn't exist on XEmacs, so let it default to nil.
- (unwind-protect
- (load local-copy noerror t t)
- (delete-file local-copy)))))
- t)))
-
-;; Localname manipulation functions that grok Tramp localnames...
-(defun tramp-handle-file-name-as-directory (file)
- "Like `file-name-as-directory' but aware of Tramp files."
- ;; `file-name-as-directory' would be sufficient except localname is
- ;; the empty string.
- (let ((v (tramp-dissect-file-name file t)))
- ;; Run the command on the localname portion only.
- (tramp-make-tramp-file-name
- (tramp-file-name-method v)
- (tramp-file-name-user v)
- (tramp-file-name-host v)
- (tramp-run-real-handler
- 'file-name-as-directory (list (or (tramp-file-name-localname v) ""))))))
-
-(defun tramp-handle-file-name-directory (file)
- "Like `file-name-directory' but aware of Tramp files."
- ;; Everything except the last filename thing is the directory. We
- ;; cannot apply `with-parsed-tramp-file-name', because this expands
- ;; the remote file name parts. This is a problem when we are in
- ;; file name completion.
- (let ((v (tramp-dissect-file-name file t)))
- ;; Run the command on the localname portion only.
- (tramp-make-tramp-file-name
- (tramp-file-name-method v)
- (tramp-file-name-user v)
- (tramp-file-name-host v)
- (tramp-run-real-handler
- 'file-name-directory (list (or (tramp-file-name-localname v) ""))))))
-
-(defun tramp-handle-file-name-nondirectory (file)
- "Like `file-name-nondirectory' but aware of Tramp files."
- (with-parsed-tramp-file-name file nil
- (tramp-run-real-handler 'file-name-nondirectory (list localname))))
-
-(defun tramp-handle-file-truename (filename &optional counter prev-dirs)
- "Like `file-truename' for Tramp files."
- (with-parsed-tramp-file-name (expand-file-name filename) nil
- (with-file-property v localname "file-truename"
- (let ((result nil)) ; result steps in reverse order
- (tramp-message v 4 "Finding true name for `%s'" filename)
- (cond
- ;; Use GNU readlink --canonicalize-missing where available.
- ((tramp-get-remote-readlink v)
- (setq result
- (tramp-send-command-and-read
- v
- (format "echo \"\\\"`%s --canonicalize-missing %s`\\\"\""
- (tramp-get-remote-readlink v)
- (tramp-shell-quote-argument localname)))))
-
- ;; Use Perl implementation.
- ((and (tramp-get-remote-perl v)
- (tramp-get-connection-property v "perl-file-spec" nil)
- (tramp-get-connection-property v "perl-cwd-realpath" nil))
- (tramp-maybe-send-script
- v tramp-perl-file-truename "tramp_perl_file_truename")
- (setq result
- (tramp-send-command-and-read
- v
- (format "tramp_perl_file_truename %s"
- (tramp-shell-quote-argument localname)))))
-
- ;; Do it yourself. We bind `directory-sep-char' here for
- ;; XEmacs on Windows, which would otherwise use backslash.
- (t (let* ((directory-sep-char ?/)
- (steps (tramp-compat-split-string localname "/"))
- (localnamedir (tramp-run-real-handler
- 'file-name-as-directory (list localname)))
- (is-dir (string= localname localnamedir))
- (thisstep nil)
- (numchase 0)
- ;; Don't make the following value larger than
- ;; necessary. People expect an error message in a
- ;; timely fashion when something is wrong;
- ;; otherwise they might think that Emacs is hung.
- ;; Of course, correctness has to come first.
- (numchase-limit 20)
- symlink-target)
- (while (and steps (< numchase numchase-limit))
- (setq thisstep (pop steps))
- (tramp-message
- v 5 "Check %s"
- (mapconcat 'identity
- (append '("") (reverse result) (list thisstep))
- "/"))
- (setq symlink-target
- (nth 0 (file-attributes
- (tramp-make-tramp-file-name
- method user host
- (mapconcat 'identity
- (append '("")
- (reverse result)
- (list thisstep))
- "/")))))
- (cond ((string= "." thisstep)
- (tramp-message v 5 "Ignoring step `.'"))
- ((string= ".." thisstep)
- (tramp-message v 5 "Processing step `..'")
- (pop result))
- ((stringp symlink-target)
- ;; It's a symlink, follow it.
- (tramp-message v 5 "Follow symlink to %s" symlink-target)
- (setq numchase (1+ numchase))
- (when (file-name-absolute-p symlink-target)
- (setq result nil))
- ;; If the symlink was absolute, we'll get a string like
- ;; "/user@host:/some/target"; extract the
- ;; "/some/target" part from it.
- (when (tramp-tramp-file-p symlink-target)
- (unless (tramp-equal-remote filename symlink-target)
- (tramp-error
- v 'file-error
- "Symlink target `%s' on wrong host" symlink-target))
- (setq symlink-target localname))
- (setq steps
- (append (tramp-compat-split-string
- symlink-target "/")
- steps)))
- (t
- ;; It's a file.
- (setq result (cons thisstep result)))))
- (when (>= numchase numchase-limit)
- (tramp-error
- v 'file-error
- "Maximum number (%d) of symlinks exceeded" numchase-limit))
- (setq result (reverse result))
- ;; Combine list to form string.
- (setq result
- (if result
- (mapconcat 'identity (cons "" result) "/")
- "/"))
- (when (and is-dir (or (string= "" result)
- (not (string= (substring result -1) "/"))))
- (setq result (concat result "/"))))))
-
- (tramp-message v 4 "True name of `%s' is `%s'" filename result)
- (tramp-make-tramp-file-name method user host result)))))
-
-;; Basic functions.
-
-(defun tramp-handle-file-exists-p (filename)
- "Like `file-exists-p' for Tramp files."
- (with-parsed-tramp-file-name filename nil
- (with-file-property v localname "file-exists-p"
- (or (not (null (tramp-get-file-property
- v localname "file-attributes-integer" nil)))
- (not (null (tramp-get-file-property
- v localname "file-attributes-string" nil)))
- (zerop (tramp-send-command-and-check
- v
- (format
- "%s %s"
- (tramp-get-file-exists-command v)
- (tramp-shell-quote-argument localname))))))))
-
;; Inodes don't exist for some file systems. Therefore we must
;; generate virtual ones. Used in `find-buffer-visiting'. The method
;; applied might be not so efficient (Ange-FTP uses hashes). But
@@ -2791,1638 +1603,12 @@ target of the symlink differ."
(defvar tramp-devices nil
"Keeps virtual device numbers.")
-;; CCC: This should check for an error condition and signal failure
-;; when something goes wrong.
-;; Daniel Pittman <daniel@danann.net>
-(defun tramp-handle-file-attributes (filename &optional id-format)
- "Like `file-attributes' for Tramp files."
- (unless id-format (setq id-format 'integer))
- ;; Don't modify `last-coding-system-used' by accident.
- (let ((last-coding-system-used last-coding-system-used))
- (with-parsed-tramp-file-name (expand-file-name filename) nil
- (with-file-property v localname (format "file-attributes-%s" id-format)
- (save-excursion
- (tramp-convert-file-attributes
- v
- (cond
- ((tramp-get-remote-stat v)
- (tramp-do-file-attributes-with-stat v localname id-format))
- ((tramp-get-remote-perl v)
- (tramp-do-file-attributes-with-perl v localname id-format))
- (t
- (tramp-do-file-attributes-with-ls v localname id-format)))))))))
-
-(defun tramp-do-file-attributes-with-ls (vec localname &optional id-format)
- "Implement `file-attributes' for Tramp files using the ls(1) command."
- (let (symlinkp dirp
- res-inode res-filemodes res-numlinks
- res-uid res-gid res-size res-symlink-target)
- (tramp-message vec 5 "file attributes with ls: %s" localname)
- (tramp-send-command
- vec
- (format "(%s %s || %s -h %s) && %s %s %s"
- (tramp-get-file-exists-command vec)
- (tramp-shell-quote-argument localname)
- (tramp-get-test-command vec)
- (tramp-shell-quote-argument localname)
- (tramp-get-ls-command vec)
- (if (eq id-format 'integer) "-ildn" "-ild")
- (tramp-shell-quote-argument localname)))
- ;; parse `ls -l' output ...
- (with-current-buffer (tramp-get-buffer vec)
- (when (> (buffer-size) 0)
- (goto-char (point-min))
- ;; ... inode
- (setq res-inode
- (condition-case err
- (read (current-buffer))
- (invalid-read-syntax
- (when (and (equal (cadr err)
- "Integer constant overflow in reader")
- (string-match
- "^[0-9]+\\([0-9][0-9][0-9][0-9][0-9]\\)\\'"
- (car (cddr err))))
- (let* ((big (read (substring (car (cddr err)) 0
- (match-beginning 1))))
- (small (read (match-string 1 (car (cddr err)))))
- (twiddle (/ small 65536)))
- (cons (+ big twiddle)
- (- small (* twiddle 65536))))))))
- ;; ... file mode flags
- (setq res-filemodes (symbol-name (read (current-buffer))))
- ;; ... number links
- (setq res-numlinks (read (current-buffer)))
- ;; ... uid and gid
- (setq res-uid (read (current-buffer)))
- (setq res-gid (read (current-buffer)))
- (if (eq id-format 'integer)
- (progn
- (unless (numberp res-uid) (setq res-uid -1))
- (unless (numberp res-gid) (setq res-gid -1)))
- (progn
- (unless (stringp res-uid) (setq res-uid (symbol-name res-uid)))
- (unless (stringp res-gid) (setq res-gid (symbol-name res-gid)))))
- ;; ... size
- (setq res-size (read (current-buffer)))
- ;; From the file modes, figure out other stuff.
- (setq symlinkp (eq ?l (aref res-filemodes 0)))
- (setq dirp (eq ?d (aref res-filemodes 0)))
- ;; if symlink, find out file name pointed to
- (when symlinkp
- (search-forward "-> ")
- (setq res-symlink-target
- (buffer-substring (point) (tramp-compat-line-end-position))))
- ;; return data gathered
- (list
- ;; 0. t for directory, string (name linked to) for symbolic
- ;; link, or nil.
- (or dirp res-symlink-target)
- ;; 1. Number of links to file.
- res-numlinks
- ;; 2. File uid.
- res-uid
- ;; 3. File gid.
- res-gid
- ;; 4. Last access time, as a list of two integers. First
- ;; integer has high-order 16 bits of time, second has low 16
- ;; bits.
- ;; 5. Last modification time, likewise.
- ;; 6. Last status change time, likewise.
- '(0 0) '(0 0) '(0 0) ;CCC how to find out?
- ;; 7. Size in bytes (-1, if number is out of range).
- res-size
- ;; 8. File modes, as a string of ten letters or dashes as in ls -l.
- res-filemodes
- ;; 9. t if file's gid would change if file were deleted and
- ;; recreated. Will be set in `tramp-convert-file-attributes'
- t
- ;; 10. inode number.
- res-inode
- ;; 11. Device number. Will be replaced by a virtual device number.
- -1
- )))))
-
-(defun tramp-do-file-attributes-with-perl
- (vec localname &optional id-format)
- "Implement `file-attributes' for Tramp files using a Perl script."
- (tramp-message vec 5 "file attributes with perl: %s" localname)
- (tramp-maybe-send-script
- vec tramp-perl-file-attributes "tramp_perl_file_attributes")
- (tramp-send-command-and-read
- vec
- (format "tramp_perl_file_attributes %s %s"
- (tramp-shell-quote-argument localname) id-format)))
-
-(defun tramp-do-file-attributes-with-stat
- (vec localname &optional id-format)
- "Implement `file-attributes' for Tramp files using stat(1) command."
- (tramp-message vec 5 "file attributes with stat: %s" localname)
- (tramp-send-command-and-read
- vec
- (format
- ;; On Opsware, pdksh (which is the true name of ksh there) doesn't
- ;; parse correctly the sequence "((". Therefore, we add a space.
- "( (%s %s || %s -h %s) && %s -c '( (\"%%N\") %%h %s %s %%Xe0 %%Ye0 %%Ze0 %%se0 \"%%A\" t %%ie0 -1)' %s || echo nil)"
- (tramp-get-file-exists-command vec)
- (tramp-shell-quote-argument localname)
- (tramp-get-test-command vec)
- (tramp-shell-quote-argument localname)
- (tramp-get-remote-stat vec)
- (if (eq id-format 'integer) "%u" "\"%U\"")
- (if (eq id-format 'integer) "%g" "\"%G\"")
- (tramp-shell-quote-argument localname))))
-
-(defun tramp-handle-set-visited-file-modtime (&optional time-list)
- "Like `set-visited-file-modtime' for Tramp files."
- (unless (buffer-file-name)
- (error "Can't set-visited-file-modtime: buffer `%s' not visiting a file"
- (buffer-name)))
- (if time-list
- (tramp-run-real-handler 'set-visited-file-modtime (list time-list))
- (let ((f (buffer-file-name))
- coding-system-used)
- (with-parsed-tramp-file-name f nil
- (let* ((attr (file-attributes f))
- ;; '(-1 65535) means file doesn't exists yet.
- (modtime (or (nth 5 attr) '(-1 65535))))
- (when (boundp 'last-coding-system-used)
- (setq coding-system-used (symbol-value 'last-coding-system-used)))
- ;; We use '(0 0) as a don't-know value. See also
- ;; `tramp-do-file-attributes-with-ls'.
- (if (not (equal modtime '(0 0)))
- (tramp-run-real-handler 'set-visited-file-modtime (list modtime))
- (progn
- (tramp-send-command
- v
- (format "%s -ild %s"
- (tramp-get-ls-command v)
- (tramp-shell-quote-argument localname)))
- (setq attr (buffer-substring (point)
- (progn (end-of-line) (point)))))
- (tramp-set-file-property
- v localname "visited-file-modtime-ild" attr))
- (when (boundp 'last-coding-system-used)
- (set 'last-coding-system-used coding-system-used))
- nil)))))
-
-;; This function makes the same assumption as
-;; `tramp-handle-set-visited-file-modtime'.
-(defun tramp-handle-verify-visited-file-modtime (buf)
- "Like `verify-visited-file-modtime' for Tramp files.
-At the time `verify-visited-file-modtime' calls this function, we
-already know that the buffer is visiting a file and that
-`visited-file-modtime' does not return 0. Do not call this
-function directly, unless those two cases are already taken care
-of."
- (with-current-buffer buf
- (let ((f (buffer-file-name)))
- ;; There is no file visiting the buffer, or the buffer has no
- ;; recorded last modification time, or there is no established
- ;; connection.
- (if (or (not f)
- (eq (visited-file-modtime) 0)
- (not (tramp-file-name-handler 'file-remote-p f nil 'connected)))
- t
- (with-parsed-tramp-file-name f nil
- (tramp-flush-file-property v localname)
- (let* ((attr (file-attributes f))
- (modtime (nth 5 attr))
- (mt (visited-file-modtime)))
-
- (cond
- ;; File exists, and has a known modtime.
- ((and attr (not (equal modtime '(0 0))))
- (< (abs (tramp-time-diff
- modtime
- ;; For compatibility, deal with both the old
- ;; (HIGH . LOW) and the new (HIGH LOW) return
- ;; values of `visited-file-modtime'.
- (if (atom (cdr mt))
- (list (car mt) (cdr mt))
- mt)))
- 2))
- ;; Modtime has the don't know value.
- (attr
- (tramp-send-command
- v
- (format "%s -ild %s"
- (tramp-get-ls-command v)
- (tramp-shell-quote-argument localname)))
- (with-current-buffer (tramp-get-buffer v)
- (setq attr (buffer-substring
- (point) (progn (end-of-line) (point)))))
- (equal
- attr
- (tramp-get-file-property
- v localname "visited-file-modtime-ild" "")))
- ;; If file does not exist, say it is not modified if and
- ;; only if that agrees with the buffer's record.
- (t (equal mt '(-1 65535))))))))))
-
-(defun tramp-handle-set-file-modes (filename mode)
- "Like `set-file-modes' for Tramp files."
- (with-parsed-tramp-file-name filename nil
- (tramp-flush-file-property v localname)
- (unless (zerop (tramp-send-command-and-check
- v
- (format "chmod %s %s"
- (tramp-decimal-to-octal mode)
- (tramp-shell-quote-argument localname))))
- ;; FIXME: extract the proper text from chmod's stderr.
- (tramp-error
- v 'file-error "Error while changing file's mode %s" filename))))
-
-(defun tramp-handle-set-file-times (filename &optional time)
- "Like `set-file-times' for Tramp files."
- (zerop
- (if (file-remote-p filename)
- (with-parsed-tramp-file-name filename nil
- (tramp-flush-file-property v localname)
- (let ((time (if (or (null time) (equal time '(0 0)))
- (current-time)
- time))
- ;; With GNU Emacs, `format-time-string' has an optional
- ;; parameter UNIVERSAL. This is preferred, because we
- ;; could handle the case when the remote host is
- ;; located in a different time zone as the local host.
- (utc (not (featurep 'xemacs))))
- (tramp-send-command-and-check
- v (format "%s touch -t %s %s"
- (if utc "TZ=UTC; export TZ;" "")
- (if utc
- (format-time-string "%Y%m%d%H%M.%S" time t)
- (format-time-string "%Y%m%d%H%M.%S" time))
- (tramp-shell-quote-argument localname)))))
-
- ;; We handle also the local part, because in older Emacsen,
- ;; without `set-file-times', this function is an alias for this.
- ;; We are local, so we don't need the UTC settings.
- (tramp-local-call-process
- "touch" nil nil nil "-t"
- (format-time-string "%Y%m%d%H%M.%S" time)
- (tramp-shell-quote-argument filename)))))
-
-(defun tramp-set-file-uid-gid (filename &optional uid gid)
- "Set the ownership for FILENAME.
-If UID and GID are provided, these values are used; otherwise uid
-and gid of the corresponding user is taken. Both parameters must be integers."
- ;; Modern Unices allow chown only for root. So we might need
- ;; another implementation, see `dired-do-chown'. OTOH, it is mostly
- ;; working with su(do)? when it is needed, so it shall succeed in
- ;; the majority of cases.
- ;; Don't modify `last-coding-system-used' by accident.
- (let ((last-coding-system-used last-coding-system-used))
- (if (file-remote-p filename)
- (with-parsed-tramp-file-name filename nil
- (if (and (zerop (user-uid)) (tramp-local-host-p v))
- ;; If we are root on the local host, we can do it directly.
- (tramp-set-file-uid-gid localname uid gid)
- (let ((uid (or (and (integerp uid) uid)
- (tramp-get-remote-uid v 'integer)))
- (gid (or (and (integerp gid) gid)
- (tramp-get-remote-gid v 'integer))))
- (tramp-send-command
- v (format
- "chown %d:%d %s" uid gid
- (tramp-shell-quote-argument localname))))))
-
- ;; We handle also the local part, because there doesn't exist
- ;; `set-file-uid-gid'. On W32 "chown" might not work.
- (let ((uid (or (and (integerp uid) uid) (tramp-get-local-uid 'integer)))
- (gid (or (and (integerp gid) gid) (tramp-get-local-gid 'integer))))
- (tramp-local-call-process
- "chown" nil nil nil
- (format "%d:%d" uid gid) (tramp-shell-quote-argument filename))))))
-
-(defun tramp-remote-selinux-p (vec)
- "Check, whether SELINUX is enabled on the remote host."
- (with-connection-property (tramp-get-connection-process vec) "selinux-p"
- (let ((result (tramp-find-executable
- vec "getenforce" (tramp-get-remote-path vec) t t)))
- (and result
- (string-equal
- (tramp-send-command-and-read
- vec (format "echo \\\"`%S`\\\"" result))
- "Enforcing")))))
-
-(defun tramp-handle-file-selinux-context (filename)
- "Like `file-selinux-context' for Tramp files."
- (with-parsed-tramp-file-name filename nil
- (with-file-property v localname "file-selinux-context"
- (let ((context '(nil nil nil nil))
- (regexp (concat "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\):"
- "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\)")))
- (when (and (tramp-remote-selinux-p v)
- (zerop (tramp-send-command-and-check
- v (format
- "%s -d -Z %s"
- (tramp-get-ls-command v)
- (tramp-shell-quote-argument localname)))))
- (with-current-buffer (tramp-get-connection-buffer v)
- (goto-char (point-min))
- (when (re-search-forward regexp (tramp-compat-line-end-position) t)
- (setq context (list (match-string 1) (match-string 2)
- (match-string 3) (match-string 4))))))
- ;; Return the context.
- context))))
-
-(defun tramp-handle-set-file-selinux-context (filename context)
- "Like `set-file-selinux-context' for Tramp files."
- (with-parsed-tramp-file-name filename nil
- (if (and (consp context)
- (tramp-remote-selinux-p v)
- (zerop (tramp-send-command-and-check
- v (format "chcon %s %s %s %s %s"
- (if (stringp (nth 0 context))
- (format "--user=%s" (nth 0 context)) "")
- (if (stringp (nth 1 context))
- (format "--role=%s" (nth 1 context)) "")
- (if (stringp (nth 2 context))
- (format "--type=%s" (nth 2 context)) "")
- (if (stringp (nth 3 context))
- (format "--range=%s" (nth 3 context)) "")
- (tramp-shell-quote-argument localname)))))
- (tramp-set-file-property v localname "file-selinux-context" context)
- (tramp-set-file-property v localname "file-selinux-context" 'undef)))
- ;; We always return nil.
- nil)
-
-;; Simple functions using the `test' command.
-
-(defun tramp-handle-file-executable-p (filename)
- "Like `file-executable-p' for Tramp files."
- (with-parsed-tramp-file-name filename nil
- (with-file-property v localname "file-executable-p"
- ;; Examine `file-attributes' cache to see if request can be
- ;; satisfied without remote operation.
- (or (tramp-check-cached-permissions v ?x)
- (zerop (tramp-run-test "-x" filename))))))
-
-(defun tramp-handle-file-readable-p (filename)
- "Like `file-readable-p' for Tramp files."
- (with-parsed-tramp-file-name filename nil
- (with-file-property v localname "file-readable-p"
- ;; Examine `file-attributes' cache to see if request can be
- ;; satisfied without remote operation.
- (or (tramp-check-cached-permissions v ?r)
- (zerop (tramp-run-test "-r" filename))))))
-
-;; When the remote shell is started, it looks for a shell which groks
-;; tilde expansion. Here, we assume that all shells which grok tilde
-;; expansion will also provide a `test' command which groks `-nt' (for
-;; newer than). If this breaks, tell me about it and I'll try to do
-;; something smarter about it.
-(defun tramp-handle-file-newer-than-file-p (file1 file2)
- "Like `file-newer-than-file-p' for Tramp files."
- (cond ((not (file-exists-p file1))
- nil)
- ((not (file-exists-p file2))
- t)
- ;; We are sure both files exist at this point.
- (t
- (save-excursion
- ;; We try to get the mtime of both files. If they are not
- ;; equal to the "dont-know" value, then we subtract the times
- ;; and obtain the result.
- (let ((fa1 (file-attributes file1))
- (fa2 (file-attributes file2)))
- (if (and (not (equal (nth 5 fa1) '(0 0)))
- (not (equal (nth 5 fa2) '(0 0))))
- (> 0 (tramp-time-diff (nth 5 fa2) (nth 5 fa1)))
- ;; If one of them is the dont-know value, then we can
- ;; still try to run a shell command on the remote host.
- ;; However, this only works if both files are Tramp
- ;; files and both have the same method, same user, same
- ;; host.
- (unless (tramp-equal-remote file1 file2)
- (with-parsed-tramp-file-name
- (if (tramp-tramp-file-p file1) file1 file2) nil
- (tramp-error
- v 'file-error
- "Files %s and %s must have same method, user, host"
- file1 file2)))
- (with-parsed-tramp-file-name file1 nil
- (zerop (tramp-run-test2
- (tramp-get-test-nt-command v) file1 file2)))))))))
-
-;; Functions implemented using the basic functions above.
-
-(defun tramp-handle-file-modes (filename)
- "Like `file-modes' for Tramp files."
- (let ((truename (or (file-truename filename) filename)))
- (when (file-exists-p truename)
- (tramp-mode-string-to-int (nth 8 (file-attributes truename))))))
-
(defun tramp-default-file-modes (filename)
"Return file modes of FILENAME as integer.
If the file modes of FILENAME cannot be determined, return the
value of `default-file-modes', without execute permissions."
(or (file-modes filename)
- (logand (default-file-modes) (tramp-octal-to-decimal "0666"))))
-
-(defun tramp-handle-file-directory-p (filename)
- "Like `file-directory-p' for Tramp files."
- ;; Care must be taken that this function returns `t' for symlinks
- ;; pointing to directories. Surely the most obvious implementation
- ;; would be `test -d', but that returns false for such symlinks.
- ;; CCC: Stefan Monnier says that `test -d' follows symlinks. And
- ;; I now think he's right. So we could be using `test -d', couldn't
- ;; we?
- ;;
- ;; Alternatives: `cd %s', `test -d %s'
- (with-parsed-tramp-file-name filename nil
- (with-file-property v localname "file-directory-p"
- (zerop (tramp-run-test "-d" filename)))))
-
-(defun tramp-handle-file-regular-p (filename)
- "Like `file-regular-p' for Tramp files."
- (and (file-exists-p filename)
- (eq ?- (aref (nth 8 (file-attributes filename)) 0))))
-
-(defun tramp-handle-file-symlink-p (filename)
- "Like `file-symlink-p' for Tramp files."
- (with-parsed-tramp-file-name filename nil
- (let ((x (car (file-attributes filename))))
- (when (stringp x)
- ;; When Tramp is running on VMS, then `file-name-absolute-p'
- ;; might do weird things.
- (if (file-name-absolute-p x)
- (tramp-make-tramp-file-name method user host x)
- x)))))
-
-(defun tramp-handle-file-writable-p (filename)
- "Like `file-writable-p' for Tramp files."
- (with-parsed-tramp-file-name filename nil
- (with-file-property v localname "file-writable-p"
- (if (file-exists-p filename)
- ;; Examine `file-attributes' cache to see if request can be
- ;; satisfied without remote operation.
- (or (tramp-check-cached-permissions v ?w)
- (zerop (tramp-run-test "-w" filename)))
- ;; If file doesn't exist, check if directory is writable.
- (and (zerop (tramp-run-test
- "-d" (file-name-directory filename)))
- (zerop (tramp-run-test
- "-w" (file-name-directory filename))))))))
-
-(defun tramp-handle-file-ownership-preserved-p (filename)
- "Like `file-ownership-preserved-p' for Tramp files."
- (with-parsed-tramp-file-name filename nil
- (with-file-property v localname "file-ownership-preserved-p"
- (let ((attributes (file-attributes filename)))
- ;; Return t if the file doesn't exist, since it's true that no
- ;; information would be lost by an (attempted) delete and create.
- (or (null attributes)
- (= (nth 2 attributes) (tramp-get-remote-uid v 'integer)))))))
-
-;; Other file name ops.
-
-(defun tramp-handle-directory-file-name (directory)
- "Like `directory-file-name' for Tramp files."
- ;; If localname component of filename is "/", leave it unchanged.
- ;; Otherwise, remove any trailing slash from localname component.
- ;; Method, host, etc, are unchanged. Does it make sense to try
- ;; to avoid parsing the filename?
- (with-parsed-tramp-file-name directory nil
- (if (and (not (zerop (length localname)))
- (eq (aref localname (1- (length localname))) ?/)
- (not (string= localname "/")))
- (substring directory 0 -1)
- directory)))
-
-;; Directory listings.
-
-(defun tramp-handle-directory-files
- (directory &optional full match nosort files-only)
- "Like `directory-files' for Tramp files."
- ;; FILES-ONLY is valid for XEmacs only.
- (when (file-directory-p directory)
- (setq directory (file-name-as-directory (expand-file-name directory)))
- (let ((temp (nreverse (file-name-all-completions "" directory)))
- result item)
-
- (while temp
- (setq item (directory-file-name (pop temp)))
- (when (and (or (null match) (string-match match item))
- (or (null files-only)
- ;; Files only.
- (and (equal files-only t) (file-regular-p item))
- ;; Directories only.
- (file-directory-p item)))
- (push (if full (concat directory item) item)
- result)))
- (if nosort result (sort result 'string<)))))
-
-(defun tramp-handle-directory-files-and-attributes
- (directory &optional full match nosort id-format)
- "Like `directory-files-and-attributes' for Tramp files."
- (unless id-format (setq id-format 'integer))
- (when (file-directory-p directory)
- (setq directory (expand-file-name directory))
- (let* ((temp
- (copy-tree
- (with-parsed-tramp-file-name directory nil
- (with-file-property
- v localname
- (format "directory-files-and-attributes-%s" id-format)
- (save-excursion
- (mapcar
- (lambda (x)
- (cons (car x)
- (tramp-convert-file-attributes v (cdr x))))
- (cond
- ((tramp-get-remote-stat v)
- (tramp-do-directory-files-and-attributes-with-stat
- v localname id-format))
- ((tramp-get-remote-perl v)
- (tramp-do-directory-files-and-attributes-with-perl
- v localname id-format)))))))))
- result item)
-
- (while temp
- (setq item (pop temp))
- (when (or (null match) (string-match match (car item)))
- (when full
- (setcar item (expand-file-name (car item) directory)))
- (push item result)))
-
- (if nosort
- result
- (sort result (lambda (x y) (string< (car x) (car y))))))))
-
-(defun tramp-do-directory-files-and-attributes-with-perl
- (vec localname &optional id-format)
- "Implement `directory-files-and-attributes' for Tramp files using a Perl script."
- (tramp-message vec 5 "directory-files-and-attributes with perl: %s" localname)
- (tramp-maybe-send-script
- vec tramp-perl-directory-files-and-attributes
- "tramp_perl_directory_files_and_attributes")
- (let ((object
- (tramp-send-command-and-read
- vec
- (format "tramp_perl_directory_files_and_attributes %s %s"
- (tramp-shell-quote-argument localname) id-format))))
- (when (stringp object) (tramp-error vec 'file-error object))
- object))
-
-(defun tramp-do-directory-files-and-attributes-with-stat
- (vec localname &optional id-format)
- "Implement `directory-files-and-attributes' for Tramp files using stat(1) command."
- (tramp-message vec 5 "directory-files-and-attributes with stat: %s" localname)
- (tramp-send-command-and-read
- vec
- (format
- (concat
- ;; We must care about filenames with spaces, or starting with
- ;; "-"; this would confuse xargs. "ls -aQ" might be a solution,
- ;; but it does not work on all remote systems. Therefore, we
- ;; quote the filenames via sed.
- "cd %s; echo \"(\"; (%s -a | sed -e s/\\$/\\\"/g -e s/^/\\\"/g | xargs "
- "%s -c '(\"%%n\" (\"%%N\") %%h %s %s %%Xe0 %%Ye0 %%Ze0 %%se0 \"%%A\" t %%ie0 -1)'); "
- "echo \")\"")
- (tramp-shell-quote-argument localname)
- (tramp-get-ls-command vec)
- (tramp-get-remote-stat vec)
- (if (eq id-format 'integer) "%u" "\"%U\"")
- (if (eq id-format 'integer) "%g" "\"%G\""))))
-
-;; This function should return "foo/" for directories and "bar" for
-;; files.
-(defun tramp-handle-file-name-all-completions (filename directory)
- "Like `file-name-all-completions' for Tramp files."
- (unless (save-match-data (string-match "/" filename))
- (with-parsed-tramp-file-name (expand-file-name directory) nil
-
- (all-completions
- filename
- (mapcar
- 'list
- (or
- ;; Try cache first
- (and
- ;; Ignore if expired
- (or (not (integerp tramp-completion-reread-directory-timeout))
- (<= (tramp-time-diff
- (current-time)
- (tramp-get-file-property
- v localname "last-completion" '(0 0 0)))
- tramp-completion-reread-directory-timeout))
-
- ;; Try cache entries for filename, filename with last
- ;; character removed, filename with last two characters
- ;; removed, ..., and finally the empty string - all
- ;; concatenated to the local directory name
-
- ;; This is inefficient for very long filenames, pity
- ;; `reduce' is not available...
- (car
- (apply
- 'append
- (mapcar
- (lambda (x)
- (let ((cache-hit
- (tramp-get-file-property
- v
- (concat localname (substring filename 0 x))
- "file-name-all-completions"
- nil)))
- (when cache-hit (list cache-hit))))
- (tramp-compat-number-sequence (length filename) 0 -1)))))
-
- ;; Cache expired or no matching cache entry found so we need
- ;; to perform a remote operation
- (let (result)
- ;; Get a list of directories and files, including reliably
- ;; tagging the directories with a trailing '/'. Because I
- ;; rock. --daniel@danann.net
-
- ;; Changed to perform `cd' in the same remote op and only
- ;; get entries starting with `filename'. Capture any `cd'
- ;; error messages. Ensure any `cd' and `echo' aliases are
- ;; ignored.
- (tramp-send-command
- v
- (if (tramp-get-remote-perl v)
- (progn
- (tramp-maybe-send-script
- v tramp-perl-file-name-all-completions
- "tramp_perl_file_name_all_completions")
- (format "tramp_perl_file_name_all_completions %s %s %d"
- (tramp-shell-quote-argument localname)
- (tramp-shell-quote-argument filename)
- (if (symbol-value
- ;; `read-file-name-completion-ignore-case'
- ;; is introduced with Emacs 22.1.
- (if (boundp
- 'read-file-name-completion-ignore-case)
- 'read-file-name-completion-ignore-case
- 'completion-ignore-case))
- 1 0)))
-
- (format (concat
- "(\\cd %s 2>&1 && (%s %s -a 2>/dev/null"
- ;; `ls' with wildcard might fail with `Argument
- ;; list too long' error in some corner cases; if
- ;; `ls' fails after `cd' succeeded, chances are
- ;; that's the case, so let's retry without
- ;; wildcard. This will return "too many" entries
- ;; but that isn't harmful.
- " || %s -a 2>/dev/null)"
- " | while read f; do"
- " if %s -d \"$f\" 2>/dev/null;"
- " then \\echo \"$f/\"; else \\echo \"$f\"; fi; done"
- " && \\echo ok) || \\echo fail")
- (tramp-shell-quote-argument localname)
- (tramp-get-ls-command v)
- ;; When `filename' is empty, just `ls' without
- ;; filename argument is more efficient than `ls *'
- ;; for very large directories and might avoid the
- ;; `Argument list too long' error.
- ;;
- ;; With and only with wildcard, we need to add
- ;; `-d' to prevent `ls' from descending into
- ;; sub-directories.
- (if (zerop (length filename))
- "."
- (concat (tramp-shell-quote-argument filename) "* -d"))
- (tramp-get-ls-command v)
- (tramp-get-test-command v))))
-
- ;; Now grab the output.
- (with-current-buffer (tramp-get-buffer v)
- (goto-char (point-max))
-
- ;; Check result code, found in last line of output
- (forward-line -1)
- (if (looking-at "^fail$")
- (progn
- ;; Grab error message from line before last line
- ;; (it was put there by `cd 2>&1')
- (forward-line -1)
- (tramp-error
- v 'file-error
- "tramp-handle-file-name-all-completions: %s"
- (buffer-substring
- (point) (tramp-compat-line-end-position))))
- ;; For peace of mind, if buffer doesn't end in `fail'
- ;; then it should end in `ok'. If neither are in the
- ;; buffer something went seriously wrong on the remote
- ;; side.
- (unless (looking-at "^ok$")
- (tramp-error
- v 'file-error
- "\
-tramp-handle-file-name-all-completions: internal error accessing `%s': `%s'"
- (tramp-shell-quote-argument localname) (buffer-string))))
-
- (while (zerop (forward-line -1))
- (push (buffer-substring
- (point) (tramp-compat-line-end-position))
- result)))
-
- ;; Because the remote op went through OK we know the
- ;; directory we `cd'-ed to exists
- (tramp-set-file-property
- v localname "file-exists-p" t)
-
- ;; Because the remote op went through OK we know every
- ;; file listed by `ls' exists.
- (mapc (lambda (entry)
- (tramp-set-file-property
- v (concat localname entry) "file-exists-p" t))
- result)
-
- (tramp-set-file-property
- v localname "last-completion" (current-time))
-
- ;; Store result in the cache
- (tramp-set-file-property
- v (concat localname filename)
- "file-name-all-completions"
- result))))))))
-
-(defun tramp-handle-file-name-completion
- (filename directory &optional predicate)
- "Like `file-name-completion' for Tramp files."
- (unless (tramp-tramp-file-p directory)
- (error
- "tramp-handle-file-name-completion invoked on non-tramp directory `%s'"
- directory))
- (try-completion
- filename
- (mapcar 'list (file-name-all-completions filename directory))
- (when predicate
- (lambda (x) (funcall predicate (expand-file-name (car x) directory))))))
-
-;; cp, mv and ln
-
-(defun tramp-handle-add-name-to-file
- (filename newname &optional ok-if-already-exists)
- "Like `add-name-to-file' for Tramp files."
- (unless (tramp-equal-remote filename newname)
- (with-parsed-tramp-file-name
- (if (tramp-tramp-file-p filename) filename newname) nil
- (tramp-error
- v 'file-error
- "add-name-to-file: %s"
- "only implemented for same method, same user, same host")))
- (with-parsed-tramp-file-name filename v1
- (with-parsed-tramp-file-name newname v2
- (let ((ln (when v1 (tramp-get-remote-ln v1))))
- (when (and (not ok-if-already-exists)
- (file-exists-p newname)
- (not (numberp ok-if-already-exists))
- (y-or-n-p
- (format
- "File %s already exists; make it a new name anyway? "
- newname)))
- (tramp-error
- v2 'file-error
- "add-name-to-file: file %s already exists" newname))
- (tramp-flush-file-property v2 (file-name-directory v2-localname))
- (tramp-flush-file-property v2 v2-localname)
- (tramp-barf-unless-okay
- v1
- (format "%s %s %s" ln (tramp-shell-quote-argument v1-localname)
- (tramp-shell-quote-argument v2-localname))
- "error with add-name-to-file, see buffer `%s' for details"
- (buffer-name))))))
-
-(defun tramp-handle-copy-file
- (filename newname &optional ok-if-already-exists keep-date
- preserve-uid-gid preserve-selinux-context)
- "Like `copy-file' for Tramp files."
- (setq filename (expand-file-name filename))
- (setq newname (expand-file-name newname))
- (cond
- ;; At least one file a Tramp file?
- ((or (tramp-tramp-file-p filename)
- (tramp-tramp-file-p newname))
- (tramp-do-copy-or-rename-file
- 'copy filename newname ok-if-already-exists keep-date
- preserve-uid-gid preserve-selinux-context))
- ;; Compat section.
- (preserve-selinux-context
- (tramp-run-real-handler
- 'copy-file
- (list filename newname ok-if-already-exists keep-date
- preserve-uid-gid preserve-selinux-context)))
- (preserve-uid-gid
- (tramp-run-real-handler
- 'copy-file
- (list filename newname ok-if-already-exists keep-date preserve-uid-gid)))
- (t
- (tramp-run-real-handler
- 'copy-file (list filename newname ok-if-already-exists keep-date)))))
-
-(defun tramp-handle-copy-directory (dirname newname &optional keep-date parents)
- "Like `copy-directory' for Tramp files."
- (let ((t1 (tramp-tramp-file-p dirname))
- (t2 (tramp-tramp-file-p newname)))
- (with-parsed-tramp-file-name (if t1 dirname newname) nil
- (if (and (tramp-get-method-parameter method 'tramp-copy-recursive)
- ;; When DIRNAME and NEWNAME are remote, they must have
- ;; the same method.
- (or (null t1) (null t2)
- (string-equal
- (tramp-file-name-method (tramp-dissect-file-name dirname))
- (tramp-file-name-method (tramp-dissect-file-name newname)))))
- ;; scp or rsync DTRT.
- (progn
- (setq dirname (directory-file-name (expand-file-name dirname))
- newname (directory-file-name (expand-file-name newname)))
- (if (and (file-directory-p newname)
- (not (string-equal (file-name-nondirectory dirname)
- (file-name-nondirectory newname))))
- (setq newname
- (expand-file-name
- (file-name-nondirectory dirname) newname)))
- (if (not (file-directory-p (file-name-directory newname)))
- (make-directory (file-name-directory newname) parents))
- (tramp-do-copy-or-rename-file-out-of-band
- 'copy dirname newname keep-date))
- ;; We must do it file-wise.
- (tramp-run-real-handler
- 'copy-directory (list dirname newname keep-date parents)))
-
- ;; When newname did exist, we have wrong cached values.
- (when t2
- (with-parsed-tramp-file-name newname nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname))))))
-
-(defun tramp-handle-rename-file
- (filename newname &optional ok-if-already-exists)
- "Like `rename-file' for Tramp files."
- ;; Check if both files are local -- invoke normal rename-file.
- ;; Otherwise, use Tramp from local system.
- (setq filename (expand-file-name filename))
- (setq newname (expand-file-name newname))
- ;; At least one file a Tramp file?
- (if (or (tramp-tramp-file-p filename)
- (tramp-tramp-file-p newname))
- (tramp-do-copy-or-rename-file
- 'rename filename newname ok-if-already-exists t t)
- (tramp-run-real-handler
- 'rename-file (list filename newname ok-if-already-exists))))
-
-(defun tramp-do-copy-or-rename-file
- (op filename newname &optional ok-if-already-exists keep-date
- preserve-uid-gid preserve-selinux-context)
- "Copy or rename a remote file.
-OP must be `copy' or `rename' and indicates the operation to perform.
-FILENAME specifies the file to copy or rename, NEWNAME is the name of
-the new file (for copy) or the new name of the file (for rename).
-OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already.
-KEEP-DATE means to make sure that NEWNAME has the same timestamp
-as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep
-the uid and gid if both files are on the same host.
-PRESERVE-SELINUX-CONTEXT activates selinux commands.
-
-This function is invoked by `tramp-handle-copy-file' and
-`tramp-handle-rename-file'. It is an error if OP is neither of `copy'
-and `rename'. FILENAME and NEWNAME must be absolute file names."
- (unless (memq op '(copy rename))
- (error "Unknown operation `%s', must be `copy' or `rename'" op))
- (let ((t1 (tramp-tramp-file-p filename))
- (t2 (tramp-tramp-file-p newname))
- (context (and preserve-selinux-context
- (apply 'file-selinux-context (list filename))))
- pr tm)
-
- (with-parsed-tramp-file-name (if t1 filename newname) nil
- (when (and (not ok-if-already-exists) (file-exists-p newname))
- (tramp-error
- v 'file-already-exists "File %s already exists" newname))
-
- (with-progress-reporter
- v 0 (format "%s %s to %s"
- (if (eq op 'copy) "Copying" "Renaming")
- filename newname)
-
- (cond
- ;; Both are Tramp files.
- ((and t1 t2)
- (with-parsed-tramp-file-name filename v1
- (with-parsed-tramp-file-name newname v2
- (cond
- ;; Shortcut: if method, host, user are the same for
- ;; both files, we invoke `cp' or `mv' on the remote
- ;; host directly.
- ((tramp-equal-remote filename newname)
- (tramp-do-copy-or-rename-file-directly
- op filename newname
- ok-if-already-exists keep-date preserve-uid-gid))
-
- ;; Try out-of-band operation.
- ((tramp-method-out-of-band-p
- v1 (nth 7 (file-attributes filename)))
- (tramp-do-copy-or-rename-file-out-of-band
- op filename newname keep-date))
-
- ;; No shortcut was possible. So we copy the file
- ;; first. If the operation was `rename', we go back
- ;; and delete the original file (if the copy was
- ;; successful). The approach is simple-minded: we
- ;; create a new buffer, insert the contents of the
- ;; source file into it, then write out the buffer to
- ;; the target file. The advantage is that it doesn't
- ;; matter which filename handlers are used for the
- ;; source and target file.
- (t
- (tramp-do-copy-or-rename-file-via-buffer
- op filename newname keep-date))))))
-
- ;; One file is a Tramp file, the other one is local.
- ((or t1 t2)
- (cond
- ;; Fast track on local machine.
- ((tramp-local-host-p v)
- (tramp-do-copy-or-rename-file-directly
- op filename newname
- ok-if-already-exists keep-date preserve-uid-gid))
-
- ;; If the Tramp file has an out-of-band method, the
- ;; corresponding copy-program can be invoked.
- ((tramp-method-out-of-band-p v (nth 7 (file-attributes filename)))
- (tramp-do-copy-or-rename-file-out-of-band
- op filename newname keep-date))
-
- ;; Use the inline method via a Tramp buffer.
- (t (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")))
-
- ;; Handle `preserve-selinux-context'.
- (when context (apply 'set-file-selinux-context (list newname context)))
-
- ;; In case of `rename', we must flush the cache of the source file.
- (when (and t1 (eq op 'rename))
- (with-parsed-tramp-file-name filename v1
- (tramp-flush-file-property v1 (file-name-directory localname))
- (tramp-flush-file-property v1 localname)))
-
- ;; When newname did exist, we have wrong cached values.
- (when t2
- (with-parsed-tramp-file-name newname v2
- (tramp-flush-file-property v2 (file-name-directory localname))
- (tramp-flush-file-property v2 localname)))))))
-
-(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.
-KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME."
- (with-temp-buffer
- ;; We must disable multibyte, because binary data shall not be
- ;; converted.
- (set-buffer-multibyte nil)
- (let ((coding-system-for-read 'binary)
- (jka-compr-inhibit t))
- (insert-file-contents-literally filename))
- ;; We don't want the target file to be compressed, so we let-bind
- ;; `jka-compr-inhibit' to t.
- (let ((coding-system-for-write 'binary)
- (jka-compr-inhibit t))
- (write-region (point-min) (point-max) newname)))
- ;; KEEP-DATE handling.
- (when keep-date (set-file-times newname (nth 5 (file-attributes filename))))
- ;; Set the mode.
- (set-file-modes newname (tramp-default-file-modes filename))
- ;; If the operation was `rename', delete the original file.
- (unless (eq op 'copy) (delete-file filename)))
-
-(defun tramp-do-copy-or-rename-file-directly
- (op filename newname ok-if-already-exists keep-date preserve-uid-gid)
- "Invokes `cp' or `mv' on the remote system.
-OP must be one of `copy' or `rename', indicating `cp' or `mv',
-respectively. FILENAME specifies the file to copy or rename,
-NEWNAME is the name of the new file (for copy) or the new name of
-the file (for rename). Both files must reside on the same host.
-KEEP-DATE means to make sure that NEWNAME has the same timestamp
-as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep
-the uid and gid from FILENAME."
- (let ((t1 (tramp-tramp-file-p filename))
- (t2 (tramp-tramp-file-p newname))
- (file-times (nth 5 (file-attributes filename)))
- (file-modes (tramp-default-file-modes filename)))
- (with-parsed-tramp-file-name (if t1 filename newname) nil
- (let* ((cmd (cond ((and (eq op 'copy) preserve-uid-gid) "cp -f -p")
- ((eq op 'copy) "cp -f")
- ((eq op 'rename) "mv -f")
- (t (tramp-error
- v 'file-error
- "Unknown operation `%s', must be `copy' or `rename'"
- op))))
- (localname1
- (if t1
- (tramp-file-name-handler 'file-remote-p filename 'localname)
- filename))
- (localname2
- (if t2
- (tramp-file-name-handler 'file-remote-p newname 'localname)
- newname))
- (prefix (file-remote-p (if t1 filename newname)))
- cmd-result)
-
- (cond
- ;; Both files are on a remote host, with same user.
- ((and t1 t2)
- (setq cmd-result
- (tramp-send-command-and-check
- v
- (format "%s %s %s" cmd
- (tramp-shell-quote-argument localname1)
- (tramp-shell-quote-argument localname2))))
- (with-current-buffer (tramp-get-buffer v)
- (goto-char (point-min))
- (unless
- (or
- (and keep-date
- ;; Mask cp -f error.
- (re-search-forward
- tramp-operation-not-permitted-regexp nil t))
- (zerop cmd-result))
- (tramp-error-with-buffer
- nil v 'file-error
- "Copying directly failed, see buffer `%s' for details."
- (buffer-name)))))
-
- ;; We are on the local host.
- ((or t1 t2)
- (cond
- ;; We can do it directly.
- ((let (file-name-handler-alist)
- (and (file-readable-p localname1)
- (file-writable-p (file-name-directory localname2))
- (or (file-directory-p localname2)
- (file-writable-p localname2))))
- (if (eq op 'copy)
- (tramp-compat-copy-file
- localname1 localname2 ok-if-already-exists
- keep-date preserve-uid-gid)
- (tramp-run-real-handler
- 'rename-file (list localname1 localname2 ok-if-already-exists))))
-
- ;; We can do it directly with `tramp-send-command'
- ((and (file-readable-p (concat prefix localname1))
- (file-writable-p
- (file-name-directory (concat prefix localname2)))
- (or (file-directory-p (concat prefix localname2))
- (file-writable-p (concat prefix localname2))))
- (tramp-do-copy-or-rename-file-directly
- op (concat prefix localname1) (concat prefix localname2)
- ok-if-already-exists keep-date t)
- ;; We must change the ownership to the local user.
- (tramp-set-file-uid-gid
- (concat prefix localname2)
- (tramp-get-local-uid 'integer)
- (tramp-get-local-gid 'integer)))
-
- ;; We need a temporary file in between.
- (t
- ;; Create the temporary file.
- (let ((tmpfile (tramp-compat-make-temp-file localname1)))
- (unwind-protect
- (progn
- (cond
- (t1
- (or
- (zerop
- (tramp-send-command-and-check
- v (format
- "%s %s %s" cmd
- (tramp-shell-quote-argument localname1)
- (tramp-shell-quote-argument tmpfile))))
- (tramp-error-with-buffer
- nil v 'file-error
- "Copying directly failed, see buffer `%s' for details."
- (tramp-get-buffer v)))
- ;; We must change the ownership as remote user.
- ;; Since this does not work reliable, we also
- ;; give read permissions.
- (set-file-modes
- (concat prefix tmpfile) (tramp-octal-to-decimal "0777"))
- (tramp-set-file-uid-gid
- (concat prefix tmpfile)
- (tramp-get-local-uid 'integer)
- (tramp-get-local-gid 'integer)))
- (t2
- (if (eq op 'copy)
- (tramp-compat-copy-file
- localname1 tmpfile t
- keep-date preserve-uid-gid)
- (tramp-run-real-handler
- 'rename-file
- (list localname1 tmpfile t)))
- ;; We must change the ownership as local user.
- ;; Since this does not work reliable, we also
- ;; give read permissions.
- (set-file-modes tmpfile (tramp-octal-to-decimal "0777"))
- (tramp-set-file-uid-gid
- tmpfile
- (tramp-get-remote-uid v 'integer)
- (tramp-get-remote-gid v 'integer))))
-
- ;; Move the temporary file to its destination.
- (cond
- (t2
- (or
- (zerop
- (tramp-send-command-and-check
- v (format
- "cp -f -p %s %s"
- (tramp-shell-quote-argument tmpfile)
- (tramp-shell-quote-argument localname2))))
- (tramp-error-with-buffer
- nil v 'file-error
- "Copying directly failed, see buffer `%s' for details."
- (tramp-get-buffer v))))
- (t1
- (tramp-run-real-handler
- 'rename-file
- (list tmpfile localname2 ok-if-already-exists)))))
-
- ;; Save exit.
- (condition-case nil
- (delete-file tmpfile)
- (error)))))))))
-
- ;; Set the time and mode. Mask possible errors.
- (condition-case nil
- (when keep-date
- (set-file-times newname file-times)
- (set-file-modes newname file-modes))
- (error)))))
-
-(defun tramp-do-copy-or-rename-file-out-of-band (op filename newname keep-date)
- "Invoke rcp program to copy.
-The method used must be an out-of-band method."
- (let ((t1 (tramp-tramp-file-p filename))
- (t2 (tramp-tramp-file-p newname))
- copy-program copy-args copy-env copy-keep-date port spec
- source target)
-
- (with-parsed-tramp-file-name (if t1 filename newname) nil
- (if (and t1 t2)
-
- ;; Both are Tramp files. We shall optimize it, when the
- ;; methods for filename and newname are the same.
- (let* ((dir-flag (file-directory-p filename))
- (tmpfile (tramp-compat-make-temp-file localname dir-flag)))
- (if dir-flag
- (setq tmpfile
- (expand-file-name
- (file-name-nondirectory newname) tmpfile)))
- (unwind-protect
- (progn
- (tramp-do-copy-or-rename-file-out-of-band
- op filename tmpfile keep-date)
- (tramp-do-copy-or-rename-file-out-of-band
- 'rename tmpfile newname keep-date))
- ;; Save exit.
- (condition-case nil
- (if dir-flag
- (tramp-compat-delete-directory
- (expand-file-name ".." tmpfile) 'recursive)
- (delete-file tmpfile))
- (error))))
-
- ;; Expand hops. Might be necessary for gateway methods.
- (setq v (car (tramp-compute-multi-hops v)))
- (aset v 3 localname)
-
- ;; Check which ones of source and target are Tramp files.
- (setq source (if t1 (tramp-make-copy-program-file-name v) filename)
- target (funcall
- (if (and (file-directory-p filename)
- (string-equal
- (file-name-nondirectory filename)
- (file-name-nondirectory newname)))
- 'file-name-directory
- 'identity)
- (if t2 (tramp-make-copy-program-file-name v) newname)))
-
- ;; Check for port number. Until now, there's no need for handling
- ;; like method, user, host.
- (setq host (tramp-file-name-real-host v)
- port (tramp-file-name-port v)
- port (or (and port (number-to-string port)) ""))
-
- ;; Compose copy command.
- (setq spec (format-spec-make
- ?h host ?u user ?p port
- ?t (tramp-get-connection-property
- (tramp-get-connection-process v) "temp-file" "")
- ?k (if keep-date " " ""))
- copy-program (tramp-get-method-parameter
- method 'tramp-copy-program)
- copy-keep-date (tramp-get-method-parameter
- method 'tramp-copy-keep-date)
- copy-args
- (delq
- nil
- (mapcar
- (lambda (x)
- (setq
- x
- ;; " " is indication for keep-date argument.
- (delete " " (mapcar (lambda (y) (format-spec y spec)) x)))
- (unless (member "" x) (mapconcat 'identity x " ")))
- (tramp-get-method-parameter method 'tramp-copy-args)))
- copy-env
- (delq
- nil
- (mapcar
- (lambda (x)
- (setq x (mapcar (lambda (y) (format-spec y spec)) x))
- (unless (member "" x) (mapconcat 'identity x " ")))
- (tramp-get-method-parameter method 'tramp-copy-env))))
-
- ;; Check for program.
- (when (and (fboundp 'executable-find)
- (not (let ((default-directory
- (tramp-compat-temporary-file-directory)))
- (executable-find copy-program))))
- (tramp-error
- v 'file-error "Cannot find copy program: %s" copy-program))
-
- ;; Set variables for computing the prompt for reading
- ;; password.
- (setq tramp-current-method (tramp-file-name-method v)
- tramp-current-user (tramp-file-name-user v)
- tramp-current-host (tramp-file-name-host v))
-
- (unwind-protect
- (with-temp-buffer
- ;; The default directory must be remote.
- (let ((default-directory
- (file-name-directory (if t1 filename newname)))
- (process-environment (copy-sequence process-environment)))
- ;; Set the transfer process properties.
- (tramp-set-connection-property
- v "process-name" (buffer-name (current-buffer)))
- (tramp-set-connection-property
- v "process-buffer" (current-buffer))
- (while copy-env
- (tramp-message v 5 "%s=\"%s\"" (car copy-env) (cadr copy-env))
- (setenv (pop copy-env) (pop copy-env)))
-
- ;; Use an asynchronous process. By this, password can
- ;; be handled. The default directory must be local, in
- ;; order to apply the correct `copy-program'. We don't
- ;; set a timeout, because the copying of large files can
- ;; last longer than 60 secs.
- (let ((p (let ((default-directory
- (tramp-compat-temporary-file-directory)))
- (apply 'start-process
- (tramp-get-connection-property
- v "process-name" nil)
- (tramp-get-connection-property
- v "process-buffer" nil)
- copy-program
- (append copy-args (list source target))))))
- (tramp-message
- v 6 "%s" (mapconcat 'identity (process-command p) " "))
- (tramp-set-process-query-on-exit-flag p nil)
- (tramp-process-actions p v tramp-actions-copy-out-of-band))))
-
- ;; Reset the transfer process properties.
- (tramp-set-connection-property v "process-name" nil)
- (tramp-set-connection-property v "process-buffer" nil))
-
- ;; Handle KEEP-DATE argument.
- (when (and keep-date (not copy-keep-date))
- (set-file-times newname (nth 5 (file-attributes filename))))
-
- ;; Set the mode.
- (unless (and keep-date copy-keep-date)
- (ignore-errors
- (set-file-modes newname (tramp-default-file-modes filename)))))
-
- ;; If the operation was `rename', delete the original file.
- (unless (eq op 'copy)
- (if (file-regular-p filename)
- (delete-file filename)
- (tramp-compat-delete-directory filename 'recursive))))))
-
-(defun tramp-handle-make-directory (dir &optional parents)
- "Like `make-directory' for Tramp files."
- (setq dir (expand-file-name dir))
- (with-parsed-tramp-file-name dir nil
- (tramp-flush-directory-property v (file-name-directory localname))
- (save-excursion
- (tramp-barf-unless-okay
- v
- (format "%s %s"
- (if parents "mkdir -p" "mkdir")
- (tramp-shell-quote-argument localname))
- "Couldn't make directory %s" dir))))
-
-(defun tramp-handle-delete-directory (directory &optional recursive)
- "Like `delete-directory' for Tramp files."
- (setq directory (expand-file-name directory))
- (with-parsed-tramp-file-name directory nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-directory-property v localname)
- (unless (zerop (tramp-send-command-and-check
- v
- (format
- "%s %s"
- (if recursive "rm -rf" "rmdir")
- (tramp-shell-quote-argument localname))))
- (tramp-error v 'file-error "Couldn't delete %s" directory))))
-
-(defun tramp-handle-delete-file (filename &optional trash)
- "Like `delete-file' for Tramp files."
- (setq filename (expand-file-name filename))
- (with-parsed-tramp-file-name filename nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
- (unless
- (zerop
- (tramp-send-command-and-check
- v (format "%s %s"
- (or (and trash (tramp-get-remote-trash v)) "rm -f")
- (tramp-shell-quote-argument localname))))
- (tramp-error v 'file-error "Couldn't delete %s" filename))))
-
-;; Dired.
-
-;; CCC: This does not seem to be enough. Something dies when
-;; we try and delete two directories under Tramp :/
-(defun tramp-handle-dired-recursive-delete-directory (filename)
- "Recursively delete the directory given.
-This is like `dired-recursive-delete-directory' for Tramp files."
- (with-parsed-tramp-file-name filename nil
- ;; Run a shell command 'rm -r <localname>'
- ;; Code shamelessly stolen from the dired implementation and, um, hacked :)
- (unless (file-exists-p filename)
- (tramp-error v 'file-error "No such directory: %s" filename))
- ;; Which is better, -r or -R? (-r works for me <daniel@danann.net>)
- (tramp-send-command
- v
- (format "rm -rf %s" (tramp-shell-quote-argument localname))
- ;; Don't read the output, do it explicitely.
- nil t)
- ;; Wait for the remote system to return to us...
- ;; This might take a while, allow it plenty of time.
- (tramp-wait-for-output (tramp-get-connection-process v) 120)
- ;; Make sure that it worked...
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-directory-property v localname)
- (and (file-exists-p filename)
- (tramp-error
- v 'file-error "Failed to recursively delete %s" filename))))
-
-(defun tramp-handle-dired-compress-file (file &rest ok-flag)
- "Like `dired-compress-file' for Tramp files."
- ;; OK-FLAG is valid for XEmacs only, but not implemented.
- ;; Code stolen mainly from dired-aux.el.
- (with-parsed-tramp-file-name file nil
- (tramp-flush-file-property v localname)
- (save-excursion
- (let ((suffixes
- (if (not (featurep 'xemacs))
- ;; Emacs case
- (symbol-value 'dired-compress-file-suffixes)
- ;; XEmacs has `dired-compression-method-alist', which is
- ;; transformed into `dired-compress-file-suffixes' structure.
- (mapcar
- (lambda (x)
- (list (concat (regexp-quote (nth 1 x)) "\\'")
- nil
- (mapconcat 'identity (nth 3 x) " ")))
- (symbol-value 'dired-compression-method-alist))))
- suffix)
- ;; See if any suffix rule matches this file name.
- (while suffixes
- (let (case-fold-search)
- (if (string-match (car (car suffixes)) localname)
- (setq suffix (car suffixes) suffixes nil))
- (setq suffixes (cdr suffixes))))
-
- (cond ((file-symlink-p file)
- nil)
- ((and suffix (nth 2 suffix))
- ;; We found an uncompression rule.
- (with-progress-reporter v 0 (format "Uncompressing %s" file)
- (when (zerop
- (tramp-send-command-and-check
- v (concat (nth 2 suffix) " "
- (tramp-shell-quote-argument localname))))
- ;; `dired-remove-file' is not defined in XEmacs.
- (tramp-compat-funcall 'dired-remove-file file)
- (string-match (car suffix) file)
- (concat (substring file 0 (match-beginning 0))))))
- (t
- ;; We don't recognize the file as compressed, so compress it.
- ;; Try gzip.
- (with-progress-reporter v 0 (format "Compressing %s" file)
- (when (zerop
- (tramp-send-command-and-check
- v (concat "gzip -f "
- (tramp-shell-quote-argument localname))))
- ;; `dired-remove-file' is not defined in XEmacs.
- (tramp-compat-funcall 'dired-remove-file file)
- (cond ((file-exists-p (concat file ".gz"))
- (concat file ".gz"))
- ((file-exists-p (concat file ".z"))
- (concat file ".z"))
- (t nil))))))))))
-
-(defun tramp-handle-dired-uncache (dir &optional dir-p)
- "Like `dired-uncache' for Tramp files."
- ;; DIR-P is valid for XEmacs only.
- (with-parsed-tramp-file-name
- (if (or dir-p (file-directory-p dir)) dir (file-name-directory dir)) nil
- (tramp-flush-directory-property v localname)))
-
-;; Pacify byte-compiler. The function is needed on XEmacs only. I'm
-;; not sure at all that this is the right way to do it, but let's hope
-;; it works for now, and wait for a guru to point out the Right Way to
-;; achieve this.
-;;(eval-when-compile
-;; (unless (fboundp 'dired-insert-set-properties)
-;; (fset 'dired-insert-set-properties 'ignore)))
-;; Gerd suggests this:
-(eval-when-compile (require 'dired))
-;; Note that dired is required at run-time, too, when it is needed.
-;; It is only needed on XEmacs for the function
-;; `dired-insert-set-properties'.
-
-(defun tramp-handle-insert-directory
- (filename switches &optional wildcard full-directory-p)
- "Like `insert-directory' for Tramp files."
- (setq filename (expand-file-name filename))
- (with-parsed-tramp-file-name filename nil
- (if (and (featurep 'ls-lisp)
- (not (symbol-value 'ls-lisp-use-insert-directory-program)))
- (tramp-run-real-handler
- 'insert-directory (list filename switches wildcard full-directory-p))
- (when (stringp switches)
- (setq switches (split-string switches)))
- (when (and (member "--dired" switches)
- (not (tramp-get-ls-command-with-dired v)))
- (setq switches (delete "--dired" switches)))
- (when wildcard
- (setq wildcard (tramp-run-real-handler
- 'file-name-nondirectory (list localname)))
- (setq localname (tramp-run-real-handler
- 'file-name-directory (list localname))))
- (unless full-directory-p
- (setq switches (add-to-list 'switches "-d" 'append)))
- (setq switches (mapconcat 'tramp-shell-quote-argument switches " "))
- (when wildcard
- (setq switches (concat switches " " wildcard)))
- (tramp-message
- v 4 "Inserting directory `ls %s %s', wildcard %s, fulldir %s"
- switches filename (if wildcard "yes" "no")
- (if full-directory-p "yes" "no"))
- ;; If `full-directory-p', we just say `ls -l FILENAME'.
- ;; Else we chdir to the parent directory, then say `ls -ld BASENAME'.
- (if full-directory-p
- (tramp-send-command
- v
- (format "%s %s %s 2>/dev/null"
- (tramp-get-ls-command v)
- switches
- (if wildcard
- localname
- (tramp-shell-quote-argument (concat localname ".")))))
- (tramp-barf-unless-okay
- v
- (format "cd %s" (tramp-shell-quote-argument
- (tramp-run-real-handler
- 'file-name-directory (list localname))))
- "Couldn't `cd %s'"
- (tramp-shell-quote-argument
- (tramp-run-real-handler 'file-name-directory (list localname))))
- (tramp-send-command
- v
- (format "%s %s %s"
- (tramp-get-ls-command v)
- switches
- (if (or wildcard
- (zerop (length
- (tramp-run-real-handler
- 'file-name-nondirectory (list localname)))))
- ""
- (tramp-shell-quote-argument
- (tramp-run-real-handler
- 'file-name-nondirectory (list localname)))))))
- (let ((beg (point)))
- ;; We cannot use `insert-buffer-substring' because the Tramp
- ;; buffer changes its contents before insertion due to calling
- ;; `expand-file' and alike.
- (insert
- (with-current-buffer (tramp-get-buffer v)
- (buffer-string)))
-
- ;; Check for "--dired" output.
- (forward-line -2)
- (when (looking-at "//SUBDIRED//")
- (forward-line -1))
- (when (looking-at "//DIRED//\\s-+")
- (let ((databeg (match-end 0))
- (end (tramp-compat-line-end-position)))
- ;; Now read the numeric positions of file names.
- (goto-char databeg)
- (while (< (point) end)
- (let ((start (+ beg (read (current-buffer))))
- (end (+ beg (read (current-buffer)))))
- (if (memq (char-after end) '(?\n ?\ ))
- ;; End is followed by \n or by " -> ".
- (put-text-property start end 'dired-filename t))))))
- ;; Remove trailing lines.
- (goto-char (tramp-compat-line-beginning-position))
- (while (looking-at "//")
- (forward-line 1)
- (delete-region (match-beginning 0) (point)))
-
- ;; The inserted file could be from somewhere else.
- (when (and (not wildcard) (not full-directory-p))
- (goto-char (point-max))
- (when (file-symlink-p filename)
- (goto-char (search-backward "->" beg 'noerror)))
- (search-backward
- (if (zerop (length (file-name-nondirectory filename)))
- "."
- (file-name-nondirectory filename))
- beg 'noerror)
- (replace-match (file-relative-name filename) t))
-
- (goto-char (point-max))))))
-
-(defun tramp-handle-unhandled-file-name-directory (filename)
- "Like `unhandled-file-name-directory' for Tramp files."
- ;; With Emacs 23, we could simply return `nil'. But we must keep it
- ;; for backward compatibility.
- (expand-file-name "~/"))
-
-;; Canonicalization of file names.
-
-(defun tramp-handle-expand-file-name (name &optional dir)
- "Like `expand-file-name' for Tramp files.
-If the localname part of the given filename starts with \"/../\" then
-the result will be a local, non-Tramp, filename."
- ;; If DIR is not given, use DEFAULT-DIRECTORY or "/".
- (setq dir (or dir default-directory "/"))
- ;; Unless NAME is absolute, concat DIR and NAME.
- (unless (file-name-absolute-p name)
- (setq name (concat (file-name-as-directory dir) name)))
- ;; If NAME is not a Tramp file, run the real handler.
- (if (not (tramp-connectable-p name))
- (tramp-run-real-handler 'expand-file-name (list name nil))
- ;; Dissect NAME.
- (with-parsed-tramp-file-name name nil
- (unless (tramp-run-real-handler 'file-name-absolute-p (list localname))
- (setq localname (concat "~/" localname)))
- ;; Tilde expansion if necessary. This needs a shell which
- ;; groks tilde expansion! The function `tramp-find-shell' is
- ;; supposed to find such a shell on the remote host. Please
- ;; tell me about it when this doesn't work on your system.
- (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname)
- (let ((uname (match-string 1 localname))
- (fname (match-string 2 localname)))
- ;; We cannot simply apply "~/", because under sudo "~/" is
- ;; expanded to the local user home directory but to the
- ;; root home directory. On the other hand, using always
- ;; the default user name for tilde expansion is not
- ;; appropriate either, because ssh and companions might
- ;; use a user name from the config file.
- (when (and (string-equal uname "~")
- (string-match "\\`su\\(do\\)?\\'" method))
- (setq uname (concat uname user)))
- (setq uname
- (with-connection-property v uname
- (tramp-send-command
- v (format "cd %s; pwd" (tramp-shell-quote-argument uname)))
- (with-current-buffer (tramp-get-buffer v)
- (goto-char (point-min))
- (buffer-substring
- (point) (tramp-compat-line-end-position)))))
- (setq localname (concat uname fname))))
- ;; There might be a double slash, for example when "~/"
- ;; expands to "/". Remove this.
- (while (string-match "//" localname)
- (setq localname (replace-match "/" t t localname)))
- ;; No tilde characters in file name, do normal
- ;; `expand-file-name' (this does "/./" and "/../"). We bind
- ;; `directory-sep-char' here for XEmacs on Windows, which would
- ;; otherwise use backslash. `default-directory' is bound,
- ;; because on Windows there would be problems with UNC shares or
- ;; Cygwin mounts.
- (let ((directory-sep-char ?/)
- (default-directory (tramp-compat-temporary-file-directory)))
- (tramp-make-tramp-file-name
- method user host
- (tramp-drop-volume-letter
- (tramp-run-real-handler
- 'expand-file-name (list localname))))))))
+ (logand (default-file-modes) (tramp-compat-octal-to-decimal "0666"))))
(defun tramp-replace-environment-variables (filename)
"Replace environment variables in FILENAME.
@@ -4439,38 +1625,6 @@ Return the string with the replaced variables."
t nil filename)))
filename)))
-(defun tramp-handle-substitute-in-file-name (filename)
- "Like `substitute-in-file-name' for Tramp files.
-\"//\" and \"/~\" substitute only in the local filename part.
-If the URL Tramp syntax is chosen, \"//\" as method delimeter and \"/~\" at
-beginning of local filename are not substituted."
- ;; First, we must replace environment variables.
- (setq filename (tramp-replace-environment-variables filename))
- (with-parsed-tramp-file-name filename nil
- (if (equal tramp-syntax 'url)
- ;; We need to check localname only. The other parts cannot contain
- ;; "//" or "/~".
- (if (and (> (length localname) 1)
- (or (string-match "//" localname)
- (string-match "/~" localname 1)))
- (tramp-run-real-handler 'substitute-in-file-name (list filename))
- (tramp-make-tramp-file-name
- (when method (substitute-in-file-name method))
- (when user (substitute-in-file-name user))
- (when host (substitute-in-file-name host))
- (when localname
- (tramp-run-real-handler
- 'substitute-in-file-name (list localname)))))
- ;; Ignore in LOCALNAME everything before "//" or "/~".
- (when (and (stringp localname) (string-match ".+?/\\(/\\|~\\)" localname))
- (setq filename
- (concat (file-remote-p filename)
- (replace-match "\\1" nil nil localname)))
- ;; "/m:h:~" does not work for completion. We use "/m:h:~/".
- (when (string-match "~$" filename)
- (setq filename (concat filename "/"))))
- (tramp-run-real-handler 'substitute-in-file-name (list filename)))))
-
;; In XEmacs, electricity is implemented via a key map for ?/ and ?~,
;; which calls corresponding functions (see minibuf.el).
(when (fboundp 'minibuffer-electric-separator)
@@ -4500,406 +1654,6 @@ beginning of local filename are not substituted."
'(minibuffer-electric-separator
minibuffer-electric-tilde)))
-
-;;; Remote commands:
-
-(defun tramp-handle-executable-find (command)
- "Like `executable-find' for Tramp files."
- (with-parsed-tramp-file-name default-directory nil
- (tramp-find-executable v command (tramp-get-remote-path v) t)))
-
-(defun tramp-process-sentinel (proc event)
- "Flush file caches."
- (unless (memq (process-status proc) '(run open))
- (let ((vec (tramp-get-connection-property proc "vector" nil)))
- (when vec
- (tramp-message vec 5 "Sentinel called: `%s' `%s'" proc event)
- (tramp-flush-directory-property vec "")))))
-
-;; We use BUFFER also as connection buffer during setup. Because of
-;; this, its original contents must be saved, and restored once
-;; connection has been setup.
-(defun tramp-handle-start-file-process (name buffer program &rest args)
- "Like `start-file-process' for Tramp files."
- (with-parsed-tramp-file-name default-directory nil
- (unwind-protect
- ;; When PROGRAM is nil, we just provide a tty.
- (let ((command
- (when (stringp program)
- (format "cd %s; exec %s"
- (tramp-shell-quote-argument localname)
- (mapconcat 'tramp-shell-quote-argument
- (cons program args) " "))))
- (tramp-process-connection-type
- (or (null program) tramp-process-connection-type))
- (name1 name)
- (i 0))
- (unless buffer
- ;; BUFFER can be nil. We use a temporary buffer.
- (setq buffer (generate-new-buffer tramp-temp-buffer-name)))
- (while (get-process name1)
- ;; NAME must be unique as process name.
- (setq i (1+ i)
- name1 (format "%s<%d>" name i)))
- (setq name name1)
- ;; Set the new process properties.
- (tramp-set-connection-property v "process-name" name)
- (tramp-set-connection-property v "process-buffer" buffer)
- ;; Activate narrowing in order to save BUFFER contents.
- ;; Clear also the modification time; otherwise we might be
- ;; interrupted by `verify-visited-file-modtime'.
- (with-current-buffer (tramp-get-connection-buffer v)
- (clear-visited-file-modtime)
- (narrow-to-region (point-max) (point-max)))
- (if command
- ;; Send the command.
- (tramp-send-command v command nil t) ; nooutput
- ;; Check, whether a pty is associated.
- (tramp-maybe-open-connection v)
- (unless (process-get (tramp-get-connection-process v) 'remote-tty)
- (tramp-error
- v 'file-error "pty association is not supported for `%s'" name)))
- (let ((p (tramp-get-connection-process v)))
- ;; Set sentinel and query flag for this process.
- (tramp-set-connection-property p "vector" v)
- (set-process-sentinel p 'tramp-process-sentinel)
- (tramp-set-process-query-on-exit-flag p t)
- ;; Return process.
- p))
- ;; Save exit.
- (with-current-buffer (tramp-get-connection-buffer v)
- (if (string-match tramp-temp-buffer-name (buffer-name))
- (progn
- (set-process-buffer (tramp-get-connection-process v) nil)
- (kill-buffer (current-buffer)))
- (widen)
- (goto-char (point-max))))
- (tramp-set-connection-property v "process-name" nil)
- (tramp-set-connection-property v "process-buffer" nil))))
-
-(defun tramp-handle-process-file
- (program &optional infile destination display &rest args)
- "Like `process-file' for Tramp files."
- ;; The implementation is not complete yet.
- (when (and (numberp destination) (zerop destination))
- (error "Implementation does not handle immediate return"))
-
- (with-parsed-tramp-file-name default-directory nil
- (let (command input tmpinput stderr tmpstderr outbuf ret)
- ;; Compute command.
- (setq command (mapconcat 'tramp-shell-quote-argument
- (cons program args) " "))
- ;; Determine input.
- (if (null infile)
- (setq input "/dev/null")
- (setq infile (expand-file-name infile))
- (if (tramp-equal-remote default-directory infile)
- ;; INFILE is on the same remote host.
- (setq input (with-parsed-tramp-file-name infile nil localname))
- ;; INFILE must be copied to remote host.
- (setq input (tramp-make-tramp-temp-file v)
- tmpinput (tramp-make-tramp-file-name method user host input))
- (copy-file infile tmpinput t)))
- (when input (setq command (format "%s <%s" command input)))
-
- ;; Determine output.
- (cond
- ;; Just a buffer.
- ((bufferp destination)
- (setq outbuf destination))
- ;; A buffer name.
- ((stringp destination)
- (setq outbuf (get-buffer-create destination)))
- ;; (REAL-DESTINATION ERROR-DESTINATION)
- ((consp destination)
- ;; output.
- (cond
- ((bufferp (car destination))
- (setq outbuf (car destination)))
- ((stringp (car destination))
- (setq outbuf (get-buffer-create (car destination))))
- ((car destination)
- (setq outbuf (current-buffer))))
- ;; stderr.
- (cond
- ((stringp (cadr destination))
- (setcar (cdr destination) (expand-file-name (cadr destination)))
- (if (tramp-equal-remote default-directory (cadr destination))
- ;; stderr is on the same remote host.
- (setq stderr (with-parsed-tramp-file-name
- (cadr destination) nil localname))
- ;; stderr must be copied to remote host. The temporary
- ;; file must be deleted after execution.
- (setq stderr (tramp-make-tramp-temp-file v)
- tmpstderr (tramp-make-tramp-file-name
- method user host stderr))))
- ;; stderr to be discarded.
- ((null (cadr destination))
- (setq stderr "/dev/null"))))
- ;; 't
- (destination
- (setq outbuf (current-buffer))))
- (when stderr (setq command (format "%s 2>%s" command stderr)))
-
- ;; Send the command. It might not return in time, so we protect
- ;; it. Call it in a subshell, in order to preserve working
- ;; directory.
- (condition-case nil
- (unwind-protect
- (setq ret
- (tramp-send-command-and-check
- v (format "\\cd %s; %s"
- (tramp-shell-quote-argument localname)
- command)
- t t))
- ;; We should show the output anyway.
- (when outbuf
- (with-current-buffer outbuf
- (insert
- (with-current-buffer (tramp-get-connection-buffer v)
- (buffer-string))))
- (when display (display-buffer outbuf))))
- ;; When the user did interrupt, we should do it also. We use
- ;; return code -1 as marker.
- (quit
- (kill-buffer (tramp-get-connection-buffer v))
- (setq ret -1))
- ;; Handle errors.
- (error
- (kill-buffer (tramp-get-connection-buffer v))
- (setq ret 1)))
-
- ;; Provide error file.
- (when tmpstderr (rename-file tmpstderr (cadr destination) t))
-
- ;; Cleanup. We remove all file cache values for the connection,
- ;; because the remote process could have changed them.
- (when tmpinput (delete-file tmpinput))
-
- ;; `process-file-side-effects' has been introduced with GNU
- ;; Emacs 23.2. If set to `nil', no remote file will be changed
- ;; by `program'. If it doesn't exist, we assume its default
- ;; value 't'.
- (unless (and (boundp 'process-file-side-effects)
- (not (symbol-value 'process-file-side-effects)))
- (tramp-flush-directory-property v ""))
-
- ;; Return exit status.
- (if (equal ret -1)
- (keyboard-quit)
- ret))))
-
-(defun tramp-local-call-process
- (program &optional infile destination display &rest args)
- "Calls `call-process' on the local host.
-This is needed because for some Emacs flavors Tramp has
-defadviced `call-process' to behave like `process-file'. The
-Lisp error raised when PROGRAM is nil is trapped also, returning 1."
- (let ((default-directory
- (if (file-remote-p default-directory)
- (tramp-compat-temporary-file-directory)
- default-directory)))
- (if (executable-find program)
- (apply 'call-process program infile destination display args)
- 1)))
-
-(defun tramp-handle-call-process-region
- (start end program &optional delete buffer display &rest args)
- "Like `call-process-region' for Tramp files."
- (let ((tmpfile (tramp-compat-make-temp-file "")))
- (write-region start end tmpfile)
- (when delete (delete-region start end))
- (unwind-protect
- (apply 'call-process program tmpfile buffer display args)
- (delete-file tmpfile))))
-
-(defun tramp-handle-shell-command
- (command &optional output-buffer error-buffer)
- "Like `shell-command' for Tramp files."
- (let* ((asynchronous (string-match "[ \t]*&[ \t]*\\'" command))
- ;; We cannot use `shell-file-name' and `shell-command-switch',
- ;; they are variables of the local host.
- (args (list
- (tramp-get-method-parameter
- (tramp-file-name-method
- (tramp-dissect-file-name default-directory))
- 'tramp-remote-sh)
- "-c" (substring command 0 asynchronous)))
- current-buffer-p
- (output-buffer
- (cond
- ((bufferp output-buffer) output-buffer)
- ((stringp output-buffer) (get-buffer-create output-buffer))
- (output-buffer
- (setq current-buffer-p t)
- (current-buffer))
- (t (get-buffer-create
- (if asynchronous
- "*Async Shell Command*"
- "*Shell Command Output*")))))
- (error-buffer
- (cond
- ((bufferp error-buffer) error-buffer)
- ((stringp error-buffer) (get-buffer-create error-buffer))))
- (buffer
- (if (and (not asynchronous) error-buffer)
- (with-parsed-tramp-file-name default-directory nil
- (list output-buffer (tramp-make-tramp-temp-file v)))
- output-buffer))
- (p (get-buffer-process output-buffer)))
-
- ;; Check whether there is another process running. Tramp does not
- ;; support 2 (asynchronous) processes in parallel.
- (when p
- (if (yes-or-no-p "A command is running. Kill it? ")
- (condition-case nil
- (kill-process p)
- (error nil))
- (error "Shell command in progress")))
-
- (if current-buffer-p
- (progn
- (barf-if-buffer-read-only)
- (push-mark nil t))
- (with-current-buffer output-buffer
- (setq buffer-read-only nil)
- (erase-buffer)))
-
- (if (and (not current-buffer-p) (integerp asynchronous))
- (prog1
- ;; Run the process.
- (apply 'start-file-process "*Async Shell*" buffer args)
- ;; Display output.
- (pop-to-buffer output-buffer)
- (setq mode-line-process '(":%s"))
- (require 'shell) (shell-mode))
-
- (prog1
- ;; Run the process.
- (apply 'process-file (car args) nil buffer nil (cdr args))
- ;; Insert error messages if they were separated.
- (when (listp buffer)
- (with-current-buffer error-buffer
- (insert-file-contents (cadr buffer)))
- (delete-file (cadr buffer)))
- (if current-buffer-p
- ;; This is like exchange-point-and-mark, but doesn't
- ;; activate the mark. It is cleaner to avoid activation,
- ;; even though the command loop would deactivate the mark
- ;; because we inserted text.
- (goto-char (prog1 (mark t)
- (set-marker (mark-marker) (point)
- (current-buffer))))
- ;; There's some output, display it.
- (when (with-current-buffer output-buffer (> (point-max) (point-min)))
- (if (functionp 'display-message-or-buffer)
- (tramp-compat-funcall 'display-message-or-buffer output-buffer)
- (pop-to-buffer output-buffer))))))))
-
-;; File Editing.
-
-(defvar tramp-handle-file-local-copy-hook nil
- "Normal hook to be run at the end of `tramp-handle-file-local-copy'.")
-
-(defun tramp-handle-file-local-copy (filename)
- "Like `file-local-copy' for Tramp files."
-
- (with-parsed-tramp-file-name filename nil
- (unless (file-exists-p filename)
- (tramp-error
- v 'file-error
- "Cannot make local copy of non-existing file `%s'" filename))
-
- (let* ((size (nth 7 (file-attributes filename)))
- (rem-enc (tramp-get-inline-coding v "remote-encoding" size))
- (loc-dec (tramp-get-inline-coding v "local-decoding" size))
- (tmpfile (tramp-compat-make-temp-file filename)))
-
- (condition-case err
- (cond
- ;; `copy-file' handles direct copy and out-of-band methods.
- ((or (tramp-local-host-p v)
- (tramp-method-out-of-band-p v size))
- (copy-file filename tmpfile t t))
-
- ;; Use inline encoding for file transfer.
- (rem-enc
- (save-excursion
- (with-progress-reporter
- v 3 (format "Encoding remote file %s" filename)
- (tramp-barf-unless-okay
- v (format rem-enc (tramp-shell-quote-argument localname))
- "Encoding remote file failed"))
-
- (if (functionp loc-dec)
- ;; If local decoding is a function, we call it. We
- ;; must disable multibyte, because
- ;; `uudecode-decode-region' doesn't handle it
- ;; correctly.
- (with-temp-buffer
- (set-buffer-multibyte nil)
- (insert-buffer-substring (tramp-get-buffer v))
- (with-progress-reporter
- v 3 (format "Decoding remote file %s with function %s"
- filename loc-dec)
- (funcall loc-dec (point-min) (point-max))
- ;; Unset `file-name-handler-alist'. Otherwise,
- ;; epa-file gets confused.
- (let (file-name-handler-alist
- (coding-system-for-write 'binary))
- (write-region (point-min) (point-max) tmpfile))))
-
- ;; If tramp-decoding-function is not defined for this
- ;; method, we invoke tramp-decoding-command instead.
- (let ((tmpfile2 (tramp-compat-make-temp-file filename)))
- ;; Unset `file-name-handler-alist'. Otherwise,
- ;; epa-file gets confused.
- (let (file-name-handler-alist
- (coding-system-for-write 'binary))
- (write-region (point-min) (point-max) tmpfile2))
- (with-progress-reporter
- v 3 (format "Decoding remote file %s with command %s"
- filename loc-dec)
- (unwind-protect
- (tramp-call-local-coding-command
- loc-dec tmpfile2 tmpfile)
- (delete-file tmpfile2)))))
-
- ;; Set proper permissions.
- (set-file-modes tmpfile (tramp-default-file-modes filename))
- ;; Set local user ownership.
- (tramp-set-file-uid-gid tmpfile)))
-
- ;; Oops, I don't know what to do.
- (t (tramp-error
- v 'file-error "Wrong method specification for `%s'" method)))
-
- ;; Error handling.
- ((error quit)
- (delete-file tmpfile)
- (signal (car err) (cdr err))))
-
- (run-hooks 'tramp-handle-file-local-copy-hook)
- tmpfile)))
-
-(defun tramp-handle-file-remote-p (filename &optional identification connected)
- "Like `file-remote-p' for Tramp files."
- (let ((tramp-verbose 3))
- (when (tramp-tramp-file-p filename)
- (let* ((v (tramp-dissect-file-name filename))
- (p (tramp-get-connection-process v))
- (c (and p (processp p) (memq (process-status p) '(run open)))))
- ;; We expand the file name only, if there is already a connection.
- (with-parsed-tramp-file-name
- (if c (expand-file-name filename) filename) nil
- (and (or (not connected) c)
- (cond
- ((eq identification 'method) method)
- ((eq identification 'user) user)
- ((eq identification 'host) host)
- ((eq identification 'localname) localname)
- (t (tramp-make-tramp-file-name method user host "")))))))))
-
(defun tramp-find-file-name-coding-system-alist (filename tmpname)
"Like `find-operation-coding-system' for Tramp filenames.
Tramp's `insert-file-contents' and `write-region' work over
@@ -4915,535 +1669,6 @@ coding system might not be determined. This function repairs it."
(add-to-list
'result (cons (regexp-quote tmpname) (cdr elt)) 'append)))))
-(defun tramp-handle-insert-file-contents
- (filename &optional visit beg end replace)
- "Like `insert-file-contents' for Tramp files."
- (barf-if-buffer-read-only)
- (setq filename (expand-file-name filename))
- (let (result local-copy remote-copy)
- (with-parsed-tramp-file-name filename nil
- (unwind-protect
- (if (not (file-exists-p filename))
- ;; We don't raise a Tramp error, because it might be
- ;; suppressed, like in `find-file-noselect-1'.
- (signal 'file-error
- (list "File not found on remote host" filename))
-
- (if (and (tramp-local-host-p v)
- (let (file-name-handler-alist)
- (file-readable-p localname)))
- ;; Short track: if we are on the local host, we can
- ;; run directly.
- (setq result
- (tramp-run-real-handler
- 'insert-file-contents
- (list localname visit beg end replace)))
-
- ;; When we shall insert only a part of the file, we copy
- ;; this part.
- (when (or beg end)
- (setq remote-copy (tramp-make-tramp-temp-file v))
- (tramp-send-command
- v
- (cond
- ((and beg end)
- (format "tail -c +%d %s | head -c +%d >%s"
- (1+ beg) (tramp-shell-quote-argument localname)
- (- end beg) remote-copy))
- (beg
- (format "tail -c +%d %s >%s"
- (1+ beg) (tramp-shell-quote-argument localname)
- remote-copy))
- (end
- (format "head -c +%d %s >%s"
- (1+ end) (tramp-shell-quote-argument localname)
- remote-copy)))))
-
- ;; `insert-file-contents-literally' takes care to avoid
- ;; calling jka-compr. By let-binding
- ;; `inhibit-file-name-operation', we propagate that care
- ;; to the `file-local-copy' operation.
- (setq local-copy
- (let ((inhibit-file-name-operation
- (when (eq inhibit-file-name-operation
- 'insert-file-contents)
- 'file-local-copy)))
- (cond
- ((stringp remote-copy)
- (file-local-copy
- (tramp-make-tramp-file-name
- method user host remote-copy)))
- ((stringp tramp-temp-buffer-file-name)
- (copy-file filename tramp-temp-buffer-file-name 'ok)
- tramp-temp-buffer-file-name)
- (t (file-local-copy filename)))))
-
- ;; When the file is not readable for the owner, it
- ;; cannot be inserted, even it is redable for the group
- ;; or for everybody.
- (set-file-modes local-copy (tramp-octal-to-decimal "0600"))
-
- (when (and (null remote-copy)
- (tramp-get-method-parameter
- method 'tramp-copy-keep-tmpfile))
- ;; We keep the local file for performance reasons,
- ;; useful for "rsync".
- (setq tramp-temp-buffer-file-name local-copy)
- (put 'tramp-temp-buffer-file-name 'permanent-local t))
-
- (with-progress-reporter
- v 3 (format "Inserting local temp file `%s'" local-copy)
- ;; We must ensure that `file-coding-system-alist'
- ;; matches `local-copy'.
- (let ((file-coding-system-alist
- (tramp-find-file-name-coding-system-alist
- filename local-copy)))
- (setq result
- (insert-file-contents
- local-copy nil nil nil replace))))))
-
- ;; Save exit.
- (progn
- (when visit
- (setq buffer-file-name filename)
- (setq buffer-read-only (not (file-writable-p filename)))
- (set-visited-file-modtime)
- (set-buffer-modified-p nil)
- ;; For root, preserve owner and group when editing files.
- (when (string-equal (file-remote-p filename 'user) "root")
- (set (make-local-variable 'backup-by-copying-when-mismatch) t)))
- (when (and (stringp local-copy)
- (or remote-copy (null tramp-temp-buffer-file-name)))
- (delete-file local-copy))
- (when (stringp remote-copy)
- (delete-file
- (tramp-make-tramp-file-name method user host remote-copy))))))
-
- ;; Result.
- (list (expand-file-name filename)
- (cadr result))))
-
-;; This is needed for XEmacs only. Code stolen from files.el.
-(defun tramp-handle-insert-file-contents-literally
- (filename &optional visit beg end replace)
- "Like `insert-file-contents-literally' for Tramp files."
- (let ((format-alist nil)
- (after-insert-file-functions nil)
- (coding-system-for-read 'no-conversion)
- (coding-system-for-write 'no-conversion)
- (find-buffer-file-type-function
- (if (fboundp 'find-buffer-file-type)
- (symbol-function 'find-buffer-file-type)
- nil))
- (inhibit-file-name-handlers '(jka-compr-handler image-file-handler))
- (inhibit-file-name-operation 'insert-file-contents))
- (unwind-protect
- (progn
- (fset 'find-buffer-file-type (lambda (filename) t))
- (insert-file-contents filename visit beg end replace))
- ;; Save exit.
- (if find-buffer-file-type-function
- (fset 'find-buffer-file-type find-buffer-file-type-function)
- (fmakunbound 'find-buffer-file-type)))))
-
-(defun tramp-handle-find-backup-file-name (filename)
- "Like `find-backup-file-name' for Tramp files."
- (with-parsed-tramp-file-name filename nil
- ;; We set both variables. It doesn't matter whether it is
- ;; Emacs or XEmacs.
- (let ((backup-directory-alist
- ;; Emacs case.
- (when (boundp 'backup-directory-alist)
- (if (symbol-value 'tramp-backup-directory-alist)
- (mapcar
- (lambda (x)
- (cons
- (car x)
- (if (and (stringp (cdr x))
- (file-name-absolute-p (cdr x))
- (not (tramp-file-name-p (cdr x))))
- (tramp-make-tramp-file-name method user host (cdr x))
- (cdr x))))
- (symbol-value 'tramp-backup-directory-alist))
- (symbol-value 'backup-directory-alist))))
-
- (bkup-backup-directory-info
- ;; XEmacs case.
- (when (boundp 'bkup-backup-directory-info)
- (if (symbol-value 'tramp-bkup-backup-directory-info)
- (mapcar
- (lambda (x)
- (nconc
- (list (car x))
- (list
- (if (and (stringp (car (cdr x)))
- (file-name-absolute-p (car (cdr x)))
- (not (tramp-file-name-p (car (cdr x)))))
- (tramp-make-tramp-file-name
- method user host (car (cdr x)))
- (car (cdr x))))
- (cdr (cdr x))))
- (symbol-value 'tramp-bkup-backup-directory-info))
- (symbol-value 'bkup-backup-directory-info)))))
-
- (tramp-run-real-handler 'find-backup-file-name (list filename)))))
-
-(defun tramp-handle-make-auto-save-file-name ()
- "Like `make-auto-save-file-name' for Tramp files.
-Returns a file name in `tramp-auto-save-directory' for autosaving this file."
- (let ((tramp-auto-save-directory tramp-auto-save-directory)
- (buffer-file-name
- (tramp-subst-strs-in-string
- '(("_" . "|")
- ("/" . "_a")
- (":" . "_b")
- ("|" . "__")
- ("[" . "_l")
- ("]" . "_r"))
- (buffer-file-name))))
- ;; File name must be unique. This is ensured with Emacs 22 (see
- ;; UNIQUIFY element of `auto-save-file-name-transforms'); but for
- ;; all other cases we must do it ourselves.
- (when (boundp 'auto-save-file-name-transforms)
- (mapc
- (lambda (x)
- (when (and (string-match (car x) buffer-file-name)
- (not (car (cddr x))))
- (setq tramp-auto-save-directory
- (or tramp-auto-save-directory
- (tramp-compat-temporary-file-directory)))))
- (symbol-value 'auto-save-file-name-transforms)))
- ;; Create directory.
- (when tramp-auto-save-directory
- (setq buffer-file-name
- (expand-file-name buffer-file-name tramp-auto-save-directory))
- (unless (file-exists-p tramp-auto-save-directory)
- (make-directory tramp-auto-save-directory t)))
- ;; Run plain `make-auto-save-file-name'. There might be an advice when
- ;; it is not a magic file name operation (since Emacs 22).
- ;; We must deactivate it temporarily.
- (if (not (ad-is-active 'make-auto-save-file-name))
- (tramp-run-real-handler 'make-auto-save-file-name nil)
- ;; else
- (ad-deactivate 'make-auto-save-file-name)
- (prog1
- (tramp-run-real-handler 'make-auto-save-file-name nil)
- (ad-activate 'make-auto-save-file-name)))))
-
-(defvar tramp-handle-write-region-hook nil
- "Normal hook to be run at the end of `tramp-handle-write-region'.")
-
-;; CCC grok LOCKNAME
-(defun tramp-handle-write-region
- (start end filename &optional append visit lockname confirm)
- "Like `write-region' for Tramp files."
- (setq filename (expand-file-name filename))
- (with-parsed-tramp-file-name filename nil
- ;; Following part commented out because we don't know what to do about
- ;; file locking, and it does not appear to be a problem to ignore it.
- ;; Ange-ftp ignores it, too.
- ;; (when (and lockname (stringp lockname))
- ;; (setq lockname (expand-file-name lockname)))
- ;; (unless (or (eq lockname nil)
- ;; (string= lockname filename))
- ;; (error
- ;; "tramp-handle-write-region: LOCKNAME must be nil or equal FILENAME"))
-
- ;; XEmacs takes a coding system as the seventh argument, not `confirm'.
- (when (and (not (featurep 'xemacs)) confirm (file-exists-p filename))
- (unless (y-or-n-p (format "File %s exists; overwrite anyway? " filename))
- (tramp-error v 'file-error "File not overwritten")))
-
- (let ((uid (or (nth 2 (tramp-compat-file-attributes filename 'integer))
- (tramp-get-remote-uid v 'integer)))
- (gid (or (nth 3 (tramp-compat-file-attributes filename 'integer))
- (tramp-get-remote-gid v 'integer))))
-
- (if (and (tramp-local-host-p v)
- ;; `file-writable-p' calls `file-expand-file-name'. We
- ;; cannot use `tramp-run-real-handler' therefore.
- (let (file-name-handler-alist)
- (and
- (file-writable-p (file-name-directory localname))
- (or (file-directory-p localname)
- (file-writable-p localname)))))
- ;; Short track: if we are on the local host, we can run directly.
- (tramp-run-real-handler
- 'write-region
- (list start end localname append 'no-message lockname confirm))
-
- (let ((modes (save-excursion (tramp-default-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. This
- ;; way, any intermediary coding systems used while
- ;; talking to the remote shell or suchlike won't hose
- ;; this variable. This approach was snarfed from
- ;; ange-ftp.el.
- coding-system-used
- ;; Write region into a tmp file. This isn't really
- ;; needed if we use an encoding function, but currently
- ;; we use it always because this makes the logic
- ;; simpler.
- (tmpfile (or tramp-temp-buffer-file-name
- (tramp-compat-make-temp-file filename))))
-
- ;; If `append' is non-nil, we copy the file locally, and let
- ;; the native `write-region' implementation do the job.
- (when append (copy-file filename tmpfile 'ok))
-
- ;; We say `no-message' here because we don't want the
- ;; visited file modtime data to be clobbered from the temp
- ;; file. We call `set-visited-file-modtime' ourselves later
- ;; on. We must ensure that `file-coding-system-alist'
- ;; matches `tmpfile'.
- (let (file-name-handler-alist
- (file-coding-system-alist
- (tramp-find-file-name-coding-system-alist filename tmpfile)))
- (condition-case err
- (tramp-run-real-handler
- 'write-region
- (list start end tmpfile append 'no-message lockname confirm))
- ((error quit)
- (setq tramp-temp-buffer-file-name nil)
- (delete-file tmpfile)
- (signal (car err) (cdr err))))
-
- ;; Now, `last-coding-system-used' has the right value. Remember it.
- (when (boundp 'last-coding-system-used)
- (setq coding-system-used
- (symbol-value 'last-coding-system-used))))
-
- ;; 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.
- ;; Ensure, that it is still readable.
- (when modes
- (set-file-modes
- tmpfile (logior (or modes 0) (tramp-octal-to-decimal "0400"))))
-
- ;; This is a bit lengthy due to the different methods
- ;; possible for file transfer. First, we check whether the
- ;; method uses an rcp program. If so, we call it.
- ;; Otherwise, both encoding and decoding command must be
- ;; specified. However, if the method _also_ specifies an
- ;; encoding function, then that is used for encoding the
- ;; contents of the tmp file.
- (let* ((size (nth 7 (file-attributes tmpfile)))
- (rem-dec (tramp-get-inline-coding v "remote-decoding" size))
- (loc-enc (tramp-get-inline-coding v "local-encoding" size)))
- (cond
- ;; `copy-file' handles direct copy and out-of-band methods.
- ((or (tramp-local-host-p v)
- (tramp-method-out-of-band-p v size))
- (if (and (not (stringp start))
- (= (or end (point-max)) (point-max))
- (= (or start (point-min)) (point-min))
- (tramp-get-method-parameter
- method 'tramp-copy-keep-tmpfile))
- (progn
- (setq tramp-temp-buffer-file-name tmpfile)
- (condition-case err
- ;; We keep the local file for performance
- ;; reasons, useful for "rsync".
- (copy-file tmpfile filename t)
- ((error quit)
- (setq tramp-temp-buffer-file-name nil)
- (delete-file tmpfile)
- (signal (car err) (cdr err)))))
- (setq tramp-temp-buffer-file-name nil)
- ;; Don't rename, in order to keep context in SELinux.
- (unwind-protect
- (copy-file tmpfile filename t)
- (delete-file tmpfile))))
-
- ;; Use inline file transfer.
- (rem-dec
- ;; Encode tmpfile.
- (unwind-protect
- (with-temp-buffer
- (set-buffer-multibyte nil)
- ;; Use encoding function or command.
- (if (functionp loc-enc)
- (with-progress-reporter
- v 3 (format "Encoding region using function `%s'"
- loc-enc)
- (let ((coding-system-for-read 'binary))
- (insert-file-contents-literally tmpfile))
- ;; The following `let' is a workaround for the
- ;; base64.el that comes with pgnus-0.84. If
- ;; both of the following conditions are
- ;; satisfied, it tries to write to a local
- ;; file in default-directory, but at this
- ;; point, default-directory is remote.
- ;; (`call-process-region' can't write to
- ;; remote files, it seems.) The file in
- ;; question is a tmp file anyway.
- (let ((default-directory
- (tramp-compat-temporary-file-directory)))
- (funcall loc-enc (point-min) (point-max))))
-
- (with-progress-reporter
- v 3 (format "Encoding region using command `%s'"
- loc-enc)
- (unless (zerop (tramp-call-local-coding-command
- loc-enc tmpfile t))
- (tramp-error
- v 'file-error
- (concat "Cannot write to `%s', "
- "local encoding command `%s' failed")
- filename loc-enc))))
-
- ;; Send buffer into remote decoding command which
- ;; writes to remote file. Because this happens on
- ;; the remote host, we cannot use the function.
- (with-progress-reporter
- v 3
- (format "Decoding region into remote file %s" filename)
- (goto-char (point-max))
- (unless (bolp) (newline))
- (tramp-send-command
- v
- (format
- (concat rem-dec " <<'EOF'\n%sEOF")
- (tramp-shell-quote-argument localname)
- (buffer-string)))
- (tramp-barf-unless-okay
- v nil
- "Couldn't write region to `%s', decode using `%s' failed"
- filename rem-dec)
- ;; When `file-precious-flag' is set, the region is
- ;; written to a temporary file. Check that the
- ;; checksum is equal to that from the local tmpfile.
- (when file-precious-flag
- (erase-buffer)
- (and
- ;; cksum runs locally, if possible.
- (zerop (tramp-local-call-process "cksum" tmpfile t))
- ;; cksum runs remotely.
- (zerop
- (tramp-send-command-and-check
- v
- (format
- "cksum <%s"
- (tramp-shell-quote-argument localname))))
- ;; ... they are different.
- (not
- (string-equal
- (buffer-string)
- (with-current-buffer (tramp-get-buffer v)
- (buffer-string))))
- (tramp-error
- v 'file-error
- (concat "Couldn't write region to `%s',"
- " decode using `%s' failed")
- filename rem-dec)))))
-
- ;; Save exit.
- (delete-file tmpfile)))
-
- ;; That's not expected.
- (t
- (tramp-error
- v 'file-error
- (concat "Method `%s' should specify both encoding and "
- "decoding command or an rcp program")
- method))))
-
- ;; Make `last-coding-system-used' have the right value.
- (when coding-system-used
- (set 'last-coding-system-used coding-system-used))))
-
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
-
- ;; We must protect `last-coding-system-used', now we have set it
- ;; to its correct value.
- (let (last-coding-system-used (need-chown t))
- ;; Set file modification time.
- (when (or (eq visit t) (stringp visit))
- (let ((file-attr (file-attributes filename)))
- (set-visited-file-modtime
- ;; We must pass modtime explicitely, because filename can
- ;; be different from (buffer-file-name), f.e. if
- ;; `file-precious-flag' is set.
- (nth 5 file-attr))
- (when (and (eq (nth 2 file-attr) uid)
- (eq (nth 3 file-attr) gid))
- (setq need-chown nil))))
-
- ;; Set the ownership.
- (when need-chown
- (tramp-set-file-uid-gid filename uid gid))
- (when (or (eq visit t) (null visit) (stringp visit))
- (tramp-message v 0 "Wrote %s" filename))
- (run-hooks 'tramp-handle-write-region-hook)))))
-
-(defvar tramp-vc-registered-file-names nil
- "List used to collect file names, which are checked during `vc-registered'.")
-
-;; VC backends check for the existence of various different special
-;; files. This is very time consuming, because every single check
-;; requires a remote command (the file cache must be invalidated).
-;; Therefore, we apply a kind of optimization. We install the file
-;; name handler `tramp-vc-file-name-handler', which does nothing but
-;; remembers all file names for which `file-exists-p' or
-;; `file-readable-p' has been applied. A first run of `vc-registered'
-;; is performed. Afterwards, a script is applied for all collected
-;; file names, using just one remote command. The result of this
-;; script is used to fill the file cache with actual values. Now we
-;; can reset the file name handlers, and we make a second run of
-;; `vc-registered', which returns the expected result without sending
-;; any other remote command.
-(defun tramp-handle-vc-registered (file)
- "Like `vc-registered' for Tramp files."
- (with-temp-message ""
- (with-parsed-tramp-file-name file nil
- (with-progress-reporter
- v 3 (format "Checking `vc-registered' for %s" file)
-
- ;; There could be new files, created by the vc backend. We
- ;; cannot reuse the old cache entries, therefore.
- (let (tramp-vc-registered-file-names
- (tramp-cache-inhibit-cache (current-time))
- (file-name-handler-alist
- `((,tramp-file-name-regexp . tramp-vc-file-name-handler))))
-
- ;; Here we collect only file names, which need an operation.
- (tramp-run-real-handler 'vc-registered (list file))
- (tramp-message v 10 "\n%s" tramp-vc-registered-file-names)
-
- ;; Send just one command, in order to fill the cache.
- (when tramp-vc-registered-file-names
- (tramp-maybe-send-script
- v
- (format tramp-vc-registered-read-file-names
- (tramp-get-file-exists-command v)
- (format "%s -r" (tramp-get-test-command v)))
- "tramp_vc_registered_read_file_names")
-
- (dolist
- (elt
- (tramp-send-command-and-read
- v
- (format
- "tramp_vc_registered_read_file_names <<'EOF'\n%s\nEOF\n"
- (mapconcat 'tramp-shell-quote-argument
- tramp-vc-registered-file-names
- "\n"))))
-
- (tramp-set-file-property
- v (car elt) (cadr elt) (cadr (cdr elt))))))
-
- ;; Second run. Now all `file-exists-p' or `file-readable-p'
- ;; calls shall be answered from the file cache. We unset
- ;; `process-file-side-effects' in order to keep the cache when
- ;; `process-file' calls appear.
- (let (process-file-side-effects)
- (tramp-run-real-handler 'vc-registered (list file)))))))
-
;;;###autoload
(progn (defun tramp-run-real-handler (operation args)
"Invoke normal file name handler for OPERATION.
@@ -5604,8 +1829,7 @@ Falls back to normal file name handler if no Tramp file name handler exists."
(condition-case err
(apply foreign operation args)
- ;; Trace that somebody has interrupted the
- ;; operation.
+ ;; Trace, that somebody has interrupted the operation.
(quit
(let (tramp-message-show-message)
(tramp-message
@@ -5663,48 +1887,6 @@ preventing reentrant calls of Tramp.")
Together with `tramp-locked', this implements a locking mechanism
preventing reentrant calls of Tramp.")
-(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."
- (when (and tramp-locked (not tramp-locker))
- (setq tramp-locked nil)
- (signal 'file-error (list "Forbidden reentrant call of Tramp")))
- (let ((tl tramp-locked))
- (unwind-protect
- (progn
- (setq tramp-locked t)
- (let ((tramp-locker t))
- (save-match-data
- (let ((fn (assoc operation tramp-file-name-handler-alist)))
- (if fn
- (apply (cdr fn) args)
- (tramp-run-real-handler operation args))))))
- (setq tramp-locked tl))))
-
-(defun tramp-vc-file-name-handler (operation &rest args)
- "Invoke special file name handler, which collects files to be handled."
- (save-match-data
- (let ((filename
- (tramp-replace-environment-variables
- (apply 'tramp-file-name-for-operation operation args)))
- (fn (assoc operation tramp-file-name-handler-alist)))
- (with-parsed-tramp-file-name filename nil
- (cond
- ;; That's what we want: file names, for which checks are
- ;; applied. We assume, that VC uses only `file-exists-p' and
- ;; `file-readable-p' checks; otherwise we must extend the
- ;; list. We do not perform any action, but return nil, in
- ;; order to keep `vc-registered' running.
- ((and fn (memq operation '(file-exists-p file-readable-p)))
- (add-to-list 'tramp-vc-registered-file-names localname 'append)
- nil)
- ;; Tramp file name handlers like `expand-file-name'. They
- ;; must still work.
- (fn
- (save-match-data (apply (cdr fn) args)))
- ;; Default file name handlers, we don't care.
- (t (tramp-run-real-handler operation args)))))))
-
;;;###autoload
(progn (defun tramp-completion-file-name-handler (operation &rest args)
"Invoke Tramp file name completion handler.
@@ -5763,9 +1945,29 @@ Falls back to normal file name handler if no Tramp file name handler exists."
;; `tramp-file-name-handler' must be registered before evaluation of
;; site-start and init files, because there might exist remote files
;; already, f.e. files kept via recentf-mode.
-;;;###autoload(tramp-register-file-name-handlers)
+;;;###autoload
(tramp-register-file-name-handlers)
+(defun tramp-exists-file-name-handler (operation &rest args)
+ "Check, whether OPERATION runs a file name handler."
+ ;; The file name handler is determined on base of either an
+ ;; argument, `buffer-file-name', or `default-directory'.
+ (ignore-errors
+ (let* ((buffer-file-name "/")
+ (default-directory "/")
+ (fnha file-name-handler-alist)
+ (check-file-name-operation operation)
+ (file-name-handler-alist
+ (list
+ (cons "/"
+ (lambda (operation &rest args)
+ "Returns OPERATION if it is the one to be checked."
+ (if (equal check-file-name-operation operation)
+ operation
+ (let ((file-name-handler-alist fnha))
+ (apply operation args))))))))
+ (equal (apply operation args) operation))))
+
;;;###autoload
(defun tramp-unload-file-name-handlers ()
(setq file-name-handler-alist
@@ -5798,6 +2000,7 @@ should never be set globally, the intention is to let-bind it.")
;; Tramp file name syntax. Maybe another variable should be introduced
;; overwriting this check in such cases. Or we change Tramp file name
;; syntax in order to avoid ambiguities, like in XEmacs ...
+;;;###tramp-autoload
(defun tramp-completion-mode-p ()
"Check, whether method / user name / host name completion is active."
(or
@@ -5902,12 +2105,11 @@ not in completion mode."
;; Complete local parts.
(append
result1
- (condition-case nil
- (apply (if (tramp-connectable-p fullname)
- 'tramp-completion-run-real-handler
- 'tramp-run-real-handler)
- 'file-name-all-completions (list (list filename directory)))
- (error nil)))))
+ (ignore-errors
+ (apply (if (tramp-connectable-p fullname)
+ 'tramp-completion-run-real-handler
+ 'tramp-run-real-handler)
+ 'file-name-all-completions (list (list filename directory)))))))
;; Method, host name and user name completion for a file.
;;;###autoload
@@ -6150,7 +2352,7 @@ Either user or host may be nil."
(concat
"^\\(" tramp-host-regexp "\\)"
"\\([ \t]+" "\\(" tramp-user-regexp "\\)" "\\)?")))
- (narrow-to-region (point) (tramp-compat-line-end-position))
+ (narrow-to-region (point) (point-at-eol))
(when (re-search-forward regexp nil t)
(setq result (append (list (match-string 3) (match-string 1)))))
(widen)
@@ -6177,7 +2379,7 @@ User is always nil."
User is always nil."
(let ((result)
(regexp (concat "^\\(" tramp-host-regexp "\\)")))
- (narrow-to-region (point) (tramp-compat-line-end-position))
+ (narrow-to-region (point) (point-at-eol))
(when (re-search-forward regexp nil t)
(setq result (list nil (match-string 1))))
(widen)
@@ -6206,7 +2408,7 @@ User is always nil."
User is always nil."
(let ((result)
(regexp (concat "^[ \t]*Host[ \t]+" "\\(" tramp-host-regexp "\\)")))
- (narrow-to-region (point) (tramp-compat-line-end-position))
+ (narrow-to-region (point) (point-at-eol))
(when (re-search-forward regexp nil t)
(setq result (list nil (match-string 1))))
(widen)
@@ -6267,7 +2469,7 @@ User is always nil."
(let ((result)
(regexp
(concat "^\\(" tramp-ipv6-regexp "\\|" tramp-host-regexp "\\)")))
- (narrow-to-region (point) (tramp-compat-line-end-position))
+ (narrow-to-region (point) (point-at-eol))
(when (re-search-forward regexp nil t)
(setq result (list nil (match-string 1))))
(widen)
@@ -6302,7 +2504,7 @@ Host is always \"localhost\"."
Host is always \"localhost\"."
(let ((result)
(regexp (concat "^\\(" tramp-user-regexp "\\):")))
- (narrow-to-region (point) (tramp-compat-line-end-position))
+ (narrow-to-region (point) (point-at-eol))
(when (re-search-forward regexp nil t)
(setq result (list (match-string 1) "localhost")))
(widen)
@@ -6332,7 +2534,7 @@ User may be nil."
(concat
"^[ \t]*machine[ \t]+" "\\(" tramp-host-regexp "\\)"
"\\([ \t]+login[ \t]+" "\\(" tramp-user-regexp "\\)" "\\)?")))
- (narrow-to-region (point) (tramp-compat-line-end-position))
+ (narrow-to-region (point) (point-at-eol))
(when (re-search-forward regexp nil t)
(setq result (list (match-string 3) (match-string 1))))
(widen)
@@ -6347,7 +2549,7 @@ User is always nil."
(let ((default-directory (tramp-compat-temporary-file-directory))
res)
(with-temp-buffer
- (when (zerop (tramp-local-call-process "reg" nil t nil "query" registry))
+ (when (zerop (tramp-compat-call-process "reg" nil t nil "query" registry))
(goto-char (point-min))
(while (not (eobp))
(push (tramp-parse-putty-group registry) res))))
@@ -6358,333 +2560,388 @@ User is always nil."
User is always nil."
(let ((result)
(regexp (concat (regexp-quote registry) "\\\\\\(.+\\)")))
- (narrow-to-region (point) (tramp-compat-line-end-position))
+ (narrow-to-region (point) (point-at-eol))
(when (re-search-forward regexp nil t)
(setq result (list nil (match-string 1))))
(widen)
(forward-line 1)
result))
-;;; Internal Functions:
+;;; Common file name handler functions for different backends:
-(defun tramp-maybe-send-script (vec script name)
- "Define in remote shell function NAME implemented as SCRIPT.
-Only send the definition if it has not already been done."
- (let* ((p (tramp-get-connection-process vec))
- (scripts (tramp-get-connection-property p "scripts" nil)))
- (unless (member name scripts)
- (with-progress-reporter vec 5 (format "Sending script `%s'" name)
- ;; The script could contain a call of Perl. This is masked with `%s'.
- (tramp-send-command-and-check
- vec
- (format "%s () {\n%s\n}" name
- (format script (tramp-get-remote-perl vec))))
- (tramp-set-connection-property p "scripts" (cons name scripts))))))
-
-(defun tramp-set-auto-save ()
- (when (and ;; ange-ftp has its own auto-save mechanism
- (eq (tramp-find-foreign-file-name-handler (buffer-file-name))
- 'tramp-sh-file-name-handler)
- auto-save-default)
- (auto-save-mode 1)))
-(add-hook 'find-file-hooks 'tramp-set-auto-save t)
-(add-hook 'tramp-unload-hook
- (lambda ()
- (remove-hook 'find-file-hooks 'tramp-set-auto-save)))
+(defvar tramp-handle-file-local-copy-hook nil
+ "Normal hook to be run at the end of `tramp-*-handle-file-local-copy'.")
+
+(defvar tramp-handle-write-region-hook nil
+ "Normal hook to be run at the end of `tramp-*-handle-write-region'.")
+
+(defun tramp-handle-directory-file-name (directory)
+ "Like `directory-file-name' for Tramp files."
+ ;; If localname component of filename is "/", leave it unchanged.
+ ;; Otherwise, remove any trailing slash from localname component.
+ ;; Method, host, etc, are unchanged. Does it make sense to try
+ ;; to avoid parsing the filename?
+ (with-parsed-tramp-file-name directory nil
+ (if (and (not (zerop (length localname)))
+ (eq (aref localname (1- (length localname))) ?/)
+ (not (string= localname "/")))
+ (substring directory 0 -1)
+ directory)))
+
+(defun tramp-handle-directory-files
+ (directory &optional full match nosort files-only)
+ "Like `directory-files' for Tramp files."
+ ;; FILES-ONLY is valid for XEmacs only.
+ (when (file-directory-p directory)
+ (setq directory (file-name-as-directory (expand-file-name directory)))
+ (let ((temp (nreverse (file-name-all-completions "" directory)))
+ result item)
+
+ (while temp
+ (setq item (directory-file-name (pop temp)))
+ (when (and (or (null match) (string-match match item))
+ (or (null files-only)
+ ;; Files only.
+ (and (equal files-only t) (file-regular-p item))
+ ;; Directories only.
+ (file-directory-p item)))
+ (push (if full (concat directory item) item)
+ result)))
+ (if nosort result (sort result 'string<)))))
+
+(defun tramp-handle-directory-files-and-attributes
+ (directory &optional full match nosort id-format)
+ "Like `directory-files-and-attributes' for Tramp files."
+ (mapcar
+ (lambda (x)
+ (cons x (tramp-compat-file-attributes
+ (if full x (expand-file-name x directory)) id-format)))
+ (directory-files directory full match nosort)))
+
+(defun tramp-handle-dired-uncache (dir &optional dir-p)
+ "Like `dired-uncache' for Tramp files."
+ ;; DIR-P is valid for XEmacs only.
+ (with-parsed-tramp-file-name
+ (if (or dir-p (file-directory-p dir)) dir (file-name-directory dir)) nil
+ (tramp-flush-directory-property v localname)))
-(defun tramp-run-test (switch filename)
- "Run `test' on the remote system, given a SWITCH and a FILENAME.
-Returns the exit code of the `test' program."
+(defun tramp-handle-file-exists-p (filename)
+ "Like `file-exists-p' for Tramp files."
+ (not (null (file-attributes filename))))
+
+(defun tramp-handle-file-modes (filename)
+ "Like `file-modes' for Tramp files."
+ (let ((truename (or (file-truename filename) filename)))
+ (when (file-exists-p truename)
+ (tramp-mode-string-to-int (nth 8 (file-attributes truename))))))
+
+;; Localname manipulation functions that grok Tramp localnames...
+(defun tramp-handle-file-name-as-directory (file)
+ "Like `file-name-as-directory' but aware of Tramp files."
+ ;; `file-name-as-directory' would be sufficient except localname is
+ ;; the empty string.
+ (let ((v (tramp-dissect-file-name file t)))
+ ;; Run the command on the localname portion only.
+ (tramp-make-tramp-file-name
+ (tramp-file-name-method v)
+ (tramp-file-name-user v)
+ (tramp-file-name-host v)
+ (tramp-run-real-handler
+ 'file-name-as-directory (list (or (tramp-file-name-localname v) ""))))))
+
+(defun tramp-handle-file-name-completion
+ (filename directory &optional predicate)
+ "Like `file-name-completion' for Tramp files."
+ (unless (tramp-tramp-file-p directory)
+ (error
+ "tramp-handle-file-name-completion invoked on non-tramp directory `%s'"
+ directory))
+ (try-completion
+ filename
+ (mapcar 'list (file-name-all-completions filename directory))
+ (when predicate
+ (lambda (x) (funcall predicate (expand-file-name (car x) directory))))))
+
+(defun tramp-handle-file-name-directory (file)
+ "Like `file-name-directory' but aware of Tramp files."
+ ;; Everything except the last filename thing is the directory. We
+ ;; cannot apply `with-parsed-tramp-file-name', because this expands
+ ;; the remote file name parts. This is a problem when we are in
+ ;; file name completion.
+ (let ((v (tramp-dissect-file-name file t)))
+ ;; Run the command on the localname portion only.
+ (tramp-make-tramp-file-name
+ (tramp-file-name-method v)
+ (tramp-file-name-user v)
+ (tramp-file-name-host v)
+ (tramp-run-real-handler
+ 'file-name-directory (list (or (tramp-file-name-localname v) ""))))))
+
+(defun tramp-handle-file-name-nondirectory (file)
+ "Like `file-name-nondirectory' but aware of Tramp files."
+ (with-parsed-tramp-file-name file nil
+ (tramp-run-real-handler 'file-name-nondirectory (list localname))))
+
+(defun tramp-handle-file-newer-than-file-p (file1 file2)
+ "Like `file-newer-than-file-p' for Tramp files."
+ (cond
+ ((not (file-exists-p file1)) nil)
+ ((not (file-exists-p file2)) t)
+ (t (tramp-time-less-p (nth 5 (file-attributes file2))
+ (nth 5 (file-attributes file1))))))
+
+(defun tramp-handle-file-regular-p (filename)
+ "Like `file-regular-p' for Tramp files."
+ (and (file-exists-p filename)
+ (eq ?- (aref (nth 8 (file-attributes filename)) 0))))
+
+(defun tramp-handle-file-remote-p (filename &optional identification connected)
+ "Like `file-remote-p' for Tramp files."
+ (let ((tramp-verbose 3))
+ (when (tramp-tramp-file-p filename)
+ (let* ((v (tramp-dissect-file-name filename))
+ (p (tramp-get-connection-process v))
+ (c (and p (processp p) (memq (process-status p) '(run open)))))
+ ;; We expand the file name only, if there is already a connection.
+ (with-parsed-tramp-file-name
+ (if c (expand-file-name filename) filename) nil
+ (and (or (not connected) c)
+ (cond
+ ((eq identification 'method) method)
+ ((eq identification 'user) user)
+ ((eq identification 'host) host)
+ ((eq identification 'localname) localname)
+ (t (tramp-make-tramp-file-name method user host "")))))))))
+
+(defun tramp-handle-file-symlink-p (filename)
+ "Like `file-symlink-p' for Tramp files."
(with-parsed-tramp-file-name filename nil
- (tramp-send-command-and-check
- v
- (format
- "%s %s %s"
- (tramp-get-test-command v)
- switch
- (tramp-shell-quote-argument localname)))))
-
-(defun tramp-run-test2 (format-string file1 file2)
- "Run `test'-like program on the remote system, given FILE1, FILE2.
-FORMAT-STRING contains the program name, switches, and place holders.
-Returns the exit code of the `test' program. Barfs if the methods,
-hosts, or files, disagree."
- (unless (tramp-equal-remote file1 file2)
- (with-parsed-tramp-file-name (if (tramp-tramp-file-p file1) file1 file2) nil
- (tramp-error
- v 'file-error
- "tramp-run-test2 only implemented for same method, user, host")))
- (with-parsed-tramp-file-name file1 v1
- (with-parsed-tramp-file-name file1 v2
- (tramp-send-command-and-check
- v1
- (format format-string
- (tramp-shell-quote-argument v1-localname)
- (tramp-shell-quote-argument v2-localname))))))
+ (let ((x (car (file-attributes filename))))
+ (when (stringp x)
+ ;; When Tramp is running on VMS, then `file-name-absolute-p'
+ ;; might do weird things.
+ (if (file-name-absolute-p x)
+ (tramp-make-tramp-file-name method user host x)
+ x)))))
-(defun tramp-buffer-name (vec)
- "A name for the connection buffer VEC."
- ;; We must use `tramp-file-name-real-host', because for gateway
- ;; methods the default port will be expanded later on, which would
- ;; tamper the name.
- (let ((method (tramp-file-name-method vec))
- (user (tramp-file-name-user vec))
- (host (tramp-file-name-real-host vec)))
- (if (not (zerop (length user)))
- (format "*tramp/%s %s@%s*" method user host)
- (format "*tramp/%s %s*" method host))))
+(defun tramp-handle-find-backup-file-name (filename)
+ "Like `find-backup-file-name' for Tramp files."
+ (with-parsed-tramp-file-name filename nil
+ ;; We set both variables. It doesn't matter whether it is
+ ;; Emacs or XEmacs.
+ (let ((backup-directory-alist
+ ;; Emacs case.
+ (when (boundp 'backup-directory-alist)
+ (if (symbol-value 'tramp-backup-directory-alist)
+ (mapcar
+ (lambda (x)
+ (cons
+ (car x)
+ (if (and (stringp (cdr x))
+ (file-name-absolute-p (cdr x))
+ (not (tramp-file-name-p (cdr x))))
+ (tramp-make-tramp-file-name method user host (cdr x))
+ (cdr x))))
+ (symbol-value 'tramp-backup-directory-alist))
+ (symbol-value 'backup-directory-alist))))
-(defun tramp-delete-temp-file-function ()
- "Remove temporary files related to current buffer."
- (when (stringp tramp-temp-buffer-file-name)
- (condition-case nil
- (delete-file tramp-temp-buffer-file-name)
- (error nil))))
+ (bkup-backup-directory-info
+ ;; XEmacs case.
+ (when (boundp 'bkup-backup-directory-info)
+ (if (symbol-value 'tramp-bkup-backup-directory-info)
+ (mapcar
+ (lambda (x)
+ (nconc
+ (list (car x))
+ (list
+ (if (and (stringp (car (cdr x)))
+ (file-name-absolute-p (car (cdr x)))
+ (not (tramp-file-name-p (car (cdr x)))))
+ (tramp-make-tramp-file-name
+ method user host (car (cdr x)))
+ (car (cdr x))))
+ (cdr (cdr x))))
+ (symbol-value 'tramp-bkup-backup-directory-info))
+ (symbol-value 'bkup-backup-directory-info)))))
-(add-hook 'kill-buffer-hook 'tramp-delete-temp-file-function)
-(add-hook 'tramp-cache-unload-hook
- (lambda ()
- (remove-hook 'kill-buffer-hook
- 'tramp-delete-temp-file-function)))
+ (tramp-run-real-handler 'find-backup-file-name (list filename)))))
-(defun tramp-get-buffer (vec)
- "Get the connection buffer to be used for VEC."
- (or (get-buffer (tramp-buffer-name vec))
- (with-current-buffer (get-buffer-create (tramp-buffer-name vec))
- (setq buffer-undo-list t)
- (setq default-directory
- (tramp-make-tramp-file-name
- (tramp-file-name-method vec)
- (tramp-file-name-user vec)
- (tramp-file-name-host vec)
- "/"))
- (current-buffer))))
+(defun tramp-handle-insert-file-contents
+ (filename &optional visit beg end replace)
+ "Like `insert-file-contents' for Tramp files."
+ (barf-if-buffer-read-only)
+ (setq filename (expand-file-name filename))
+ (let (result local-copy remote-copy)
+ (with-parsed-tramp-file-name filename nil
+ (unwind-protect
+ (if (not (file-exists-p filename))
+ ;; We don't raise a Tramp error, because it might be
+ ;; suppressed, like in `find-file-noselect-1'.
+ (signal 'file-error
+ (list "File not found on remote host" filename))
-(defun tramp-get-connection-buffer (vec)
- "Get the connection buffer to be used for VEC.
-In case a second asynchronous communication has been started, it is different
-from `tramp-get-buffer'."
- (or (tramp-get-connection-property vec "process-buffer" nil)
- (tramp-get-buffer vec)))
+ (if (and (tramp-local-host-p v)
+ (let (file-name-handler-alist)
+ (file-readable-p localname)))
+ ;; Short track: if we are on the local host, we can
+ ;; run directly.
+ (setq result
+ (tramp-run-real-handler
+ 'insert-file-contents
+ (list localname visit beg end replace)))
-(defun tramp-get-connection-process (vec)
- "Get the connection process to be used for VEC.
-In case a second asynchronous communication has been started, it is different
-from the default one."
- (get-process
- (or (tramp-get-connection-property vec "process-name" nil)
- (tramp-buffer-name vec))))
+ ;; When we shall insert only a part of the file, we copy
+ ;; this part.
+ (when (or beg end)
+ (setq remote-copy (tramp-make-tramp-temp-file v))
+ ;; This is defined in tramp-sh.el. Let's assume this
+ ;; is loaded already.
+ (tramp-compat-funcall 'tramp-send-command
+ v
+ (cond
+ ((and beg end)
+ (format "tail -c +%d %s | head -c +%d >%s"
+ (1+ beg) (tramp-shell-quote-argument localname)
+ (- end beg) remote-copy))
+ (beg
+ (format "tail -c +%d %s >%s"
+ (1+ beg) (tramp-shell-quote-argument localname)
+ remote-copy))
+ (end
+ (format "head -c +%d %s >%s"
+ (1+ end) (tramp-shell-quote-argument localname)
+ remote-copy)))))
-(defun tramp-debug-buffer-name (vec)
- "A name for the debug buffer for VEC."
- ;; We must use `tramp-file-name-real-host', because for gateway
- ;; methods the default port will be expanded later on, which would
- ;; tamper the name.
- (let ((method (tramp-file-name-method vec))
- (user (tramp-file-name-user vec))
- (host (tramp-file-name-real-host vec)))
- (if (not (zerop (length user)))
- (format "*debug tramp/%s %s@%s*" method user host)
- (format "*debug tramp/%s %s*" method host))))
+ ;; `insert-file-contents-literally' takes care to avoid
+ ;; calling jka-compr. By let-binding
+ ;; `inhibit-file-name-operation', we propagate that care
+ ;; to the `file-local-copy' operation.
+ (setq local-copy
+ (let ((inhibit-file-name-operation
+ (when (eq inhibit-file-name-operation
+ 'insert-file-contents)
+ 'file-local-copy)))
+ (cond
+ ((stringp remote-copy)
+ (file-local-copy
+ (tramp-make-tramp-file-name
+ method user host remote-copy)))
+ ((stringp tramp-temp-buffer-file-name)
+ (copy-file filename tramp-temp-buffer-file-name 'ok)
+ tramp-temp-buffer-file-name)
+ (t (file-local-copy filename)))))
-(defconst tramp-debug-outline-regexp
- "[0-9]+:[0-9]+:[0-9]+\\.[0-9]+ [a-z0-9-]+ (\\([0-9]+\\)) #")
+ ;; When the file is not readable for the owner, it
+ ;; cannot be inserted, even it is redable for the group
+ ;; or for everybody.
+ (set-file-modes local-copy (tramp-compat-octal-to-decimal "0600"))
-(defun tramp-get-debug-buffer (vec)
- "Get the debug buffer for VEC."
- (with-current-buffer
- (get-buffer-create (tramp-debug-buffer-name vec))
- (when (bobp)
- (setq buffer-undo-list t)
- ;; Activate `outline-mode'. This runs `text-mode-hook' and
- ;; `outline-mode-hook'. We must prevent that local processes
- ;; die. Yes: I've seen `flyspell-mode', which starts "ispell".
- ;; Furthermore, `outline-regexp' must have the correct value
- ;; already, because it is used by `font-lock-compile-keywords'.
- (let ((default-directory (tramp-compat-temporary-file-directory))
- (outline-regexp tramp-debug-outline-regexp))
- (outline-mode))
- (set (make-local-variable 'outline-regexp) tramp-debug-outline-regexp)
- (set (make-local-variable 'outline-level) 'tramp-outline-level))
- (current-buffer)))
+ (when (and (null remote-copy)
+ (tramp-get-method-parameter
+ method 'tramp-copy-keep-tmpfile))
+ ;; We keep the local file for performance reasons,
+ ;; useful for "rsync".
+ (setq tramp-temp-buffer-file-name local-copy)
+ (put 'tramp-temp-buffer-file-name 'permanent-local t))
-(defun tramp-outline-level ()
- "Return the depth to which a statement is nested in the outline.
-Point must be at the beginning of a header line.
+ (with-progress-reporter
+ v 3 (format "Inserting local temp file `%s'" local-copy)
+ ;; We must ensure that `file-coding-system-alist'
+ ;; matches `local-copy'.
+ (let ((file-coding-system-alist
+ (tramp-find-file-name-coding-system-alist
+ filename local-copy)))
+ (setq result
+ (insert-file-contents
+ local-copy nil nil nil replace))))))
-The outline level is equal to the verbosity of the Tramp message."
- (1+ (string-to-number (match-string 1))))
+ ;; Save exit.
+ (progn
+ (when visit
+ (setq buffer-file-name filename)
+ (setq buffer-read-only (not (file-writable-p filename)))
+ (set-visited-file-modtime)
+ (set-buffer-modified-p nil))
+ (when (and (stringp local-copy)
+ (or remote-copy (null tramp-temp-buffer-file-name)))
+ (delete-file local-copy))
+ (when (stringp remote-copy)
+ (delete-file
+ (tramp-make-tramp-file-name method user host remote-copy))))))
-(defun tramp-find-executable
- (vec progname dirlist &optional ignore-tilde ignore-path)
- "Searches for PROGNAME in $PATH and all directories mentioned in DIRLIST.
-First arg VEC specifies the connection, PROGNAME is the program
-to search for, and DIRLIST gives the list of directories to
-search. If IGNORE-TILDE is non-nil, directory names starting
-with `~' will be ignored. If IGNORE-PATH is non-nil, searches
-only in DIRLIST.
+ ;; Result.
+ (list (expand-file-name filename)
+ (cadr result))))
-Returns the absolute file name of PROGNAME, if found, and nil otherwise.
+(defun tramp-handle-load (file &optional noerror nomessage nosuffix must-suffix)
+ "Like `load' for Tramp files."
+ (with-parsed-tramp-file-name (expand-file-name file) nil
+ (unless nosuffix
+ (cond ((file-exists-p (concat file ".elc"))
+ (setq file (concat file ".elc")))
+ ((file-exists-p (concat file ".el"))
+ (setq file (concat file ".el")))))
+ (when must-suffix
+ ;; The first condition is always true for absolute file names.
+ ;; Included for safety's sake.
+ (unless (or (file-name-directory file)
+ (string-match "\\.elc?\\'" file))
+ (tramp-error
+ v 'file-error
+ "File `%s' does not include a `.el' or `.elc' suffix" file)))
+ (unless noerror
+ (when (not (file-exists-p file))
+ (tramp-error v 'file-error "Cannot load nonexistent file `%s'" file)))
+ (if (not (file-exists-p file))
+ nil
+ (let ((tramp-message-show-message (not nomessage)))
+ (with-progress-reporter v 0 (format "Loading %s" file)
+ (let ((local-copy (file-local-copy file)))
+ ;; MUST-SUFFIX doesn't exist on XEmacs, so let it default to nil.
+ (unwind-protect
+ (load local-copy noerror t t)
+ (delete-file local-copy)))))
+ t)))
-This function expects to be in the right *tramp* buffer."
- (with-current-buffer (tramp-get-connection-buffer vec)
- (let (result)
- ;; Check whether the executable is in $PATH. "which(1)" does not
- ;; report always a correct error code; therefore we check the
- ;; number of words it returns.
- (unless ignore-path
- (tramp-send-command vec (format "which \\%s | wc -w" progname))
- (goto-char (point-min))
- (if (looking-at "^\\s-*1$")
- (setq result (concat "\\" progname))))
- (unless result
- (when ignore-tilde
- ;; Remove all ~/foo directories from dirlist. In XEmacs,
- ;; `remove' is in CL, and we want to avoid CL dependencies.
- (let (newdl d)
- (while dirlist
- (setq d (car dirlist))
- (setq dirlist (cdr dirlist))
- (unless (char-equal ?~ (aref d 0))
- (setq newdl (cons d newdl))))
- (setq dirlist (nreverse newdl))))
- (tramp-send-command
- vec
- (format (concat "while read d; "
- "do if test -x $d/%s -a -f $d/%s; "
- "then echo tramp_executable $d/%s; "
- "break; fi; done <<'EOF'\n"
- "%s\nEOF")
- progname progname progname (mapconcat 'identity dirlist "\n")))
- (goto-char (point-max))
- (when (search-backward "tramp_executable " nil t)
- (skip-chars-forward "^ ")
- (skip-chars-forward " ")
- (setq result (buffer-substring
- (point) (tramp-compat-line-end-position)))))
- result)))
-
-(defun tramp-set-remote-path (vec)
- "Sets the remote environment PATH to existing directories.
-I.e., for each directory in `tramp-remote-path', it is tested
-whether it exists and if so, it is added to the environment
-variable PATH."
- (tramp-message vec 5 (format "Setting $PATH environment variable"))
- (tramp-send-command
- vec (format "PATH=%s; export PATH"
- (mapconcat 'identity (tramp-get-remote-path vec) ":"))))
-
-;; ------------------------------------------------------------
-;; -- Communication with external shell --
-;; ------------------------------------------------------------
-
-(defun tramp-find-file-exists-command (vec)
- "Find a command on the remote host for checking if a file exists.
-Here, we are looking for a command which has zero exit status if the
-file exists and nonzero exit status otherwise."
- (let ((existing "/")
- (nonexisting
- (tramp-shell-quote-argument "/ this file does not exist "))
- result)
- ;; The algorithm is as follows: we try a list of several commands.
- ;; For each command, we first run `$cmd /' -- this should return
- ;; true, as the root directory always exists. And then we run
- ;; `$cmd /this\ file\ does\ not\ exist ', hoping that the file indeed
- ;; does not exist. This should return false. We use the first
- ;; command we find that seems to work.
- ;; The list of commands to try is as follows:
- ;; `ls -d' This works on most systems, but NetBSD 1.4
- ;; has a bug: `ls' always returns zero exit
- ;; status, even for files which don't exist.
- ;; `test -e' Some Bourne shells have a `test' builtin
- ;; which does not know the `-e' option.
- ;; `/bin/test -e' For those, the `test' binary on disk normally
- ;; provides the option. Alas, the binary
- ;; is sometimes `/bin/test' and sometimes it's
- ;; `/usr/bin/test'.
- ;; `/usr/bin/test -e' In case `/bin/test' does not exist.
- (unless (or
- (and (setq result (format "%s -e" (tramp-get-test-command vec)))
- (zerop (tramp-send-command-and-check
- vec (format "%s %s" result existing)))
- (not (zerop (tramp-send-command-and-check
- vec (format "%s %s" result nonexisting)))))
- (and (setq result "/bin/test -e")
- (zerop (tramp-send-command-and-check
- vec (format "%s %s" result existing)))
- (not (zerop (tramp-send-command-and-check
- vec (format "%s %s" result nonexisting)))))
- (and (setq result "/usr/bin/test -e")
- (zerop (tramp-send-command-and-check
- vec (format "%s %s" result existing)))
- (not (zerop (tramp-send-command-and-check
- vec (format "%s %s" result nonexisting)))))
- (and (setq result (format "%s -d" (tramp-get-ls-command vec)))
- (zerop (tramp-send-command-and-check
- vec (format "%s %s" result existing)))
- (not (zerop (tramp-send-command-and-check
- vec (format "%s %s" result nonexisting))))))
- (tramp-error
- vec 'file-error "Couldn't find command to check if file exists"))
- result))
+(defun tramp-handle-substitute-in-file-name (filename)
+ "Like `substitute-in-file-name' for Tramp files.
+\"//\" and \"/~\" substitute only in the local filename part.
+If the URL Tramp syntax is chosen, \"//\" as method delimeter and \"/~\" at
+beginning of local filename are not substituted."
+ ;; First, we must replace environment variables.
+ (setq filename (tramp-replace-environment-variables filename))
+ (with-parsed-tramp-file-name filename nil
+ (if (equal tramp-syntax 'url)
+ ;; We need to check localname only. The other parts cannot contain
+ ;; "//" or "/~".
+ (if (and (> (length localname) 1)
+ (or (string-match "//" localname)
+ (string-match "/~" localname 1)))
+ (tramp-run-real-handler 'substitute-in-file-name (list filename))
+ (tramp-make-tramp-file-name
+ (when method (substitute-in-file-name method))
+ (when user (substitute-in-file-name user))
+ (when host (substitute-in-file-name host))
+ (when localname
+ (tramp-run-real-handler
+ 'substitute-in-file-name (list localname)))))
+ ;; Ignore in LOCALNAME everything before "//" or "/~".
+ (when (and (stringp localname) (string-match ".+?/\\(/\\|~\\)" localname))
+ (setq filename
+ (concat (file-remote-p filename)
+ (replace-match "\\1" nil nil localname)))
+ ;; "/m:h:~" does not work for completion. We use "/m:h:~/".
+ (when (string-match "~$" filename)
+ (setq filename (concat filename "/"))))
+ (tramp-run-real-handler 'substitute-in-file-name (list filename)))))
-(defun tramp-open-shell (vec shell)
- "Opens shell SHELL."
- (with-progress-reporter vec 5 (format "Opening remote shell `%s'" shell)
- ;; Find arguments for this shell.
- (let ((tramp-end-of-output tramp-initial-end-of-output)
- (alist tramp-sh-extra-args)
- item extra-args)
- (while (and alist (null extra-args))
- (setq item (pop alist))
- (when (string-match (car item) shell)
- (setq extra-args (cdr item))))
- (when extra-args (setq shell (concat shell " " extra-args)))
- (tramp-send-command
- vec (format "exec env ENV='' PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s"
- (shell-quote-argument tramp-end-of-output) shell)
- t))
- ;; Setting prompts.
- (tramp-send-command
- vec (format "PS1=%s" (shell-quote-argument tramp-end-of-output)) t)
- (tramp-send-command vec "PS2=''" t)
- (tramp-send-command vec "PS3=''" t)
- (tramp-send-command vec "PROMPT_COMMAND=''" t)))
-
-(defun tramp-find-shell (vec)
- "Opens a shell on the remote host which groks tilde expansion."
- (unless (tramp-get-connection-property vec "remote-shell" nil)
- (let (shell)
- (with-current-buffer (tramp-get-buffer vec)
- (tramp-send-command vec "echo ~root" t)
- (cond
- ((or (string-match "^~root$" (buffer-string))
- ;; The default shell (ksh93) of OpenSolaris is buggy.
- (string-equal (tramp-get-connection-property vec "uname" "")
- "SunOS 5.11"))
- (setq shell
- (or (tramp-find-executable
- vec "bash" (tramp-get-remote-path vec) t t)
- (tramp-find-executable
- vec "ksh" (tramp-get-remote-path vec) t t)))
- (unless shell
- (tramp-error
- vec 'file-error
- "Couldn't find a shell which groks tilde expansion"))
- (tramp-message
- vec 5 "Starting remote shell `%s' for tilde expansion" shell)
- (tramp-open-shell vec shell))
-
- (t (tramp-message
- vec 5 "Remote `%s' groks tilde expansion, good"
- (tramp-set-connection-property
- vec "remote-shell"
- (tramp-get-method-parameter
- (tramp-file-name-method vec) 'tramp-remote-sh)))))))))
-
-;; ------------------------------------------------------------
-;; -- Functions for establishing connection --
-;; ------------------------------------------------------------
+(defun tramp-handle-unhandled-file-name-directory (filename)
+ "Like `unhandled-file-name-directory' for Tramp files."
+ ;; With Emacs 23, we could simply return `nil'. But we must keep it
+ ;; for backward compatibility.
+ (expand-file-name "~/"))
+
+;;; Functions for establishing connection:
;; The following functions are actions to be taken when seeing certain
;; prompts from the remote host. See the variable
@@ -6783,7 +3040,7 @@ The terminal type can be configured with `tramp-terminal-type'."
(throw 'tramp-action 'process-died))))
(t nil)))
-;; Functions for processing the actions.
+;;; Functions for processing the actions:
(defun tramp-process-one-action (proc vec actions)
"Wait for output from the shell and perform one action."
@@ -6807,7 +3064,7 @@ The terminal type can be configured with `tramp-terminal-type'."
(defun tramp-process-actions (proc vec actions &optional timeout)
"Perform actions until success or TIMEOUT."
;; Preserve message for `progress-reporter'.
- (with-temp-message ""
+ (tramp-compat-with-temp-message ""
;; Enable auth-source and password-cache.
(tramp-set-connection-property vec "first-password-request" t)
(let (exit)
@@ -6831,7 +3088,7 @@ The terminal type can be configured with `tramp-terminal-type'."
((eq exit 'process-died) "Process died")
(t "Login failed")))))))
-;; Utility functions.
+:;; Utility functions:
(defun tramp-accept-process-output (&optional proc timeout timeout-msecs)
"Like `accept-process-output' for Tramp processes.
@@ -6915,17 +3172,6 @@ nil."
(tramp-error proc 'file-error "[[Regexp `%s' not found]]" regexp)))
found)))
-(defun tramp-barf-if-no-shell-prompt (proc timeout &rest error-args)
- "Wait for shell prompt and barf if none appears.
-Looks at process PROC to see if a shell prompt appears in TIMEOUT
-seconds. If not, it produces an error message with the given ERROR-ARGS."
- (unless
- (tramp-wait-for-regexp
- proc timeout
- (format
- "\\(%s\\|%s\\)\\'" shell-prompt-pattern tramp-shell-prompt-pattern))
- (apply 'tramp-error-with-buffer nil proc 'file-error error-args)))
-
;; We don't call `tramp-send-string' in order to hide the password
;; from the debug buffer, and because end-of-line handling of the
;; string.
@@ -6938,831 +3184,6 @@ seconds. If not, it produces an error message with the given ERROR-ARGS."
'tramp-password-end-of-line)
tramp-default-password-end-of-line))))
-(defun tramp-open-connection-setup-interactive-shell (proc vec)
- "Set up an interactive shell.
-Mainly sets the prompt and the echo correctly. PROC is the shell
-process to set up. VEC specifies the connection."
- (let ((tramp-end-of-output tramp-initial-end-of-output))
- ;; It is useful to set the prompt in the following command because
- ;; some people have a setting for $PS1 which /bin/sh doesn't know
- ;; about and thus /bin/sh will display a strange prompt. For
- ;; example, if $PS1 has "${CWD}" in the value, then ksh will
- ;; display the current working directory but /bin/sh will display
- ;; a dollar sign. The following command line sets $PS1 to a sane
- ;; value, and works under Bourne-ish shells as well as csh-like
- ;; shells. Daniel Pittman reports that the unusual positioning of
- ;; the single quotes makes it work under `rc', too. We also unset
- ;; the variable $ENV because that is read by some sh
- ;; implementations (eg, bash when called as sh) on startup; this
- ;; way, we avoid the startup file clobbering $PS1. $PROMP_COMMAND
- ;; is another way to set the prompt in /bin/bash, it must be
- ;; discarded as well.
- (tramp-open-shell
- vec
- (tramp-get-method-parameter (tramp-file-name-method vec) 'tramp-remote-sh))
-
- ;; Disable echo.
- (tramp-message vec 5 "Setting up remote shell environment")
- (tramp-send-command vec "stty -inlcr -echo kill '^U' erase '^H'" t)
- ;; Check whether the echo has really been disabled. Some
- ;; implementations, like busybox of embedded GNU/Linux, don't
- ;; support disabling.
- (tramp-send-command vec "echo foo" t)
- (with-current-buffer (process-buffer proc)
- (goto-char (point-min))
- (when (looking-at "echo foo")
- (tramp-set-connection-property proc "remote-echo" t)
- (tramp-message vec 5 "Remote echo still on. Ok.")
- ;; Make sure backspaces and their echo are enabled and no line
- ;; width magic interferes with them.
- (tramp-send-command vec "stty icanon erase ^H cols 32767" t))))
-
- (tramp-message vec 5 "Setting shell prompt")
- (tramp-send-command
- vec (format "PS1=%s" (shell-quote-argument tramp-end-of-output)) t)
- (tramp-send-command vec "PS2=''" t)
- (tramp-send-command vec "PS3=''" t)
- (tramp-send-command vec "PROMPT_COMMAND=''" t)
-
- ;; Try to set up the coding system correctly.
- ;; CCC this can't be the right way to do it. Hm.
- (tramp-message vec 5 "Determining coding system")
- (tramp-send-command vec "echo foo ; echo bar" t)
- (with-current-buffer (process-buffer proc)
- (goto-char (point-min))
- (if (featurep 'mule)
- ;; Use MULE to select the right EOL convention for communicating
- ;; with the process.
- (let* ((cs (or (tramp-compat-funcall 'process-coding-system proc)
- (cons 'undecided 'undecided)))
- cs-decode cs-encode)
- (when (symbolp cs) (setq cs (cons cs cs)))
- (setq cs-decode (car cs))
- (setq cs-encode (cdr cs))
- (unless cs-decode (setq cs-decode 'undecided))
- (unless cs-encode (setq cs-encode 'undecided))
- (setq cs-encode (tramp-coding-system-change-eol-conversion
- cs-encode 'unix))
- (when (search-forward "\r" nil t)
- (setq cs-decode (tramp-coding-system-change-eol-conversion
- cs-decode 'dos)))
- (tramp-compat-funcall
- 'set-buffer-process-coding-system cs-decode cs-encode)
- (tramp-message
- vec 5 "Setting coding system to `%s' and `%s'" cs-decode cs-encode))
- ;; Look for ^M and do something useful if found.
- (when (search-forward "\r" nil t)
- ;; We have found a ^M but cannot frob the process coding system
- ;; because we're running on a non-MULE Emacs. Let's try
- ;; stty, instead.
- (tramp-send-command vec "stty -onlcr" t))))
-
- (tramp-send-command vec "set +o vi +o emacs" t)
-
- ;; Check whether the output of "uname -sr" has been changed. If
- ;; yes, this is a strong indication that we must expire all
- ;; connection properties. We start again with
- ;; `tramp-maybe-open-connection', it will be catched there.
- (tramp-message vec 5 "Checking system information")
- (let ((old-uname (tramp-get-connection-property vec "uname" nil))
- (new-uname
- (tramp-set-connection-property
- vec "uname"
- (tramp-send-command-and-read vec "echo \\\"`uname -sr`\\\""))))
- (when (and (stringp old-uname) (not (string-equal old-uname new-uname)))
- (with-current-buffer (tramp-get-debug-buffer vec)
- ;; Keep the debug buffer.
- (rename-buffer
- (generate-new-buffer-name tramp-temp-buffer-name) 'unique)
- (tramp-compat-funcall 'tramp-cleanup-connection vec)
- (if (= (point-min) (point-max))
- (kill-buffer nil)
- (rename-buffer (tramp-debug-buffer-name vec) 'unique))
- ;; We call `tramp-get-buffer' in order to keep the debug buffer.
- (tramp-get-buffer vec)
- (tramp-message
- vec 3
- "Connection reset, because remote host changed from `%s' to `%s'"
- old-uname new-uname)
- (throw 'uname-changed (tramp-maybe-open-connection vec)))))
-
- ;; Check whether the remote host suffers from buggy
- ;; `send-process-string'. This is known for FreeBSD (see comment in
- ;; `send_process', file process.c). I've tested sending 624 bytes
- ;; successfully, sending 625 bytes failed. Emacs makes a hack when
- ;; this host type is detected locally. It cannot handle remote
- ;; hosts, though.
- (with-connection-property proc "chunksize"
- (cond
- ((and (integerp tramp-chunksize) (> tramp-chunksize 0))
- tramp-chunksize)
- (t
- (tramp-message
- vec 5 "Checking remote host type for `send-process-string' bug")
- (if (string-match
- "^FreeBSD" (tramp-get-connection-property vec "uname" ""))
- 500 0))))
-
- ;; Set remote PATH variable.
- (tramp-set-remote-path vec)
-
- ;; Search for a good shell before searching for a command which
- ;; checks if a file exists. This is done because Tramp wants to use
- ;; "test foo; echo $?" to check if various conditions hold, and
- ;; there are buggy /bin/sh implementations which don't execute the
- ;; "echo $?" part if the "test" part has an error. In particular,
- ;; the OpenSolaris /bin/sh is a problem. There are also other
- ;; problems with /bin/sh of OpenSolaris, like redirection of stderr
- ;; in function declarations, or changing HISTFILE in place.
- ;; Therefore, OpenSolaris' /bin/sh is replaced by bash, when
- ;; detected.
- (tramp-find-shell vec)
-
- ;; Disable unexpected output.
- (tramp-send-command vec "mesg n; biff n" t)
-
- ;; IRIX64 bash expands "!" even when in single quotes. This
- ;; destroys our shell functions, we must disable it. See
- ;; <http://stackoverflow.com/questions/3291692/irix-bash-shell-expands-expression-in-single-quotes-yet-shouldnt>.
- (when (string-match "^IRIX64" (tramp-get-connection-property vec "uname" ""))
- (tramp-send-command vec "set +H" t))
-
- ;; On BSD-like systems, ?\t is expanded to spaces. Suppress this.
- (when (string-match "BSD\\|Darwin"
- (tramp-get-connection-property vec "uname" ""))
- (tramp-send-command vec "stty -oxtabs" t))
-
- ;; Set `remote-tty' process property.
- (ignore-errors
- (let ((tty (tramp-send-command-and-read vec "echo \\\"`tty`\\\"")))
- (unless (zerop (length tty)) (process-put proc 'remote-tty tty))))
-
- ;; Dump stty settings in the traces.
- (when (>= tramp-verbose 9)
- (tramp-send-command vec "stty -a" t))
-
- ;; Set the environment.
- (tramp-message vec 5 "Setting default environment")
-
- (let ((env (copy-sequence tramp-remote-process-environment))
- unset item)
- (while env
- (setq item (tramp-compat-split-string (car env) "="))
- (setcdr item (mapconcat 'identity (cdr item) "="))
- (if (and (stringp (cdr item)) (not (string-equal (cdr item) "")))
- (tramp-send-command
- vec (format "%s=%s; export %s" (car item) (cdr item) (car item)) t)
- (push (car item) unset))
- (setq env (cdr env)))
- (when unset
- (tramp-send-command
- vec (format "unset %s" (mapconcat 'identity unset " ")) t))))
-
-;; CCC: We should either implement a Perl version of base64 encoding
-;; and decoding. Then we just use that in the last item. The other
-;; alternative is to use the Perl version of UU encoding. But then
-;; we need a Lisp version of uuencode.
-;;
-;; Old text from documentation of tramp-methods:
-;; Using a uuencode/uudecode inline method is discouraged, please use one
-;; of the base64 methods instead since base64 encoding is much more
-;; reliable and the commands are more standardized between the different
-;; Unix versions. But if you can't use base64 for some reason, please
-;; note that the default uudecode command does not work well for some
-;; Unices, in particular AIX and Irix. For AIX, you might want to use
-;; the following command for uudecode:
-;;
-;; sed '/^begin/d;/^[` ]$/d;/^end/d' | iconv -f uucode -t ISO8859-1
-;;
-;; For Irix, no solution is known yet.
-
-(defconst tramp-local-coding-commands
- '((b64 base64-encode-region base64-decode-region)
- (uu tramp-uuencode-region uudecode-decode-region)
- (pack
- "perl -e 'binmode STDIN; binmode STDOUT; print pack(q{u*}, join q{}, <>)'"
- "perl -e 'binmode STDIN; binmode STDOUT; print unpack(q{u*}, join q{}, <>)'"))
- "List of local coding commands for inline transfer.
-Each item is a list that looks like this:
-
-\(FORMAT ENCODING DECODING\)
-
-FORMAT is symbol describing the encoding/decoding format. It can be
-`b64' for base64 encoding, `uu' for uu encoding, or `pack' for simple packing.
-
-ENCODING and DECODING can be strings, giving commands, or symbols,
-giving functions. If they are strings, then they can contain
-the \"%s\" format specifier. If that specifier is present, the input
-filename will be put into the command line at that spot. If the
-specifier is not present, the input should be read from standard
-input.
-
-If they are functions, they will be called with two arguments, start
-and end of region, and are expected to replace the region contents
-with the encoded or decoded results, respectively.")
-
-(defconst tramp-remote-coding-commands
- '((b64 "base64" "base64 -d -i")
- ;; "-i" is more robust with older base64 from GNU coreutils.
- ;; However, I don't know whether all base64 versions do supports
- ;; this option.
- (b64 "base64" "base64 -d")
- (b64 "mimencode -b" "mimencode -u -b")
- (b64 "mmencode -b" "mmencode -u -b")
- (b64 "recode data..base64" "recode base64..data")
- (b64 tramp-perl-encode-with-module tramp-perl-decode-with-module)
- (b64 tramp-perl-encode tramp-perl-decode)
- (uu "uuencode xxx" "uudecode -o /dev/stdout")
- (uu "uuencode xxx" "uudecode -o -")
- (uu "uuencode xxx" "uudecode -p")
- (uu "uuencode xxx" tramp-uudecode)
- (pack
- "perl -e 'binmode STDIN; binmode STDOUT; print pack(q{u*}, join q{}, <>)'"
- "perl -e 'binmode STDIN; binmode STDOUT; print unpack(q{u*}, join q{}, <>)'"))
- "List of remote coding commands for inline transfer.
-Each item is a list that looks like this:
-
-\(FORMAT ENCODING DECODING\)
-
-FORMAT is symbol describing the encoding/decoding format. It can be
-`b64' for base64 encoding, `uu' for uu encoding, or `pack' for simple packing.
-
-ENCODING and DECODING can be strings, giving commands, or symbols,
-giving variables. If they are strings, then they can contain
-the \"%s\" format specifier. If that specifier is present, the input
-filename will be put into the command line at that spot. If the
-specifier is not present, the input should be read from standard
-input.
-
-If they are variables, this variable is a string containing a Perl
-implementation for this functionality. This Perl program will be transferred
-to the remote host, and it is available as shell function with the same name.")
-
-(defun tramp-find-inline-encoding (vec)
- "Find an inline transfer encoding that works.
-Goes through the list `tramp-local-coding-commands' and
-`tramp-remote-coding-commands'."
- (save-excursion
- (let ((local-commands tramp-local-coding-commands)
- (magic "xyzzy")
- loc-enc loc-dec rem-enc rem-dec litem ritem found)
- (while (and local-commands (not found))
- (setq litem (pop local-commands))
- (catch 'wont-work-local
- (let ((format (nth 0 litem))
- (remote-commands tramp-remote-coding-commands))
- (setq loc-enc (nth 1 litem))
- (setq loc-dec (nth 2 litem))
- ;; If the local encoder or decoder is a string, the
- ;; corresponding command has to work locally.
- (if (not (stringp loc-enc))
- (tramp-message
- vec 5 "Checking local encoding function `%s'" loc-enc)
- (tramp-message
- vec 5 "Checking local encoding command `%s' for sanity" loc-enc)
- (unless (zerop (tramp-call-local-coding-command
- loc-enc nil nil))
- (throw 'wont-work-local nil)))
- (if (not (stringp loc-dec))
- (tramp-message
- vec 5 "Checking local decoding function `%s'" loc-dec)
- (tramp-message
- vec 5 "Checking local decoding command `%s' for sanity" loc-dec)
- (unless (zerop (tramp-call-local-coding-command
- loc-dec nil nil))
- (throw 'wont-work-local nil)))
- ;; Search for remote coding commands with the same format
- (while (and remote-commands (not found))
- (setq ritem (pop remote-commands))
- (catch 'wont-work-remote
- (when (equal format (nth 0 ritem))
- (setq rem-enc (nth 1 ritem))
- (setq rem-dec (nth 2 ritem))
- ;; Check if remote encoding and decoding commands can be
- ;; called remotely with null input and output. This makes
- ;; sure there are no syntax errors and the command is really
- ;; found. Note that we do not redirect stdout to /dev/null,
- ;; for two reasons: when checking the decoding command, we
- ;; actually check the output it gives. And also, when
- ;; redirecting "mimencode" output to /dev/null, then as root
- ;; it might change the permissions of /dev/null!
- (when (not (stringp rem-enc))
- (let ((name (symbol-name rem-enc)))
- (while (string-match (regexp-quote "-") name)
- (setq name (replace-match "_" nil t name)))
- (tramp-maybe-send-script vec (symbol-value rem-enc) name)
- (setq rem-enc name)))
- (tramp-message
- vec 5
- "Checking remote encoding command `%s' for sanity" rem-enc)
- (unless (zerop (tramp-send-command-and-check
- vec (format "%s </dev/null" rem-enc) t))
- (throw 'wont-work-remote nil))
-
- (when (not (stringp rem-dec))
- (let ((name (symbol-name rem-dec)))
- (while (string-match (regexp-quote "-") name)
- (setq name (replace-match "_" nil t name)))
- (tramp-maybe-send-script vec (symbol-value rem-dec) name)
- (setq rem-dec name)))
- (tramp-message
- vec 5
- "Checking remote decoding command `%s' for sanity" rem-dec)
- (unless (zerop (tramp-send-command-and-check
- vec
- (format "echo %s | %s | %s"
- magic rem-enc rem-dec)
- t))
- (throw 'wont-work-remote nil))
-
- (with-current-buffer (tramp-get-buffer vec)
- (goto-char (point-min))
- (unless (looking-at (regexp-quote magic))
- (throw 'wont-work-remote nil)))
-
- ;; `rem-enc' and `rem-dec' could be a string meanwhile.
- (setq rem-enc (nth 1 ritem))
- (setq rem-dec (nth 2 ritem))
- (setq found t)))))))
-
- ;; Did we find something?
- (unless found
- (tramp-error
- vec 'file-error "Couldn't find an inline transfer encoding"))
-
- ;; Set connection properties.
- (tramp-message vec 5 "Using local encoding `%s'" loc-enc)
- (tramp-set-connection-property vec "local-encoding" loc-enc)
- (tramp-message vec 5 "Using local decoding `%s'" loc-dec)
- (tramp-set-connection-property vec "local-decoding" loc-dec)
- (tramp-message vec 5 "Using remote encoding `%s'" rem-enc)
- (tramp-set-connection-property vec "remote-encoding" rem-enc)
- (tramp-message vec 5 "Using remote decoding `%s'" rem-dec)
- (tramp-set-connection-property vec "remote-decoding" rem-dec))))
-
-(defun tramp-call-local-coding-command (cmd input output)
- "Call the local encoding or decoding command.
-If CMD contains \"%s\", provide input file INPUT there in command.
-Otherwise, INPUT is passed via standard input.
-INPUT can also be nil which means `/dev/null'.
-OUTPUT can be a string (which specifies a filename), or t (which
-means standard output and thus the current buffer), or nil (which
-means discard it)."
- (tramp-local-call-process
- tramp-encoding-shell
- (when (and input (not (string-match "%s" cmd))) input)
- (if (eq output t) t nil)
- nil
- tramp-encoding-command-switch
- (concat
- (if (string-match "%s" cmd) (format cmd input) cmd)
- (if (stringp output) (concat "> " output) ""))))
-
-(defconst tramp-inline-compress-commands
- '(("gzip" "gzip -d")
- ("bzip2" "bzip2 -d")
- ("compress" "compress -d"))
- "List of compress and decompress commands for inline transfer.
-Each item is a list that looks like this:
-
-\(COMPRESS DECOMPRESS\)
-
-COMPRESS or DECOMPRESS are strings with the respective commands.")
-
-(defun tramp-find-inline-compress (vec)
- "Find an inline transfer compress command that works.
-Goes through the list `tramp-inline-compress-commands'."
- (save-excursion
- (let ((commands tramp-inline-compress-commands)
- (magic "xyzzy")
- item compress decompress
- found)
- (while (and commands (not found))
- (catch 'next
- (setq item (pop commands)
- compress (nth 0 item)
- decompress (nth 1 item))
- (tramp-message
- vec 5
- "Checking local compress command `%s', `%s' for sanity"
- compress decompress)
- (unless (zerop (tramp-call-local-coding-command
- (format "echo %s | %s | %s"
- magic compress decompress) nil nil))
- (throw 'next nil))
- (tramp-message
- vec 5
- "Checking remote compress command `%s', `%s' for sanity"
- compress decompress)
- (unless (zerop (tramp-send-command-and-check
- vec (format "echo %s | %s | %s"
- magic compress decompress) t))
- (throw 'next nil))
- (setq found t)))
-
- ;; Did we find something?
- (if found
- (progn
- ;; Set connection properties.
- (tramp-message
- vec 5 "Using inline transfer compress command `%s'" compress)
- (tramp-set-connection-property vec "inline-compress" compress)
- (tramp-message
- vec 5 "Using inline transfer decompress command `%s'" decompress)
- (tramp-set-connection-property vec "inline-decompress" decompress))
-
- (tramp-set-connection-property vec "inline-compress" nil)
- (tramp-set-connection-property vec "inline-decompress" nil)
- (tramp-message
- vec 2 "Couldn't find an inline transfer compress command")))))
-
-(defun tramp-compute-multi-hops (vec)
- "Expands VEC according to `tramp-default-proxies-alist'.
-Gateway hops are already opened."
- (let ((target-alist `(,vec))
- (choices tramp-default-proxies-alist)
- item proxy)
-
- ;; Look for proxy hosts to be passed.
- (while choices
- (setq item (pop choices)
- proxy (eval (nth 2 item)))
- (when (and
- ;; host
- (string-match (or (eval (nth 0 item)) "")
- (or (tramp-file-name-host (car target-alist)) ""))
- ;; user
- (string-match (or (eval (nth 1 item)) "")
- (or (tramp-file-name-user (car target-alist)) "")))
- (if (null proxy)
- ;; No more hops needed.
- (setq choices nil)
- ;; Replace placeholders.
- (setq proxy
- (format-spec
- proxy
- (format-spec-make
- ?u (or (tramp-file-name-user (car target-alist)) "")
- ?h (or (tramp-file-name-host (car target-alist)) ""))))
- (with-parsed-tramp-file-name proxy l
- ;; Add the hop.
- (add-to-list 'target-alist l)
- ;; Start next search.
- (setq choices tramp-default-proxies-alist)))))
-
- ;; Handle gateways.
- (when (and (boundp 'tramp-gw-tunnel-method)
- (string-match (format
- "^\\(%s\\|%s\\)$"
- (symbol-value 'tramp-gw-tunnel-method)
- (symbol-value 'tramp-gw-socks-method))
- (tramp-file-name-method (car target-alist))))
- (let ((gw (pop target-alist))
- (hop (pop target-alist)))
- ;; Is the method prepared for gateways?
- (unless (tramp-get-method-parameter
- (tramp-file-name-method hop) 'tramp-default-port)
- (tramp-error
- vec 'file-error
- "Method `%s' is not supported for gateway access."
- (tramp-file-name-method hop)))
- ;; Add default port if needed.
- (unless
- (string-match
- tramp-host-with-port-regexp (tramp-file-name-host hop))
- (aset hop 2
- (concat
- (tramp-file-name-host hop) tramp-prefix-port-format
- (number-to-string
- (tramp-get-method-parameter
- (tramp-file-name-method hop) 'tramp-default-port)))))
- ;; Open the gateway connection.
- (add-to-list
- 'target-alist
- (vector
- (tramp-file-name-method hop) (tramp-file-name-user hop)
- (tramp-compat-funcall 'tramp-gw-open-connection vec gw hop) nil))
- ;; For the password prompt, we need the correct values.
- ;; Therefore, we must remember the gateway vector. But we
- ;; cannot do it as connection property, because it shouldn't
- ;; be persistent. And we have no started process yet either.
- (tramp-set-file-property (car target-alist) "" "gateway" hop)))
-
- ;; Foreign and out-of-band methods are not supported for multi-hops.
- (when (cdr target-alist)
- (setq choices target-alist)
- (while choices
- (setq item (pop choices))
- (when
- (or
- (not
- (tramp-get-method-parameter
- (tramp-file-name-method item) 'tramp-login-program))
- (tramp-get-method-parameter
- (tramp-file-name-method item) 'tramp-copy-program))
- (tramp-error
- vec 'file-error
- "Method `%s' is not supported for multi-hops."
- (tramp-file-name-method item)))))
-
- ;; In case the host name is not used for the remote shell
- ;; command, the user could be misguided by applying a random
- ;; hostname.
- (let* ((v (car target-alist))
- (method (tramp-file-name-method v))
- (host (tramp-file-name-host v)))
- (unless
- (or
- ;; There are multi-hops.
- (cdr target-alist)
- ;; The host name is used for the remote shell command.
- (member
- '("%h") (tramp-get-method-parameter method 'tramp-login-args))
- ;; The host is local. We cannot use `tramp-local-host-p'
- ;; here, because it opens a connection as well.
- (string-match tramp-local-host-regexp host))
- (tramp-error
- v 'file-error
- "Host `%s' looks like a remote host, `%s' can only use the local host"
- host method)))
-
- ;; Result.
- target-alist))
-
-(defun tramp-maybe-open-connection (vec)
- "Maybe open a connection VEC.
-Does not do anything if a connection is already open, but re-opens the
-connection if a previous connection has died for some reason."
- (catch 'uname-changed
- (let ((p (tramp-get-connection-process vec))
- (process-name (tramp-get-connection-property vec "process-name" nil))
- (process-environment (copy-sequence process-environment)))
-
- ;; If too much time has passed since last command was sent, look
- ;; whether process is still alive. If it isn't, kill it. When
- ;; using ssh, it can sometimes happen that the remote end has
- ;; hung up but the local ssh client doesn't recognize this until
- ;; it tries to send some data to the remote end. So that's why
- ;; we try to send a command from time to time, then look again
- ;; whether the process is really alive.
- (condition-case nil
- (when (and (> (tramp-time-diff
- (current-time)
- (tramp-get-connection-property
- p "last-cmd-time" '(0 0 0)))
- 60)
- p (processp p) (memq (process-status p) '(run open)))
- (tramp-send-command vec "echo are you awake" t t)
- (unless (and (memq (process-status p) '(run open))
- (tramp-wait-for-output p 10))
- ;; The error will be catched locally.
- (tramp-error vec 'file-error "Awake did fail")))
- (file-error
- (tramp-flush-connection-property vec)
- (tramp-flush-connection-property p)
- (delete-process p)
- (setq p nil)))
-
- ;; New connection must be opened.
- (unless (and p (processp p) (memq (process-status p) '(run open)))
-
- ;; We call `tramp-get-buffer' in order to get a debug buffer for
- ;; messages from the beginning.
- (tramp-get-buffer vec)
- (with-progress-reporter
- vec 3
- (if (zerop (length (tramp-file-name-user vec)))
- (format "Opening connection for %s using %s"
- (tramp-file-name-host vec)
- (tramp-file-name-method vec))
- (format "Opening connection for %s@%s using %s"
- (tramp-file-name-user vec)
- (tramp-file-name-host vec)
- (tramp-file-name-method vec)))
-
- ;; Start new process.
- (when (and p (processp p))
- (delete-process p))
- (setenv "TERM" tramp-terminal-type)
- (setenv "LC_ALL" "C")
- (setenv "PROMPT_COMMAND")
- (setenv "PS1" tramp-initial-end-of-output)
- (let* ((target-alist (tramp-compute-multi-hops vec))
- (process-connection-type tramp-process-connection-type)
- (process-adaptive-read-buffering nil)
- (coding-system-for-read nil)
- ;; This must be done in order to avoid our file name handler.
- (p (let ((default-directory
- (tramp-compat-temporary-file-directory)))
- (start-process
- (or process-name (tramp-buffer-name vec))
- (tramp-get-connection-buffer vec)
- tramp-encoding-shell))))
-
- (tramp-message
- vec 6 "%s" (mapconcat 'identity (process-command p) " "))
-
- ;; Check whether process is alive.
- (tramp-set-process-query-on-exit-flag p nil)
- (tramp-barf-if-no-shell-prompt
- p 60 "Couldn't find local shell prompt %s" tramp-encoding-shell)
-
- ;; Now do all the connections as specified.
- (while target-alist
- (let* ((hop (car target-alist))
- (l-method (tramp-file-name-method hop))
- (l-user (tramp-file-name-user hop))
- (l-host (tramp-file-name-host hop))
- (l-port nil)
- (login-program
- (tramp-get-method-parameter
- l-method 'tramp-login-program))
- (login-args
- (tramp-get-method-parameter l-method 'tramp-login-args))
- (async-args
- (tramp-get-method-parameter l-method 'tramp-async-args))
- (gw-args
- (tramp-get-method-parameter l-method 'tramp-gw-args))
- (gw (tramp-get-file-property hop "" "gateway" nil))
- (g-method (and gw (tramp-file-name-method gw)))
- (g-user (and gw (tramp-file-name-user gw)))
- (g-host (and gw (tramp-file-name-host gw)))
- (command login-program)
- ;; We don't create the temporary file. In fact,
- ;; it is just a prefix for the ControlPath option
- ;; of ssh; the real temporary file has another
- ;; name, and it is created and protected by ssh.
- ;; It is also removed by ssh, when the connection
- ;; is closed.
- (tmpfile
- (tramp-set-connection-property
- p "temp-file"
- (make-temp-name
- (expand-file-name
- tramp-temp-name-prefix
- (tramp-compat-temporary-file-directory)))))
- spec)
-
- ;; Add arguments for asynchrononous processes.
- (when (and process-name async-args)
- (setq login-args (append async-args login-args)))
-
- ;; Add gateway arguments if necessary.
- (when (and gw gw-args)
- (setq login-args (append gw-args login-args)))
-
- ;; Check for port number. Until now, there's no need
- ;; for handling like method, user, host.
- (when (string-match tramp-host-with-port-regexp l-host)
- (setq l-port (match-string 2 l-host)
- l-host (match-string 1 l-host)))
-
- ;; Set variables for computing the prompt for reading
- ;; password. They can also be derived from a gateway.
- (setq tramp-current-method (or g-method l-method)
- tramp-current-user (or g-user l-user)
- tramp-current-host (or g-host l-host))
-
- ;; Replace login-args place holders.
- (setq
- l-host (or l-host "")
- l-user (or l-user "")
- l-port (or l-port "")
- spec (format-spec-make
- ?h l-host ?u l-user ?p l-port ?t tmpfile)
- command
- (concat
- ;; We do not want to see the trailing local prompt in
- ;; `start-file-process'.
- (unless (memq system-type '(windows-nt)) "exec ")
- command " "
- (mapconcat
- (lambda (x)
- (setq x (mapcar (lambda (y) (format-spec y spec)) x))
- (unless (member "" x) (mapconcat 'identity x " ")))
- login-args " ")
- ;; Local shell could be a Windows COMSPEC. It
- ;; doesn't know the ";" syntax, but we must exit
- ;; always for `start-file-process'. "exec" does not
- ;; work either.
- (if (memq system-type '(windows-nt)) " && exit || exit")))
-
- ;; Send the command.
- (tramp-message vec 3 "Sending command `%s'" command)
- (tramp-send-command vec command t t)
- (tramp-process-actions p vec tramp-actions-before-shell 60)
- (tramp-message
- vec 3 "Found remote shell prompt on `%s'" l-host))
- ;; Next hop.
- (setq target-alist (cdr target-alist)))
-
- ;; Make initial shell settings.
- (tramp-open-connection-setup-interactive-shell p vec)))))))
-
-(defun tramp-send-command (vec command &optional neveropen nooutput)
- "Send the COMMAND to connection VEC.
-Erases temporary buffer before sending the command. If optional
-arg NEVEROPEN is non-nil, never try to open the connection. This
-is meant to be used from `tramp-maybe-open-connection' only. The
-function waits for output unless NOOUTPUT is set."
- (unless neveropen (tramp-maybe-open-connection vec))
- (let ((p (tramp-get-connection-process vec)))
- (when (tramp-get-connection-property p "remote-echo" nil)
- ;; We mark the command string that it can be erased in the output buffer.
- (tramp-set-connection-property p "check-remote-echo" t)
- (setq command (format "%s%s%s" tramp-echo-mark command tramp-echo-mark)))
- (tramp-message vec 6 "%s" command)
- (tramp-send-string vec command)
- (unless nooutput (tramp-wait-for-output p))))
-
-(defun tramp-wait-for-output (proc &optional timeout)
- "Wait for output from remote command."
- (unless (buffer-live-p (process-buffer proc))
- (delete-process proc)
- (tramp-error proc 'file-error "Process `%s' not available, try again" proc))
- (with-current-buffer (process-buffer proc)
- (let* (;; Initially, `tramp-end-of-output' is "#$ ". There might
- ;; be leading escape sequences, which must be ignored.
- (regexp (format "[^#$\n]*%s\r?$" (regexp-quote tramp-end-of-output)))
- ;; Sometimes, the commands do not return a newline but a
- ;; null byte before the shell prompt, for example "git
- ;; ls-files -c -z ...".
- (regexp1 (format "\\(^\\|\000\\)%s" regexp))
- (found (tramp-wait-for-regexp proc timeout regexp1)))
- (if found
- (let (buffer-read-only)
- ;; A simple-minded busybox has sent " ^H" sequences.
- ;; Delete them.
- (goto-char (point-min))
- (when (re-search-forward
- "^\\(.\b\\)+$" (tramp-compat-line-end-position) t)
- (forward-line 1)
- (delete-region (point-min) (point)))
- ;; Delete the prompt.
- (goto-char (point-max))
- (re-search-backward regexp nil t)
- (delete-region (point) (point-max)))
- (if timeout
- (tramp-error
- proc 'file-error
- "[[Remote prompt `%s' not found in %d secs]]"
- tramp-end-of-output timeout)
- (tramp-error
- proc 'file-error
- "[[Remote prompt `%s' not found]]" tramp-end-of-output)))
- ;; Return value is whether end-of-output sentinel was found.
- found)))
-
-(defun tramp-send-command-and-check
- (vec command &optional subshell dont-suppress-err)
- "Run COMMAND and check its exit status.
-Sends `echo $?' along with the COMMAND for checking the exit status. If
-COMMAND is nil, just sends `echo $?'. Returns the exit status found.
-
-If the optional argument SUBSHELL is non-nil, the command is
-executed in a subshell, ie surrounded by parentheses. If
-DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to /dev/null."
- (tramp-send-command
- vec
- (concat (if subshell "( " "")
- command
- (if command (if dont-suppress-err "; " " 2>/dev/null; ") "")
- "echo tramp_exit_status $?"
- (if subshell " )" "")))
- (with-current-buffer (tramp-get-connection-buffer vec)
- (goto-char (point-max))
- (unless (re-search-backward "tramp_exit_status [0-9]+" nil t)
- (tramp-error
- vec 'file-error "Couldn't find exit status of `%s'" command))
- (skip-chars-forward "^ ")
- (prog1
- (read (current-buffer))
- (let (buffer-read-only) (delete-region (match-beginning 0) (point-max))))))
-
-(defun tramp-barf-unless-okay (vec command fmt &rest args)
- "Run COMMAND, check exit status, throw error if exit status not okay.
-Similar to `tramp-send-command-and-check' but accepts two more arguments
-FMT and ARGS which are passed to `error'."
- (unless (zerop (tramp-send-command-and-check vec command))
- (apply 'tramp-error vec 'file-error fmt args)))
-
-(defun tramp-send-command-and-read (vec command)
- "Run COMMAND and return the output, which must be a Lisp expression.
-In case there is no valid Lisp expression, it raises an error"
- (tramp-barf-unless-okay vec command "`%s' returns with error" command)
- (with-current-buffer (tramp-get-connection-buffer vec)
- ;; Read the expression.
- (goto-char (point-min))
- (condition-case nil
- (prog1 (read (current-buffer))
- ;; Error handling.
- (when (re-search-forward "\\S-" (tramp-compat-line-end-position) t)
- (error nil)))
- (error (tramp-error
- vec 'file-error
- "`%s' does not return a valid Lisp expression: `%s'"
- command (buffer-string))))))
-
;; It seems that Tru64 Unix does not like it if long strings are sent
;; to it in one go. (This happens when sending the Perl
;; `file-attributes' implementation, for instance.) Therefore, we
@@ -7805,6 +3226,56 @@ the remote host use line-endings as defined in the variable
(setq pos (+ pos chunksize))))
(process-send-string p string)))))
+(defun tramp-get-inode (vec)
+ "Returns the virtual inode number.
+If it doesn't exist, generate a new one."
+ (let ((string (tramp-make-tramp-file-name
+ (tramp-file-name-method vec)
+ (tramp-file-name-user vec)
+ (tramp-file-name-host vec)
+ "")))
+ (unless (assoc string tramp-inodes)
+ (add-to-list 'tramp-inodes
+ (list string (length tramp-inodes))))
+ (nth 1 (assoc string tramp-inodes))))
+
+(defun tramp-get-device (vec)
+ "Returns the virtual device number.
+If it doesn't exist, generate a new one."
+ (let ((string (tramp-make-tramp-file-name
+ (tramp-file-name-method vec)
+ (tramp-file-name-user vec)
+ (tramp-file-name-host vec)
+ "")))
+ (unless (assoc string tramp-devices)
+ (add-to-list 'tramp-devices
+ (list string (length tramp-devices))))
+ (cons -1 (nth 1 (assoc string tramp-devices)))))
+
+(defun tramp-equal-remote (file1 file2)
+ "Check, whether the remote parts of FILE1 and FILE2 are identical.
+The check depends on method, user and host name of the files. If
+one of the components is missing, the default values are used.
+The local file name parts of FILE1 and FILE2 are not taken into
+account.
+
+Example:
+
+ (tramp-equal-remote \"/ssh::/etc\" \"/<your host name>:/home\")
+
+would yield `t'. On the other hand, the following check results in nil:
+
+ (tramp-equal-remote \"/sudo::/etc\" \"/su::/etc\")"
+ (and (stringp (file-remote-p file1))
+ (stringp (file-remote-p file2))
+ (string-equal (file-remote-p file1) (file-remote-p file2))))
+
+(defun tramp-get-method-parameter (method param)
+ "Return the method parameter PARAM.
+If the `tramp-methods' entry does not exist, return nil."
+ (let ((entry (assoc param (assoc method tramp-methods))))
+ (when entry (cadr entry))))
+
(defun tramp-mode-string-to-int (mode-string)
"Converts a ten-letter `drwxrwxrwx'-style mode string into mode bits."
(let* (case-fold-search
@@ -7821,454 +3292,61 @@ the remote host use line-endings as defined in the variable
(save-match-data
(logior
(cond
- ((char-equal owner-read ?r) (tramp-octal-to-decimal "00400"))
+ ((char-equal owner-read ?r) (tramp-compat-octal-to-decimal "00400"))
((char-equal owner-read ?-) 0)
(t (error "Second char `%c' must be one of `r-'" owner-read)))
(cond
- ((char-equal owner-write ?w) (tramp-octal-to-decimal "00200"))
+ ((char-equal owner-write ?w) (tramp-compat-octal-to-decimal "00200"))
((char-equal owner-write ?-) 0)
(t (error "Third char `%c' must be one of `w-'" owner-write)))
(cond
((char-equal owner-execute-or-setid ?x)
- (tramp-octal-to-decimal "00100"))
+ (tramp-compat-octal-to-decimal "00100"))
((char-equal owner-execute-or-setid ?S)
- (tramp-octal-to-decimal "04000"))
+ (tramp-compat-octal-to-decimal "04000"))
((char-equal owner-execute-or-setid ?s)
- (tramp-octal-to-decimal "04100"))
+ (tramp-compat-octal-to-decimal "04100"))
((char-equal owner-execute-or-setid ?-) 0)
(t (error "Fourth char `%c' must be one of `xsS-'"
owner-execute-or-setid)))
(cond
- ((char-equal group-read ?r) (tramp-octal-to-decimal "00040"))
+ ((char-equal group-read ?r) (tramp-compat-octal-to-decimal "00040"))
((char-equal group-read ?-) 0)
(t (error "Fifth char `%c' must be one of `r-'" group-read)))
(cond
- ((char-equal group-write ?w) (tramp-octal-to-decimal "00020"))
+ ((char-equal group-write ?w) (tramp-compat-octal-to-decimal "00020"))
((char-equal group-write ?-) 0)
(t (error "Sixth char `%c' must be one of `w-'" group-write)))
(cond
((char-equal group-execute-or-setid ?x)
- (tramp-octal-to-decimal "00010"))
+ (tramp-compat-octal-to-decimal "00010"))
((char-equal group-execute-or-setid ?S)
- (tramp-octal-to-decimal "02000"))
+ (tramp-compat-octal-to-decimal "02000"))
((char-equal group-execute-or-setid ?s)
- (tramp-octal-to-decimal "02010"))
+ (tramp-compat-octal-to-decimal "02010"))
((char-equal group-execute-or-setid ?-) 0)
(t (error "Seventh char `%c' must be one of `xsS-'"
group-execute-or-setid)))
(cond
((char-equal other-read ?r)
- (tramp-octal-to-decimal "00004"))
+ (tramp-compat-octal-to-decimal "00004"))
((char-equal other-read ?-) 0)
(t (error "Eighth char `%c' must be one of `r-'" other-read)))
(cond
- ((char-equal other-write ?w) (tramp-octal-to-decimal "00002"))
+ ((char-equal other-write ?w) (tramp-compat-octal-to-decimal "00002"))
((char-equal other-write ?-) 0)
(t (error "Nineth char `%c' must be one of `w-'" other-write)))
(cond
((char-equal other-execute-or-sticky ?x)
- (tramp-octal-to-decimal "00001"))
+ (tramp-compat-octal-to-decimal "00001"))
((char-equal other-execute-or-sticky ?T)
- (tramp-octal-to-decimal "01000"))
+ (tramp-compat-octal-to-decimal "01000"))
((char-equal other-execute-or-sticky ?t)
- (tramp-octal-to-decimal "01001"))
+ (tramp-compat-octal-to-decimal "01001"))
((char-equal other-execute-or-sticky ?-) 0)
(t (error "Tenth char `%c' must be one of `xtT-'"
other-execute-or-sticky)))))))
-(defun tramp-convert-file-attributes (vec attr)
- "Convert file-attributes ATTR generated by perl script, stat or ls.
-Convert file mode bits to string and set virtual device number.
-Return ATTR."
- (when attr
- ;; Convert last access time.
- (unless (listp (nth 4 attr))
- (setcar (nthcdr 4 attr)
- (list (floor (nth 4 attr) 65536)
- (floor (mod (nth 4 attr) 65536)))))
- ;; Convert last modification time.
- (unless (listp (nth 5 attr))
- (setcar (nthcdr 5 attr)
- (list (floor (nth 5 attr) 65536)
- (floor (mod (nth 5 attr) 65536)))))
- ;; Convert last status change time.
- (unless (listp (nth 6 attr))
- (setcar (nthcdr 6 attr)
- (list (floor (nth 6 attr) 65536)
- (floor (mod (nth 6 attr) 65536)))))
- ;; Convert file size.
- (when (< (nth 7 attr) 0)
- (setcar (nthcdr 7 attr) -1))
- (when (and (floatp (nth 7 attr))
- (<= (nth 7 attr) (tramp-compat-most-positive-fixnum)))
- (setcar (nthcdr 7 attr) (round (nth 7 attr))))
- ;; Convert file mode bits to string.
- (unless (stringp (nth 8 attr))
- (setcar (nthcdr 8 attr) (tramp-file-mode-from-int (nth 8 attr)))
- (when (stringp (car attr))
- (aset (nth 8 attr) 0 ?l)))
- ;; Convert directory indication bit.
- (when (string-match "^d" (nth 8 attr))
- (setcar attr t))
- ;; Convert symlink from `tramp-do-file-attributes-with-stat'.
- (when (consp (car attr))
- (if (and (stringp (caar attr))
- (string-match ".+ -> .\\(.+\\)." (caar attr)))
- (setcar attr (match-string 1 (caar attr)))
- (setcar attr nil)))
- ;; Set file's gid change bit.
- (setcar (nthcdr 9 attr)
- (if (numberp (nth 3 attr))
- (not (= (nth 3 attr)
- (tramp-get-remote-gid vec 'integer)))
- (not (string-equal
- (nth 3 attr)
- (tramp-get-remote-gid vec 'string)))))
- ;; Convert inode.
- (unless (listp (nth 10 attr))
- (setcar (nthcdr 10 attr)
- (condition-case nil
- (cons (floor (nth 10 attr) 65536)
- (floor (mod (nth 10 attr) 65536)))
- ;; Inodes can be incredible huge. We must hide this.
- (error (tramp-get-inode vec)))))
- ;; Set virtual device number.
- (setcar (nthcdr 11 attr)
- (tramp-get-device vec))
- attr))
-
-(defun tramp-check-cached-permissions (vec access)
- "Check `file-attributes' caches for VEC.
-Return t if according to the cache access type ACCESS is known to
-be granted."
- (let ((result nil)
- (offset (cond
- ((eq ?r access) 1)
- ((eq ?w access) 2)
- ((eq ?x access) 3))))
- (dolist (suffix '("string" "integer") result)
- (setq
- result
- (or
- result
- (let ((file-attr
- (tramp-get-file-property
- vec (tramp-file-name-localname vec)
- (concat "file-attributes-" suffix) nil))
- (remote-uid
- (tramp-get-connection-property
- vec (concat "uid-" suffix) nil))
- (remote-gid
- (tramp-get-connection-property
- vec (concat "gid-" suffix) nil)))
- (and
- file-attr
- (or
- ;; Not a symlink
- (eq t (car file-attr))
- (null (car file-attr)))
- (or
- ;; World accessible.
- (eq access (aref (nth 8 file-attr) (+ offset 6)))
- ;; User accessible and owned by user.
- (and
- (eq access (aref (nth 8 file-attr) offset))
- (equal remote-uid (nth 2 file-attr)))
- ;; Group accessible and owned by user's
- ;; principal group.
- (and
- (eq access (aref (nth 8 file-attr) (+ offset 3)))
- (equal remote-gid (nth 3 file-attr)))))))))))
-
-(defun tramp-get-inode (vec)
- "Returns the virtual inode number.
-If it doesn't exist, generate a new one."
- (let ((string (tramp-make-tramp-file-name
- (tramp-file-name-method vec)
- (tramp-file-name-user vec)
- (tramp-file-name-host vec)
- "")))
- (unless (assoc string tramp-inodes)
- (add-to-list 'tramp-inodes
- (list string (length tramp-inodes))))
- (nth 1 (assoc string tramp-inodes))))
-
-(defun tramp-get-device (vec)
- "Returns the virtual device number.
-If it doesn't exist, generate a new one."
- (let ((string (tramp-make-tramp-file-name
- (tramp-file-name-method vec)
- (tramp-file-name-user vec)
- (tramp-file-name-host vec)
- "")))
- (unless (assoc string tramp-devices)
- (add-to-list 'tramp-devices
- (list string (length tramp-devices))))
- (cons -1 (nth 1 (assoc string tramp-devices)))))
-
-(defun tramp-file-mode-from-int (mode)
- "Turn an integer representing a file mode into an ls(1)-like string."
- (let ((type (cdr (assoc (logand (lsh mode -12) 15) tramp-file-mode-type-map)))
- (user (logand (lsh mode -6) 7))
- (group (logand (lsh mode -3) 7))
- (other (logand (lsh mode -0) 7))
- (suid (> (logand (lsh mode -9) 4) 0))
- (sgid (> (logand (lsh mode -9) 2) 0))
- (sticky (> (logand (lsh mode -9) 1) 0)))
- (setq user (tramp-file-mode-permissions user suid "s"))
- (setq group (tramp-file-mode-permissions group sgid "s"))
- (setq other (tramp-file-mode-permissions other sticky "t"))
- (concat type user group other)))
-
-(defun tramp-file-mode-permissions (perm suid suid-text)
- "Convert a permission bitset into a string.
-This is used internally by `tramp-file-mode-from-int'."
- (let ((r (> (logand perm 4) 0))
- (w (> (logand perm 2) 0))
- (x (> (logand perm 1) 0)))
- (concat (or (and r "r") "-")
- (or (and w "w") "-")
- (or (and suid x suid-text) ; suid, execute
- (and suid (upcase suid-text)) ; suid, !execute
- (and x "x") "-")))) ; !suid
-
-(defun tramp-decimal-to-octal (i)
- "Return a string consisting of the octal digits of I.
-Not actually used. Use `(format \"%o\" i)' instead?"
- (cond ((< i 0) (error "Cannot convert negative number to octal"))
- ((not (integerp i)) (error "Cannot convert non-integer to octal"))
- ((zerop i) "0")
- (t (concat (tramp-decimal-to-octal (/ i 8))
- (number-to-string (% i 8))))))
-
-;; Kudos to Gerd Moellmann for this suggestion.
-(defun tramp-octal-to-decimal (ostr)
- "Given a string of octal digits, return a decimal number."
- (let ((x (or ostr "")))
- ;; `save-match' is in `tramp-mode-string-to-int' which calls this.
- (unless (string-match "\\`[0-7]*\\'" x)
- (error "Non-octal junk in string `%s'" x))
- (string-to-number ostr 8)))
-
-(defun tramp-shell-case-fold (string)
- "Converts STRING to shell glob pattern which ignores case."
- (mapconcat
- (lambda (c)
- (if (equal (downcase c) (upcase c))
- (vector c)
- (format "[%c%c]" (downcase c) (upcase c))))
- string
- ""))
-
-
-;; ------------------------------------------------------------
-;; -- Tramp file names --
-;; ------------------------------------------------------------
-;; Conversion functions between external representation and
-;; internal data structure. Convenience functions for internal
-;; data structure.
-
-(defun tramp-file-name-p (vec)
- "Check, whether VEC is a Tramp object."
- (and (vectorp vec) (= 4 (length vec))))
-
-(defun tramp-file-name-method (vec)
- "Return method component of VEC."
- (and (tramp-file-name-p vec) (aref vec 0)))
-
-(defun tramp-file-name-user (vec)
- "Return user component of VEC."
- (and (tramp-file-name-p vec) (aref vec 1)))
-
-(defun tramp-file-name-host (vec)
- "Return host component of VEC."
- (and (tramp-file-name-p vec) (aref vec 2)))
-
-(defun tramp-file-name-localname (vec)
- "Return localname component of VEC."
- (and (tramp-file-name-p vec) (aref vec 3)))
-
-;; The user part of a Tramp file name vector can be of kind
-;; "user%domain". Sometimes, we must extract these parts.
-(defun tramp-file-name-real-user (vec)
- "Return the user name of VEC without domain."
- (save-match-data
- (let ((user (tramp-file-name-user vec)))
- (if (and (stringp user)
- (string-match tramp-user-with-domain-regexp user))
- (match-string 1 user)
- user))))
-
-(defun tramp-file-name-domain (vec)
- "Return the domain name of VEC."
- (save-match-data
- (let ((user (tramp-file-name-user vec)))
- (and (stringp user)
- (string-match tramp-user-with-domain-regexp user)
- (match-string 2 user)))))
-
-;; The host part of a Tramp file name vector can be of kind
-;; "host#port". Sometimes, we must extract these parts.
-(defun tramp-file-name-real-host (vec)
- "Return the host name of VEC without port."
- (save-match-data
- (let ((host (tramp-file-name-host vec)))
- (if (and (stringp host)
- (string-match tramp-host-with-port-regexp host))
- (match-string 1 host)
- host))))
-
-(defun tramp-file-name-port (vec)
- "Return the port number of VEC."
- (save-match-data
- (let ((host (tramp-file-name-host vec)))
- (and (stringp host)
- (string-match tramp-host-with-port-regexp host)
- (string-to-number (match-string 2 host))))))
-
-(defun tramp-tramp-file-p (name)
- "Return t if NAME is a string with Tramp file name syntax."
- (save-match-data
- (and (stringp name) (string-match tramp-file-name-regexp name))))
-
-(defun tramp-find-method (method user host)
- "Return the right method string to use.
-This is METHOD, if non-nil. Otherwise, do a lookup in
-`tramp-default-method-alist'."
- (or method
- (let ((choices tramp-default-method-alist)
- lmethod item)
- (while choices
- (setq item (pop choices))
- (when (and (string-match (or (nth 0 item) "") (or host ""))
- (string-match (or (nth 1 item) "") (or user "")))
- (setq lmethod (nth 2 item))
- (setq choices nil)))
- lmethod)
- tramp-default-method))
-
-(defun tramp-find-user (method user host)
- "Return the right user string to use.
-This is USER, if non-nil. Otherwise, do a lookup in
-`tramp-default-user-alist'."
- (or user
- (let ((choices tramp-default-user-alist)
- luser item)
- (while choices
- (setq item (pop choices))
- (when (and (string-match (or (nth 0 item) "") (or method ""))
- (string-match (or (nth 1 item) "") (or host "")))
- (setq luser (nth 2 item))
- (setq choices nil)))
- luser)
- tramp-default-user))
-
-(defun tramp-find-host (method user host)
- "Return the right host string to use.
-This is HOST, if non-nil. Otherwise, it is `tramp-default-host'."
- (or (and (> (length host) 0) host)
- tramp-default-host))
-
-(defun tramp-dissect-file-name (name &optional nodefault)
- "Return a `tramp-file-name' structure.
-The structure consists of remote method, remote user, remote host
-and localname (file name on remote host). If NODEFAULT is
-non-nil, the file name parts are not expanded to their default
-values."
- (save-match-data
- (let ((match (string-match (nth 0 tramp-file-name-structure) name)))
- (unless match (error "Not a Tramp file name: %s" name))
- (let ((method (match-string (nth 1 tramp-file-name-structure) name))
- (user (match-string (nth 2 tramp-file-name-structure) name))
- (host (match-string (nth 3 tramp-file-name-structure) name))
- (localname (match-string (nth 4 tramp-file-name-structure) name)))
- (when (member method '("multi" "multiu"))
- (error
- "`%s' method is no longer supported, see (info \"(tramp)Multi-hops\")"
- method))
- (when host
- (when (string-match tramp-prefix-ipv6-regexp host)
- (setq host (replace-match "" nil t host)))
- (when (string-match tramp-postfix-ipv6-regexp host)
- (setq host (replace-match "" nil t host))))
- (if nodefault
- (vector method user host localname)
- (vector
- (tramp-find-method method user host)
- (tramp-find-user method user host)
- (tramp-find-host method user host)
- localname))))))
-
-(defun tramp-equal-remote (file1 file2)
- "Check, whether the remote parts of FILE1 and FILE2 are identical.
-The check depends on method, user and host name of the files. If
-one of the components is missing, the default values are used.
-The local file name parts of FILE1 and FILE2 are not taken into
-account.
-
-Example:
-
- (tramp-equal-remote \"/ssh::/etc\" \"/<your host name>:/home\")
-
-would yield `t'. On the other hand, the following check results in nil:
-
- (tramp-equal-remote \"/sudo::/etc\" \"/su::/etc\")"
- (and (stringp (file-remote-p file1))
- (stringp (file-remote-p file2))
- (string-equal (file-remote-p file1) (file-remote-p file2))))
-
-(defun tramp-make-tramp-file-name (method user host localname)
- "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME."
- (concat tramp-prefix-format
- (when (not (zerop (length method)))
- (concat method tramp-postfix-method-format))
- (when (not (zerop (length user)))
- (concat user tramp-postfix-user-format))
- (when host
- (if (string-match tramp-ipv6-regexp host)
- (concat tramp-prefix-ipv6-format host tramp-postfix-ipv6-format)
- host))
- tramp-postfix-host-format
- (when localname localname)))
-
-(defun tramp-completion-make-tramp-file-name (method user host localname)
- "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME.
-It must not be a complete Tramp file name, but as long as there are
-necessary only. This function will be used in file name completion."
- (concat tramp-prefix-format
- (when (not (zerop (length method)))
- (concat method tramp-postfix-method-format))
- (when (not (zerop (length user)))
- (concat user tramp-postfix-user-format))
- (when (not (zerop (length host)))
- (concat
- (if (string-match tramp-ipv6-regexp host)
- (concat tramp-prefix-ipv6-format host tramp-postfix-ipv6-format)
- host)
- tramp-postfix-host-format))
- (when localname localname)))
-
-(defun tramp-make-copy-program-file-name (vec)
- "Create a file name suitable to be passed to `rcp' and workalikes."
- (let ((user (tramp-file-name-user vec))
- (host (tramp-file-name-real-host vec))
- (localname (tramp-shell-quote-argument
- (tramp-file-name-localname vec))))
- (if (not (zerop (length user)))
- (format "%s@%s:%s" user host localname)
- (format "%s:%s" host localname))))
-
-(defun tramp-method-out-of-band-p (vec size)
- "Return t if this is an out-of-band method, nil otherwise."
- (and
- ;; It shall be an out-of-band method.
- (tramp-get-method-parameter (tramp-file-name-method vec) 'tramp-copy-program)
- ;; Either the file size is large enough, or (in rare cases) there
- ;; does not exist a remote encoding.
- (or (null tramp-copy-size-limit)
- (> size tramp-copy-size-limit)
- (null (tramp-get-inline-coding vec "remote-encoding" size)))))
-
(defun tramp-local-host-p (vec)
"Return t if this points to the local host, nil otherwise."
;; We cannot use `tramp-file-name-real-host'. A port is an
@@ -8291,385 +3369,57 @@ necessary only. This function will be used in file name completion."
(tramp-compat-temporary-file-directory)))
;; On some systems, chown runs only for root.
(or (zerop (user-uid))
- (zerop (tramp-get-remote-uid vec 'integer))))))
-
-;; Variables local to connection.
-
-(defun tramp-get-remote-path (vec)
- (with-connection-property
- ;; When `tramp-own-remote-path' is in `tramp-remote-path', we
- ;; cache the result for the session only. Otherwise, the result
- ;; is cached persistently.
- (if (memq 'tramp-own-remote-path tramp-remote-path)
- (tramp-get-connection-process vec)
- vec)
- "remote-path"
- (let* ((remote-path (copy-tree tramp-remote-path))
- (elt1 (memq 'tramp-default-remote-path remote-path))
- (elt2 (memq 'tramp-own-remote-path remote-path))
- (default-remote-path
- (when elt1
- (condition-case nil
- (tramp-send-command-and-read
- vec "echo \\\"`getconf PATH`\\\"")
- ;; Default if "getconf" is not available.
- (error
- (tramp-message
- vec 3
- "`getconf PATH' not successful, using default value \"%s\"."
- "/bin:/usr/bin")
- "/bin:/usr/bin"))))
- (own-remote-path
- (when elt2
- (condition-case nil
- (tramp-send-command-and-read vec "echo \\\"$PATH\\\"")
- ;; Default if "getconf" is not available.
- (error
- (tramp-message
- vec 3 "$PATH not set, ignoring `tramp-own-remote-path'.")
- nil)))))
-
- ;; Replace place holder `tramp-default-remote-path'.
- (when elt1
- (setcdr elt1
- (append
- (tramp-compat-split-string default-remote-path ":")
- (cdr elt1)))
- (setq remote-path (delq 'tramp-default-remote-path remote-path)))
-
- ;; Replace place holder `tramp-own-remote-path'.
- (when elt2
- (setcdr elt2
- (append
- (tramp-compat-split-string own-remote-path ":")
- (cdr elt2)))
- (setq remote-path (delq 'tramp-own-remote-path remote-path)))
+ ;; This is defined in tramp-sh.el. Let's assume this is
+ ;; loaded already.
+ (zerop (tramp-compat-funcall 'tramp-get-remote-uid vec 'integer))))))
- ;; Remove double entries.
- (setq elt1 remote-path)
- (while (consp elt1)
- (while (and (car elt1) (setq elt2 (member (car elt1) (cdr elt1))))
- (setcar elt2 nil))
- (setq elt1 (cdr elt1)))
-
- ;; Remove non-existing directories.
- (delq
- nil
- (mapcar
- (lambda (x)
- (and
- (stringp x)
- (file-directory-p
- (tramp-make-tramp-file-name
- (tramp-file-name-method vec)
- (tramp-file-name-user vec)
- (tramp-file-name-host vec)
- x))
- x))
- remote-path)))))
-
-(defun tramp-get-remote-tmpdir (vec)
- (with-connection-property vec "tmp-directory"
- (let ((dir (tramp-shell-quote-argument "/tmp")))
- (if (and (zerop
- (tramp-send-command-and-check
- vec (format "%s -d %s" (tramp-get-test-command vec) dir)))
- (zerop
- (tramp-send-command-and-check
- vec (format "%s -w %s" (tramp-get-test-command vec) dir))))
- dir
- (tramp-error vec 'file-error "Directory %s not accessible" dir)))))
-
-(defun tramp-get-ls-command (vec)
- (with-connection-property vec "ls"
- (tramp-message vec 5 "Finding a suitable `ls' command")
- (or
- (catch 'ls-found
- (dolist (cmd '("ls" "gnuls" "gls"))
- (let ((dl (tramp-get-remote-path vec))
- result)
- (while (and dl (setq result (tramp-find-executable vec cmd dl t t)))
- ;; Check parameters. On busybox, "ls" output coloring is
- ;; enabled by default sometimes. So we try to disable it
- ;; when possible. $LS_COLORING is not supported there.
- ;; Some "ls" versions are sensible wrt the order of
- ;; arguments, they fail when "-al" is after the
- ;; "--color=never" argument (for example on FreeBSD).
- (when (zerop (tramp-send-command-and-check
- vec (format "%s -lnd /" result)))
- (when (zerop (tramp-send-command-and-check
- vec (format
- "%s --color=never -al /dev/null" result)))
- (setq result (concat result " --color=never")))
- (throw 'ls-found result))
- (setq dl (cdr dl))))))
- (tramp-error vec 'file-error "Couldn't find a proper `ls' command"))))
-
-(defun tramp-get-ls-command-with-dired (vec)
- (save-match-data
- (with-connection-property vec "ls-dired"
- (tramp-message vec 5 "Checking, whether `ls --dired' works")
- ;; Some "ls" versions are sensible wrt the order of arguments,
- ;; they fail when "-al" is after the "--dired" argument (for
- ;; example on FreeBSD).
- (zerop (tramp-send-command-and-check
- vec (format "%s --dired -al /dev/null"
- (tramp-get-ls-command vec)))))))
-
-(defun tramp-get-test-command (vec)
- (with-connection-property vec "test"
- (tramp-message vec 5 "Finding a suitable `test' command")
- (if (zerop (tramp-send-command-and-check vec "test 0"))
- "test"
- (tramp-find-executable vec "test" (tramp-get-remote-path vec)))))
-
-(defun tramp-get-test-nt-command (vec)
- ;; Does `test A -nt B' work? Use abominable `find' construct if it
- ;; doesn't. BSD/OS 4.0 wants the parentheses around the command,
- ;; for otherwise the shell crashes.
- (with-connection-property vec "test-nt"
- (or
- (progn
- (tramp-send-command
- vec (format "( %s / -nt / )" (tramp-get-test-command vec)))
- (with-current-buffer (tramp-get-buffer vec)
- (goto-char (point-min))
- (when (looking-at (regexp-quote tramp-end-of-output))
- (format "%s %%s -nt %%s" (tramp-get-test-command vec)))))
- (progn
- (tramp-send-command
- vec
- (format
- "tramp_test_nt () {\n%s -n \"`find $1 -prune -newer $2 -print`\"\n}"
- (tramp-get-test-command vec)))
- "tramp_test_nt %s %s"))))
-
-(defun tramp-get-file-exists-command (vec)
- (with-connection-property vec "file-exists"
- (tramp-message vec 5 "Finding command to check if file exists")
- (tramp-find-file-exists-command vec)))
-
-(defun tramp-get-remote-ln (vec)
- (with-connection-property vec "ln"
- (tramp-message vec 5 "Finding a suitable `ln' command")
- (tramp-find-executable vec "ln" (tramp-get-remote-path vec))))
-
-(defun tramp-get-remote-perl (vec)
- (with-connection-property vec "perl"
- (tramp-message vec 5 "Finding a suitable `perl' command")
- (let ((result
- (or (tramp-find-executable vec "perl5" (tramp-get-remote-path vec))
- (tramp-find-executable
- vec "perl" (tramp-get-remote-path vec)))))
- ;; We must check also for some Perl modules.
- (when result
- (with-connection-property vec "perl-file-spec"
- (zerop
- (tramp-send-command-and-check
- vec (format "%s -e 'use File::Spec;'" result))))
- (with-connection-property vec "perl-cwd-realpath"
- (zerop
- (tramp-send-command-and-check
- vec (format "%s -e 'use Cwd \"realpath\";'" result)))))
- result)))
-
-(defun tramp-get-remote-stat (vec)
- (with-connection-property vec "stat"
- (tramp-message vec 5 "Finding a suitable `stat' command")
- (let ((result (tramp-find-executable
- vec "stat" (tramp-get-remote-path vec)))
- tmp)
- ;; Check whether stat(1) returns usable syntax. %s does not
- ;; work on older AIX systems.
- (when result
- (setq tmp
- ;; We don't want to display an error message.
- (with-temp-message (or (current-message) "")
- (condition-case nil
- (tramp-send-command-and-read
- vec (format "%s -c '(\"%%N\" %%s)' /" result))
- (error nil))))
- (unless (and (listp tmp) (stringp (car tmp))
- (string-match "^./.$" (car tmp))
- (integerp (cadr tmp)))
- (setq result nil)))
- result)))
-
-(defun tramp-get-remote-readlink (vec)
- (with-connection-property vec "readlink"
- (tramp-message vec 5 "Finding a suitable `readlink' command")
- (let ((result (tramp-find-executable
- vec "readlink" (tramp-get-remote-path vec))))
- (when (and result
- ;; We don't want to display an error message.
- (with-temp-message (or (current-message) "")
- (condition-case nil
- (zerop
- (tramp-send-command-and-check
- vec (format "%s --canonicalize-missing /" result)))
- (error nil))))
- result))))
+(defun tramp-make-tramp-temp-file (vec)
+ "Create a temporary file on the remote host identified by VEC.
+Return the local name of the temporary file."
+ (let ((prefix
+ (tramp-make-tramp-file-name
+ (tramp-file-name-method vec)
+ (tramp-file-name-user vec)
+ (tramp-file-name-host vec)
+ (tramp-drop-volume-letter
+ (expand-file-name
+ tramp-temp-name-prefix
+ ;; This is defined in tramp-sh.el. Let's assume this is
+ ;; loaded already.
+ (tramp-compat-funcall 'tramp-get-remote-tmpdir vec)))))
+ result)
+ (while (not result)
+ ;; `make-temp-file' would be the natural choice for
+ ;; implementation. But it calls `write-region' internally,
+ ;; which also needs a temporary file - we would end in an
+ ;; infinite loop.
+ (setq result (make-temp-name prefix))
+ (if (file-exists-p result)
+ (setq result nil)
+ ;; This creates the file by side effect.
+ (set-file-times result)
+ (set-file-modes result (tramp-compat-octal-to-decimal "0700"))))
-(defun tramp-get-remote-trash (vec)
- (with-connection-property vec "trash"
- (tramp-message vec 5 "Finding a suitable `trash' command")
- (tramp-find-executable vec "trash" (tramp-get-remote-path vec))))
-
-(defun tramp-get-remote-id (vec)
- (with-connection-property vec "id"
- (tramp-message vec 5 "Finding POSIX `id' command")
- (or
- (catch 'id-found
- (let ((dl (tramp-get-remote-path vec))
- result)
- (while (and dl (setq result (tramp-find-executable vec "id" dl t t)))
- ;; Check POSIX parameter.
- (when (zerop (tramp-send-command-and-check
- vec (format "%s -u" result)))
- (throw 'id-found result))
- (setq dl (cdr dl)))))
- (tramp-error vec 'file-error "Couldn't find a POSIX `id' command"))))
-
-(defun tramp-get-remote-uid (vec id-format)
- (with-connection-property vec (format "uid-%s" id-format)
- (let ((res (tramp-send-command-and-read
- vec
- (format "%s -u%s %s"
- (tramp-get-remote-id vec)
- (if (equal id-format 'integer) "" "n")
- (if (equal id-format 'integer)
- "" "| sed -e s/^/\\\"/ -e s/\$/\\\"/")))))
- ;; The command might not always return a number.
- (if (and (equal id-format 'integer) (not (integerp res))) -1 res))))
-
-(defun tramp-get-remote-gid (vec id-format)
- (with-connection-property vec (format "gid-%s" id-format)
- (let ((res (tramp-send-command-and-read
- vec
- (format "%s -g%s %s"
- (tramp-get-remote-id vec)
- (if (equal id-format 'integer) "" "n")
- (if (equal id-format 'integer)
- "" "| sed -e s/^/\\\"/ -e s/\$/\\\"/")))))
- ;; The command might not always return a number.
- (if (and (equal id-format 'integer) (not (integerp res))) -1 res))))
-
-(defun tramp-get-local-uid (id-format)
- (if (equal id-format 'integer) (user-uid) (user-login-name)))
-
-(defun tramp-get-local-gid (id-format)
- (nth 3 (tramp-compat-file-attributes "~/" id-format)))
-
-;; Some predefined connection properties.
-(defun tramp-get-inline-compress (vec prop size)
- "Return the compress command related to PROP.
-PROP is either `inline-compress' or `inline-decompress'. SIZE is
-the length of the file to be compressed.
-
-If no corresponding command is found, nil is returned."
- (when (and (integerp tramp-inline-compress-start-size)
- (> size tramp-inline-compress-start-size))
- (with-connection-property vec prop
- (tramp-find-inline-compress vec)
- (tramp-get-connection-property vec prop nil))))
-
-(defun tramp-get-inline-coding (vec prop size)
- "Return the coding command related to PROP.
-PROP is either `remote-encoding', `remode-decoding',
-`local-encoding' or `local-decoding'.
-
-SIZE is the length of the file to be coded. Depending on SIZE,
-compression might be applied.
-
-If no corresponding command is found, nil is returned.
-Otherwise, either a string is returned which contains a `%s' mark
-to be used for the respective input or output file; or a Lisp
-function cell is returned to be applied on a buffer."
- ;; We must catch the errors, because we want to return `nil', when
- ;; no inline coding is found.
- (ignore-errors
- (let ((coding
- (with-connection-property vec prop
- (tramp-find-inline-encoding vec)
- (tramp-get-connection-property vec prop nil)))
- (prop1 (if (string-match "encoding" prop)
- "inline-compress" "inline-decompress"))
- compress)
- ;; The connection property might have been cached. So we must
- ;; send the script to the remote side - maybe.
- (when (and coding (symbolp coding) (string-match "remote" prop))
- (let ((name (symbol-name coding)))
- (while (string-match (regexp-quote "-") name)
- (setq name (replace-match "_" nil t name)))
- (tramp-maybe-send-script vec (symbol-value coding) name)
- (setq coding name)))
- (when coding
- ;; Check for the `compress' command.
- (setq compress (tramp-get-inline-compress vec prop1 size))
- ;; Return the value.
- (cond
- ((and compress (symbolp coding))
- (if (string-match "decompress" prop1)
- `(lambda (beg end)
- (,coding beg end)
- (let ((coding-system-for-write 'binary)
- (coding-system-for-read 'binary))
- (apply
- 'call-process-region (point-min) (point-max)
- (car (split-string ,compress)) t t nil
- (cdr (split-string ,compress)))))
- `(lambda (beg end)
- (let ((coding-system-for-write 'binary)
- (coding-system-for-read 'binary))
- (apply
- 'call-process-region beg end
- (car (split-string ,compress)) t t nil
- (cdr (split-string ,compress))))
- (,coding (point-min) (point-max)))))
- ((symbolp coding)
- coding)
- ((and compress (string-match "decoding" prop))
- (format "(%s | %s >%%s)" coding compress))
- (compress
- (format "(%s <%%s | %s)" compress coding))
- ((string-match "decoding" prop)
- (format "%s >%%s" coding))
- (t
- (format "%s <%%s" coding)))))))
+ ;; Return the local part.
+ (with-parsed-tramp-file-name result nil localname)))
-(defun tramp-get-method-parameter (method param)
- "Return the method parameter PARAM.
-If the `tramp-methods' entry does not exist, return nil."
- (let ((entry (assoc param (assoc method tramp-methods))))
- (when entry (cadr entry))))
+(defun tramp-delete-temp-file-function ()
+ "Remove temporary files related to current buffer."
+ (when (stringp tramp-temp-buffer-file-name)
+ (ignore-errors (delete-file tramp-temp-buffer-file-name))))
-;; Auto saving to a special directory.
+(add-hook 'kill-buffer-hook 'tramp-delete-temp-file-function)
+(add-hook 'tramp-cache-unload-hook
+ (lambda ()
+ (remove-hook 'kill-buffer-hook
+ 'tramp-delete-temp-file-function)))
-(defun tramp-exists-file-name-handler (operation &rest args)
- "Check, whether OPERATION runs a file name handler."
- ;; The file name handler is determined on base of either an
- ;; argument, `buffer-file-name', or `default-directory'.
- (condition-case nil
- (let* ((buffer-file-name "/")
- (default-directory "/")
- (fnha file-name-handler-alist)
- (check-file-name-operation operation)
- (file-name-handler-alist
- (list
- (cons "/"
- (lambda (operation &rest args)
- "Returns OPERATION if it is the one to be checked."
- (if (equal check-file-name-operation operation)
- operation
- (let ((file-name-handler-alist fnha))
- (apply operation args))))))))
- (equal (apply operation args) operation))
- (error nil)))
+;;; Auto saving to a special directory:
(unless (tramp-exists-file-name-handler 'make-auto-save-file-name)
(defadvice make-auto-save-file-name
(around tramp-advice-make-auto-save-file-name () activate)
- "Invoke `tramp-handle-make-auto-save-file-name' for Tramp files."
+ "Invoke `tramp-*-handle-make-auto-save-file-name' for Tramp files."
(if (tramp-tramp-file-p (buffer-file-name))
;; We cannot call `tramp-handle-make-auto-save-file-name'
;; directly, because this would bypass the locking mechanism.
@@ -8699,8 +3449,9 @@ If the `tramp-methods' entry does not exist, return nil."
;; Permissions should be set always, because there might be an old
;; auto-saved file belonging to another original file. This could
;; be a security threat.
- (set-file-modes buffer-auto-save-file-name
- (or (file-modes bfn) (tramp-octal-to-decimal "0600"))))))
+ (set-file-modes
+ buffer-auto-save-file-name
+ (or (file-modes bfn) (tramp-compat-octal-to-decimal "0600"))))))
(unless (and (featurep 'xemacs)
(= emacs-major-version 21)
@@ -8723,9 +3474,7 @@ ALIST is of the form ((FROM . TO) ...)."
(setq alist (cdr alist))))
string))
-;; ------------------------------------------------------------
-;; -- Compatibility functions section --
-;; ------------------------------------------------------------
+;;; Compatibility functions section:
(defun tramp-read-passwd (proc &optional prompt)
"Read a password from user (compat function).
@@ -8804,7 +3553,6 @@ Return the difference in the format of a time value."
(defun tramp-time-diff (t1 t2)
"Return the difference between the two times, in seconds.
T1 and T2 are time values (as returned by `current-time' for example)."
- ;; Pacify byte-compiler with `symbol-function'.
(cond ((and (fboundp 'subtract-time)
(fboundp 'float-time))
(tramp-compat-funcall
@@ -8824,37 +3572,6 @@ T1 and T2 are time values (as returned by `current-time' for example)."
(cadr time)
(/ (or (nth 2 time) 0) 1000000.0))))))
-(defun tramp-coding-system-change-eol-conversion (coding-system eol-type)
- "Return a coding system like CODING-SYSTEM but with given EOL-TYPE.
-EOL-TYPE can be one of `dos', `unix', or `mac'."
- (cond ((fboundp 'coding-system-change-eol-conversion)
- (tramp-compat-funcall
- 'coding-system-change-eol-conversion coding-system eol-type))
- ((fboundp 'subsidiary-coding-system)
- (tramp-compat-funcall
- 'subsidiary-coding-system coding-system
- (cond ((eq eol-type 'dos) 'crlf)
- ((eq eol-type 'unix) 'lf)
- ((eq eol-type 'mac) 'cr)
- (t
- (error "Unknown EOL-TYPE `%s', must be %s"
- eol-type
- "`dos', `unix', or `mac'")))))
- (t (error "Can't change EOL conversion -- is MULE missing?"))))
-
-(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)
- (tramp-compat-funcall 'set-process-query-on-exit-flag process flag)
- (tramp-compat-funcall 'process-kill-without-query process flag)))
-
-
-;; ------------------------------------------------------------
-;; -- Kludges section --
-;; ------------------------------------------------------------
-
;; Currently (as of Emacs 20.5), the function `shell-quote-argument'
;; does not deal well with newline characters. Newline is replaced by
;; backslash newline. But if, say, the string `a backslash newline b'
@@ -8880,6 +3597,7 @@ exiting if process is running."
;; CCC: This function should be rewritten so that
;; `shell-quote-argument' is not used. This way, we are safe from
;; changes in `shell-quote-argument'.
+;;;###tramp-autoload
(defun tramp-shell-quote-argument (s)
"Similar to `shell-quote-argument', but groks newlines.
Only works for Bourne-like shells."
@@ -8905,113 +3623,42 @@ Only works for Bourne-like shells."
(defun tramp-unload-tramp ()
"Discard Tramp from loading remote files."
(interactive)
- ;; When Tramp is not loaded yet, its autoloads are still active.
- (tramp-unload-file-name-handlers)
;; ange-ftp settings must be enabled.
(tramp-compat-funcall 'tramp-ftp-enable-ange-ftp)
- ;; Maybe its not loaded yet.
- (condition-case nil
- (unload-feature 'tramp 'force)
- (error nil)))
-
-(when (and load-in-progress
- (string-match "Loading tramp..." (or (current-message) "")))
- (message "Loading tramp...done"))
+ ;; Maybe it's not loaded yet.
+ (ignore-errors (unload-feature 'tramp 'force)))
(provide 'tramp)
;;; TODO:
-;; * Handle nonlocal exits such as C-g.
-;; * But it would probably be better to use with-local-quit at the
-;; place where it's actually needed: around any potentially
-;; indefinitely blocking piece of code. In this case it would be
-;; within Tramp around one of its calls to accept-process-output (or
-;; around one of the loops that calls accept-process-output)
-;; (Stefan Monnier).
;; * Rewrite `tramp-shell-quote-argument' to abstain from using
;; `shell-quote-argument'.
;; * 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)
;; * Make ffap.el grok Tramp filenames. (Eli Tziperman)
-;; * Don't use globbing for directories with many files, as this is
-;; likely to produce long command lines, and some shells choke on
-;; long command lines.
-;; * How to deal with MULE in `insert-file-contents' and `write-region'?
;; * abbreviate-file-name
;; * Better error checking. At least whenever we see something
;; strange when doing zerop, we should kill the process and start
;; again. (Greg Stark)
-;; * Remove unneeded parameters from methods.
-;; * Make it work for different encodings, and for different file name
-;; encodings, too. (Daniel Pittman)
-;; * Don't search for perl5 and perl. Instead, only search for perl and
-;; then look if it's the right version (with `perl -v').
-;; * 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.
;; * Username and hostname completion.
;; ** Try to avoid usage of `last-input-event' in `tramp-completion-mode-p'.
;; ** Unify `tramp-parse-{rhosts,shosts,sconfig,hosts,passwd,netrc}'.
;; Code is nearly identical.
-;; * Allow out-of-band methods as _last_ multi-hop. Open a connection
-;; until the last but one hop via `start-file-process'. Apply it
-;; also for ftp and smb.
-;; * WIBNI if we had a command "trampclient"? If I was editing in
-;; some shell with root priviledges, it would be nice if I could
-;; just call
-;; trampclient filename.c
-;; as an editor, and the _current_ shell would connect to an Emacs
-;; server and would be used in an existing non-priviledged Emacs
-;; session for doing the editing in question.
-;; That way, I need not tell Emacs my password again and be afraid
-;; that it makes it into core dumps or other ugly stuff (I had Emacs
-;; once display a just typed password in the context of a keyboard
-;; sequence prompt for a question immediately following in a shell
-;; script run within Emacs -- nasty).
-;; And if I have some ssh session running to a different computer,
-;; having the possibility of passing a local file there to a local
-;; Emacs session (in case I can arrange for a connection back) would
-;; be nice.
-;; Likely the corresponding Tramp server should not allow the
-;; equivalent of the emacsclient -eval option in order to make this
-;; reasonably unproblematic. And maybe trampclient should have some
-;; way of passing credentials, like by using an SSL socket or
-;; something. (David Kastrup)
-;; * Reconnect directly to a compliant shell without first going
-;; through the user's default shell. (Pete Forman)
;; * Make `tramp-default-user' obsolete.
-;; * How can I interrupt the remote process with a signal
-;; (interrupt-process seems not to work)? (Markus Triska)
-;; * Avoid the local shell entirely for starting remote processes. If
-;; so, I think even a signal, when delivered directly to the local
-;; SSH instance, would correctly be propagated to the remote process
-;; automatically; possibly SSH would have to be started with
-;; "-t". (Markus Triska)
-;; * It makes me wonder if tramp couldn't fall back to ssh when scp
-;; isn't on the remote host. (Mark A. Hershberger)
-;; * Use lsh instead of ssh. (Alfred M. Szmidt)
;; * Implement a general server-local-variable mechanism, as there are
;; probably other variables that need different values for different
;; servers too. The user could then configure a variable (such as
;; tramp-server-local-variable-alist) to define any such variables
;; that they need to, which would then be let bound as appropriate
;; in tramp functions. (Jason Rumney)
-;; * Optimize out-of-band copying, when both methods are scp-like (not
-;; rsync).
-;; * Keep a second connection open for out-of-band methods like scp or
-;; rsync.
;; * IMHO, it's a drawback that currently Tramp doesn't support
;; Unicode in Dired file names by default. Is it possible to
;; improve Tramp to set LC_ALL to "C" only for commands where Tramp
;; expects English? Or just to set LC_MESSAGES to "C" if Tramp
;; expects only English messages? (Juri Linkov)
;; * Make shadowfile.el grok Tramp filenames. (Bug#4526, Bug#4846)
-;; * Load Tramp subpackages only when needed. (Bug#1529, Bug#5448, Bug#5705)
-;; * Try telnet+curl as new method. It might be useful for busybox,
-;; without built-in uuencode/uudecode.
-;; * Load ~/.emacs_SHELLNAME on the remote host for `shell'.
;; * I was wondering it it would be possible to use tramp even if I'm
;; actually using sshfs. But when I launch a command I would like
;; to get it executed on the remote machine where the files really
@@ -9023,7 +3670,6 @@ Only works for Bourne-like shells."
;; Functions for file-name-handler-alist:
;; diff-latest-backup-file -- in diff.el
-;; arch-tag: 3a21a994-182b-48fa-b0cd-c1d9fede424a
;;; tramp.el ends here
;; Local Variables:
diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el
index ab9a8acba1e..c66900dfd09 100644
--- a/lisp/net/trampver.el
+++ b/lisp/net/trampver.el
@@ -6,6 +6,7 @@
;; Author: Kai Großjohann <kai.grossjohann@gmx.net>
;; Keywords: comm, processes
+;; Package: tramp
;; This file is part of GNU Emacs.
@@ -30,19 +31,31 @@
;; version check is defined in macro AC_EMACS_INFO of aclocal.m4;
;; should be changed only there.
-(defconst tramp-version "2.1.20"
+;;;###tramp-autoload
+(defconst tramp-version "2.2.0"
"This version of Tramp.")
+;;;###tramp-autoload
(defconst tramp-bug-report-address "tramp-devel@gnu.org"
"Email address to send bug reports to.")
;; Check for (X)Emacs version.
-(let ((x (if (or (>= emacs-major-version 22) (and (featurep 'xemacs) (= emacs-major-version 21) (>= emacs-minor-version 4))) "ok" (format "Tramp 2.1.20 is not fit for %s" (when (string-match "^.*$" (emacs-version)) (match-string 0 (emacs-version)))))))
+(let ((x (if (or (>= emacs-major-version 22)
+ (and (featurep 'xemacs)
+ (= emacs-major-version 21)
+ (>= emacs-minor-version 4)))
+ "ok"
+ (format "Tramp 2.2.0 is not fit for %s"
+ (when (string-match "^.*$" (emacs-version))
+ (match-string 0 (emacs-version)))))))
(unless (string-match "\\`ok\\'" x) (error "%s" x)))
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (unload-feature 'trampver 'force)))
+
(provide 'trampver)
-;; arch-tag: 443576ca-f8f1-4bb1-addc-5c70861e93b1
;;; trampver.el ends here
;; Local Variables:
diff --git a/lisp/net/xesam.el b/lisp/net/xesam.el
index 35df085bc57..03c188006d0 100644
--- a/lisp/net/xesam.el
+++ b/lisp/net/xesam.el
@@ -151,7 +151,7 @@
(defgroup xesam nil
"Xesam compatible interface to search engines."
:group 'extensions
- :group 'hypermedia
+ :group 'comm
:version "23.1")
(defcustom xesam-query-type 'user-query
diff --git a/lisp/newcomment.el b/lisp/newcomment.el
index 1e40317c9a1..de6b2474e21 100644
--- a/lisp/newcomment.el
+++ b/lisp/newcomment.el
@@ -6,6 +6,7 @@
;; Author: code extracted from Emacs-20's simple.el
;; Maintainer: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: comment uncomment
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -946,12 +947,12 @@ indentation to be kept as it was before narrowing."
(delete-char n)
(setq ,bindent (- ,bindent n)))))))))))
-;; Compute the number of extra comment starter characters
-;; (extra semicolons in Lisp mode, extra stars in C mode, etc.)
-;; If ARG is non-nil, just follow ARG.
-;; If the comment-starter is multi-char, just follow ARG.
-;; Otherwise obey comment-add, and double it if EXTRA is non-nil.
(defun comment-add (arg)
+ "Compute the number of extra comment starter characters
+\(extra semicolons in Lisp mode, extra stars in C mode, etc.)
+If ARG is non-nil, just follow ARG.
+If the comment starter is multi-char, just follow ARG.
+Otherwise obey `comment-add'."
(if (and (null arg) (= (string-match "[ \t]*\\'" comment-start) 1))
(* comment-add 1)
(1- (prefix-numeric-value arg))))
@@ -1163,8 +1164,8 @@ is passed on to the respective function."
(defun comment-dwim (arg)
"Call the comment command you want (Do What I Mean).
If the region is active and `transient-mark-mode' is on, call
- `comment-region' (unless it only consists of comments, in which
- case it calls `uncomment-region').
+`comment-region' (unless it only consists of comments, in which
+case it calls `uncomment-region').
Else, if the current line is empty, call `comment-insert-comment-function'
if it is defined, otherwise insert a comment and indent it.
Else if a prefix ARG is specified, call `comment-kill'.
diff --git a/lisp/notifications.el b/lisp/notifications.el
new file mode 100644
index 00000000000..dc4904db4ca
--- /dev/null
+++ b/lisp/notifications.el
@@ -0,0 +1,294 @@
+;;; notifications.el --- Client interface to desktop notifications.
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Julien Danjou <julien@danjou.info>
+;; Keywords: comm desktop notifications
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package provides an implementation of the Desktop Notifications
+;; <http://www.galago-project.org/specs/notification/>.
+
+;; In order to activate this package, you must add the following code
+;; into your .emacs:
+;;
+;; (require 'notifications)
+
+;;; Code:
+(eval-when-compile
+ (require 'cl))
+
+;; Pacify byte-compiler. D-Bus support in the Emacs core can be
+;; disabled with configuration option "--without-dbus". Declare used
+;; subroutines and variables of `dbus' therefore.
+(declare-function dbus-call-method "dbusbind.c")
+(declare-function dbus-register-signal "dbusbind.c")
+
+(require 'dbus)
+
+(defconst notifications-specification-version "1.1"
+ "The version of the Desktop Notifications Specification implemented.")
+
+(defconst notifications-application-name "Emacs"
+ "Default application name.")
+
+(defconst notifications-application-icon
+ (expand-file-name
+ "images/icons/hicolor/scalable/apps/emacs.svg"
+ data-directory)
+ "Default application icon.")
+
+(defconst notifications-service "org.freedesktop.Notifications"
+ "D-Bus notifications service name.")
+
+(defconst notifications-path "/org/freedesktop/Notifications"
+ "D-Bus notifications service path.")
+
+(defconst notifications-interface "org.freedesktop.Notifications"
+ "D-Bus notifications service path.")
+
+(defconst notifications-notify-method "Notify"
+ "D-Bus notifications service path.")
+
+(defconst notifications-close-notification-method "CloseNotification"
+ "D-Bus notifications service path.")
+
+(defconst notifications-action-signal "ActionInvoked"
+ "D-Bus notifications action signal.")
+
+(defconst notifications-closed-signal "NotificationClosed"
+ "D-Bus notifications closed signal.")
+
+(defconst notifications-closed-reason
+ '((1 expired)
+ (2 dismissed)
+ (3 close-notification)
+ (4 undefined))
+ "List of reasons why a notification has been closed.")
+
+(defvar notifications-on-action-map nil
+ "Mapping between notification and action callback functions.")
+
+(defvar notifications-on-close-map nil
+ "Mapping between notification and close callback functions.")
+
+(defun notifications-on-action-signal (id action)
+ "Dispatch signals to callback functions from `notifications-on-action-map'."
+ (let ((entry (assoc id notifications-on-action-map)))
+ (when entry
+ (funcall (cadr entry) id action)
+ (remove entry 'notifications-on-action-map))))
+
+(when (fboundp 'dbus-register-signal)
+ (dbus-register-signal
+ :session
+ notifications-service
+ notifications-path
+ notifications-interface
+ notifications-action-signal
+ 'notifications-on-action-signal))
+
+(defun notifications-on-closed-signal (id reason)
+ "Dispatch signals to callback functions from `notifications-on-closed-map'."
+ (let ((entry (assoc id notifications-on-close-map)))
+ (when entry
+ (funcall (cadr entry)
+ id (cadr (assoc reason notifications-closed-reason)))
+ (remove entry 'notifications-on-close-map))))
+
+(when (fboundp 'dbus-register-signal)
+ (dbus-register-signal
+ :session
+ notifications-service
+ notifications-path
+ notifications-interface
+ notifications-closed-signal
+ 'notifications-on-closed-signal))
+
+(defun notifications-notify (&rest params)
+ "Send notification via D-Bus using the Freedesktop notification protocol.
+Various PARAMS can be set:
+
+ :title The notification title.
+ :body The notification body text.
+ :app-name The name of the application sending the notification.
+ Default to `notifications-application-name'.
+ :replaces-id The notification ID that this notification replaces.
+ :app-icon The notification icon.
+ Default is `notifications-application-icon'.
+ Set to nil if you do not want any icon displayed.
+ :actions A list of actions in the form:
+ (KEY TITLE KEY TITLE ...)
+ where KEY and TITLE are both strings.
+ The default action (usually invoked by clicking the
+ notification) should have a key named \"default\".
+ The title can be anything, though implementations are free
+ not to display it.
+ :timeout The timeout time in milliseconds since the display
+ of the notification at which the notification should
+ automatically close.
+ If -1, the notification's expiration time is dependent
+ on the notification server's settings, and may vary for
+ the type of notification.
+ If 0, the notification never expires.
+ Default value is -1.
+ :urgency The urgency level.
+ Either `low', `normal' or `critical'.
+ :category The type of notification this is.
+ :desktop-entry This specifies the name of the desktop filename representing
+ the calling program.
+ :image-data This is a raw data image format which describes the width,
+ height, rowstride, has alpha, bits per sample, channels and
+ image data respectively.
+ :image-path This is represented either as a URI (file:// is the
+ only URI schema supported right now) or a name
+ in a freedesktop.org-compliant icon theme.
+ :sound-file The path to a sound file to play when the notification pops up.
+ :sound-name A themeable named sound from the freedesktop.org sound naming
+ specification to play when the notification pops up.
+ Similar to icon-name,only for sounds. An example would
+ be \"message-new-instant\".
+ :suppress-sound Causes the server to suppress playing any sounds, if it has
+ that ability.
+ :x Specifies the X location on the screen that the notification
+ should point to. The \"y\" hint must also be specified.
+ :y Specifies the Y location on the screen that the notification
+ should point to. The \"x\" hint must also be specified.
+ :on-action Function to call when an action is invoked.
+ The notification id and the key of the action are passed
+ as arguments to the function.
+ :on-close Function to call when the notification has been closed
+ by timeout or by the user.
+ The function receive the notification id and the closing
+ reason as arguments:
+ - `expired' if the notification has expired
+ - `dismissed' if the notification was dismissed by the user
+ - `close-notification' if the notification was closed
+ by a call to CloseNotification
+
+This function returns a notification id, an integer, which can be
+used to manipulate the notification item with
+`notifications-close'."
+ (let ((title (plist-get params :title))
+ (body (plist-get params :body))
+ (app-name (plist-get params :app-name))
+ (replaces-id (plist-get params :replaces-id))
+ (app-icon (plist-get params :app-icon))
+ (actions (plist-get params :actions))
+ (timeout (plist-get params :timeout))
+ ;; Hints
+ (hints '())
+ (urgency (plist-get params :urgency))
+ (category (plist-get params :category))
+ (desktop-entry (plist-get params :desktop-entry))
+ (image-data (plist-get params :image-data))
+ (image-path (plist-get params :image-path))
+ (sound-file (plist-get params :sound-file))
+ (sound-name (plist-get params :sound-name))
+ (suppress-sound (plist-get params :suppress-sound))
+ (x (plist-get params :x))
+ (y (plist-get params :y))
+ id)
+ ;; Build hints array
+ (when urgency
+ (add-to-list 'hints `(:dict-entry
+ "urgency"
+ (:variant :byte ,(case urgency
+ ('low 0)
+ ('critical 2)
+ (t 1)))) t))
+ (when category
+ (add-to-list 'hints `(:dict-entry
+ "category"
+ (:variant :string ,category)) t))
+ (when desktop-entry
+ (add-to-list 'hints `(:dict-entry
+ "desktop-entry"
+ (:variant :string ,desktop-entry)) t))
+ (when image-data
+ (add-to-list 'hints `(:dict-entry
+ "image_data"
+ (:variant :struct ,image-data)) t))
+ (when image-path
+ (add-to-list 'hints `(:dict-entry
+ "image_path"
+ (:variant :string ,image-path)) t))
+ (when sound-file
+ (add-to-list 'hints `(:dict-entry
+ "sound-file"
+ (:variant :string ,sound-file)) t))
+ (when sound-name
+ (add-to-list 'hints `(:dict-entry
+ "sound-name"
+ (:variant :string ,sound-name)) t))
+ (when suppress-sound
+ (add-to-list 'hints `(:dict-entry
+ "suppress-sound"
+ (:variant :boolean ,suppress-sound)) t))
+ (when x
+ (add-to-list 'hints `(:dict-entry "x" (:variant :int32 ,x)) t))
+ (when y
+ (add-to-list 'hints `(:dict-entry "y" (:variant :int32 ,y)) t))
+
+ ;; Call Notify method
+ (setq id
+ (dbus-call-method :session
+ notifications-service
+ notifications-path
+ notifications-interface
+ notifications-notify-method
+ :string (or app-name
+ notifications-application-name)
+ :uint32 (or replaces-id 0)
+ :string (if app-icon
+ (expand-file-name app-icon)
+ ;; If app-icon is nil because user
+ ;; requested it to be so, send the
+ ;; empty string
+ (if (plist-member params :app-icon)
+ ""
+ ;; Otherwise send the default icon path
+ notifications-application-icon))
+ :string (or title "")
+ :string (or body "")
+ `(:array ,@actions)
+ (or hints '(:array :signature "{sv}"))
+ :int32 (or timeout -1)))
+
+ ;; Register close/action callback function
+ (let ((on-action (plist-get params :on-action))
+ (on-close (plist-get params :on-close)))
+ (when on-action
+ (add-to-list 'notifications-on-action-map (list id on-action)))
+ (when on-close
+ (add-to-list 'notifications-on-close-map (list id on-close))))
+
+ ;; Return notification id
+ id))
+
+(defun notifications-close-notification (id)
+ "Close a notification with identifier ID."
+ (dbus-call-method :session
+ notifications-service
+ notifications-path
+ notifications-interface
+ notifications-close-notification-method
+ :int32 id))
+
+(provide 'notifications)
diff --git a/lisp/nxml/TODO b/lisp/nxml/TODO
deleted file mode 100644
index a5ac542f942..00000000000
--- a/lisp/nxml/TODO
+++ /dev/null
@@ -1,468 +0,0 @@
-* High priority
-
-** Command to insert an element template, including all required
-attributes and child elements. When there's a choice of elements
-possible, we could insert a comment, and put an overlay on that
-comment that makes it behave like a button with a pop-up menu to
-select the appropriate choice.
-
-** Command to tag a region. With a schema should complete using legal
-tags, but should work without a schema as well.
-
-** Provide a way to conveniently rename an element. With a schema should
-complete using legal tags, but should work without a schema as well.
-
-* Outlining
-
-** Implement C-c C-o C-q.
-
-** Install pre/post command hook for moving out of invisible section.
-
-** Put a modify hook on invisible sections that expands them.
-
-** Integrate dumb folding somehow.
-
-** An element should be able to be its own heading.
-
-** Optimize to avoid complete buffer scan on each command.
-
-** Make it work with HTML-style headings (i.e. level indicated by
-name of heading element rather than depth of section nesting).
-
-** Recognize root element as a section provided it has a title, even
-if it doesn't match section-element-name-regex.
-
-** Support for incremental search automatically making hidden text
-visible.
-
-** Allow title to be an attribute.
-
-** Command that says to recognize the tag at point as a section/heading.
-
-** Explore better ways to determine when an element is a section
-or a heading.
-
-** rng-next-error needs to either ignore invisible portion or reveal it
-(maybe use isearch oriented text properties).
-
-** Errors within hidden section should be highlighted by underlining the
-ellipsis.
-
-** Make indirect buffers work.
-
-** How should nxml-refresh outline recover from non well-formed tags?
-
-** Hide tags in title elements?
-
-** Use overlays instead of text properties for holding outline state?
-Necessary for indirect buffers to work?
-
-** Allow an outline to go in the speedbar.
-
-** Split up outlining manual section into subsections.
-
-** More detail in the manual about each outlining command.
-
-** More menu entries for hiding/showing?
-
-** Indication of many lines have been hidden?
-
-* Locating schemas
-
-** Should rng-validate-mode give the user an opportunity to specify a
-schema if there is currently none? Or should it at least give a hint
-to the user how to specify a non-vacuous schema?
-
-** Support for adding new schemas to schema-locating files. Add
-documentElement and namespace elements.
-
-** C-c C-w should be able to report current type id.
-
-** Implement doctypePublicId.
-
-** Implement typeIdBase.
-
-** Implement typeIdProcessingInstruction.
-
-** Support xml:base.
-
-** Implement group.
-
-** Find preferred prefix from schema-locating files. Get rid of
-rng-preferred-prefix-alist.
-
-** Inserting document element with vacuous schema should complete using
-document elements declared in schema locating files, and set schema
-appropriately.
-
-** Add a ruleType attribute to the <include> element?
-
-** Allow processing instruction in prolog to contain the compact syntax
-schema directly.
-
-** Use RDDL to locate a schema based on the namespace URI.
-
-** Should not prompt to add redundant association to schema locating
-file.
-
-** Command to reload current schema.
-
-* Schema-sensitive features
-
-** Should filter dynamic markup possibilities using schema validity, by
-adding hook to nxml-mode.
-
-** Dynamic markup word should (at least optionally) be able to look in
-other buffers that are using nxml-mode.
-
-** Should clicking on Invalid move to next error if already on an error?
-
-** Take advantage of a:documentation. Needs change to schema format.
-
-** Provide feasible validation (as in Jing) toggle.
-
-** Save the validation state as a property on the error overlay to enable
-more detailed diagnosis.
-
-** Provide an Error Summary buffer showing all the validation errors.
-
-** Pop-up menu. What is useful? Tag a region (should be greyed out if
-the region is not balanced). Suggestions based on error messages.
-
-** Have configurable list of namespace URIs so that we can provide
-namespace URI completion on extension elements or with schema-less
-documents.
-
-** Allow validation to handle XInclude.
-
-** ID/IDREF support.
-
-* Completion
-
-** Make it work with icomplete. Only use a function to complete when
-some of the possible names have undeclared namespaces.
-
-** How should C-return in mixed text work?
-
-** When there's a vacuous schema, C-return after < will insert the
-end-tag. Is this a bug or a feature?
-
-** After completing start-tag, ensure we don't get unhelpful message
-from validation
-
-** Syntax table for completion.
-
-** Should complete start-tag name with a space if namespace attributes
-are required.
-
-** When completing start-tag name with no prefix and it doesn't match
-should try to infer namespace from local name.
-
-** Should completion pay attention to characters after point? If so,
-how?
-
-** When completing start-tag name, add required atts if only one required
-attribute.
-
-** When completing attribute name, add attribute value if only one value
-is possible.
-
-** After attribute-value completion, insert space after close delimiter
-if more attributes are required.
-
-** Complete on enumerated data values in elements.
-
-** When in context that allows only elements, should get tag
-completion without having to type < first.
-
-** When immediately after start-tag name, and name is valid and not
-prefix of any other name, should C-return complete on attribute names?
-
-** When completing attributes, more consistent to ignore all attributes
-after point.
-
-** Inserting attribute value completions needs to be sensitive to what
-delimiter is used so that it quotes the correct character.
-
-** Complete on encoding-names in XML decl.
-
-** Complete namespace declarations by searching for all namespaces
-mentioned in the schema.
-
-* Well-formed XML support
-
-** Deal better with Mule-UCS
-
-** Deal with UTF-8 BOM when reading.
-
-** Complete entity names.
-
-** Provide some support for entity names for MathML.
-
-** Command to repeat the last tag.
-
-** Support for changing between character references and characters.
-Need to check that context is one in which character references are
-allowed. xmltok prolog parsing will need to distinguish parameter
-literals from other kinds of literal.
-
-** Provide a comment command to bind to M-; that works better than the
-normal one.
-
-** Make indenting in a multi-line comment work.
-
-** Structure view. Separate buffer displaying element tree. Be able to
-navigate from structure view to document and vice-versa.
-
-** Flash matching >.
-
-** Smart selection command that selects increasingly large syntactically
-coherent chunks of XML. If point is in an attribute value, first
-select complete value; then if command is repeated, select value plus
-delimiters, then select attribute name as well, then complete
-start-tag, then complete element, then enclosing element, etc.
-
-** ispell integration.
-
-** Block-level items in mixed content should be indented, e.g:
- <para>This is list:
- <ul>
- <li>item</li>
-
-** Provide option to indent like this:
-
-** <para>This is a paragraph
- occupying multiple lines.</para>
-
-** Option to add make a / that closes a start-tag electrically insert a
-space for the XHTML guys.
-
-** C-M-q should work.
-
-* Datatypes
-
-** Figure out workaround for CJK characters with regexps.
-
-** Does category C contain Cn?
-
-** Do ENTITY datatype properly.
-
-* XML Parsing Library
-
-** Parameter entity parsing option, nil (never), t (always),
-unless-standalone (unless standalone="yes" in XML declaration).
-
-** When a file is currently being edited, there should be an option to
-use its buffer instead of the on-disk copy.
-
-* Handling all XML features
-
-** Provide better support for editing external general parsed entities.
-Perhaps provide a way to force ignoring undefined entities; maybe turn
-this on automatically with <?xml encoding=""?> (with no version
-pseudo-att).
-
-** Handle internal general entity declarations containing elements.
-
-** Handle external general entity declarations.
-
-** Handle default attribute declarations in internal subset.
-
-** Handle parameter entities (including DTD).
-
-* RELAX NG
-
-** Do complete schema checking, at least optionally.
-
-** Detect include/external loops during schema parse.
-
-** Coding system detection for schemas. Should use utf-8/utf-16 per the
-spec. But also need to allow encodings other than UTF-8/16 to support
-CJK charsets that Emacs cannot represent in Unicode.
-
-* Catching XML errors
-
-** Check public identifiers.
-
-** Check default attribute values.
-
-* Performance
-
-** Explore whether overlay-recenter can cure overlays performance
-problems.
-
-** Cache schemas. Need to have list of files and mtimes.
-
-** Make it possible to reduce rng-validate-chunk-size significantly,
-perhaps to 500 bytes, without bad performance impact: don't do
-redisplay on every chunk; pass continue functions on other uses of
-rng-do-some-validation.
-
-** Cache after first tag.
-
-** Introduce a new name class that is a choice between names (so that
-we can use member)
-
-** intern-choice should simplify after patterns with same 1st/2nd args
-
-** Large numbers of overlays slow things down dramatically. Represent
-errors using text properties. This implies we cannot incrementally
-keep track of the number of errors, in order to determine validity.
-Instead, when validation completes, scan for any characters with an
-error text property; this seems to be fast enough even with large
-buffers. Problem with error at end of buffer, where there's no
-character; need special variable for this. Need to merge face from
-font-lock with the error face: use :inherit attribute with list of two
-faces. How do we avoid making rng-valid depend on nxml-mode?
-
-* Error recovery
-
-** Don't stop at newline in looking for close of start-tag.
-
-** Use indentation to guide recovery from mismatched end-tags
-
-** Don't keep parsing when currently not well-formed but previously
-well-formed
-
-** Try to recover from a bad start-tag by popping an open element if
-there was a mismatched end-tag unaccounted for.
-
-** Try to recover from a bad start-tag open on the hypothesis that there
-was an error in the namespace URI.
-
-** Better recovery from ill-formed XML declarations.
-
-* Useability improvements
-
-** Should print a "Parsing..." message during long movements.
-
-** Provide better position for reference to undefined pattern error.
-
-** Put Well-formed in the mode-line when validating against any-content.
-
-** Trim marking of illegal data for leading and trailing whitespace.
-
-** Show Invalid status as soon as we are sure it's invalid, rather than
-waiting for everything to be completely up to date.
-
-** When narrowed, Valid or Invalid status should probably consider only
-validity of narrowed region.
-
-* Bug fixes
-
-** Need to give an error for a document like: <foo/><![CDATA[ ]]>
-
-** Make nxml-forward-balanced-item work better for the prolog.
-
-** Make filling and indenting comments work in the prolog.
-
-** Should delete RNC Input buffers.
-
-** Figure out what regex use for NCName and use it consistently,
-
-** Should have not-well-formed tokens in ref.
-
-** Require version in XML declaration? Probably not because prevents
-use for external parsed entities. At least forbid standalone
-without version.
-
-** Reject schema that compiles to rng-not-allowed-ipattern.
-
-** Move point backwards on schema parse error so that it's on the right token.
-
-* Internal
-
-** Use rng-quote-string consistently.
-
-** Use parsing library for XML to texinfo conversion.
-
-** Rename xmltok.el to nxml-token.el. Use nxml-t- prefix instead of
-xmltok-. Change nxml-t-type to nxml-t-token-type, nxml-t-start to
-nxml-t-token-start.
-
-** Can we set fill-prefix to nil and rely on indenting?
-
-** xmltok should make available replacement text of entities containing
-elements
-
-** In rng-valid, instead of using modification-hooks and
-insert-behind-hooks on dependent overlays, use same technique as
-nxml-mode.
-
-** Port to XEmacs. Issues include: Unicode (XEmacs seems to be based on
-Mule-UCS); overlays/text properties vs extents; absence of
-fontification-functions hook.
-
-* Fontification
-
-** Allow face to depend on element qname, attribute qname, attribute
-value. Use list with pairs of (R . F), where R specifies regexps and
-F specifies faces. How can this list be made to depend on the
-document type?
-
-* Other
-
-** Support RELAX NG XML syntax (use XML parsing library).
-
-** Support W3C XML Schema (use XML parsing library).
-
-** Command to infer schema from current document (like trang).
-
-* Schemas
-
-** XSLT schema should take advantage of RELAX NG to express cooccurrence
-constraints on attributes (e.g. xsl:template).
-
-* Documentation
-
-** Move material from README to manual.
-
-** Document encodings.
-
-* Notes
-
-** How can we allow an error to be displayed on a different token from
-where it is detected? In particular, for a missing closing ">" we
-will need to display it at the beginning of the following token. At
-the moment, when we parse the following token the error overlay will
-get cleared.
-
-** How should rng-goto-next-error deal with narrowing?
-
-** Perhaps should merge errors having same start position even if they
-have different ends.
-
-** How to handle surrogates? One possibility is to be compatible with
-utf8.e: represent as sequence of 4 chars. But utf-16 is incompatible
-with this.
-
-** Should we distinguish well-formedness errors from invalidity errors?
-(I think not: we may want to recover from a bad start-tag by implying
-an end-tag.)
-
-** Seems to be a bug with Emacs, where a mouse movement that causes
-help-echo text to appear counts as pending input but does not cause
-idle timer to be restarted.
-
-** Use XML to represent this file.
-
-** I had a TODO which said simply "split-string". What did I mean?
-
-** Investigate performance on large files all on one line.
-
-* Issues for Emacs versions >= 22
-
-** Take advantage of UTF-8 CJK support.
-
-** Supply a next-error-function.
-
-** Investigate this NEWS item "Emacs now tries to set up buffer coding
-systems for HTML/XML files automatically."
-
-** Take advantage of the pointer text property.
-
-** Leverage char-displayable-p.
-
-Local variables:
-mode: outline
-end:
diff --git a/lisp/nxml/nxml-maint.el b/lisp/nxml/nxml-maint.el
index 5062da5cff9..a10ad2b21ac 100644
--- a/lisp/nxml/nxml-maint.el
+++ b/lisp/nxml/nxml-maint.el
@@ -1,6 +1,7 @@
;;; nxml-maint.el --- commands for maintainers of nxml-*.el
-;; Copyright (C) 2003, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: James Clark
;; Keywords: XML
@@ -78,7 +79,7 @@
(goto-char (point-min))
(while (re-search-forward "^ *\\([a-FA-F0-9]\\{2\\}\\)[ \t]+" nil t)
(let ((row (match-string 1))
- (eol (save-excursion (end-of-line) (point))))
+ (eol (line-end-position)))
(while (re-search-forward "\\([a-FA-F0-9]\\{2\\}\\)-\\([a-FA-F0-9]\\{2\\}\\)\\|\\([a-FA-F0-9]\\{2\\}\\)" eol t)
(setq lst
(cons (if (match-beginning 3)
@@ -102,5 +103,4 @@
(provide 'nxml-maint)
-;; arch-tag: 2cff6b55-12af-47db-90da-a91f782f435a
;;; nxml-maint.el ends here
diff --git a/lisp/nxml/nxml-mode.el b/lisp/nxml/nxml-mode.el
index 8919d920c9d..290e660cf5b 100644
--- a/lisp/nxml/nxml-mode.el
+++ b/lisp/nxml/nxml-mode.el
@@ -45,8 +45,7 @@
(defgroup nxml nil
"New XML editing mode."
- :group 'languages
- :group 'wp)
+ :group 'languages)
(defgroup nxml-faces nil
"Faces for XML syntax highlighting."
@@ -405,6 +404,8 @@ reference.")
(define-key map "\M-}" 'nxml-forward-paragraph)
(define-key map "\M-h" 'nxml-mark-paragraph)
(define-key map "\C-c\C-f" 'nxml-finish-element)
+ (define-key map "\C-c]" 'nxml-finish-element)
+ (define-key map "\C-c/" 'nxml-finish-element)
(define-key map "\C-c\C-m" 'nxml-split-element)
(define-key map "\C-c\C-b" 'nxml-balanced-close-start-tag-block)
(define-key map "\C-c\C-i" 'nxml-balanced-close-start-tag-inline)
@@ -1370,17 +1371,21 @@ of the inserted start-tag or nil if none was inserted."
(defun nxml-indent-line ()
"Indent current line as XML."
- (let ((indent (nxml-compute-indent))
- (from-end (- (point-max) (point))))
- (when (and indent
- (/= indent (current-indentation)))
- (beginning-of-line)
- (let ((bol (point)))
- (skip-chars-forward " \t")
- (delete-region bol (point)))
- (indent-to indent)
- (when (> (- (point-max) from-end) (point))
- (goto-char (- (point-max) from-end))))))
+ (let* ((savep (point))
+ (indent (condition-case nil
+ (save-excursion
+ (forward-line 0)
+ (skip-chars-forward " \t")
+ (if (>= (point) savep) (setq savep nil))
+ (or (nxml-compute-indent) 0))
+ (error 0))))
+ (if (not (numberp indent))
+ ;; If something funny is used (e.g. `noindent'), return it.
+ indent
+ (if (< indent 0) (setq indent 0)) ;Just in case.
+ (if savep
+ (save-excursion (indent-line-to indent))
+ (indent-line-to indent)))))
(defun nxml-compute-indent ()
"Return the indent for the line containing point."
diff --git a/lisp/obsolete/cl-compat.el b/lisp/obsolete/cl-compat.el
index f4582081031..622c4eaace6 100644
--- a/lisp/obsolete/cl-compat.el
+++ b/lisp/obsolete/cl-compat.el
@@ -73,11 +73,6 @@
;;; by capitalizing the first letter: Values, Multiple-value-*,
;;; to avoid conflict with the new-style definitions in cl-macs.
-(put 'Multiple-value-bind 'lisp-indent-function 2)
-(put 'Multiple-value-setq 'lisp-indent-function 2)
-(put 'Multiple-value-call 'lisp-indent-function 1)
-(put 'Multiple-value-prog1 'lisp-indent-function 1)
-
(defvar *mvalues-values* nil)
(defun Values (&rest val-forms)
@@ -93,18 +88,22 @@
(list *mvalues-temp*))))
(defmacro Multiple-value-call (function &rest args)
+ (declare (indent 1))
(list 'apply function
(cons 'append
(mapcar (function (lambda (x) (list 'Multiple-value-list x)))
args))))
(defmacro Multiple-value-bind (vars form &rest body)
+ (declare (indent 2))
(list* 'multiple-value-bind vars (list 'Multiple-value-list form) body))
(defmacro Multiple-value-setq (vars form)
+ (declare (indent 2))
(list 'multiple-value-setq vars (list 'Multiple-value-list form)))
(defmacro Multiple-value-prog1 (form &rest body)
+ (declare (indent 1))
(list 'prog1 form (list* 'let '((*mvalues-values* nil)) body)))
diff --git a/lisp/complete.el b/lisp/obsolete/complete.el
index ba78820a49f..b7e94743802 100644
--- a/lisp/complete.el
+++ b/lisp/obsolete/complete.el
@@ -5,6 +5,8 @@
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Keywords: abbrev convenience
+;; Obsolete-since: 24.1
+;;
;; Special thanks to Hallvard Furuseth for his many ideas and contributions.
;; This file is part of GNU Emacs.
@@ -697,7 +699,7 @@ GOTO-END is non-nil, however, it instead replaces up to END."
(if (and (eq mode 'word)
(not PC-word-failed-flag))
(let ((PC-word-failed-flag t))
- (delete-backward-char 1)
+ (delete-char -1)
(PC-do-completion 'word))
(when abbreviated
(delete-region beg end)
diff --git a/lisp/obsolete/lazy-lock.el b/lisp/obsolete/lazy-lock.el
index ae1f32537b0..b425498e182 100644
--- a/lisp/obsolete/lazy-lock.el
+++ b/lisp/obsolete/lazy-lock.el
@@ -310,7 +310,7 @@ until TEST returns nil."
;; User Variables:
(defcustom lazy-lock-minimum-size 25600
- "*Minimum size of a buffer for demand-driven fontification.
+ "Minimum size of a buffer for demand-driven fontification.
On-demand fontification occurs if the buffer size is greater than this value.
If nil, means demand-driven fontification is never performed.
If a list, each element should be a cons pair of the form (MAJOR-MODE . SIZE),
@@ -334,7 +334,7 @@ The value of this variable is used when Lazy Lock mode is turned on."
:group 'lazy-lock)
(defcustom lazy-lock-defer-on-the-fly t
- "*If non-nil, means fontification after a change should be deferred.
+ "If non-nil, means fontification after a change should be deferred.
If nil, means on-the-fly fontification is performed. This means when changes
occur in the buffer, those areas are immediately fontified.
If a list, it should be a list of `major-mode' symbol names for which deferred
@@ -354,7 +354,7 @@ The value of this variable is used when Lazy Lock mode is turned on."
:group 'lazy-lock)
(defcustom lazy-lock-defer-on-scrolling nil
- "*If non-nil, means fontification after a scroll should be deferred.
+ "If non-nil, means fontification after a scroll should be deferred.
If nil, means demand-driven fontification is performed. This means when
scrolling into unfontified areas of the buffer, those areas are immediately
fontified. Thus scrolling never presents unfontified areas. However, since
@@ -379,7 +379,7 @@ The value of this variable is used when Lazy Lock mode is turned on."
:group 'lazy-lock)
(defcustom lazy-lock-defer-contextually 'syntax-driven
- "*If non-nil, means deferred fontification should be syntactically true.
+ "If non-nil, means deferred fontification should be syntactically true.
If nil, means deferred fontification occurs only on those lines modified. This
means where modification on a line causes syntactic change on subsequent lines,
those subsequent lines are not refontified to reflect their new context.
@@ -396,9 +396,8 @@ The value of this variable is used when Lazy Lock mode is turned on."
(other :tag "syntax-driven" syntax-driven))
:group 'lazy-lock)
-(defcustom lazy-lock-defer-time
- (if (featurep 'lisp-float-type) (/ (float 1) (float 4)) 1)
- "*Time in seconds to delay before beginning deferred fontification.
+(defcustom lazy-lock-defer-time 0.25
+ "Time in seconds to delay before beginning deferred fontification.
Deferred fontification occurs if there is no input within this time.
If nil, means fontification is never deferred, regardless of the values of the
variables `lazy-lock-defer-on-the-fly', `lazy-lock-defer-on-scrolling' and
@@ -410,7 +409,7 @@ The value of this variable is used when Lazy Lock mode is turned on."
:group 'lazy-lock)
(defcustom lazy-lock-stealth-time 30
- "*Time in seconds to delay before beginning stealth fontification.
+ "Time in seconds to delay before beginning stealth fontification.
Stealth fontification occurs if there is no input within this time.
If nil, means stealth fontification is never performed.
@@ -420,7 +419,7 @@ The value of this variable is used when Lazy Lock mode is turned on."
:group 'lazy-lock)
(defcustom lazy-lock-stealth-lines (if font-lock-maximum-decoration 100 250)
- "*Maximum size of a chunk of stealth fontification.
+ "Maximum size of a chunk of stealth fontification.
Each iteration of stealth fontification can fontify this number of lines.
To speed up input response during stealth fontification, at the cost of stealth
taking longer to fontify, you could reduce the value of this variable."
@@ -429,7 +428,7 @@ taking longer to fontify, you could reduce the value of this variable."
(defcustom lazy-lock-stealth-load
(if (condition-case nil (load-average) (error)) 200)
- "*Load in percentage above which stealth fontification is suspended.
+ "Load in percentage above which stealth fontification is suspended.
Stealth fontification pauses when the system short-term load average (as
returned by the function `load-average' if supported) goes above this level,
thus reducing the demand that stealth fontification makes on the system.
@@ -443,9 +442,8 @@ See also `lazy-lock-stealth-nice'."
'(const :format "%t: unsupported\n" nil))
:group 'lazy-lock)
-(defcustom lazy-lock-stealth-nice
- (if (featurep 'lisp-float-type) (/ (float 1) (float 8)) 1)
- "*Time in seconds to pause between chunks of stealth fontification.
+(defcustom lazy-lock-stealth-nice 0.125
+ "Time in seconds to pause between chunks of stealth fontification.
Each iteration of stealth fontification is separated by this amount of time,
thus reducing the demand that stealth fontification makes on the system.
If nil, means stealth fontification is never paused.
@@ -457,9 +455,8 @@ See also `lazy-lock-stealth-load'."
:group 'lazy-lock)
(defcustom lazy-lock-stealth-verbose
- (if (featurep 'lisp-float-type)
- (and (not lazy-lock-defer-contextually) (not (null font-lock-verbose))))
- "*If non-nil, means stealth fontification should show status messages."
+ (and (not lazy-lock-defer-contextually) (not (null font-lock-verbose)))
+ "If non-nil, means stealth fontification should show status messages."
:type 'boolean
:group 'lazy-lock)
@@ -1058,5 +1055,4 @@ verbosity is controlled via the variable `lazy-lock-stealth-verbose'."
;; byte-compile-warnings: (not obsolete)
;; End:
-;; arch-tag: c1776846-f046-4a45-9684-54b951b12fc9
;;; lazy-lock.el ends here
diff --git a/lisp/obsolete/lucid.el b/lisp/obsolete/lucid.el
index 85edd310a92..a35cde02290 100644
--- a/lisp/obsolete/lucid.el
+++ b/lisp/obsolete/lucid.el
@@ -1,7 +1,7 @@
;;; lucid.el --- emulate some Lucid Emacs functions
-;; Copyright (C) 1993, 1995, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1995, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: emulations
@@ -89,8 +89,8 @@ This function exists for compatibility with XEmacs."
((display-grayscale-p device) 'grayscale)
(t 'mono)))
-(defalias 'find-face 'internal-find-face)
-(defalias 'get-face 'internal-get-face)
+(defalias 'find-face 'facep)
+(defalias 'get-face 'facep)
;; internal-try-face-font was removed from faces.el in rev 1.139, 1999/07/21.
;;;(defalias 'try-face-font 'internal-try-face-font)
@@ -234,5 +234,8 @@ This is an XEmacs compatibility function."
(provide 'lucid)
-;; arch-tag: 80f9ab46-0b36-4151-86ed-3edb6d449c9e
+;; Local Variables:
+;; byte-compile-warnings: (not cl-functions)
+;; End:
+
;;; lucid.el ends here
diff --git a/lisp/obsolete/old-whitespace.el b/lisp/obsolete/old-whitespace.el
index 4531bc06f81..71568f98d55 100644
--- a/lisp/obsolete/old-whitespace.el
+++ b/lisp/obsolete/old-whitespace.el
@@ -725,9 +725,8 @@ If timer is not set, then set it to scan the files in
(setq bufname (cadr thiselt))
(setq buf (get-buffer bufname))
(if (buffer-live-p buf)
- (save-excursion
+ (with-current-buffer bufname
;;(message "buffer %s live" bufname)
- (set-buffer bufname)
(if whitespace-mode
(progn
;;(message "checking for whitespace in %s" bufname)
@@ -788,7 +787,7 @@ This is meant to be added buffer-locally to `write-file-functions'."
(defun whitespace-unload-function ()
"Unload the whitespace library."
- (if (unintern "whitespace-unload-hook")
+ (if (unintern "whitespace-unload-hook" obarray)
;; if whitespace-unload-hook is defined, let's get rid of it
;; and recursively call `unload-feature'
(progn (unload-feature 'whitespace) t)
diff --git a/lisp/obsolete/rnews.el b/lisp/obsolete/rnews.el
deleted file mode 100644
index 5b0f5d5a6b0..00000000000
--- a/lisp/obsolete/rnews.el
+++ /dev/null
@@ -1,981 +0,0 @@
-;;; rnews.el --- USENET news reader for GNU Emacs
-
-;; Copyright (C) 1985, 1986, 1987, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Maintainer: FSF
-;; Keywords: news
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This file has been obsolete since Emacs 21.1.
-
-;;; Change Log:
-
-;; Created Sun Mar 10,1985 at 21:35:01 ads and sundar@hernes.ai.mit.edu
-;; Should do the point pdl stuff sometime
-;; finito except pdl.... Sat Mar 16,1985 at 06:43:44
-;; lets keep the summary stuff out until we get it working ..
-;; sundar@hermes.ai.mit.edu Wed Apr 10,1985 at 16:32:06
-;; hack slash maim. mly@gnu.org Thu 18 Apr, 1985 06:11:14
-;; modified to correct reentrance bug, to not bother with groups that
-;; received no new traffic since last read completely, to find out
-;; what traffic a group has available much more quickly when
-;; possible, to do some completing reads for group names - should
-;; be much faster...
-;; KING@KESTREL.arpa, Thu Mar 13 09:03:28 1986
-;; made news-{next,previous}-group skip groups with no new messages; and
-;; added checking for unsubscribed groups to news-add-news-group
-;; tower@gnu.org Jul 18 1986
-;; bound rmail-output to C-o; and changed header-field commands binding to
-;; agree with the new C-c C-f usage in sendmail
-;; tower@gnu.org Sep 3 1986
-;; added news-rotate-buffer-body
-;; tower@gnu.org Oct 17 1986
-;; made messages more user friendly, cleaned up news-inews
-;; move posting and mail code to new file rnewpost.el
-;; tower@gnu.org Oct 29 1986
-;; added caesar-region, rename news-caesar-buffer-body, hacked accordingly
-;; tower@gnu.org Nov 21 1986
-;; added tower@gnu.org 22 Apr 87
-
-;;; Code:
-
-(require 'mail-utils)
-(require 'sendmail)
-
-(defvar caesar-translate-table)
-(defvar minor-modes)
-(defvar news-buffer-save)
-(defvar news-group-name)
-(defvar news-minor-modes)
-
-(autoload 'rmail-output "rmailout"
- "Append this message to Unix mail file named FILE-NAME."
- t)
-
-(autoload 'news-reply "rnewspost"
- "Compose and post a reply to the current article on USENET.
-While composing the reply, use \\[mail-yank-original] to yank the original
-message into it."
- t)
-
-(autoload 'news-mail-other-window "rnewspost"
- "Send mail in another window.
-While composing the message, use \\[mail-yank-original] to yank the
-original message into it."
- t)
-
-(autoload 'news-post-news "rnewspost"
- "Begin editing a new USENET news article to be posted."
- t)
-
-(autoload 'news-mail-reply "rnewspost"
- "Mail a reply to the author of the current article.
-While composing the reply, use \\[mail-yank-original] to yank the original
-message into it."
- t)
-
-(defvar news-group-hook-alist nil
- "Alist of (GROUP-REGEXP . HOOK) pairs.
-Just before displaying a message, each HOOK is called
-if its GROUP-REGEXP matches the current newsgroup name.")
-
-(defvar rmail-last-file (expand-file-name "~/mbox.news"))
-
-;Now in paths.el.
-;(defvar news-path "/usr/spool/news/"
-; "The root directory below which all news files are stored.")
-
-(defvar news-startup-file "$HOME/.newsrc" "Contains ~/.newsrc")
-(defvar news-certification-file "$HOME/.news-dates" "Contains ~/.news-dates")
-
-;; random headers that we decide to ignore.
-(defvar news-ignored-headers
- "^Path:\\|^Posting-Version:\\|^Article-I.D.:\\|^Expires:\\|^Date-Received:\\|^References:\\|^Control:\\|^Xref:\\|^Lines:\\|^Posted:\\|^Relay-Version:\\|^Message-ID:\\|^Nf-ID:\\|^Nf-From:\\|^Approved:\\|^Sender:"
- "All random fields within the header of a message.")
-
-(defvar news-mode-map nil)
-(defvar news-read-first-time-p t)
-;; Contains the (dotified) news groups of which you are a member.
-(defvar news-user-group-list nil)
-
-(defvar news-current-news-group nil)
-(defvar news-current-group-begin nil)
-(defvar news-current-group-end nil)
-(defvar news-current-certifications nil
- "An assoc list of a group name and the time at which it is
-known that the group had no new traffic")
-(defvar news-current-certifiable nil
- "The time when the directory we are now working on was written")
-
-(defvar news-message-filter nil
- "User specifiable filter function that will be called during
-formatting of the news file")
-
-;(defvar news-mode-group-string "Starting-Up"
-; "Mode line group name info is held in this variable")
-(defvar news-list-of-files nil
- "Global variable in which we store the list of files
-associated with the current newsgroup")
-(defvar news-list-of-files-possibly-bogus nil
- "variable indicating we only are guessing at which files are available.
-Not currently used.")
-
-;; association list in which we store lists of the form
-;; (pointified-group-name (first last old-last))
-(defvar news-group-article-assoc nil)
-
-(defvar news-current-message-number 0 "Displayed Article Number")
-(defvar news-total-current-group 0 "Total no of messages in group")
-
-(defvar news-unsubscribe-groups ())
-(defvar news-point-pdl () "List of visited news messages.")
-(defvar news-no-jumps-p t)
-(defvar news-buffer () "Buffer into which news files are read.")
-
-(defmacro news-push (item ref)
- (list 'setq ref (list 'cons item ref)))
-
-(defmacro news-cadr (x) (list 'car (list 'cdr x)))
-(defmacro news-cdar (x) (list 'cdr (list 'car x)))
-(defmacro news-caddr (x) (list 'car (list 'cdr (list 'cdr x))))
-(defmacro news-cadar (x) (list 'car (list 'cdr (list 'car x))))
-(defmacro news-caadr (x) (list 'car (list 'car (list 'cdr x))))
-(defmacro news-cdadr (x) (list 'cdr (list 'car (list 'cdr x))))
-
-(defmacro news-wins (pfx index)
- `(file-exists-p (concat ,pfx "/" (int-to-string ,index))))
-
-(defvar news-max-plausible-gap 2
- "* In an rnews directory, the maximum possible gap size.
-A gap is a sequence of missing messages between two messages that exist.
-An empty file does not contribute to a gap -- it ends one.")
-
-(defun news-find-first-and-last (prefix base)
- (and (news-wins prefix base)
- (cons (news-find-first-or-last prefix base -1)
- (news-find-first-or-last prefix base 1))))
-
-(defmacro news-/ (a1 a2)
-;; a form of / that guarantees that (/ -1 2) = 0
- (if (zerop (/ -1 2))
- `(/ ,a1 ,a2)
- `(if (< ,a1 0)
- (- (/ (- ,a1) ,a2))
- (/ ,a1 ,a2))))
-
-(defun news-find-first-or-last (pfx base dirn)
- ;; first use powers of two to find a plausible ceiling
- (let ((original-dir dirn))
- (while (news-wins pfx (+ base dirn))
- (setq dirn (* dirn 2)))
- (setq dirn (news-/ dirn 2))
- ;; Then use a binary search to find the high water mark
- (let ((offset (news-/ dirn 2)))
- (while (/= offset 0)
- (if (news-wins pfx (+ base dirn offset))
- (setq dirn (+ dirn offset)))
- (setq offset (news-/ offset 2))))
- ;; If this high-water mark is bogus, recurse.
- (let ((offset (* news-max-plausible-gap original-dir)))
- (while (and (/= offset 0) (not (news-wins pfx (+ base dirn offset))))
- (setq offset (- offset original-dir)))
- (if (= offset 0)
- (+ base dirn)
- (news-find-first-or-last pfx (+ base dirn offset) original-dir)))))
-
-(defun rnews ()
-"Read USENET news for groups for which you are a member and add or
-delete groups.
-You can reply to articles posted and send articles to any group.
-
-Type \\[describe-mode] once reading news to get a list of rnews commands."
- (interactive)
- (let ((last-buffer (buffer-name)))
- (make-local-variable 'rmail-last-file)
- (switch-to-buffer (setq news-buffer (get-buffer-create "*news*")))
- (news-mode)
- (setq news-buffer-save last-buffer)
- (setq buffer-read-only nil)
- (erase-buffer)
- (setq buffer-read-only t)
- (set-buffer-modified-p t)
- (sit-for 0)
- (message "Getting new USENET news...")
- (news-set-mode-line)
- (news-get-certifications)
- (news-get-new-news)))
-
-(defun news-group-certification (group)
- (cdr-safe (assoc group news-current-certifications)))
-
-
-(defun news-set-current-certifiable ()
- ;; Record the date that corresponds to the directory you are about to check
- (let ((file (concat news-path
- (string-subst-char ?/ ?. news-current-news-group))))
- (setq news-current-certifiable
- (nth 5 (file-attributes
- (or (file-symlink-p file) file))))))
-
-(defun news-get-certifications ()
- ;; Read the certified-read file from last session
- (save-excursion
- (save-window-excursion
- (setq news-current-certifications
- (car-safe
- (condition-case var
- (let*
- ((file (substitute-in-file-name news-certification-file))
- (buf (find-file-noselect file)))
- (and (file-exists-p file)
- (progn
- (switch-to-buffer buf 'norecord)
- (unwind-protect
- (read-from-string (buffer-string))
- (kill-buffer buf)))))
- (error nil)))))))
-
-(defun news-write-certifications ()
- ;; Write a certification file.
- ;; This is an assoc list of group names with doubletons that represent
- ;; mod times of the directory when group is read completely.
- (save-excursion
- (save-window-excursion
- (with-output-to-temp-buffer
- "*CeRtIfIcAtIoNs*"
- (print news-current-certifications))
- (let ((buf (get-buffer "*CeRtIfIcAtIoNs*")))
- (switch-to-buffer buf)
- (write-file (substitute-in-file-name news-certification-file))
- (kill-buffer buf)))))
-
-(defun news-set-current-group-certification ()
- (let ((cgc (assoc news-current-news-group news-current-certifications)))
- (if cgc (setcdr cgc news-current-certifiable)
- (news-push (cons news-current-news-group news-current-certifiable)
- news-current-certifications))))
-
-(defun news-set-message-counters ()
- "Scan through current news-groups filelist to figure out how many messages
-are there. Set counters for use with minor mode display."
- (if (null news-list-of-files)
- (setq news-current-message-number 0)))
-
-(if news-mode-map
- nil
- (setq news-mode-map (make-keymap))
- (suppress-keymap news-mode-map)
- (define-key news-mode-map "." 'beginning-of-buffer)
- (define-key news-mode-map " " 'scroll-up)
- (define-key news-mode-map "\177" 'scroll-down)
- (define-key news-mode-map "n" 'news-next-message)
- (define-key news-mode-map "c" 'news-make-link-to-message)
- (define-key news-mode-map "p" 'news-previous-message)
- (define-key news-mode-map "j" 'news-goto-message)
- (define-key news-mode-map "q" 'news-exit)
- (define-key news-mode-map "e" 'news-exit)
- (define-key news-mode-map "\ej" 'news-goto-news-group)
- (define-key news-mode-map "\en" 'news-next-group)
- (define-key news-mode-map "\ep" 'news-previous-group)
- (define-key news-mode-map "l" 'news-list-news-groups)
- (define-key news-mode-map "?" 'describe-mode)
- (define-key news-mode-map "g" 'news-get-new-news)
- (define-key news-mode-map "f" 'news-reply)
- (define-key news-mode-map "m" 'news-mail-other-window)
- (define-key news-mode-map "a" 'news-post-news)
- (define-key news-mode-map "r" 'news-mail-reply)
- (define-key news-mode-map "o" 'news-save-item-in-file)
- (define-key news-mode-map "\C-o" 'rmail-output)
- (define-key news-mode-map "t" 'news-show-all-headers)
- (define-key news-mode-map "x" 'news-force-update)
- (define-key news-mode-map "A" 'news-add-news-group)
- (define-key news-mode-map "u" 'news-unsubscribe-current-group)
- (define-key news-mode-map "U" 'news-unsubscribe-group)
- (define-key news-mode-map "\C-c\C-r" 'news-caesar-buffer-body))
-
-(defun news-mode ()
- "News Mode is used by M-x rnews for reading USENET Newsgroups articles.
-New readers can find additional help in newsgroup: news.announce.newusers .
-All normal editing commands are turned off.
-Instead, these commands are available:
-
-. move point to front of this news article (same as Meta-<).
-Space scroll to next screen of this news article.
-Delete scroll down previous page of this news article.
-n move to next news article, possibly next group.
-p move to previous news article, possibly previous group.
-j jump to news article specified by numeric position.
-M-j jump to news group.
-M-n goto next news group.
-M-p goto previous news group.
-l list all the news groups with current status.
-? print this help message.
-C-c C-r caesar rotate all letters by 13 places in the article's body (rot13).
-g get new USENET news.
-f post a reply article to USENET.
-a post an original news article.
-A add a newsgroup.
-o save the current article in the named file (append if file exists).
-C-o output this message to a Unix-format mail file (append it).
-c \"copy\" (actually link) current or prefix-arg msg to file.
- warning: target directory and message file must be on same device
- (UNIX magic)
-t show all the headers this news article originally had.
-q quit reading news after updating .newsrc file.
-e exit updating .newsrc file.
-m mail a news article. Same as C-x 4 m.
-x update last message seen to be the current message.
-r mail a reply to this news article. Like m but initializes some fields.
-u unsubscribe from current newsgroup.
-U unsubscribe from specified newsgroup."
- (interactive)
- (kill-all-local-variables)
- (make-local-variable 'news-read-first-time-p)
- (setq news-read-first-time-p t)
- (make-local-variable 'news-current-news-group)
-; (setq news-current-news-group "??")
- (make-local-variable 'news-current-group-begin)
- (setq news-current-group-begin 0)
- (make-local-variable 'news-current-message-number)
- (setq news-current-message-number 0)
- (make-local-variable 'news-total-current-group)
- (make-local-variable 'news-buffer-save)
- (make-local-variable 'version-control)
- (setq version-control 'never)
- (make-local-variable 'news-point-pdl)
-; This breaks it. I don't have time to figure out why. -- RMS
-; (make-local-variable 'news-group-article-assoc)
- (setq major-mode 'news-mode)
- (setq mode-line-process '(news-minor-modes))
- (setq mode-name "NEWS")
- (news-set-mode-line)
- (set-syntax-table text-mode-syntax-table)
- (use-local-map news-mode-map)
- (setq local-abbrev-table text-mode-abbrev-table)
- (run-mode-hooks 'news-mode-hook))
-
-(defun string-subst-char (new old string)
- (let (index)
- (setq old (regexp-quote (char-to-string old))
- string (substring string 0))
- (while (setq index (string-match old string))
- (aset string index new)))
- string)
-
-;; update read message number
-(defmacro news-update-message-read (ngroup nno)
- (list 'setcar
- (list 'news-cdadr
- (list 'assoc ngroup 'news-group-article-assoc))
- nno))
-
-(defun news-parse-range (number-string)
- "Parse string representing range of numbers of he form <a>-<b>
-to a list (a . b)"
- (let ((n (string-match "-" number-string)))
- (if n
- (cons (string-to-number (substring number-string 0 n))
- (string-to-number (substring number-string (1+ n))))
- (setq n (string-to-number number-string))
- (cons n n))))
-
-;(defun is-in (elt lis)
-; (catch 'foo
-; (while lis
-; (if (equal (car lis) elt)
-; (throw 'foo t)
-; (setq lis (cdr lis))))))
-
-(defun news-get-new-news ()
- "Get new USENET news, if there is any for the current user."
- (interactive)
- (if (not (null news-user-group-list))
- (news-update-newsrc-file))
- (setq news-group-article-assoc ())
- (setq news-user-group-list ())
- (message "Looking up %s file..." news-startup-file)
- (let ((file (substitute-in-file-name news-startup-file))
- (temp-user-groups ()))
- (save-excursion
- (let ((newsrcbuf (find-file-noselect file))
- start end endofline tem)
- (set-buffer newsrcbuf)
- (goto-char 0)
- (while (search-forward ": " nil t)
- (setq end (point))
- (beginning-of-line)
- (setq start (point))
- (end-of-line)
- (setq endofline (point))
- (setq tem (buffer-substring start (- end 2)))
- (let ((range (news-parse-range
- (buffer-substring end endofline))))
- (if (assoc tem news-group-article-assoc)
- (message "You are subscribed twice to %s; I ignore second"
- tem)
- (setq temp-user-groups (cons tem temp-user-groups)
- news-group-article-assoc
- (cons (list tem (list (car range)
- (cdr range)
- (cdr range)))
- news-group-article-assoc)))))
- (kill-buffer newsrcbuf)))
- (setq temp-user-groups (nreverse temp-user-groups))
- (message "Prefrobnicating...")
- (switch-to-buffer news-buffer)
- (setq news-user-group-list temp-user-groups)
- (while (and temp-user-groups
- (not (news-read-files-into-buffer
- (car temp-user-groups) nil)))
- (setq temp-user-groups (cdr temp-user-groups)))
- (if (null temp-user-groups)
- (message "No news is good news.")
- (message ""))))
-
-(defun news-list-news-groups ()
- "Display all the news groups to which you belong."
- (interactive)
- (with-output-to-temp-buffer "*Newsgroups*"
- (with-current-buffer standard-output
- (insert
- "News Group Msg No. News Group Msg No.\n")
- (insert
- "------------------------- -------------------------\n")
- (let ((temp news-user-group-list)
- (flag nil))
- (while temp
- (let ((item (assoc (car temp) news-group-article-assoc)))
- (insert (car item))
- (indent-to (if flag 52 20))
- (insert (int-to-string (news-cadr (news-cadr item))))
- (if flag
- (insert "\n")
- (indent-to 33))
- (setq temp (cdr temp) flag (not flag))))))))
-
-;; Mode line hack
-(defun news-set-mode-line ()
- "Set mode line string to something useful."
- (setq mode-line-process
- (concat " "
- (if (integerp news-current-message-number)
- (int-to-string news-current-message-number)
- "??")
- "/"
- (if (integerp news-current-group-end)
- (int-to-string news-current-group-end)
- news-current-group-end)))
- (setq mode-line-buffer-identification
- (concat "NEWS: "
- news-current-news-group
- ;; Enough spaces to pad group name to 17 positions.
- (substring " "
- 0 (max 0 (- 17 (length news-current-news-group))))))
- (set-buffer-modified-p t)
- (sit-for 0))
-
-(defun news-goto-news-group (gp)
- "Takes a string and goes to that news group."
- (interactive (list (completing-read "NewsGroup: "
- news-group-article-assoc)))
- (message "Jumping to news group %s..." gp)
- (news-select-news-group gp)
- (message "Jumping to news group %s... done." gp))
-
-(defun news-select-news-group (gp)
- (let ((grp (assoc gp news-group-article-assoc)))
- (if (null grp)
- (error "Group %s not subscribed to" gp)
- (progn
- (news-update-message-read news-current-news-group
- (news-cdar news-point-pdl))
- (news-read-files-into-buffer (car grp) nil)
- (news-set-mode-line)))))
-
-(defun news-goto-message (arg)
- "Goes to the article ARG in current newsgroup."
- (interactive "p")
- (if (null current-prefix-arg)
- (setq arg (read-no-blanks-input "Go to article: " "")))
- (news-select-message arg))
-
-(defun news-select-message (arg)
- (if (stringp arg) (setq arg (string-to-number arg)))
- (let ((file (concat news-path
- (string-subst-char ?/ ?. news-current-news-group)
- "/" arg)))
- (if (= arg
- (or (news-cadr (memq (news-cdar news-point-pdl) news-list-of-files))
- 0))
- (setcdr (car news-point-pdl) arg))
- (setq news-current-message-number arg)
- (if (file-exists-p file)
- (let ((buffer-read-only nil))
- (news-read-in-file file)
- (news-set-mode-line))
- (news-set-mode-line)
- (error "Article %d nonexistent" arg))))
-
-(defun news-force-update ()
- "updates the position of last article read in the current news group"
- (interactive)
- (setcdr (car news-point-pdl) news-current-message-number)
- (message "Updated to %d" news-current-message-number))
-
-(defun news-next-message (arg)
- "Move ARG messages forward within one newsgroup.
-Negative ARG moves backward.
-If ARG is 1 or -1, moves to next or previous newsgroup if at end."
- (interactive "p")
- (let ((no (+ arg news-current-message-number)))
- (if (or (< no news-current-group-begin)
- (> no news-current-group-end))
- (cond ((= arg 1)
- (news-set-current-group-certification)
- (news-next-group))
- ((= arg -1)
- (news-previous-group))
- (t (error "Article out of range")))
- (let ((plist (news-get-motion-lists
- news-current-message-number
- news-list-of-files)))
- (if (< arg 0)
- (news-select-message (nth (1- (- arg)) (car (cdr plist))))
- (news-select-message (nth (1- arg) (car plist))))))))
-
-(defun news-previous-message (arg)
- "Move ARG messages backward in current newsgroup.
-With no arg or arg of 1, move one message
-and move to previous newsgroup if at beginning.
-A negative ARG means move forward."
- (interactive "p")
- (news-next-message (- arg)))
-
-(defun news-move-to-group (arg)
- "Given arg move forward or backward to a new newsgroup."
- (let ((cg news-current-news-group))
- (let ((plist (news-get-motion-lists cg news-user-group-list))
- ngrp)
- (if (< arg 0)
- (or (setq ngrp (nth (1- (- arg)) (news-cadr plist)))
- (error "No previous news groups"))
- (or (setq ngrp (nth arg (car plist)))
- (error "No more news groups")))
- (news-select-news-group ngrp))))
-
-(defun news-next-group ()
- "Moves to the next user group."
- (interactive)
-; (message "Moving to next group...")
- (news-move-to-group 0)
- (while (null news-list-of-files)
- (news-move-to-group 0)))
-; (message "Moving to next group... done.")
-
-(defun news-previous-group ()
- "Moves to the previous user group."
- (interactive)
-; (message "Moving to previous group...")
- (news-move-to-group -1)
- (while (null news-list-of-files)
- (news-move-to-group -1)))
-; (message "Moving to previous group... done.")
-
-(defun news-get-motion-lists (arg listy)
- "Given a msgnumber/group this will return a list of two lists;
-one for moving forward and one for moving backward."
- (let ((temp listy)
- (result ()))
- (catch 'out
- (while temp
- (if (equal (car temp) arg)
- (throw 'out (cons (cdr temp) (list result)))
- (setq result (nconc (list (car temp)) result))
- (setq temp (cdr temp)))))))
-
-;; miscellaneous io routines
-(defun news-read-in-file (filename)
- (erase-buffer)
- (let ((start (point)))
- (insert-file-contents filename)
- (news-convert-format)
- ;; Run each hook that applies to the current newsgroup.
- (let ((hooks news-group-hook-alist))
- (while hooks
- (goto-char start)
- (if (string-match (car (car hooks)) news-group-name)
- (funcall (cdr (car hooks))))
- (setq hooks (cdr hooks))))
- (goto-char start)
- (forward-line 1)
- (if (eobp)
- (message "(Empty file?)")
- (goto-char start))))
-
-(defun news-convert-format ()
- (save-excursion
- (save-restriction
- (let* ((start (point))
- (end (condition-case ()
- (progn (search-forward "\n\n") (point))
- (error nil)))
- has-from has-date)
- (cond (end
- (narrow-to-region start end)
- (goto-char start)
- (setq has-from (search-forward "\nFrom:" nil t))
- (cond ((and (not has-from) has-date)
- (goto-char start)
- (search-forward "\nDate:")
- (beginning-of-line)
- (kill-line) (kill-line)))
- (news-delete-headers start)
- (goto-char start)))))))
-
-(defun news-show-all-headers ()
- "Redisplay current news item with all original headers"
- (interactive)
- (let (news-ignored-headers
- (buffer-read-only ()))
- (erase-buffer)
- (news-set-mode-line)
- (news-read-in-file
- (concat news-path
- (string-subst-char ?/ ?. news-current-news-group)
- "/" (int-to-string news-current-message-number)))))
-
-(defun news-delete-headers (pos)
- (goto-char pos)
- (and (stringp news-ignored-headers)
- (while (re-search-forward news-ignored-headers nil t)
- (beginning-of-line)
- (delete-region (point)
- (progn (re-search-forward "\n[^ \t]")
- (forward-char -1)
- (point))))))
-
-(defun news-exit ()
- "Quit news reading session and update the .newsrc file."
- (interactive)
- (if (y-or-n-p "Do you really wanna quit reading news ? ")
- (progn (message "Updating %s..." news-startup-file)
- (news-update-newsrc-file)
- (news-write-certifications)
- (message "Updating %s... done" news-startup-file)
- (message "Now do some real work")
- (quit-window)
- (switch-to-buffer news-buffer-save)
- (setq news-user-group-list ()))
- (message "")))
-
-(defun news-update-newsrc-file ()
- "Updates the .newsrc file in the users home dir."
- (let ((newsrcbuf (find-file-noselect
- (substitute-in-file-name news-startup-file)))
- (tem news-user-group-list)
- group)
- (save-excursion
- (if (not (null news-current-news-group))
- (news-update-message-read news-current-news-group
- (news-cdar news-point-pdl)))
- (set-buffer newsrcbuf)
- (while tem
- (setq group (assoc (car tem) news-group-article-assoc))
- (if (= (news-cadr (news-cadr group)) (news-caddr (news-cadr group)))
- nil
- (goto-char 0)
- (if (search-forward (concat (car group) ": ") nil t)
- (kill-line nil)
- (insert (car group) ": \n") (backward-char 1))
- (insert (int-to-string (car (news-cadr group))) "-"
- (int-to-string (news-cadr (news-cadr group)))))
- (setq tem (cdr tem)))
- (while news-unsubscribe-groups
- (setq group (assoc (car news-unsubscribe-groups)
- news-group-article-assoc))
- (goto-char 0)
- (if (search-forward (concat (car group) ": ") nil t)
- (progn
- (backward-char 2)
- (kill-line nil)
- (insert "! " (int-to-string (car (news-cadr group)))
- "-" (int-to-string (news-cadr (news-cadr group))))))
- (setq news-unsubscribe-groups (cdr news-unsubscribe-groups)))
- (save-buffer)
- (kill-buffer (current-buffer)))))
-
-
-(defun news-unsubscribe-group (group)
- "Removes you from newgroup GROUP."
- (interactive (list (completing-read "Unsubscribe from group: "
- news-group-article-assoc)))
- (news-unsubscribe-internal group))
-
-(defun news-unsubscribe-current-group ()
- "Removes you from the newsgroup you are now reading."
- (interactive)
- (if (y-or-n-p "Do you really want to unsubscribe from this group ? ")
- (news-unsubscribe-internal news-current-news-group)))
-
-(defun news-unsubscribe-internal (group)
- (let ((tem (assoc group news-group-article-assoc)))
- (if tem
- (progn
- (setq news-unsubscribe-groups (cons group news-unsubscribe-groups))
- (news-update-message-read group (news-cdar news-point-pdl))
- (if (equal group news-current-news-group)
- (news-next-group))
- (message ""))
- (error "Not subscribed to group: %s" group))))
-
-(defun news-save-item-in-file (file)
- "Save the current article that is being read by appending to a file."
- (interactive "FSave item in file: ")
- (append-to-file (point-min) (point-max) file))
-
-(defun news-get-pruned-list-of-files (gp-list end-file-no)
- "Given a news group it finds all files in the news group.
-The arg must be in slashified format.
-Using ls was found to be too slow in a previous version."
- (let
- ((answer
- (and
- (not (and end-file-no
- (equal (news-set-current-certifiable)
- (news-group-certification gp-list))
- (setq news-list-of-files nil
- news-list-of-files-possibly-bogus t)))
- (let* ((file-directory (concat news-path
- (string-subst-char ?/ ?. gp-list)))
- tem
- (last-winner
- (and end-file-no
- (news-wins file-directory end-file-no)
- (news-find-first-or-last file-directory end-file-no 1))))
- (setq news-list-of-files-possibly-bogus t news-list-of-files nil)
- (if last-winner
- (progn
- (setq news-list-of-files-possibly-bogus t
- news-current-group-end last-winner)
- (while (> last-winner end-file-no)
- (news-push last-winner news-list-of-files)
- (setq last-winner (1- last-winner)))
- news-list-of-files)
- (if (or (not (file-directory-p file-directory))
- (not (file-readable-p file-directory)))
- nil
- (setq news-list-of-files
- (condition-case error
- (directory-files file-directory)
- (file-error
- (if (string= (nth 2 error) "permission denied")
- (message "Newsgroup %s is read-protected"
- gp-list)
- (signal 'file-error (cdr error)))
- nil)))
- (setq tem news-list-of-files)
- (while tem
- (if (or (not (string-match "^[0-9]*$" (car tem)))
- ;; don't get confused by directories that look like numbers
- (file-directory-p
- (concat file-directory "/" (car tem)))
- (<= (string-to-number (car tem)) end-file-no))
- (setq news-list-of-files
- (delq (car tem) news-list-of-files)))
- (setq tem (cdr tem)))
- (if (null news-list-of-files)
- (progn (setq news-current-group-end 0)
- nil)
- (setq news-list-of-files
- (mapcar 'string-to-number news-list-of-files))
- (setq news-list-of-files (sort news-list-of-files '<))
- (setq news-current-group-end
- (elt news-list-of-files
- (1- (length news-list-of-files))))
- news-list-of-files)))))))
- (or answer (progn (news-set-current-group-certification) nil))))
-
-(defun news-read-files-into-buffer (group reversep)
- (let* ((files-start-end (news-cadr (assoc group news-group-article-assoc)))
- (start-file-no (car files-start-end))
- (end-file-no (news-cadr files-start-end))
- (buffer-read-only nil))
- (setq news-current-news-group group)
- (setq news-current-message-number nil)
- (setq news-current-group-end nil)
- (news-set-mode-line)
- (news-get-pruned-list-of-files group end-file-no)
- (news-set-mode-line)
- ;; @@ should be a lot smarter than this if we have to move
- ;; @@ around correctly.
- (setq news-point-pdl (list (cons (car files-start-end)
- (news-cadr files-start-end))))
- (if (null news-list-of-files)
- (progn (erase-buffer)
- (setq news-current-group-end end-file-no)
- (setq news-current-group-begin end-file-no)
- (setq news-current-message-number end-file-no)
- (news-set-mode-line)
-; (message "No new articles in " group " group.")
- nil)
- (setq news-current-group-begin (car news-list-of-files))
- (if reversep
- (setq news-current-message-number news-current-group-end)
- (if (> (car news-list-of-files) end-file-no)
- (setcdr (car news-point-pdl) (car news-list-of-files)))
- (setq news-current-message-number news-current-group-begin))
- (news-set-message-counters)
- (news-set-mode-line)
- (news-read-in-file (concat news-path
- (string-subst-char ?/ ?. group)
- "/"
- (int-to-string
- news-current-message-number)))
- (news-set-message-counters)
- (news-set-mode-line)
- t)))
-
-(defun news-add-news-group (gp)
- "Resubscribe to or add a USENET news group named GROUP (a string)."
-; @@ (completing-read ...)
-; @@ could be based on news library file ../active (slightly fascist)
-; @@ or (expensive to compute) all directories under the news spool directory
- (interactive "sAdd news group: ")
- (let ((file-dir (concat news-path (string-subst-char ?/ ?. gp))))
- (save-excursion
- (if (null (assoc gp news-group-article-assoc))
- (let ((newsrcbuf (find-file-noselect
- (substitute-in-file-name news-startup-file))))
- (if (file-directory-p file-dir)
- (progn
- (switch-to-buffer newsrcbuf)
- (goto-char 0)
- (if (search-forward (concat gp "! ") nil t)
- (progn
- (message "Re-subscribing to group %s." gp)
- ;;@@ news-unsubscribe-groups isn't being used
- ;;(setq news-unsubscribe-groups
- ;; (delq gp news-unsubscribe-groups))
- (backward-char 2)
- (delete-char 1)
- (insert ":"))
- (progn
- (message
- "Added %s to your list of newsgroups." gp)
- (goto-char (point-max))
- (insert gp ": 1-1\n")))
- (search-backward gp nil t)
- (let (start end endofline tem)
- (search-forward ": " nil t)
- (setq end (point))
- (beginning-of-line)
- (setq start (point))
- (end-of-line)
- (setq endofline (point))
- (setq tem (buffer-substring start (- end 2)))
- (let ((range (news-parse-range
- (buffer-substring end endofline))))
- (setq news-group-article-assoc
- (cons (list tem (list (car range)
- (cdr range)
- (cdr range)))
- news-group-article-assoc))))
- (save-buffer)
- (kill-buffer (current-buffer)))
- (message "Newsgroup %s doesn't exist." gp)))
- (message "Already subscribed to group %s." gp)))))
-
-(defun news-make-link-to-message (number newname)
- "Forges a link to an rnews message numbered number (current if no arg)
-Good for hanging on to a message that might or might not be
-automatically deleted."
- (interactive "P
-FName to link to message: ")
- (add-name-to-file
- (concat news-path
- (string-subst-char ?/ ?. news-current-news-group)
- "/" (if number
- (prefix-numeric-value number)
- news-current-message-number))
- newname))
-
-;;; caesar-region written by phr@gnu.org Nov 86
-;;; modified by tower@gnu.org Nov 86
-(defun caesar-region (&optional n)
- "Caesar rotation of region by N, default 13, for decrypting netnews."
- (interactive (if current-prefix-arg ; Was there a prefix arg?
- (list (prefix-numeric-value current-prefix-arg))
- (list nil)))
- (cond ((not (numberp n)) (setq n 13))
- (t (setq n (mod n 26)))) ;canonicalize N
- (if (not (zerop n)) ; no action needed for a rot of 0
- (progn
- (if (or (not (boundp 'caesar-translate-table))
- (/= (aref caesar-translate-table ?a) (+ ?a n)))
- (let ((i 0) (lower "abcdefghijklmnopqrstuvwxyz") upper)
- (message "Building caesar-translate-table...")
- (setq caesar-translate-table (make-vector 256 0))
- (while (< i 256)
- (aset caesar-translate-table i i)
- (setq i (1+ i)))
- (setq lower (concat lower lower) upper (upcase lower) i 0)
- (while (< i 26)
- (aset caesar-translate-table (+ ?a i) (aref lower (+ i n)))
- (aset caesar-translate-table (+ ?A i) (aref upper (+ i n)))
- (setq i (1+ i)))
- (message "Building caesar-translate-table... done")))
- (let ((from (region-beginning))
- (to (region-end))
- (i 0) str len)
- (setq str (buffer-substring from to))
- (setq len (length str))
- (while (< i len)
- (aset str i (aref caesar-translate-table (aref str i)))
- (setq i (1+ i)))
- (goto-char from)
- (kill-region from to)
- (insert str)))))
-
-;;; news-caesar-buffer-body written by paul@media-lab.mit.edu Wed Oct 1, 1986
-;;; hacked further by tower@gnu.org
-(defun news-caesar-buffer-body (&optional rotnum)
- "Caesar rotates all letters in the current buffer by 13 places.
-Used to encode/decode possibly offensive messages (commonly in net.jokes).
-With prefix arg, specifies the number of places to rotate each letter forward.
-Mail and USENET news headers are not rotated."
- (interactive (if current-prefix-arg ; Was there a prefix arg?
- (list (prefix-numeric-value current-prefix-arg))
- (list nil)))
- (save-excursion
- (let ((buffer-status buffer-read-only))
- (setq buffer-read-only nil)
- ;; setup the region
- (set-mark (if (equal major-mode 'news-mode)
- (progn (goto-char (point-min))
- (search-forward "\n\n" nil t))
- (mail-text-start)))
- (goto-char (point-max))
- (caesar-region rotnum)
- (setq buffer-read-only buffer-status))))
-
-(provide 'rnews)
-
-;; arch-tag: c032a20b-cafb-466c-b3fa-5be404a18f8c
-;;; rnews.el ends here
diff --git a/lisp/obsolete/rnewspost.el b/lisp/obsolete/rnewspost.el
deleted file mode 100644
index 23f7dfe4400..00000000000
--- a/lisp/obsolete/rnewspost.el
+++ /dev/null
@@ -1,447 +0,0 @@
-;;; rnewspost.el --- USENET news poster/mailer for GNU Emacs
-
-;; Copyright (C) 1985, 1986, 1987, 1995, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-
-;; Maintainer: FSF
-;; Keywords: mail, news
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This file has been obsolete since Emacs 22.1.
-
-;;; Change Log:
-
-;; moved posting and mail code from rnews.el
-;; tower@gnu.org Wed Oct 29 1986
-;; brought posting code almost up to the revision of RFC 850 for News 2.11
-;; - couldn't see handling the special meaning of the Keyword: poster
-;; - not worth the code space to support the old A news Title: (which
-;; Subject: replaced) and Article-I.D.: (which Message-ID: replaced)
-;; tower@gnu.org Nov 86
-;; changed C-c C-r key-binding due to rename of news-caesar-buffer-body
-;; tower@gnu.org 21 Nov 86
-;; added (require 'rnews) tower@gnu.org 22 Apr 87
-;; restricted call of news-show-all-headers in news-post-news & news-reply
-;; tower@gnu.org 28 Apr 87
-;; commented out Posting-Front-End to save USENET bytes tower@gnu.org Jul 31 87
-;; commented out -n and -t args in news-inews tower@gnu.org 15 Oct 87
-
-;Now in paths.el.
-;(defvar news-inews-program "inews"
-; "Function to post news.")
-
-;; Replying and posting news items are done by these functions.
-;; imported from rmail and modified to work with rnews ...
-;; Mon Mar 25,1985 at 03:07:04 ads@mit-hermes.
-;; this is done so that rnews can operate independently from rmail.el and
-;; sendmail and doesn't have to autoload these functions.
-;;
-;;; >> Nuked by Mly to autoload those functions again, as the duplication of
-;;; >> code was making maintenance too difficult.
-
-;;; Code:
-
-(require 'sendmail)
-(require 'rnews)
-
-(defvar mail-reply-buffer)
-
-(defvar news-reply-mode-map () "Mode map used by news-reply.")
-
-(or news-reply-mode-map
- (progn
- (setq news-reply-mode-map (make-keymap))
- (define-key news-reply-mode-map "\C-c\C-f\C-d" 'news-reply-distribution)
- (define-key news-reply-mode-map "\C-c\C-f\C-k" 'news-reply-keywords)
- (define-key news-reply-mode-map "\C-c\C-f\C-n" 'news-reply-newsgroups)
- (define-key news-reply-mode-map "\C-c\C-f\C-f" 'news-reply-followup-to)
- (define-key news-reply-mode-map "\C-c\C-f\C-s" 'mail-subject)
- (define-key news-reply-mode-map "\C-c\C-f\C-a" 'news-reply-summary)
- (define-key news-reply-mode-map "\C-c\C-t" 'mail-text)
- (define-key news-reply-mode-map "\C-c\C-r" 'news-caesar-buffer-body)
- (define-key news-reply-mode-map "\C-c\C-w" 'news-reply-signature)
- (define-key news-reply-mode-map "\C-c\C-y" 'news-reply-yank-original)
- (define-key news-reply-mode-map "\C-c\C-q" 'mail-fill-yanked-message)
- (define-key news-reply-mode-map "\C-c\C-c" 'news-inews)
- (define-key news-reply-mode-map "\C-c\C-s" 'news-inews)
- (define-key news-reply-mode-map [menu-bar] (make-sparse-keymap))
- (define-key news-reply-mode-map [menu-bar fields]
- (cons "Fields" (make-sparse-keymap "Fields")))
- (define-key news-reply-mode-map [menu-bar fields news-reply-distribution]
- '("Distribution" . news-reply-distribution))
- (define-key news-reply-mode-map [menu-bar fields news-reply-keywords]
- '("Keywords" . news-reply-keywords))
- (define-key news-reply-mode-map [menu-bar fields news-reply-newsgroups]
- '("Newsgroups" . news-reply-newsgroups))
- (define-key news-reply-mode-map [menu-bar fields news-reply-followup-to]
- '("Followup-to" . news-reply-followup-to))
- (define-key news-reply-mode-map [menu-bar fields mail-subject]
- '("Subject" . mail-subject))
- (define-key news-reply-mode-map [menu-bar fields news-reply-summary]
- '("Summary" . news-reply-summary))
- (define-key news-reply-mode-map [menu-bar fields mail-text]
- '("Text" . mail-text))
- (define-key news-reply-mode-map [menu-bar news]
- (cons "News" (make-sparse-keymap "News")))
- (define-key news-reply-mode-map [menu-bar news news-caesar-buffer-body]
- '("Rot13" . news-caesar-buffer-body))
- (define-key news-reply-mode-map [menu-bar news news-reply-yank-original]
- '("Yank Original" . news-reply-yank-original))
- (define-key news-reply-mode-map [menu-bar news mail-fill-yanked-message]
- '("Fill Yanked Messages" . mail-fill-yanked-message))
- (define-key news-reply-mode-map [menu-bar news news-inews]
- '("Send" . news-inews))))
-
-(defun news-reply-mode ()
- "Major mode for editing news to be posted on USENET.
-First-time posters are asked to please read the articles in newsgroup:
- news.announce.newusers .
-Like Text Mode but with these additional commands:
-
-C-c C-s news-inews (post the message) C-c C-c news-inews
-C-c C-f move to a header field (and create it if there isn't):
- C-c C-f C-n move to Newsgroups: C-c C-f C-s move to Subj:
- C-c C-f C-f move to Followup-To: C-c C-f C-k move to Keywords:
- C-c C-f C-d move to Distribution: C-c C-f C-a move to Summary:
-C-c C-y news-reply-yank-original (insert current message, in NEWS).
-C-c C-q mail-fill-yanked-message (fill what was yanked).
-C-c C-r caesar rotate all letters by 13 places in the article's body (rot13)."
- (interactive)
- (kill-all-local-variables)
- (make-local-variable 'mail-reply-buffer)
- (setq mail-reply-buffer nil)
- (set-syntax-table text-mode-syntax-table)
- (use-local-map news-reply-mode-map)
- (setq local-abbrev-table text-mode-abbrev-table)
- (setq major-mode 'news-reply-mode)
- (setq mode-name "News Reply")
- (make-local-variable 'paragraph-separate)
- (make-local-variable 'paragraph-start)
- (run-mode-hooks 'text-mode-hook 'news-reply-mode-hook))
-
-(defvar news-reply-yank-from ""
- "Save `From:' field for `news-reply-yank-original'.")
-
-(defvar news-reply-yank-message-id ""
- "Save `Message-Id:' field for `news-reply-yank-original'.")
-
-(defun news-reply-yank-original (arg)
- "Insert the message being replied to, if any (in Mail mode).
-Puts point before the text and mark after.
-Indents each nonblank line ARG spaces (default 3).
-Just \\[universal-argument] as argument means don't indent
-and don't delete any header fields."
- (interactive "P")
- (mail-yank-original arg)
- (exchange-point-and-mark)
- (run-hooks 'news-reply-header-hook))
-
-(defvar news-reply-header-hook
- (lambda ()
- (insert "In article " news-reply-yank-message-id
- " " news-reply-yank-from " writes:\n\n"))
- "Hook for inserting a header at the top of a yanked message.")
-
-(defun news-reply-newsgroups ()
- "Move point to end of `Newsgroups:' field.
-RFC 850 constrains the `Newsgroups:' field to be a comma-separated list
-of valid newsgroup names at your site. For example,
- Newsgroups: news.misc,comp.misc,rec.misc"
- (interactive)
- (expand-abbrev)
- (goto-char (point-min))
- (mail-position-on-field "Newsgroups"))
-
-(defun news-reply-followup-to ()
- "Move point to end of `Followup-To:' field. Create the field if none.
-One usually requests followups to only one newsgroup.
-RFC 850 constrains the `Followup-To:' field to be a comma-separated list
-of valid newsgroups names at your site, and it must be a subset of the
-`Newsgroups:' field. For example:
- Newsgroups: news.misc,comp.misc,rec.misc,misc.misc,soc.misc
- Followup-To: news.misc,comp.misc,rec.misc"
- (interactive)
- (expand-abbrev)
- (or (mail-position-on-field "Followup-To" t)
- (progn (mail-position-on-field "newsgroups")
- (insert "\nFollowup-To: ")))
- ;; @@ could do a completing read based on the Newsgroups: field to
- ;; @@ fill in the Followup-To: field
-)
-
-(defun news-reply-distribution ()
- "Move point to end of `Distribution:' optional field.
-Create the field if none. Without this field the posting goes to all of
-USENET. The field is used to restrict the posting to parts of USENET."
- (interactive)
- (expand-abbrev)
- (mail-position-on-field "Distribution")
- ;; @@could do a completing read based on the news library file:
- ;; @@ ../distributions to fill in the field.
- )
-
-(defun news-reply-keywords ()
- "Move point to end of `Keywords:' optional field. Create the field if none.
-Used as an aid to the news reader, it can contain a few, well selected keywords
-identifying the message."
- (interactive)
- (expand-abbrev)
- (mail-position-on-field "Keywords"))
-
-(defun news-reply-summary ()
- "Move point to end of `Summary:' optional field. Create the field if none.
-Used as an aid to the news reader, it can contain a succinct
-summary (abstract) of the message."
- (interactive)
- (expand-abbrev)
- (mail-position-on-field "Summary"))
-
-(defun news-reply-signature ()
- "The inews program appends `~/.signature' automatically."
- (interactive)
- (message "Posting news will append your signature automatically."))
-
-(defun news-setup (to subject in-reply-to newsgroups replybuffer)
- "Set up the news reply or posting buffer with the proper headers and mode."
- (setq mail-reply-buffer replybuffer)
- (let ((mail-setup-hook nil)
- ;; Avoid inserting a signature.
- (mail-signature))
- (if (null to)
- ;; this hack is needed so that inews wont be confused by
- ;; the fcc: and bcc: fields
- (let ((mail-self-blind nil)
- (mail-archive-file-name nil))
- (mail-setup to subject in-reply-to nil replybuffer nil)
- (beginning-of-line)
- (delete-region (point) (progn (forward-line 1) (point)))
- (goto-char (point-max)))
- (mail-setup to subject in-reply-to nil replybuffer nil))
- ;;;(mail-position-on-field "Posting-Front-End")
- ;;;(insert (emacs-version))
- (goto-char (point-max))
- (if (let ((case-fold-search t))
- (re-search-backward "^Subject:" (point-min) t))
- (progn (beginning-of-line)
- (insert "Newsgroups: " (or newsgroups "") "\n")
- (if (not newsgroups)
- (backward-char 1)
- (goto-char (point-max)))))
- (let (actual-header-separator)
- (rfc822-goto-eoh)
- (setq actual-header-separator (buffer-substring
- (point)
- (save-excursion (end-of-line) (point))))
- (setq paragraph-start
- (concat "^" actual-header-separator "$\\|" paragraph-start))
- (setq paragraph-separate
- (concat "^" actual-header-separator "$\\|" paragraph-separate)))
- (run-hooks 'news-setup-hook)))
-
-(defun news-inews ()
- "Send a news message using inews."
- (interactive)
- (let* (newsgroups subject
- (case-fold-search nil))
- (save-excursion
- (save-restriction
- (narrow-to-region (point-min) (mail-header-end))
- (setq newsgroups (mail-fetch-field "newsgroups")
- subject (mail-fetch-field "subject")))
- (widen)
- (goto-char (point-min))
- (run-hooks 'news-inews-hook)
- (mail-sendmail-undelimit-header)
- (goto-char (point-max))
- ;; require a newline at the end for inews to append .signature to
- (or (= (preceding-char) ?\n)
- (insert ?\n))
- (message "Posting to USENET...")
- (unwind-protect
- (if (not (eq 0
- (call-process-region (point-min) (point-max)
- news-inews-program nil 0 nil
- "-h"))) ; take all header lines!
- ;@@ setting of subject and newsgroups still needed?
- ;"-t" subject
- ;"-n" newsgroups
- (error "Posting to USENET failed")
- (message "Posting to USENET... done"))
- (mail-sendmail-delimit-header)
- (set-buffer-modified-p nil)))
- (bury-buffer)))
-
-;@@ shares some code with news-reply and news-post-news
-(defun news-mail-reply ()
- "Mail a reply to the author of the current article.
-While composing the reply, use \\[news-reply-yank-original] to yank the
-original message into it."
- (interactive)
- (let (from cc subject date to reply-to message-id
- (buffer (current-buffer)))
- (save-restriction
- (narrow-to-region (point-min) (progn (goto-char (point-min))
- (search-forward "\n\n")
- (1- (point))))
- (setq from (mail-fetch-field "from")
- subject (mail-fetch-field "subject")
- reply-to (mail-fetch-field "reply-to")
- date (mail-fetch-field "date")
- message-id (mail-fetch-field "message-id")))
- (setq to from)
- (pop-to-buffer "*mail*")
- (mail nil
- (if reply-to reply-to to)
- subject
- (let ((stop-pos (string-match " *at \\| *@ \\| *(\\| *<" from)))
- (concat (if stop-pos (substring from 0 stop-pos) from)
- "'s message "
- (if message-id
- (concat message-id " of ")
- "of ")
- date))
- nil
- buffer)))
-
-;@@ the guts of news-reply and news-post-news should be combined. -tower
-(defun news-reply ()
- "Compose and post a reply (aka a followup) to the current article on USENET.
-While composing the followup, use \\[news-reply-yank-original] to yank the
-original message into it."
- (interactive)
- (if (y-or-n-p "Are you sure you want to followup to all of USENET? ")
- (let (from cc subject date to followup-to newsgroups message-of
- references distribution message-id
- (buffer (current-buffer)))
- (save-restriction
- (and (not (= 0 (buffer-size))) ;@@real problem is non-existence of
- ;@@ of article file
- (equal major-mode 'news-mode) ;@@ if rmail-mode,
- ;@@ should show full headers
- (progn
- (news-show-all-headers) ;@@ should save/restore header state,
- ;@@ but rnews.el lacks support
- (narrow-to-region (point-min) (progn (goto-char (point-min))
- (search-forward "\n\n")
- (- (point) 1)))))
- (setq from (mail-fetch-field "from")
- news-reply-yank-from from
- ;; @@ not handling old Title: field
- subject (mail-fetch-field "subject")
- date (mail-fetch-field "date")
- followup-to (mail-fetch-field "followup-to")
- newsgroups (or followup-to
- (mail-fetch-field "newsgroups"))
- references (mail-fetch-field "references")
- ;; @@ not handling old Article-I.D.: field
- distribution (mail-fetch-field "distribution")
- message-id (mail-fetch-field "message-id")
- news-reply-yank-message-id message-id)
- (pop-to-buffer "*post-news*")
- (news-reply-mode)
- (if (and (buffer-modified-p)
- (not
- (y-or-n-p "Unsent article being composed; erase it? ")))
- ()
- (progn
- (erase-buffer)
- (and subject
- (progn (if (string-match "\\`Re: " subject)
- (while (string-match "\\`Re: " subject)
- (setq subject (substring subject 4))))
- (setq subject (concat "Re: " subject))))
- (and from
- (progn
- (let ((stop-pos
- (string-match " *at \\| *@ \\| *(\\| *<" from)))
- (setq message-of
- (concat
- (if stop-pos (substring from 0 stop-pos) from)
- "'s message "
- (if message-id
- (concat message-id " of ")
- "of ")
- date)))))
- (news-setup
- nil
- subject
- message-of
- newsgroups
- buffer)
- (if followup-to
- (progn (news-reply-followup-to)
- (insert followup-to)))
- (if distribution
- (progn
- (mail-position-on-field "Distribution")
- (insert distribution)))
- (mail-position-on-field "References")
- (if references
- (insert references))
- (if (and references message-id)
- (insert " "))
- (if message-id
- (insert message-id))
- (goto-char (point-max))))))
- (message "")))
-
-;@@ the guts of news-reply and news-post-news should be combined. -tower
-;;;###autoload
-(defun news-post-news (&optional noquery)
- "Begin editing a new USENET news article to be posted.
-Type \\[describe-mode] once editing the article to get a list of commands.
-If NOQUERY is non-nil, we do not query before doing the work."
- (interactive)
- (if (or noquery
- (y-or-n-p "Are you sure you want to post to all of USENET? "))
- (let ((buffer (current-buffer)))
- (save-restriction
- (and (not (= 0 (buffer-size))) ;@@real problem is non-existence of
- ;@@ of article file
- (equal major-mode 'news-mode) ;@@ if rmail-mode,
- ;@@ should show full headers
- (progn
- (news-show-all-headers) ;@@ should save/restore header state,
- ;@@ but rnews.el lacks support
- (narrow-to-region (point-min) (progn (goto-char (point-min))
- (search-forward "\n\n")
- (- (point) 1)))))
- (setq news-reply-yank-from (mail-fetch-field "from")
- ;; @@ not handling old Article-I.D.: field
- news-reply-yank-message-id (mail-fetch-field "message-id")))
- (pop-to-buffer "*post-news*")
- (news-reply-mode)
- (if (and (buffer-modified-p)
- (not (y-or-n-p "Unsent article being composed; erase it? ")))
- () ;@@ not saving point from last time
- (progn (erase-buffer)
- (news-setup () () () () buffer))))
- (message "")))
-
-(defun news-mail-other-window ()
- "Send mail in another window.
-While composing the message, use \\[news-reply-yank-original] to yank the
-original message into it."
- (interactive)
- (mail-other-window nil nil nil nil nil (current-buffer)))
-
-(provide 'rnewspost)
-
-;; arch-tag: 18f7b2af-cf9a-49e4-878b-71eb49913e00
-;;; rnewspost.el ends here
diff --git a/lisp/s-region.el b/lisp/obsolete/s-region.el
index 3bef30c2fe5..a88d1f37ee7 100644
--- a/lisp/s-region.el
+++ b/lisp/obsolete/s-region.el
@@ -6,6 +6,7 @@
;; Author: Morten Welinder <terra@diku.dk>
;; Keywords: terminals
;; Favourite-brand-of-beer: None, I hate beer.
+;; Obsolete-since: 24.1
;; This file is part of GNU Emacs.
diff --git a/lisp/obsolete/sc.el b/lisp/obsolete/sc.el
deleted file mode 100644
index d5837f6ae7d..00000000000
--- a/lisp/obsolete/sc.el
+++ /dev/null
@@ -1,19 +0,0 @@
-;;; sc.el --- old name for supercite
-
-;; Maintainer: FSF
-
-;; This file is part of GNU Emacs.
-
-;;; Commentary:
-
-;; This file has been obsolete since Emacs 21.1.
-
-;;; Code:
-
-(require 'supercite)
-(provide 'sc)
-
-(message "The name `sc' works but is obsolete; please use `supercite' instead")
-
-;; arch-tag: 31e8ae19-689e-4b7d-9161-6d7dd60c6ece
-;;; sc.el ends here
diff --git a/lisp/obsolete/vc-mcvs.el b/lisp/obsolete/vc-mcvs.el
index fcfb566b4f2..8027ee62933 100644
--- a/lisp/obsolete/vc-mcvs.el
+++ b/lisp/obsolete/vc-mcvs.el
@@ -102,10 +102,9 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches."
:version "22.1"
:group 'vc)
-(defcustom vc-mcvs-header (or (cdr (assoc 'MCVS vc-header-alist))
- vc-cvs-header)
+(defcustom vc-mcvs-header vc-cvs-header
"Header keywords to be inserted by `vc-insert-headers'."
- :version "22.1"
+ :version "24.1" ; no longer consult the obsolete vc-header-alist
:type '(repeat string)
:group 'vc)
diff --git a/lisp/obsolete/x-menu.el b/lisp/obsolete/x-menu.el
deleted file mode 100644
index 1536a023364..00000000000
--- a/lisp/obsolete/x-menu.el
+++ /dev/null
@@ -1,153 +0,0 @@
-;;; x-menu.el --- menu support for X
-
-;; Copyright (C) 1986, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010 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 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This file has been obsolete since Emacs 21.1.
-
-;;; Code:
-
-(defvar x-process-mouse-hook)
-
-(defun x-menu-mode ()
- "Major mode for creating permanent menus for use with X.
-These menus are implemented entirely in Lisp; popup menus, implemented
-with x-popup-menu, are implemented using XMenu primitives."
- (make-local-variable 'x-menu-items-per-line)
- (make-local-variable 'x-menu-item-width)
- (make-local-variable 'x-menu-items-alist)
- (make-local-variable 'x-process-mouse-hook)
- (make-local-variable 'x-menu-assoc-buffer)
- (setq buffer-read-only t)
- (setq truncate-lines t)
- (setq x-process-mouse-hook 'x-menu-pick-entry)
- (setq mode-line-buffer-identification '("MENU: %32b")))
-
-(defvar x-menu-max-width 0)
-(defvar x-menu-items-per-line 0)
-(defvar x-menu-item-width 0)
-(defvar x-menu-items-alist nil)
-(defvar x-menu-assoc-buffer nil)
-
-(defvar x-menu-item-spacing 1
- "*Minimum horizontal spacing between objects in a permanent X menu.")
-
-(defun x-menu-create-menu (name)
- "Create a permanent X menu.
-Returns an item which should be used as a
-menu object whenever referring to the menu."
- (let ((old (current-buffer))
- (buf (get-buffer-create name)))
- (set-buffer buf)
- (x-menu-mode)
- (setq x-menu-assoc-buffer old)
- (set-buffer old)
- buf))
-
-(defun x-menu-change-associated-buffer (menu buffer)
- "Change associated buffer of MENU to BUFFER.
-BUFFER should be a buffer object."
- (let ((old (current-buffer)))
- (set-buffer menu)
- (setq x-menu-assoc-buffer buffer)
- (set-buffer old)))
-
-(defun x-menu-add-item (menu item binding)
- "Add to MENU an item with name ITEM, associated with BINDING.
-Following a sequence of calls to x-menu-add-item, a call to x-menu-compute
-should be performed before the menu will be made available to the user.
-
-BINDING should be a function of one argument, which is the numerical
-button/key code as defined in x-menu.el."
- (let ((old (current-buffer))
- elt)
- (set-buffer menu)
- (if (setq elt (assoc item x-menu-items-alist))
- (rplacd elt binding)
- (setq x-menu-items-alist (append x-menu-items-alist
- (list (cons item binding)))))
- (set-buffer old)
- item))
-
-(defun x-menu-delete-item (menu item)
- "Delete from MENU the item named ITEM.
-Call `x-menu-compute' before making the menu available to the user."
- (let ((old (current-buffer))
- elt)
- (set-buffer menu)
- (if (setq elt (assoc item x-menu-items-alist))
- (rplaca elt nil))
- (set-buffer old)
- item))
-
-(defun x-menu-activate (menu)
- "Compute all necessary parameters for MENU.
-This must be called whenever a menu is modified before it is made
-available to the user. This also creates the menu itself."
- (let ((buf (current-buffer)))
- (pop-to-buffer menu)
- (let (buffer-read-only)
- (setq x-menu-max-width (1- (frame-width)))
- (setq x-menu-item-width 0)
- (let (items-head
- (items-tail x-menu-items-alist))
- (while items-tail
- (if (car (car items-tail))
- (progn (setq items-head (cons (car items-tail) items-head))
- (setq x-menu-item-width
- (max x-menu-item-width
- (length (car (car items-tail)))))))
- (setq items-tail (cdr items-tail)))
- (setq x-menu-items-alist (reverse items-head)))
- (setq x-menu-item-width (+ x-menu-item-spacing x-menu-item-width))
- (setq x-menu-items-per-line
- (max 1 (/ x-menu-max-width x-menu-item-width)))
- (erase-buffer)
- (let ((items-head x-menu-items-alist))
- (while items-head
- (let ((items 0))
- (while (and items-head
- (<= (setq items (1+ items)) x-menu-items-per-line))
- (insert (format (concat "%"
- (int-to-string x-menu-item-width) "s")
- (car (car items-head))))
- (setq items-head (cdr items-head))))
- (insert ?\n)))
- (shrink-window (max 0
- (- (window-height)
- (1+ (count-lines (point-min) (point-max))))))
- (goto-char (point-min)))
- (pop-to-buffer buf)))
-
-(defun x-menu-pick-entry (position event)
- "Internal function for dispatching on mouse/menu events"
- (let* ((x (min (1- x-menu-items-per-line)
- (/ (current-column) x-menu-item-width)))
- (y (- (count-lines (point-min) (point))
- (if (zerop (current-column)) 0 1)))
- (item (+ x (* y x-menu-items-per-line)))
- (litem (cdr (nth item x-menu-items-alist))))
- (and litem (funcall litem event)))
- (pop-to-buffer x-menu-assoc-buffer))
-
-(provide 'x-menu)
-
-;; arch-tag: 889f6d49-c01b-49e7-aaef-b0c6966c2961
-;;; x-menu.el ends here
diff --git a/lisp/org/ChangeLog b/lisp/org/ChangeLog
index 96e00f4ddf3..29295d67d17 100644
--- a/lisp/org/ChangeLog
+++ b/lisp/org/ChangeLog
@@ -1,16 +1,5946 @@
-2010-10-22 Juanma Barranquero <lekktu@gmail.com>
+2010-11-12 Carsten Dominik <carsten.dominik@gmail.com>
- * org-exp.el (org-export-visible): Fix typo in docstring.
+ * org-capture.el (org-capture-templates): Remove autoload from
+ defcustom.
-2010-10-12 Juanma Barranquero <lekktu@gmail.com>
+ * ob-lisp.el (slime): Don't expect slime to be present.
- * org-agenda.el (org-prefix-category-length)
- (org-prefix-category-max-length): Fix typos in docstrings.
+2010-11-11 Dan Davison <dandavison7@gmail.com>
+
+ * ob.el: `copy-sequence' suffices to copy alist; no need for
+ `copy-tree'.
+
+2010-11-11 Dan Davison <dandavison7@gmail.com>
+
+ * ob.el (org-babel-execute-src-block): If ":results file" is in
+ effect, then ensure that the value of :file is returned as the
+ result; don't rely on language files for this.
+
+2010-11-11 Dan Davison <dandavison7@gmail.com>
+
+ * ob.el (org-babel-sha1-hash): Avoid corrupting `info' data
+ structure by side-effects of `sort'.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-bottom-point-with-indent): Do not check
+ indentation of a non-empty blank line.
+
+ * org-list.el (org-sort-list): Sort a list with point anywhere
+ inside it.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-calc.el (org-babel-execute:calc): Safer evaluation and
+ hopefully better error messages.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * org.el (org-babel-load-languages): Adding calc.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-initiate-session): Don't resolve variable
+ references unless prefix arg is supplied.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-calc.el (org-babel-execute:calc): Ensure that calc stack
+ refers to the correct stack.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-calc.el: Adding the beginnings of support for calc code
+ blocks.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-tangle.el (org-babel-update-block-body): Declaring function
+ for updating code block bodies.
+ (org-babel-spec-to-string):
+ (org-babel-detangle): Detangle all tangled and commented code
+ blocks in the current file back to org.
+ (org-babel-tangle-jump-to-org): Jump from a tangled and commented
+ file back to the originating org-mode code block ob-tangle:
+ detangle changes in code files back to the original org files.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-tangle.el (org-babel-tangle-comment-format-beg): Fix typo.
+ (org-babel-tangle-comment-format-end): Fix typo.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * org-exp.el (org-export-format-source-code-or-example): Use
+ minted for latex source code export if `org-export-latex-listings'
+ has the value 'minted
+
+ * org-latex.el (org-export-latex-listings): Document special value
+ 'minted
+
+ * org-latex.el (org-export-latex-minted): Delete variable.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-get-src-block-info): Retrieve contents of
+ parentheses, excluding parentheses themselves.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-gnuplot.el (org-babel-variable-assignments:gnuplot): Fixed
+ bug in gnuplot data file assignment using user variables.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-latex.el (org-babel-execute:latex): Adding new :headers
+ header argument for latex code blocks.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-capture.el (org-capture-templates): New capture property
+ `:kill-buffer'. (org-capture-finalize): Kill target buffer if that
+ is desired.
+ (org-capture-target-buffer): Remember if we have to make the
+ buffer.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-clock.el (org-dblock-write:clocktable): Fix bug when
+ computing clock tables.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-clock.el (org-dblock-write:clocktable): Pass file minutes up
+ to caller even if no table is generated.
+
+2010-11-11 Łukasz Stelmach <lukasz.stelmach@iem.pw.edu.pl>
+
+ * org-agenda.el (org-agenda-get-sexps): Handle lists as return
+ values from diary entries
+
+ * org-bbdb.el (org-bbdb-anniversaries): Handle lists of
+ anniversaries
+
+ * org.el (org-diary-sexp-entry): Handle lists as return values
+ from diary entries.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-capture.el (org-capture-empty-lines-before):
+ (org-capture-empty-lines-after): Make sure the n=0 does not insert
+ any newlines.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-clojure.el (org-babel-clojure-babel-clojure-cmd): Fixed error
+ message when clojure binary is not found.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-html.el (org-format-table-html): New argument DOCBOOK.
+ (org-format-org-table-html): New argument DOCBOOK. When set, use
+ align instead of class to align table fields.
+
+ * org-docbook.el (org-export-as-docbook): Specify the docbook
+ argument for the table converter.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-macs.el (org-called-interactively-p): New macro.
+
+ * org-freemind.el: No longer require 'rx.
+ (org-freemind): New customization group, use it for all the
+ variables.
+ (org-export-as-freemind): Add docstring.
+ (org-freemind-show): Improve filen naming.
+ (org-freemind-convert-links-helper): New function.
+ (org-freemind-bol-helper-base-indent): New variable.
+ (org-freemind-bol-helper): New function.
+ (org-freemind-node-css-style): New option.
+ (org-freemind-node-pattern): New variable.
+ (org-freemind-from-org-mode): Better docstring.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * ob-haskell.el (org-babel-variable-assignments:haskell): Don't
+ pass more than two arguments to mapc.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * ob.el (org-babel-ref-resolve): Declare to silence byte compiler.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-footnote.el (message-signature-separator): Defvar to silence
+ byte compiler.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-exp.el (org-export-string): Fix reference to wrong symbol.
+
+2010-11-11 Jambunathan K <kjambunathan@gmail.com>
+
+ * org.el (org-link-search): Return 'dedicated on successful match
+ when org-link-search-must-match-exact-headline is set to t.
+
+2010-11-11 Daniel Clemente <n142857@gmail.com>
+
+ * org-html.el (org-html-make-link): Append fragment to file: links
+ if present.
+
+2010-11-11 Tassilo Horn <tassilo@member.fsf.org>
+
+ * org-footnote.el (org-footnote-create-definition)
+ (org-footnote-goto-local-insertion-point): Add footnotes before
+ signature when in message-mode.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-display-inline-images): Improve regexp.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-cycle): Make sure resetting to startup visibility
+ works after another cycle command.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * org-exp.el (org-export-string): New function org-export-string
+ can be used to convert a string of test in org-mode markup to a
+ specified format.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-display-inline-images): Allow non-ASCII characters
+ in image file names. Save match data.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-auto-repeat-maybe): Fix shifting multiple time
+ stamps.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-exp.el (org-store-forced-table-alignment):
+ (org-export-remove-special-table-lines): Allow the "c" cookie for
+ table alignment.
+
+ * org-html.el (org-export-table-header-tags):
+ (org-export-table-data-tags): Add another %s format for the
+ alignment.
+ (org-export-html-table-align-individual-fields): New option.
+ (org-format-org-table-html): Implement field-by-field alignment
+ and support centering.
+ (org-format-table-table-html): Make sure the new table tag formats
+ don't break this function.
+
+ * org-table.el (org-table-cookie-line-p):
+ (org-table-align): Allow for the <c> cookie.
+
+ * org.el (org-set-font-lock-defaults): Allow for the <c> cookie.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-exp.el (org-export-normalize-links): Skip normalization of
+ plain links that are part of another link.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-R.el (org-babel-expand-body:R): Fix bug in let binding.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-indent.el: (org-indent-add-properties): Use
+ `with-silent-modificaitons'.
+ (org-indent-remove-properties): Use `with-silent-modificaitons'.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-table.el (org-table-cookie-line-p): Fix indentation.
+
+ * org-exp.el (org-store-forced-table-alignment): New function.
+ (org-export-preprocess-string): Call
+ `org-store-forced-table-alignment'.
+
+ * org-html.el (org-format-org-table-html): Use stored alignment
+ information.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-execute-src-block): Respects prefix argument
+ (which forces re-calculation).
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-execute-src-block): Removed needless param
+ sorting from ob-execute-src-block, the params are sorted already
+ by ob-sha1-hash.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-sha1-hash): Ensure that info is sorted at the
+ header argument level.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-sha1-hash): Consider words in different order
+ as different input.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-sha1-hash): Fix check for zero length sequences.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-sh.el (org-babel-sh-var-to-sh): Ensure value has the
+ structure of an Org-mode table (list of lists).
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-tangle.el (org-babel-tangle-collect-blocks): Fix bug
+ (reference to unassigned variable `src-lang' and avoid calling
+ org-babel-get-src-block-info twice.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-demarcate-block): Updated to reflect the new
+ info list contents.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * org-src.el (org-edit-src-code): Supply non-nil argument to
+ `org-babel-get-src-block-info' to avoid resolving variable
+ references.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-map-src-blocks): Fixed minor bug in and
+ improved efficiency of org-babel-map-src-blocks.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-tangle.el (org-babel-tangle-collect-blocks): Now explicitly
+ checks that a code block will actually be tangled before
+ collecting it's full information (a process which could involve
+ the execution of other code blocks).
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-demarcate-block): Use light version of
+ `org-babel-get-src-block-info'.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-sha1-hash): Now handles more complex types in
+ params.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-execute-src-block): Generally using the new
+ more informative params
+ (org-babel-process-params): Don't forget the :var portion of
+ variable assignments.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-table.el (sbe): Simplified to reflect to var resolution.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-ref.el (org-babel-ref-resolve): Bringing the referent
+ arguments back to their params before evaluation.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-ref.el (org-babel-ref-resolve): Cleanup of variable usage and
+ indentation.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-table.el (sbe): Use `org-babel-process-params params' instead
+ of `org-babel-expand-variables'.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-C.el (org-babel-C-execute): Remove call to
+ org-babel-process-params which should no longer be called from
+ within a language file
+
+ * ob-R.el (org-babel-execute:R): Remove call to
+ org-babel-process-params which should no longer be called from
+ within a language file
+ (org-babel-R-variable-assignments): Remove call to
+ org-babel-process-params which should no longer be called from
+ within a language file
+
+ * ob-asymptote.el (org-babel-execute:asymptote): Remove call to
+ org-babel-process-params which should no longer be called from
+ within a language file
+
+ * ob-clojure.el (org-babel-execute:clojure): Remove call to
+ org-babel-process-params which should no longer be called from
+ within a language file
+
+ * ob-dot.el (org-babel-execute:dot): Remove call to
+ org-babel-process-params which should no longer be called from
+ within a language file
+
+ * ob-emacs-lisp.el (org-babel-expand-body:emacs-lisp): Remove
+ call to org-babel-process-params which should no longer be called
+ from within a language file
+ (org-babel-execute:emacs-lisp): Remove call to
+ org-babel-process-params which should no longer be called from
+ within a language file
+
+ * ob-haskell.el (org-babel-execute:haskell): Remove call to
+ org-babel-process-params which should no longer be called from
+ within a language file
+
+ * ob-js.el (org-babel-execute:js): Remove call to
+ org-babel-process-params which should no longer be called from
+ within a language file
+
+ * ob-lisp.el (org-babel-execute:lisp): Remove call to
+ org-babel-process-params which should no longer be called from
+ within a language file
+
+ * ob-ocaml.el (org-babel-execute:ocaml): Remove call to
+ org-babel-process-params which should no longer be called from
+ within a language file
+
+ * ob-octave.el (org-babel-execute:octave): Remove call to
+ org-babel-process-params which should no longer be called from
+ within a language file
+
+ * ob-perl.el (org-babel-execute:perl): Remove call to
+ org-babel-process-params which should no longer be called from
+ within a language file
+
+ * ob-python.el (org-babel-execute:python): Remove call to
+ org-babel-process-params which should no longer be called from
+ within a language file
+
+ * ob-ruby.el (org-babel-execute:ruby): Remove call to
+ org-babel-process-params which should no longer be called from
+ within a language file
+
+ * ob-scheme.el (org-babel-execute:scheme): Remove call to
+ org-babel-process-params which should no longer be called from
+ within a language file
+
+ * ob-screen.el (org-babel-execute:screen): Remove call to
+ org-babel-process-params which should no longer be called from
+ within a language file
+ (org-babel-prep-session:screen): Remove call to
+ org-babel-process-params which should no longer be called from
+ within a language file
+
+ * ob-sh.el (org-babel-execute:sh): Remove call to
+ org-babel-process-params which should no longer be called from
+ within a language file
+
+ * ob-sql.el (org-babel-execute:sql): Remove call to
+ org-babel-process-params which should no longer be called from
+ within a language file
+
+ * ob-haskell.el (org-babel-execute:haskell): Remove reference to
+ processed params
+
+ * ob-clojure.el (org-babel-execute:clojure): Remove reference to
+ processed params
+
+ * ob-R.el (org-babel-execute:R): Remove reference to processed
+ params.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-sql.el (org-babel-execute:sql): Use generic expansion
+ function
+ (org-babel-expand-body:sql): Delete function.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-sh.el (org-babel-execute:sh): Use generic expansion function
+ (org-babel-expand-body:sh): Delete function
+ (org-babel-prep-session:sh): Change name of called function
+ (org-babel-variable-assignments:sh): Change function name.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-screen.el (org-babel-execute:screen): Use generic expansion
+ function
+ (org-babel-expand-body:screen): Delete function
+ (org-babel-prep-session:screen): Remove references to processed
+ params.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-sass.el (org-babel-execute:sass): Use generic expansion
+ function
+ (org-babel-expand-body:sass): Delete function.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-ruby.el (org-babel-execute:ruby): Use generic expansion
+ function
+ (org-babel-prep-session:ruby): Use new variable assignment
+ function
+ (org-babel-variable-assignments:ruby): New function
+ (org-babel-expand-body:ruby): Delete function.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-python.el (org-babel-execute:python): Use generic expansion
+ function
+ (org-babel-prep-session:python): Change name of called function
+ (org-babel-variable-assignments:python): Change function name
+ (org-babel-expand-body:python): Delete function.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-plantuml.el (org-babel-expand-body:plantuml): Delete function
+ (automatically handled by generic version).
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-perl.el (org-babel-execute:perl): Use generic expansion
+ function
+ (org-babel-expand-body:perl): Delete function
+ (org-babel-variable-assignments:perl): New function.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-org.el (org-babel-expand-body:org): Delete function
+ (automatically handled by generic version).
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-octave.el (org-babel-execute:octave): Use generic expansion
+ function
+ (org-babel-variable-assignments:octave): Change name of function
+ (org-babel-variable-assignments:matlab): New defalias
+ (org-babel-prep-session:octave): Change name of function
+ (org-babel-expand-body:matlab): Delete function
+ (org-babel-expand-body:octave): Delete function.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-ocaml.el (org-babel-execute:ocaml): Use generic expansion
+ function
+ (org-babel-variable-assignments:ocaml): New function
+ (org-babel-expand-body:ocaml): Delete function.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-mscgen.el (org-babel-expand-body:mscgen): Delete function
+ (automatically handled by generic version).
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-js.el (org-babel-execute:js): Use new variable assignment
+ function
+ (org-babel-expand-body:js): Delete function
+ (org-babel-prep-session:js): Use new variable assignment function
+ (org-babel-variable-assignments:js): New function.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-haskell.el (org-babel-execute:haskell): Use generic expansion
+ function
+ (org-babel-expand-body:haskell): Delete function
+ (org-babel-prep-session:haskell): Use variable assignment function
+ (org-babel-variable-assignments:haskell): New function.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-gnuplot.el (org-babel-expand-body:gnuplot): Use variable
+ assignment function
+ (org-babel-prep-session:gnuplot): Use variable assignment function
+ (org-babel-variable-assignments:gnuplot): New function.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-ditaa.el (org-babel-expand-body:ditaa): Delete function
+ (automatically handled by generic version).
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-css.el (org-babel-expand-body:css): Delete function
+ (automatically handled by generic version).
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-asymptote.el (org-babel-execute:asymptote): Use generic
+ expansion function
+ (org-babel-expand-body:asymptote): Delete function
+ (org-babel-variable-assignments:asymptote): New function.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-R.el (org-babel-expand-body:R): Use new function
+ `org-babel-variable-assignments:R'; don't trim body.
+ (org-babel-execute:R): Respond to changes in
+ `org-babel-expand-body:R'
+ (org-babel-prep-session:R): Called function is now named
+ `org-babel-variable-assignments:R'
+ (org-babel-variable-assignments:R): Receives processed-params as
+ new optional argument.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-C.el (org-babel-C-expand): Don't trim body.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-scheme.el (org-babel-expand-body:scheme): Fix bug in
+ obtaining variable references.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-tangle.el (org-babel-tangle-collect-blocks): Supply variable
+ assignment lines to generic expansion command.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-expand-src-block): Supply variable assignment
+ lines to generic expansion function
+ (org-babel-expand-body:generic): Prepend body with optional
+ variable assignment lines.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-exp.el (org-babel-exp-results): Replaced old function call.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-lob.el (org-babel-lob-execute): Now expanding variable
+ references before execution.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-execute-src-block): Only sort parameters if
+ it's required for caching.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-table.el (sbe): Reworking for better indentation and to
+ integrate the new variable resolution.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-ref.el (org-babel-ref-resolve-reference): Now expanding
+ variables when resolving references.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-merge-params): Fixed order or precedence for
+ variables.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-C.el (org-babel-expand-body:c++): Remove obsoleted optional
+ third argument
+ (org-babel-expand-body:c++): Remove obsoleted optional third
+ argument
+ (org-babel-C-expand): Remove obsoleted optional third argument
+
+ * ob-R.el:
+ (org-babel-expand-body:R): Remove obsoleted optional third
+ argument
+ (org-babel-execute:R): Remove obsoleted optional third argument
+ (org-babel-R-variable-assignments): Remove obsoleted optional
+ third argument
+
+ * ob-asymptote.el:
+ (org-babel-expand-body:asymptote): Remove obsoleted optional
+ third argument
+ (org-babel-execute:asymptote): Remove obsoleted optional third
+ argument
+
+ * ob-clojure.el:
+ (org-babel-expand-body:clojure): Remove obsoleted optional third
+ argument
+ (org-babel-execute:clojure): Remove obsoleted optional third
+ argument
+
+ * ob-css.el:
+ (org-babel-expand-body:css): Remove obsoleted optional third
+ argument
+
+ * ob-ditaa.el:
+ (org-babel-expand-body:ditaa): Remove obsoleted optional third
+ argument
+
+ * ob-dot.el:
+ (org-babel-expand-body:dot): Remove obsoleted optional third
+ argument
+ (org-babel-execute:dot): Remove obsoleted optional third
+ argument
+
+ * ob-emacs-lisp.el:
+ (org-babel-expand-body:emacs-lisp): Remove obsoleted optional
+ third argument
+ (org-babel-execute:emacs-lisp): Remove obsoleted optional third
+ argument
+
+ * ob-gnuplot.el:
+ (org-babel-expand-body:gnuplot): Remove obsoleted optional third
+ argument
+
+ * ob-haskell.el:
+ (org-babel-expand-body:haskell): Remove obsoleted optional third
+ argument
+ (org-babel-execute:haskell): Remove obsoleted optional third
+ argument
+ (org-babel-load-session:haskell): Remove obsoleted optional
+ third
+ (org-babel-prep-session:haskell): Remove obsoleted optional
+ third
+
+ * ob-js.el:
+ (org-babel-expand-body:js): Remove obsoleted optional third
+ argument
+ (org-babel-execute:js): Remove obsoleted optional third argument
+
+ * ob-latex.el:
+ (org-babel-expand-body:latex): Remove obsoleted optional third
+ argument
+
+ * ob-lisp.el:
+ (org-babel-expand-body:lisp): Remove obsoleted optional third
+ argument
+ (org-babel-execute:lisp): Remove obsoleted optional third
+ argument
+
+ * ob-mscgen.el:
+ (org-babel-expand-body:mscgen): Remove obsoleted optional third
+ argument
+
+ * ob-ocaml.el:
+ (org-babel-expand-body:ocaml): Remove obsoleted optional third
+ argument
+ (org-babel-execute:ocaml): Remove obsoleted optional third
+ argument
+
+ * ob-octave.el:
+ (org-babel-expand-body:matlab): Remove obsoleted optional third
+ argument
+ (org-babel-expand-body:octave): Remove obsoleted optional third
+ argument
+ (org-babel-execute:octave): Remove obsoleted optional third
+ argument
+ (org-babel-octave-variable-assignments): Remove obsoleted
+ optional third
+
+ * ob-org.el:
+ (org-babel-expand-body:org): Remove obsoleted optional third
+ argument
+
+ * ob-perl.el:
+ (org-babel-expand-body:perl): Remove obsoleted optional third
+ argument
+ (org-babel-execute:perl): Remove obsoleted optional third
+ argument
+
+ * ob-plantuml.el:
+ (org-babel-expand-body:plantuml): Remove obsoleted optional
+ third argument
+
+ * ob-python.el:
+ (org-babel-expand-body:python): Remove obsoleted optional third
+ argument
+ (org-babel-execute:python): Remove obsoleted optional third
+ argument
+ (org-babel-python-variable-assignments): Remove obsoleted
+ optional third
+
+ * ob-ruby.el:
+ (org-babel-expand-body:ruby): Remove obsoleted optional third
+ argument
+ (org-babel-execute:ruby): Remove obsoleted optional third
+ argument
+
+ * ob-sass.el:
+ (org-babel-expand-body:sass): Remove obsoleted optional third
+ argument
+
+ * ob-scheme.el:
+ (org-babel-expand-body:scheme): Remove obsoleted optional third
+ argument
+ (org-babel-execute:scheme): Remove obsoleted optional third
+ argument
+
+ * ob-screen.el:
+ (org-babel-expand-body:screen): Remove obsoleted optional third
+ argument
+
+ * ob-sh.el:
+ (org-babel-expand-body:sh): Remove obsoleted optional third
+ argument
+ (org-babel-execute:sh): Remove obsoleted optional third argument
+ (org-babel-sh-variable-assignments): Remove obsoleted optional
+ third
+
+ * ob-sql.el:
+ (org-babel-expand-body:sql): Remove obsoleted optional third
+ argument
+
+ * ob-sqlite.el:
+ (org-babel-expand-body:sqlite): Remove obsoleted optional third
+ argument
+ (org-babel-execute:sqlite): Remove obsoleted optional third
+ argument
+
+ * ob.el:
+ (org-babel-expand-body:generic): Remove obsoleted optional third
+ argument.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-clojure.el (org-babel-prep-session:clojure): Purging all
+ calls to removed org-babel-ref-variables.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-lob.el (org-babel-lob-ingest): Now returns the count of
+ ingested code blocks.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-exp.el (org-babel-exp-in-export-file): Wrapper for collecting
+ information from within the original export file.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-get-src-block-info): Small but crucial fix)
+ (this should return nil if not match found.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-emacs-lisp.el (org-babel-expand-body:emacs-lisp): Whitespace
+ (org-babel-execute:emacs-lisp): Whitespace.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-sh.el (org-babel-sh-variable-assignments): Provide missing
+ docstring
+
+ * ob-python.el (org-babel-python-variable-assignments): Provide
+ missing docstring.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-octave.el (org-babel-expand-body:octave): Refactor: break
+ variable assignment part out into a separate function
+ (org-babel-octave-variable-assignments): New function constructing
+ list of variable assignment statements
+ (org-babel-prep-session:octave): Use new function
+ `org-babel-octave-variable-assignments' instead of previous
+ (incorrect) variable assignment code.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-sh.el (org-babel-expand-body:sh): Refactor: break variable
+ assignment part out into a separate function
+ (org-babel-sh-variable-assignments): New function constructing
+ list of variable assignment statements
+ (org-babel-prep-session:sh): Use new function
+ `org-babel-sh-variable-assignments' instead of previous
+ (incorrect) variable assignment code.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-python.el (org-babel-expand-body:python): Refactor: break
+ variable assignment part out into a separate function
+ (org-babel-python-variable-assignments): New function constructing
+ list of variable assignment statements
+ (org-babel-prep-session:python): Use new function
+ `org-babel-python-variable-assignments' instead of previous
+ (incorrect) variable assignment code.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-R.el (org-babel-expand-body:R): Refactor: break variable
+ assignment part out into a separate function
+ (org-babel-R-variable-assignments): New function constructing list
+ of variable assignment statements
+ (org-babel-prep-session:R): Use new function
+ `org-babel-R-variable-assignments' instead of previous
+ (incorrect) variable assignment code.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-initiate-session): Better variable names.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-number-sequence): Declared
+
+ * ob-R.el (org-number-sequence): Declared.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-map-src-blocks): Store correct value of
+ `end-block'.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-mark-block): New function to mark the body of a
+ src block in the style of `mark-defun'.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-compat.el (org-number-sequence): New function.
+
+ * ob-R.el (org-babel-expand-body:R): Use `org-number-sequence'.
+
+ * ob.el (org-babel-where-is-src-block-result): Use
+ `org-number-sequence'.
+ (org-babel-current-buffer-properties): Fix variable definition.
+
+ * ob-ref.el (org-babel-ref-index-list): Use `org-number-sequence'.
+
+ * ob-latex.el (org-babel-latex-tex-to-pdf): Use the 2-argument
+ version of `shell-command'.
+
+ * org-latex.el (org-export-as-pdf): Use the 2-argument version of
+ `shell-command'.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-list.el (org-list-search-unenclosed-generic): Replace call
+ to booleanp.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-agenda-jump-prefer-future): New option.
+
+ * org-agenda.el (org-agenda-goto-date): Use
+ `org-agenda-jump-prefer-future'.
+
+2010-11-11 Noorul Islam <noorul@noorul.com>
+
+ * org-latex.el (org-export-latex-links) : Replaced hard coded
+ hyperref format with custom variable
+ `org-export-latex-hyperref-format'.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-insert-heading): Fix docstring.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com> (tiny change)
+
+ * org-capture.el (org-capture-place-entry): If the first line is
+ already a headline, just stay there.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-sh.el (org-babel-sh-evaluate): No longer assumes that results
+ are non-nil.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-ascii.el (org-ascii-replace-entities): Match an optional {}
+ after an entity.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-table.el (orgtbl-to-html): Apply `org-html-expand' to the
+ table fields.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-insert-heading): When on the headline of an inline
+ task, insert another inline tasks.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-tangle.el (org-babel-tangle-collect-blocks): Only create
+ links for blocks that will actually tangle.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-sh.el (org-babel-expand-body:sh): Don't insert extra newlines
+ in expanded shell bodies.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-sh.el (org-babel-expand-body:sh): Avoid inserting extra
+ newline characters.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-sh.el (org-babel-expand-body:sh): Align code.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-params-from-properties): Max line with at <=80
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * org-latex.el (org-export-latex-listings-langs): Clojure is now
+ recognized as a lisp.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-params-from-properties): Use `org-babel-read'
+ to interpret property as header argument value.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-parse-header-arguments): Simplify reading of
+ header arg value.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-publish.el (org-publish-org-to-ascii):
+ (org-publish-org-to-latin1):
+ (org-publish-org-to-utf8): New functions.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-insert-heading): Skip inline tasks when trying to
+ insert a new heading after the end of the subtree.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-inlinetask.el (org-inlinetask-min-level): Set customization
+ type to integer or nil.
+
+ * org.el (org-insert-heading): When after an inline task, do not
+ use level but go back to headline level before the inline task.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-inlinetask.el (org-inlinetask-in-task-p): New function.
+
+ * org.el (org-indent-line-function): Fix indentation of inline
+ tasks.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-activate-links): Fix customize type.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-latex-to-pdf-process): Add rubber as another
+ default option.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * org-latex.el (org-export-latex-minted): Document pygments
+ dependency.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-mobile.el (org-mobile-create-index-file): Encrypt the index
+ file if encryption has been turned on.
+ (org-mobile-copy-agenda-files): Avoid double encryption of
+ `mobileorg.org'.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * org-exp.el (org-export-latex-minted-with-line-numbers): Ensure
+ that variable is declared.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-python.el (org-src-preserve-indentation): Fixed compiler
+ warning.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * org-exp.el (org-export-format-source-code-or-example): Latex
+ formatting of source code blocks using the minted package
+ (org-export-plist-vars): Add :latex-minted property
+ (org-export-latex-minted): Ensure variable is defined
+ (org-export-latex-minted-langs): Ensure variable is defined.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-src.el (org-edit-src-code): Use `org-region-active-p'.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-tangle.el (org-babel-spec-to-string): Whitespace changes.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-tangle.el (org-babel-spec-to-string): Don't trim whitespace
+ when `org-src-preserve-indentation' is non-nil.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-lob.el (org-babel-lob-ingest): Provide message stating number
+ of blocks added to Library of Babel.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-lob.el (org-babel-lob-ingest): Check for nil source block
+ name.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-beamer.el (org-beamer-place-default-actions-for-lists): Fix
+ typo in regexp.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-toggle-checkbox): Avoid some boundary error
+ when inserting a checkbox in an empty last item of a list.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-gnus.el (org-gnus-nnimap-query-article-no-from-file): Query
+ article number from file is nil by default.
+
+2010-11-11 Stephen Eglen <S.J.Eglen@damtp.cam.ac.uk>
+
+ * org-beamer.el (org-beamer-amend-header): Fix typo in docstring.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-capture.el (org-capture-place-entry): Move to `beg' before
+ searching for `%?'.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-format-latex): Fix mathjax treatment of single
+ letters in between dollars.
+
+2010-11-11 Sébastien Vauban <wxhgmqzgwmuf@spammotel.com>
+
+ * org-latex.el (org-latex-to-pdf-process): Add a third pdflatex
+ run.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-blank-before-new-entry): Improve docstring.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-mobile.el (org-mobile-force-id-on-agenda-items): Fix
+ docstring.
+ (org-mobile-write-agenda-for-mobile): Use outline path if we do
+ not have an ID and are not allowed to make one.
+ (org-mobile-get-outline-path-link): New function.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-mobile.el (org-mobile-copy-agenda-files): Encrypt the empty
+ file.
+ (org-mobile-write-agenda-for-mobile): Use the right name, even if
+ the file get encrypted.
+ (org-mobile-move-capture): Only delete tempfile if it does exist.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-number-p): Fixed documentation string.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-tangle.el (org-babel-tangle-collect-blocks): Accepting
+ "tangle" as a positive argument for the :noweb header argument
+ during tangling.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-exp.el (org-babel-exp-src-blocks): Fixed export when headings
+ have links, with tests.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-latex-to-pdf-process): Use texi2dvi if
+ available.
+ (org-export-latex-get-error): New function.
+ (org-export-as-pdf): Give an indication of the errors that
+ happened during processing.
+
+2010-11-11 Łukasz Stelmach <lukasz.stelmach@iem.pw.edu.pl>
+
+ * org-exp.el (org-export-language-setup): Fix Polish entries.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-set-tags): Allow comma as a separator when
+ specifying tags at the completion interface.
+ (org-tags-completion-function): Allow comma as a separator when
+ specifying tags at the completion interface.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-exp.el (org-babel-exp-src-blocks): Don't jump back to
+ export-file if exporting from a buffer which is not visiting a
+ file.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-exp.el (org-babel-exp-src-blocks): Only append "::" to a file
+ name in link construction if there is a heading to follow it.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-html.el (org-export-html-inline-image-extensions): Add "svg"
+ as an allowed extension.
+
+2010-11-11 Sébastien Vauban <wxhgmqzgwmuf@spammotel.com>
+
+ * org-agenda.el (org-agenda-add-time-grid-maybe): Pad clock times
+ with zeros. Start applying face earlier.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (or): Don't create org-babel-temporary-directory in batch
+ as it won't be removed by emacs-kill-hook
+ (org-babel-remove-temporary-directory): Only try to remove this
+ directory if it exists.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-temporary-directory): Fixing byte-compilation
+ warning in ob.el.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-tangle.el (org-babel-tangle): Now sharing the file name in
+ the tangling message.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-load-languages): Fixes compiler warning.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-plantuml.el (org-babel-execute:plantuml): Fixes bug with svg
+ output.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-ascii.el (org-export-as-ascii): Use the correct match group.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (boundp): Uncommenting defvar form for
+ org-babel-temporary-directory
+ (org-babel-temp-file): Now using the org-babel-temporary-directory
+ for holding new babel temporary files
+ (org-babel-remove-temporary-directory): Removes the babel temp dir
+ when Emacs shutsdown
+ (kill-emacs-hook): Now removing the babel temp dir on Emacs
+ shutdown.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-capture.el (org-capture-fill-template): Initialize history
+ variable.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * org-src.el (org-edit-src-code): Don't move point when generating
+ edit buffer.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * org-src.el (org-edit-src-code): Deal with point being in
+ #+end_src line.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-table.el (org-table-current-column): Add interactive to turn
+ this into a command.
+
+2010-11-11 Bernt Hansen <bernt@norang.ca>
+
+ * org.el (org-insert-heading): Run org-insert-heading-hook when
+ creating the first heading in a file.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-startup-with-inline-images): New option.
+ (org-startup-options): Add new keywords inlineimages and
+ noinlineimages.
+ (org-mode): Inline images when this has been configured.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-get-src-block-info): Remove optional
+ HEADER-VARS-ONLY argument; further simplification.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-confirm-evaluate): Fixed bug causing extra
+ prompt in ob-confirm-evaluate in some cases.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-demarcate-block): Visible region and completion
+ during language selection.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-get-src-block-info): Remove comment.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-get-src-block-info): Simplify function.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-get-src-block-info): Form info list correctly
+ when parenthesised arguments are missing.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-exp.el (org-export-babel-evaluate): Docstring typo
+ (org-babel-exp-code): Docstring typo.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-mobile.el (org-mobile-encryption-password): Improve
+ docstring.
+ (org-mobile-encryption-password-session): New variable.
+ (org-mobile-encryption-password): New function.
+ (org-mobile-check-setup):
+ (org-mobile-encrypt-file):
+ (org-mobile-decrypt-file): Use the new function.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-capture.el (org-capture-place-template): Widen to remove
+ possible restrictions in target buffer.
+
+2010-11-11 Jambunathan K <kjambunathan@gmail.com>
+
+ * org.el (org-speed-command-hook): Added org-speed-command-hook
+ (org-babel-speed-command-hook): Hook for Babel's speed commands.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-execute-buffer): Re-implement using
+ `org-babel-map-src-blocks'.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-capture.el (org-capture-templates): Update doc string with
+ new message date related escapes.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-wl.el (org-wl-store-link-message): Define properties %:date)
+ (%:date-timestamp, and %:date-timestamp-inactive.
+
+ * org-mew.el (org-mew-store-link): Dto.
+
+ * org-mhe.el (org-mhe-store-link): Dto.
+
+ * org-rmail.el (org-rmail-store-link): Dto.
+
+ * org-vm.el (org-vm-store-link): Dto.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-wl.el (org-wl-message-field): Always get literal content of
+ header fields.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-gnus.el (org-gnus-store-link): Define properties
+ %:date-timestamp and %:date-timestamp-inactive.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-gnus.el (org-gnus-store-link): Handle empty date header
+ field.
+
+2010-11-11 Jambunathan K <kjambunathan@gmail.com> (tiny change)
+
+ * org.el (org-speed-command-hook): New. Hook for installing
+ additional speed commands. Use this for enabling speed commands on
+ src blocks.
+ (org-speed-command-default-hook): The default hook for
+ org-speed-command-hook. Factored out from org-self-insert-command
+ and mimics existing behaviour.
+ (org-self-insert-command): Modified to use org-speed-command-hook.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-search-view): Recover spaces in search words
+ if they were escaped with \ or inside a regexp.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-additional-option-like-keywords): Add PROPERTIES to
+ the list of completable meta line words.
+ (org-complete): Complete property names after #+PROPERTY.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-python.el (org-babel-python-evaluate-session): Make temp file
+ names consistent.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-clojure.el (org-babel-clojure-evaluate-external-process):
+ Delete extra format argument.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-org.el (org-babel-org-export): Typo in docstring.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-sh.el (org-babel-sh-evaluate): Remove unused temporary file
+ variable.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-scheme.el (org-babel-execute:scheme): Alter temp file name.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-process-file-name): New function
+ (org-babel-maybe-remote-file): Delete function.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-C.el (org-babel-C-execute): Remove unused variable.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org.el (org-make-link-string): Prevent superfluous colon.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org.el (org-make-org-heading-search-string): Leave headline
+ intact.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org.el (org-make-link-string): Don't escape characters in link
+ type.
+
+2010-11-11 Bastien Guerry <bzg@altern.org>
+
+ * org-capture.el (org-capture-templates): Update docstring to
+ advertize %:org-date.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-dot.el (org-babel-execute:dot): Automatically specifies
+ "-T<ext>" based on file name extension.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-org.el (org-babel-org-export): Raise error on nested export
+ call.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-plantuml.el (org-babel-execute:plantuml): Support for svg
+ output files.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-demarcate-block): Better initialization of
+ stars.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * org-src.el (org-src-tab-acts-natively): Add customize interface.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * org-src.el (org-src-strip-leading-and-trailing-blank-lines): New
+ variable allowing prevention of automatic stripping of leading and
+ trailing blank lines when exiting edit buffer.
+ (org-edit-src-exit): Respect value of
+ `org-src-strip-leading-and-trailing-blank-lines'
+ (org-src-native-tab-command-maybe): Bind
+ `org-src-strip-leading-and-trailing-blank-lines' to nil during
+ this function.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * org-src.el (org-edit-src-code): If mark was inside code block
+ then code edit buffer inherits mark with active region.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-demarcate-block): Fix compiler warnings.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-demarcate-block): Better handling of empty
+ space around demarcated area.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-agenda-goto-date): Turn off prefer future for
+ this command.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-gnus.el (org-gnus-open-nntp): New function.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-wl.el (org-wl-open-nntp): New function.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-wl.el (org-wl-open): Open message by numeric reference if
+ article part is not a message id.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-agenda-filter-apply): Move cursor to a
+ visible line.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-demarcate-block): Interactive demarcation of
+ code blocks
+
+ * ob-keys.el (org-babel-key-bindings): Key bindings for block
+ demarcation.
+
+2010-11-11 Bastien Guerry <bzg@altern.org>
+
+ * org.el (org-link-types): Add the "message" link type.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org.el (org-link-types): Add 'message:' link type to default
+ link types.
+
+2010-11-11 Bastien Guerry <bzg@altern.org>
+
+ * org-gnus.el (org-gnus-store-link): Add the :date property to
+ gnus links, allowing the use of %:date in capture templates.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-cycle-list-bullet): Follow order of bullets
+ indicated in doc-string.
+
+ * org-list.el (org-list-bottom-point-with-indent): List is ended
+ when a line is less indented that the last item, not the less
+ indented item.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-exp.el (org-babel-exp-src-blocks): Now switching back to the
+ original file before resolving code block parameters to ensure
+ headline and buffer wide parameters are taken into consideration
+ when only a narrowed portion of the file is exported.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-forward-same-level): Fix docstring.
+
+2010-11-11 Sebastian Rose <sebastian_rose@gmx.de>
+
+ * org-publish.el (org-publish-attachment): Put the attachment into
+ the right directory.
+
+2010-11-11 Jambunathan K <kjambunathan@gmail.com> (tiny change)
+
+ * org.el (org-goto-first-child): New command.
+
+2010-11-11 Matt Lundin <mdl@imapmail.org>
+
+ * org-agenda.el (org-prepare-agenda): If the agenda is called from
+ within the agenda via an elisp link, such as
+ [[elisp:(org-agenda-list)]], org-prepare-agenda erases the buffer
+ of the file containing the link, since that buffer is current
+ during org-prepare agenda (due to a with-current-buffer in
+ org-agenda-open-link). An additional test now ensures that the
+ agenda buffer is in fact current when the buffer is erased and
+ local variables for the agenda are set.
+
+2010-11-11 David Maus <dmaus@ictsoc.de> (tiny change)
+
+ * org-exp.el (org-infile-export-plist): Define property macro.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-mhe.el (org-mhe-get-header): Remove possible folding white
+ space in message header field.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-feed.el (org-feed): Fix typo in customization group :tag
+ property.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-export-latex-tag-markup): New option.
+ (org-export-latex-keywords-maybe): Use
+ `org-export-latex-tag-markup'.
+
+2010-11-11 Rémi Vanicat <vanicat@debian.org>
+
+ * org-icalendar.el (org-icalendar-use-UTC-date-time): New option.
+ (org-ical-ts-to-string): Use UTC time when requested.
+
+2010-11-11 Noorul Islam <noorul@noorul.com> (tiny change)
+
+ * org-html.el (org-html-cvt-org-as-html): Do not convert protocol
+ from 'file' to 'http'.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org.el (org-store-log-note): Fix wrong usage
+ of`org-adapt-indentation'.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org.el (org-skip-over-state-notes): Do not compute bottom point
+ at each item.
+
+ * org-mouse.el (org-mouse-for-each-item): Use `org-apply-on-list'
+ instead of moving to each item.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-capture.el (org-capture-templates): Small fix in doc string.
+
+2010-11-11 aaa bbb <dominik@powerbook-g4-12-van-aaa-bbb.local>
+
+ * org-archive.el (org-get-local-archive-location): Use
+ `org-carchive-location' as default.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-C.el (org): No longer requires org
+
+ * ob-ledger.el (org): No longer requires org.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org.el (org-priority): Save match data before call to
+ `read-char-exclusive'.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-to-generic): Descriptions labels can be
+ any suit of symbols, and will end at double colons.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org.el (org-indent-line-function): Indent past [@num] and
+ [@start:num], consistently with what is already done with
+ checkboxes.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org.el (org-store-log-note): Indent new notes to the right
+ column. Also take `org-list-two-spaces-after-bullet-regexp' into
+ consideration when creating the note.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-gnus.el (nnimap-group-overview-filename): Declare function
+ to silence byte compiler.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-gnus.el (org-gnus-nnimap-query-article-no-from-file): New
+ customization variable.
+ (org-gnus-nnimap-cached-article-number): New function.
+ (org-gnus-follow-link): Try to fetch cached article number of
+ message-id.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-org.el (org-babel-org-default-header): Used to insert a dummy
+ first line into code blocks before export so that the first line
+ is not interpreted as a title
+ (org-babel-org-export): Use new dummy code block prefix.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-insert-result): No longer throws error when
+ inserting an empty result.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-tangle.el: autoload org-babel-tangle-lang-exts from ob-tangle.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-do-in-edit-buffer): Use
+ `org-babel-where-is-src-block-head' to test for source block at
+ point.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-keys.el (org-babel-key-bindings): Adding key-binding for
+ `org-babel-goto-src-block-head'
+
+ * ob.el (org-babel-goto-src-block-head): Jump to the head of the
+ current code block.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-next-src-block): Now raising more informative
+ error when no further code blocks can be found
+ (org-babel-previous-src-block): Now raising more informative error
+ when no previous code blocks can be found.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * org-exp-blocks.el
+ (org-export-preprocess-after-include-files-hook): Now using this
+ hook instead of `org-export-preprocess-hook'.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-plantuml.el (org-babel-execute:plantuml):
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-python.el (org-babel-python-evaluate): Refactor as call to
+ either `org-babel-python-evaluate-external-process' or
+ `org-babel-python-evaluate-session'.
+ (org-babel-python-evaluate-external-process): New function to
+ handle evaluation in external process.
+ (org-babel-python-evaluate-session): New function to handle
+ evaluation in emacs inferior process.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-org.el (org-babel-execute:org): Evaluates body to latex ascii
+ or html respecting :results header arg
+ (org-babel-org-export): Exports a string of text to an output
+ format.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-insert-result): Remove existing results when
+ nil results are returned.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-ascii.el (org-export-as-ascii): Bind and set link path for
+ link type specific markup function.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-clock.el (notifications-notify): Properly declare function
+ to silence byte compiler.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-insert-item): Check invisibility of point at a
+ meaningful location.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-insert-item-generic): Updating checkboxes
+ can modifiy bottom point of a list, so make it a marker before
+ calling `org-update-checkbox-count-maybe'.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * org.el (org-src-fontify-natively): Set to nil by default.
+ Supply cutomize interface.
+
+2010-11-11 Bastien Guerry <bzg@altern.org>
+
+ * org-ascii.el (org-export-as-ascii): Fix bug in ASCII export: use
+ `org-bracket-link-analytic-regexp++' to match the link type.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-tangle.el (org-babel-tangle-collect-blocks): Rename `lang' to
+ `language'.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-tangle.el (org-babel-tangle-comment-format-beg): Format
+ string specifying the link-comment preceding a code block
+ (org-babel-tangle-comment-format-end): Format string specifying
+ the link-comment following a code block
+ (org-babel-tangle-collect-blocks): Storing more information in the
+ spec of a tangling code block
+ (org-babel-spec-to-string): Now makes use of customizable
+ link-comment formats.
+
+2010-11-11 Achim Gratz <Stromeko@stromeko.net> (tiny change)
+
+ * org.el (org-delete-backward-char): Check for nil overwrite-mode
+ before inserting spaces.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-icalendar.el (org-print-icalendar-entries): Exclude tags
+ from summary of non-TODO ical entries.
+ (org-print-icalendar-entries): Use `org-complex-heading-regexp' to
+ exclude tags from summary of TODO ical entries.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-map-src-blocks): Now exposes much information
+ about the code block in the form of let-bound local variables.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-list.el (org-outline-regexp, org-ts-regexp)
+ (org-ts-regexp-both, org-in-regexps-block-p)
+ (org-level-increment, org-at-heading-p)
+ (outline-previous-heading, org-icompleting-read)
+ (org-time-string-to-seconds): Declare to fix compiler warning.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-toggle-checkbox): Ignore items in drawers when
+ used from an heading. Send an error when no item is in region.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-do-in-edit-buffer): Use unwind-protect to
+ ensure that edit buffer is exited.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-tangle.el (org-babel-tangle-pad-newline): Can be used to
+ control the amount of extra newlines inserted into tangled code
+ (org-babel-tangle-collect-blocks): Now conditionally collects
+ information to be used for "org" style comments
+ (org-babel-spec-to-string): Now inserts "org" style comments, and
+ obeys the newline configuration variable when inserting whitespace.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-tangle.el (org-babel-pre-tangle-hook): Defines new tangle
+ hook
+ (org-babel-tangle): Calls new tangle hook.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-capture.el (org-capture): Compute the length of the correct
+ string when removing properties.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-plantuml.el (org-babel-execute:plantuml): Now expanding file
+ names before shell quoting.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * org-src.el (org-src-tab-indents-natively): New variable
+ controlling whether language-native TAB action should be performed
+ (org-src-native-tab-command-maybe): New function to perform
+ language-native TAB action.
+ (org-tab-first-hook): Add `org-src-native-tab-command-maybe'.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-plantuml.el (org-babel-execute:plantuml): Explicitly check
+ `org-plantuml-jar-path' before use.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * org-src.el (org-src-font-lock-fontify-block): Re-use hidden
+ language major mode buffers during fontification.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * org.el (org-fontify-meta-lines-and-blocks): Alter main regexp to
+ match code blocks with switches and header args. Call
+ `org-src-font-lock-fontify-block' for automatic fontification of
+ code in code blocks, controlled by variable
+ `org-src-fontify-natively'.
+ (org-src-fontify-natively): New variable.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-ruby.el (org-babel-expand-body:ruby): Removed requirement of
+ inf-ruby.
+
+2010-11-11 Noorul Islam <noorul@noorul.com> (tiny change)
+
+ * org-html.el (org-html-make-link): (Expand-file-name ) removes
+ one "/" from "///path-to-file", so add one. Anything other than
+ 'file' type should be exported along with the type.
+
+2010-11-11 Noorul Islam <noorul@noorul.com> (tiny change)
+
+ * org.el (org-insert-subheading) : Fix compiler warning
+ (org-insert-todo-subheading) : Fix compiler warning.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-capture.el (org-capture): Remove read-only text properties
+ from capture text.
+ (org-capture-set-target-location): Throw an error if file+headline
+ target does not point into a file which is in Org mode.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-map-src-blocks): Prefer `when' to `if'.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * org-src.el (org-edit-src-code): Improve docstring.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-execute-src-block): Document prefix argument in
+ docstring.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-ditaa.el (org-babel-execute:ditaa): Now expanding
+ org-ditaa-jar-path with expand-file-name.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-execute-subtree): Pass prefix arg through to
+ `org-babel-execute-src-block'.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-ascii.el (org-export-ascii-preprocess): Allow [@start:x] and
+ [@x] syntax for list numbering.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org.el (org-indent-line-function): Indentation of source block
+ is left to `org-edit-src-exit' and shouldn't be modified by
+ `org-indent-line-function'. Indentation of others blocks should be
+ the same as the #+begin line.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-map-src-blocks): If FILE is nil evaluate BODY
+ forms on source blocks in current buffer; restore point in current
+ buffer.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-struct): Accept list boundaries as an
+ argument in order to avoid computing `org-list-top-point' and
+ `org-list-bottom-point' twice when indenting.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-ending-method): Default value is now
+ `both', to ensure maximum compatibility before previous
+ implementation.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-in-item-p-with-indent): Test if first line
+ is the item beginning.
+
+ * org-list.el (org-list-top-point-with-indent): Test if first line
+ is a valid list beginning.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-ending-method): New customizable variable
+ to tell Org Mode how lists end. See docstring.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-indent-item-tree): Shifting step of top-level
+ item depends on `org-level-increment'.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org.el (org-indent-line-function): Indent first non blank line
+ after a list according to current heading level.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-docbook.el (org-export-as-docbook): Removed check for
+ indentation on lines that do not start with a list bullet.
+
+ * org-html.el (org-export-as-html): Same thing.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-bottom-point): Take into consideration
+ that bound of search can be before true ending of the list.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-struct-apply-struct): No longer shift
+ item's body twice: one after replacing bullet and one after
+ changing indentation.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-struct-indent): Added code to replace
+ bullets if needed when indenting.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-insert-item-generic): A single item
+ already counting blank lines in his body should be separated with
+ the next one by a blank line. Moreover, if user already provided
+ blank lines, follow his wishes.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-indent-item-tree): When moving top item of a
+ *-list to column 0, only the first item had its bullet changed to
+ -. It now changes all items of the top-level list, as expected.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-toggle-checkbox): Go to beginning of line
+ before processing.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-struct-apply-struct): Check if ancestor
+ exists.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-renumber-ordered-list): Check for [@start:x] is
+ done at each item.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el : Removed unused variable
+ `org-suppress-item-indentation'.
+
+ * org-list.el (org-renumber-ordered-list): Skip item if bullet
+ number is already good.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-automatic-rules): Doc-string reflects this
+ change.
+
+ * org-list.el (org-indent-item-tree): Prevent whole list from
+ being moved when user is not moving subtree. Thus)
+ (`org-cycle-item-indentation' will not allow to move the list.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-indent-item-tree): Removed region code. It was
+ prone to errors and undocumented.
+
+ * org-list.el (org-item-indent-positions): Better heuristics to
+ determine what bullet the item will have when demoted.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-bullet-string): First check if
+ `org-list-two-spaces-after-bullet-regexp' isn't nil.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-bullet-string): Do not modify match-data.
+
+ * org.el (org-toggle-item): Now working again when changing list
+ items into plain text. Moreover take into consideration
+ `org-list-two-spaces-after-bullet-regexp'.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-indent-item-tree): Removed unnecessary bullets
+ fix, and improved heuristics to determine bullet when indenting.
+
+ * org-list.el (org-item-indent-positions): Function now returns
+ sane results when there are two lists separated with blank lines
+ only.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-docbook.el (org-export-as-docbook): Use override="num" in
+ any listitem matching [@start:num]
+
+ * org-html.el (org-export-as-html): Use value="num" in any li
+ matching
+ [@start:num]
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org.el (org-set-font-lock-defaults): Correct fontification for
+ checkboxes found after [@start:?].
+
+ * org-list.el (org-list-at-regexp-after-bullet-p): Skip any
+ [@start:?] when looking at a regex after a bullet.
+
+ * org-list.el (org-toggle-checkbox): Correct insertion of
+ checkboxes when there is already a [@start:?] in the item.
+
+ * org-list.el (org-checkbox-blocked-p): Properly check if there's
+ an unchecked item before.
+
+ * org-list.el (org-list-parse-list): Function handles items having
+ both a counter and a checkbox.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-cycle-item-indentation): Org-tab-ind-state
+ stores both indentation and bullet when cycle started.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el: `org-at-description-p' renamed to
+ `org-at-item-description-p', `org-first-list-item-p' renamed to
+ `org-list-first-item-p', `org-end-of-item-text-before-children'
+ renamed to `org-end-of-item-or-at-child'.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org.el (org-ctrl-c-ctrl-c): Call `org-fix-bullet-type' instead
+ of `org-maybe-renumber-ordered-list' and `org-fix-bullet-type'
+ before toggling a checkbox.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-bullet-string): New function returning
+ bullet concatenated with an appropriate number of white spaces.
+
+ * org-list.el (org-list-insert-item-generic): Insert the right
+ bullet, with help of `org-list-bullet-string'.
+
+ * org-list.el (org-indent-item-tree): Use
+ `org-list-bullet-string'.
+
+ * org-list.el (org-fix-bullet-type): Use `org-list-bullet-string'.
+
+ * org-list.el (org-toggle-checkbox): Send an error when
+ `org-toggle-checkbox' is trying to insert a checkbox at a
+ description item.
+
+ * org-list.el (org-item-re): Modified regexp so it can catch
+ correct number of white space before item body.
+
+ * org-list.el (org-list-at-regexp-after-bullet-p): Take into
+ consideration new `org-item-re'.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-insert-item-generic): The second item in a
+ list will be separated from its predecessor with the number of
+ blank lines separating the first item from its parent, if any, or
+ no blank line.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-indent-item-tree): Fix and reorder every list
+ and sublist, from parent of list that has moved if indenting, or
+ from list at point if outdenting.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-indent-item-tree): Try to keep relative
+ position on line. It can't if point is in white spaces before
+ bullet because mixed tabs and spaces make some columns
+ unattainable.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-cycle-item-indentation): Cycle when the whole
+ item only contains bullet and maybe a checkbox. Previously, TAB
+ would cycle when the first line of the item was blank.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-cycle-item-indentation): Allow a point just
+ after a description item or a checkboxed item to start cycling.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-cycle-list-bullet): Check
+ `org-plain-list-ordered-item-terminator' before allowing 1. or 1)
+ as valid bullets when cycling.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-cycle-item-indentation): Do return t if and
+ only if cycling is possible and succeded.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-indent-item-tree): When outdenting a subtree,
+ the last item shouldn't have a children.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-cycle-item-indentation): Cycling should play
+ nicely with indent rule in `org-list-automatic-rules'.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-indent-item-tree): If indent rule is activated,
+ it should be impossible to outdent an item having children without
+ moving its subtree. Improved reordering of lists modified by
+ cycling indentation.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-maybe-renumber-ordered-list): Removed call for
+ `org-fix-bullet-type' to prevent infinite loop, and some checks
+ already done in `org-renumber-ordered-list'.
+
+ * org-list.el (org-fix-bullet-type): Remove a check and call
+ directly `org-maybe-renumber-ordered-list'.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-indent-item-tree): It shouldn't be possible to
+ indent the first item of a sublist (though outdent is possible) as
+ it would break list's structure.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-insert-item-generic): When local search
+ doesn't help, search the list globally for blank lines. Moreover,
+ don't bother with new lists, and add 1 blank line.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-capture.el (org-capture-place-item): Use
+ `org-search-forward-unenclosed' and
+ `org-search-backward-unenclosed' and new variable
+ `org-item-beginning-re'.
+
+ * org-list.el (org-item-beginning-re): Regexp matching beginning
+ of an item.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-cycle-list-bullet): Put back support for
+ 'previous argument.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-in-item-p): Handle case when point is at an
+ heading.
+
+ * org-list.el (org-list-make-subtree): Add protection when used
+ outside of list
+
+ * org-list.el (org-insert-item): Removed useless hack now
+ `org-in-item-p' is fixed.
+
+ * org-timer.el (org-timer-item): Removed useless hack now
+ `org-in-item-p' is fixed.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-cycle-list-bullet): Prevent description items
+ from being numbered. String argument is also recognized now, as
+ long as it is a valid bullet.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-indent-item-tree): Moving indentation of top
+ list item will make the whole list move.
+
+ * org-list.el (org-apply-on-list): Function is less sensitive to
+ changes of indentation.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-at-item-checkbox-p): Add whitespaces at the end
+ of the regexp.
+
+ * org-list.el (org-checkbox-blocked-p): Use new checkbox regexp.
+
+ * org-list.el (org-cycle-item-indentation): Allow cycling
+ description items and checkbox items.
+
+ * org-list.el (org-toggle-checkbox): Use new checkbox regexp.
+
+ * org-list.el (org-reset-checkbox-state-subtree): Use new checkbox
+ regexp.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-insert-item-internal): Guessing of blank lines
+ number is made by looking at neighbours items, if any.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-sort-list): Add the possibility to sort timer
+ lists with the ?t or ?T options.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-search-unenclosed-internal): New function to
+ handle both `org-search-forward-unenclosed' and
+ `org-search-backward-unenclosed'.
+
+ * org-list.el (org-search-backward-unenclosed): Can send errors
+ now. Removed useless usage of COUNT.
+
+ * org-list.el (org-search-forward-unenclosed): Can send errors
+ now. Removed useless usage of COUNT.
+
+ * org-list.el (org-update-checkbox-count): Use
+ `org-search-forward-unenclosed' and
+ `org-search-backward-unenclosed' instead of `re-search-forward'
+ and `re-search-backward'.
+
+ * org-list.el (org-sort-list): Use `org-search-forward-unenclosed'
+ and `org-search-backward-unenclosed' instead of
+ `re-search-forward' and `re-search-backward'.
+
+ * org-list.el (org-list-make-subtree): Use
+ `org-search-forward-unenclosed' and
+ `org-search-backward-unenclosed' instead of `re-search-forward'
+ and `re-search-backward'.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-insert-item-internal): Fixes the problem when
+ point was before the first char of the item's body.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-timer.el (org-timer-item): Refactoring. Compute timer string
+ before inserting it in the buffer
+
+ * org-timer.el (org-timer): Added an optional argument to return
+ timer string instead of inserting it.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-insert-item-internal): New function to handle
+ positionning and contents of an item being inserted at a specific
+ pos. It is not possible anymore to split a term in a description
+ list or a checkbox when inserting a new item.
+
+ * org-list.el (org-insert-item): Refactored by using the new
+ `org-insert-item-internal' function.
+
+ * org-timer.el (org-timer-item): Refactored by using the new
+ `org-insert-item-internal' function.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-bottom-point): Be sure to check real
+ ORG-OUTLINE-REGEXP and not outline-regexp, that might be modified.
+
+ * org.el (org-cycle-internal-local): Cycle up to end of subtree or
+ end of item if we are in a list.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-insert-item): Move before any special block in
+ a list prior to add a new item.
+
+ * org-timer.el (org-timer-item): When in a timer list, insert a
+ new timer item like `org-insert-item'. If in another list, send an
+ error. Otherwise, start a new timer list.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el: Minor refactoring.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-timer.el (org-timer-item): Insert description list item at
+ the right column.
+
+ * org-list.el (org-insert-item): Insert the right number of blank
+ lines before a relative timer.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-insert-item): Remove restriction on latex
+ blocks.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-search-backward-unenclosed): Do not stop in
+ protected places.
+
+ * org-list.el (org-search-forward-unenclosed): Do not stop in
+ protected places.
+
+ * org-latex.el (org-export-latex-lists): Use the fact that
+ org-search-forward do not stop anymore at protected places.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-search-backward-unenclosed): Do not prevent
+ list items from being inside LaTeX blocks.
+
+ * org-list.el (org-search-forward-unenclosed): Do not prevent list
+ items from being inside LaTeX blocks.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-in-item-p): Do not widen before checking if we
+ are in item.
+
+ * org-list.el (org-list-send-list): We cannot count on
+ `org-list-top-point' and `org-list-bottom-point' before buffer is
+ narrowed. Find bounds of list otherwise.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-end-regexp): By default, list ending is
+ exactly 2 blank lines.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-docbook.el (org-export-as-docbook): When we find an empty
+ line, we do not need to check for
+ `org-empty-line-terminates-plain-lists' because we would have
+ found end-list marker before.
+
+ * org-html.el (org-export-as-html): Same.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-insert-item): Simplify count of blank lines to
+ insert.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-end-regexp): New customizable variable to
+ define what string should end lists.
+
+ * org-list.el (org-list-end-re): Function is now aware of
+ `org-list-end-regexp'.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-html.el (org-export-as-html): Code cleanup.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-docbook.el (org-export-as-docbook): Properly close any open
+ list when seeing ORG-LIST-END. Removed any reference to now
+ unneeded DIDCLOSE variable.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-exp.el (org-export-mark-list-ending): Fix number of blank
+ lines inserted after a list.
+
+ * org-list.el (org-list-parse-list): Fix case when
+ `org-list-end-re' would have an indentation greater than current
+ list.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-exp.el (org-export-mark-list-ending): Differentiate between
+ export backends, and replace `org-list-end-re' by a blank line
+ upon exporting.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-html.el (org-export-as-html): Delete didclose and everything
+ related to it, as it is no longer needed.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-html.el (org-export-html-preprocess): Remove unneeded
+ insertion of list end marker, as it is now handled by
+ `org-export-mark-list-ending'.
+
+ * org-html.el (org-export-as-html): Cleaner termination of lists.
+
+ * org-exp.el (org-export-mark-list-ending): New function to insert
+ specific markers at the end of lists when exporting to a backend
+ not using `org-list-parse-list'. This function is called early in
+ `org-export-preprocess-string', while it is still able to
+ recognize lists.
+
+ * org-latex.el (org-export-latex-lists): Better search for
+ lists. It now only finds items not enclosed and not protected.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el: Replaced `re-search-forward' by
+ `org-search-forward-unenclosed' where it made sense.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-apply-to-list): Now a return value is handed at
+ each new call of the function applied.
+
+ * org-list.el (org-fix-bullet-type): Use the new
+ `org-apply-to-list' format.
+
+ * org-list.el (org-renumber-ordered-list): Use the new
+ `org-apply-to-list' format.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org.el (org-in-regexps-block-p): Minor fix: limit wasn't
+ correctly used.
+
+ * org-list.el (org-search-forward-unenclosed): Better regexp used.
+
+ * org-list.el (org-search-backward-unenclosed): Better regexp
+ used.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-sort-list): End-rec function was ill-defined.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-search-forward-unenclosed): Fix behavior when
+ last occurence was enclosed.
+
+ * org-list.el (org-search-backward-unenclosed): Fix behavior when
+ last occurence was enclosed.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org.el (org-in-regexps-block-p): Fix documentation.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-search-backward-unenclosed): Fix block regexp.
+
+ * org-list.el (org-search-forward-unenclosed): Fix block regexp.
+
+ * org-list.el (org-list-parse-list): Minor fix.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-parse-list): Delete `org-list-end-re' when
+ called with t argument.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-html.el (org-export-html-preprocess): Replace
+ `org-list-end-re' by a blank line during pre-process.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-bottom-point): No need for square brackets
+ for `skip-chars-backward'.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-html.el: Do not delete space between end of list and
+ beginning of the following.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-html.el: preprocess buffer string and add ORG-LIST-END where
+ needed. Lists should not end before seeing this.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-html.el: Notice end of lists.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-parse-list): Better handling of
+ restrictions when function is called on a list with sublists.
+
+ * org-list.el (org-list-send-list): Find the true ending of the
+ list being sent.
+
+ * org-list.el (org-list-radio-list-templates): Templates are more
+ specific to lists.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-js.el (org-babel-js-eoe): Indicate end of input
+ (org-babel-execute:js): Support for session evaluation
+ (org-babel-prep-session:js): Fleshed out definition
+ (org-babel-js-initiate-session): Can initiate a session using
+ mozrepl.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org.el (org-set-regexps-and-options): Protect escape char in
+ `org-complex-heading-regexp-format'.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-scheme.el (org-babel-scheme-eoe): For marking the end of
+ session-based evaluation
+ (org-babel-execute:scheme): Now supports session-based evaluation
+ (org-babel-prep-session:scheme): Now works and defines variables
+ (org-babel-scheme-initiate-session): Now works using run-scheme
+ from cmuscheme.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-export-latex-default-packages-alist): Remove the
+ t1enc package - this is already covered by fontenc.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (with-parsed-tramp-file-name): Declared
+ (org-babel-tramp-localname): Ensure variable name exists locally.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-temp-file): Don't use babel temporary directory
+ in remote case; use make-temp-file with remote file name so that
+ temp file is guaranteed not to exist previously on remote machine.
+ (org-babel-tramp-localname): New function to return local name
+ portion of possibly remote file specification.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-R.el (org-babel-R-write-object-command): New unified R
+ command for writing results to file
+ (org-babel-R-wrapper-method): Remove variable
+ (org-babel-R-wrapper-lastvar): Remove variable
+ (org-babel-R-evaluate-external-process): Use new R command
+ (org-babel-R-evaluate-session): Use new R command.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-comint.el
+ (org-babel-comint-eval-invisibly-and-wait-for-file): New function
+ to evaluate code invisibly and block until output file exists.
+
+ * ob-R.el (org-babel-R-evaluate-session): Use `ess-eval-buffer' to
+ evaluate R code in session for :results value. Write result to
+ file invisibly using new function
+ `org-babel-comint-eval-invisibly-and-wait-for-file'.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-capture.el (org-capture-fill-template): Align tags after
+ insertion.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-exp.el (org-export-concatenate-multiline-emphasis): Ignore
+ matches that start in a headline.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-plantuml.el (org-babel-execute:plantuml): Wrapping in-file
+ and out-file in shell-quote-argument.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-docview.el (org-docview-store-link): Use expanded macro to
+ get current page.
+ (doc-view-goto-page, image-mode-window-get): Declare functions for
+ byte compiler.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-scheme.el: very preliminary support for evaluating scheme
+ code blocks
+
+ * org.el (org-babel-load-languages): Adding scheme.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (require): Remove circular (require 'org).
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-R.el (ess-make-buffer-current): Declared
+ (ess-ask-for-ess-directory): Declared
+ (ess-local-process-name): Declared
+
+ * ob-latex.el (org-babel-latex-tex-to-pdf): Capturing free
+ variable
+
+ * ob.el (org-edit-src-code): Fixing arguments
+ (org-edit-src-exit): Declared
+ (org-outline-overlay-data): Declared
+ (org-set-outline-overlay-data): Declared.
+
+2010-11-11 Glenn Morris <rgm@gnu.org>
+
+ * ob.el: Require org when compiling.
+ (org-save-outline-visibility): Remove macro declaration.
+
+ * ob-emacs-lisp.el: Require ob-comint when compiling, for macros.
+ Remove unnecessary/macro declarations.
+
+ * org-docview.el: Require doc-view when compiling.
+ (doc-view-goto-page): Autoload rather than declaring.
+ (doc-view-current-page): Remove macro declaration.
+
+ * ob.el (tramp-compat-make-temp-file, org-edit-src-code)
+ (org-entry-get, org-table-import): Fix declarations.
+ (org-match-string-no-properties): Remove declaration.
+
+ * ob-sh.el (org-babel-comint-in-buffer)
+ (org-babel-comint-wait-for-output, org-babel-comint-buffer-livep)
+ (org-babel-comint-with-output): Remove unnecessary declarations.
+
+ * ob-R.el (orgtbl-to-tsv): Fix declaration.
+
+ * org-list.el (org-entry-get): Fix declaration.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-remove-temporary-directory): Removed explicit
+ second argument.
+
+2010-11-11 Magnus Henoch <magnus.henoch@gmail.com> (tiny change)
+
+ * org-clock.el (org-clocktable-steps): Allow ts and te to be day
+ numbers.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * org-macs.el (org-save-outline-visibility): Moved from org.el.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-org.el (org-babel-default-header-args:org): Additional
+ ":results silent" default header argument for org code blocks.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-exp.el (org-babel-exp-do-export): Remove hacky ":noeval",
+ which is now an alias to ":eval no"
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-remove-temporary-directory): The version of
+ `delete-directory' found in files.el can not be assumed to be
+ present on all versions, so this copies the recursive behavior of
+ that command in such a way that all calls to delete-directory will
+ also work with the built-in internal C implementation of that
+ function. This is not overly difficult as all elements of the
+ directory can be assumed to be files.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-C.el (org-babel-C-execute): Corrected arguments to
+ org-babel-temp-file.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-temporary-directory): Variable to hold the
+ value of the Babel temporary directory.
+
+2010-11-11 Aditya Siram <aditya.siram@gmail.com>
+
+ * ob.el (org-babel-load-in-session): Expanding noweb references
+ when appropriate.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org.el (org-make-link-regexps): Modified regexp of
+ org-plain-link-re.
+
+2010-11-11 Noorul Islam <noorul@noorul.com> (tiny change)
+
+ * org-habit.el (org-habit-parse-todo): Find sr-days only if
+ scheduled-repeat is non nil. Use 4th element of the list returned
+ by (org-heading-components) as habit-entry. Modify the error
+ message to be more meaningful.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-latex.el (org-babel-execute:latex): Adding new ":fit" and
+ ":border" header arguments which both use the "preview" latex
+ package to fit the resulting pdf image to the figure.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-wl.el (org-wl-store-link): Don't try to store link if point
+ is at end of buffer.
+
+2010-11-11 Harri Kiiskinen <harkiisk@gmail.com>
+
+ * org-publish.el (org-publish-project-alist): Document the new
+ body-only property.
+ (org-publish-org-to): Use the body-only property.
+
+2010-11-11 Jambunathan K <kjambunathan@gmail.com> (tiny change)
+
+ * org.el (org-store-link): Return link when invoked
+ non-interactively from an agenda buffer.
+
+2010-11-11 Jambunathan K <kjambunathan@gmail.com> (tiny change)
+
+ * org.el (org-store-link): Storing of links to headlines in
+ indirect buffers was broken. Fix it.
+
+2010-11-11 Aidan Kehoe <kehoea@parhasard.net>
+
+ * ob-tangle.el (org-babel-tangle): Change the MODE argument to
+ #'set-file-modes to use integer, not character syntax, avoiding
+ compile problems with recent XEmacs.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-agenda-add-entry-text): Make sure we move
+ forward even if there is no text to be added.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-make-tags-matcher): Read "\\-" as "-" in the
+ tags/property matcher.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-exp.el (org-infile-export-plist): Bind case-fold-search to
+ t.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-agenda-with-point-at-orig-entry): New macro.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-export-latex-set-initial-vars): Bind
+ `case-fold-search' to t around the search for special LaTeX setup.
+
+ * org-beamer.el (org-beamer-after-initial-vars): Bind
+ `case-fold-search' to t around the search for special BEAMER
+ setup.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-agenda.el (org-write-agenda): Delete postscript file after
+ creating conversion to pdf.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-agenda.el (org-write-agenda): Move require statements to
+ proper place in evaluated lisp expression.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-agenda.el (org-write-agenda): Rename temporary buffer to
+ remove dependency of `flet' macro.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-lob.el (org-babel-lob-get-info): Edit docstring.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-exp.el (org-babel-exp-lob-one-liners): Get parameter values
+ from all standard sources when executing #+lob/#+call lines.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-R.el (org-babel-R-evaluate): Break the two branches into two
+ separate functions
+ (org-babel-R-evaluate-external-process): New function to handle
+ external process evaluation
+ (org-babel-R-evaluate-session): New function to handle session
+ evaluation.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-initiate-session): New function derived from
+ previous `org-babel-switch-to-session'
+ (org-babel-switch-to-session): Refactored to use new
+ `org-babel-initiate-session'.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-switch-to-session): Supply missing "P" argument
+ to (interactive).
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-feed.el (org-feed-format-entry): Decode entry according to
+ its character encoding.
+
+2010-11-11 David Maus <dmaus@ictsoc.de> (tiny change)
+
+ * org-feed.el (xml-substitute-special): Declare function for byte
+ compiler.
+ (org-feed-unescape): Removed.
+ (org-feed-parse-rss-entry, org-feed-parse-atom-entry): Use
+ `xml-substitute-special' to unescape XML entities.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-switch-to-session): Throw error if block if
+ :session not in effect for the block.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-table.el (org-table-create-with-table.el): Align table
+ before converting.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-do-in-edit-buffer): Suppress message and check
+ that org-src buffer is current before attempting exit.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * org-src.el (ob-comint): Require 'ob-comint
+ (org-src-babel-info): Define variable.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-do-in-edit-buffer): New macro to evaluate lisp
+ in the language major mode edit buffer.
+ (org-babel-do-key-sequence-in-edit-buffer): New function to call
+ an arbitrary key sequence in the language major mode edit buffer
+
+ * org-src.el (org-src-switch-to-buffer): Add new allowed value
+ 'switch-invisibly for `org-src-window-setup'.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * org-src.el (ob-keys): Require ob-keys, because `org-babel-map'
+ is used.
+ (org-src-do-at-code-block): New macro to evaluate lisp with point
+ at the start of the Org code block containing the code in this
+ edit buffer.
+ (org-src-do-key-sequence-at-code-block): New function to execute
+ command bound to key at the Org code block containing the code in
+ this edit buffer.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-R.el (org-babel-R-associate-session): New function to
+ associate R code edit buffers with ESS comint session.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * org-src.el (org-edit-src-code): If at src block, store babel
+ info as buffer local variable.
+ (org-src-associate-babel-session): New function to associate code
+ edit buffer with comint session. Does nothing unless a
+ language-specific function named
+ `org-babel-LANG-associate-session' exists.
+ (org-src-babel-configure-edit-buffer): New function to be called
+ in `org-src-mode-hook'.
+ (org-src-mode-hook): Add `org-src-babel-configure-edit-buffer' to
+ hook.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-switch-to-session-with-code): New function to
+ generate split frame displaying edit buffer and session.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-set-tags): Consider org-indent-mode when computing
+ the tags column.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-compat.el (org-looking-at-p): Only use looking-at-p when
+ defined.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-agenda.el (org-finalize-agenda-entries): Delete excluded
+ lines directly after call to sorting filter function.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-complex-heading-regexp-format): Document the
+ variable.
+ (org-get-refile-targets): Use `org-complex-heading-regexp-format'
+ to make the regular expression for matching the headline.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-refile-check-position): New function.
+ (org-goto):
+ (org-refile-get-location): Call `org-refile-check-position'.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-python.el (org-babel-python-initiate-session-by-key): Use eq
+ instead of equal to compare symbols.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-agenda-before-sorting-filter-function): New
+ hook function.
+ (org-finalize-agenda-entries): Apply
+ `org-agenda-before-sorting-filter-function'.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-export-latex-first-lines): Do not protect meta
+ lines that have nothing to do with babel.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-capture.el (org-capture-place-template): Handle the
+ checkitem case.
+ (org-capture-place-item): Provide boundaries for the search to
+ make sure we do not get a match in a different tree.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-exp.el (org-export-preprocess-apply-macros): Fix the macro
+ argument parser.
+
+2010-11-11 Noorul Islam <noorul@noorul.com>
+
+ * org-latex.el (org-latex-to-pdf-process): Add output-directory
+ option for the command pdflatex.
+ (org-export-as-pdf): Respect directory in path of
+ EXPORT_FILE_NAME.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-exp.el (org-export-with-LaTeX-fragments): New default t,
+ which now means to use MathJax processing for HTML. Also allow
+ new value `dvipng' to force the old image processing.
+ (org-infile-export-plist): Parse for MATHJAX setup line.
+
+ * org-html.el (org-export-html-mathjax-options): New option.
+ (org-export-html-mathjax-config): New function.
+ (org-export-html-mathjax-template): New option.
+ (org-export-html-preprocess): Call the LaTeX snippet processor
+ with an additional argument to declare special ways of processing.
+ (org-export-as-html): Bind the dynamical variable
+ `org-export-have-math'. Insert the MathJax script template when
+ it is needed by the document.
+
+ * org.el (org-preview-latex-fragment): Call `org-format-latex'
+ with the additional processing argument.
+ (org-export-have-math): New variable, for dynamic scoping.
+ (org-format-latex): Implement specific ways of processing. New
+ function argument for processing type.
+ (org-org-menu): Remove the entry to configure LaTeX snippet
+ processing.
+
+2010-11-11 Bastien Guerry <bzg@altern.org>
+
+ * org-agenda.el (org-agenda-clock-goto): Use `\C-c\C-x\C-j' for
+ `org-clock-goto' and `J' for `org-agenda-clock-goto'. If the
+ heading currently clocked in is not listed in the agenda, display
+ this entry in another buffer. If there is no running clock,
+ display a help message.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-latex.el (org-export-latex-tables): Return "" instead of nil
+ when no label is attached.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-agenda-menu-show-match): New option.
+ (org-agenda-menu-two-column): New option.
+ (org-agenda-get-restriction-and-command): Implement dispatch menu
+ without showing the matcher, and with two-column display.
+
+2010-11-11 Bernt Hansen <bernt@norang.ca>
+
+ * org-indent.el (org-indent-mode): Fix grammar for message when
+ mode is refused.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-insert-result): Ensures `beg' is set, even if
+ no previous result exists.
+
+2010-11-11 Noorul Islam <noorul@noorul.com>
+
+ * ob.el Declare org-babel-lob-execute-maybe() to avoid compiler
+ warning.
+
+2010-11-11 Noorul Islam <noorul@noorul.com>
+
+ * org.el: org-set-visibility-according-to-property () Use backward
+ search instead of forward, so that top hierarchy gets priority.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-timeline): Allow indirect buffer.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-exp.el (org-export-preprocess-after-radio-targets-hook):
+ (org-export-define-heading-targets-headline-hook): New hooks.
+
+ * org.el (org-modules): Add entry for org-wikinodes.el.
+ (org-font-lock-set-keywords-hook): New hook.
+ (org-open-at-point-functions): New hook.
+ (org-find-exact-headling-in-buffer):
+ (org-find-exact-heading-in-directory): New functions.
+ (org-mode-flyspell-verify): Better cursor position for checking if
+ flyspell should ignore a word.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-indent.el (org-indent-remove-properties):
+ (org-indent-add-properties): Make sure changing these properties
+ does not trigger modification hooks.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-link-search-must-match-exact-headline): New option.
+ (org-link-search-inhibit-query): New variable.
+ (org-link-search): Search for exact headline match in Org files.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-execute-src-block-maybe): Remove check for
+ `org-babel-no-eval-on-ctrl-c-ctrl-c'; this is done in the new
+ function `org-babel-execute-safely-maybe'.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-load-in-session): Set directory in case :dir
+ arg is in effect.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-tangle.el (org-babel-tangle-collect-blocks): Don't throw
+ errors when we're not under of a headline.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-octave.el (org-babel-octave-wrapper-method): Use dlmwrite to
+ write delimited text instead of save -ascii
+ (org-babel-octave-import-elisp-from-file): Specify that data
+ written to file is tab-delimited.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-R.el (org-babel-R-evaluate): Specify that tabular data is
+ tab-delimited.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob.el (org-babel-import-elisp-from-file): Allow separator to be
+ specified.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-python.el (org-babel-python-table-or-string): Fix recognition
+ of lists and tuples.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-octave.el (org-babel-octave-evaluate-external-process): Allow
+ remote files.
+
+2010-11-11 Juan Pechiar <pechiar@computer.org>
+
+ * ob-octave.el (org-babel-octave-evaluate-external-process): Use
+ `org-babel-octave-import-elisp-from-file' instead of
+ `org-babel-eval-read-file'.
+ (org-babel-octave-var-to-octave): Separate matrix rows with ';',
+ and use '%s' as format specifier instead of '%S'.
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-octave.el: Only (require 'matlab) when necessary.
+ (org-babel-octave-initiate-session) (require) octave-inf or matlab
+ as appropriate.
+ (org-babel-execute:matlab): Remove (require).
+ (org-babel-prep-session:matlab): Remove (require).
+ (org-babel-matlab-initiate-session): Remove (require).
+
+2010-11-11 Dan Davison <davison@stats.ox.ac.uk>
+
+ * ob-octave.el (org-babel-octave-evaluate): Fix formal argument
+ list.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-python.el (org-babel-python-table-or-string): Can now handle
+ VERY long result lines.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-latex.el (org-export-latex-tables): Add label if any
+
+ * org-latex.el (org-export-latex-convert-table.el-table): Fix
+ little mistake when inserting label.
+
+2010-11-11 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org.el (org-cycle-internal-local): Removed an unnecessary call
+ to `org-back-to-heading' that was preventing point to stay at its
+ column when cycling visibility.
+
+2010-11-11 Noorul Islam <noorul@noorul.com>
+
+ * org-capture.el (org-capture-finalize): Make messages consistent.
+
+2010-11-11 Noorul Islam <noorul@noorul.com>
+
+ * org-gnus.el: Suppress compiler warning by declaring outside
+ function nnimap-retrieve-headers-from-file.
+
+2010-11-11 Noorul Islam <noorul@noorul.com>
+
+ * org-colview.el Use org-beamer-select-environment instead of
+ org-beamer-set-environment-tag.
+
+2010-11-11 Matt Lundin <mdl@imapmail.org>
+
+ * org.el (org-insert-time-stamp): Fix org-insert-time-stamp so
+ that the value of org-last-inserted-timestamp includes time range.
+
+2010-11-11 David Maus <dmaus@ictsoc.de>
+
+ * org-wl.el (org-wl-store-link-message): Provide link property for
+ message-id without angle brackets.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-R.el (org-babel-R-evaluate): Improved prompt-stripping regexp.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-tangle.el (org-babel-find-file-noselect-refresh): Finds a
+ file ensuing that the latest changes on disk are represented.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-sqlite.el (org-babel-sqlite-expand-vars): Now inserts string
+ arguments w/o quotes.
+
+2010-11-11 Bernt Hansen <bernt@norang.ca>
+
+ * org-capture.el (org-capture-finalize): Fix clock in of
+ interrupted task during capture finalize.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-R.el (org-babel-R-evaluate): Clean up extra prompts in
+ session output.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-C.el (org-babel-C-ensure-main-wrap): More generous regular
+ expression for matching main function.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-lob.el (org-babel-lob-one-liner-regexp): Fixed error in lob
+ regexp -- it wasn't matching lob lines w/o indices.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * org-exp.el (org-export-latex-listings-w-names): Fix compiler
+ warning in org-exp.el.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-publish.el (org-publish-file): Better error message if
+ base-directory or publishing-directory are not defined.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-colview.el (org-columns-display-here): Use overlays to
+ overrule line prefix properties during column view.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-agenda-filter-preset): Document the
+ limitation for the filter preset - it can only be used for an
+ entire agenda view, not in an individual block in a block agenda.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-table.el (sbe): Now able to accept range references from
+ tables.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob.el (org-babel-pick-name): If colnames or rownames contain a
+ list of names, then use those directly.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * org-exp.el (org-export-format-source-code-or-example): Escape
+ underscores in code block names on latex listings export.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-tangle.el (org-babel-with-temp-filebuffer): Use
+ find-file-noselect to avoid excess buffer movement.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-html.el (org-html-should-inline-p): Only inline images if
+ they should be.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-id.el (org-id-store-link): Autoload.
+
+ * org.el ("org-id"): Autoload `org-id-store-link'.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-html.el (org-html-should-inline-p): Only inline images if
+ they should be.
+
+2010-11-11 Eric S Fraga <e.fraga@ucl.ac.uk>
+
+ * org-icalendar.el (org-icalendar-alarm-time): New option.
+
+ * org-icalendar.el (org-print-icalendar-entries): Timed events are
+ exported with alarm events, a.k.a. reminders.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-capture.el (org-capture-target-buffer): Throw an error if we
+ have no target file.
+ (org-capture-select-template): Use a default template if the user
+ has not specified any.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-modules): Add entry for org-velocity.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-lob.el (org-babel-lob-execute): Changing indentation to
+ improve line length.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-exp.el (org-export-handle-table-metalines): Choose a better
+ position for checking protectedness.
+
+2010-11-11 Eric Schulte <schulte.eric@gmail.com>
+
+ * org-table.el (org-table-convert-region): Don't continue csv
+ importation which the point catches the end, this fixes an
+ infinite loop which was caused by the (point) never catching up
+ with the "end" marker.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-macs.el (org-string-nw-p): New function.
+
+ * org-capture.el (org-capture-import-remember-templates):
+ Interpret an empty string as request to use
+ `org-default-notes-file'.
+ (org-capture-target-buffer): If the FILE is not a (non-empty)
+ string, use `org-default-notes-file'.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-capture.el (org-capture-templates): Fix customize type.
+
+2010-11-11 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-colview-xemacs.el (org-columns-compile-map):
+ (org-columns-number-to-string):
+ (org-columns-string-to-number): Handle estimate ranges.
+ (org-estimate-mean-and-var): New function.
+ (org-estimate-combine): New function.
+ (org-estimate-print): New function.
+ (org-string-to-estimate): New function.
+
+2010-09-25 Juanma Barranquero <lekktu@gmail.com>
+
+ * org.el (org-refile-targets):
+ * org-agenda.el (org-agenda-hide-tags-regexp): Fix typos in docstrings.
+
+2010-08-19 Glenn Morris <rgm@gnu.org>
+
+ * org.el (org-outline-overlay-data, org-set-outline-overlay-data)
+ (org-save-outline-visibility): Move to org-macs.
+ * org-macs.el (org-outline-overlay-data, org-set-outline-overlay-data)
+ (org-save-outline-visibility): Move here from org.el.
+ (show-all): Autoload it.
+ * ob.el: Don't require org when compiling.
+
+2010-08-18 Glenn Morris <rgm@gnu.org>
+
+ * ob.el: Require org when compiling.
+ (org-save-outline-visibility): Remove macro declaration.
+ * ob-emacs-lisp.el: Require ob-comint when compiling, for macros.
+ Remove unnecessary/macro declarations.
+ * org-docview.el: Require doc-view when compiling.
+ (doc-view-goto-page): Autoload rather than declaring.
+ (doc-view-current-page): Remove macro declaration.
+
+2010-08-17 Glenn Morris <rgm@gnu.org>
+
+ * ob.el (tramp-compat-make-temp-file, org-edit-src-code)
+ (org-entry-get, org-table-import): Fix declarations.
+ (org-match-string-no-properties): Remove unnecessary declaration.
+ * ob-sh.el (org-babel-comint-in-buffer)
+ (org-babel-comint-wait-for-output, org-babel-comint-buffer-livep)
+ (org-babel-comint-with-output): Remove unnecessary declarations.
+ * ob-R.el (orgtbl-to-tsv): Fix declaration.
+ * org-list.el (org-entry-get): Fix declaration.
+
+2010-07-19 Eric Schulte <schulte.eric@gmail.com>
+
+ * ob-C.el: New file.
+ * ob-R.el: New file.
+ * ob-asymptote.el: New file.
+ * ob-clojure.el: New file.
+ * ob-comint.el: New file.
+ * ob-css.el: New file.
+ * ob-ditaa.el: New file.
+ * ob-dot.el: New file.
+ * ob-emacs-lisp.el: New file.
+ * ob-eval.el: New file.
+ * ob-exp.el: New file.
+ * ob-gnuplot.el: New file.
+ * ob-haskell.el: New file.
+ * ob-keys.el: New file.
+ * ob-latex.el: New file.
+ * ob-lob.el: New file.
+ * ob-matlab.el: New file.
+ * ob-mscgen.el: New file.
+ * ob-ocaml.el: New file.
+ * ob-octave.el: New file.
+ * ob-perl.el: New file.
+ * ob-python.el: New file.
+ * ob-ref.el: New file.
+ * ob-ruby.el: New file.
+ * ob-sass.el: New file.
+ * ob-screen.el: New file.
+ * ob-sh.el: New file.
+ * ob-sql.el: New file.
+ * ob-sqlite.el: New file.
+ * ob-table.el: New file.
+ * ob-tangle.el: New file.
+ * ob.el: New file.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-mks.el: New file.
+ * org-capture.el: New file.
+
+2010-07-19 Christian Egli <christian.egli@sbszh.ch>
+
+ * org-taskjuggler.el: New file.
+
+2010-07-19 Matt Lundin <mdl@imapmail.org>
+
+ * org-agenda.el (org-search-view): Fix inclusion of agenda-archives
+ in org-agenda-text-search-extra-files.
+
+2010-07-19 David Maus <dmaus@ictsoc.de>
+
+ * org-list.el (org-list-send-list): Locally bind variable `txt'.
+
+2010-07-19 Eric Schulte <schulte.eric@gmail.com>
+
+ * org.el (org-reload): Now also reloading babel files.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-capture.el (org-capture-set-plist): Make sure txt is a string
+ before calling `string-match'.
+ (org-capture-templates): Fix customization type.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-export-latex-preprocess): Make a special case
+ for \nbsp.
+ (org-latex-entities): Remove the entry for \nbsp.
+ (org-latex-entities-exceptions): Variable removed.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-capture.el (org-capture-refile): Do not try to manipulate
+ bookmark list.
+
+ * org.el (org-refile): Use the correct bookmark here.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-list.el (org-list-send-list): Parse list from its true beginning.
+
+ * org.el (org-ctrl-c-ctrl-c): Maybe send the list when at a list item.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-insert-link): Correctly determine if we should use
+ a relative path.
+
+2010-07-19 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-radio-list-templates): Fix templates.
+
+2010-07-19 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-list.el (org-list-send-list): Regexp defining the start of
+ a radio list is now on par with the one used for radio tables.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-entities.el (org-entities-help): Add a headline for
+ the user-defined entities.
+
+2010-07-19 Dirk-Jan C. Binnema <djcb.bulk@gmail.com> (tiny change)
+
+ * org-agenda.el (org-agenda-action): Document capture key and add it
+ to the prompt.
+
+2010-07-19 Eric Schulte <schulte.eric@gmail.com>
+
+ * org-latex.el (org-export-latex-listings-langs): Add (sqlite "SQL").
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-export-latex-first-lines): Do not mark
+ meta lines for removal. Do not remove BABEL config lines during export.
+
+2010-07-19 David Maus <dmaus@ictsoc.de>
+
+ * org-capture.el (org-capture): Check if
+ `org-capture-link-is-already-stored' is bound before evaluating.
+
+2010-07-19 Eric Schulte <schulte.eric@gmail.com>
+
+ * org.el: Add autoload for org-babel-do-load-languages.
+
+2010-07-19 Eric Schulte <schulte.eric@gmail.com>
+
+ * org-src.el (org-src-lang-modes): Add sqlite to sql-mode.
+
+2010-07-19 David Maus <dmaus@ictsoc.de>
+
+ * org-feed.el: Change indentation to match coding style
+ guideline.
+
+2010-07-19 David Maus <dmaus@ictsoc.de>
+
+ * org-feed.el (org-feed-unescape, org-feed-parse-atom-feed): Load XML
+ library if necessary.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-beamer.el (org-beamer-amend-header): Standardize the
+ header cookie for the beamer extra stuff.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-beamer.el (org-beamer-amend-header): Put extra header
+ last in header.
+
+2010-07-19 David Maus <dmaus@ictsoc.de>
+
+ * org-exp-blocks.el (org-export-blocks-format-ditaa)
+ (org-export-blocks-format-dot): Remove text properties of body before
+ calculating cache hash.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-export-latex-tabular-environment): New option.
+ (org-export-latex-tables): Use `org-export-latex-tabular-environment'.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-compat.el (org-version-check): New function.
+
+ * org-indent.el (org-indent-mode): Check for exact emacs version.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-capture.el (org-capture-templates): Allow the template
+ to come from a file or function call.
+ (org-capture-place-entry): Get the template from file or function.
+
+2010-07-19 David Maus <dmaus@ictsoc.de>
+
+ * org-agenda.el (org-agenda-bulk-action): Don't create marker for
+ position if target is entire file.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-autoload): Autoload a few more org-table functions.
+
+2010-07-19 Eric Schulte <schulte.eric@gmail.com>
+
+ * org.el (org-babel-load-languages): Add ob-mscgen.
+
+2010-07-19 Eric Schulte <schulte.eric@gmail.com>
+
+ * org-latex.el (org-export-latex-tables): Format string now
+ matches options.
+
+2010-07-19 Eric Schulte <schulte.eric@gmail.com>
+
+ * org.el (org-babel-load-languages): This variable controls which
+ languages will be loaded by org-babel. It is customizable through
+ the customize interface.
+
+2010-07-19 Eric Schulte <schulte.eric@gmail.com>
+
+ * org-latex.el (org-export-latex-format-image): Update number of
+ arguments to allow for an optional short-name.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-indent.el (org-indent-mode): Refuse to turn on prior to Emacs 23.2.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-capture.el (org-capture-set-target-location): Store
+ exact positions for file+regexp and file+function targets.
+ (org-capture-place-entry, org-capture-place-item)
+ (org-capture-place-table-line, org-capture-place-plain-text): Respect
+ exact positions.
+ (org-capture-finalize): Make sure we are at the beginning of a line
+ when fixing the empty lines after the entry.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-entry-get-with-inheritance): New argument LITERAL-NIL.
+ (org-entry-get): Pass `literal-nil' into
+ `org-entry-get-with-inheritance'.
+ (org-todo): React to nil values of the LOGGING property.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-default-notes-file): Update docstring.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-link-frame-setup): Use `org-gnus-no-new-news' as default.
+
+2010-07-19 Eric Schulte <schulte.eric@gmail.com>
+
+ * org-exp.el (org-export-attach-captions-and-attributes): Add
+ a shortname attribute to caption strings under the symbol name
+ org-caption-shortn.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-switchb): Rename from `org-iswitchb'. Improve
+ docstring.
+ (org-iswitchb): New alias.
+ (org-ido-switchb): Make alias point to `org-switchb'.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-capture.el (org-capture-fill-template): Respect
+ time-of-day preference in template prompt.
+
+2010-07-19 David Maus <dmaus@ictsoc.de>
+
+ * org-feed.el (org-feed-unescape): Remove superfluous lambda.
+
+2010-07-19 David Maus <dmaus@ictsoc.de>
+
+ * org-wl.el (org-wl-disable-folder-check): New customization
+ variable.
+ (org-wl-open): Disable folder check depending on
+ `org-wl-disable-folder-check'.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-capture.el (org-capture-set-target-location): Fix
+ file+function interpretation.
+
+2010-07-19 David Maus <dmaus@ictsoc.de>
+
+ * org-feed.el (org-feed-parse-rss-entry): Unescape rss element
+ content.
+
+2010-07-19 David Maus <dmaus@ictsoc.de>
+
+ * org-feed.el (xml-entity-alist): Declare variable
+ `xml-entity-alist' for byte compiler.
+
+2010-07-19 David Maus <dmaus@ictsoc.de>
+
+ * org-feed.el (org-feed-unescape): New function. Unescape
+ protected entities.
+ (org-feed-parse-atom-entry): Use function for atom:content
+ type text and html.
+
+2010-07-19 David Maus <dmaus@ictsoc.de>
+
+ * org-feed.el (org-feed-parse-rss-feed): Ignore case of rss
+ element names.
+
+2010-07-19 Bernt Hansen <bernt@norang.ca>
+
+ * org.el (org-time-string-to-absolute): Ignore cyclic repeater
+ when displaying items on todays agenda date.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-agenda-get-progress): Avoid reusing previous
+ value of EXTRA.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-publish.el (org-publish-initialize-cache): Make
+ timestamp directory, the entire path to it.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-exp.el (org-export-handle-comments): Make sure to check
+ for protection in the comment line, and not in the line after it.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-html.el (org-export-html-preprocess): Call org-format-latex,
+ possibly with a protect-only argument.
+
+ * org.el (org-format-latex): New argument PROTECT-ONLY.
+
+2010-07-19 Eric Schulte <schulte.eric@gmail.com>
+
+ * org-exp.el (org-export-handle-table-metalines): This function
+ removes table specific meta-lines, now that we aren't wiping
+ everything that looks remotely like a comment at the end of the
+ export process we have to be sure to catch all of the specific lines
+ in org-exp.el.
+
+2010-07-19 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-exp.el (org-export-select-backend-specific-text): Properly
+ get rid of #+Backend and #+ATTR_Backend specifics to backends not
+ matching the one we're exporting to.
+
+2010-07-19 Eric Schulte <schulte.eric@gmail.com>
+
+ * org-table.el (orgtbl-to-generic): Add the :remove-newlines
+ option which will strip newline characters from the text of table
+ cells and replace then with "\n".
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-confirm-shell-link-function)
+ (org-confirm-elisp-link-function): Limit the values that can be set by
+ file variables.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-compute-latex-and-specials-regexp): Deal with
+ string elements by discarding them.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-iswitchb): Make sure to use at least iswitchb.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-capture.el (org-capture-position-for-last-stored)
+ (org-capture-bookmark-last-stored-position): New functions.
+ (org-capture-place-table-line): Better error catching.
+ (org-capture-place-item, org-capture-place-entry)
+ (org-capture-place-plain-text): Call
+ `org-capture-position-for-last-stored'.
+ (org-capture-finalize): Just call
+ `org-capture-bookmark-last-stored-position'.
+
+2010-07-19 Eric Schulte <schulte.eric@gmail.com>
+
+ * org-exp.el (org-export-mark-blockquote-verse-center): Fix
+ small bug, now grabbing match data before overwritten by looking-at
+ this fixes a problem with remainders of #+end_quote lines appearing
+ in exported output.
+
+2010-07-19 David Maus <dmaus@ictsoc.de>
+
+ * org.el (org-link-frame-setup): Add customization option for
+ Wanderlust.
+
+2010-07-19 Eric Schulte <schulte.eric@gmail.com>
+
+ * org-latex.el (org-export-latex-fixed-width): Now check
+ org-example rather than org-protected on verbatim export, because by
+ default all ": " prefixed lines are marked protected.
+
+2010-07-19 Eric Schulte <schulte.eric@gmail.com>
+
+ * org-latex.el (org-export-latex-fixed-width): Check for
+ protection before wrapping ": " lines as verbatim.
+
+2010-07-19 Eric Schulte <schulte.eric@gmail.com>
+
+ * org-exp.el (org-export-handle-comments): Check for protection
+ before removing comments.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-entities.el (org-entities): Restructure the list.
+ (org-entities-help): Turn the help output into a buffer
+ in Org-mode, so that it becomes easier to find a symbol
+ in the structure.
+ (org-entities-create-table): Deal with new structure.
+
+2010-07-19 David Maus <dmaus@ictsoc.de>
+
+ * org-agenda.el (org-write-agenda): Use backquotes to expand
+ `flet' at compile time.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-entry-properties): Make sure that standard property
+ names are used even if the user has customized time keywords.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-macs.el (org-not-nil): Return the value if not interpreted
+ as nil.
+
+ * org.el (org-entry-get)
+ (org-entry-get-with-inheritance): Interpret the value "nil"
+ as nil for properties.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-switch-to-buffer-other-window): Return the buffer.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-macs.el (org-not-nil): New function.
+
+ * org.el (org-block-todo-from-children-or-siblings-or-parent):
+ Use `org-not-nil' to interpret a property value of nil.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-truely-invisible-p): New function.
+ (org-beginning-of-line): Use `org-truely-invisible-p'.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-agenda-get-timestamps): No errors
+ while getting TODO state.
+ (org-agenda-highlight-todo): No error when no keyword has
+ been matched.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-timestamp-change): New optional argument UPDOWN.
+ Use this to identify calls from org-timestamp-up/down, so that we can
+ skip by rounding minutes in this case.
+ (org-timestamp-up, org-timestamp-down, org-timestamp-up-day)
+ (org-timestamp-down-day): Call org-timestamp-change with the
+ updown argument.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-agenda-action): Make `c' key call org-capture.
+
+ * org-capture.el: New file.
+
+ * org-compat.el (org-get-x-clipboard): Function moved here from
+ remember.el.
+
+ * org-mks.el: New file.
+
+ * org.el (org-set-regexps-and-options): Allow statistic cookies as
+ part of complex headlines.
+ (org-find-olp): New argument THIS-BUFFER. When set, assume that the
+ OLP does not contain a file name.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-mode): Set `comment-start' instead of changing the
+ syntax of the `#' character.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-exp.el (org-export-format-source-code-or-example): Mark examples
+ by a property.
+
+ * org-html.el (org-export-html-close-lists-maybe): Check if raw
+ HTML stuff was actually made from an example.
+
+2010-07-19 Bastien Guerry <bzg@altern.org>
+
+ * org-latex.el: Items are no longer skipped when their first line
+ ends on a protected element.
+
+ * org-list.el: Protected environments looking like lists are not
+ exported anymore.
+
+2010-07-19 Eric Schulte <schulte.eric@gmail.com>
+
+ * org-exp-blocks.el (org-export-blocks-preprocess):
+ Cleanup trailing newline after block.
+
+2010-07-19 Bastien Guerry <bzg@altern.org>
+
+ * org-exp.el: Comment regexp now matches documentation. No more
+ protection check when deleting comments before export.
+
+2010-07-19 Bastien Guerry <bzg@altern.org>
+
+ * org-exp.el (org-export-preprocess-string):
+ Now using `org-export-handle-include-files-recurse' to resolve
+ included files.
+
+2010-07-19 Bastien Guerry <bzg@altern.org>
+
+ * org-agenda.el (org-agenda-get-deadlines)
+ (org-agenda-get-scheduled):
+ * org.el (org-time-string-to-seconds):
+ For deadline and scheduled agenda display ignore the cyclic repeater
+ when calculating how many days late the task is. If you have a weekly
+ task and miss the date the agenda view will show more than a week late
+ now instead of resetting on the cyclic repeating date. This makes it
+ much more obvious when you missed a repeating task after the repeater.
+
+2010-07-19 Bastien Guerry <bzg@altern.org>
+
+ * org-exp.el (org-export-mark-blockquote-verse-center):
+ Consider environments that end at eob.
+
+2010-07-19 Mikael Fornius <mfo@abc.se>
+
+ * org.el (org-raise-scripts): Do not fontify sub/superscripts of text
+ with face `org-special-keyword'. Make property keys as :LAST_REPEAT:
+ display correctly.
+
+2010-07-19 Mikael Fornius <mfo@abc.se>
+
+ * org.el (org-at-property-p): Use save-match-data macro instead of let.
+
+2010-07-19 Mikael Fornius <mfo@abc.se>
+
+ * org.el (test): Remove unused test function.
+
+2010-07-19 Eric Schulte <schulte.eric@gmail.com>
+
+ * org-exp-blocks.el (org-export-blocks-preprocess): Fix typo.
+
+2010-07-19 Eric Schulte <schulte.eric@gmail.com>
+
+ * org-exp-blocks.el (org-export-blocks-postblock-hook): Add
+ documentation to and turn into a defcustom.
+
+2010-07-19 Eric Schulte <schulte.eric@gmail.com>
+
+ * org-exp.el (org-get-file-contents): By un-setting prefix1 to ""
+ instead of to nil we avoid errors when :prefix1 is defined, but
+ prefix is not.
+
+2010-07-19 Nicolas Goaziou <n.goaziou@gmail.com>
+
+ * org-latex.el (org-export-latex-preprocess): Environments coming
+ from latex backend specific instructions (#+LaTeX) are already
+ protected and won't be treated as normal environments.
+
+2010-07-19 Bastien Guerry <bzg@altern.org>
+
+ * org-timer.el (org-timer-set-timer): Fix typo in the docstring.
+
+2010-07-19 Bastien Guerry <bzg@altern.org>
+
+ * org-timer.el (org-timer-set-timer): Use a prefix argument.
+ See the docstring of the function.
+
+2010-07-19 Bastien Guerry <bzg@altern.org>
+
+ * org-timer.el (org-timer-set-timer): Fix bug about cancelling
+ timers.
+
+2010-07-19 David Maus <dmaus@ictsoc.de>
+
+ * org-w3m.el (org-w3m-copy-for-org-mode)
+ (org-w3m-get-next-link-start, org-w3m-get-prev-link-start):
+ Get text property directly, not using macro `w3m-anchor'.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-emph-re): Document the match groups.
+
+2010-07-19 Bernt Hansen <bernt@norang.ca>
+
+ * org-clock.el (org-clock-in): Set `org-clock-clocking-in' to
+ t before calling `org-clock-out', so that that function can
+ know its call context.
+
+2010-07-19 Bastien Guerry <bzg@altern.org>
+
+ * org-timer.el (org-timer-default-timer): New variable.
+ (org-timer-set-timer): Use the new variable. Also offer the
+ possibility to replace the current timer by a new one.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-kill-note-or-show-branches): Hide subtree before
+ exposing the headings.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-add-planning-info): Remove the empty line also
+ if there is no whitespace at all in there.
+
+ * org-table.el (org-table-align): Fix alignment of strings
+ with invisible characters.
+
+2010-07-19 David Maus <dmaus@ictsoc.de>
+
+ * org.el (org-refile-cache-get): Return empty list of targets
+ when cache was cleared.
+ (org-clone-subtree-with-time-shift): Maybe create ID property
+ in cloned subtrees.
+ (org-clone-delete-id): New customization variable.
+ (org-clone-subtree-with-time-shift): Use customization
+ variable `org-clone-delete-id'.
+ (org-clone-subtree-with-time-shift): Remove empty property
+ drawer in cloned subtrees.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-refile-use-cache): New option.
+ (org-refile-cache, org-refile-markers): New variable.
+ (org-refile-marker, org-refile-cache-clear)
+ (org-refile-cache-check-set, org-refile-cache-put)
+ (org-refile-cache-get): New function.
+ (org-get-refile-targets): Use the refile cache.
+
+ * org-clock.el (org-clock-sum): Don't include running clock if
+ the time block is wrong.
+
+2010-07-19 John Wiegley <jwiegley@gmail.com>
+
+ * org-clock.el (org-clock-clock-in, org-clock-in): Add
+ parameter `start-time'.
+ (org-clock-resolve-clock): Add parameter `clock-out-time'.
+ If set, and resolve-to is a past time, then the clock out
+ event occurs at `clock-out-time' rather than at `resolve-to'.
+ In this case, `resolve-to' becomes the clock in time.
+ (org-clock-jump-to-current-clock): Create new global command
+ to reveal the current clock.
+ (org-clock-resolve): Add new commands g/G and j/J, and a
+ help window describing all commands and their meaning.
+ (org-clock-resolve-expert): New customization variable.
+ (org-find-open-clocks): Fix a bug that caused discovered
+ clocks not to match up with the currently active clock.
+ (org-resolve-clocks): Change the argument
+ `also-non-dangling-p' to `only-dangling-p', since due to a bug
+ this was the default behavior all along.
+
+2010-07-19 David Maus <dmaus@ictsoc.de>
+
+ * org-id.el (org-id-uuid): New function. Return string with
+ random (version 4) UUID.
+ (org-id-method): Make 'uuid the new default value.
+ (org-id-new): Use `org-id-uuid' if call to uuidgen program
+ does not return a UUID.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-export-latex-format-image): Add support
+ for multicolumn figures in LaTeX.
+
+2010-07-19 David Maus <dmaus@ictsoc.de>
+
+ * org.el (org-clone-subtree-with-time-shift): Remove ID
+ property of original subtree in cloned subtrees.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-exp.el (org-export-format-source-code-or-example):
+ XEmacs compatibility.
+
+ * org-latex.el (org-export-latex-tables): Accept comma in
+ align string.
+
+ * org-docbook.el (org-export-docbook-xslt-stylesheet): New option.
+ (org-export-docbook-xslt-proc-command): Fix docstring.
+ (org-export-docbook-xsl-fo-proc-command): Fix docstring.
+ (org-export-as-docbook-pdf): Improve
+ formatting of the xslt command.
+
+ * org-exp.el (org-infile-export-plist): Check for XSLT setting.
+
+ * org.el (org-file-contents): Improve error message.
+ (org-set-regexps-and-options): Remove spaces at both ends.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-docbook.el (org-export-as-docbook-pdf): Improve
+ formatting of the xslt command.
+
+2010-07-19 Sebastian Rose <sebastian_rose@gmx.de>
+
+ * org-publish.el (org-publish-cache): Use one big hashmap for
+ each project defined in `org-publish-project-alist'.
+ (initialize-files-alist): Function removed.
+ (org-publish-validate-link): Function removed.
+ (org-publish-get-base-files): Add variable `sitemap-requested'
+ to avoid sorting where possible.
+ (org-publish-get-files): Function removed.
+ (org-publish-get-project-from-filename): Make independent of
+ file list.
+ (org-publish-file): New argument NO-CACHE.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-beginning-of-defun, org-end-of-defun): New
+ functions.
+ (org-mode): Install the `org-beginning-of-defun' and
+ `org-end-of-defun' functions.
+ (org-pretty-entities): New option.
+ (org-toggle-pretty-entities): New command.
+ (org-fontify-entities): New function.
+ (org-startup-options): New keywords for pretty entities.
+ (org-set-font-lock-defaults): Call the pretty entities
+ function.
+
+ * org-latex.el (org-export-latex-keywords-maybe): Protect the
+ TODO markup.
+
+2010-07-19 Mikael Fornius <mfo@abc.se>
+
+ * org-habit.el (org-habit-build-graph): Help-echo date when
+ mouse is over stars.
+
+2010-07-19 Jan Böker <jan.boecker@jboecker.de>
+
+ * org.el (org-file-apps): Improve docstring to reflect
+ grouping matches.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-set-startup-visibility): Fix empty line display.
+
+ * org-latex.el (org-export-latex-links): Use the formatting
+ function of the link type, if it is available.
+
+ * org-table.el (org-table-get-remote-range): Return to
+ original buffer when retrieving remote reference.
+
+ * org.el (org-display-inline-images): Do the entire buffer,
+ not just the narrowed region. Clear the cache.
+ (org-display-inline-images): Match mode file paths.
+
+2010-07-19 David Maus <dmaus@ictsoc.de>
+
+ * org-wl.el (org-wl-store-link-folder): Don't throw error when
+ called on WL folder group.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-replace-escapes): Make sure the cdr is not nil.
+ (org-read-date): Make `M-v' and `C-v' scroll the popup calendar.
+ (org-mode): Revert comment syntax changes.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-sparse-tree): Make `C-c / t' search for all TODO
+ keywords, and `C-c / T' for a specific one.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-mode): Fix comment syntax settings.
+
+ * org-src.el (org-edit-src-allow-write-back-p): Define
+ variable.
+
+ * org.el (org-inline-image-overlays): New variable.
+ (org-toggle-inline-images, org-display-inline-images)
+ (org-remove-inline-images): New commands.
+ (org-mode-map): Define a key for `org-toggle-inline-images'.
+
+2010-07-19 David Maus <dmaus@ictsoc.de>
+
+ * org-wl.el (org-wl-message-field): New function. Return
+ content of header field in message entity.
+ (org-wl-store-link): Call `org-wl-store-link-folder' or
+ `org-wl-store-link-message' depending on major-mode.
+ (org-wl-store-link-folder): New function. Store link to
+ Wanderlust folder.
+ (org-wl-store-link-message): New function. Store link to
+ Wanderlust message.
+ (org-wl-store-link-message): Store link to message while
+ visiting message.
+ (org-wl-open): Don't try to jump to message when opening a
+ folder link.
+
+2010-07-19 David Maus <dmaus@ictsoc.de>
+
+ * org.el (org-replace-escapes): Avoid infinite loop when
+ replace string contains escape sequence it replaces.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-crypt.el (org-crypt-key-for-heading): Use symmetric
+ encryption when now key is set.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-table.el (org-table-recalculate-buffer-tables)
+ (org-table-iterate-buffer-tables): New commands.
+
+ * org.el (org-check-for-hidden): When there is a region, skip
+ the check.
+
+2010-07-19 Dan Davison <davison@stats.ox.ac.uk>
+
+ * org-src.el (org-edit-src-code): allow-write-back-p had
+ erroneously been omitted from let binding.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-sorting-choice): New sorting type alpha.
+ (org-cmp-alpha): New defsubst.
+ (org-em): New defsubst.
+ (org-entries-lessp): Only compute needed comparisons.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-html.el (org-format-org-table-html): Test all columns
+ for number content.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-export-latex-treat-sub-super-char): Make
+ sure parenthesis matching is consistent.
+
+ * org-table.el (org-table-colgroup-line-p)
+ (org-table-cookie-line-p): New functions.
+
+ * org-exp.el (org-table-clean-before-export): Better tests for
+ colgroup and cookie lines.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-agenda-goto): Push a mark before changing
+ the position.
+
+ * org-footnote.el (org-footnote): New group.
+ (org-footnote-section)
+ (org-footnote-tag-for-non-org-mode-files): Fix typos.
+
+ * org-list.el (org-end-of-item-text-before-children): Also do
+ the right thing at the end of a file.
+
+ * org.el (org-set-packages-alist, org-get-packages-alist): New
+ function.
+ (org-export-latex-default-packages-alist)
+ (org-export-latex-packages-alist): Add extra flag to
+ each package, indicating if it should be used for snippets.
+ (org-create-formula-image): Add the snippet argument.
+ (org-splice-latex-header): New argument SNIPPET-P, pass it
+ through to `org-latex-packages-to-string'.
+ (org-latex-packages-to-string): New argument SNIPPET-P.
+
+ * org-latex.el (org-export-latex-make-header): Add the snippet
+ argument.
+
+ * org-docbook.el (org-export-as-docbook): Implement ordered
+ lists starting at some offset.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-link-types, org-open-at-point): Add doi links.
+
+ * org-ascii.el (org-export-ascii-preprocess): Remove list
+ startcounter cookies.
+
+ * org-list.el (org-renumber-ordered-list): Respect counter
+ start values.
+
+ * org-latex.el (org-export-latex-lists): Accept ordered list
+ item offset cookie.
+
+ * org-html.el (org-export-as-html): Accept ordered list
+ item offset cookie.
+
+ * org-indent.el (org-indent-mode): Turn off `indent-tabs-mode'
+ which messes up alignment of tags.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-clock.el (org-clock-cancel, org-clock-out): Make sure
+ the modeline display is removed.
+
+ * org-exp.el (org-export-format-drawer-function): Fix
+ docstring.
+
+ * org-agenda.el (org-agenda-refile): New optional argument
+ NO-UPDATE.
+ (org-agenda-refile): Call `org-agenda-redo' unless NO-UPDATE
+ is set.
+ (org-agenda-bulk-action): Call the refile command with updates
+ suppressed - but arrange for `org-agenda-redo' to be called at
+ the end.
+
+ * org.el (org-mode): Make table mapping quiet.
+ (org-table-map-tables): New optional argument QUIETLY.
+
+ * org-ascii.el (org-export-ascii-preprocess): Make table
+ mapping quiet.
+
+ * org-html.el (org-export-as-html, org-html-level-start): Change
+ XHTML IDs to not use dots.
+
+ * org-exp.el (org-export-define-heading-targets): Change
+ XHTML IDs to not use dots.
+
+ * org-docbook.el (org-export-docbook-level-start): Change
+ XHTML IDs to not use dots.
+
+ * org-latex.el (org-export-as-latex): Make sure that the
+ result buffer is in latex-mode.
+
+ * org.el (org-shiftup-final-hook, org-shiftdown-final-hook)
+ (org-shiftleft-final-hook, org-shiftright-final-hook): New
+ hooks.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-table.el (org-table-justify-field-maybe): Make sure that
+ inserting a value does not turn a line into a hline.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-clock.el (org-clock-sum): New argument HEADLINE-FILTER.
+ (org-clock-sum): Add property to selected headlines.
+ (org-dblock-write:clocktable): Make tags matcher.
+
+ * org.el (org-set-autofill-regexps): XEmacs compatibility.
+
+ * org-latex.el (org-export-latex-set-initial-vars): Allow "-"
+ in latex class definitions.
+
+ * org.el (org-shiftup-hook, org-shiftdown-hook)
+ (org-shiftleft-hook, org-shiftright-hook): New hooks.
+
+ * org-entities.el (org-entities): Use \land and \lor for logical
+ operators.
+
+ * org.el (org-shiftmetaleft, org-shiftmetaright): Call the subtree
+ indentation commands.
+ (org-hidden-tree-error): New defsubst.
+ (org-metaleft, org-metaright): Check for hidden stuff and throw an
+ error.
+ (org-check-for-hidden): New function.
+
+ * org-list.el (org-item-re): New function.
+ (org-at-item-p): Use `org-item-re'.
+ (org-end-of-item-text-before-children): New function.
+ (org-outdent-item, org-indent-item): Arrange for leaving the
+ subtree alone.
+ (org-outdent-item-tree, org-indent-item-tree): New argument
+ NO-SUBTREE.
+ (org-indent-item-tree): Use `org-end-of-item-text-before-children'
+ to find the end for processing while ignoring the subtree.
+
+ * org-publish.el (org-publish-sitemap-sort-alphabetically)
+ (org-publish-sitemap-sort-folders)
+ (org-publish-sitemap-sort-ignore-case): New options.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-publish.el (org-publish-compare-directory-files): Fix sorting.
+
+ * org-compat.el (org-get-x-clipboard-compat): Use (featurep 'xemacs).
+
+ * org-publish.el (org-publish-project-alist): Update docstring.
+ (org-publish-file-title-cache): New variable.
+ (org-publish-initialize-files-alist): Initialize
+ `org-publish-initialize-files-alist' to nil.
+ (org-publish-sort-directory-files): New function.
+ (org-publish-projects): Access the new properties.
+ (org-publish-find-title): Use the file title cache.
+ (org-publish-find-title): Build the file title cache.
+ (org-publish-get-base-files-1): Sort files.
+ (org-publish-aux-preprocess): Do not throw an error when before
+ the first headline. Allow an empty target, meaning to link just
+ to the file.
+ (org-publish-index-generate-theindex.inc): Check if there is
+ actually a target and only then add it to the link.
+ (org-publish-projects): Fix a remaining issue with the last commit.
+
+ * org-html.el (org-export-as-html): Treat verse as open/close
+ paragraph.
+ (org-export-html-close-lists-maybe): Allow to splice raw HTML into
+ and out of lists.
+
+2010-07-19 Dan Davison <davison@stats.ox.ac.uk>
+
+ * org-src.el (org-edit-src-code): Allow the org-src edit buffer to
+ be used in a read-only mode.
+ (org-edit-src-code): Different message in read-only mode.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-src.el (org-edit-src-find-region-and-lang): Test for
+ table.el as late as possible.
+
+ * org-colview-xemacs.el: Make sure this file is never loaded into
+ Emacs. Remove all tests for XEmacs.
+
+ * org-colview.el: Make sure this file is never loaded into XEmacs.
+
+ * org-agenda.el (org-highlight, org-unhighlight): Use direct
+ overlay calls.
+
+ * org.el (org-key): Apply the translations defined in
+ `org-xemacs-key-equivalents'.
+
+ * org-mouse.el (org-mode-hook): Use `org-defkey'.
+
+ * org-compat.el (org-xemacs-key-equivalents): New constant.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-inlinetask.el (org-inlinetask-defaut-state): New option.
+ (org-inlinetask-insert-task): Use `org-inlinetask-defaut-state'.
+ Obey `org-odd-levels-only'.
+
+ * org-compat.el (org-find-overlays): Use overlays-in/at.
+
+ * org.el (org-remove-empty-overlays-at)
+ (org-outline-overlay-data, org-hide-block-toggle)
+ (org-format-latex, org-context): Use overlays-in/at.
+
+ * org-src.el (org-edit-src-exit): Use overlays-in/at.
+
+ * org-agenda.el (org-agenda-mark-clocking-task)
+ (org-agenda-fontify-priorities, org-agenda-dim-blocked-tasks)
+ (org-agenda-entry-text-hide)
+ (org-agenda-fix-tags-filter-overlays-at)
+ (org-agenda-bulk-remove-overlays): Use overlays-in/at.
+
+ * org-compat.el (org-overlays-at): Function removed.
+ (org-overlays-in): Function removed.
+
+2010-07-19 Bastien Guerry <bzg@altern.org>
+
+ * org-clock.el (org-clock-set-current): Just return the headline
+ itself, strip the TODO keyword, the priority cookie and the tags.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-compat.el (org-xemacs-without-invisibility): New macro.
+ (org-xemacs-without-invisibility): New macro.
+ (org-indent-to-column, org-indent-line-to, org-move-to-column):
+ Redefine using the macro `org-xemacs-without-invisibility'.
+
+ * org.el (org-mode, org-org-menu): Use `add-to-invisibility-spec'.
+
+ * org-table.el (orgtbl-mode): Use `add-to-invisibility-spec'.
+
+ * org-compat.el (org-make-overlay, org-delete-overlay)
+ (org-overlay-start, org-overlay-end, org-overlay-put)
+ (org-overlay-get, org-overlay-move, org-overlay-buffer): Functions
+ removed.
+ (org-add-to-invisibility-spec): Function removed.
+
+ * org-html.el (org-export-as-html-and-open): Add argument to
+ kill-buffer.
+
+ * org-habit.el (require): `calendar' is now required already by
+ org.el on top level.
+
+ * org-clock.el (require): `calendar' is now required already by
+ org.el on top level.
+
+ * org-agenda.el (require, org-timeline, org-agenda-list)
+ (org-todo-list, org-agenda-to-appt): `calendar' is now required
+ already by org.el on top level.
+
+ * org.el (org-export-latex-fix-inputenc): Declare function.
+
+ * org-agenda.el (org-agenda-goto-calendar): Do not bind obsolete
+ variables.
+
+ * org.el (calendar): Require calendar now on top level in org.el
+ and define aliases to new variables when needed.
+ (org-read-date, org-goto-calendar): Do not bind obsolete
+ variables.
+
+ * org-clock.el (org-clock-out, org-clock-cancel): Get rid of
+ compilation warning, add comment that this cannot be done with
+ `with-current-buffer'.
+
+ * org-wl.el (org-wl-open): Use `with-current-buffer'.
+
+ * org.el (overlay, org-remove-empty-overlays-at)
+ (org-outline-overlay-data, org-set-outline-overlay-data)
+ (org-show-block-all, org-hide-block-toggle)
+ (org-highlight-new-match, org-remove-occur-highlights)
+ (org-tags-overlay, org-fast-tag-selection, org-date-ovl)
+ (org-read-date, org-read-date-display, org-eval-in-calendar)
+ (org-format-latex, org-context)
+ (org-speedbar-restriction-lock-overlay)
+ (org-speedbar-set-agenda-restriction): Use the normal overlay API.
+
+ * org-table.el (org-table-add-rectangle-overlay)
+ (org-table-remove-rectangle-highlight)
+ (org-table-overlay-coordinates)
+ (org-table-toggle-coordinate-overlays): Use the normal overlay
+ API.
+
+ * org-src.el (org-edit-src-code, org-edit-fixed-width-region)
+ (org-edit-src-exit, org-src-mode-configure-edit-buffer): Use the
+ normal overlay API.
+
+ * org-colview.el (org-columns-new-overlay)
+ (org-columns-display-here, org-columns-remove-overlays)
+ (org-columns-edit-value, org-columns-next-allowed-value)
+ (org-columns-update): Use the normal overlay API.
+
+ * org-clock.el (org-clock-out, org-clock-cancel)
+ (org-clock-put-overlay, org-clock-remove-overlays): Use the normal
+ overlay API.
+
+ * org-agenda.el (org-agenda-mark-filtered-text)
+ (org-agenda-mark-clocking-task, org-agenda-fontify-priorities)
+ (org-agenda-dim-blocked-tasks, org-agenda-entry-text-show-here)
+ (org-agenda-entry-text-hide)
+ (org-agenda-restriction-lock-overlay)
+ (org-agenda-set-restriction-lock)
+ (org-agenda-filter-by-tag-hide-line)
+ (org-agenda-fix-tags-filter-overlays-at)
+ (org-agenda-filter-by-tag-show-all, org-hl)
+ (org-agenda-goto-calendar, org-agenda-bulk-mark)
+ (org-agenda-bulk-remove-overlays): Use the normal overlay API.
+
+ * org-freemind.el (org-freemind-from-org-mode-node)
+ (org-freemind-from-org-mode)
+ (org-freemind-from-org-sparse-tree, org-freemind-to-org-mode): Use
+ interactive-p instead of called-interactively, because this is
+ backward compatible with older Emacsen I still support..
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-exp.el (org-export-define-heading-targets): Fix bug in
+ regexp finding ID and CUSTOM_ID properties.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-footnote.el (org-footnote-goto-previous-reference): Rename
+ from `org-footnote-goto-next-reference'.
+
+ * org.el (org-auto-repeat-maybe): Only record LAST_REPEAT if
+ org-log-repeat is non-nil, or if there is clocking data in the
+ entry.
+
+ * org-crypt.el (org-encrypt-entry): Improve mapping behavior.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-align-all-tags): New command.
+
+2010-07-19 David Maus <dmaus@ictsoc.de>
+
+ * org-wl.el (org-wl-link-remove-filter): New customizable
+ variable. If non-nil, filter conditions are stripped when storing
+ link to message in filter folder.
+ (org-wl-shimbun-prefer-web-links): New customizable variable. If
+ non-nil, links to shimbun messages are created as web links to
+ message source.
+ (org-wl-nntp-prefer-web-links): New customizable variable. If
+ non-nil, links to nntp message are created as web links to gmane
+ or googlegroups.
+ (org-wl-namazu-default-index): New customizable variable.
+ Directory of namazu search index that should be used as default
+ when opening a link in a search folder.
+ (org-wl-folder-types): New constant. Wanderlust folder type
+ indicators.
+ (org-wl-folder-type): New function. Return type of Wanderlust
+ folder.
+ (org-wl-store-link): Create web links for shimbun or nntp messages
+ and strip filter conditions depending on customizable variables.
+ (org-wl-open): Open namazu search folder for message when called
+ with prefix.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-remove-if, org-remove-if-not): New functions.
+ (org-open-file): Use internal remove-if functions.
+
+2010-07-19 Jan Böcker <jan.boecker@jboecker.de>
+
+ * org.el (org-file-apps-entry-match-against-dlink-p): New function.
+ (org-file-apps-ex): Remove variable.
+ (org-open-file): Integrate org-file-apps-ex functionality back
+ into org-file-apps, and decide whether to match a regexp against
+ the link or the filename using org-file-apps-entry-uses-grouping-p.
+
+2010-07-19 Jan Böcker <jan.boecker@jboecker.de>
+
+ * org.el (org-file-apps-ex): New variable.
+ (org-open-file): Before considering org-file-apps, first match the
+ regexps from org-file-apps-ex against the whole link. See
+ docstring of org-file-apps-ex.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-export-latex-default-packages-alist): Remove
+ microtype package.
+ (org-todo-repeat-to-state): New variable.
+ (org-auto-repeat-maybe): Allow user-selected target states.
+ (org-default-properties): Add the new property REPEAT_TO_STATE.
+
+2010-07-19 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-mobile.el (org-mobile-check-setup): Make sure that there is
+ a binary to compute checksums.
+
+2010-06-26 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-agenda-goto-calendar): Do not bind obsolete
+ variables.
+
+ * org.el (calendar): Require calendar now on top level in org.el
+ and define aliases to new variables when needed.
+ (org-read-date, org-goto-calendar): Do not bind obsolete
+ variables.
+
+2010-06-22 Glenn Morris <rgm@gnu.org>
+
+ * org-entities.el: Add explicit utf-8 coding cookie to file with
+ utf-8 characters.
+
+2010-05-26 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * org.el (org-file-complete-link): Avoid (expand-file-name ".").
2010-05-07 Chong Yidong <cyd@stupidchicken.com>
* Version 23.2 released.
+2010-05-05 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * org-table.el (orgtbl-setup):
+ * org-agenda.el (org-agenda-entry-text-mode): Simplify.
+
+2010-05-03 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * org-table.el (orgtbl-mode): Use define-minor-mode.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-insert-link): Find the link buffer on visible frames.
+ (org-export-latex-default-packages-alist): Hyperref must be loaded
+ late.
+ (org-open-file): More care with the new matching for file links.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-export-latex-preprocess): Do not yet protect
+ defined entities - these will be taken care of later.
+ (org-export-latex-special-chars): Post-process entity replacement.
+ (org-export-latex-fontify-headline): Do not yet protect defined
+ entities - these will be taken care of later.
+ (org-export-latex-tables, org-export-latex-links): Format the
+ caption properly.
+
+ * org-entities.el (org-entities-user): Fix typo.
+
+ * org.el (org-prepare-agenda-buffers): Uniquify TODO keywords.
+
+ * org-entities.el (org-entities-user): Improve docstring.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-entities.el (org-macs): Require org-macs, to be sure that we
+ have `declare-function' defined.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-export-latex-classes): Update docstring.
+
+ * org.el (org-format-latex-header): Add cookies to the header.
+ (org-splice-latex-header): Implement placement according to cookies.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-publish.el (org-publish-aux-preprocess): Control case
+ sensitivity.
+
+2010-04-10 Bastien Guerry <bzg@altern.org>
+
+ * org.el (org-splice-latex-header): Fix typo.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-export-latex-make-header):
+ Use `org-splice-latex-header' to build the header.
+ (org-export-latex-classes): Update docstring.
+
+ * org.el (org-splice-latex-header): New function.
+ (org-create-formula-image): Use `org-splice-latex-header' to build
+ the header.
+
+ * org-gnus.el (org-gnus-follow-link): Handle nndoc backend.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-export-latex-packages-alist)
+ (org-export-latex-default-packages-alist): Fix docstring to
+ reflect the expected structure.
+
+ * org-docbook.el (org-docbook-do-expand): Fix bug with variable names.
+ (org-export-docbook-finalize-table): Make use of label for tables.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-attach.el (org-attach-commit): Split on newlines.
+
+ * org.el (org-export-latex-default-packages-alist): Use list
+ instead of cons for the entries.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-entities.el (org-entity-get-representation): Catch the case
+ that there is not entry in the list.
+
+ * org-mobile.el (org-mobile-use-encryption)
+ (org-mobile-encryption-tempfile, org-mobile-encryption-password):
+ New options.
+ (org-mobile-check-setup): CHeck the encryption setup.
+ (org-mobile-copy-agenda-files, org-mobile-sumo-agenda-command)
+ (org-mobile-create-sumo-agenda): Use encryption code.
+ (org-mobile-encrypt-and-move): New function.
+ (org-mobile-encrypt-file, org-mobile-decrypt-file): New
+ functions.
+ (org-mobile-move-capture): Decrypt the capture file.
+
+ * org.el (org-entities): Require the new file.
+ (org-export-latex-default-packages-alist): New variable.
+ (org-complete): Use new entity code for completion.
+ (org-create-formula-image): Use the new packages variable.
+
+ * org-latex.el (org-export-latex-classes): Remove the standard
+ packages from the class headers.
+ (org-export-latex-make-header): Use the new package variable.
+ (org-export-latex-special-chars): Better regexp for entities, to
+ support entity name that contain numbers.
+ (org-export-latex-treat-backslash-char): Use the new entity code.
+
+ * org-html.el (org-html-do-expand): Use the new entity code.
+
+ * org-exp.el (org-export): Add the new export commands.
+ (org-html-entities): Constant removed.
+ (org-export-visible): Add the new export commands.
+
+ * org-docbook.el (org-docbook-do-expand): Use new entity code.
+
+ * org-ascii.el (org-export-ascii-entities): New variable.
+ (org-export-as-latin1, org-export-as-latin1-to-buffer)
+ (org-export-as-utf8, org-export-as-utf8-to-buffer): New commands.
+ (org-export-as-encoding): New function.
+ (org-export-ascii-preprocess): Call `org-ascii-replace-entities'.
+ (org-ascii-replace-entities): New function.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+ Ulf Stegemann <ulf@zeitform.de>
+
+ * org-entities.el: New file.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-html.el (org-html-level-start): Catch the case that target
+ might be nil.
+
+2010-04-10 Dan Davison <davison@stats.ox.ac.uk>
+
+ * org.el (org-appearance): Change Customize group variable name
+ from org-font-lock to org-appearance, and change tag from "Org
+ Font Lock" to "Org Appearance".
+ (org-odd-levels-only): Change Customize group variable name.
+ (org-level-color-stars-only): Change Customize group variable name.
+ (org-hide-leading-stars): Change Customize group variable name.
+ (org-hidden-keywords): Change Customize group variable name.
+ (org-fontify-done-headline): Change Customize group variable name.
+ (org-fontify-emphasized-text): Change Customize group variable name.
+ (org-fontify-whole-heading-line): Change Customize group variable name.
+ (org-highlight-latex-fragments-and-specials): Change Customize
+ group variable name.
+ (org-hide-emphasis-markers): Change Customize group variable name.
+ (org-emphasis-alist): Change Customize group variable name.
+ (org-emphasis-regexp-components): Change Customize group variable
+ name.
+ (org-modules): Remove mention of org-R.
+
+ * org-faces.el (org-faces): Change Customize group variable name.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-diary-last-run-time): New variable.
+ (org-diary): Prepare agenda buffers only if last call was some
+ time ago.
+
+ * org-html.el (org-export-html-preprocess): Replace \ref macros
+ with a link.
+ (org-format-org-table-html): Add the label as an anchor.
+
+ * org-docbook.el (org-export-docbook-format-image): Do some
+ formatting on captions.
+
+ * org-latex.el (org-export-latex-tables, org-export-latex-links):
+ Do some formatting on captions.
+
+ * org-html.el (org-export-html-format-image)
+ (org-format-org-table-html): Do some formatting on captions.
+
+2010-04-10 Dan Davison <davison@stats.ox.ac.uk>
+
+ * org.el (org-hidden-keywords): New customizable variable. This is
+ a list of symbols specifying which of the special keywords #+DATE,
+ #+AUTHOR, #+EMAIL and #+TITLE should be hidden by font lock.
+ (org-fontify-meta-lines-and-blocks): Changes to font-lock code
+ implementing new faces and hiding behaviour.
+
+ * org-faces.el (org-document-title): New face for #+TITLE lines.
+ (org-document-info): New face for #+DATE, #+AUTHOR, #+EMAIL lines.
+ (org-document-info-keyword): New face for #+DATE, #+AUTHOR, #+EMAIL
+ keywords.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-publish.el (org-publish-sanitize-plist): New function to
+ rename "index" properties to "sitemap". Do this renaming
+ globally.
+ (org-publish-with-aux-preprocess-maybe): New macro.
+ (org-publish-org-to-pdf, org-publish-org-to-html): Use the new
+ macro.
+ (org-publish-aux-preprocess)
+ (org-publish-index-generate-theindex.inc): New function.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-table.el (org-table-align): Interpret <N> at fixed width,
+ not as maximum width.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-exp.el (org-export-author-info, org-export-email-info): Fix
+ docstrings.
+
+ * org-beamer.el (org-beamer-select-environment): Rename from
+ `org-beamer-set-environment-tag'. Improve docstring.
+
+ * org-freemind.el (org-freemind-write-mm-buffer): Fix another
+ problem with odd levels.
+
+ * org-ascii.el (org-export-as-ascii): Export email only if the
+ author wants it.
+
+ * org-docbook.el (org-export-as-docbook): Export email only if the
+ author wants it.
+
+ * org-html.el (org-export-as-html): Export email only if the
+ author wants it.
+
+ * org-exp.el (org-export-email-info): New option.
+ (org-export-plist-vars): Add entry for `org-export-email'.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-table.el (org-table-goto-line): Fix typo.
+
+2010-04-10 Mikael Fornius <mfo@abc.se>
+
+ * org.el (org-agenda-files): Typo.
+ (org-read-agenda-file-list): Add optional argument to help
+ `org-store-new-agenda-file-list' to remember un-expanded file
+ names. Expand file names relative to `org-directory'.
+ (org-store-new-agenda-file-list): Keep un-expanded file names when
+ saving, if available.
+ (org-agenda-files): Update documentation.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-ascii.el (org-export-as-ascii): Catch the case of exporting
+ a buffer with no file name attached.
+
+ * org.el (org-log-refile): New option.
+ (org-log-note-headings): Add a heading for refiling.
+ (org-startup-options): Add keywords for logging of the refile
+ action.
+ (org-refile): Add logging action.
+ (org-add-log-note): Allow for refiling action.
+
+ * org-agenda.el (org-agenda-bulk-action): Make sure
+ `org-log-refile' is not `note' during a bulk action.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-map-dblocks): Use save-excursion to remember the
+ position.
+
+ * org-attach.el (org-attach-commit): Remove dependence on xargs.
+ (org-attach-delete-one): Commit after deleting a file.
+
+ * org-latex.el (org-export-latex-fontify): Do not mistake table.el
+ borders for strike-through emphasis.
+
+ * org-freemind.el (org-freemind-write-mm-buffer): Simplify the
+ handling of odd levels.
+
+ * org-agenda.el (org-agenda-todo-ignore-deadlines): Document `past'
+ and `future' values.
+ (org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item):
+ Handle `past' and `future' values.
+
+ * org.el (org-read-agenda-file-list): Interpret file names
+ relative to org-directory and allow environment variables and
+ "~".
+
+ * org-latex.el (org-export-latex-special-chars): Allow a
+ parenthesis before an exponent or subscript.
+
+2010-04-10 Dan Davison <davison@stats.ox.ac.uk>
+
+ * org-src.el (org-edit-src-exit): When returning from code edit
+ buffer, if code block is hidden, leave point at start of
+ #+begin_src line.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-insert-heading): Do not remove all spaces if the
+ headline is empty.
+
+ * org-indent.el (org-indent): Fix group name.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-table.el (org-table-goto-column): Fix forcing a non-existing
+ column.
+ (org-table-get, org-table-put, org-table-goto-line)
+ (org-table-current-line): New functions.
+
+2010-04-10 Jan Böcker <jan.boecker@jboecker.de>
+
+ * org.el (org-open-file): Allow regular expressions in
+ org-file-apps to capture link parameters using groups. In a
+ command string to be executed, the parameters can be referenced
+ using %1, %2, etc. Lisp forms can access them using
+ (match-string n link).
+ (org-apps-regexp-alist): Adopt the created regexp, as this is now
+ matched against a file: link instead of the file name.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-crypt.el (org-reveal-start-hook): Add a decryption function
+ to this hook.
+ (org-decrypt-entries, org-encrypt-entries, org-decrypt-entry): Add
+ docstrings.
+
+ * org.el (org-point-at-end-of-empty-headline)
+ (org-level-increment, org-get-previous-line-level): New function.
+ (org-cycle-level): Rewritten to be independent of when this
+ function is called.
+ (org-in-regexps-block-p): New function.
+ (org-reveal-start-hook): New hook.
+ (org-reveal): Run new hook.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-export-latex-keywords): Start a new paragraph
+ after time keywords, do not add "\newline".
+
+ * org-html.el (org-export-as-html): Avoid double # in href.
+
+ * org.el (org-refile-get-location): Catch an invalid target
+ specification.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-agenda-add-entry-to-org-agenda-diary-file):
+ Make sure the behavior regarding to extracting time is
+ consistent.
+
+2010-04-10 Stephen Eglen <stephen@gnu.org>
+
+ * org-agenda.el (org-agenda-insert-diary-extract-time): New
+ variable.
+ (org-agenda-add-entry-to-org-agenda-diary-file): Use this new
+ variable rather than `org-agenda-search-headline-for-time'.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-list.el (org-fix-bullet-type): Improve cursor positioning.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-adaptive-fill-regexp-backup): New variable.
+ (org-set-autofill-regexps): Store a backup of
+ `adaptive-fill-regexp'.
+ (org-adaptive-fill-function): Fix filling of comments and ordered
+ lists. If there is no other match, till try adaptive fill.
+
+2010-04-10 John Wiegley <jwiegley@gmail.com>
+
+ * org-agenda.el (org-agenda-include-deadlines): Add new
+ customization variable to determine whether unscheduled tasks
+ should appear in the agenda solely because of their deadline.
+ Default to true, which was the previous behavior (it just wasn't
+ configurable).
+ (org-agenda-mode-map, org-agenda-view-mode-dispatch): Bind ! in
+ the agenda to show/hide deadline tasks.
+ (org-agenda-menu): Add menu option for show/hide deadlines.
+ (org-agenda-list): Make the agenda list sensitive to the value of
+ `org-agenda-include-deadlines'.
+ (org-agenda-toggle-deadlines): New function to toggle the value of
+ `org-agenda-include-deadlines' and repaint the modeline
+ indicators.
+ (org-agenda-set-mode-name): Show "Deadlines" in the agenda
+ modeline if deadline tasks are being displayed.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-table.el (org-table-eval-formula): Replace $# and @# by
+ current column and row number.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-set-property, org-delete-property): Go back to
+ prompting for the property.
+
+ * org-latex.el (org-export-latex-make-header): Fully process
+ author line.
+ (org-export-latex-fontify-headline): Allow several arguments, not
+ just one.
+ (org-export-latex-fix-inputenc): Catch the error when
+ `latexenc-coding-system-to-inputenc' is not defined.
+
+ * org-agenda.el (org-agenda-skip-if-todo): New function.
+ (org-agenda-skip-if): Add conditions for TODO keywords.
+ (org-agenda-skip-if): Document the new todo conditions.
+
+2010-04-10 Mikael Fornius <mfo@abc.se>
+
+ * org.el (org-at-property-p): Check if we are inside a property
+ drawer not just any drawer.
+ (org-set-property, org-delete-property): When cursor is on a
+ property key value pair do not prompt for property name instead
+ use name at cursor.
+ (org-ctrl-c-ctrl-c): Still do org-property-action when cursor is
+ on the first line of a property drawer.
+ (org-property-end-re): Spell check.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-exp.el (org-export-attach-captions-and-attributes): Add the
+ properties to the entire table, in case the first line is
+ removed.
+
+ * org-archive.el (org-archive-reversed-order): New option.
+ (org-archive-subtree, org-archive-to-archive-sibling): Use the new
+ option `org-archive-reversed-order'.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-agenda-entry-types): New variable.
+ (org-agenda-list): Use `org-agenda-entry-types'.
+ (org-agenda-custom-commands-local-options): Support for setting
+ `org-agenda-entry-types' as an option.
+ (org-diary): Shift some documentation from here to the variable
+ `org-agenda-entry-types'.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-export-latex-make-header): Apply macros in
+ author field.
+
+ * org-clock.el (org-clocking-buffer, org-clocking-p): New function.
+ (org-clock-select-task, org-clock-notify-once-if-expired)
+ (org-clock-in, org-clock-out, org-clock-cancel, org-clock-goto)
+ (org-clock-out-if-current, org-clock-save): Use the new functions.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-docbook.el (org-export-as-docbook): Remove unnecessary
+ newline.
+ (org-export-as-docbook): Remove unnecessary newline.
+ (org-export-as-docbook): Fix problem with double footnote
+ reference in one place.
+
+ * org-exp.el (org-export-format-source-code-or-example): Remove
+ unnecessary newline.
+
+ * org.el (org-deadline, org-schedule): Allow rescheduling entries
+ with repeaters.
+
+ * org-table.el (org-table-convert-refs-to-rc): Better way to catch
+ function calls that look like references.
+
+ * org.el (org-open-at-point): Get link abbreviations from
+ reference buffer.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-table.el (org-table-convert-refs-to-rc): Do not read arctan2
+ as a reference.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-link-unescape): Solve issue with lower-case escapes.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-export-latex-classes): Add
+ \usepackage{latexsym} to all classes.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-html.el (org-export-as-html): Do not allow protected lines
+ into the table of contents.
+
+ * org-latex.el (org-export-latex-special-chars): Find subsequent
+ occurrences of special characters.
+ (org-export-latex-tables): Do not convert table-like stuff that is
+ protected.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-list.el (org-toggle-checkbox): No errors when updating
+ checkbox count fails because there is no heading.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-clock.el (org-clock-report-include-clocking-task): New
+ option.
+ (org-clock-sum): Add the current clocking task.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-cycle): Print a message when in a table.el table.
+ (org-edit-special): Recognize the table.el context.
+ (org-ctrl-c-ctrl-c): Print a message when in a table.el table.
+
+ * org-src.el (org-at-table.el-p): Declare.
+ (org-edit-src-code): Handle a special case for table.el editing.
+ (org-edit-src-find-region-and-lang): Recognize the table.el
+ context.
+
+ * org-latex.el (org-export-latex-tables): Convert table.el
+ tables.
+ (org-export-latex-convert-table.el-table): New function.
+
+ * org-html.el (org-html-expand): Fix table.el export.
+
+ * org-latex.el (org-export-latex-preprocess): Protect footnotes in
+ headings.
+
+ * org-id.el (org-id-find-id-file): Fix bug when there is no hash
+ table for the id locations.
+
+ * org.el (org-read-date-analyze): Match American-style dates, like
+ 5/30 or 5/13/7. Make sure cal-iso.el is loaded. Don't force he
+ current year when reading ISO and American dates.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-face-from-face-or-color): New function.
+ (org-get-todo-face, org-font-lock-add-priority-faces)
+ (org-get-tag-face): Use `org-face-from-face-or-color'.
+
+ * org-faces.el (org-todo-keyword-faces, org-priority-faces): Allow
+ simple colors as values.
+ (org-faces-easy-properties): New option.
+
+ * org-agenda.el (org-agenda-set-mode-name): Show if the agenda is
+ restricted, as an agenda mode.
+ (org-agenda-fontify-priorities): Allow simple colors as values.
+
+2010-04-10 Bastien Guerry <bzg@altern.org>
+
+ * org-timer.el (org-timer-current-timer): Rename from
+ `org-timer-last-timer'.
+ (org-timer-timer1, org-timer-timer2, org-timer-timer3): Remove.
+ (org-timer-cancel-timer, org-timer-show-remaining-time)
+ (org-timer-set-timer): Update to use only one timer.
+
+ * org.el (org-set-property): Remove useless space in the prompt.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-html.el (org-export-html-style-default): Add a default style
+ for textareas.
+
+ * org-exp.el (org-export-format-source-code-or-example): Fix
+ textarea tag.
+
+2010-04-10 Bastien Guerry <bzg@altern.org>
+
+ * org-clock.el (org-clock-current-task): New variable to store
+ last clocked in task.
+ (org-clock-set-current, org-clock-delete-current): New functions.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-remember.el (org-remember-apply-template): Extend comment.
+ (org-remember-handler): Implement clock sibling filing.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-publish.el (org-publish-all, org-publish-current-file)
+ (org-publish-current-project): When called with prefix argument
+ FORCE, also rebuild the validation file list.
+
+ * org-latex.el (org-export-latex-preprocess): Protect footnotes in
+ section headings.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-html.el (org-export-as-html-and-open): Kill product buffer
+ if the user wants that.
+
+ * org-latex.el (org-export-as-pdf-and-open): Kill product buffer
+ if the user wants that.
+
+ * org-exp.el (org-export-kill-product-buffer-when-displayed): New
+ option.
+
+ * org-agenda.el (org-batch-agenda-csv): Use the time property
+ instead of the `time-of-day' property.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-timer.el (org-timer-start-hook, org-timer-stop-hook)
+ (org-timer-pause-hook, org-timer-set-hook)
+ (org-timer-cancel-hook): New hooks.
+ (org-timer-start): Run `org-timer-start-hook'.
+ (org-timer-pause-or-continue): Run `org-timer-pause-hook'.
+ (org-timer-stop): Run `org-timer-stop-hook'.
+ (org-timer-cancel-timers): Run `org-timer-cancel-hook'.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-reveal): Double prefix arg shows the subtree of the
+ parent.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-search-view): Fix bug with searching full
+ words in headlines in search view.
+ (org-agenda-skip-deadline-prewarning-if-scheduled): New option.
+ (org-agenda-get-deadlines): Suppress pre-warning if the entry is
+ scheduled (if the user configures it so.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-hide-archived-subtrees): Don't jump to end of
+ subtree if the match was not in a headline.
+ (org-inside-latex-macro-p): Allow more complex arguments.
+ (org-emphasize): Protect against use at end of buffer.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-agenda-align-tags): Avoid side effects on
+ text properties.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-agenda-todo-ignore-scheduled): More allowed
+ values.
+ (org-agenda-todo-ignore-scheduled)
+ (org-agenda-todo-ignore-deadlines): More control with different
+ allowed values.
+ (org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item):
+ Honor the new option settings.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-get-location): Make sure the selection buffer is
+ shown in the current frame.
+
+ * org-ascii.el (org-export-ascii-table-widen-columns): New
+ option.
+ (org-export-ascii-preprocess): Realign tables to remove narrowing
+ if `org-export-ascii-table-widen-columns' is set.
+
+ * org-table.el (org-table-do-narrow): New variable.
+ (org-table-align): Narrow only if `org-table-do-narrow' is t.
+
+ * org.el (org-deadline, org-schedule): Allow updating if the
+ relevant time stamp does not have a repeater, i.e. do not require
+ that no time stamp has a repeater.
+
+ * org-agenda.el (org-agenda-align-tags): Don't add a face to the
+ new white space before the tags.
+
+ * org-latex.el (org-export-as-latex): Do nit require the buffer to
+ be visiting a file when only exporting to a buffer or string.
+ (org-export-latex-fix-inputenc): Only save the buffer is there is
+ a file name attached to it.
+
+2010-04-10 Dan Davison <davison@stats.ox.ac.uk>
+
+ * org-src.el (org-edit-src-exit): Widen before exiting edit buffers.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-fontify-meta-lines-and-blocks): Honor
+ `org-fontify-quote-and-verse-blocks'.
+
+ * org-faces.el (org-fontify-quote-and-verse-blocks): New option.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-open-at-point): Also check for text property
+ org-linked-text before offering collected links.
+
+2010-04-10 Stephen Eglen <stephen@gnu.org>
+
+ * org-agenda.el (org-agenda-add-entry-to-org-agenda-diary-file):
+ Optionally extract time specification from text and add to the
+ timestamp.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-exp.el (org-html-entities): Fix typo.
+
+ * org-latex.el (org-export-latex-make-header): Use \providecommand
+ to make sure the \alert macro is defined.
+
+ * org.el (org-format-latex-signal-error)
+ (org-create-formula-image): Use `org-format-latex-signal-error'.
+
+2010-04-10 Stephen Eglen <stephen@gnu.org>
+
+ * org.el (org-store-link): For dired buffers, use
+ default-directory as link name if dired-get-filename returns
+ nil.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-exp.el (org-export-concatenate-multiline-links): The for
+ protectedness at beginning of match.
+
+ * org-latex.el (org-export-latex-fix-inputenc): Never leave the
+ AUTO as a coding system, instead default to utf8.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-block-todo-from-children-or-siblings-or-parent)
+ (org-block-todo-from-checkboxes): Respect the local variable
+ value when deciding if blocking should be active.
+
+ * org-latex.el (org-export-latex-make-header): Define the align
+ macro if it is not yet defined.
+
+ * org-agenda.el (org-agenda-insert-diary-make-new-entry): Call
+ `org-insert-heading' with the INVISIBLE-OK argument.
+
+ * org-mac-message.el (org-mac-message-insert-flagged): Call
+ `org-insert-heading' with the INVISIBLE-OK argument.
+
+ * org.el (org-insert-heading): New argument INVISIBLE-OK.
+
+ * org-agenda.el (org-agenda-view-mode-dispatch): Improve the
+ prompt message.
+
+ * org-html.el (org-html-level-start): Use the
+ `html-container-class' text property to set an additional class
+ for an outline container.
+
+ * org-exp.el (org-export-remember-html-container-classes): New
+ function.
+ (org-export-preprocess-string): Call
+ `org-export-remember-html-container-classes'.
+
+ * org.el (org-cycle): Mention level cycling in the docstring.
+ (org-default-properties): Add new property HTML_CONTAINER_CLASS.
+
+ * org-remember.el (org-remember-apply-template): Do file insertion
+ first.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-habit.el (org-habit-insert-consistency-graphs): Fix a
+ problem with mis-aligned graphs when showing habits.
+
+2010-04-10 Mikael Fornius <mfo@abc.se>
+
+ * org.el (org-assign-fast-keys): Prefer keys used in keyword name
+ when assigning. Begin using numerical characters when all in name
+ is used up. This is to spare alphanumeric characters for better
+ match with other keywords.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-exp.el (org-export-preprocess-hook): Improve documentation.
+
+ * org-latex.el (org-export-latex-preprocess): More consistent
+ conversion and protection of the words LaTeX and TeX.
+ (org-export-latex-fontify-headline, org-export-latex-preprocess):
+ Allow angle brackets in commands, for beamer.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-clock.el (org-clock-in): Improve the look of the clock line
+ by formatting links.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-export-latex-classes): Use AUTO as the place
+ holder string for the coding system. And improve the
+ documentation.
+ (org-export-latex-fix-inputenc): Only modify the coding system if
+ it is given by the placeholder AUTO.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-clock.el (org-task-overrun-text): New option.
+ (org-task-overrun, org-clock-update-period): New variables.
+ (org-clock-get-clock-string, org-clock-update-mode-line): Mark
+ overrun clock.
+ (org-clock-notify-once-if-expired): Check if clock is overrun.
+
+ * org-faces.el: New face `org-mode-line-clock-overrun'.
+
+2010-04-10 Jan Böcker <jan.boecker@jboecker.de>
+
+ * org.el (org-narrow-to-subtree): Position the end of the narrowed
+ region before the line with the next heading, to prevent the user
+ from prepending text to the next headline.
+
+2010-04-10 Stephen Eglen <stephen@gnu.org>
+
+ * org-agenda.el (org-get-time-of-day): Use
+ org-agenda-time-leading-zero to allow leading zero (rather than
+ space) for times.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-agenda-diary-entry-in-org-file): Make sure
+ org-datetree.el is loaded.
+
+ * org-datetree.el: Autoload `org-datetree-find-day-create'.
+
+ * org-latex.el (org-export-latex-hyperref-format): New option.
+ (org-export-latex-links): Use `org-export-latex-hyperref-format'.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-ctags.el (org-ctags-enable): Change order of functions.
+ (org-ctags-create-tags): Add wildcard to file name expansion.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-entry-properties): Fix some important bugs.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-link-unescape, org-link-escape): Only use hexlify if
+ the table is not explicitly given.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-clock.el (org-clock-out-when-done): Allow a list of keywords
+ as value.
+ (org-clock-out-if-current): Work with the new list value of
+ `org-clock-out-when-done'.
+ (org-clock-out, org-clock-out-if-current): Avoid circular logic
+ between clocking out and state changes.
+
+ * org-ctags.el (org-ctags-path-to-ctags): Better system-type test.
+
+ * org-latex.el (org-export-latex-treat-backslash-char): Do not by
+ accident protect a character that is before a backslash.
+
+2010-04-10 Paul Sexton <eeeickythump@gmail.com>
+
+ * org-ctags.el: New file.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-diary-class): Use
+ `org-order-calendar-date-args'.
+
+ * org.el (org-order-calendar-date-args): New function.
+
+ * org-exp.el (org-export-target-internal-links): Check for
+ protectedness after the first bracket.
+
+ * org.el (org-entry-properties): Don't match wrong-case TODO
+ keywords.
+
+ * org-agenda.el (org-agenda-schedule, org-agenda-deadline):
+ Document that ARG is passed through to remove the date.
+ (org-agenda-bulk-action): Accept prefix arg and pass it on. Do
+ not read a date when the user has given a `C-u' prefix.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-agenda-fix-displayed-tags): Fix bug when all
+ tags are hidden.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-export-latex-fix-inputenc): New function.
+ (org-export-latex-inputenc-alist): New option.
+
+ * org-exp.el (org-export): New key SPC to publish enclosing
+ subtree.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-indent.el (org-indent-add-properties): Catch case when there
+ is no headline in the buffer.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-exp.el (org-html-entities): Add checkmark symbol.
+
+ * org-ascii.el (org-export-ascii-preprocess): Protect targets in
+ verbatim code for ASCII export.
+
+ * org.el (org-update-statistics-cookies): Also see checkboxes in
+ ordered lists.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-agenda-view-mode-dispatch): Define the `L'
+ key.
+
+ * org-beamer.el (org-beamer-amend-header): Change the location
+ where `org-beamer-header-extra' is inserted.
+
+ * org.el (org-compute-latex-and-specials-regexp): Don't do BIND
+ just for computing this regexp.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-beamer.el (org-beamer-frame-default-options): New option.
+ (org-beamer-sectioning): Use default options if the user does not
+ have defined any.
+ (org-beamer-fix-toc): Put a frame around the table of contents.
+
+ * org-exp.el (org-export-remove-comment-blocks-and-subtrees): Make
+ sure case-folding works well when processing comment stuff.
+
+ * org-latex.el (org-export-latex-after-save-hook): New hook.
+ (org-export-as-latex): Run the new hook.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-beamer.el (org-beamer-environments-default): Add the note
+ environments.
+ (org-beamer-after-initial-vars): Allow several BEAMER_HEADER_EXTRA
+ lines and collect and combine the content.
+ (org-beamer-after-initial-vars): Check for note tags and make sure
+ they will be seen like a property.
+
+ * org.el (org-offer-links-in-entry): Fix bug when there is a
+ single link.
+
+ * org-exp.el (org-export): Make sure the mark is activated, also
+ when `transient-mark-mode' is off.
+
+ * org-agenda.el (org-agenda-search-view-always-boolean): New option.
+ (org-agenda-search-view-search-words-only): Obsolete variable, is
+ now an alias for `org-agenda-search-view-always-boolean'.
+ (org-agenda-search-view-force-full-words): New option.
+ (org-search-view): Improve docstring, and implement a better logic
+ for Boolean and phrase searches.
+ (org-agenda-last-search-view-search-was-boolean): New variable.
+ (org-agenda-manipulate-query): Consider the type of the last
+ search when modifying the search string.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-export-as-latex): Do the first letbind in the
+ right moment.
+
+ * org-agenda.el (org-get-entries-from-diary): Add the new face to
+ these entries.
+
+ * org-faces.el (org-agenda-diary): New face.
+
+ * org.el (org-make-link-regexps): Allow regexp-special characters
+ in link types.
+ (org-open-file): When in-emacs is `system', also force system
+ opening, like when the value was `(16)'.
+ (org-update-statistics-cookies): Handle entries without children.
+
+ * org-exp.el
+ (org-export-preprocess-before-normalizing-links-hook): New hook.
+ (org-export-preprocess-string): Run the new hook.
+
+ * org.el (org-offer-links-in-entry): Make RET open all links.
+
+ * org-html.el (org-export-as-html): Remove any leftover display
+ properties in the html file.
+
+ * org-wl.el (org-wl-store-link): Work-around for format bug with
+ text properties.
+
+ * org-habit.el (org-habit-insert-consistency-graphs): Turn off
+ invisibility while adding the graphs.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-remember.el (org-select-remember-template): Use C letter to
+ customize remember templates.
+
+ * org-agenda.el (org-agenda-bulk-mark, org-agenda-bulk-unmark):
+ Move cursor to next visible line.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-beamer.el (org-beamer-sectioning): Leave columns environment
+ by specifying 0 or 1 for column width.
+ (org-beamer-column-widths): Make 0 stand for 0.0.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-exp.el (org-export-mark-radio-links): Don't match inside
+ <<target>>.
+
+ * org.el (org-format-latex-header-extra): New variable.
+ (org-format-latex): Set org-format-latex-header-extra from
+ in-buffer stuff.
+ (org-format-latex): Add org-format-latex-header-extra to the
+ variables on which image creation depends.
+ (org-create-formula-image): Add the header stuff from in-buffer
+ settings.
+ (org-read-date-analyze): Base the analysis for future preference
+ on NOW, not on the default date.
+
+ * org-inlinetask.el (org-inlinetask-export-handler): Add CSS class
+ for TODO keyword in inline tasks.
+
+ * org.el (org-log-note-headings): New headings for removing
+ deadline or scheduling date.
+ (org-deadline, org-schedule): Arrange for logging when removing a
+ date.
+ (org-add-log-note): Handle deadline and scheduling removal.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-exp.el (org-export-visible): Add LaTeX/pdf export.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-diary-class): New function.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-export-latex-preprocess): Do process the text
+ of a radio target.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-entry-properties): Add TIMESTAMP properties back
+ in.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-all-time-keywords): New variable.
+ (org-set-regexps-and-options): Set `org-all-time-keywords'.
+ (org-entry-blocked-p): New function.
+ (org-special-properties): Add BLOCKED as a new special property.
+ (org-entry-properties): New optional argument SPECIFIC, only parse
+ for this property when it is specified.
+ (org-entry-get): Pass a SPECIFIC argument to
+ `org-entry-properties'.
+
+ * org-latex.el (org-export-as-latex): Preprocess TEXT as well.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-export-latex-tables): No forced line end if
+ there is no caption.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-exp.el (org-html-entities): Add Euro symbols from Marvosym
+ package.
+
+ * org-latex.el (org-export-latex-tables): Only add a caption when
+ macro in in longtable environments if one has been defined.
+
+ * org-html.el (org-export-as-html): Only take title from buffer if
+ not exporting body-only.
+
+ * org-latex.el (org-export-latex-preprocess): Better version of
+ the regular expression for protecting LaTeX macros.
+ (org-export-latex-preprocess): Start searching for macros to
+ protect from beginning of buffer.
+
+ * org-exp.el (org-export-target-internal-links): Check for
+ protectedness earlier in the string.
+
+ * org-agenda.el (org-agenda-highlight-todo): Match TODO keywords
+ case sensitively.
+
+ * org-id.el (org-id-store-link): Match TODO keywords case
+ sensitively.
+
+ * org.el (org-heading-components, org-get-outline-path)
+ (org-display-outline-path): Match TODO keywords case sensitively.
+
+ * org-latex.el (org-export-as-latex): Ignore read-only
+ properties.
+
+ * org-exp.el (org-export-preprocess-string): Remove any
+ `read-only' properties.
+
+ * org-agenda.el (org-agenda-inactive-leader): New option.
+ (org-agenda-get-timestamps): Use `org-agenda-inactive-leader'.
+ (org-tags-view): Prompt for matcher if MATCH is an empty string.
+ (org-todo-list): Prompt for matcher if ARG is an empty string.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-open-link-functions): New hook.
+ (org-open-at-point): Run `org-open-link-functions'.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-agenda.el (org-agenda-date-prompt): Allow inactive time
+ stamps as well.
+
+ * org.el (org-inhibit-startup-visibility-stuff): New variable.
+ (org-mode): Don't do startup visibility if inhibited.
+ (org-outline-overlay-data, org-set-outline-overlay-data): New
+ functions.
+ (org-save-outline-visibility): New macro.
+ (org-log-note-headings): Document that one should not change the
+ `state' note format.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-make-link-regexps): Capture link path into a group.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-beamer.el (org-beamer-after-initial-vars): Do not overwrite
+ the options plist.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org.el (org-startup-with-beamer-mode): New option.
+ (org-property-changed-functions)
+ (org-property-allowed-value-functions): New hooks.
+ (org-entry-put, org-property-get-allowed-values): Run the new
+ hooks.
+ (org-property-next-allowed-value): Run the new hooks.
+
+ * org-exp.el (org-export-select-backend-specific-text): Add the
+ special beamer tags.
+
+ * org-beamer.el: New file.
+
+ * org-latex.el (org-export-latex-after-initial-vars-hook): New hook.
+ (org-export-as-latex): Run
+ `org-export-latex-after-initial-vars-hook'.
+ (org-export-latex-format-toc-function)
+ (org-export-latex-make-header): Call
+ `org-export-latex-format-toc-function'.
+
+ * org.el (org-fill-template): Make template searches case sensitive.
+
+ * org-exp.el (org-export): Use "1" as a sign to export only the
+ subtree.
+
+ * org-colview-xemacs.el (org-columns-edit-value): Use
+ org-unrestricted property.
+
+ * org-colview.el (org-columns-edit-value): Use
+ org-unrestricted property.
+
+ * org.el (org-compute-property-at-point): Set org-unrestricted
+ text property if the list contains ":ETC".
+ (org-insert-property-drawer): Use
+ org-unrestricted property.
+
+ * org-exp.el
+ (org-export-preprocess-before-selecting-backend-code-hook): New hook.
+ (org-export-preprocess-string): Run
+ `org-export-preprocess-before-selecting-backend-code-hook'.
+
+ * org-xoxo.el (org-export-as-xoxo): Run `org-export-first-hook'.
+
+ * org-latex.el (org-export-region-as-latex): Run
+ `org-export-first-hook'.
+
+ * org-html.el (org-export-as-html): Run `org-export-first-hook'.
+
+ * org-docbook.el (org-export-as-docbook): Run
+ `org-export-first-hook'.
+
+ * org-ascii.el (org-export-as-ascii): Run `org-export-first-hook'.
+
+ * org-exp.el (org-export-first-hook): New hook.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-list.el (org-previous-item): Exit at the beginning of the
+ buffer.
+
+ * org-id.el (org-id-locations-save): Only write the id locations
+ if any are defined.
+
+ * org-archive.el (org-archive-all-done): Make this work in a file
+ with org-odd-levels-only set.
+
+ * org.el (org-get-refile-targets): Catch the case when a buffer
+ has no file.
+
+ * org-latex.el (org-export-as-latex): Cleanup forced line ends
+ where they are not needed.
+ (org-export-latex-subcontent): Remove unnecessary newlines.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-export-latex-make-header): Remove \obeylines.
+ (org-export-latex-fontify): Fix regexp bug that takes special
+ care of protecting the right boundary characters in emphasis
+ matches.
+ (org-export-latex-preprocess): Allow multiple arguments to latex
+ macros.
+
+ * org.el (org-make-link-regexps): Use John Gruber's regexp for
+ urls.
+
+ * org-macs.el (org-re): Interpret :punct: in regexps.
+
+ * org-exp.el (org-export-replace-src-segments-and-examples): Also
+ take the final newline after the END line.
+
+ * org.el (org-clean-visibility-after-subtree-move): Only fix
+ entries that are not entirely invisible already.
+ (org-insert-link): Respect org-link-file-path-type for
+ "docview:" links in addition to "file:" links.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-exp.el (org-export-format-source-code-or-example): Avoid
+ additional extra white lines in LaTeX.
+
+ * org-list.el (org-list-parse-list): Leave empty lines after the
+ list, don't consider them as part of the list.
+
+ * org-mobile.el (org-mobile-sumo-agenda-command): Allow tagstodo
+ searches.
+
+ * org-clock.el (org-clock-select-task): Convert integer to
+ character for XEmacs.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-clock.el (org-clock-resolve): Make reading a char XEmacs
+ compatible.
+
+2010-04-10 Tassilo Horn <tassilo@member.fsf.org>
+
+ * org.el (org-complete-tags-always-offer-all-agenda-tags): New
+ variable.
+ (org-set-tags): Use it.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-list.el (org-empty-line-terminates-plain-lists): Update
+ docstring.
+
+ * org.el (org-format-latex): Fix link creation for processed latex
+ snippets.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-footnote.el (org-footnote-normalize): Protect replacement
+ text.
+
+ * org.el (org-inside-latex-macro-p): Save match data.
+
+2010-04-10 Jan Böcker <jan.boecker@jboecker.de>
+
+ * org-docview.el: New file.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-export-latex-class-options): New variable.
+ (org-export-latex-set-initial-vars): Use the class options.
+
+ * org.el (org-forward-same-level): Stop at headings that start
+ with an invisible character.
+ (org-additional-option-like-keywords): Add LaTeX_CLASS_OPTIONS.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-footnote.el (org-footnote-normalize): Don't take optional
+ arguments in LaTeX macros as footnotes.
+
+ * org.el (org-inside-latex-macro-p): New function.
+
+ * org-latex.el (org-latex-to-pdf-process): Change customization
+ group to `org-export-pdf'.
+
+ * org-agenda.el (org-agenda-get-blocks): Look at time string also
+ on days after the first one.
+
+ * org.el (org-insert-heading): Also check for item before assuming
+ before-first-heading condition.
+
+ * org-latex.el (org-latex-to-pdf-process): Fix typo in group tag.
+ (org-export-pdf-logfiles): New option.
+ (org-export-as-pdf): Use `org-export-pdf-logfiles'.
+ (org-export-pdf-logfiles): Fix customization type.
+
+ * org.el (org-insert-link): Improve error message when there is no
+ default link to select with RET.
+
+ * org-agenda.el (org-agenda-filter-by-tag): Use char argument from
+ parameter list.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-export-latex-parse-global)
+ (org-export-latex-parse-content)
+ (org-export-latex-parse-subcontent): Use
+ `org-re-search-forward-unprotected'.
+ (org-export-as-pdf): Remove log files produced by XeTeX.
+
+ * org-macs.el (org-re-search-forward-unprotected): New function.
+
+2010-04-10 James TD Smith <ahktenzero@mohorovi.cc>
+
+ * org-colview.el (org-agenda-colview-summarize): Sort out some
+ confusion between properties and titles, which resulted in
+ agenda summaries not working if a title was set for a column.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-mobile.el (org-mobile-agendas): New option.
+ (org-mobile-sumo-agenda-command): Select the right agendas.
+
+ * org-latex.el (org-export-latex-format-image): Preserve the
+ original-indentation property.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-clock.el (org-clock-insert-selection-line): Catch error when
+ an old tasks no longer exists.
+
+ * org-latex.el (org-export-as-pdf): Remove also the .idx file.
+ (org-export-as-pdf): Don't remove the old PDF file before making
+ the new one.
+
+ * org-mouse.el (org-mouse-end-headline, org-mouse-insert-item)
+ (org-mouse-context-menu): Use `org-looking-back'.
+
+ * org.el (org-cycle-level): Use `org-looking-back'.
+
+ * org-list.el (org-cycle-item-indentation): Use
+ `org-looking-back'.
+
+ * org-compat.el (org-looking-back): New function.
+
+ * org.el (org-insert-heading): Catch before-first-headline when
+ inserting a headline.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-latex.el (org-export-latex-format-image): Indent figure
+ environment, so that it does not interrupt plain list.
+
+ * org.el (org-open-at-point): Allow long link descriptions.
+
+2010-04-10 Carsten Dominik <carsten.dominik@gmail.com>
+
+ * org-html.el (org-export-as-html): Remove empty lines at the
+ beginning of the exported text.
+
+2010-03-12 Chong Yidong <cyd@stupidchicken.com>
+
+ * org.el (org): Remove from hypermedia group.
+
+2010-03-10 Chong Yidong <cyd@stupidchicken.com>
+
+ * Branch for 23.2.
+
2010-02-15 Chong Yidong <cyd@stupidchicken.com>
* org-freemind.el (org-freemind-from-org-mode-node)
@@ -312,16 +6242,15 @@
2009-11-13 Dan Davison <davison@stats.ox.ac.uk>
- * org-exp.el (org-export-format-source-code-or-example): restrict
+ * org-exp.el (org-export-format-source-code-or-example): Restrict
scope of preserve-indentp to the let binding.
- (org-src): require org-src, since org-src-preserve-indentation is used.
+ (org-src): Require org-src, since org-src-preserve-indentation is used.
2009-11-13 Carsten Dominik <carsten.dominik@gmail.com>
* org-timer.el (org-timer-set-timer): Set variables
org-timer-timer[123] correctly.
-
* org-mobile.el (org-mobile-files-alist): Make it work when
`agenda-archives' is included in
`org-agenda-text-search-extra-files'.
@@ -384,7 +6313,7 @@
2009-11-13 James TD Smith <ahktenzero@mohorovi.cc>
- * org-colview-xemacs.el: Add in changes from org-colview.el
+ * org-colview-xemacs.el: Add in changes from org-colview.el.
2009-11-13 Dan Davison <davison@stats.ox.ac.uk>
@@ -525,12 +6454,12 @@
point.
(org-columns-compile-map): There is now an extra position in each
entry specifying the function to use to calculate the displayed
- value for the non-calculated properties in the column,
+ value for the non-calculated properties in the column.
(org-columns-compute-all): Set `org-columns-time' to the current
time so time difference calculations will work.
(org-columns-compute): Handle column operators where the values
used are calculated from the underlying property.
- (org-columns-number-to-string): Handle the 'age' column format
+ (org-columns-number-to-string): Handle the 'age' column format.
(org-columns-string-to-number): Correct the function name (was
org-column...). Add support for the 'age' column format.
(org-columns-compile-format): Support the additional parameter in
@@ -591,7 +6520,7 @@
called with either `org-scheduled-string' or
`org-deadline-string'.
- * org-clock.el (org-clock-auto-clock-resolution): Renamed
+ * org-clock.el (org-clock-auto-clock-resolution): Rename from
`org-clock-disable-clock-resolution', since negatives don't sound
good in customization variables.
(org-clock-in): Don't use the auto-resolution logic if the user is
@@ -633,14 +6562,14 @@
more general.
(org-habit-parse-todo): Parse the new ".+N/N" style repeater.
- * org-agenda.el (org-agenda-get-deadlines): Removed all mention of
+ * org-agenda.el (org-agenda-get-deadlines): Remove all mention of
habits, since they don't use DEADLINE anymore.
* org.el (org-repeat-re, org-display-custom-time)
- (org-timestamp-change): Extended to support the new ".+N/N"
+ (org-timestamp-change): Extend to support the new ".+N/N"
syntax, used for habits.
- * org-clock.el (org-clock-resolve-clock): Fixed an incorrect
+ * org-clock.el (org-clock-resolve-clock): Fix an incorrect
variable reference.
* org-agenda.el (org-agenda-set-mode-name): Show Habit in the
@@ -674,7 +6603,7 @@
* org.el (org-file-tags): Fix docstring.
(org-get-buffer-tags): Add the #+FILETAGS tags.
- ("ecb"): Maks ecb show context after jumping into an Org file.
+ ("ecb"): Make ecb show context after jumping into an Org file.
2009-11-13 John Wiegley <johnw@newartisans.com>
@@ -705,11 +6634,11 @@
(org-agenda-get-scheduled): Display consistency graphs when
outputting habits into the agenda. The graphs are always relative
to the current time.
- (org-format-agenda-item): Added new parameter `habitp', which
+ (org-format-agenda-item): Add new parameter `habitp', which
indicates whether we are formatting a habit or not. Do not
display "extra" leading information if habitp is true.
- * org.el (org-repeat-re): Improved regexp to include .+ and ++
+ * org.el (org-repeat-re): Improve regexp to include .+ and ++
leaders for repeat strings.
(org-get-repeat): Now takes a string parameter `tagline', so the
caller can obtain the SCHEDULED repeat, or the DEADLINE repeat.
@@ -727,7 +6656,7 @@
* org.el (org-files-list): Don't attempt to return a file name for
Org buffers which have no associated file.
- * org-agenda.el (org-agenda-do-action): Fixed a typo.
+ * org-agenda.el (org-agenda-do-action): Fix a typo.
2009-11-13 Carsten Dominik <carsten.dominik@gmail.com>
@@ -749,7 +6678,7 @@
* org-clock.el (org-clock-resolve, org-resolve-clocks)
(org-emacs-idle-seconds): Use `org-float-time' instead of
- `time-to-seconds'
+ `time-to-seconds'.
2009-11-13 Carsten Dominik <carsten.dominik@gmail.com>
@@ -777,7 +6706,7 @@
currently active clock if the user has exceeded the time returned
by `org-user-idle-seconds', based on the value of
`org-clock-idle-time'.
- (org-clock-in): If, after resolving clocks,
+ (org-clock-in): If, after resolving clocks, (???)
(org-clock-out): Cancel the `org-clock-idle-timer' on clock out.
* org-clock.el (org-clock-resolve-clock): New function that
@@ -918,7 +6847,7 @@
* org-exp.el (org-export-select-backend-specific-text): Remove the
region markers.
- * org-inlinetask.el (org-inlinetask-export-handler): fix bug for
+ * org-inlinetask.el (org-inlinetask-export-handler): Fix bug for
tasks without content.
* org-clock.el: Make sure the clock-in target position does not
@@ -1207,7 +7136,7 @@
2009-10-01 Bastien Guerry <bzg@altern.org>
- * org.el (org-check-agenda-file): Use a more explicit message
+ * org.el (org-check-agenda-file): Use a more explicit message.
2009-10-01 Carsten Dominik <carsten.dominik@gmail.com>
@@ -1586,7 +7515,7 @@
* org-exp.el (org-export-format-source-code-or-example): Translate
language.
- * org-src.el (org-src-lang-modes): New variable
+ * org-src.el (org-src-lang-modes): New variable.
(org-edit-src-code): Translate language.
* org-exp.el (org-export-format-source-code-or-example): Deal wit
@@ -1714,7 +7643,7 @@
the markup is src or example.
* org-agenda.el (org-agenda-skip-scheduled-if-deadline-is-shown):
- New option
+ New option.
(org-agenda-get-day-entries): Remember deadline results and pass
them on into the function getting the scheduling information.
(org-agenda-get-scheduled): Accept deadline results as parameters
@@ -1725,7 +7654,7 @@
convert current line to headline.
* org-clock.el (org-clock-save-markers-for-cut-and-paste): Also
- cheeeeeck the hd marker
+ cheeeeeck the hd marker.
(org-clock-in): Also set the hd marker.
(org-clock-out): Also set the hd marker.
(org-clock-cancel): Reset markers.
@@ -1735,7 +7664,7 @@
* org-faces.el (org-agenda-clocking): New face.
* org-agenda.el (org-agenda-mark-clocking-task): New function.
- (org-finalize-agenda): call `org-agenda-mark-clocking-task'.
+ (org-finalize-agenda): Call `org-agenda-mark-clocking-task'.
* org.el (org-modules): Add org-track.el.
@@ -1947,9 +7876,9 @@
2009-08-06 Bastien Guerry <bzg@altern.org>
* org.el (org-make-link-regexps): Don't exclude parentheses from
- `org-plain-link-re'
+ `org-plain-link-re'.
(org-cycle-internal-local): When locally cycling, switch directly
- from CHILDREN to FOLDED if there is no subtree
+ from CHILDREN to FOLDED if there is no subtree.
(org-cycle): Update the docstring to document the new behavior of
`org-cycle-internal-local'.
@@ -2458,8 +8387,8 @@
* org.el (org-global-properties-fixed): Add default for
CLOCK_MODELINE_TOTAL.
- * org-clock.el (org-clock-sum): Accept lists and strigs as tstart
- andd tend.
+ * org-clock.el (org-clock-sum): Accept lists and strings as tstart
+ and tend.
(org-clock-sum-current-item): Optional argument TSTART, pass it to
org-clock-sum.
(org-clock-get-sum-start): New function.
@@ -2540,7 +8469,7 @@
(org-set-font-lock-defaults): Call the new fontification
function.
- * org-faces.el (org-meta-line): New face
+ * org-faces.el (org-meta-line): New face.
(org-block): New face.
2009-08-06 Carsten Dominik <carsten.dominik@gmail.com>
@@ -2704,7 +8633,7 @@
2009-08-06 Carsten Dominik <carsten.dominik@gmail.com>
- * org-icalendar.el (org-icalendar-include-todo): New allowedvalue
+ * org-icalendar.el (org-icalendar-include-todo): New allowed value
`unblocked'.
(org-print-icalendar-entries): Respect the new value of
`org-icalendar-include-todo'.
@@ -2770,7 +8699,7 @@
2009-08-06 Carsten Dominik <carsten.dominik@gmail.com>
* org-exp.el (org-export, org-export-visible): Support ASCII
- export to buffer
+ export to buffer.
(org-export-normalize-links): Do not protect the description if it
is explicitly given.
@@ -3125,7 +9054,7 @@
* org-mouse.el: XEmacs compatibility fixes.
- * org.el (org-modules): Add org-inlinetasks.el
+ * org.el (org-modules): Add org-inlinetasks.el.
(org-cycle): Implement limiting level on cycling.
(org-move-subtree-down): Fix bug with swapping subtrees at end of
buffer.
@@ -3135,7 +9064,7 @@
* org.el (org-emphasis-regexp-components): Allow braces in
emphasis pre and post match.
- * org-footnote.el (org-footnote-normalize): When only dorting, do
+ * org-footnote.el (org-footnote-normalize): When only sorting, do
not insert inline notes at the end.
* org.el (org-require-autoloaded-modules): Add org-docbook.el.
@@ -3217,7 +9146,7 @@
(org-mouse-context-menu): Use `org-mouse-todo-menu'.
* org-table.el (org-table-beginning-of-field)
- (org-table-end-of-field): New commands
+ (org-table-end-of-field): New commands.
(org-table-previous-field, org-table-beginning-of-field): Better
error messages.
(orgtbl-setup): Include `M-a' and `M-e'.
@@ -3383,7 +9312,7 @@
(org-export-plist-vars): Add entries for :keywords and
:description.
(org-infile-export-plist): Parse for new keywords.
- (org-get-current-options): Add new keywords
+ (org-get-current-options): Add new keywords.
(org-export-as-html): Publish description and keywords.
* org-agenda.el (org-agenda-add-entry-text-descriptive-links): New
@@ -3569,9 +9498,9 @@
(org-export-latex-fontify): Catch error when org-emph-alist has
entries that are not defined for LaTeX export.
- * org-export-latex.el: renamed to org-latex.el.
+ * org-export-latex.el: Rename to org-latex.el.
- * org-latex.el: renamed from org-export-latex.el.
+ * org-latex.el: Rename from org-export-latex.el.
* org.el (orgstruct++-mode): New function.
(turn-on-orgstruct++): Call `orgstruct++-mode'.
@@ -4654,7 +10583,7 @@
* org-list.el (org-list-two-spaces-after-bullet-regexp): New
option.
- (org-fix-bullet-type): respect
+ (org-fix-bullet-type): Respect
`org-list-two-spaces-after-bullet-regexp'.
* org-clock.el (org-clock-load): Clean up the code.
@@ -5031,7 +10960,7 @@
* org-agenda.el (org-agenda-remove-marked-text): New function.
(org-agenda-mark-filtered-text)
(org-agenda-unmark-filtered-text): New functions.
- (org-write-agenda): Remove fltered text.
+ (org-write-agenda): Remove filtered text.
* org.el (org-make-tags-matcher): Give access to TODO "property"
without speed penalty.
@@ -5128,7 +11057,7 @@
* org.el (org-insert-heading-respect-content): Force heading
creation.
- (org-insert-heading): keep the folding state of the heading before
+ (org-insert-heading): Keep the folding state of the heading before
the inserted one.
2008-10-26 Carsten Dominik <dominik@science.uva.nl>
@@ -5199,7 +11128,7 @@
immediately after the scheduling keywords.
* org-clock.el (org-clock-in-switch-to-state): Allow this to be a
- function
+ function.
(org-clock-in): If `org-clock-in-switch-to-state' is a function,
call it with the current todo state to get the state to switch to
when clocking in.
@@ -5402,7 +11331,7 @@
line.
* org.el (org-get-refile-targets): Replace links with their
- descriptions
+ descriptions.
(org-imenu-get-tree): Replace links with their descriptions.
* org-remember.el (org-remember-apply-template): Add a new
@@ -5411,7 +11340,7 @@
* org.el (org-add-log-setup): Skip over drawers (properties,
clocks etc) when adding notes.
- * org-agenda.el (org-agenda-get-closed): show durations of clocked
+ * org-agenda.el (org-agenda-get-closed): Show durations of clocked
items as well as the start and end times.
* org-compat.el (org-get-x-clipboard-compat): Add a compat
@@ -5423,7 +11352,7 @@
set-text-properties to remove text properties from the clipboard
value.
- * lisp/org-clock.el (org-update-mode-line): Support limiting the
+ * org-clock.el (org-update-mode-line): Support limiting the
modeline clock string, and display the full todo value in the
tooltip. Set a local keymap so mouse-3 on the clock string goes to
the currently clocked task.
@@ -5437,7 +11366,7 @@
2008-10-12 Bastien Guerry <bzg@altern.org>
- * org-export-latex.el (org-export-latex-tables): protect exported
+ * org-export-latex.el (org-export-latex-tables): Protect exported
tables from further special chars conversion.
(org-export-latex-preprocess): Preserve LaTeX environments.
(org-list-parse-list): Parse descriptive lists.
@@ -5446,7 +11375,7 @@
(org-quote-chars): Remove.
(org-export-latex-keywords-maybe): Use `replace-regexp-in-string'.
(org-export-latex-list-beginning-re): Rename to
- `org-list-beginning-re'
+ `org-list-beginning-re'.
(org-list-item-begin): Rename to `org-list-item-beginning'.
2008-10-12 Eric Schulte <schulte.eric@gmail.com>
@@ -5781,7 +11710,7 @@
(org-map-entries): Make sure org-agenda-archives-mode is nil.
(org-agenda-files): Functionality of second arg changed.
- * org-agenda.el (org-agenda-archives-mode): New variable
+ * org-agenda.el (org-agenda-archives-mode): New variable.
(org-write-agenda, org-prepare-agenda, org-agenda-list)
(org-search-view, org-todo-list, org-tags-view)
(org-agenda-list-stuck-projects): Call `org-agenda-files' with
diff --git a/lisp/org/ob-C.el b/lisp/org/ob-C.el
new file mode 100644
index 00000000000..1c8eac65ace
--- /dev/null
+++ b/lisp/org/ob-C.el
@@ -0,0 +1,194 @@
+;;; ob-C.el --- org-babel functions for C and similar languages
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Org-Babel support for evaluating C code.
+;;
+;; very limited implementation:
+;; - currently only support :results output
+;; - not much in the way of error feedback
+
+;;; Code:
+(require 'ob)
+(require 'ob-eval)
+(require 'cc-mode)
+
+(declare-function org-entry-get "org"
+ (pom property &optional inherit literal-nil))
+
+(add-to-list 'org-babel-tangle-lang-exts '("c++" . "cpp"))
+
+(defvar org-babel-default-header-args:C '())
+
+(defvar org-babel-C-compiler "gcc"
+ "Command used to compile a C source code file into an
+ executable.")
+
+(defvar org-babel-c++-compiler "g++"
+ "Command used to compile a c++ source code file into an
+ executable.")
+
+(defvar org-babel-c-variant nil
+ "Internal variable used to hold which type of C (e.g. C or C++)
+is currently being evaluated.")
+
+(defun org-babel-execute:cpp (body params)
+ "Execute BODY according to PARAMS. This function calls
+`org-babel-execute:C'."
+ (org-babel-execute:C body params))
+
+(defun org-babel-execute:c++ (body params)
+ "Execute a block of C++ code with org-babel. This function is
+called by `org-babel-execute-src-block'."
+ (let ((org-babel-c-variant 'cpp)) (org-babel-C-execute body params)))
+
+(defun org-babel-expand-body:c++ (body params)
+ "Expand a block of C++ code with org-babel according to it's
+header arguments (calls `org-babel-C-expand')."
+ (let ((org-babel-c-variant 'cpp)) (org-babel-C-expand body params)))
+
+(defun org-babel-execute:C (body params)
+ "Execute a block of C code with org-babel. This function is
+called by `org-babel-execute-src-block'."
+ (let ((org-babel-c-variant 'c)) (org-babel-C-execute body params)))
+
+(defun org-babel-expand-body:c (body params)
+ "Expand a block of C code with org-babel according to it's
+header arguments (calls `org-babel-C-expand')."
+ (let ((org-babel-c-variant 'c)) (org-babel-C-expand body params)))
+
+(defun org-babel-C-execute (body params)
+ "This function should only be called by `org-babel-execute:C'
+or `org-babel-execute:c++'."
+ (let* ((tmp-src-file (org-babel-temp-file
+ "C-src-"
+ (cond
+ ((equal org-babel-c-variant 'c) ".c")
+ ((equal org-babel-c-variant 'cpp) ".cpp"))))
+ (tmp-bin-file (org-babel-temp-file "C-bin-"))
+ (cmdline (cdr (assoc :cmdline params)))
+ (flags (cdr (assoc :flags params)))
+ (full-body (org-babel-C-expand body params))
+ (compile
+ (progn
+ (with-temp-file tmp-src-file (insert full-body))
+ (org-babel-eval
+ (format "%s -o %s %s %s"
+ (cond
+ ((equal org-babel-c-variant 'c) org-babel-C-compiler)
+ ((equal org-babel-c-variant 'cpp) org-babel-c++-compiler))
+ (org-babel-process-file-name tmp-bin-file)
+ (mapconcat 'identity
+ (if (listp flags) flags (list flags)) " ")
+ (org-babel-process-file-name tmp-src-file)) ""))))
+ ((lambda (results)
+ (org-babel-reassemble-table
+ (if (member "vector" (cdr (assoc :result-params params)))
+ (let ((tmp-file (org-babel-temp-file "c-")))
+ (with-temp-file tmp-file (insert results))
+ (org-babel-import-elisp-from-file tmp-file))
+ (org-babel-read results))
+ (org-babel-pick-name
+ (cdr (assoc :colname-names params)) (cdr (assoc :colnames params)))
+ (org-babel-pick-name
+ (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params)))))
+ (org-babel-trim
+ (org-babel-eval
+ (concat tmp-bin-file (if cmdline (concat " " cmdline) "")) "")))))
+
+(defun org-babel-C-expand (body params)
+ "Expand a block of C or C++ code with org-babel according to
+it's header arguments."
+ (let ((vars (mapcar #'cdr (org-babel-get-header params :var)))
+ (main-p (not (string= (cdr (assoc :main params)) "no")))
+ (includes (or (cdr (assoc :includes params))
+ (org-babel-read (org-entry-get nil "includes" t))))
+ (defines (org-babel-read
+ (or (cdr (assoc :defines params))
+ (org-babel-read (org-entry-get nil "defines" t))))))
+ (mapconcat 'identity
+ (list
+ ;; includes
+ (mapconcat
+ (lambda (inc) (format "#include %s" inc))
+ (if (listp includes) includes (list includes)) "\n")
+ ;; defines
+ (mapconcat
+ (lambda (inc) (format "#define %s" inc))
+ (if (listp defines) defines (list defines)) "\n")
+ ;; variables
+ (mapconcat 'org-babel-C-var-to-C vars "\n")
+ ;; body
+ (if main-p
+ (org-babel-C-ensure-main-wrap body)
+ body) "\n") "\n")))
+
+(defun org-babel-C-ensure-main-wrap (body)
+ "Wrap body in a \"main\" function call if none exists."
+ (if (string-match "^[ \t]*[intvod]+[ \t\n\r]*main[ \t]*(.*)" body)
+ body
+ (format "int main() {\n%s\n}\n" body)))
+
+(defun org-babel-prep-session:C (session params)
+ "This function does nothing as C is a compiled language with no
+support for sessions"
+ (error "C is a compiled languages -- no support for sessions"))
+
+(defun org-babel-load-session:C (session body params)
+ "This function does nothing as C is a compiled language with no
+support for sessions"
+ (error "C is a compiled languages -- no support for sessions"))
+
+;; helper functions
+
+(defun org-babel-C-var-to-C (pair)
+ "Convert an elisp val into a string of C code specifying a var
+of the same value."
+ ;; TODO list support
+ (let ((var (car pair))
+ (val (cdr pair)))
+ (when (symbolp val)
+ (setq val (symbol-name val))
+ (when (= (length val) 1)
+ (setq val (string-to-char val))))
+ (cond
+ ((integerp val)
+ (format "int %S = %S;" var val))
+ ((floatp val)
+ (format "double %S = %S;" var val))
+ ((or (characterp val))
+ (format "char %S = '%S';" var val))
+ ((stringp val)
+ (format "char %S[%d] = \"%s\";"
+ var (+ 1 (length val)) val))
+ (t
+ (format "u32 %S = %S;" var val)))))
+
+
+(provide 'ob-C)
+
+;; arch-tag: 8f49e462-54e3-417b-9a8d-423864893b37
+
+;;; ob-C.el ends here
diff --git a/lisp/org/ob-R.el b/lisp/org/ob-R.el
new file mode 100644
index 00000000000..81d628e4206
--- /dev/null
+++ b/lisp/org/ob-R.el
@@ -0,0 +1,302 @@
+;;; ob-R.el --- org-babel functions for R code evaluation
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Dan Davison
+;; Keywords: literate programming, reproducible research, R, statistics
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Org-Babel support for evaluating R code
+
+;;; Code:
+(require 'ob)
+(require 'ob-ref)
+(require 'ob-comint)
+(require 'ob-eval)
+(eval-when-compile (require 'cl))
+
+(declare-function orgtbl-to-tsv "org-table" (table params))
+(declare-function R "ext:essd-r" (&optional start-args))
+(declare-function inferior-ess-send-input "ext:ess-inf" ())
+(declare-function ess-make-buffer-current "ext:ess-inf" ())
+(declare-function ess-eval-buffer "ext:ess-inf" (vis))
+(declare-function org-number-sequence "org-compat" (from &optional to inc))
+
+(defconst org-babel-header-arg-names:R
+ '(width height bg units pointsize antialias quality compression
+ res type family title fonts version paper encoding
+ pagecentre colormodel useDingbats horizontal)
+ "R-specific header arguments.")
+
+(defvar org-babel-default-header-args:R '())
+
+(defvar org-babel-R-command "R --slave --no-save"
+ "Name of command to use for executing R code.")
+
+(defun org-babel-expand-body:R (body params)
+ "Expand BODY according to PARAMS, return the expanded body."
+ (let ((out-file (cdr (assoc :file params))))
+ (mapconcat
+ #'identity
+ ((lambda (inside)
+ (if out-file
+ (append
+ (list (org-babel-R-construct-graphics-device-call out-file params))
+ inside
+ (list "dev.off()"))
+ inside))
+ (append (org-babel-variable-assignments:R params)
+ (list body))) "\n")))
+
+(defun org-babel-execute:R (body params)
+ "Execute a block of R code.
+This function is called by `org-babel-execute-src-block'."
+ (save-excursion
+ (let* ((result-type (cdr (assoc :result-type params)))
+ (session (org-babel-R-initiate-session
+ (cdr (assoc :session params)) params))
+ (colnames-p (cdr (assoc :colnames params)))
+ (rownames-p (cdr (assoc :rownames params)))
+ (out-file (cdr (assoc :file params)))
+ (full-body (org-babel-expand-body:R body params))
+ (result
+ (org-babel-R-evaluate
+ session full-body result-type
+ (or (equal "yes" colnames-p)
+ (org-babel-pick-name
+ (cdr (assoc :colname-names params)) colnames-p))
+ (or (equal "yes" rownames-p)
+ (org-babel-pick-name
+ (cdr (assoc :rowname-names params)) rownames-p)))))
+ (message "result is %S" result)
+ (or out-file result))))
+
+(defun org-babel-prep-session:R (session params)
+ "Prepare SESSION according to the header arguments specified in PARAMS."
+ (let* ((session (org-babel-R-initiate-session session params))
+ (var-lines (org-babel-variable-assignments:R params)))
+ (org-babel-comint-in-buffer session
+ (mapc (lambda (var)
+ (end-of-line 1) (insert var) (comint-send-input nil t)
+ (org-babel-comint-wait-for-output session)) var-lines))
+ session))
+
+(defun org-babel-load-session:R (session body params)
+ "Load BODY into SESSION."
+ (save-window-excursion
+ (let ((buffer (org-babel-prep-session:R session params)))
+ (with-current-buffer buffer
+ (goto-char (process-mark (get-buffer-process (current-buffer))))
+ (insert (org-babel-chomp body)))
+ buffer)))
+
+;; helper functions
+
+(defun org-babel-variable-assignments:R (params)
+ "Return list of R statements assigning the block's variables"
+ (let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
+ (mapcar
+ (lambda (pair)
+ (org-babel-R-assign-elisp
+ (car pair) (cdr pair)
+ (equal "yes" (cdr (assoc :colnames params)))
+ (equal "yes" (cdr (assoc :rownames params)))))
+ (mapcar
+ (lambda (i)
+ (cons (car (nth i vars))
+ (org-babel-reassemble-table
+ (cdr (nth i vars))
+ (cdr (nth i (cdr (assoc :colname-names params))))
+ (cdr (nth i (cdr (assoc :rowname-names params)))))))
+ (org-number-sequence 0 (1- (length vars)))))))
+
+(defun org-babel-R-quote-tsv-field (s)
+ "Quote field S for export to R."
+ (if (stringp s)
+ (concat "\"" (mapconcat 'identity (split-string s "\"") "\"\"") "\"")
+ (format "%S" s)))
+
+(defun org-babel-R-assign-elisp (name value colnames-p rownames-p)
+ "Construct R code assigning the elisp VALUE to a variable named NAME."
+ (if (listp value)
+ (let ((transition-file (org-babel-temp-file "R-import-")))
+ ;; ensure VALUE has an orgtbl structure (depth of at least 2)
+ (unless (listp (car value)) (setq value (list value)))
+ (with-temp-file transition-file
+ (insert (orgtbl-to-tsv value '(:fmt org-babel-R-quote-tsv-field)))
+ (insert "\n"))
+ (format "%s <- read.table(\"%s\", header=%s, row.names=%s, sep=\"\\t\", as.is=TRUE)"
+ name (org-babel-process-file-name transition-file 'noquote)
+ (if (or (eq (nth 1 value) 'hline) colnames-p) "TRUE" "FALSE")
+ (if rownames-p "1" "NULL")))
+ (format "%s <- %s" name (org-babel-R-quote-tsv-field value))))
+
+(defvar ess-ask-for-ess-directory nil)
+(defun org-babel-R-initiate-session (session params)
+ "If there is not a current R process then create one."
+ (unless (string= session "none")
+ (let ((session (or session "*R*"))
+ (ess-ask-for-ess-directory
+ (and ess-ask-for-ess-directory (not (cdr (assoc :dir params))))))
+ (if (org-babel-comint-buffer-livep session)
+ session
+ (save-window-excursion
+ (require 'ess) (R)
+ (rename-buffer
+ (if (bufferp session)
+ (buffer-name session)
+ (if (stringp session)
+ session
+ (buffer-name))))
+ (current-buffer))))))
+
+(defvar ess-local-process-name nil)
+(defun org-babel-R-associate-session (session)
+ "Associate R code buffer with an R session.
+Make SESSION be the inferior ESS process associated with the
+current code buffer."
+ (setq ess-local-process-name
+ (process-name (get-buffer-process session)))
+ (ess-make-buffer-current))
+
+(defun org-babel-R-construct-graphics-device-call (out-file params)
+ "Construct the call to the graphics device."
+ (let ((devices
+ '((:bmp . "bmp")
+ (:jpg . "jpeg")
+ (:jpeg . "jpeg")
+ (:tiff . "tiff")
+ (:png . "png")
+ (:svg . "svg")
+ (:pdf . "pdf")
+ (:ps . "postscript")
+ (:postscript . "postscript")))
+ (allowed-args '(:width :height :bg :units :pointsize
+ :antialias :quality :compression :res
+ :type :family :title :fonts :version
+ :paper :encoding :pagecentre :colormodel
+ :useDingbats :horizontal))
+ (device (and (string-match ".+\\.\\([^.]+\\)" out-file)
+ (match-string 1 out-file)))
+ (extra-args (cdr (assq :R-dev-args params))) filearg args)
+ (setq device (or (and device (cdr (assq (intern (concat ":" device))
+ devices))) "png"))
+ (setq filearg
+ (if (member device '("pdf" "postscript" "svg")) "file" "filename"))
+ (setq args (mapconcat
+ (lambda (pair)
+ (if (member (car pair) allowed-args)
+ (format ",%s=%s"
+ (substring (symbol-name (car pair)) 1)
+ (cdr pair)) ""))
+ params ""))
+ (format "%s(%s=\"%s\"%s%s%s)"
+ device filearg out-file args
+ (if extra-args "," "") (or extra-args ""))))
+
+(defvar org-babel-R-eoe-indicator "'org_babel_R_eoe'")
+(defvar org-babel-R-eoe-output "[1] \"org_babel_R_eoe\"")
+(defvar org-babel-R-write-object-command "{function(object, transfer.file) {invisible(if(inherits(try(write.table(object, file=transfer.file, sep=\"\\t\", na=\"nil\",row.names=%s, col.names=%s, quote=FALSE), silent=TRUE),\"try-error\")) {if(!file.exists(transfer.file)) file.create(transfer.file)})}}(object=%s, transfer.file=\"%s\")")
+
+(defun org-babel-R-evaluate
+ (session body result-type column-names-p row-names-p)
+ "Evaluate R code in BODY."
+ (if session
+ (org-babel-R-evaluate-session
+ session body result-type column-names-p row-names-p)
+ (org-babel-R-evaluate-external-process
+ body result-type column-names-p row-names-p)))
+
+(defun org-babel-R-evaluate-external-process
+ (body result-type column-names-p row-names-p)
+ "Evaluate BODY in external R process.
+If RESULT-TYPE equals 'output then return standard output as a
+string. If RESULT-TYPE equals 'value then return the value of the
+last statement in BODY, as elisp."
+ (case result-type
+ (value
+ (let ((tmp-file (org-babel-temp-file "R-")))
+ (org-babel-eval org-babel-R-command
+ (format org-babel-R-write-object-command
+ (if row-names-p "TRUE" "FALSE")
+ (if column-names-p
+ (if row-names-p "NA" "TRUE")
+ "FALSE")
+ (format "{function ()\n{\n%s\n}}()" body)
+ (org-babel-process-file-name tmp-file 'noquote)))
+ (org-babel-R-process-value-result
+ (org-babel-import-elisp-from-file tmp-file '(16)) column-names-p)))
+ (output (org-babel-eval org-babel-R-command body))))
+
+(defun org-babel-R-evaluate-session
+ (session body result-type column-names-p row-names-p)
+ "Evaluate BODY in SESSION.
+If RESULT-TYPE equals 'output then return standard output as a
+string. If RESULT-TYPE equals 'value then return the value of the
+last statement in BODY, as elisp."
+ (case result-type
+ (value
+ (with-temp-buffer
+ (insert (org-babel-chomp body))
+ (let ((ess-local-process-name
+ (process-name (get-buffer-process session))))
+ (ess-eval-buffer nil)))
+ (let ((tmp-file (org-babel-temp-file "R-")))
+ (org-babel-comint-eval-invisibly-and-wait-for-file
+ session tmp-file
+ (format org-babel-R-write-object-command
+ (if row-names-p "TRUE" "FALSE")
+ (if column-names-p
+ (if row-names-p "NA" "TRUE")
+ "FALSE")
+ ".Last.value" (org-babel-process-file-name tmp-file 'noquote)))
+ (org-babel-R-process-value-result
+ (org-babel-import-elisp-from-file tmp-file '(16)) column-names-p)))
+ (output
+ (mapconcat
+ #'org-babel-chomp
+ (butlast
+ (delq nil
+ (mapcar
+ (lambda (line) ;; cleanup extra prompts left in output
+ (if (string-match
+ "^\\([ ]*[>+][ ]?\\)+\\([[0-9]+\\|[ ]\\)" line)
+ (substring line (match-end 1))
+ line))
+ (org-babel-comint-with-output (session org-babel-R-eoe-output)
+ (insert (mapconcat #'org-babel-chomp
+ (list body org-babel-R-eoe-indicator)
+ "\n"))
+ (inferior-ess-send-input)))) 2) "\n"))))
+
+(defun org-babel-R-process-value-result (result column-names-p)
+ "R-specific processing of return value.
+Insert hline if column names in output have been requested."
+ (if column-names-p
+ (cons (car result) (cons 'hline (cdr result)))
+ result))
+
+(provide 'ob-R)
+
+;; arch-tag: cd4c7298-503b-450f-a3c2-f3e74b630237
+
+;;; ob-R.el ends here
diff --git a/lisp/org/ob-asymptote.el b/lisp/org/ob-asymptote.el
new file mode 100644
index 00000000000..43d65462612
--- /dev/null
+++ b/lisp/org/ob-asymptote.el
@@ -0,0 +1,164 @@
+;;; ob-asymptote.el --- org-babel functions for asymptote evaluation
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Org-Babel support for evaluating asymptote source code.
+;;
+;; This differs from most standard languages in that
+;;
+;; 1) there is no such thing as a "session" in asymptote
+;;
+;; 2) we are generally only going to return results of type "file"
+;;
+;; 3) we are adding the "file" and "cmdline" header arguments, if file
+;; is omitted then the -V option is passed to the asy command for
+;; interactive viewing
+
+;;; Requirements:
+
+;; - The asymptote program :: http://asymptote.sourceforge.net/
+;;
+;; - asy-mode :: Major mode for editing asymptote files
+
+;;; Code:
+(require 'ob)
+(eval-when-compile (require 'cl))
+
+(declare-function orgtbl-to-generic "org-table" (table params))
+(declare-function org-combine-plists "org" (&rest plists))
+
+(add-to-list 'org-babel-tangle-lang-exts '("asymptote" . "asy"))
+
+(defvar org-babel-default-header-args:asymptote
+ '((:results . "file") (:exports . "results"))
+ "Default arguments when evaluating an Asymptote source block.")
+
+(defun org-babel-execute:asymptote (body params)
+ "Execute a block of Asymptote code.
+This function is called by `org-babel-execute-src-block'."
+ (let* ((result-params (split-string (or (cdr (assoc :results params)) "")))
+ (out-file (cdr (assoc :file params)))
+ (format (or (and out-file
+ (string-match ".+\\.\\(.+\\)" out-file)
+ (match-string 1 out-file))
+ "pdf"))
+ (cmdline (cdr (assoc :cmdline params)))
+ (in-file (org-babel-temp-file "asymptote-"))
+ (cmd
+ (concat "asy "
+ (if out-file
+ (concat
+ "-globalwrite -f " format
+ " -o " (org-babel-process-file-name out-file))
+ "-V")
+ " " cmdline
+ " " (org-babel-process-file-name in-file))))
+ (with-temp-file in-file
+ (insert (org-babel-expand-body:generic
+ body params
+ (org-babel-variable-assignments:asymptote params))))
+ (message cmd) (shell-command cmd)
+ out-file))
+
+(defun org-babel-prep-session:asymptote (session params)
+ "Return an error if the :session header argument is set.
+Asymptote does not support sessions"
+ (error "Asymptote does not support sessions"))
+
+(defun org-babel-variable-assignments:asymptote (params)
+ "Return list of asymptote statements assigning the block's variables"
+ (mapcar #'org-babel-asymptote-var-to-asymptote
+ (mapcar #'cdr (org-babel-get-header params :var))))
+
+(defun org-babel-asymptote-var-to-asymptote (pair)
+ "Convert an elisp value into an Asymptote variable.
+The elisp value PAIR is converted into Asymptote code specifying
+a variable of the same value."
+ (let ((var (car pair))
+ (val (if (symbolp (cdr pair))
+ (symbol-name (cdr pair))
+ (cdr pair))))
+ (cond
+ ((integerp val)
+ (format "int %S=%S;" var val))
+ ((floatp val)
+ (format "real %S=%S;" var val))
+ ((stringp val)
+ (format "string %S=\"%s\";" var val))
+ ((listp val)
+ (let* ((dimension-2-p (not (null (cdr val))))
+ (dim (if dimension-2-p "[][]" "[]"))
+ (type (org-babel-asymptote-define-type val))
+ (array (org-babel-asymptote-table-to-array
+ val
+ (if dimension-2-p '(:lstart "{" :lend "}," :llend "}")))))
+ (format "%S%s %S=%s;" type dim var array))))))
+
+(defun org-babel-asymptote-table-to-array (table params)
+ "Convert values of an elisp table into a string of an asymptote array.
+Empty cells are ignored."
+ (labels ((atom-to-string (table)
+ (cond
+ ((null table) '())
+ ((not (listp (car table)))
+ (cons (if (and (stringp (car table))
+ (not (string= (car table) "")))
+ (format "\"%s\"" (car table))
+ (format "%s" (car table)))
+ (atom-to-string (cdr table))))
+ (t
+ (cons (atom-to-string (car table))
+ (atom-to-string (cdr table))))))
+ ;; Remove any empty row
+ (fix-empty-lines (table)
+ (delq nil (mapcar (lambda (l) (delq "" l)) table))))
+ (orgtbl-to-generic
+ (fix-empty-lines (atom-to-string table))
+ (org-combine-plists '(:hline nil :sep "," :tstart "{" :tend "}") params))))
+
+(defun org-babel-asymptote-define-type (data)
+ "Determine type of DATA.
+DATA is a list. Type symbol is returned as 'symbol. The type is
+usually the type of the first atom encountered, except for arrays
+of int, where every cell must be of int type."
+ (labels ((anything-but-int (el)
+ (cond
+ ((null el) nil)
+ ((not (listp (car el)))
+ (cond
+ ((floatp (car el)) 'real)
+ ((stringp (car el)) 'string)
+ (t
+ (anything-but-int (cdr el)))))
+ (t
+ (or (anything-but-int (car el))
+ (anything-but-int (cdr el)))))))
+ (or (anything-but-int data) 'int)))
+
+(provide 'ob-asymptote)
+
+;; arch-tag: f2f5bd0d-78e8-412b-8e6c-6dadc94cc06b
+
+;;; ob-asymptote.el ends here
diff --git a/lisp/org/ob-calc.el b/lisp/org/ob-calc.el
new file mode 100644
index 00000000000..426aafd154f
--- /dev/null
+++ b/lisp/org/ob-calc.el
@@ -0,0 +1,67 @@
+;;; ob-calc.el --- org-babel functions for calc code evaluation
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Org-Babel support for evaluating calc code
+
+;;; Code:
+(require 'ob)
+(require 'calc)
+(require 'calc-trail)
+(eval-when-compile (require 'ob-comint))
+
+(defvar org-babel-default-header-args:calc nil
+ "Default arguments for evaluating an calc source block.")
+
+(defun org-babel-expand-body:calc (body params)
+ "Expand BODY according to PARAMS, return the expanded body." body)
+
+(defun org-babel-execute:calc (body params)
+ "Execute a block of calc code with Babel."
+ (mapcar
+ (lambda (line)
+ (when (> (length line) 0)
+ (if (string= "'" (substring line 0 1))
+ (funcall (lookup-key calc-mode-map (substring line 1)) nil)
+ (calc-push-list
+ (list ((lambda (res)
+ (cond
+ ((numberp res) res)
+ ((listp res) (error "calc error \"%s\" on input \"%s\""
+ (cadr res) line))
+ (t res))
+ (if (numberp res) res (math-read-number res)))
+ (calc-eval line)))))))
+ (mapcar #'org-babel-trim
+ (split-string (org-babel-expand-body:calc body params) "[\n\r]")))
+ (save-excursion
+ (set-buffer (get-buffer "*Calculator*"))
+ (calc-eval (calc-top 1))))
+
+(provide 'ob-calc)
+
+;; arch-tag: 5c57a3b7-5818-4c6c-acda-7a94831a6449
+
+;;; ob-calc.el ends here
diff --git a/lisp/org/ob-clojure.el b/lisp/org/ob-clojure.el
new file mode 100644
index 00000000000..0a76e827125
--- /dev/null
+++ b/lisp/org/ob-clojure.el
@@ -0,0 +1,318 @@
+;;; ob-clojure.el --- org-babel functions for clojure evaluation
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Joel Boehland
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; ob support for evaluating clojure code
+
+;;; Requirements:
+
+;;; A working clojure install. This also implies a working java executable
+;;; clojure-mode
+;;; slime
+;;; swank-clojure
+
+;;; By far, the best way to install these components is by following
+;;; the directions as set out by Phil Hagelberg (Technomancy) on the
+;;; web page: http://technomancy.us/126
+
+;;; Code:
+(require 'ob)
+(require 'ob-eval)
+(eval-when-compile (require 'cl))
+
+(declare-function slime-eval-async "ext:slime" (sexp &optional cont package))
+(declare-function slime-eval "ext:slime" (sexp &optional package))
+(declare-function swank-clojure-concat-paths "ext:slime" (paths))
+(declare-function slime "ext:slime" (&optional command coding-system))
+(declare-function slime-output-buffer "ext:slime" (&optional noprompt))
+(declare-function slime-filter-buffers "ext:slime" (predicate))
+
+(add-to-list 'org-babel-tangle-lang-exts '("clojure" . "clj"))
+
+(defvar org-babel-default-header-args:clojure '())
+
+(defvar org-babel-clojure-wrapper-method
+ "
+(defn spit
+ [f content]
+ (with-open [#^java.io.PrintWriter w
+ (java.io.PrintWriter.
+ (java.io.BufferedWriter.
+ (java.io.OutputStreamWriter.
+ (java.io.FileOutputStream.
+ (java.io.File. f)))))]
+ (.print w content)))
+
+(defn main
+ []
+ %s)
+
+(spit \"%s\" (str (main)))")
+;;";; <-- syntax highlighting is messed without this double quote
+
+;;taken mostly from clojure-test-mode.el
+(defun org-babel-clojure-clojure-slime-eval (string &optional handler)
+ "Evaluate a STRING of clojure code using `slime-eval-async'."
+ (slime-eval-async `(swank:eval-and-grab-output ,string)
+ (or handler #'identity)))
+
+(defun org-babel-clojure-slime-eval-sync (string)
+ "Evaluate a STRING of clojure code using `slime-eval'."
+ (slime-eval `(swank:eval-and-grab-output ,string)))
+
+;;taken from swank-clojure.el
+(defvar swank-clojure-binary)
+(defvar swank-clojure-classpath)
+(defvar swank-clojure-java-path)
+(defvar swank-clojure-extra-vm-args)
+(defvar swank-clojure-library-paths)
+(defvar swank-clojure-extra-classpaths)
+(defun org-babel-clojure-babel-clojure-cmd ()
+ "Create the command to start clojure according to current settings."
+ (or (when swank-clojure-binary
+ (if (listp swank-clojure-binary)
+ swank-clojure-binary
+ (list swank-clojure-binary)))
+ (when swank-clojure-classpath
+ (delq
+ nil
+ (append
+ (list swank-clojure-java-path)
+ swank-clojure-extra-vm-args
+ (list
+ (when swank-clojure-library-paths
+ (concat "-Djava.library.path="
+ (swank-clojure-concat-paths swank-clojure-library-paths)))
+ "-classpath"
+ (swank-clojure-concat-paths
+ (append
+ swank-clojure-classpath
+ swank-clojure-extra-classpaths))
+ "clojure.main"))))
+ (error "%s" (concat "You must specifiy either a `swank-clojure-binary' "
+ "or a `swank-clojure-classpath'"))))
+
+(defun org-babel-clojure-table-or-string (results)
+ "Convert RESULTS to an elisp value.
+If RESULTS looks like a table, then convert to an Emacs-lisp
+table, otherwise return the results as a string."
+ (org-babel-read
+ (if (string-match "^\\[.+\\]$" results)
+ (org-babel-read
+ (concat "'"
+ (replace-regexp-in-string
+ "\\[" "(" (replace-regexp-in-string
+ "\\]" ")" (replace-regexp-in-string
+ ", " " " (replace-regexp-in-string
+ "'" "\"" results))))))
+ results)))
+
+(defun org-babel-clojure-var-to-clojure (var)
+ "Convert an elisp value into a clojure variable.
+The elisp value VAR is converted into a string of clojure source
+code specifying a variable of the same value."
+ (if (listp var)
+ (format "'%s" var)
+ (format "%S" var)))
+
+(defun org-babel-clojure-build-full-form (body vars)
+ "Construct a clojure let form with VARS as the let variables."
+ (let ((vars-forms
+ (mapconcat ;; define any variables
+ (lambda (pair)
+ (format "%s %s"
+ (car pair) (org-babel-clojure-var-to-clojure (cdr pair))))
+ vars "\n "))
+ (body (org-babel-trim body)))
+ (if (> (length vars-forms) 0)
+ (format "(let [%s]\n %s)" vars-forms body)
+ body)))
+
+(defun org-babel-prep-session:clojure (session params)
+ "Prepare SESSION according to the header arguments specified in PARAMS."
+ (require 'slime) (require 'swank-clojure)
+ (let* ((session-buf (org-babel-clojure-initiate-session session))
+ (vars (mapcar #'cdr (org-babel-get-header params :var)))
+ (var-lines (mapcar ;; define any top level session variables
+ (lambda (pair)
+ (format "(def %s %s)\n" (car pair)
+ (org-babel-clojure-var-to-clojure (cdr pair))))
+ vars)))
+ session-buf))
+
+(defun org-babel-load-session:clojure (session body params)
+ "Load BODY into SESSION."
+ (require 'slime) (require 'swank-clojure)
+ (save-window-excursion
+ (let ((buffer (org-babel-prep-session:clojure session params)))
+ (with-current-buffer buffer
+ (goto-char (point-max))
+ (insert (org-babel-chomp body)))
+ buffer)))
+
+(defvar org-babel-clojure-buffers '())
+(defvar org-babel-clojure-pending-sessions '())
+
+(defun org-babel-clojure-session-buffer (session)
+ "Return the buffer associated with SESSION."
+ (cdr (assoc session org-babel-clojure-buffers)))
+
+(defun org-babel-clojure-initiate-session-by-key (&optional session)
+ "Initiate a clojure session in an inferior-process-buffer.
+If there is not a current inferior-process-buffer in SESSION
+then create one. Return the initialized session."
+ (save-window-excursion
+ (let* ((session (if session
+ (if (stringp session) (intern session)
+ session)
+ :default))
+ (clojure-buffer (org-babel-clojure-session-buffer session)))
+ (unless (and clojure-buffer (buffer-live-p clojure-buffer))
+ (setq org-babel-clojure-buffers
+ (assq-delete-all session org-babel-clojure-buffers))
+ (push session org-babel-clojure-pending-sessions)
+ (slime)
+ ;; we are waiting to finish setting up which will be done in
+ ;; org-babel-clojure-session-connected-hook below.
+ (let ((timeout 9))
+ (while (and (not (org-babel-clojure-session-buffer session))
+ (< 0 timeout))
+ (message "Waiting for clojure repl for session: %s ... %i"
+ session timeout)
+ (sit-for 1)
+ (decf timeout)))
+ (setq org-babel-clojure-pending-sessions
+ (remove session org-babel-clojure-pending-sessions))
+ (unless (org-babel-clojure-session-buffer session)
+ (error "Couldn't create slime clojure process"))
+ (setq clojure-buffer (org-babel-clojure-session-buffer session)))
+ session)))
+
+(defun org-babel-clojure-initiate-session (&optional session params)
+ "Return the slime-clojure repl buffer bound to SESSION.
+Returns nil if \"none\" is specified."
+ (require 'slime) (require 'swank-clojure)
+ (unless (and (stringp session) (string= session "none"))
+ (org-babel-clojure-session-buffer
+ (org-babel-clojure-initiate-session-by-key session))))
+
+(defun org-babel-clojure-session-connected-hook ()
+ "Finish binding an org-babel session to a slime-clojure repl."
+ (let ((pending-session (pop org-babel-clojure-pending-sessions)))
+ (when pending-session
+ (save-excursion
+ (switch-to-buffer (slime-output-buffer))
+ (rename-buffer
+ (if (stringp pending-session)
+ pending-session (symbol-name pending-session)))
+ (org-babel-clojure-bind-session-to-repl-buffer
+ pending-session (slime-output-buffer))))))
+
+(add-hook 'slime-connected-hook 'org-babel-clojure-session-connected-hook)
+
+(defun org-babel-clojure-bind-session-to-repl-buffer (session repl-buffer)
+ "Associate SESSION with REPL-BUFFER."
+ (when (stringp session) (setq session (intern session)))
+ (setq org-babel-clojure-buffers
+ (cons (cons session repl-buffer)
+ (assq-delete-all session org-babel-clojure-buffers))))
+
+(defun org-babel-clojure-repl-buffer-pred ()
+ "Test whether the current buffer is an active slime-clojure
+repl buffer."
+ (and (buffer-live-p (current-buffer)) (eq major-mode 'slime-repl-mode)))
+
+(defun org-babel-clojure-bind-session-to-repl (session)
+ "Bind SESSION to a clojure repl."
+ (interactive "sEnter session name: ")
+ (let ((repl-bufs (slime-filter-buffers 'org-babel-clojure-repl-buffer-pred)))
+ (unless repl-bufs (error "No existing slime-clojure repl buffers exist"))
+ (let ((repl-buf (read-buffer "Choose slime-clojure repl: " repl-bufs t)))
+ (org-babel-clojure-bind-session-to-repl-buffer session repl-buf))))
+
+(defun org-babel-clojure-evaluate-external-process
+ (buffer body &optional result-type)
+ "Evaluate the body in an external process."
+ (let ((cmd (format "%s -" (mapconcat #'identity
+ (org-babel-clojure-babel-clojure-cmd)
+ " "))))
+ (case result-type
+ (output (org-babel-eval cmd body))
+ (value (let* ((tmp-file (org-babel-temp-file "clojure-")))
+ (org-babel-eval
+ cmd
+ (format
+ org-babel-clojure-wrapper-method
+ body
+ (org-babel-process-file-name tmp-file 'noquote)))
+ (org-babel-clojure-table-or-string
+ (org-babel-eval-read-file tmp-file)))))))
+
+(defun org-babel-clojure-evaluate-session (buffer body &optional result-type)
+ "Evaluate the body in the context of a clojure session."
+ (require 'slime) (require 'swank-clojure)
+ (let ((raw nil)
+ (results nil))
+ (with-current-buffer buffer
+ (setq raw (org-babel-clojure-slime-eval-sync body))
+ (setq results (reverse (mapcar #'org-babel-trim raw)))
+ (cond
+ ((equal result-type 'output)
+ (mapconcat #'identity (reverse (cdr results)) "\n"))
+ ((equal result-type 'value)
+ (org-babel-clojure-table-or-string (car results)))))))
+
+(defun org-babel-clojure-evaluate (buffer body &optional result-type)
+ "Pass BODY to the Clojure process in BUFFER.
+If RESULT-TYPE equals 'output then return a list of the outputs
+of the statements in BODY, if RESULT-TYPE equals 'value then
+return the value of the last statement in BODY as elisp."
+ (if buffer
+ (org-babel-clojure-evaluate-session buffer body result-type)
+ (org-babel-clojure-evaluate-external-process buffer body result-type)))
+
+(defun org-babel-expand-body:clojure (body params)
+ "Expand BODY according to PARAMS, return the expanded body."
+ (org-babel-clojure-build-full-form
+ body (mapcar #'cdr (org-babel-get-header params :var))))
+
+(defun org-babel-execute:clojure (body params)
+ "Execute a block of Clojure code."
+ (require 'slime) (require 'swank-clojure)
+ (let* ((body (org-babel-expand-body:clojure body params))
+ (session (org-babel-clojure-initiate-session
+ (cdr (assoc :session params)))))
+ (org-babel-reassemble-table
+ (org-babel-clojure-evaluate session body (cdr (assoc :result-type params)))
+ (org-babel-pick-name
+ (cdr (assoc :colname-names params)) (cdr (assoc :colnames params)))
+ (org-babel-pick-name
+ (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params))))))
+
+(provide 'ob-clojure)
+
+;; arch-tag: a43b33f2-653e-46b1-ac56-2805cf05b7d1
+
+;;; ob-clojure.el ends here
diff --git a/lisp/org/ob-comint.el b/lisp/org/ob-comint.el
new file mode 100644
index 00000000000..d05b7fbfa40
--- /dev/null
+++ b/lisp/org/ob-comint.el
@@ -0,0 +1,163 @@
+;;; ob-comint.el --- org-babel functions for interaction with comint buffers
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research, comint
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; These functions build on comint to ease the sending and receiving
+;; of commands and results from comint buffers.
+
+;; Note that the buffers in this file are analogous to sessions in
+;; org-babel at large.
+
+;;; Code:
+(require 'ob)
+(require 'comint)
+(eval-when-compile (require 'cl))
+(declare-function with-parsed-tramp-file-name "tramp" (filename var &rest body))
+(declare-function tramp-flush-directory-property "tramp" (vec directory))
+
+(defun org-babel-comint-buffer-livep (buffer)
+ "Check if BUFFER is a comint buffer with a live process."
+ (let ((buffer (if buffer (get-buffer buffer))))
+ (and buffer (buffer-live-p buffer) (get-buffer-process buffer) buffer)))
+
+(defmacro org-babel-comint-in-buffer (buffer &rest body)
+ "Check BUFFER and execute BODY.
+BUFFER is checked with `org-babel-comint-buffer-livep'. BODY is
+executed inside the protection of `save-excursion' and
+`save-match-data'."
+ (declare (indent 1))
+ `(save-excursion
+ (save-match-data
+ (unless (org-babel-comint-buffer-livep ,buffer)
+ (error "buffer %s doesn't exist or has no process" ,buffer))
+ (set-buffer ,buffer)
+ ,@body)))
+
+(defmacro org-babel-comint-with-output (meta &rest body)
+ "Evaluate BODY in BUFFER and return process output.
+Will wait until EOE-INDICATOR appears in the output, then return
+all process output. If REMOVE-ECHO and FULL-BODY are present and
+non-nil, then strip echo'd body from the returned output. META
+should be a list containing the following where the last two
+elements are optional.
+
+ (BUFFER EOE-INDICATOR REMOVE-ECHO FULL-BODY)
+
+This macro ensures that the filter is removed in case of an error
+or user `keyboard-quit' during execution of body."
+ (declare (indent 1))
+ (let ((buffer (car meta))
+ (eoe-indicator (cadr meta))
+ (remove-echo (cadr (cdr meta)))
+ (full-body (cadr (cdr (cdr meta)))))
+ `(org-babel-comint-in-buffer ,buffer
+ (let ((string-buffer "") dangling-text raw)
+ (flet ((my-filt (text)
+ (setq string-buffer (concat string-buffer text))))
+ ;; setup filter
+ (add-hook 'comint-output-filter-functions 'my-filt)
+ (unwind-protect
+ (progn
+ ;; got located, and save dangling text
+ (goto-char (process-mark (get-buffer-process (current-buffer))))
+ (let ((start (point))
+ (end (point-max)))
+ (setq dangling-text (buffer-substring start end))
+ (delete-region start end))
+ ;; pass FULL-BODY to process
+ ,@body
+ ;; wait for end-of-evaluation indicator
+ (while (progn
+ (goto-char comint-last-input-end)
+ (not (save-excursion
+ (and (re-search-forward
+ comint-prompt-regexp nil t)
+ (re-search-forward
+ (regexp-quote ,eoe-indicator) nil t)))))
+ (accept-process-output (get-buffer-process (current-buffer)))
+ ;; thought the following this would allow async
+ ;; background running, but I was wrong...
+ ;; (run-with-timer .5 .5 'accept-process-output
+ ;; (get-buffer-process (current-buffer)))
+ )
+ ;; replace cut dangling text
+ (goto-char (process-mark (get-buffer-process (current-buffer))))
+ (insert dangling-text))
+ ;; remove filter
+ (remove-hook 'comint-output-filter-functions 'my-filt)))
+ ;; remove echo'd FULL-BODY from input
+ (if (and ,remove-echo ,full-body
+ (string-match
+ (replace-regexp-in-string
+ "\n" "[\r\n]+" (regexp-quote (or ,full-body "")))
+ string-buffer))
+ (setq raw (substring string-buffer (match-end 0))))
+ (split-string string-buffer comint-prompt-regexp)))))
+
+(defun org-babel-comint-input-command (buffer cmd)
+ "Pass CMD to BUFFER.
+The input will not be echoed."
+ (org-babel-comint-in-buffer buffer
+ (goto-char (process-mark (get-buffer-process buffer)))
+ (insert cmd)
+ (comint-send-input)
+ (org-babel-comint-wait-for-output buffer)))
+
+(defun org-babel-comint-wait-for-output (buffer)
+ "Wait until output arrives from BUFFER.
+Note: this is only safe when waiting for the result of a single
+statement (not large blocks of code)."
+ (org-babel-comint-in-buffer buffer
+ (while (progn
+ (goto-char comint-last-input-end)
+ (not (and (re-search-forward comint-prompt-regexp nil t)
+ (goto-char (match-beginning 0))
+ (string= (face-name (face-at-point))
+ "comint-highlight-prompt"))))
+ (accept-process-output (get-buffer-process buffer)))))
+
+(defun org-babel-comint-eval-invisibly-and-wait-for-file
+ (buffer file string &optional period)
+ "Evaluate STRING in BUFFER invisibly.
+Don't return until FILE exists. Code in STRING must ensure that
+FILE exists at end of evaluation."
+ (unless (org-babel-comint-buffer-livep buffer)
+ (error "buffer %s doesn't exist or has no process" buffer))
+ (if (file-exists-p file) (delete-file file))
+ (process-send-string
+ (get-buffer-process buffer)
+ (if (string-match "\n$" string) string (concat string "\n")))
+ ;; From Tramp 2.1.19 the following cache flush is not necessary
+ (if (file-remote-p default-directory)
+ (let (v)
+ (with-parsed-tramp-file-name default-directory nil
+ (tramp-flush-directory-property v ""))))
+ (while (not (file-exists-p file)) (sit-for (or period 0.25))))
+
+(provide 'ob-comint)
+
+;; arch-tag: 9adddce6-0864-4be3-b0b5-6c5157dc7889
+
+;;; ob-comint.el ends here
diff --git a/lisp/org/ob-css.el b/lisp/org/ob-css.el
new file mode 100644
index 00000000000..d93f28dcebc
--- /dev/null
+++ b/lisp/org/ob-css.el
@@ -0,0 +1,49 @@
+;;; ob-css.el --- org-babel functions for css evaluation
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Since CSS can't be executed, this file exists solely for tangling
+;; CSS from org-mode files.
+
+;;; Code:
+(require 'ob)
+
+(defvar org-babel-default-header-args:css '())
+
+(defun org-babel-execute:css (body params)
+ "Execute a block of CSS code.
+This function is called by `org-babel-execute-src-block'."
+ body)
+
+(defun org-babel-prep-session:css (session params)
+ "Return an error if the :session header argument is set.
+CSS does not support sessions."
+ (error "CSS sessions are nonsensical"))
+
+(provide 'ob-css)
+
+;; arch-tag: f4447e8c-50ab-41f9-b322-b7b9574d9fbe
+
+;;; ob-css.el ends here
diff --git a/lisp/org/ob-ditaa.el b/lisp/org/ob-ditaa.el
new file mode 100644
index 00000000000..a9b6b3ceaf1
--- /dev/null
+++ b/lisp/org/ob-ditaa.el
@@ -0,0 +1,74 @@
+;;; ob-ditaa.el --- org-babel functions for ditaa evaluation
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Org-Babel support for evaluating ditaa source code.
+;;
+;; This differs from most standard languages in that
+;;
+;; 1) there is no such thing as a "session" in ditaa
+;;
+;; 2) we are generally only going to return results of type "file"
+;;
+;; 3) we are adding the "file" and "cmdline" header arguments
+;;
+;; 4) there are no variables (at least for now)
+
+;;; Code:
+(require 'ob)
+
+(defvar org-babel-default-header-args:ditaa
+ '((:results . "file") (:exports . "results"))
+ "Default arguments for evaluating a ditaa source block.")
+
+(defvar org-ditaa-jar-path)
+(defun org-babel-execute:ditaa (body params)
+ "Execute a block of Ditaa code with org-babel.
+This function is called by `org-babel-execute-src-block'."
+ (let* ((result-params (split-string (or (cdr (assoc :results params)) "")))
+ (out-file (cdr (assoc :file params)))
+ (cmdline (cdr (assoc :cmdline params)))
+ (in-file (org-babel-temp-file "ditaa-"))
+ (cmd (concat "java -jar "
+ (shell-quote-argument
+ (expand-file-name org-ditaa-jar-path))
+ " " cmdline
+ " " (org-babel-process-file-name in-file)
+ " " (org-babel-process-file-name out-file))))
+ (unless (file-exists-p org-ditaa-jar-path)
+ (error "Could not find ditaa.jar at %s" org-ditaa-jar-path))
+ (with-temp-file in-file (insert body))
+ (message cmd) (shell-command cmd)
+ out-file))
+
+(defun org-babel-prep-session:ditaa (session params)
+ "Return an error because ditaa does not support sessions."
+ (error "Ditaa does not support sessions"))
+
+(provide 'ob-ditaa)
+
+;; arch-tag: 492cd006-07d9-4fac-bef6-5bb60b48842e
+
+;;; ob-ditaa.el ends here
diff --git a/lisp/org/ob-dot.el b/lisp/org/ob-dot.el
new file mode 100644
index 00000000000..c78f3dbee0d
--- /dev/null
+++ b/lisp/org/ob-dot.el
@@ -0,0 +1,90 @@
+;;; ob-dot.el --- org-babel functions for dot evaluation
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Org-Babel support for evaluating dot source code.
+;;
+;; For information on dot see http://www.graphviz.org/
+;;
+;; This differs from most standard languages in that
+;;
+;; 1) there is no such thing as a "session" in dot
+;;
+;; 2) we are generally only going to return results of type "file"
+;;
+;; 3) we are adding the "file" and "cmdline" header arguments
+;;
+;; 4) there are no variables (at least for now)
+
+;;; Code:
+(require 'ob)
+(require 'ob-eval)
+
+(defvar org-babel-default-header-args:dot
+ '((:results . "file") (:exports . "results"))
+ "Default arguments to use when evaluating a dot source block.")
+
+(defun org-babel-expand-body:dot (body params)
+ "Expand BODY according to PARAMS, return the expanded body."
+ (let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
+ (mapc
+ (lambda (pair)
+ (let ((name (symbol-name (car pair)))
+ (value (cdr pair)))
+ (setq body
+ (replace-regexp-in-string
+ (concat "\$" (regexp-quote name))
+ (if (stringp value) value (format "%S" value))
+ body))))
+ vars)
+ body))
+
+(defun org-babel-execute:dot (body params)
+ "Execute a block of Dot code with org-babel.
+This function is called by `org-babel-execute-src-block'."
+ (let* ((result-params (cdr (assoc :result-params params)))
+ (out-file (cdr (assoc :file params)))
+ (cmdline (or (cdr (assoc :cmdline params))
+ (format "-T%s" (file-name-extension out-file))))
+ (cmd (or (cdr (assoc :cmd params)) "dot"))
+ (in-file (org-babel-temp-file "dot-")))
+ (with-temp-file in-file
+ (insert (org-babel-expand-body:dot body params)))
+ (org-babel-eval
+ (concat cmd
+ " " (org-babel-process-file-name in-file)
+ " " cmdline
+ " -o " (org-babel-process-file-name out-file)) "")
+ out-file))
+
+(defun org-babel-prep-session:dot (session params)
+ "Return an error because Dot does not support sessions."
+ (error "Dot does not support sessions"))
+
+(provide 'ob-dot)
+
+;; arch-tag: 817d0516-7b47-4f77-a8b2-2aadd8e4d0e2
+
+;;; ob-dot.el ends here
diff --git a/lisp/org/ob-emacs-lisp.el b/lisp/org/ob-emacs-lisp.el
new file mode 100644
index 00000000000..f1d41b3db0d
--- /dev/null
+++ b/lisp/org/ob-emacs-lisp.el
@@ -0,0 +1,71 @@
+;;; ob-emacs-lisp.el --- org-babel functions for emacs-lisp code evaluation
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Org-Babel support for evaluating emacs-lisp code
+
+;;; Code:
+(require 'ob)
+(eval-when-compile (require 'ob-comint))
+
+(defvar org-babel-default-header-args:emacs-lisp
+ '((:hlines . "yes") (:colnames . "no"))
+ "Default arguments for evaluating an emacs-lisp source block.")
+
+(declare-function orgtbl-to-generic "org-table" (table params))
+
+(defun org-babel-expand-body:emacs-lisp (body params)
+ "Expand BODY according to PARAMS, return the expanded body."
+ (let* ((vars (mapcar #'cdr (org-babel-get-header params :var)))
+ (result-params (cdr (assoc :result-params params)))
+ (print-level nil) (print-length nil)
+ (body (if (> (length vars) 0)
+ (concat "(let ("
+ (mapconcat
+ (lambda (var)
+ (format "%S" (print `(,(car var) ',(cdr var)))))
+ vars "\n ")
+ ")\n" body ")")
+ body)))
+ (if (or (member "code" result-params)
+ (member "pp" result-params))
+ (concat "(pp " body ")") body)))
+
+(defun org-babel-execute:emacs-lisp (body params)
+ "Execute a block of emacs-lisp code with Babel."
+ (save-window-excursion
+ (org-babel-reassemble-table
+ (eval (read (format "(progn %s)"
+ (org-babel-expand-body:emacs-lisp body params))))
+ (org-babel-pick-name (cdr (assoc :colname-names params))
+ (cdr (assoc :colnames params)))
+ (org-babel-pick-name (cdr (assoc :rowname-names params))
+ (cdr (assoc :rownames params))))))
+
+(provide 'ob-emacs-lisp)
+
+;; arch-tag: e9a3acca-dc84-472a-9f5a-23c35befbcd6
+
+;;; ob-emacs-lisp.el ends here
diff --git a/lisp/org/ob-eval.el b/lisp/org/ob-eval.el
new file mode 100644
index 00000000000..57f4dc509aa
--- /dev/null
+++ b/lisp/org/ob-eval.el
@@ -0,0 +1,254 @@
+;;; ob-eval.el --- org-babel functions for external code evaluation
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research, comint
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; These functions build existing Emacs support for executing external
+;; shell commands.
+
+;;; Code:
+(require 'ob)
+(eval-when-compile (require 'cl))
+
+(defun org-babel-eval-error-notify (exit-code stderr)
+ "Open a buffer to display STDERR and a message with the value of EXIT-CODE."
+ (let ((buf (get-buffer-create "*Org-Babel Error Output*")))
+ (with-current-buffer buf
+ (goto-char (point-max))
+ (save-excursion (insert stderr)))
+ (display-buffer buf))
+ (message "Babel evaluation exited with code %S" exit-code))
+
+(defun org-babel-eval (cmd body)
+ "Run CMD on BODY.
+If CMD succeeds then return its results, otherwise display
+STDERR with `org-babel-eval-error-notify'."
+ (let ((err-buff (get-buffer-create "*Org-Babel Error*")) exit-code)
+ (with-current-buffer err-buff (erase-buffer))
+ (with-temp-buffer
+ (insert body)
+ (setq exit-code
+ (org-babel-shell-command-on-region
+ (point-min) (point-max) cmd t 'replace err-buff))
+ (if (or (not (numberp exit-code)) (> exit-code 0))
+ (progn
+ (with-current-buffer err-buff
+ (org-babel-eval-error-notify exit-code (buffer-string)))
+ nil)
+ (buffer-string)))))
+
+(defun org-babel-eval-read-file (file)
+ "Return the contents of FILE as a string."
+ (with-temp-buffer (insert-file-contents file)
+ (buffer-string)))
+
+(defun org-babel-shell-command-on-region (start end command
+ &optional output-buffer replace
+ error-buffer display-error-buffer)
+ "Execute COMMAND in an inferior shell with region as input.
+
+Fixes bugs in the emacs 23.1.1 version of `shell-command-on-region'
+
+Normally display output (if any) in temp buffer `*Shell Command Output*';
+Prefix arg means replace the region with it. Return the exit code of
+COMMAND.
+
+To specify a coding system for converting non-ASCII characters in
+the input and output to the shell command, use
+\\[universal-coding-system-argument] before this command. By
+default, the input (from the current buffer) is encoded in the
+same coding system that will be used to save the file,
+`buffer-file-coding-system'. If the output is going to replace
+the region, then it is decoded from that same coding system.
+
+The noninteractive arguments are START, END, COMMAND,
+OUTPUT-BUFFER, REPLACE, ERROR-BUFFER, and DISPLAY-ERROR-BUFFER.
+Noninteractive callers can specify coding systems by binding
+`coding-system-for-read' and `coding-system-for-write'.
+
+If the command generates output, the output may be displayed
+in the echo area or in a buffer.
+If the output is short enough to display in the echo area
+\(determined by the variable `max-mini-window-height' if
+`resize-mini-windows' is non-nil), it is shown there. Otherwise
+it is displayed in the buffer `*Shell Command Output*'. The output
+is available in that buffer in both cases.
+
+If there is output and an error, a message about the error
+appears at the end of the output.
+
+If there is no output, or if output is inserted in the current buffer,
+then `*Shell Command Output*' is deleted.
+
+If the optional fourth argument OUTPUT-BUFFER is non-nil,
+that says to put the output in some other buffer.
+If OUTPUT-BUFFER is a buffer or buffer name, put the output there.
+If OUTPUT-BUFFER is not a buffer and not nil,
+insert output in the current buffer.
+In either case, the output is inserted after point (leaving mark after it).
+
+If REPLACE, the optional fifth argument, is non-nil, that means insert
+the output in place of text from START to END, putting point and mark
+around it.
+
+If optional sixth argument ERROR-BUFFER is non-nil, it is a buffer
+or buffer name to which to direct the command's standard error output.
+If it is nil, error output is mingled with regular output.
+If DISPLAY-ERROR-BUFFER is non-nil, display the error buffer if there
+were any errors. (This is always t, interactively.)
+In an interactive call, the variable `shell-command-default-error-buffer'
+specifies the value of ERROR-BUFFER."
+ (interactive (let (string)
+ (unless (mark)
+ (error "The mark is not set now, so there is no region"))
+ ;; Do this before calling region-beginning
+ ;; and region-end, in case subprocess output
+ ;; relocates them while we are in the minibuffer.
+ (setq string (read-shell-command "Shell command on region: "))
+ ;; call-interactively recognizes region-beginning and
+ ;; region-end specially, leaving them in the history.
+ (list (region-beginning) (region-end)
+ string
+ current-prefix-arg
+ current-prefix-arg
+ shell-command-default-error-buffer
+ t)))
+ (let ((error-file
+ (if error-buffer
+ (make-temp-file
+ (expand-file-name "scor"
+ (or (unless (featurep 'xemacs)
+ small-temporary-file-directory)
+ temporary-file-directory)))
+ nil))
+ exit-status)
+ (if (or replace
+ (and output-buffer
+ (not (or (bufferp output-buffer) (stringp output-buffer)))))
+ ;; Replace specified region with output from command.
+ (let ((swap (and replace (< start end))))
+ ;; Don't muck with mark unless REPLACE says we should.
+ (goto-char start)
+ (and replace (push-mark (point) 'nomsg))
+ (setq exit-status
+ (call-process-region start end shell-file-name t
+ (if error-file
+ (list output-buffer error-file)
+ t)
+ nil shell-command-switch command))
+ ;; It is rude to delete a buffer which the command is not using.
+ ;; (let ((shell-buffer (get-buffer "*Shell Command Output*")))
+ ;; (and shell-buffer (not (eq shell-buffer (current-buffer)))
+ ;; (kill-buffer shell-buffer)))
+ ;; Don't muck with mark unless REPLACE says we should.
+ (and replace swap (exchange-point-and-mark)))
+ ;; No prefix argument: put the output in a temp buffer,
+ ;; replacing its entire contents.
+ (let ((buffer (get-buffer-create
+ (or output-buffer "*Shell Command Output*"))))
+ (unwind-protect
+ (if (eq buffer (current-buffer))
+ ;; If the input is the same buffer as the output,
+ ;; delete everything but the specified region,
+ ;; then replace that region with the output.
+ (progn (setq buffer-read-only nil)
+ (delete-region (max start end) (point-max))
+ (delete-region (point-min) (min start end))
+ (setq exit-status
+ (call-process-region (point-min) (point-max)
+ shell-file-name t
+ (if error-file
+ (list t error-file)
+ t)
+ nil shell-command-switch
+ command)))
+ ;; Clear the output buffer, then run the command with
+ ;; output there.
+ (let ((directory default-directory))
+ (with-current-buffer buffer
+ (setq buffer-read-only nil)
+ (if (not output-buffer)
+ (setq default-directory directory))
+ (erase-buffer)))
+ (setq exit-status
+ (call-process-region start end shell-file-name nil
+ (if error-file
+ (list buffer error-file)
+ buffer)
+ nil shell-command-switch command)))
+ ;; Report the output.
+ (with-current-buffer buffer
+ (setq mode-line-process
+ (cond ((null exit-status)
+ " - Error")
+ ((stringp exit-status)
+ (format " - Signal [%s]" exit-status))
+ ((not (equal 0 exit-status))
+ (format " - Exit [%d]" exit-status)))))
+ (if (with-current-buffer buffer (> (point-max) (point-min)))
+ ;; There's some output, display it
+ (display-message-or-buffer buffer)
+ ;; No output; error?
+ (let ((output
+ (if (and error-file
+ (< 0 (nth 7 (file-attributes error-file))))
+ "some error output"
+ "no output")))
+ (cond ((null exit-status)
+ (message "(Shell command failed with error)"))
+ ((equal 0 exit-status)
+ (message "(Shell command succeeded with %s)"
+ output))
+ ((stringp exit-status)
+ (message "(Shell command killed by signal %s)"
+ exit-status))
+ (t
+ (message "(Shell command failed with code %d and %s)"
+ exit-status output))))
+ ;; Don't kill: there might be useful info in the undo-log.
+ ;; (kill-buffer buffer)
+ ))))
+
+ (when (and error-file (file-exists-p error-file))
+ (if (< 0 (nth 7 (file-attributes error-file)))
+ (with-current-buffer (get-buffer-create error-buffer)
+ (let ((pos-from-end (- (point-max) (point))))
+ (or (bobp)
+ (insert "\f\n"))
+ ;; Do no formatting while reading error file,
+ ;; because that can run a shell command, and we
+ ;; don't want that to cause an infinite recursion.
+ (format-insert-file error-file nil)
+ ;; Put point after the inserted errors.
+ (goto-char (- (point-max) pos-from-end)))
+ (and display-error-buffer
+ (display-buffer (current-buffer)))))
+ (delete-file error-file))
+ exit-status))
+
+(provide 'ob-eval)
+
+;; arch-tag: 5328b17f-957d-42d9-94da-a2952682d04d
+
+;;; ob-eval.el ends here
diff --git a/lisp/org/ob-exp.el b/lisp/org/ob-exp.el
new file mode 100644
index 00000000000..52da00103f6
--- /dev/null
+++ b/lisp/org/ob-exp.el
@@ -0,0 +1,328 @@
+;;; ob-exp.el --- Exportation of org-babel source blocks
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte, Dan Davison
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; See the online documentation for more information
+;;
+;; http://orgmode.org/worg/org-contrib/babel/
+
+;;; Code:
+(require 'ob)
+(require 'org-exp-blocks)
+(eval-when-compile
+ (require 'cl))
+
+(defvar obe-marker nil)
+(defvar org-current-export-file)
+(defvar org-babel-lob-one-liner-regexp)
+(defvar org-babel-ref-split-regexp)
+(declare-function org-babel-lob-get-info "ob-lob" ())
+(declare-function org-babel-ref-literal "ob-ref" (ref))
+
+(add-to-list 'org-export-interblocks '(src org-babel-exp-inline-src-blocks))
+(add-to-list 'org-export-interblocks '(lob org-babel-exp-lob-one-liners))
+(add-hook 'org-export-blocks-postblock-hook 'org-exp-res/src-name-cleanup)
+
+(org-export-blocks-add-block '(src org-babel-exp-src-blocks nil))
+
+(defcustom org-export-babel-evaluate t
+ "Switch controlling code evaluation during export.
+When set to nil no code will be evaluated as part of the export
+process."
+ :group 'org-babel
+ :type 'boolean)
+(put 'org-export-babel-evaluate 'safe-local-variable (lambda (x) (eq x nil)))
+
+(defvar org-babel-function-def-export-keyword "function"
+ "The keyword to substitute for the source name line on export.
+When exporting a source block function, this keyword will
+appear in the exported version in the place of source name
+line. A source block is considered to be a source block function
+if the source name is present and is followed by a parenthesized
+argument list. The parentheses may be empty or contain
+whitespace. An example is the following which generates n random
+\(uniform) numbers.
+
+#+source: rand(n)
+#+begin_src R
+ runif(n)
+#+end_src")
+
+(defvar org-babel-function-def-export-indent 4
+ "Number of characters to indent a source block on export.
+When exporting a source block function, the block contents will
+be indented by this many characters. See
+`org-babel-function-def-export-name' for the definition of a
+source block function.")
+
+(defmacro org-babel-exp-in-export-file (&rest body)
+ `(let* ((lang-headers (intern (concat "org-babel-default-header-args:" lang)))
+ (heading (nth 4 (ignore-errors (org-heading-components))))
+ (link (when org-current-export-file
+ (org-make-link-string
+ (if heading
+ (concat org-current-export-file "::" heading)
+ org-current-export-file))))
+ (export-buffer (current-buffer)) results)
+ (when link
+ ;; resolve parameters in the original file so that
+ ;; headline and file-wide parameters are included, attempt
+ ;; to go to the same heading in the original file
+ (set-buffer (get-file-buffer org-current-export-file))
+ (save-restriction
+ (condition-case nil
+ (org-open-link-from-string link)
+ (error (when heading
+ (goto-char (point-min))
+ (re-search-forward (regexp-quote heading) nil t))))
+ (setq results ,@body))
+ (set-buffer export-buffer)
+ results)))
+
+(defun org-babel-exp-src-blocks (body &rest headers)
+ "Process source block for export.
+Depending on the 'export' headers argument in replace the source
+code block with...
+
+both ---- display the code and the results
+
+code ---- the default, display the code inside the block but do
+ not process
+
+results - just like none only the block is run on export ensuring
+ that it's results are present in the org-mode buffer
+
+none ----- do not display either code or results upon export"
+ (interactive)
+ (message "org-babel-exp processing...")
+ (save-excursion
+ (goto-char (match-beginning 0))
+ (let* ((info (org-babel-get-src-block-info 'light))
+ (lang (nth 0 info))
+ (raw-params (nth 2 info)))
+ ;; bail if we couldn't get any info from the block
+ (when info
+ (org-babel-exp-in-export-file
+ (setf (nth 2 info)
+ (org-babel-merge-params
+ org-babel-default-header-args
+ (org-babel-params-from-buffer)
+ (org-babel-params-from-properties lang)
+ (if (boundp lang-headers) (eval lang-headers) nil)
+ raw-params)))
+ ;; expand noweb references in the original file
+ (setf (nth 1 info)
+ (if (and (cdr (assoc :noweb (nth 2 info)))
+ (string= "yes" (cdr (assoc :noweb (nth 2 info)))))
+ (org-babel-expand-noweb-references
+ info (get-file-buffer org-current-export-file))
+ (nth 1 info)))
+ (org-babel-exp-do-export info 'block)))))
+
+(defun org-babel-exp-inline-src-blocks (start end)
+ "Process inline source blocks between START and END for export.
+See `org-babel-exp-src-blocks' for export options, currently the
+options and are taken from `org-babel-default-inline-header-args'."
+ (interactive)
+ (save-excursion
+ (goto-char start)
+ (while (and (< (point) end)
+ (re-search-forward org-babel-inline-src-block-regexp end t))
+ (let* ((info (save-match-data (org-babel-parse-inline-src-block-match)))
+ (params (nth 2 info))
+ (replacement
+ (save-match-data
+ (if (org-babel-in-example-or-verbatim)
+ (buffer-substring (match-beginning 0) (match-end 0))
+ ;; expand noweb references in the original file
+ (setf (nth 1 info)
+ (if (and (cdr (assoc :noweb params))
+ (string= "yes" (cdr (assoc :noweb params))))
+ (org-babel-expand-noweb-references
+ info (get-file-buffer org-current-export-file))
+ (nth 1 info)))
+ (org-babel-exp-do-export info 'inline)))))
+ (setq end (+ end (- (length replacement) (length (match-string 1)))))
+ (replace-match replacement t t nil 1)))))
+
+(defun org-exp-res/src-name-cleanup ()
+ "Clean up #+results and #+srcname lines for export.
+This function should only be called after all block processing
+has taken place."
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (while (org-re-search-forward-unprotected
+ (concat
+ "\\("org-babel-src-name-regexp"\\|"org-babel-result-regexp"\\)")
+ nil t)
+ (delete-region
+ (progn (beginning-of-line) (point))
+ (progn (end-of-line) (+ 1 (point)))))))
+
+(defun org-babel-in-example-or-verbatim ()
+ "Return true if point is in example or verbatim code.
+Example and verbatim code include escaped portions of
+an org-mode buffer code that should be treated as normal
+org-mode text."
+ (or (org-in-indented-comment-line)
+ (save-excursion
+ (save-match-data
+ (goto-char (point-at-bol))
+ (looking-at "[ \t]*:[ \t]")))
+ (org-in-regexps-block-p "^[ \t]*#\\+begin_src" "^[ \t]*#\\+end_src")))
+
+(defun org-babel-exp-lob-one-liners (start end)
+ "Process Library of Babel calls between START and END for export.
+See `org-babel-exp-src-blocks' for export options. Currently the
+options are taken from `org-babel-default-header-args'."
+ (interactive)
+ (let (replacement)
+ (save-excursion
+ (goto-char start)
+ (while (and (< (point) end)
+ (re-search-forward org-babel-lob-one-liner-regexp nil t))
+ (setq replacement
+ (let ((lob-info (org-babel-lob-get-info)))
+ (save-match-data
+ (org-babel-exp-do-export
+ (list "emacs-lisp" "results"
+ (org-babel-merge-params
+ org-babel-default-header-args
+ (org-babel-params-from-buffer)
+ (org-babel-params-from-properties)
+ (org-babel-parse-header-arguments
+ (org-babel-clean-text-properties
+ (concat ":var results="
+ (mapconcat #'identity
+ (butlast lob-info) " ")))))
+ (car (last lob-info)))
+ 'lob))))
+ (setq end (+ end (- (length replacement) (length (match-string 0)))))
+ (replace-match replacement t t)))))
+
+(defun org-babel-exp-do-export (info type)
+ "Return a string with the exported content of a code block.
+The function respects the value of the :exports header argument."
+ (flet ((silently () (let ((session (cdr (assoc :session (nth 2 info)))))
+ (when (and session
+ (not (equal "none" session)))
+ (org-babel-exp-results info type 'silent))))
+ (clean () (org-babel-remove-result info)))
+ (case (intern (or (cdr (assoc :exports (nth 2 info))) "code"))
+ ('none (silently) (clean) "")
+ ('code (silently) (clean) (org-babel-exp-code info type))
+ ('results (org-babel-exp-results info type))
+ ('both (concat (org-babel-exp-code info type)
+ "\n\n"
+ (org-babel-exp-results info type))))))
+
+(defvar backend)
+(defun org-babel-exp-code (info type)
+ "Prepare and return code in the current code block for export.
+Code is prepared in a manner suitable for export by
+org-mode. This function is called by `org-babel-exp-do-export'.
+The code block is not evaluated."
+ (let ((lang (nth 0 info))
+ (body (nth 1 info))
+ (switches (nth 3 info))
+ (name (nth 4 info))
+ (args (mapcar #'cdr (org-babel-get-header (nth 2 info) :var))))
+ (case type
+ ('inline (format "=%s=" body))
+ ('block
+ (let ((str
+ (format "#+BEGIN_SRC %s %s\n%s%s#+END_SRC\n" lang switches body
+ (if (and body (string-match "\n$" body))
+ "" "\n"))))
+ (when name
+ (add-text-properties
+ 0 (length str)
+ (list 'org-caption
+ (format "%s(%s)"
+ name
+ (mapconcat #'identity args ", ")))
+ str))
+ str))
+ ('lob
+ (let ((call-line (and (string-match "results=" (car args))
+ (substring (car args) (match-end 0)))))
+ (cond
+ ((eq backend 'html)
+ (format "\n#+HTML: <label class=\"org-src-name\">%s</label>\n"
+ call-line))
+ ((format ": %s\n" call-line))))))))
+
+(defun org-babel-exp-results (info type &optional silent)
+ "Evaluate and return the results of the current code block for export.
+Results are prepared in a manner suitable for export by org-mode.
+This function is called by `org-babel-exp-do-export'. The code
+block will be evaluated. Optional argument SILENT can be used to
+inhibit insertion of results into the buffer."
+ (or
+ (when org-export-babel-evaluate
+ (let ((lang (nth 0 info))
+ (body (nth 1 info)))
+ (setf (nth 2 info) (org-babel-exp-in-export-file
+ (org-babel-process-params (nth 2 info))))
+ ;; skip code blocks which we can't evaluate
+ (when (fboundp (intern (concat "org-babel-execute:" lang)))
+ (if (equal type 'inline)
+ (let ((raw (org-babel-execute-src-block
+ nil info '((:results . "silent"))))
+ (result-params (split-string
+ (cdr (assoc :results (nth 2 info))))))
+ (unless silent
+ (cond ;; respect the value of the :results header argument
+ ((member "file" result-params)
+ (org-babel-result-to-file raw))
+ ((or (member "raw" result-params)
+ (member "org" result-params))
+ (format "%s" raw))
+ ((member "code" result-params)
+ (format "src_%s{%s}" lang raw))
+ (t
+ (if (stringp raw)
+ (if (= 0 (length raw)) "=(no results)="
+ (format "%s" raw))
+ (format "%S" raw))))))
+ (prog1 nil
+ (setf (nth 2 info)
+ (org-babel-merge-params
+ (nth 2 info)
+ `((:results . ,(if silent "silent" "replace")))))
+ (cond
+ ((equal type 'block) (org-babel-execute-src-block nil info))
+ ((equal type 'lob)
+ (save-excursion
+ (re-search-backward org-babel-lob-one-liner-regexp nil t)
+ (org-babel-execute-src-block nil info)))))))))
+ ""))
+
+(provide 'ob-exp)
+
+;; arch-tag: 523abf4c-76d1-44ed-9f27-e3bddf34bf0f
+
+;;; ob-exp.el ends here
diff --git a/lisp/org/ob-gnuplot.el b/lisp/org/ob-gnuplot.el
new file mode 100644
index 00000000000..053d154610b
--- /dev/null
+++ b/lisp/org/ob-gnuplot.el
@@ -0,0 +1,235 @@
+;;; ob-gnuplot.el --- org-babel functions for gnuplot evaluation
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Org-Babel support for evaluating gnuplot source code.
+;;
+;; This differs from most standard languages in that
+;;
+;; 1) we are generally only going to return results of type "file"
+;;
+;; 2) we are adding the "file" and "cmdline" header arguments
+
+;;; Requirements:
+
+;; - gnuplot :: http://www.gnuplot.info/
+;;
+;; - gnuplot-mode :: http://cars9.uchicago.edu/~ravel/software/gnuplot-mode.html
+
+;;; Code:
+(require 'ob)
+(require 'ob-ref)
+(require 'ob-comint)
+(eval-when-compile (require 'cl))
+
+(declare-function org-time-string-to-time "org" (s))
+(declare-function org-combine-plists "org" (&rest plists))
+(declare-function orgtbl-to-generic "org-table" (table params))
+(declare-function gnuplot-mode "ext:gnuplot-mode" ())
+(declare-function gnuplot-send-string-to-gnuplot "ext:gnuplot-mode" (str txt))
+(declare-function gnuplot-send-buffer-to-gnuplot "ext:gnuplot-mode" ())
+
+(defvar org-babel-default-header-args:gnuplot
+ '((:results . "file") (:exports . "results") (:session . nil))
+ "Default arguments to use when evaluating a gnuplot source block.")
+
+(defvar org-babel-gnuplot-timestamp-fmt nil)
+
+(defun org-babel-gnuplot-process-vars (params)
+ "Extract variables from PARAMS and process the variables.
+Dumps all vectors into files and returns an association list
+of variable names and the related value to be used in the gnuplot
+code."
+ (mapcar
+ (lambda (pair)
+ (cons
+ (car pair) ;; variable name
+ (if (listp (cdr pair)) ;; variable value
+ (org-babel-gnuplot-table-to-data
+ (cdr pair) (org-babel-temp-file "gnuplot-") params)
+ (cdr pair))))
+ (mapcar #'cdr (org-babel-get-header params :var))))
+
+(defun org-babel-expand-body:gnuplot (body params)
+ "Expand BODY according to PARAMS, return the expanded body."
+ (save-window-excursion
+ (let* ((vars (org-babel-gnuplot-process-vars params))
+ (out-file (cdr (assoc :file params)))
+ (term (or (cdr (assoc :term params))
+ (when out-file (file-name-extension out-file))))
+ (cmdline (cdr (assoc :cmdline params)))
+ (title (plist-get params :title))
+ (lines (plist-get params :line))
+ (sets (plist-get params :set))
+ (x-labels (plist-get params :xlabels))
+ (y-labels (plist-get params :ylabels))
+ (timefmt (plist-get params :timefmt))
+ (time-ind (or (plist-get params :timeind)
+ (when timefmt 1)))
+ output)
+ (flet ((add-to-body (text)
+ (setq body (concat text "\n" body))))
+ ;; append header argument settings to body
+ (when title (add-to-body (format "set title '%s'" title))) ;; title
+ (when lines (mapc (lambda (el) (add-to-body el)) lines)) ;; line
+ (when sets
+ (mapc (lambda (el) (add-to-body (format "set %s" el))) sets))
+ (when x-labels
+ (add-to-body
+ (format "set xtics (%s)"
+ (mapconcat (lambda (pair)
+ (format "\"%s\" %d" (cdr pair) (car pair)))
+ x-labels ", "))))
+ (when y-labels
+ (add-to-body
+ (format "set ytics (%s)"
+ (mapconcat (lambda (pair)
+ (format "\"%s\" %d" (cdr pair) (car pair)))
+ y-labels ", "))))
+ (when time-ind
+ (add-to-body "set xdata time")
+ (add-to-body (concat "set timefmt \""
+ (or timefmt
+ "%Y-%m-%d-%H:%M:%S") "\"")))
+ (when out-file (add-to-body (format "set output \"%s\"" out-file)))
+ (when term (add-to-body (format "set term %s" term)))
+ ;; insert variables into code body: this should happen last
+ ;; placing the variables at the *top* of the code in case their
+ ;; values are used later
+ (add-to-body (mapconcat #'identity
+ (org-babel-variable-assignments:gnuplot params)
+ "\n"))
+ ;; replace any variable names preceded by '$' with the actual
+ ;; value of the variable
+ (mapc (lambda (pair)
+ (setq body (replace-regexp-in-string
+ (format "\\$%s" (car pair)) (cdr pair) body)))
+ vars))
+ body)))
+
+(defun org-babel-execute:gnuplot (body params)
+ "Execute a block of Gnuplot code.
+This function is called by `org-babel-execute-src-block'."
+ (require 'gnuplot)
+ (let ((session (cdr (assoc :session params)))
+ (result-type (cdr (assoc :results params)))
+ (out-file (cdr (assoc :file params)))
+ (body (org-babel-expand-body:gnuplot body params))
+ output)
+ (save-window-excursion
+ ;; evaluate the code body with gnuplot
+ (if (string= session "none")
+ (let ((script-file (org-babel-temp-file "gnuplot-script-")))
+ (with-temp-file script-file
+ (insert (concat body "\n")))
+ (message "gnuplot \"%s\"" script-file)
+ (setq output
+ (shell-command-to-string
+ (format
+ "gnuplot \"%s\""
+ (org-babel-process-file-name script-file))))
+ (message output))
+ (with-temp-buffer
+ (insert (concat body "\n"))
+ (gnuplot-mode)
+ (gnuplot-send-buffer-to-gnuplot)))
+ (if (member "output" (split-string result-type))
+ output
+ out-file))))
+
+(defun org-babel-prep-session:gnuplot (session params)
+ "Prepare SESSION according to the header arguments in PARAMS."
+ (let* ((session (org-babel-gnuplot-initiate-session session))
+ (var-lines (org-babel-variable-assignments:gnuplot params)))
+ (message "%S" session)
+ (org-babel-comint-in-buffer session
+ (mapc (lambda (var-line)
+ (insert var-line) (comint-send-input nil t)
+ (org-babel-comint-wait-for-output session)
+ (sit-for .1) (goto-char (point-max))) var-lines))
+ session))
+
+(defun org-babel-load-session:gnuplot (session body params)
+ "Load BODY into SESSION."
+ (save-window-excursion
+ (let ((buffer (org-babel-prep-session:gnuplot session params)))
+ (with-current-buffer buffer
+ (goto-char (process-mark (get-buffer-process (current-buffer))))
+ (insert (org-babel-chomp body)))
+ buffer)))
+
+(defun org-babel-variable-assignments:gnuplot (params)
+ "Return list of gnuplot statements assigning the block's variables"
+ (mapcar
+ (lambda (pair) (format "%s = \"%s\"" (car pair) (cdr pair)))
+ (org-babel-gnuplot-process-vars params)))
+
+(defvar gnuplot-buffer)
+(defun org-babel-gnuplot-initiate-session (&optional session params)
+ "Initiate a gnuplot session.
+If there is not a current inferior-process-buffer in SESSION
+then create one. Return the initialized session. The current
+`gnuplot-mode' doesn't provide support for multiple sessions."
+ (require 'gnuplot)
+ (unless (string= session "none")
+ (save-window-excursion
+ (gnuplot-send-string-to-gnuplot "" "line")
+ gnuplot-buffer)))
+
+(defun org-babel-gnuplot-quote-timestamp-field (s)
+ "Convert S from timestamp to Unix time and export to gnuplot."
+ (format-time-string org-babel-gnuplot-timestamp-fmt (org-time-string-to-time s)))
+
+(defvar org-table-number-regexp)
+(defvar org-ts-regexp3)
+(defun org-babel-gnuplot-quote-tsv-field (s)
+ "Quote S for export to gnuplot."
+ (unless (stringp s)
+ (setq s (format "%s" s)))
+ (if (string-match org-table-number-regexp s) s
+ (if (string-match org-ts-regexp3 s)
+ (org-babel-gnuplot-quote-timestamp-field s)
+ (concat "\"" (mapconcat 'identity (split-string s "\"") "\"\"") "\""))))
+
+(defun org-babel-gnuplot-table-to-data (table data-file params)
+ "Export TABLE to DATA-FILE in a format readable by gnuplot.
+Pass PARAMS through to `orgtbl-to-generic' when exporting TABLE."
+ (with-temp-file data-file
+ (make-local-variable 'org-babel-gnuplot-timestamp-fmt)
+ (setq org-babel-gnuplot-timestamp-fmt (or
+ (plist-get params :timefmt)
+ "%Y-%m-%d-%H:%M:%S"))
+ (insert (orgtbl-to-generic
+ table
+ (org-combine-plists
+ '(:sep "\t" :fmt org-babel-gnuplot-quote-tsv-field)
+ params))))
+ data-file)
+
+(provide 'ob-gnuplot)
+
+;; arch-tag: 50490ace-a9e1-4b29-a6e5-0db9f16c610b
+
+;;; ob-gnuplot.el ends here
diff --git a/lisp/org/ob-haskell.el b/lisp/org/ob-haskell.el
new file mode 100644
index 00000000000..1ae8fba66b6
--- /dev/null
+++ b/lisp/org/ob-haskell.el
@@ -0,0 +1,226 @@
+;;; ob-haskell.el --- org-babel functions for haskell evaluation
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Org-Babel support for evaluating haskell source code. This one will
+;; be sort of tricky because haskell programs must be compiled before
+;; they can be run, but haskell code can also be run through an
+;; interactive interpreter.
+;;
+;; For now lets only allow evaluation using the haskell interpreter.
+
+;;; Requirements:
+
+;; - haskell-mode :: http://www.iro.umontreal.ca/~monnier/elisp/#haskell-mode
+;;
+;; - inf-haskell :: http://www.iro.umontreal.ca/~monnier/elisp/#haskell-mode
+;;
+;; - (optionally) lhs2tex :: http://people.cs.uu.nl/andres/lhs2tex/
+
+;;; Code:
+(require 'ob)
+(require 'ob-comint)
+(require 'comint)
+(eval-when-compile (require 'cl))
+
+(declare-function org-remove-indentation "org" (code &optional n))
+(declare-function haskell-mode "ext:haskell-mode" ())
+(declare-function run-haskell "ext:inf-haskell" (&optional arg))
+(declare-function inferior-haskell-load-file
+ "ext:inf-haskell" (&optional reload))
+
+(add-to-list 'org-babel-tangle-lang-exts '("haskell" . "hs"))
+
+(defvar org-babel-default-header-args:haskell '())
+
+(defvar org-babel-haskell-lhs2tex-command "lhs2tex")
+
+(defvar org-babel-haskell-eoe "\"org-babel-haskell-eoe\"")
+
+(defun org-babel-execute:haskell (body params)
+ "Execute a block of Haskell code."
+ (let* ((session (cdr (assoc :session params)))
+ (vars (mapcar #'cdr (org-babel-get-header params :var)))
+ (result-type (cdr (assoc :result-type params)))
+ (full-body (org-babel-expand-body:generic
+ body params
+ (org-babel-variable-assignments:haskell params)))
+ (session (org-babel-haskell-initiate-session session params))
+ (raw (org-babel-comint-with-output
+ (session org-babel-haskell-eoe t full-body)
+ (insert (org-babel-trim full-body))
+ (comint-send-input nil t)
+ (insert org-babel-haskell-eoe)
+ (comint-send-input nil t)))
+ (results (mapcar
+ #'org-babel-haskell-read-string
+ (cdr (member org-babel-haskell-eoe
+ (reverse (mapcar #'org-babel-trim raw)))))))
+ (org-babel-reassemble-table
+ (cond
+ ((equal result-type 'output)
+ (mapconcat #'identity (reverse (cdr results)) "\n"))
+ ((equal result-type 'value)
+ (org-babel-haskell-table-or-string (car results))))
+ (org-babel-pick-name (cdr (assoc :colname-names params))
+ (cdr (assoc :colname-names params)))
+ (org-babel-pick-name (cdr (assoc :rowname-names params))
+ (cdr (assoc :rowname-names params))))))
+
+(defun org-babel-haskell-read-string (string)
+ "Strip \\\"s from around a haskell string."
+ (if (string-match "^\"\\([^\000]+\\)\"$" string)
+ (match-string 1 string)
+ string))
+
+(defun org-babel-haskell-initiate-session (&optional session params)
+ "Initiate a haskell session.
+If there is not a current inferior-process-buffer in SESSION
+then create one. Return the initialized session."
+ (require 'inf-haskell)
+ (or (get-buffer "*haskell*")
+ (save-window-excursion (run-haskell) (sleep-for 0.25) (current-buffer))))
+
+(defun org-babel-load-session:haskell (session body params)
+ "Load BODY into SESSION."
+ (save-window-excursion
+ (let* ((buffer (org-babel-prep-session:haskell session params))
+ (load-file (concat (org-babel-temp-file "haskell-load-") ".hs")))
+ (with-temp-buffer
+ (insert body) (write-file load-file)
+ (haskell-mode) (inferior-haskell-load-file))
+ buffer)))
+
+(defun org-babel-prep-session:haskell (session params)
+ "Prepare SESSION according to the header arguments in PARAMS."
+ (save-window-excursion
+ (let ((buffer (org-babel-haskell-initiate-session session)))
+ (org-babel-comint-in-buffer buffer
+ (mapc (lambda (line)
+ (insert line)
+ (comint-send-input nil t))
+ (org-babel-variable-assignments:haskell params)))
+ (current-buffer))))
+
+(defun org-babel-variable-assignments:haskell (params)
+ "Return list of haskell statements assigning the block's variables"
+ (mapcar (lambda (pair)
+ (format "let %s = %s"
+ (car pair)
+ (org-babel-haskell-var-to-haskell (cdr pair))))
+ (mapcar #'cdr (org-babel-get-header params :var))))
+
+(defun org-babel-haskell-table-or-string (results)
+ "Convert RESULTS to an Emacs-lisp table or string.
+If RESULTS look like a table, then convert them into an
+Emacs-lisp table, otherwise return the results as a string."
+ (org-babel-read
+ (if (and (stringp results) (string-match "^\\[.+\\]$" results))
+ (org-babel-read
+ (concat "'"
+ (replace-regexp-in-string
+ "\\[" "(" (replace-regexp-in-string
+ "\\]" ")" (replace-regexp-in-string
+ "," " " (replace-regexp-in-string
+ "'" "\"" results))))))
+ results)))
+
+(defun org-babel-haskell-var-to-haskell (var)
+ "Convert an elisp value VAR into a haskell variable.
+The elisp VAR is converted to a string of haskell source code
+specifying a variable of the same value."
+ (if (listp var)
+ (concat "[" (mapconcat #'org-babel-haskell-var-to-haskell var ", ") "]")
+ (format "%S" var)))
+
+(defvar org-src-preserve-indentation)
+(defun org-babel-haskell-export-to-lhs (&optional arg)
+ "Export to a .lhs file with all haskell code blocks escaped.
+When called with a prefix argument the resulting
+.lhs file will be exported to a .tex file. This function will
+create two new files, base-name.lhs and base-name.tex where
+base-name is the name of the current org-mode file.
+
+Note that all standard Babel literate programming
+constructs (header arguments, no-web syntax etc...) are ignored."
+ (interactive "P")
+ (let* ((contents (buffer-string))
+ (haskell-regexp
+ (concat "^\\([ \t]*\\)#\\+begin_src[ \t]haskell*\\(.*\\)?[\r\n]"
+ "\\([^\000]*?\\)[\r\n][ \t]*#\\+end_src.*"))
+ (base-name (file-name-sans-extension (buffer-file-name)))
+ (tmp-file (org-babel-temp-file "haskell-"))
+ (tmp-org-file (concat tmp-file ".org"))
+ (tmp-tex-file (concat tmp-file ".tex"))
+ (lhs-file (concat base-name ".lhs"))
+ (tex-file (concat base-name ".tex"))
+ (command (concat org-babel-haskell-lhs2tex-command
+ " " (org-babel-process-file-name lhs-file)
+ " > " (org-babel-process-file-name tex-file)))
+ (preserve-indentp org-src-preserve-indentation)
+ indentation)
+ ;; escape haskell source-code blocks
+ (with-temp-file tmp-org-file
+ (insert contents)
+ (goto-char (point-min))
+ (while (re-search-forward haskell-regexp nil t)
+ (save-match-data (setq indentation (length (match-string 1))))
+ (replace-match (save-match-data
+ (concat
+ "#+begin_latex\n\\begin{code}\n"
+ (if (or preserve-indentp
+ (string-match "-i" (match-string 2)))
+ (match-string 3)
+ (org-remove-indentation (match-string 3)))
+ "\n\\end{code}\n#+end_latex\n"))
+ t t)
+ (indent-code-rigidly (match-beginning 0) (match-end 0) indentation)))
+ (save-excursion
+ ;; export to latex w/org and save as .lhs
+ (find-file tmp-org-file) (funcall 'org-export-as-latex nil)
+ (kill-buffer)
+ (delete-file tmp-org-file)
+ (find-file tmp-tex-file)
+ (goto-char (point-min)) (forward-line 2)
+ (insert "%include polycode.fmt\n")
+ ;; ensure all \begin/end{code} statements start at the first column
+ (while (re-search-forward "^[ \t]+\\\\begin{code}[^\000]+\\\\end{code}" nil t)
+ (replace-match (save-match-data (org-remove-indentation (match-string 0)))
+ t t))
+ (setq contents (buffer-string))
+ (save-buffer) (kill-buffer))
+ (delete-file tmp-tex-file)
+ ;; save org exported latex to a .lhs file
+ (with-temp-file lhs-file (insert contents))
+ (if (not arg)
+ (find-file lhs-file)
+ ;; process .lhs file with lhs2tex
+ (message "running %s" command) (shell-command command) (find-file tex-file))))
+
+(provide 'ob-haskell)
+
+;; arch-tag: b53f75f3-ba1a-4b05-82d9-a2a0d4e70804
+
+;;; ob-haskell.el ends here
diff --git a/lisp/org/ob-js.el b/lisp/org/ob-js.el
new file mode 100644
index 00000000000..dc652a95c96
--- /dev/null
+++ b/lisp/org/ob-js.el
@@ -0,0 +1,163 @@
+;;; ob-js.el --- org-babel functions for Javascript
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research, js
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Now working with SBCL for both session and external evaluation.
+;;
+;; This certainly isn't optimally robust, but it seems to be working
+;; for the basic use cases.
+
+;;; Requirements:
+
+;; - a non-browser javascript engine such as node.js http://nodejs.org/
+;; or mozrepl http://wiki.github.com/bard/mozrepl/
+;;
+;; - for session based evaluation mozrepl and moz.el are required see
+;; http://wiki.github.com/bard/mozrepl/emacs-integration for
+;; configuration instructions
+
+;;; Code:
+(require 'ob)
+(require 'ob-ref)
+(require 'ob-comint)
+(require 'ob-eval)
+(eval-when-compile (require 'cl))
+
+(declare-function run-mozilla "ext:moz" (arg))
+
+(defvar org-babel-default-header-args:js '()
+ "Default header arguments for js code blocks.")
+
+(defvar org-babel-js-eoe "org-babel-js-eoe"
+ "String to indicate that evaluation has completed.")
+
+(defcustom org-babel-js-cmd "node"
+ "Name of command used to evaluate js blocks."
+ :group 'org-babel
+ :type 'string)
+
+(defvar org-babel-js-function-wrapper
+ "require('sys').print(require('sys').inspect(function(){%s}()));"
+ "Javascript code to print value of body.")
+
+(defun org-babel-execute:js (body params)
+ "Execute a block of Javascript code with org-babel.
+This function is called by `org-babel-execute-src-block'"
+ (let* ((org-babel-js-cmd (or (cdr (assoc :cmd params)) org-babel-js-cmd))
+ (result-type (cdr (assoc :result-type params)))
+ (full-body (org-babel-expand-body:generic
+ body params (org-babel-variable-assignments:js params))))
+ (org-babel-js-read
+ (if (not (string= (cdr (assoc :session params)) "none"))
+ ;; session evaluation
+ (let ((session (org-babel-prep-session:js
+ (cdr (assoc :session params)) params)))
+ (nth 1
+ (org-babel-comint-with-output
+ (session (format "%S" org-babel-js-eoe) t body)
+ (mapc
+ (lambda (line)
+ (insert (org-babel-chomp line)) (comint-send-input nil t))
+ (list body (format "%S" org-babel-js-eoe))))))
+ ;; external evaluation
+ (let ((script-file (org-babel-temp-file "js-script-")))
+ (with-temp-file script-file
+ (insert
+ ;; return the value or the output
+ (if (string= result-type "value")
+ (format org-babel-js-function-wrapper full-body)
+ full-body)))
+ (org-babel-eval
+ (format "%s %s" org-babel-js-cmd
+ (org-babel-process-file-name script-file)) ""))))))
+
+(defun org-babel-js-read (results)
+ "Convert RESULTS into an appropriate elisp value.
+If RESULTS look like a table, then convert them into an
+Emacs-lisp table, otherwise return the results as a string."
+ (org-babel-read
+ (if (and (stringp results) (string-match "^\\[.+\\]$" results))
+ (org-babel-read
+ (concat "'"
+ (replace-regexp-in-string
+ "\\[" "(" (replace-regexp-in-string
+ "\\]" ")" (replace-regexp-in-string
+ ", " " " (replace-regexp-in-string
+ "'" "\"" results))))))
+ results)))
+
+(defun org-babel-js-var-to-js (var)
+ "Convert VAR into a js variable.
+Convert an elisp value into a string of js source code
+specifying a variable of the same value."
+ (if (listp var)
+ (concat "[" (mapconcat #'org-babel-js-var-to-js var ", ") "]")
+ (format "%S" var)))
+
+(defun org-babel-prep-session:js (session params)
+ "Prepare SESSION according to the header arguments specified in PARAMS."
+ (let* ((session (org-babel-js-initiate-session session))
+ (var-lines (org-babel-variable-assignments:js params)))
+ (when session
+ (org-babel-comint-in-buffer session
+ (sit-for .5) (goto-char (point-max))
+ (mapc (lambda (var)
+ (insert var) (comint-send-input nil t)
+ (org-babel-comint-wait-for-output session)
+ (sit-for .1) (goto-char (point-max))) var-lines)))
+ session))
+
+(defun org-babel-variable-assignments:js (params)
+ "Return list of Javascript statements assigning the block's variables"
+ (mapcar
+ (lambda (pair) (format "var %s=%s;"
+ (car pair) (org-babel-js-var-to-js (cdr pair))))
+ (mapcar #'cdr (org-babel-get-header params :var))))
+
+(defun org-babel-js-initiate-session (&optional session)
+ "If there is not a current inferior-process-buffer in SESSION
+then create. Return the initialized session."
+ (unless (string= session "none")
+ (cond
+ ((string= "mozrepl" org-babel-js-cmd)
+ (require 'moz)
+ (let ((session-buffer (save-window-excursion
+ (run-mozilla nil)
+ (rename-buffer session)
+ (current-buffer))))
+ (if (org-babel-comint-buffer-livep session-buffer)
+ (progn (sit-for .25) session-buffer)
+ (sit-for .5)
+ (org-babel-js-initiate-session session))))
+ ((string= "node" org-babel-js-cmd )
+ (error "session evaluation with node.js is not supported"))
+ (t
+ (error "sessions are only supported with mozrepl add \":cmd mozrepl\"")))))
+
+(provide 'ob-js)
+
+;; arch-tag: 84401fb3-b8d9-4bb6-9a90-cbe2d103d494
+
+;;; ob-js.el ends here
diff --git a/lisp/org/ob-keys.el b/lisp/org/ob-keys.el
new file mode 100644
index 00000000000..e04d9ade6bc
--- /dev/null
+++ b/lisp/org/ob-keys.el
@@ -0,0 +1,98 @@
+;;; ob-keys.el --- key bindings for org-babel
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Add org-babel keybindings to the org-mode keymap for exposing
+;; org-babel functions. These will all share a common prefix. See
+;; the value of `org-babel-key-bindings' for a list of interactive
+;; functions and their associated keys.
+
+;;; Code:
+(require 'ob)
+
+(defvar org-babel-key-prefix "\C-c\C-v"
+ "The key prefix for Babel interactive key-bindings.
+See `org-babel-key-bindings' for the list of interactive babel
+functions which are assigned key bindings, and see
+`org-babel-map' for the actual babel keymap.")
+
+(defvar org-babel-map (make-sparse-keymap)
+ "The keymap for interactive Babel functions.")
+
+;;;###autoload
+(defun org-babel-describe-bindings ()
+ "Describe all keybindings behind `org-babel-key-prefix'."
+ (interactive)
+ (describe-bindings org-babel-key-prefix))
+
+(defvar org-babel-key-bindings
+ '(("p" . org-babel-previous-src-block)
+ ("\C-p" . org-babel-previous-src-block)
+ ("n" . org-babel-next-src-block)
+ ("\C-n" . org-babel-next-src-block)
+ ("e" . org-babel-execute-maybe)
+ ("\C-e" . org-babel-execute-maybe)
+ ("o" . org-babel-open-src-block-result)
+ ("\C-o" . org-babel-open-src-block-result)
+ ("\C-v" . org-babel-expand-src-block)
+ ("v" . org-babel-expand-src-block)
+ ("u" . org-babel-goto-src-block-head)
+ ("\C-u" . org-babel-goto-src-block-head)
+ ("g" . org-babel-goto-named-src-block)
+ ("r" . org-babel-goto-named-result)
+ ("\C-r" . org-babel-goto-named-result)
+ ("\C-b" . org-babel-execute-buffer)
+ ("b" . org-babel-execute-buffer)
+ ("\C-s" . org-babel-execute-subtree)
+ ("s" . org-babel-execute-subtree)
+ ("\C-d" . org-babel-demarcate-block)
+ ("d" . org-babel-demarcate-block)
+ ("\C-t" . org-babel-tangle)
+ ("t" . org-babel-tangle)
+ ("\C-f" . org-babel-tangle-file)
+ ("f" . org-babel-tangle-file)
+ ("\C-l" . org-babel-load-in-session)
+ ("l" . org-babel-load-in-session)
+ ("\C-i" . org-babel-lob-ingest)
+ ("i" . org-babel-lob-ingest)
+ ("\C-z" . org-babel-switch-to-session)
+ ("z" . org-babel-switch-to-session-with-code)
+ ("\C-a" . org-babel-sha1-hash)
+ ("a" . org-babel-sha1-hash)
+ ("h" . org-babel-describe-bindings)
+ ("\C-x" . org-babel-do-key-sequence-in-edit-buffer)
+ ("x" . org-babel-do-key-sequence-in-edit-buffer)
+ ("\C-\M-h" . org-babel-mark-block))
+ "Alist of key bindings and interactive Babel functions.
+This list associates interactive Babel functions
+with keys. Each element of this list will add an entry to the
+`org-babel-map' using the letter key which is the `car' of the
+a-list placed behind the generic `org-babel-key-prefix'.")
+
+(provide 'ob-keys)
+
+;; arch-tag: 01e348ee-4906-46fa-839a-6b7b6f989048
+
+;;; ob-keys.el ends here
diff --git a/lisp/org/ob-latex.el b/lisp/org/ob-latex.el
new file mode 100644
index 00000000000..f4cf0802de6
--- /dev/null
+++ b/lisp/org/ob-latex.el
@@ -0,0 +1,180 @@
+;;; ob-latex.el --- org-babel functions for latex "evaluation"
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Org-Babel support for evaluating LaTeX source code.
+;;
+;; Currently on evaluation this returns raw LaTeX code, unless a :file
+;; header argument is given in which case small png or pdf files will
+;; be created directly form the latex source code.
+
+;;; Code:
+(require 'ob)
+
+(declare-function org-create-formula-image "org" (string tofile options buffer))
+(declare-function org-splice-latex-header "org"
+ (tpl def-pkg pkg snippets-p &optional extra))
+(declare-function org-export-latex-fix-inputenc "org-latex" ())
+(add-to-list 'org-babel-tangle-lang-exts '("latex" . "tex"))
+
+(defvar org-format-latex-header)
+(defvar org-format-latex-header-extra)
+(defvar org-export-latex-packages-alist)
+(defvar org-export-latex-default-packages-alist)
+(defvar org-export-pdf-logfiles)
+(defvar org-latex-to-pdf-process)
+(defvar org-export-pdf-remove-logfiles)
+(defvar org-format-latex-options)
+(defvar org-export-latex-packages-alist)
+
+(defvar org-babel-default-header-args:latex
+ '((:results . "latex") (:exports . "results"))
+ "Default arguments to use when evaluating a LaTeX source block.")
+
+(defun org-babel-expand-body:latex (body params)
+ "Expand BODY according to PARAMS, return the expanded body."
+ (mapc (lambda (pair) ;; replace variables
+ (setq body
+ (replace-regexp-in-string
+ (regexp-quote (format "%S" (car pair)))
+ (if (stringp (cdr pair))
+ (cdr pair) (format "%S" (cdr pair)))
+ body))) (mapcar #'cdr (org-babel-get-header params :var)))
+ (org-babel-trim body))
+
+(defun org-babel-execute:latex (body params)
+ "Execute a block of Latex code with Babel.
+This function is called by `org-babel-execute-src-block'."
+ (setq body (org-babel-expand-body:latex body params))
+ (if (cdr (assoc :file params))
+ (let* ((out-file (cdr (assoc :file params)))
+ (tex-file (org-babel-temp-file "latex-" ".tex"))
+ (border (cdr (assoc :border params)))
+ (fit (or (cdr (assoc :fit params)) border))
+ (height (and fit (cdr (assoc :pdfheight params))))
+ (width (and fit (cdr (assoc :pdfwidth params))))
+ (headers (cdr (assoc :headers params)))
+ (in-buffer (not (string= "no" (cdr (assoc :buffer params)))))
+ (org-export-latex-packages-alist
+ (append (cdr (assoc :packages params))
+ org-export-latex-packages-alist)))
+ (cond
+ ((string-match "\\.png$" out-file)
+ (org-create-formula-image
+ body out-file org-format-latex-options in-buffer))
+ ((string-match "\\.pdf$" out-file)
+ (require 'org-latex)
+ (with-temp-file tex-file
+ (insert
+ (org-splice-latex-header
+ org-format-latex-header
+ (delq
+ nil
+ (mapcar
+ (lambda (el)
+ (unless (and (listp el) (string= "hyperref" (cadr el)))
+ el))
+ org-export-latex-default-packages-alist))
+ org-export-latex-packages-alist
+ org-format-latex-header-extra)
+ (if fit "\n\\usepackage[active, tightpage]{preview}\n" "")
+ (if border (format "\\setlength{\\PreviewBorder}{%s}" border) "")
+ (if height (concat "\n" (format "\\pdfpageheight %s" height)) "")
+ (if width (concat "\n" (format "\\pdfpagewidth %s" width)) "")
+ (if headers
+ (concat "\n"
+ (if (listp headers)
+ (mapconcat #'identity headers "\n")
+ headers) "\n")
+ "")
+ (if org-format-latex-header-extra
+ (concat "\n" org-format-latex-header-extra)
+ "")
+ (if fit
+ (concat "\n\\begin{document}\n\\begin{preview}\n" body
+ "\n\\end{preview}\n\\end{document}\n")
+ (concat "\n\\begin{document}\n" body "\n\\end{document}\n")))
+ (org-export-latex-fix-inputenc))
+ (when (file-exists-p out-file) (delete-file out-file))
+ (rename-file (org-babel-latex-tex-to-pdf tex-file) out-file))
+ ((string-match "\\.\\([^\\.]+\\)$" out-file)
+ (error "can not create %s files, please specify a .png or .pdf file"
+ (match-string 1 out-file))))
+ out-file)
+ body))
+
+(defun org-babel-latex-tex-to-pdf (file)
+ "Generate a pdf file according to the contents FILE.
+Extracted from `org-export-as-pdf' in org-latex.el."
+ (let* ((wconfig (current-window-configuration))
+ (default-directory (file-name-directory file))
+ (base (file-name-sans-extension file))
+ (pdffile (concat base ".pdf"))
+ (cmds org-latex-to-pdf-process)
+ (outbuf (get-buffer-create "*Org PDF LaTeX Output*"))
+ output-dir cmd)
+ (with-current-buffer outbuf (erase-buffer))
+ (message (concat "Processing LaTeX file " file "..."))
+ (setq output-dir (file-name-directory file))
+ (if (and cmds (symbolp cmds))
+ (funcall cmds (shell-quote-argument file))
+ (while cmds
+ (setq cmd (pop cmds))
+ (while (string-match "%b" cmd)
+ (setq cmd (replace-match
+ (save-match-data
+ (shell-quote-argument base))
+ t t cmd)))
+ (while (string-match "%f" cmd)
+ (setq cmd (replace-match
+ (save-match-data
+ (shell-quote-argument file))
+ t t cmd)))
+ (while (string-match "%o" cmd)
+ (setq cmd (replace-match
+ (save-match-data
+ (shell-quote-argument output-dir))
+ t t cmd)))
+ (shell-command cmd outbuf)))
+ (message (concat "Processing LaTeX file " file "...done"))
+ (if (not (file-exists-p pdffile))
+ (error (concat "PDF file " pdffile " was not produced"))
+ (set-window-configuration wconfig)
+ (when org-export-pdf-remove-logfiles
+ (dolist (ext org-export-pdf-logfiles)
+ (setq file (concat base "." ext))
+ (and (file-exists-p file) (delete-file file))))
+ (message "Exporting to PDF...done")
+ pdffile)))
+
+(defun org-babel-prep-session:latex (session params)
+ "Return an error because LaTeX doesn't support sesstions."
+ (error "LaTeX does not support sessions"))
+
+(provide 'ob-latex)
+
+;; arch-tag: 1f13f7e2-26de-4c24-9274-9f331d4c6ff3
+
+;;; ob-latex.el ends here
diff --git a/lisp/org/ob-ledger.el b/lisp/org/ob-ledger.el
new file mode 100644
index 00000000000..33ec9d3a898
--- /dev/null
+++ b/lisp/org/ob-ledger.el
@@ -0,0 +1,72 @@
+;;; ob-ledger.el --- org-babel functions for ledger evaluation
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Eric S Fraga
+;; Keywords: literate programming, reproducible research, accounting
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Org-Babel support for evaluating ledger entries.
+;;
+;; This differs from most standard languages in that
+;;
+;; 1) there is no such thing as a "session" in ledger
+;;
+;; 2) we are generally only going to return output from the leger program
+;;
+;; 3) we are adding the "cmdline" header argument
+;;
+;; 4) there are no variables
+
+;;; Code:
+(require 'ob)
+
+(defvar org-babel-default-header-args:ledger
+ '((:results . "output") (:cmdline . "bal"))
+ "Default arguments to use when evaluating a ledger source block.")
+
+(defun org-babel-execute:ledger (body params)
+ "Execute a block of Ledger entries with org-babel. This function is
+called by `org-babel-execute-src-block'."
+ (message "executing Ledger source code block")
+ (let ((result-params (split-string (or (cdr (assoc :results params)) "")))
+ (cmdline (cdr (assoc :cmdline params)))
+ (in-file (org-babel-temp-file "ledger-"))
+ (out-file (org-babel-temp-file "ledger-output-")))
+ (with-temp-file in-file (insert body))
+ (message (concat "ledger"
+ " -f " (org-babel-process-file-name in-file)
+ " " cmdline))
+ (with-output-to-string
+ (shell-command (concat "ledger"
+ " -f " (org-babel-process-file-name in-file)
+ " " cmdline
+ " > " (org-babel-process-file-name out-file))))
+ (with-temp-buffer (insert-file-contents out-file) (buffer-string))))
+
+(defun org-babel-prep-session:ledger (session params)
+ (error "Ledger does not support sessions"))
+
+(provide 'ob-ledger)
+
+;; arch-tag: 7bbb529e-95a1-4236-9d29-b0000b918c7c
+
+;;; ob-ledger.el ends here
diff --git a/lisp/org/ob-lisp.el b/lisp/org/ob-lisp.el
new file mode 100644
index 00000000000..3f9ac673279
--- /dev/null
+++ b/lisp/org/ob-lisp.el
@@ -0,0 +1,108 @@
+;;; ob-lisp.el --- org-babel functions for Common Lisp
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: David T. O'Toole <dto@gnu.org>
+;; Eric Schulte
+;; Keywords: literate programming, reproducible research, lisp
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Now working with SBCL for both session and external evaluation.
+;;
+;; This certainly isn't optimally robust, but it seems to be working
+;; for the basic use cases.
+
+;;; Requirements:
+
+;; Requires SLIME (Superior Lisp Interaction Mode for Emacs.)
+;; See http://common-lisp.net/project/slime/
+
+;;; Code:
+(require 'ob)
+(require 'ob-ref)
+(require 'ob-comint)
+(require 'ob-eval)
+(declare-function slime-eval "ext:slime" (form))
+(declare-function slime-connected-p "ext:slime" ())
+(declare-function slime-process "ext:slime" ())
+(require 'slime nil 'noerror)
+
+(defvar org-babel-default-header-args:lisp '()
+ "Default header arguments for lisp code blocks.")
+
+(defcustom org-babel-lisp-cmd "sbcl --script"
+ "Name of command used to evaluate lisp blocks.")
+
+(defun org-babel-expand-body:lisp (body params)
+ "Expand BODY according to PARAMS, return the expanded body."
+ (let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
+ (if (> (length vars) 0)
+ (concat "(let ("
+ (mapconcat
+ (lambda (var) (format "%S" (print `(,(car var) ',(cdr var)))))
+ vars "\n ")
+ ")\n" body ")")
+ body)))
+
+(defun org-babel-execute:lisp (body params)
+ "Execute a block of Lisp code with org-babel.
+This function is called by `org-babel-execute-src-block'"
+ (message "executing Lisp source code block")
+ (let* ((session (org-babel-lisp-initiate-session
+ (cdr (assoc :session params))))
+ (result-type (cdr (assoc :result-type params)))
+ (full-body (org-babel-expand-body:lisp body params)))
+ (read
+ (if session
+ ;; session evaluation
+ (save-window-excursion
+ (cadr (slime-eval `(swank:eval-and-grab-output ,full-body))))
+ ;; external evaluation
+ (let ((script-file (org-babel-temp-file "lisp-script-")))
+ (with-temp-file script-file
+ (insert
+ ;; return the value or the output
+ (if (string= result-type "value")
+ (format "(print %s)" full-body)
+ full-body)))
+ (org-babel-eval
+ (format "%s %s" org-babel-lisp-cmd
+ (org-babel-process-file-name script-file)) ""))))))
+
+;; This function should be used to assign any variables in params in
+;; the context of the session environment.
+(defun org-babel-prep-session:lisp (session params)
+ "Prepare SESSION according to the header arguments specified in PARAMS."
+ (error "not yet implemented"))
+
+(defun org-babel-lisp-initiate-session (&optional session)
+ "If there is not a current inferior-process-buffer in SESSION
+then create. Return the initialized session."
+ (unless (string= session "none")
+ (save-window-excursion
+ (or (slime-connected-p)
+ (slime-process)))))
+
+(provide 'ob-lisp)
+
+;; arch-tag: 18086168-009f-4947-bbb5-3532375d851d
+
+;;; ob-lisp.el ends here
diff --git a/lisp/org/ob-lob.el b/lisp/org/ob-lob.el
new file mode 100644
index 00000000000..243666c0a1b
--- /dev/null
+++ b/lisp/org/ob-lob.el
@@ -0,0 +1,121 @@
+;;; ob-lob.el --- functions supporting the Library of Babel
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Dan Davison
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; See the online documentation for more information
+;;
+;; http://orgmode.org/worg/org-contrib/babel/
+
+;;; Code:
+(require 'ob)
+(require 'ob-table)
+
+(defvar org-babel-library-of-babel nil
+ "Library of source-code blocks.
+This is an association list. Populate the library by adding
+files to `org-babel-lob-files'.")
+
+(defcustom org-babel-lob-files '()
+ "Files used to populate the `org-babel-library-of-babel'.
+To add files to this list use the `org-babel-lob-ingest' command."
+ :group 'org-babel
+ :type 'list)
+
+;;;###autoload
+(defun org-babel-lob-ingest (&optional file)
+ "Add all named source-blocks defined in FILE to
+`org-babel-library-of-babel'."
+ (interactive "f")
+ (let ((lob-ingest-count 0))
+ (org-babel-map-src-blocks file
+ (let* ((info (org-babel-get-src-block-info 'light))
+ (source-name (nth 4 info)))
+ (when source-name
+ (setq source-name (intern source-name)
+ org-babel-library-of-babel
+ (cons (cons source-name info)
+ (assq-delete-all source-name org-babel-library-of-babel))
+ lob-ingest-count (1+ lob-ingest-count)))))
+ (message "%d src block%s added to Library of Babel"
+ lob-ingest-count (if (> lob-ingest-count 1) "s" ""))
+ lob-ingest-count))
+
+(defconst org-babel-lob-call-aliases '("lob" "call")
+ "Aliases to call a source block function.
+If you change the value of this variable then your files may
+ become unusable by other org-babel users, and vice versa.")
+
+(defconst org-babel-lob-one-liner-regexp
+ (concat
+ "^\\([ \t]*\\)#\\+\\(?:"
+ (mapconcat #'regexp-quote org-babel-lob-call-aliases "\\|")
+ "\\):[ \t]+\\([^\(\)\n]+\\)\(\\([^\n]*\\)\)\\(\\[.+\\]\\|\\)[ \t]*\\([^\n]*\\)")
+ "Regexp to match calls to predefined source block functions.")
+
+;; functions for executing lob one-liners
+;;;###autoload
+(defun org-babel-lob-execute-maybe ()
+ "Execute a Library of Babel source block, if appropriate.
+Detect if this is context for a Library Of Babel source block and
+if so then run the appropriate source block from the Library."
+ (interactive)
+ (let ((info (org-babel-lob-get-info)))
+ (if (nth 0 info) (progn (org-babel-lob-execute info) t) nil)))
+
+;;;###autoload
+(defun org-babel-lob-get-info ()
+ "Return a Library of Babel function call as a string."
+ (let ((case-fold-search t))
+ (save-excursion
+ (beginning-of-line 1)
+ (if (looking-at org-babel-lob-one-liner-regexp)
+ (append
+ (mapcar #'org-babel-clean-text-properties
+ (list
+ (format "%s(%s)%s"
+ (match-string 2) (match-string 3) (match-string 4))
+ (match-string 5)))
+ (list (length (match-string 1))))))))
+
+(defun org-babel-lob-execute (info)
+ "Execute the lob call specified by INFO."
+ (let ((params (org-babel-process-params
+ (org-babel-merge-params
+ org-babel-default-header-args
+ (org-babel-params-from-buffer)
+ (org-babel-params-from-properties)
+ (org-babel-parse-header-arguments
+ (org-babel-clean-text-properties
+ (concat ":var results="
+ (mapconcat #'identity (butlast info) " "))))))))
+ (org-babel-execute-src-block
+ nil (list "emacs-lisp" "results" params nil nil (nth 2 info)))))
+
+(provide 'ob-lob)
+
+;; arch-tag: ce0712c9-2147-4019-ba3f-42341b8b474b
+
+;;; ob-lob.el ends here
diff --git a/lisp/org/ob-matlab.el b/lisp/org/ob-matlab.el
new file mode 100644
index 00000000000..c75d806cc62
--- /dev/null
+++ b/lisp/org/ob-matlab.el
@@ -0,0 +1,48 @@
+;;; ob-matlab.el --- org-babel support for matlab evaluation
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Dan Davison
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Functions that are common to org-babel support for matlab and
+;; octave are in org-babel-octave.el
+
+;;; Requirements:
+
+;; Matlab
+
+;; matlab.el required for interactive emacs sessions and matlab-mode
+;; major mode for source code editing buffer
+;; http://matlab-emacs.sourceforge.net/
+
+;;; Code:
+(require 'ob)
+(require 'ob-octave)
+
+;; see ob-octave for matlab implementation
+
+(provide 'ob-matlab)
+
+;; arch-tag: 6b234299-c1f7-4eb1-ace8-7b93344065ac
+
+;;; ob-matlab.el ends here
diff --git a/lisp/org/ob-mscgen.el b/lisp/org/ob-mscgen.el
new file mode 100644
index 00000000000..119d28cfba0
--- /dev/null
+++ b/lisp/org/ob-mscgen.el
@@ -0,0 +1,86 @@
+;;; ob-msc.el --- org-babel functions for mscgen evaluation
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Juan Pechiar
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; This software provides EMACS org-babel export support for message
+;; sequence charts. The mscgen utility is used for processing the
+;; sequence definition, and must therefore be installed in the system.
+;;
+;; Mscgen is available and documented at
+;; http://www.mcternan.me.uk/mscgen/index.html
+;;
+;; This code is directly inspired by Eric Schulte's ob-dot.el
+;;
+;; Example:
+;;
+;; #+begin_src mscgen :file example.png
+;; msc {
+;; A,B;
+;; A -> B [ label = "send message" ];
+;; A <- B [ label = "get answer" ];
+;; }
+;; #+end_src
+;;
+;; Header for alternative file type:
+;;
+;; #+begin_src mscgen :file ex2.svg :filetype svg
+
+;; This differs from most standard languages in that
+;;
+;; 1) there is no such thing as a "session" in mscgen
+;; 2) we are generally only going to return results of type "file"
+;; 3) we are adding the "file" and "filetype" header arguments
+;; 4) there are no variables
+
+;;; Code:
+(require 'ob)
+(require 'ob-eval)
+
+(defvar org-babel-default-header-args:mscgen
+ '((:results . "file") (:exports . "results"))
+ "Default arguments to use when evaluating a mscgen source block.")
+
+(defun org-babel-execute:mscgen (body params)
+ "Execute a block of Mscgen code with Babel.
+This function is called by `org-babel-execute-src-block'.
+Default filetype is png. Modify by setting :filetype parameter to
+mscgen supported formats."
+ (let* ((out-file (or (cdr (assoc :file params)) "output.png" ))
+ (filetype (or (cdr (assoc :filetype params)) "png" )))
+ (unless (cdr (assoc :file params))
+ (error "
+ERROR: no output file specified. Add \":file name.png\" to the src header"))
+ (org-babel-eval (concat "mscgen -T " filetype " -o " out-file) body)
+ out-file))
+
+(defun org-babel-prep-session:mscgen (session params)
+ "Raise an error because Mscgen doesn't support sessions."
+ (error "Mscgen does not support sessions"))
+
+(provide 'ob-mscgen)
+
+;; arch-tag: 74695b1e-715f-4b5a-a3a9-d78ee39ba5c8
+
+;;; ob-msc.el ends here
diff --git a/lisp/org/ob-ocaml.el b/lisp/org/ob-ocaml.el
new file mode 100644
index 00000000000..2217118e537
--- /dev/null
+++ b/lisp/org/ob-ocaml.el
@@ -0,0 +1,157 @@
+;;; ob-ocaml.el --- org-babel functions for ocaml evaluation
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Org-Babel support for evaluating ocaml source code. This one will
+;; be sort of tricky because ocaml programs must be compiled before
+;; they can be run, but ocaml code can also be run through an
+;; interactive interpreter.
+;;
+;; For now lets only allow evaluation using the ocaml interpreter.
+
+;;; Requirements:
+
+;; - tuareg-mode :: http://www-rocq.inria.fr/~acohen/tuareg/
+
+;;; Code:
+(require 'ob)
+(require 'ob-comint)
+(require 'comint)
+(eval-when-compile (require 'cl))
+
+(declare-function tuareg-run-caml "ext:tuareg" ())
+(declare-function tuareg-interactive-send-input "ext:tuareg" ())
+
+(add-to-list 'org-babel-tangle-lang-exts '("ocaml" . "ml"))
+
+(defvar org-babel-default-header-args:ocaml '())
+
+(defvar org-babel-ocaml-eoe-indicator "\"org-babel-ocaml-eoe\";;")
+(defvar org-babel-ocaml-eoe-output "org-babel-ocaml-eoe")
+
+(defun org-babel-execute:ocaml (body params)
+ "Execute a block of Ocaml code with Babel."
+ (let* ((vars (mapcar #'cdr (org-babel-get-header params :var)))
+ (full-body (org-babel-expand-body:generic
+ body params
+ (org-babel-variable-assignments:ocaml params)))
+ (session (org-babel-prep-session:ocaml
+ (cdr (assoc :session params)) params))
+ (raw (org-babel-comint-with-output
+ (session org-babel-ocaml-eoe-output t full-body)
+ (insert
+ (concat
+ (org-babel-chomp full-body)"\n"org-babel-ocaml-eoe-indicator))
+ (tuareg-interactive-send-input)))
+ (clean
+ (car (let ((re (regexp-quote org-babel-ocaml-eoe-output)) out)
+ (delq nil (mapcar (lambda (line)
+ (if out
+ (progn (setq out nil) line)
+ (when (string-match re line)
+ (progn (setq out t) nil))))
+ (mapcar #'org-babel-trim (reverse raw))))))))
+ (org-babel-reassemble-table
+ (org-babel-ocaml-parse-output (org-babel-trim clean))
+ (org-babel-pick-name
+ (cdr (assoc :colname-names params)) (cdr (assoc :colnames params)))
+ (org-babel-pick-name
+ (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params))))))
+
+(defvar tuareg-interactive-buffer-name)
+(defun org-babel-prep-session:ocaml (session params)
+ "Prepare SESSION according to the header arguments in PARAMS."
+ (require 'tuareg)
+ (let ((tuareg-interactive-buffer-name (if (and (not (string= session "none"))
+ (not (string= session "default"))
+ (stringp session))
+ session
+ tuareg-interactive-buffer-name)))
+ (save-window-excursion (tuareg-run-caml)
+ (get-buffer tuareg-interactive-buffer-name))))
+
+(defun org-babel-variable-assignments:ocaml (params)
+ "Return list of ocaml statements assigning the block's variables"
+ (mapcar
+ (lambda (pair) (format "let %s = %s;;" (car pair)
+ (org-babel-ocaml-elisp-to-ocaml (cdr pair))))
+ (mapcar #'cdr (org-babel-get-header params :var))))
+
+(defun org-babel-ocaml-elisp-to-ocaml (val)
+ "Return a string of ocaml code which evaluates to VAL."
+ (if (listp val)
+ (concat "[|" (mapconcat #'org-babel-ocaml-elisp-to-ocaml val "; ") "|]")
+ (format "%S" val)))
+
+(defun org-babel-ocaml-parse-output (output)
+ "Parse OUTPUT.
+OUTPUT is string output from an ocaml process."
+ (let ((regexp "%s = \\(.+\\)$"))
+ (cond
+ ((string-match (format regexp "string") output)
+ (org-babel-read (match-string 1 output)))
+ ((or (string-match (format regexp "int") output)
+ (string-match (format regexp "float") output))
+ (string-to-number (match-string 1 output)))
+ ((string-match (format regexp "list") output)
+ (org-babel-ocaml-read-list (match-string 1 output)))
+ ((string-match (format regexp "array") output)
+ (org-babel-ocaml-read-array (match-string 1 output)))
+ (t (message "don't recognize type of %s" output) output))))
+
+(defun org-babel-ocaml-read-list (results)
+ "Convert RESULTS into an elisp table or string.
+If the results look like a table, then convert them into an
+Emacs-lisp table, otherwise return the results as a string."
+ (org-babel-read
+ (if (and (stringp results) (string-match "^\\[.+\\]$" results))
+ (org-babel-read
+ (replace-regexp-in-string
+ "\\[" "(" (replace-regexp-in-string
+ "\\]" ")" (replace-regexp-in-string
+ "; " " " (replace-regexp-in-string
+ "'" "\"" results)))))
+ results)))
+
+(defun org-babel-ocaml-read-array (results)
+ "Convert RESULTS into an elisp table or string.
+If the results look like a table, then convert them into an
+Emacs-lisp table, otherwise return the results as a string."
+ (org-babel-read
+ (if (and (stringp results) (string-match "^\\[.+\\]$" results))
+ (org-babel-read
+ (concat
+ "'" (replace-regexp-in-string
+ "\\[|" "(" (replace-regexp-in-string
+ "|\\]" ")" (replace-regexp-in-string
+ "; " " " (replace-regexp-in-string
+ "'" "\"" results))))))
+ results)))
+
+(provide 'ob-ocaml)
+
+;; arch-tag: 2e815f4d-365e-4d69-b1df-dd17fdd7b7b7
+
+;;; ob-ocaml.el ends here
diff --git a/lisp/org/ob-octave.el b/lisp/org/ob-octave.el
new file mode 100644
index 00000000000..d6affecd74d
--- /dev/null
+++ b/lisp/org/ob-octave.el
@@ -0,0 +1,264 @@
+;;; ob-octave.el --- org-babel functions for octave and matlab evaluation
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Dan Davison
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Requirements:
+
+;; octave
+;; octave-mode.el and octave-inf.el come with GNU emacs
+
+;;; Code:
+(require 'ob)
+(require 'ob-ref)
+(require 'ob-comint)
+(require 'ob-eval)
+(eval-when-compile (require 'cl))
+
+(declare-function matlab-shell "ext:matlab-mode")
+(declare-function matlab-shell-run-region "ext:matlab-mode")
+
+(defvar org-babel-default-header-args:matlab '())
+(defvar org-babel-default-header-args:octave '())
+
+(defvar org-babel-matlab-shell-command "matlab -nosplash"
+ "Shell command to run matlab as an external process.")
+(defvar org-babel-octave-shell-command "octave -q"
+ "Shell command to run octave as an external process.")
+
+(defvar org-babel-matlab-with-emacs-link nil
+ "If non-nil use matlab-shell-run-region for session evaluation.
+ This will use EmacsLink if (matlab-with-emacs-link) evaluates
+ to a non-nil value.")
+
+(defvar org-babel-matlab-emacs-link-wrapper-method
+ "%s
+if ischar(ans), fid = fopen('%s', 'w'); fprintf(fid, '%%s\\n', ans); fclose(fid);
+else, save -ascii %s ans
+end
+delete('%s')
+")
+(defvar org-babel-octave-wrapper-method
+ "%s
+if ischar(ans), fid = fopen('%s', 'w'); fprintf(fid, '%%s\\n', ans); fclose(fid);
+else, dlmwrite('%s', ans, '\\t')
+end")
+
+(defvar org-babel-octave-eoe-indicator "\'org_babel_eoe\'")
+
+(defvar org-babel-octave-eoe-output "ans = org_babel_eoe")
+
+(defun org-babel-execute:matlab (body params)
+ "Execute a block of matlab code with Babel."
+ (org-babel-execute:octave body params 'matlab))
+
+(defun org-babel-execute:octave (body params &optional matlabp)
+ "Execute a block of octave code with Babel."
+ (let* ((session
+ (funcall (intern (format "org-babel-%s-initiate-session"
+ (if matlabp "matlab" "octave")))
+ (cdr (assoc :session params)) params))
+ (vars (mapcar #'cdr (org-babel-get-header params :var)))
+ (result-params (cdr (assoc :result-params params)))
+ (result-type (cdr (assoc :result-type params)))
+ (out-file (cdr (assoc :file params)))
+ (full-body
+ (org-babel-expand-body:generic
+ body params (org-babel-variable-assignments:octave params)))
+ (result (org-babel-octave-evaluate
+ session full-body result-type matlabp)))
+ (or out-file
+ (org-babel-reassemble-table
+ result
+ (org-babel-pick-name
+ (cdr (assoc :colname-names params)) (cdr (assoc :colnames params)))
+ (org-babel-pick-name
+ (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params)))))))
+
+(defun org-babel-prep-session:matlab (session params)
+ "Prepare SESSION according to PARAMS."
+ (org-babel-prep-session:octave session params 'matlab))
+
+(defun org-babel-variable-assignments:octave (params)
+ "Return list of octave statements assigning the block's variables"
+ (mapcar
+ (lambda (pair)
+ (format "%s=%s"
+ (car pair)
+ (org-babel-octave-var-to-octave (cdr pair))))
+ (mapcar #'cdr (org-babel-get-header params :var))))
+
+(defalias 'org-babel-variable-assignments:matlab
+ 'org-babel-variable-assignments:octave)
+
+(defun org-babel-octave-var-to-octave (var)
+ "Convert an emacs-lisp value into an octave variable.
+Converts an emacs-lisp variable into a string of octave code
+specifying a variable of the same value."
+ (if (listp var)
+ (concat "[" (mapconcat #'org-babel-octave-var-to-octave var
+ (if (listp (car var)) "; " ",")) "]")
+ (format "%s" (or var "nil"))))
+
+(defun org-babel-prep-session:octave (session params &optional matlabp)
+ "Prepare SESSION according to the header arguments specified in PARAMS."
+ (let* ((session (org-babel-octave-initiate-session session params matlabp))
+ (var-lines (org-babel-variable-assignments:octave params)))
+ (org-babel-comint-in-buffer session
+ (mapc (lambda (var)
+ (end-of-line 1) (insert var) (comint-send-input nil t)
+ (org-babel-comint-wait-for-output session)) var-lines))
+ session))
+
+(defun org-babel-matlab-initiate-session (&optional session params)
+ "Create a matlab inferior process buffer.
+If there is not a current inferior-process-buffer in SESSION then
+create. Return the initialized session."
+ (org-babel-octave-initiate-session session params 'matlab))
+
+(defun org-babel-octave-initiate-session (&optional session params matlabp)
+ "Create an octave inferior process buffer.
+If there is not a current inferior-process-buffer in SESSION then
+create. Return the initialized session."
+ (if matlabp (require 'matlab) (require 'octave-inf))
+ (unless (string= session "none")
+ (let ((session (or session
+ (if matlabp "*Inferior Matlab*" "*Inferior Octave*"))))
+ (if (org-babel-comint-buffer-livep session) session
+ (save-window-excursion
+ (if matlabp (unless org-babel-matlab-with-emacs-link (matlab-shell))
+ (run-octave))
+ (rename-buffer (if (bufferp session) (buffer-name session)
+ (if (stringp session) session (buffer-name))))
+ (current-buffer))))))
+
+(defun org-babel-octave-evaluate
+ (session body result-type &optional matlabp)
+ "Pass BODY to the octave process in SESSION.
+If RESULT-TYPE equals 'output then return the outputs of the
+statements in BODY, if RESULT-TYPE equals 'value then return the
+value of the last statement in BODY, as elisp."
+ (if session
+ (org-babel-octave-evaluate-session session body result-type matlabp)
+ (org-babel-octave-evaluate-external-process body result-type matlabp)))
+
+(defun org-babel-octave-evaluate-external-process (body result-type matlabp)
+ "Evaluate BODY in an external octave process."
+ (let ((cmd (if matlabp
+ org-babel-matlab-shell-command
+ org-babel-octave-shell-command)))
+ (case result-type
+ (output (org-babel-eval cmd body))
+ (value (let ((tmp-file (org-babel-temp-file "octave-")))
+ (org-babel-eval
+ cmd
+ (format org-babel-octave-wrapper-method body
+ (org-babel-process-file-name tmp-file 'noquote)
+ (org-babel-process-file-name tmp-file 'noquote)))
+ (org-babel-octave-import-elisp-from-file tmp-file))))))
+
+(defun org-babel-octave-evaluate-session
+ (session body result-type &optional matlabp)
+ "Evaluate BODY in SESSION."
+ (let* ((tmp-file (org-babel-temp-file (if matlabp "matlab-" "octave-")))
+ (wait-file (org-babel-temp-file "matlab-emacs-link-wait-signal-"))
+ (full-body
+ (case result-type
+ (output
+ (mapconcat
+ #'org-babel-chomp
+ (list body org-babel-octave-eoe-indicator) "\n"))
+ (value
+ (if (and matlabp org-babel-matlab-with-emacs-link)
+ (concat
+ (format org-babel-matlab-emacs-link-wrapper-method
+ body
+ (org-babel-process-file-name tmp-file 'noquote)
+ (org-babel-process-file-name tmp-file 'noquote) wait-file) "\n")
+ (mapconcat
+ #'org-babel-chomp
+ (list (format org-babel-octave-wrapper-method
+ body
+ (org-babel-process-file-name tmp-file 'noquote)
+ (org-babel-process-file-name tmp-file 'noquote))
+ org-babel-octave-eoe-indicator) "\n")))))
+ (raw (if (and matlabp org-babel-matlab-with-emacs-link)
+ (save-window-excursion
+ (with-temp-buffer
+ (insert full-body)
+ (write-region "" 'ignored wait-file nil nil nil 'excl)
+ (matlab-shell-run-region (point-min) (point-max))
+ (message "Waiting for Matlab Emacs Link")
+ (while (file-exists-p wait-file) (sit-for 0.01))
+ "")) ;; matlab-shell-run-region doesn't seem to
+ ;; make *matlab* buffer contents easily
+ ;; available, so :results output currently
+ ;; won't work
+ (org-babel-comint-with-output
+ (session
+ (if matlabp
+ org-babel-octave-eoe-indicator
+ org-babel-octave-eoe-output)
+ t full-body)
+ (insert full-body) (comint-send-input nil t)))) results)
+ (case result-type
+ (value
+ (org-babel-octave-import-elisp-from-file tmp-file))
+ (output
+ (progn
+ (setq results
+ (if matlabp
+ (cdr (reverse (delq "" (mapcar
+ #'org-babel-octave-read-string
+ (mapcar #'org-babel-trim raw)))))
+ (cdr (member org-babel-octave-eoe-output
+ (reverse (mapcar
+ #'org-babel-octave-read-string
+ (mapcar #'org-babel-trim raw)))))))
+ (mapconcat #'identity (reverse results) "\n"))))))
+
+(defun org-babel-octave-import-elisp-from-file (file-name)
+ "Import data from FILE-NAME.
+This removes initial blank and comment lines and then calls
+`org-babel-import-elisp-from-file'."
+ (let ((temp-file (org-babel-temp-file "octave-matlab-")) beg end)
+ (with-temp-file temp-file
+ (insert-file-contents file-name)
+ (re-search-forward "^[ \t]*[^# \t]" nil t)
+ (if (< (setq beg (point-min))
+ (setq end (point-at-bol)))
+ (delete-region beg end)))
+ (org-babel-import-elisp-from-file temp-file '(16))))
+
+(defun org-babel-octave-read-string (string)
+ "Strip \\\"s from around octave string"
+ (if (string-match "^\"\\([^\000]+\\)\"$" string)
+ (match-string 1 string)
+ string))
+
+(provide 'ob-octave)
+
+;; arch-tag: d8e5f68b-ba13-440a-a495-b653e989e704
+
+;;; ob-octave.el ends here
diff --git a/lisp/org/ob-org.el b/lisp/org/ob-org.el
new file mode 100644
index 00000000000..86abbabfb13
--- /dev/null
+++ b/lisp/org/ob-org.el
@@ -0,0 +1,62 @@
+;;; ob-org.el --- org-babel functions for org code block evaluation
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This is the simplest of code blocks, where upon evaluation the
+;; contents of the code block are returned in a raw result.
+
+;;; Code:
+(require 'ob)
+
+(declare-function org-export-string "org-exp" (string fmt &optional dir))
+
+(defvar org-babel-default-header-args:org
+ '((:results . "raw silent") (:exports . "results"))
+ "Default arguments for evaluating a org source block.")
+
+(defvar org-babel-org-default-header
+ "#+TITLE: default empty header\n"
+ "Default header inserted during export of org blocks.")
+
+(defun org-babel-execute:org (body params)
+ "Execute a block of Org code with.
+This function is called by `org-babel-execute-src-block'."
+ (let ((result-params (split-string (or (cdr (assoc :results params)) "")))
+ (body (replace-regexp-in-string "^," "" body)))
+ (cond
+ ((member "latex" result-params) (org-export-string body "latex"))
+ ((member "html" result-params) (org-export-string body "html"))
+ ((member "ascii" result-params) (org-export-string body "ascii"))
+ (t body))))
+
+(defun org-babel-prep-session:org (session params)
+ "Return an error because org does not support sessions."
+ (error "Org does not support sessions"))
+
+(provide 'ob-org)
+
+;; arch-tag: 130af5fe-cc56-46bd-9508-fa0ebd94cb1f
+
+;;; ob-org.el ends here
diff --git a/lisp/org/ob-perl.el b/lisp/org/ob-perl.el
new file mode 100644
index 00000000000..23c0353fcb0
--- /dev/null
+++ b/lisp/org/ob-perl.el
@@ -0,0 +1,118 @@
+;;; ob-perl.el --- org-babel functions for perl evaluation
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Dan Davison
+;; Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Org-Babel support for evaluating perl source code.
+
+;;; Code:
+(require 'ob)
+(require 'ob-eval)
+(eval-when-compile (require 'cl))
+
+(add-to-list 'org-babel-tangle-lang-exts '("perl" . "pl"))
+
+(defvar org-babel-default-header-args:perl '())
+
+(defvar org-babel-perl-command "perl"
+ "Name of command to use for executing perl code.")
+
+(defun org-babel-execute:perl (body params)
+ "Execute a block of Perl code with Babel.
+This function is called by `org-babel-execute-src-block'."
+ (let* ((session (cdr (assoc :session params)))
+ (result-params (cdr (assoc :result-params params)))
+ (result-type (cdr (assoc :result-type params)))
+ (full-body (org-babel-expand-body:generic
+ body params (org-babel-variable-assignments:perl params)))
+ (session (org-babel-perl-initiate-session session)))
+ (org-babel-reassemble-table
+ (org-babel-perl-evaluate session full-body result-type)
+ (org-babel-pick-name
+ (cdr (assoc :colname-names params)) (cdr (assoc :colnames params)))
+ (org-babel-pick-name
+ (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params))))))
+
+(defun org-babel-prep-session:perl (session params)
+ "Prepare SESSION according to the header arguments in PARAMS."
+ (error "Sessions are not supported for Perl."))
+
+(defun org-babel-variable-assignments:perl (params)
+ "Return list of perl statements assigning the block's variables"
+ (mapcar
+ (lambda (pair)
+ (format "$%s=%s;"
+ (car pair)
+ (org-babel-perl-var-to-perl (cdr pair))))
+ (mapcar #'cdr (org-babel-get-header params :var))))
+
+;; helper functions
+
+(defun org-babel-perl-var-to-perl (var)
+ "Convert an elisp value to a perl variable.
+The elisp value, VAR, is converted to a string of perl source code
+specifying a var of the same value."
+ (if (listp var)
+ (concat "[" (mapconcat #'org-babel-perl-var-to-perl var ", ") "]")
+ (format "%S" var)))
+
+(defvar org-babel-perl-buffers '(:default . nil))
+
+(defun org-babel-perl-initiate-session (&optional session params)
+ "Return nil because sessions are not supported by perl"
+nil)
+
+(defvar org-babel-perl-wrapper-method
+ "
+sub main {
+%s
+}
+@r = main;
+open(o, \">%s\");
+print o join(\"\\n\", @r), \"\\n\"")
+
+(defvar org-babel-perl-pp-wrapper-method
+ nil)
+
+(defun org-babel-perl-evaluate (session body &optional result-type)
+ "Pass BODY to the Perl process in SESSION.
+If RESULT-TYPE equals 'output then return a list of the outputs
+of the statements in BODY, if RESULT-TYPE equals 'value then
+return the value of the last statement in BODY, as elisp."
+ (when session (error "Sessions are not supported for Perl."))
+ (case result-type
+ (output (org-babel-eval org-babel-perl-command body))
+ (value (let ((tmp-file (org-babel-temp-file "perl-")))
+ (org-babel-eval
+ org-babel-perl-command
+ (format org-babel-perl-wrapper-method body
+ (org-babel-process-file-name tmp-file 'noquote)))
+ (org-babel-eval-read-file tmp-file)))))
+
+(provide 'ob-perl)
+
+;; arch-tag: 88ef9396-d857-4dc3-8946-5a72bdfa2337
+
+;;; ob-perl.el ends here
diff --git a/lisp/org/ob-plantuml.el b/lisp/org/ob-plantuml.el
new file mode 100644
index 00000000000..37561020cb0
--- /dev/null
+++ b/lisp/org/ob-plantuml.el
@@ -0,0 +1,83 @@
+;;; ob-plantuml.el --- org-babel functions for plantuml evaluation
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Zhang Weize
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Org-Babel support for evaluating plantuml script.
+;;
+;; Inspired by Ian Yang's org-export-blocks-format-plantuml
+;; http://www.emacswiki.org/emacs/org-export-blocks-format-plantuml.el
+
+;;; Requirements:
+
+;; plantuml | http://plantuml.sourceforge.net/
+;; plantuml.jar | `org-plantuml-jar-path' should point to the jar file
+
+;;; Code:
+(require 'ob)
+(require 'ob-eval)
+
+(defvar org-babel-default-header-args:plantuml
+ '((:results . "file") (:exports . "results"))
+ "Default arguments for evaluating a plantuml source block.")
+
+(defcustom org-plantuml-jar-path nil
+ "Path to the plantuml.jar file."
+ :group 'org-babel
+ :type 'string)
+
+(defun org-babel-execute:plantuml (body params)
+ "Execute a block of plantuml code with org-babel.
+This function is called by `org-babel-execute-src-block'."
+ (let* ((result-params (split-string (or (cdr (assoc :results params)) "")))
+ (out-file (or (cdr (assoc :file params))
+ (error "plantuml requires a \":file\" header argument")))
+ (cmdline (cdr (assoc :cmdline params)))
+ (in-file (org-babel-temp-file "plantuml-"))
+ (cmd (if (not org-plantuml-jar-path)
+ (error "`org-plantuml-jar-path' is not set")
+ (concat "java -jar "
+ (shell-quote-argument
+ (expand-file-name org-plantuml-jar-path))
+ (if (string= (file-name-extension out-file) "svg")
+ " -tsvg" "")
+ " -p " cmdline " < "
+ (org-babel-process-file-name in-file)
+ " > "
+ (org-babel-process-file-name out-file)))))
+ (unless (file-exists-p org-plantuml-jar-path)
+ (error "Could not find plantuml.jar at %s" org-plantuml-jar-path))
+ (with-temp-file in-file (insert (concat "@startuml\n" body "\n@enduml")))
+ (message "%s" cmd) (org-babel-eval cmd "")
+ out-file))
+
+(defun org-babel-prep-session:plantuml (session params)
+ "Return an error because plantuml does not support sessions."
+ (error "Plantuml does not support sessions"))
+
+(provide 'ob-plantuml)
+
+;; arch-tag: 451f50c5-e779-407e-ad64-70e0e8f161d1
+
+;;; ob-plantuml.el ends here
diff --git a/lisp/org/ob-python.el b/lisp/org/ob-python.el
new file mode 100644
index 00000000000..22cb5337d7a
--- /dev/null
+++ b/lisp/org/ob-python.el
@@ -0,0 +1,289 @@
+;;; ob-python.el --- org-babel functions for python evaluation
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Dan Davison
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Org-Babel support for evaluating python source code.
+
+;;; Code:
+(require 'ob)
+(require 'ob-ref)
+(require 'ob-comint)
+(require 'ob-eval)
+(eval-when-compile (require 'cl))
+
+(declare-function org-remove-indentation "org" )
+(declare-function py-shell "ext:python-mode" (&optional argprompt))
+(declare-function run-python "ext:python" (&optional cmd noshow new))
+
+(add-to-list 'org-babel-tangle-lang-exts '("python" . "py"))
+
+(defvar org-babel-default-header-args:python '())
+
+(defvar org-babel-python-command "python"
+ "Name of command for executing python code.")
+
+(defvar org-babel-python-mode (if (featurep 'xemacs) 'python-mode 'python)
+ "Preferred python mode for use in running python interactively.")
+
+(defvar org-src-preserve-indentation)
+
+(defun org-babel-execute:python (body params)
+ "Execute a block of Python code with Babel.
+This function is called by `org-babel-execute-src-block'."
+ (let* ((session (org-babel-python-initiate-session
+ (cdr (assoc :session params))))
+ (result-params (cdr (assoc :result-params params)))
+ (result-type (cdr (assoc :result-type params)))
+ (full-body
+ (org-babel-expand-body:generic
+ body params (org-babel-variable-assignments:python params)))
+ (result (org-babel-python-evaluate
+ session full-body result-type result-params)))
+ (or (cdr (assoc :file params))
+ (org-babel-reassemble-table
+ result
+ (org-babel-pick-name (cdr (assoc :colname-names params))
+ (cdr (assoc :colnames params)))
+ (org-babel-pick-name (cdr (assoc :rowname-names params))
+ (cdr (assoc :rownames params)))))))
+
+(defun org-babel-prep-session:python (session params)
+ "Prepare SESSION according to the header arguments in PARAMS.
+VARS contains resolved variable references"
+ (let* ((session (org-babel-python-initiate-session session))
+ (var-lines
+ (org-babel-variable-assignments:python params)))
+ (org-babel-comint-in-buffer session
+ (mapc (lambda (var)
+ (end-of-line 1) (insert var) (comint-send-input)
+ (org-babel-comint-wait-for-output session)) var-lines))
+ session))
+
+(defun org-babel-load-session:python (session body params)
+ "Load BODY into SESSION."
+ (save-window-excursion
+ (let ((buffer (org-babel-prep-session:python session params)))
+ (with-current-buffer buffer
+ (goto-char (process-mark (get-buffer-process (current-buffer))))
+ (insert (org-babel-chomp body)))
+ buffer)))
+
+;; helper functions
+
+(defun org-babel-variable-assignments:python (params)
+ "Return list of python statements assigning the block's variables"
+ (mapcar
+ (lambda (pair)
+ (format "%s=%s"
+ (car pair)
+ (org-babel-python-var-to-python (cdr pair))))
+ (mapcar #'cdr (org-babel-get-header params :var))))
+
+(defun org-babel-python-var-to-python (var)
+ "Convert an elisp value to a python variable.
+Convert an elisp value, VAR, into a string of python source code
+specifying a variable of the same value."
+ (if (listp var)
+ (concat "[" (mapconcat #'org-babel-python-var-to-python var ", ") "]")
+ (if (equal var 'hline)
+ "None"
+ (format
+ (if (and (stringp var) (string-match "[\n\r]" var)) "\"\"%S\"\"" "%S")
+ var))))
+
+(defun org-babel-python-table-or-string (results)
+ "Convert RESULTS into an appropriate elisp value.
+If the results look like a list or tuple, then convert them into an
+Emacs-lisp table, otherwise return the results as a string."
+ ((lambda (res)
+ (if (listp res)
+ (mapcar (lambda (el) (if (equal el 'None) 'hline el)) res)
+ res))
+ (org-babel-read
+ (if (and (stringp results) (string-match "^[([].+[])]$" results))
+ (org-babel-read
+ (concat "'"
+ (replace-regexp-in-string
+ "\\[" "(" (replace-regexp-in-string
+ "\\]" ")" (replace-regexp-in-string
+ ", " " " (replace-regexp-in-string
+ "'" "\"" results t))))))
+ results))))
+
+(defvar org-babel-python-buffers '((:default . nil)))
+
+(defun org-babel-python-session-buffer (session)
+ "Return the buffer associated with SESSION."
+ (cdr (assoc session org-babel-python-buffers)))
+
+(defun org-babel-python-initiate-session-by-key (&optional session)
+ "Initiate a python session.
+If there is not a current inferior-process-buffer in SESSION
+then create. Return the initialized session."
+ (require org-babel-python-mode)
+ (save-window-excursion
+ (let* ((session (if session (intern session) :default))
+ (python-buffer (org-babel-python-session-buffer session)))
+ (cond
+ ((and (eq 'python org-babel-python-mode)
+ (fboundp 'run-python)) ; python.el
+ (run-python))
+ ((and (eq 'python-mode org-babel-python-mode)
+ (fboundp 'py-shell)) ; python-mode.el
+ ;; `py-shell' creates a buffer whose name is the value of
+ ;; `py-which-bufname' with '*'s at the beginning and end
+ (let* ((bufname (if python-buffer
+ (replace-regexp-in-string ;; zap surrounding *
+ "^\\*\\([^*]+\\)\\*$" "\\1" python-buffer)
+ (concat "Python-" (symbol-name session))))
+ (py-which-bufname bufname))
+ (py-shell)
+ (setq python-buffer (concat "*" bufname "*"))))
+ (t
+ (error "No function available for running an inferior python.")))
+ (setq org-babel-python-buffers
+ (cons (cons session python-buffer)
+ (assq-delete-all session org-babel-python-buffers)))
+ session)))
+
+(defun org-babel-python-initiate-session (&optional session params)
+ "Create a session named SESSION according to PARAMS."
+ (unless (string= session "none")
+ (org-babel-python-session-buffer
+ (org-babel-python-initiate-session-by-key session))))
+
+(defvar org-babel-python-eoe-indicator "'org_babel_python_eoe'"
+ "A string to indicate that evaluation has completed.")
+(defvar org-babel-python-wrapper-method
+ "
+def main():
+%s
+
+open('%s', 'w').write( str(main()) )")
+(defvar org-babel-python-pp-wrapper-method
+ "
+import pprint
+def main():
+%s
+
+open('%s', 'w').write( pprint.pformat(main()) )")
+
+(defun org-babel-python-evaluate
+ (session body &optional result-type result-params)
+ "Evaluate BODY as python code."
+ (if session
+ (org-babel-python-evaluate-session
+ session body result-type result-params)
+ (org-babel-python-evaluate-external-process
+ body result-type result-params)))
+
+(defun org-babel-python-evaluate-external-process
+ (body &optional result-type result-params)
+ "Evaluate BODY in external python process.
+If RESULT-TYPE equals 'output then return standard output as a
+string. If RESULT-TYPE equals 'value then return the value of the
+last statement in BODY, as elisp."
+ (case result-type
+ (output (org-babel-eval org-babel-python-command body))
+ (value (let ((tmp-file (org-babel-temp-file "python-")))
+ (org-babel-eval org-babel-python-command
+ (format
+ (if (member "pp" result-params)
+ org-babel-python-pp-wrapper-method
+ org-babel-python-wrapper-method)
+ (mapconcat
+ (lambda (line) (format "\t%s" line))
+ (split-string
+ (org-remove-indentation
+ (org-babel-trim body))
+ "[\r\n]") "\n")
+ (org-babel-process-file-name tmp-file 'noquote)))
+ ((lambda (raw)
+ (if (or (member "code" result-params)
+ (member "pp" result-params))
+ raw
+ (org-babel-python-table-or-string raw)))
+ (org-babel-eval-read-file tmp-file))))))
+
+(defun org-babel-python-evaluate-session
+ (session body &optional result-type result-params)
+ "Pass BODY to the Python process in SESSION.
+If RESULT-TYPE equals 'output then return standard output as a
+string. If RESULT-TYPE equals 'value then return the value of the
+last statement in BODY, as elisp."
+ (flet ((dump-last-value
+ (tmp-file pp)
+ (mapc
+ (lambda (statement) (insert statement) (comint-send-input))
+ (if pp
+ (list
+ "import pp"
+ (format "open('%s', 'w').write(pprint.pformat(_))"
+ (org-babel-process-file-name tmp-file 'noquote)))
+ (list (format "open('%s', 'w').write(str(_))"
+ (org-babel-process-file-name tmp-file 'noquote))))))
+ (input-body (body)
+ (mapc (lambda (statement) (insert statement) (comint-send-input))
+ (split-string (org-babel-trim body) "[\r\n]+"))
+ (comint-send-input) (comint-send-input)))
+ (case result-type
+ (output
+ (mapconcat
+ #'org-babel-trim
+ (butlast
+ (org-babel-comint-with-output
+ (session org-babel-python-eoe-indicator t body)
+ (let ((comint-process-echoes nil))
+ (input-body body)
+ (insert org-babel-python-eoe-indicator)
+ (comint-send-input))) 2) "\n"))
+ (value
+ ((lambda (results)
+ (if (or (member "code" result-params) (member "pp" result-params))
+ results
+ (org-babel-python-table-or-string results)))
+ (let ((tmp-file (org-babel-temp-file "python-")))
+ (org-babel-comint-with-output
+ (session org-babel-python-eoe-indicator t body)
+ (let ((comint-process-echoes nil))
+ (input-body body)
+ (dump-last-value tmp-file (member "pp" result-params))
+ (comint-send-input) (comint-send-input)
+ (insert org-babel-python-eoe-indicator)
+ (comint-send-input)))
+ (org-babel-eval-read-file tmp-file)))))))
+
+(defun org-babel-python-read-string (string)
+ "Strip 's from around python string"
+ (if (string-match "^'\\([^\000]+\\)'$" string)
+ (match-string 1 string)
+ string))
+
+(provide 'ob-python)
+
+;; arch-tag: f19b6c3d-dfcb-4a1a-9ce0-45ade1ebc212
+
+;;; ob-python.el ends here
diff --git a/lisp/org/ob-ref.el b/lisp/org/ob-ref.el
new file mode 100644
index 00000000000..e104d6bd693
--- /dev/null
+++ b/lisp/org/ob-ref.el
@@ -0,0 +1,233 @@
+;;; ob-ref.el --- org-babel functions for referencing external data
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Dan Davison
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Functions for referencing data from the header arguments of a
+;; org-babel block. The syntax of such a reference should be
+
+;; #+VAR: variable-name=file:resource-id
+
+;; - variable-name :: the name of the variable to which the value
+;; will be assigned
+
+;; - file :: path to the file containing the resource, or omitted if
+;; resource is in the current file
+
+;; - resource-id :: the id or name of the resource
+
+;; So an example of a simple src block referencing table data in the
+;; same file would be
+
+;; #+TBLNAME: sandbox
+;; | 1 | 2 | 3 |
+;; | 4 | org-babel | 6 |
+;;
+;; #+begin_src emacs-lisp :var table=sandbox
+;; (message table)
+;; #+end_src
+
+;;; Code:
+(require 'ob)
+(eval-when-compile
+ (require 'cl))
+
+(declare-function org-remove-if-not "org" (predicate seq))
+(declare-function org-at-table-p "org" (&optional table-type))
+(declare-function org-count "org" (CL-ITEM CL-SEQ))
+
+(defvar org-babel-ref-split-regexp
+ "[ \f\t\n\r\v]*\\(.+?\\)[ \f\t\n\r\v]*=[ \f\t\n\r\v]*\\(.+\\)[ \f\t\n\r\v]*")
+
+(defun org-babel-ref-parse (assignment)
+ "Parse a variable ASSIGNMENT in a header argument.
+If the right hand side of the assignment has a literal value
+return that value, otherwise interpret as a reference to an
+external resource and find it's value using
+`org-babel-ref-resolve'. Return a list with two elements. The
+first element of the list will be the name of the variable, and
+the second will be an emacs-lisp representation of the value of
+the variable."
+ (when (string-match org-babel-ref-split-regexp assignment)
+ (let ((var (match-string 1 assignment))
+ (ref (match-string 2 assignment)))
+ (cons (intern var)
+ ((lambda (val)
+ (if (equal :ob-must-be-reference val)
+ (org-babel-ref-resolve ref) val))
+ (org-babel-ref-literal ref))))))
+
+(defun org-babel-ref-literal (ref)
+ "Return the value of REF if it is a literal value.
+Determine if the right side of a header argument variable
+assignment is a literal value or is a reference to some external
+resource. REF should be a string of the right hand side of the
+assignment. If REF is literal then return it's value, otherwise
+return nil."
+ (let ((out (org-babel-read ref)))
+ (if (equal out ref)
+ (if (string-match "^\".+\"$" ref)
+ (read ref)
+ :ob-must-be-reference)
+ out)))
+
+(defvar org-babel-library-of-babel)
+(defun org-babel-ref-resolve (ref)
+ "Resolve the reference REF and return its value."
+ (save-excursion
+ (let ((case-fold-search t)
+ type args new-refere new-referent result lob-info split-file split-ref
+ index index-row index-col)
+ ;; if ref is indexed grab the indices -- beware nested indices
+ (when (and (string-match "\\[\\(.+\\)\\]" ref)
+ (let ((str (substring ref 0 (match-beginning 0))))
+ (= (org-count ?( str) (org-count ?) str))))
+ (setq index (match-string 1 ref))
+ (setq ref (substring ref 0 (match-beginning 0))))
+ ;; assign any arguments to pass to source block
+ (when (string-match "^\\(.+?\\)\(\\(.*\\)\)$" ref)
+ (setq new-refere (match-string 1 ref))
+ (setq new-referent (match-string 2 ref))
+ (when (> (length new-refere) 0)
+ (if (> (length new-referent) 0)
+ (setq args (mapcar (lambda (ref) (cons :var ref))
+ (org-babel-ref-split-args new-referent))))
+ (setq ref new-refere)))
+ (when (string-match "^\\(.+\\):\\(.+\\)$" ref)
+ (setq split-file (match-string 1 ref))
+ (setq split-ref (match-string 2 ref))
+ (find-file split-file) (setq ref split-ref))
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (if (let ((result_regexp (concat "^[ \t]*#\\+\\(TBLNAME\\|RESNAME"
+ "\\|RESULTS\\):[ \t]*"
+ (regexp-quote ref) "[ \t]*$"))
+ (regexp (concat org-babel-src-name-regexp
+ (regexp-quote ref) "\\(\(.*\)\\)?" "[ \t]*$")))
+ ;; goto ref in the current buffer
+ (or (and (not args)
+ (or (re-search-forward result_regexp nil t)
+ (re-search-backward result_regexp nil t)))
+ (re-search-forward regexp nil t)
+ (re-search-backward regexp nil t)
+ ;; check the Library of Babel
+ (setq lob-info (cdr (assoc (intern ref)
+ org-babel-library-of-babel)))))
+ (unless lob-info (goto-char (match-beginning 0)))
+ ;; ;; TODO: allow searching for names in other buffers
+ ;; (setq id-loc (org-id-find ref 'marker)
+ ;; buffer (marker-buffer id-loc)
+ ;; loc (marker-position id-loc))
+ ;; (move-marker id-loc nil)
+ (error "reference '%s' not found in this buffer" ref))
+ (if lob-info
+ (setq type 'lob)
+ (while (not (setq type (org-babel-ref-at-ref-p)))
+ (forward-line 1)
+ (beginning-of-line)
+ (if (or (= (point) (point-min)) (= (point) (point-max)))
+ (error "reference not found"))))
+ (let ((params (append args '((:results . "silent")))))
+ (setq result
+ (case type
+ ('results-line (org-babel-read-result))
+ ('table (org-babel-read-table))
+ ('file (org-babel-read-link))
+ ('source-block (org-babel-execute-src-block nil nil params))
+ ('lob (org-babel-execute-src-block nil lob-info params)))))
+ (if (symbolp result)
+ (format "%S" result)
+ (if (and index (listp result))
+ (org-babel-ref-index-list index result)
+ result))))))
+
+(defun org-babel-ref-index-list (index lis)
+ "Return the subset of LIS indexed by INDEX.
+
+Indices are 0 based and negative indices count from the end of
+LIS, so 0 references the first element of LIS and -1 references
+the last. If INDEX is separated by \",\"s then each \"portion\"
+is assumed to index into the next deepest nesting or dimension.
+
+A valid \"portion\" can consist of either an integer index, two
+integers separated by a \":\" in which case the entire range is
+returned, or an empty string or \"*\" both of which are
+interpreted to mean the entire range and as such are equivalent
+to \"0:-1\"."
+ (if (and (> (length index) 0) (string-match "^\\([^,]*\\),?" index))
+ (let ((ind-re "\\(\\([-[:digit:]]+\\):\\([-[:digit:]]+\\)\\|\*\\)")
+ (length (length lis))
+ (portion (match-string 1 index))
+ (remainder (substring index (match-end 0))))
+ (flet ((wrap (num) (if (< num 0) (+ length num) num))
+ (open (ls) (if (and (listp ls) (= (length ls) 1)) (car ls) ls)))
+ (open
+ (mapcar
+ (lambda (sub-lis) (org-babel-ref-index-list remainder sub-lis))
+ (if (or (= 0 (length portion)) (string-match ind-re portion))
+ (mapcar
+ (lambda (n) (nth n lis))
+ (apply 'org-number-sequence
+ (if (and (> (length portion) 0) (match-string 2 portion))
+ (list
+ (wrap (string-to-number (match-string 2 portion)))
+ (wrap (string-to-number (match-string 3 portion))))
+ (list (wrap 0) (wrap -1)))))
+ (list (nth (wrap (string-to-number portion)) lis)))))))
+ lis))
+
+(defun org-babel-ref-split-args (arg-string)
+ "Split ARG-STRING into top-level arguments of balanced parenthesis."
+ (let ((index 0) (depth 0) (buffer "") holder return)
+ ;; crawl along string, splitting at any ","s which are on the top level
+ (while (< index (length arg-string))
+ (setq holder (substring arg-string index (+ 1 index)))
+ (setq buffer (concat buffer holder))
+ (setq index (+ 1 index))
+ (cond
+ ((string= holder ",")
+ (when (= depth 0)
+ (setq return (reverse (cons (substring buffer 0 -1) return)))
+ (setq buffer "")))
+ ((or (string= holder "(") (string= holder "[")) (setq depth (+ depth 1)))
+ ((or (string= holder ")") (string= holder "]")) (setq depth (- depth 1)))))
+ (mapcar #'org-babel-trim (reverse (cons buffer return)))))
+
+(defvar org-bracket-link-regexp)
+(defun org-babel-ref-at-ref-p ()
+ "Return the type of reference located at point.
+Return nil if none of the supported reference types are found.
+Supported reference types are tables and source blocks."
+ (cond ((org-at-table-p) 'table)
+ ((looking-at "^[ \t]*#\\+BEGIN_SRC") 'source-block)
+ ((looking-at org-bracket-link-regexp) 'file)
+ ((looking-at org-babel-result-regexp) 'results-line)))
+
+(provide 'ob-ref)
+
+;; arch-tag: ace4a4f4-ea38-4dac-8fe6-6f52fcc43b6d
+
+;;; ob-ref.el ends here
diff --git a/lisp/org/ob-ruby.el b/lisp/org/ob-ruby.el
new file mode 100644
index 00000000000..70b46411086
--- /dev/null
+++ b/lisp/org/ob-ruby.el
@@ -0,0 +1,248 @@
+;;; ob-ruby.el --- org-babel functions for ruby evaluation
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Org-Babel support for evaluating ruby source code.
+
+;;; Requirements:
+
+;; - ruby and irb executables :: http://www.ruby-lang.org/
+;;
+;; - ruby-mode :: Can be installed through ELPA, or from
+;; http://github.com/eschulte/rinari/raw/master/util/ruby-mode.el
+;;
+;; - inf-ruby mode :: Can be installed through ELPA, or from
+;; http://github.com/eschulte/rinari/raw/master/util/inf-ruby.el
+
+;;; Code:
+(require 'ob)
+(require 'ob-ref)
+(require 'ob-comint)
+(require 'ob-eval)
+(eval-when-compile (require 'cl))
+
+(declare-function run-ruby "ext:inf-ruby" (&optional command name))
+
+(add-to-list 'org-babel-tangle-lang-exts '("ruby" . "rb"))
+
+(defvar org-babel-default-header-args:ruby '())
+
+(defvar org-babel-ruby-command "ruby"
+ "Name of command to use for executing ruby code.")
+
+(defun org-babel-execute:ruby (body params)
+ "Execute a block of Ruby code with Babel.
+This function is called by `org-babel-execute-src-block'."
+ (let* ((session (org-babel-ruby-initiate-session
+ (cdr (assoc :session params))))
+ (result-params (cdr (assoc :result-params params)))
+ (result-type (cdr (assoc :result-type params)))
+ (full-body (org-babel-expand-body:generic
+ body params (org-babel-variable-assignments:ruby params)))
+ (result (org-babel-ruby-evaluate
+ session full-body result-type result-params)))
+ (or (cdr (assoc :file params))
+ (org-babel-reassemble-table
+ result
+ (org-babel-pick-name (cdr (assoc :colname-names params))
+ (cdr (assoc :colnames params)))
+ (org-babel-pick-name (cdr (assoc :rowname-names params))
+ (cdr (assoc :rownames params)))))))
+
+(defun org-babel-prep-session:ruby (session params)
+ "Prepare SESSION according to the header arguments specified in PARAMS."
+ ;; (message "params=%S" params) ;; debugging
+ (let* ((session (org-babel-ruby-initiate-session session))
+ (var-lines (org-babel-variable-assignments:ruby params)))
+ (org-babel-comint-in-buffer session
+ (sit-for .5) (goto-char (point-max))
+ (mapc (lambda (var)
+ (insert var) (comint-send-input nil t)
+ (org-babel-comint-wait-for-output session)
+ (sit-for .1) (goto-char (point-max))) var-lines))
+ session))
+
+(defun org-babel-load-session:ruby (session body params)
+ "Load BODY into SESSION."
+ (save-window-excursion
+ (let ((buffer (org-babel-prep-session:ruby session params)))
+ (with-current-buffer buffer
+ (goto-char (process-mark (get-buffer-process (current-buffer))))
+ (insert (org-babel-chomp body)))
+ buffer)))
+
+;; helper functions
+
+(defun org-babel-variable-assignments:ruby (params)
+ "Return list of ruby statements assigning the block's variables"
+ (mapcar
+ (lambda (pair)
+ (format "%s=%s"
+ (car pair)
+ (org-babel-ruby-var-to-ruby (cdr pair))))
+ (mapcar #'cdr (org-babel-get-header params :var))))
+
+(defun org-babel-ruby-var-to-ruby (var)
+ "Convert VAR into a ruby variable.
+Convert an elisp value into a string of ruby source code
+specifying a variable of the same value."
+ (if (listp var)
+ (concat "[" (mapconcat #'org-babel-ruby-var-to-ruby var ", ") "]")
+ (format "%S" var)))
+
+(defun org-babel-ruby-table-or-string (results)
+ "Convert RESULTS into an appropriate elisp value.
+If RESULTS look like a table, then convert them into an
+Emacs-lisp table, otherwise return the results as a string."
+ (org-babel-read
+ (if (and (stringp results) (string-match "^\\[.+\\]$" results))
+ (org-babel-read
+ (concat "'"
+ (replace-regexp-in-string
+ "\\[" "(" (replace-regexp-in-string
+ "\\]" ")" (replace-regexp-in-string
+ ", " " " (replace-regexp-in-string
+ "'" "\"" results))))))
+ results)))
+
+(defun org-babel-ruby-initiate-session (&optional session params)
+ "Initiate a ruby session.
+If there is not a current inferior-process-buffer in SESSION
+then create one. Return the initialized session."
+ (require 'inf-ruby)
+ (unless (string= session "none")
+ (let ((session-buffer (save-window-excursion
+ (run-ruby nil session) (current-buffer))))
+ (if (org-babel-comint-buffer-livep session-buffer)
+ (progn (sit-for .25) session-buffer)
+ (sit-for .5)
+ (org-babel-ruby-initiate-session session)))))
+
+(defvar org-babel-ruby-eoe-indicator ":org_babel_ruby_eoe"
+ "String to indicate that evaluation has completed.")
+(defvar org-babel-ruby-f-write
+ "File.open('%s','w'){|f| f.write((_.class == String) ? _ : _.inspect)}")
+(defvar org-babel-ruby-pp-f-write
+ "File.open('%s','w'){|f| $stdout = f; pp(results); $stdout = orig_out}")
+(defvar org-babel-ruby-wrapper-method
+ "
+def main()
+%s
+end
+results = main()
+File.open('%s', 'w'){ |f| f.write((results.class == String) ? results : results.inspect) }
+")
+(defvar org-babel-ruby-pp-wrapper-method
+ "
+require 'pp'
+def main()
+%s
+end
+results = main()
+File.open('%s', 'w') do |f|
+ $stdout = f
+ pp results
+end
+")
+
+(defun org-babel-ruby-evaluate
+ (buffer body &optional result-type result-params)
+ "Pass BODY to the Ruby process in BUFFER.
+If RESULT-TYPE equals 'output then return a list of the outputs
+of the statements in BODY, if RESULT-TYPE equals 'value then
+return the value of the last statement in BODY, as elisp."
+ (if (not buffer)
+ ;; external process evaluation
+ (case result-type
+ (output (org-babel-eval org-babel-ruby-command body))
+ (value (let ((tmp-file (org-babel-temp-file "ruby-")))
+ (org-babel-eval
+ org-babel-ruby-command
+ (format (if (member "pp" result-params)
+ org-babel-ruby-pp-wrapper-method
+ org-babel-ruby-wrapper-method)
+ body (org-babel-process-file-name tmp-file 'noquote)))
+ ((lambda (raw)
+ (if (or (member "code" result-params)
+ (member "pp" result-params))
+ raw
+ (org-babel-ruby-table-or-string raw)))
+ (org-babel-eval-read-file tmp-file)))))
+ ;; comint session evaluation
+ (case result-type
+ (output
+ (mapconcat
+ #'identity
+ (butlast
+ (split-string
+ (mapconcat
+ #'org-babel-trim
+ (butlast
+ (org-babel-comint-with-output
+ (buffer org-babel-ruby-eoe-indicator t body)
+ (mapc
+ (lambda (line)
+ (insert (org-babel-chomp line)) (comint-send-input nil t))
+ (list body org-babel-ruby-eoe-indicator))
+ (comint-send-input nil t)) 2)
+ "\n") "[\r\n]")) "\n"))
+ (value
+ ((lambda (results)
+ (if (or (member "code" result-params) (member "pp" result-params))
+ results
+ (org-babel-ruby-table-or-string results)))
+ (let* ((tmp-file (org-babel-temp-file "ruby-"))
+ (ppp (or (member "code" result-params)
+ (member "pp" result-params))))
+ (org-babel-comint-with-output
+ (buffer org-babel-ruby-eoe-indicator t body)
+ (when ppp (insert "require 'pp';") (comint-send-input nil t))
+ (mapc
+ (lambda (line)
+ (insert (org-babel-chomp line)) (comint-send-input nil t))
+ (append
+ (list body)
+ (if (not ppp)
+ (list (format org-babel-ruby-f-write
+ (org-babel-process-file-name tmp-file 'noquote)))
+ (list
+ "results=_" "require 'pp'" "orig_out = $stdout"
+ (format org-babel-ruby-pp-f-write
+ (org-babel-process-file-name tmp-file 'noquote))))
+ (list org-babel-ruby-eoe-indicator)))
+ (comint-send-input nil t))
+ (org-babel-eval-read-file tmp-file)))))))
+
+(defun org-babel-ruby-read-string (string)
+ "Strip \\\"s from around a ruby string."
+ (if (string-match "^\"\\([^\000]+\\)\"$" string)
+ (match-string 1 string)
+ string))
+
+(provide 'ob-ruby)
+
+;; arch-tag: 3e9726db-4520-49e2-b263-e8f571ac88f5
+
+;;; ob-ruby.el ends here
diff --git a/lisp/org/ob-sass.el b/lisp/org/ob-sass.el
new file mode 100644
index 00000000000..7f241e0320d
--- /dev/null
+++ b/lisp/org/ob-sass.el
@@ -0,0 +1,69 @@
+;;; ob-sass.el --- org-babel functions for the sass css generation language
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; For more information on sass see http://sass-lang.com/
+;;
+;; This accepts a 'file' header argument which is the target of the
+;; compiled sass. The default output type for sass evaluation is
+;; either file (if a 'file' header argument was given) or scalar if no
+;; such header argument was supplied.
+;;
+;; A 'cmdline' header argument can be supplied to pass arguments to
+;; the sass command line.
+
+;;; Requirements:
+
+;; - sass-mode :: http://github.com/nex3/haml/blob/master/extra/sass-mode.el
+
+;;; Code:
+(require 'ob)
+
+(defvar org-babel-default-header-args:sass '())
+
+(defun org-babel-execute:sass (body params)
+ "Execute a block of Sass code with Babel.
+This function is called by `org-babel-execute-src-block'."
+ (let* ((result-params (split-string (or (cdr (assoc :results params)) "")))
+ (file (cdr (assoc :file params)))
+ (out-file (or file (org-babel-temp-file "sass-out-")))
+ (cmdline (cdr (assoc :cmdline params)))
+ (in-file (org-babel-temp-file "sass-in-"))
+ (cmd (concat "sass " (or cmdline "")
+ " " (org-babel-process-file-name in-file)
+ " " (org-babel-process-file-name out-file))))
+ (with-temp-file in-file
+ (insert (org-babel-expand-body:generic body params))) (shell-command cmd)
+ (or file (with-temp-buffer (insert-file-contents out-file) (buffer-string)))))
+
+(defun org-babel-prep-session:sass (session params)
+ "Raise an error because sass does not support sessions."
+ (error "Sass does not support sessions"))
+
+(provide 'ob-sass)
+
+;; arch-tag: 2954b169-eef4-45ce-a8e5-3e619f0f07ac
+
+;;; ob-sass.el ends here
diff --git a/lisp/org/ob-scheme.el b/lisp/org/ob-scheme.el
new file mode 100644
index 00000000000..c0e0a3fb6f9
--- /dev/null
+++ b/lisp/org/ob-scheme.el
@@ -0,0 +1,137 @@
+;;; ob-scheme.el --- org-babel functions for Scheme
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research, scheme
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Now working with SBCL for both session and external evaluation.
+;;
+;; This certainly isn't optimally robust, but it seems to be working
+;; for the basic use cases.
+
+;;; Requirements:
+
+;; - a working scheme implementation
+;; (e.g. guile http://www.gnu.org/software/guile/guile.html)
+;;
+;; - for session based evaluation cmuscheme.el is required which is
+;; included in Emacs
+
+;;; Code:
+(require 'ob)
+(require 'ob-ref)
+(require 'ob-comint)
+(require 'ob-eval)
+(eval-when-compile (require 'cl))
+
+(declare-function run-scheme "ext:cmuscheme" (cmd))
+
+(defvar org-babel-default-header-args:scheme '()
+ "Default header arguments for scheme code blocks.")
+
+(defvar org-babel-scheme-eoe "org-babel-scheme-eoe"
+ "String to indicate that evaluation has completed.")
+
+(defcustom org-babel-scheme-cmd "guile"
+ "Name of command used to evaluate scheme blocks."
+ :group 'org-babel
+ :type 'string)
+
+(defun org-babel-expand-body:scheme (body params)
+ "Expand BODY according to PARAMS, return the expanded body."
+ (let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
+ (if (> (length vars) 0)
+ (concat "(let ("
+ (mapconcat
+ (lambda (var) (format "%S" (print `(,(car var) ',(cdr var)))))
+ vars "\n ")
+ ")\n" body ")")
+ body)))
+
+(defvar scheme-program-name)
+(defun org-babel-execute:scheme (body params)
+ "Execute a block of Scheme code with org-babel.
+This function is called by `org-babel-execute-src-block'"
+ (let* ((result-type (cdr (assoc :result-type params)))
+ (org-babel-scheme-cmd (or (cdr (assoc :scheme params))
+ org-babel-scheme-cmd))
+ (full-body (org-babel-expand-body:scheme body params)))
+ (read
+ (if (not (string= (cdr (assoc :session params)) "none"))
+ ;; session evaluation
+ (let ((session (org-babel-prep-session:scheme
+ (cdr (assoc :session params)) params)))
+ (org-babel-comint-with-output
+ (session (format "%S" org-babel-scheme-eoe) t body)
+ (mapc
+ (lambda (line)
+ (insert (org-babel-chomp line)) (comint-send-input nil t))
+ (list body (format "%S" org-babel-scheme-eoe)))))
+ ;; external evaluation
+ (let ((script-file (org-babel-temp-file "scheme-script-")))
+ (with-temp-file script-file
+ (insert
+ ;; return the value or the output
+ (if (string= result-type "value")
+ (format "(display %s)" full-body)
+ full-body)))
+ (org-babel-eval
+ (format "%s %s" org-babel-scheme-cmd
+ (org-babel-process-file-name script-file)) ""))))))
+
+(defun org-babel-prep-session:scheme (session params)
+ "Prepare SESSION according to the header arguments specified in PARAMS."
+ (let* ((session (org-babel-scheme-initiate-session session))
+ (vars (mapcar #'cdr (org-babel-get-header params :var)))
+ (var-lines
+ (mapcar
+ (lambda (var) (format "%S" (print `(define ,(car var) ',(cdr var)))))
+ vars)))
+ (when session
+ (org-babel-comint-in-buffer session
+ (sit-for .5) (goto-char (point-max))
+ (mapc (lambda (var)
+ (insert var) (comint-send-input nil t)
+ (org-babel-comint-wait-for-output session)
+ (sit-for .1) (goto-char (point-max))) var-lines)))
+ session))
+
+(defun org-babel-scheme-initiate-session (&optional session)
+ "If there is not a current inferior-process-buffer in SESSION
+then create. Return the initialized session."
+ (require 'cmuscheme)
+ (unless (string= session "none")
+ (let ((session-buffer (save-window-excursion
+ (run-scheme org-babel-scheme-cmd)
+ (rename-buffer session)
+ (current-buffer))))
+ (if (org-babel-comint-buffer-livep session-buffer)
+ (progn (sit-for .25) session-buffer)
+ (sit-for .5)
+ (org-babel-scheme-initiate-session session)))))
+
+(provide 'ob-scheme)
+
+;; arch-tag: 6b2fe76f-4b25-4e87-ad1c-225b2f282a71
+
+;;; ob-scheme.el ends here
diff --git a/lisp/org/ob-screen.el b/lisp/org/ob-screen.el
new file mode 100644
index 00000000000..206e51b19fe
--- /dev/null
+++ b/lisp/org/ob-screen.el
@@ -0,0 +1,147 @@
+;;; ob-screen.el --- org-babel support for interactive terminal
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Benjamin Andresen
+;; Keywords: literate programming, interactive shell
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Org-Babel support for interactive terminals. Mostly shell scripts.
+;; Heavily inspired by 'eev' from Eduardo Ochs
+;;
+;; Adding :cmd and :terminal as header arguments
+;; :terminal must support the -T (title) and -e (command) parameter
+;;
+;; You can test the default setup. (xterm + sh) with
+;; M-x org-babel-screen-test RET
+
+;;; Code:
+(require 'ob)
+(require 'ob-ref)
+
+(defvar org-babel-screen-location "screen"
+ "The command location for screen.
+In case you want to use a different screen than one selected by your $PATH")
+
+(defvar org-babel-default-header-args:screen
+ '((:results . "silent") (:session . "default") (:cmd . "sh") (:terminal . "xterm"))
+ "Default arguments to use when running screen source blocks.")
+
+(defun org-babel-execute:screen (body params)
+ "Send a block of code via screen to a terminal using Babel.
+\"default\" session is used when none is specified."
+ (message "Sending source code block to interactive terminal session...")
+ (save-window-excursion
+ (let* ((session (cdr (assoc :session params)))
+ (socket (org-babel-screen-session-socketname session)))
+ (unless socket (org-babel-prep-session:screen session params))
+ (org-babel-screen-session-execute-string
+ session (org-babel-expand-body:generic body params)))))
+
+(defun org-babel-prep-session:screen (session params)
+ "Prepare SESSION according to the header arguments specified in PARAMS."
+ (let* ((session (cdr (assoc :session params)))
+ (socket (org-babel-screen-session-socketname session))
+ (cmd (cdr (assoc :cmd params)))
+ (terminal (cdr (assoc :terminal params)))
+ (process-name (concat "org-babel: terminal (" session ")")))
+ (apply 'start-process process-name "*Messages*"
+ terminal `("-T" ,(concat "org-babel: " session) "-e" ,org-babel-screen-location
+ "-c" "/dev/null" "-mS" ,(concat "org-babel-session-" session)
+ ,cmd))
+ ;; XXX: Is there a better way than the following?
+ (while (not (org-babel-screen-session-socketname session))
+ ;; wait until screen session is available before returning
+ )))
+
+;; helper functions
+
+(defun org-babel-screen-session-execute-string (session body)
+ "If SESSION exists, send BODY to it."
+ (let ((socket (org-babel-screen-session-socketname session)))
+ (when socket
+ (let ((tmpfile (org-babel-screen-session-write-temp-file session body)))
+ (apply 'start-process (concat "org-babel: screen (" session ")") "*Messages*"
+ org-babel-screen-location
+ `("-S" ,socket "-X" "eval" "msgwait 0"
+ ,(concat "readreg z " tmpfile)
+ "paste z"))))))
+
+(defun org-babel-screen-session-socketname (session)
+ "Check if SESSION exists by parsing output of \"screen -ls\"."
+ (let* ((screen-ls (shell-command-to-string "screen -ls"))
+ (sockets (delq
+ nil
+ (mapcar
+ (lambda (x)
+ (when (string-match (rx (or "(Attached)" "(Detached)")) x)
+ x))
+ (split-string screen-ls "\n"))))
+ (match-socket (car
+ (delq
+ nil
+ (mapcar
+ (lambda (x)
+ (when (string-match
+ (concat "org-babel-session-" session) x)
+ x))
+ sockets)))))
+ (when match-socket (car (split-string match-socket)))))
+
+(defun org-babel-screen-session-write-temp-file (session body)
+ "Save BODY in a temp file that is named after SESSION."
+ (let ((tmpfile (concat "/tmp/screen.org-babel-session-" session)))
+ (with-temp-file tmpfile
+ (insert body)
+
+ ;; org-babel has superflous spaces
+ (goto-char (point-min))
+ (delete-matching-lines "^ +$"))
+ tmpfile))
+
+(defun org-babel-screen-test ()
+ "Test if the default setup works.
+The terminal should shortly flicker."
+ (interactive)
+ (let* ((session "org-babel-testing")
+ (random-string (format "%s" (random 99999)))
+ (tmpfile "/tmp/org-babel-screen.test")
+ (body (concat "echo '" random-string "' > " tmpfile "\nexit\n"))
+ process tmp-string)
+ (org-babel-execute:screen body org-babel-default-header-args:screen)
+ ;; XXX: need to find a better way to do the following
+ (while (not (file-readable-p tmpfile))
+ ;; do something, otherwise this will be optimized away
+ (format "org-babel-screen: File not readable yet."))
+ (setq tmp-string (with-temp-buffer
+ (insert-file-contents-literally tmpfile)
+ (buffer-substring (point-min) (point-max))))
+ (delete-file tmpfile)
+ (message (concat "org-babel-screen: Setup "
+ (if (string-match random-string tmp-string)
+ "WORKS."
+ "DOESN'T work.")))))
+
+(provide 'ob-screen)
+
+;; arch-tag: 908e5afe-89a0-4f27-b982-23f1f2e3bac9
+
+;;; ob-screen.el ends here
diff --git a/lisp/org/ob-sh.el b/lisp/org/ob-sh.el
new file mode 100644
index 00000000000..e86386426cd
--- /dev/null
+++ b/lisp/org/ob-sh.el
@@ -0,0 +1,180 @@
+;;; ob-sh.el --- org-babel functions for shell evaluation
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Org-Babel support for evaluating shell source code.
+
+;;; Code:
+(require 'ob)
+(require 'ob-comint)
+(require 'ob-eval)
+(require 'shell)
+(eval-when-compile (require 'cl))
+
+(declare-function org-babel-comint-in-buffer "ob-comint" (buffer &rest body))
+(declare-function org-babel-comint-wait-for-output "ob-comint" (buffer))
+(declare-function org-babel-comint-buffer-livep "ob-comint" (buffer))
+(declare-function org-babel-comint-with-output "ob-comint" (meta &rest body))
+(declare-function orgtbl-to-generic "org-table" (table params))
+
+(defvar org-babel-default-header-args:sh '())
+
+(defvar org-babel-sh-command "sh"
+ "Command used to invoke a shell.
+This will be passed to `shell-command-on-region'")
+
+(defun org-babel-execute:sh (body params)
+ "Execute a block of Shell commands with Babel.
+This function is called by `org-babel-execute-src-block'."
+ (let* ((session (org-babel-sh-initiate-session
+ (cdr (assoc :session params))))
+ (result-params (cdr (assoc :result-params params)))
+ (full-body (org-babel-expand-body:generic
+ body params (org-babel-variable-assignments:sh params))))
+ (org-babel-reassemble-table
+ (org-babel-sh-evaluate session full-body result-params)
+ (org-babel-pick-name
+ (cdr (assoc :colname-names params)) (cdr (assoc :colnames params)))
+ (org-babel-pick-name
+ (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params))))))
+
+(defun org-babel-prep-session:sh (session params)
+ "Prepare SESSION according to the header arguments specified in PARAMS."
+ (let* ((session (org-babel-sh-initiate-session session))
+ (var-lines (org-babel-variable-assignments:sh params)))
+ (org-babel-comint-in-buffer session
+ (mapc (lambda (var)
+ (insert var) (comint-send-input nil t)
+ (org-babel-comint-wait-for-output session)) var-lines))
+ session))
+
+(defun org-babel-load-session:sh (session body params)
+ "Load BODY into SESSION."
+ (save-window-excursion
+ (let ((buffer (org-babel-prep-session:sh session params)))
+ (with-current-buffer buffer
+ (goto-char (process-mark (get-buffer-process (current-buffer))))
+ (insert (org-babel-chomp body)))
+ buffer)))
+
+;; helper functions
+
+(defun org-babel-variable-assignments:sh (params)
+ "Return list of shell statements assigning the block's variables"
+ (let ((sep (cdr (assoc :separator params))))
+ (mapcar
+ (lambda (pair)
+ (format "%s=%s"
+ (car pair)
+ (org-babel-sh-var-to-sh (cdr pair) sep)))
+ (mapcar #'cdr (org-babel-get-header params :var)))))
+
+(defun org-babel-sh-var-to-sh (var &optional sep)
+ "Convert an elisp value to a shell variable.
+Convert an elisp var into a string of shell commands specifying a
+var of the same value."
+ (if (listp var)
+ (flet ((deep-string (el)
+ (if (listp el)
+ (mapcar #'deep-string el)
+ (org-babel-sh-var-to-sh el sep))))
+ (format "$(cat <<BABEL_TABLE\n%s\nBABEL_TABLE\n)"
+ (orgtbl-to-generic
+ (deep-string (if (listp (car var)) var (list var)))
+ (list :sep (or sep "\t")))))
+ (if (stringp var)
+ (if (string-match "[\n\r]" var)
+ (format "$(cat <<BABEL_STRING\n%s\nBABEL_STRING\n)" var)
+ (format "%s" var))
+ (format "%S" var))))
+
+(defun org-babel-sh-table-or-results (results)
+ "Convert RESULTS to an appropriate elisp value.
+If the results look like a table, then convert them into an
+Emacs-lisp table, otherwise return the results as a string."
+ (org-babel-read
+ (if (string-match "^\\[.+\\]$" results)
+ (org-babel-read
+ (concat "'"
+ (replace-regexp-in-string
+ "\\[" "(" (replace-regexp-in-string
+ "\\]" ")" (replace-regexp-in-string
+ ", " " " (replace-regexp-in-string
+ "'" "\"" results))))))
+ results)))
+
+(defun org-babel-sh-initiate-session (&optional session params)
+ "Initiate a session named SESSION according to PARAMS."
+ (when (and session (not (string= session "none")))
+ (save-window-excursion
+ (or (org-babel-comint-buffer-livep session)
+ (progn (shell session) (get-buffer (current-buffer)))))))
+
+(defvar org-babel-sh-eoe-indicator "echo 'org_babel_sh_eoe'"
+ "String to indicate that evaluation has completed.")
+(defvar org-babel-sh-eoe-output "org_babel_sh_eoe"
+ "String to indicate that evaluation has completed.")
+
+(defun org-babel-sh-evaluate (session body &optional result-params)
+ "Pass BODY to the Shell process in BUFFER.
+If RESULT-TYPE equals 'output then return a list of the outputs
+of the statements in BODY, if RESULT-TYPE equals 'value then
+return the value of the last statement in BODY."
+ ((lambda (results)
+ (when results
+ (if (or (member "scalar" result-params)
+ (member "output" result-params))
+ results
+ (let ((tmp-file (org-babel-temp-file "sh-")))
+ (with-temp-file tmp-file (insert results))
+ (org-babel-import-elisp-from-file tmp-file)))))
+ (if (not session)
+ (org-babel-eval org-babel-sh-command (org-babel-trim body))
+ (mapconcat
+ #'org-babel-sh-strip-weird-long-prompt
+ (mapcar
+ #'org-babel-trim
+ (butlast
+ (org-babel-comint-with-output
+ (session org-babel-sh-eoe-output t body)
+ (mapc
+ (lambda (line)
+ (insert line) (comint-send-input nil t) (sleep-for 0.25))
+ (append
+ (split-string (org-babel-trim body) "\n")
+ (list org-babel-sh-eoe-indicator))))
+ 2)) "\n"))))
+
+(defun org-babel-sh-strip-weird-long-prompt (string)
+ "Remove prompt cruft from a string of shell output."
+ (while (string-match "^% +[\r\n$]+ *" string)
+ (setq string (substring string (match-end 0))))
+ string)
+
+(provide 'ob-sh)
+
+;; arch-tag: 416dd531-c230-4b0a-a5bf-8d948f990f2d
+
+;;; ob-sh.el ends here
diff --git a/lisp/org/ob-sql.el b/lisp/org/ob-sql.el
new file mode 100644
index 00000000000..78e8a3b4377
--- /dev/null
+++ b/lisp/org/ob-sql.el
@@ -0,0 +1,94 @@
+;;; ob-sql.el --- org-babel functions for sql evaluation
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Org-Babel support for evaluating sql source code.
+;;
+;; SQL is somewhat unique in that there are many different engines for
+;; the evaluation of sql (Mysql, PostgreSQL, etc...), so much of this
+;; file will have to be implemented engine by engine.
+;;
+;; Also SQL evaluation generally takes place inside of a database.
+;;
+;; For now lets just allow a generic ':cmdline' header argument.
+;;
+;; TODO:
+;;
+;; - support for sessions
+;; - add more useful header arguments (user, passwd, database, etc...)
+;; - support for more engines (currently only supports mysql)
+;; - what's a reasonable way to drop table data into SQL?
+;;
+
+;;; Code:
+(require 'ob)
+(eval-when-compile (require 'cl))
+
+(declare-function org-table-import "org-table" (file arg))
+
+(defvar org-babel-default-header-args:sql '())
+
+(defun org-babel-execute:sql (body params)
+ "Execute a block of Sql code with Babel.
+This function is called by `org-babel-execute-src-block'."
+ (let* ((result-params (cdr (assoc :result-params params)))
+ (cmdline (cdr (assoc :cmdline params)))
+ (engine (cdr (assoc :engine params)))
+ (in-file (org-babel-temp-file "sql-in-"))
+ (out-file (or (cdr (assoc :out-file params))
+ (org-babel-temp-file "sql-out-")))
+ (command (case (intern engine)
+ ('mysql (format "mysql %s -e \"source %s\" > %s"
+ (or cmdline "")
+ (org-babel-process-file-name in-file)
+ (org-babel-process-file-name out-file)))
+ ('postgresql (format "psql -A -P footer=off -F \"\t\" -f %s -o %s %s"
+ (org-babel-process-file-name in-file)
+ (org-babel-process-file-name out-file)
+ (or cmdline "")))
+ (t (error "no support for the %s sql engine" engine)))))
+ (with-temp-file in-file
+ (insert (org-babel-expand-body:generic body params)))
+ (message command)
+ (shell-command command)
+ (with-temp-buffer
+ (org-table-import out-file nil)
+ (org-babel-reassemble-table
+ (org-table-to-lisp)
+ (org-babel-pick-name (cdr (assoc :colname-names params))
+ (cdr (assoc :colnames params)))
+ (org-babel-pick-name (cdr (assoc :rowname-names params))
+ (cdr (assoc :rownames params)))))))
+
+
+(defun org-babel-prep-session:sql (session params)
+ "Raise an error because Sql sessions aren't implemented."
+ (error "sql sessions not yet implemented"))
+
+(provide 'ob-sql)
+
+;; arch-tag: a43ff944-6de1-4566-a83c-626814e3dad2
+
+;;; ob-sql.el ends here
diff --git a/lisp/org/ob-sqlite.el b/lisp/org/ob-sqlite.el
new file mode 100644
index 00000000000..d1fa9ac4c5f
--- /dev/null
+++ b/lisp/org/ob-sqlite.el
@@ -0,0 +1,152 @@
+;;; ob-sqlite.el --- org-babel functions for sqlite database interaction
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Org-Babel support for evaluating sqlite source code.
+
+;;; Code:
+(require 'ob)
+(require 'ob-ref)
+
+(declare-function org-fill-template "org" (template alist))
+(declare-function org-table-convert-region "org-table"
+ (beg0 end0 &optional separator))
+(declare-function orgtbl-to-csv "org-table" (TABLE PARAMS))
+
+(defvar org-babel-default-header-args:sqlite '())
+
+(defvar org-babel-header-arg-names:sqlite
+ '(db header echo bail csv column html line list separator nullvalue)
+ "Sqlite specific header args.")
+
+(defun org-babel-expand-body:sqlite (body params)
+ "Expand BODY according to the values of PARAMS."
+ (org-babel-sqlite-expand-vars
+ body (mapcar #'cdr (org-babel-get-header params :var))))
+
+(defvar org-babel-sqlite3-command "sqlite3")
+
+(defun org-babel-execute:sqlite (body params)
+ "Execute a block of Sqlite code with Babel.
+This function is called by `org-babel-execute-src-block'."
+ (let ((result-params (split-string (or (cdr (assoc :results params)) "")))
+ (vars (org-babel-get-header params :var))
+ (db (cdr (assoc :db params)))
+ (separator (cdr (assoc :separator params)))
+ (nullvalue (cdr (assoc :nullvalue params)))
+ (headers-p (equal "yes" (cdr (assoc :colnames params))))
+ (others (delq nil (mapcar
+ (lambda (arg) (car (assoc arg params)))
+ (list :header :echo :bail :column
+ :csv :html :line :list))))
+ exit-code)
+ (unless db (error "ob-sqlite: can't evaluate without a database."))
+ (with-temp-buffer
+ (insert
+ (shell-command-to-string
+ (org-fill-template
+ "%cmd -init %body %header %separator %nullvalue %others %csv %db "
+ (list
+ (cons "body" ((lambda (sql-file)
+ (with-temp-file sql-file
+ (insert (org-babel-expand-body:sqlite body params)))
+ sql-file)
+ (org-babel-temp-file "sqlite-sql-")))
+ (cons "cmd" org-babel-sqlite3-command)
+ (cons "header" (if headers-p "-header" "-noheader"))
+ (cons "separator"
+ (if separator (format "-separator %s" separator) ""))
+ (cons "nullvalue"
+ (if nullvalue (format "-nullvalue %s" nullvalue) ""))
+ (cons "others"
+ (mapconcat
+ (lambda (arg) (format "-%s" (substring (symbol-name arg) 1)))
+ others " "))
+ ;; for easy table parsing, default header type should be -csv
+ (cons "csv" (if (or (member :csv others) (member :column others)
+ (member :line others) (member :list others)
+ (member :html others) separator)
+ ""
+ "-csv"))
+ (cons "db " db)))))
+ (if (or (member "scalar" result-params)
+ (member "html" result-params)
+ (member "code" result-params)
+ (equal (point-min) (point-max)))
+ (buffer-string)
+ (org-table-convert-region (point-min) (point-max))
+ (org-babel-sqlite-table-or-scalar
+ (org-babel-sqlite-offset-colnames
+ (org-table-to-lisp) headers-p))))))
+
+(defun org-babel-sqlite-expand-vars (body vars)
+ "Expand the variables held in VARS in BODY."
+ (mapc
+ (lambda (pair)
+ (setq body
+ (replace-regexp-in-string
+ (format "\$%s" (car pair))
+ ((lambda (val)
+ (if (listp val)
+ ((lambda (data-file)
+ (with-temp-file data-file
+ (insert (orgtbl-to-csv
+ val '(:fmt (lambda (el) (if (stringp el)
+ el
+ (format "%S" el)))))))
+ data-file)
+ (org-babel-temp-file "sqlite-data-"))
+ (if (stringp val) val (format "%S" val))))
+ (cdr pair))
+ body)))
+ vars)
+ body)
+
+(defun org-babel-sqlite-table-or-scalar (result)
+ "If RESULT looks like a trivial table, then unwrap it."
+ (if (and (equal 1 (length result))
+ (equal 1 (length (car result))))
+ (org-babel-read (caar result))
+ (mapcar (lambda (row)
+ (if (equal 'hline row)
+ 'hline
+ (mapcar #'org-babel-read row))) result)))
+
+(defun org-babel-sqlite-offset-colnames (table headers-p)
+ "If HEADERS-P is non-nil then offset the first row as column names."
+ (if headers-p
+ (cons (car table) (cons 'hline (cdr table)))
+ table))
+
+(defun org-babel-prep-session:sqlite (session params)
+ "Raise an error because support for sqlite sessions isn't implemented.
+Prepare SESSION according to the header arguments specified in PARAMS."
+ (error "sqlite sessions not yet implemented"))
+
+(provide 'ob-sqlite)
+
+;; arch-tag: 5c03d7f2-0f72-48b8-bbd1-35aafea248ac
+
+;;; ob-sqlite.el ends here
diff --git a/lisp/org/ob-table.el b/lisp/org/ob-table.el
new file mode 100644
index 00000000000..cdc7a6250fe
--- /dev/null
+++ b/lisp/org/ob-table.el
@@ -0,0 +1,125 @@
+;;; ob-table.el --- support for calling org-babel functions from tables
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Should allow calling functions from org-mode tables using the
+;; function `sbe' as so...
+
+;; #+begin_src emacs-lisp :results silent
+;; (defun fibbd (n) (if (< n 2) 1 (+ (fibbd (- n 1)) (fibbd (- n 2)))))
+;; #+end_src
+
+;; #+srcname: fibbd
+;; #+begin_src emacs-lisp :var n=2 :results silent
+;; (fibbd n)
+;; #+end_src
+
+;; | original | fibbd |
+;; |----------+--------|
+;; | 0 | |
+;; | 1 | |
+;; | 2 | |
+;; | 3 | |
+;; | 4 | |
+;; | 5 | |
+;; | 6 | |
+;; | 7 | |
+;; | 8 | |
+;; | 9 | |
+;; #+TBLFM: $2='(sbe 'fibbd (n $1))
+
+;;; Code:
+(require 'ob)
+
+(defun org-babel-table-truncate-at-newline (string)
+ "Replace newline character with ellipses.
+If STRING ends in a newline character, then remove the newline
+character and replace it with ellipses."
+ (if (and (stringp string) (string-match "[\n\r]" string))
+ (concat (substring string 0 (match-beginning 0)) "...")
+ string))
+
+(defmacro sbe (source-block &rest variables)
+ "Return the results of calling SOURCE-BLOCK with VARIABLES.
+Each element of VARIABLES should be a two
+element list, whose first element is the name of the variable and
+second element is a string of its value. The following call to
+`sbe' would be equivalent to the following source code block.
+
+ (sbe 'source-block (n $2) (m 3))
+
+#+begin_src emacs-lisp :var results=source-block(n=val_at_col_2, m=3) :results silent
+results
+#+end_src
+
+NOTE: by default string variable names are interpreted as
+references to source-code blocks, to force interpretation of a
+cell's value as a string, prefix the identifier with two \"$\"s
+rather than a single \"$\" (i.e. \"$$2\" instead of \"$2\" in the
+example above."
+ (let* (quote
+ (variables
+ (mapcar
+ (lambda (var)
+ ;; ensure that all cells prefixed with $'s are strings
+ (cons (car var)
+ (delq nil (mapcar
+ (lambda (el)
+ (if (eq '$ el)
+ (setq quote t)
+ (prog1 (if quote
+ (format "\"%s\"" el)
+ (org-babel-clean-text-properties el))
+ (setq quote nil))))
+ (cdr var)))))
+ variables)))
+ (unless (stringp source-block)
+ (setq source-block (symbol-name source-block)))
+ (org-babel-table-truncate-at-newline ;; org-table cells can't be multi-line
+ (if (and source-block (> (length source-block) 0))
+ (let ((params
+ (eval `(org-babel-parse-header-arguments
+ (concat ":var results="
+ ,source-block
+ "("
+ (mapconcat
+ (lambda (var-spec)
+ (if (> (length (cdr var-spec)) 1)
+ (format "%S='%S"
+ (car var-spec)
+ (mapcar #'read (cdr var-spec)))
+ (format "%S=%s"
+ (car var-spec) (cadr var-spec))))
+ ',variables ", ")
+ ")")))))
+ (org-babel-execute-src-block
+ nil (list "emacs-lisp" "results" params) '((:results . "silent"))))
+ ""))))
+
+(provide 'ob-table)
+
+;; arch-tag: 4234cc7c-4fc8-4e92-abb0-2892de1a493b
+
+;;; ob-table.el ends here
diff --git a/lisp/org/ob-tangle.el b/lisp/org/ob-tangle.el
new file mode 100644
index 00000000000..e197ff37d36
--- /dev/null
+++ b/lisp/org/ob-tangle.el
@@ -0,0 +1,453 @@
+;;; ob-tangle.el --- extract source code from org-mode files
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Extract the code from source blocks out into raw source-code files.
+
+;;; Code:
+(require 'ob)
+(require 'org-src)
+(eval-when-compile
+ (require 'cl))
+
+(declare-function org-link-escape "org" (text &optional table))
+(declare-function org-heading-components "org" ())
+(declare-function org-back-to-heading "org" (invisible-ok))
+(declare-function org-fill-template "org" (template alist))
+(declare-function org-babel-update-block-body "org" (new-body))
+
+;;;###autoload
+(defcustom org-babel-tangle-lang-exts
+ '(("emacs-lisp" . "el"))
+ "Alist mapping languages to their file extensions.
+The key is the language name, the value is the string that should
+be inserted as the extension commonly used to identify files
+written in this language. If no entry is found in this list,
+then the name of the language is used."
+ :group 'org-babel-tangle
+ :type '(repeat
+ (cons
+ (string "Language name")
+ (string "File Extension"))))
+
+(defcustom org-babel-post-tangle-hook nil
+ "Hook run in code files tangled by `org-babel-tangle'."
+ :group 'org-babel
+ :type 'hook)
+
+(defcustom org-babel-pre-tangle-hook '(save-buffer)
+ "Hook run at the beginning of `org-babel-tangle'."
+ :group 'org-babel
+ :type 'hook)
+
+(defcustom org-babel-tangle-pad-newline t
+ "Switch indicating whether to pad tangled code with newlines."
+ :group 'org-babel
+ :type 'boolean)
+
+(defcustom org-babel-tangle-comment-format-beg "[[%link][%source-name]]"
+ "Format of inserted comments in tangled code files.
+The following format strings can be used to insert special
+information into the output using `org-fill-template'.
+%start-line --- the line number at the start of the code block
+%file --------- the file from which the code block was tangled
+%link --------- Org-mode style link to the code block
+%source-name -- name of the code block
+
+Whether or not comments are inserted during tangling is
+controlled by the :comments header argument."
+ :group 'org-babel
+ :type 'string)
+
+(defcustom org-babel-tangle-comment-format-end "%source-name ends here"
+ "Format of inserted comments in tangled code files.
+The following format strings can be used to insert special
+information into the output using `org-fill-template'.
+%start-line --- the line number at the start of the code block
+%file --------- the file from which the code block was tangled
+%link --------- Org-mode style link to the code block
+%source-name -- name of the code block
+
+Whether or not comments are inserted during tangling is
+controlled by the :comments header argument."
+ :group 'org-babel
+ :type 'string)
+
+(defun org-babel-find-file-noselect-refresh (file)
+ "Find file ensuring that the latest changes on disk are
+represented in the file."
+ (find-file-noselect file)
+ (with-current-buffer (get-file-buffer file)
+ (revert-buffer t t t)))
+
+(defmacro org-babel-with-temp-filebuffer (file &rest body)
+ "Open FILE into a temporary buffer execute BODY there like
+`progn', then kill the FILE buffer returning the result of
+evaluating BODY."
+ (declare (indent 1))
+ (let ((temp-result (make-symbol "temp-result"))
+ (temp-file (make-symbol "temp-file"))
+ (visited-p (make-symbol "visited-p")))
+ `(let (,temp-result ,temp-file
+ (,visited-p (get-file-buffer ,file)))
+ (org-babel-find-file-noselect-refresh ,file)
+ (setf ,temp-file (get-file-buffer ,file))
+ (with-current-buffer ,temp-file
+ (setf ,temp-result (progn ,@body)))
+ (unless ,visited-p (kill-buffer ,temp-file))
+ ,temp-result)))
+
+;;;###autoload
+(defun org-babel-load-file (file)
+ "Load Emacs Lisp source code blocks in the Org-mode FILE.
+This function exports the source code using
+`org-babel-tangle' and then loads the resulting file using
+`load-file'."
+ (flet ((age (file)
+ (float-time
+ (time-subtract (current-time)
+ (nth 5 (or (file-attributes (file-truename file))
+ (file-attributes file)))))))
+ (let* ((base-name (file-name-sans-extension file))
+ (exported-file (concat base-name ".el")))
+ ;; tangle if the org-mode file is newer than the elisp file
+ (unless (and (file-exists-p exported-file)
+ (> (age file) (age exported-file)))
+ (org-babel-tangle-file file exported-file "emacs-lisp"))
+ (load-file exported-file)
+ (message "loaded %s" exported-file))))
+
+;;;###autoload
+(defun org-babel-tangle-file (file &optional target-file lang)
+ "Extract the bodies of source code blocks in FILE.
+Source code blocks are extracted with `org-babel-tangle'.
+Optional argument TARGET-FILE can be used to specify a default
+export file for all source blocks. Optional argument LANG can be
+used to limit the exported source code blocks by language."
+ (interactive "fFile to tangle: \nP")
+ (let ((visited-p (get-file-buffer (expand-file-name file)))
+ to-be-removed)
+ (save-window-excursion
+ (find-file file)
+ (setq to-be-removed (current-buffer))
+ (org-babel-tangle target-file lang))
+ (unless visited-p
+ (kill-buffer to-be-removed))))
+
+(defun org-babel-tangle-publish (_ filename pub-dir)
+ "Tangle FILENAME and place the results in PUB-DIR."
+ (mapc (lambda (el) (copy-file el pub-dir t)) (org-babel-tangle-file filename)))
+
+;;;###autoload
+(defun org-babel-tangle (&optional target-file lang)
+ "Write code blocks to source-specific files.
+Extract the bodies of all source code blocks from the current
+file into their own source-specific files. Optional argument
+TARGET-FILE can be used to specify a default export file for all
+source blocks. Optional argument LANG can be used to limit the
+exported source code blocks by language."
+ (interactive)
+ (run-hooks 'org-babel-pre-tangle-hook)
+ (save-excursion
+ (let ((block-counter 0)
+ (org-babel-default-header-args
+ (if target-file
+ (org-babel-merge-params org-babel-default-header-args
+ (list (cons :tangle target-file)))
+ org-babel-default-header-args))
+ path-collector)
+ (mapc ;; map over all languages
+ (lambda (by-lang)
+ (let* ((lang (car by-lang))
+ (specs (cdr by-lang))
+ (ext (or (cdr (assoc lang org-babel-tangle-lang-exts)) lang))
+ (lang-f (intern
+ (concat
+ (or (and (cdr (assoc lang org-src-lang-modes))
+ (symbol-name
+ (cdr (assoc lang org-src-lang-modes))))
+ lang)
+ "-mode")))
+ she-banged)
+ (mapc
+ (lambda (spec)
+ (flet ((get-spec (name)
+ (cdr (assoc name (nth 4 spec)))))
+ (let* ((tangle (get-spec :tangle))
+ (she-bang ((lambda (sheb) (when (> (length sheb) 0) sheb))
+ (get-spec :shebang)))
+ (base-name (cond
+ ((string= "yes" tangle)
+ (file-name-sans-extension
+ (buffer-file-name)))
+ ((string= "no" tangle) nil)
+ ((> (length tangle) 0) tangle)))
+ (file-name (when base-name
+ ;; decide if we want to add ext to base-name
+ (if (and ext (string= "yes" tangle))
+ (concat base-name "." ext) base-name))))
+ (when file-name
+ ;; delete any old versions of file
+ (when (and (file-exists-p file-name)
+ (not (member file-name path-collector)))
+ (delete-file file-name))
+ ;; drop source-block to file
+ (with-temp-buffer
+ (when (fboundp lang-f) (funcall lang-f))
+ (when (and she-bang (not (member file-name she-banged)))
+ (insert (concat she-bang "\n"))
+ (setq she-banged (cons file-name she-banged)))
+ (org-babel-spec-to-string spec)
+ ;; We avoid append-to-file as it does not work with tramp.
+ (let ((content (buffer-string)))
+ (with-temp-buffer
+ (if (file-exists-p file-name)
+ (insert-file-contents file-name))
+ (goto-char (point-max))
+ (insert content)
+ (write-region nil nil file-name))))
+ ;; if files contain she-bangs, then make the executable
+ (when she-bang (set-file-modes file-name #o755))
+ ;; update counter
+ (setq block-counter (+ 1 block-counter))
+ (add-to-list 'path-collector file-name)))))
+ specs)))
+ (org-babel-tangle-collect-blocks lang))
+ (message "tangled %d code block%s from %s" block-counter
+ (if (= block-counter 1) "" "s")
+ (file-name-nondirectory (buffer-file-name (current-buffer))))
+ ;; run `org-babel-post-tangle-hook' in all tangled files
+ (when org-babel-post-tangle-hook
+ (mapc
+ (lambda (file)
+ (org-babel-with-temp-filebuffer file
+ (run-hooks 'org-babel-post-tangle-hook)))
+ path-collector))
+ path-collector)))
+
+(defun org-babel-tangle-clean ()
+ "Remove comments inserted by `org-babel-tangle'.
+Call this function inside of a source-code file generated by
+`org-babel-tangle' to remove all comments inserted automatically
+by `org-babel-tangle'. Warning, this comment removes any lines
+containing constructs which resemble org-mode file links or noweb
+references."
+ (interactive)
+ (goto-char (point-min))
+ (while (or (re-search-forward "\\[\\[file:.*\\]\\[.*\\]\\]" nil t)
+ (re-search-forward "<<[^[:space:]]*>>" nil t))
+ (delete-region (save-excursion (beginning-of-line 1) (point))
+ (save-excursion (end-of-line 1) (forward-char 1) (point)))))
+
+(defvar org-stored-links)
+(defun org-babel-tangle-collect-blocks (&optional language)
+ "Collect source blocks in the current Org-mode file.
+Return an association list of source-code block specifications of
+the form used by `org-babel-spec-to-string' grouped by language.
+Optional argument LANG can be used to limit the collected source
+code blocks by language."
+ (let ((block-counter 1) (current-heading "") blocks)
+ (org-babel-map-src-blocks (buffer-file-name)
+ ((lambda (new-heading)
+ (if (not (string= new-heading current-heading))
+ (progn
+ (setq block-counter 1)
+ (setq current-heading new-heading))
+ (setq block-counter (+ 1 block-counter))))
+ (replace-regexp-in-string "[ \t]" "-"
+ (condition-case nil
+ (nth 4 (org-heading-components))
+ (error (buffer-file-name)))))
+ (let* ((start-line (save-restriction (widen)
+ (+ 1 (line-number-at-pos (point)))))
+ (file (buffer-file-name))
+ (info (org-babel-get-src-block-info 'light))
+ (src-lang (nth 0 info)))
+ (unless (string= (cdr (assoc :tangle (nth 2 info))) "no")
+ (unless (and language (not (string= language src-lang)))
+ (let* ((info (org-babel-get-src-block-info))
+ (params (nth 2 info))
+ (link (progn (call-interactively 'org-store-link)
+ (org-babel-clean-text-properties
+ (car (pop org-stored-links)))))
+ (source-name
+ (intern (or (nth 4 info)
+ (format "%s:%d"
+ current-heading block-counter))))
+ (expand-cmd
+ (intern (concat "org-babel-expand-body:" src-lang)))
+ (assignments-cmd
+ (intern (concat "org-babel-variable-assignments:" src-lang)))
+ (body
+ ((lambda (body)
+ (if (assoc :no-expand params)
+ body
+ (if (fboundp expand-cmd)
+ (funcall expand-cmd body params)
+ (org-babel-expand-body:generic
+ body params
+ (and (fboundp assignments-cmd)
+ (funcall assignments-cmd params))))))
+ (if (and (cdr (assoc :noweb params))
+ (let ((nowebs (split-string
+ (cdr (assoc :noweb params)))))
+ (or (member "yes" nowebs)
+ (member "tangle" nowebs))))
+ (org-babel-expand-noweb-references info)
+ (nth 1 info))))
+ (comment
+ (when (or (string= "both" (cdr (assoc :comments params)))
+ (string= "org" (cdr (assoc :comments params))))
+ ;; from the previous heading or code-block end
+ (buffer-substring
+ (max (condition-case nil
+ (save-excursion
+ (org-back-to-heading t) (point))
+ (error 0))
+ (save-excursion
+ (re-search-backward
+ org-babel-src-block-regexp nil t)
+ (match-end 0)))
+ (point))))
+ by-lang)
+ ;; add the spec for this block to blocks under it's language
+ (setq by-lang (cdr (assoc src-lang blocks)))
+ (setq blocks (delq (assoc src-lang blocks) blocks))
+ (setq blocks (cons
+ (cons src-lang
+ (cons (list start-line file link
+ source-name params body comment)
+ by-lang)) blocks)))))))
+ ;; ensure blocks in the correct order
+ (setq blocks
+ (mapcar
+ (lambda (by-lang) (cons (car by-lang) (reverse (cdr by-lang))))
+ blocks))
+ blocks))
+
+(defun org-babel-spec-to-string (spec)
+ "Insert SPEC into the current file.
+Insert the source-code specified by SPEC into the current
+source code file. This function uses `comment-region' which
+assumes that the appropriate major-mode is set. SPEC has the
+form
+
+ (start-line file link source-name params body comment)"
+ (let* ((start-line (nth 0 spec))
+ (file (nth 1 spec))
+ (link (org-link-escape (nth 2 spec)))
+ (source-name (nth 3 spec))
+ (body (nth 5 spec))
+ (comment (nth 6 spec))
+ (comments (cdr (assoc :comments (nth 4 spec))))
+ (link-p (or (string= comments "both") (string= comments "link")
+ (string= comments "yes")))
+ (link-data (mapcar (lambda (el)
+ (cons (symbol-name el)
+ ((lambda (le)
+ (if (stringp le) le (format "%S" le)))
+ (eval el))))
+ '(start-line file link source-name))))
+ (flet ((insert-comment (text)
+ (let ((text (org-babel-trim text)))
+ (when (and comments (not (string= comments "no"))
+ (> (length text) 0))
+ (when org-babel-tangle-pad-newline (insert "\n"))
+ (comment-region (point) (progn (insert text) (point)))
+ (end-of-line nil) (insert "\n")))))
+ (when comment (insert-comment comment))
+ (when link-p
+ (insert-comment
+ (org-fill-template org-babel-tangle-comment-format-beg link-data)))
+ (when org-babel-tangle-pad-newline (insert "\n"))
+ (insert
+ (format
+ "%s\n"
+ (replace-regexp-in-string
+ "^," ""
+ (org-babel-trim body (if org-src-preserve-indentation "[\f\n\r\v]")))))
+ (when link-p
+ (insert-comment
+ (org-fill-template org-babel-tangle-comment-format-end link-data))))))
+
+;; detangling functions
+(defvar org-bracket-link-analytic-regexp)
+(defun org-babel-detangle (&optional source-code-file)
+ "Propagate changes in source file back original to Org-mode file.
+This requires that code blocks were tangled with link comments
+which enable the original code blocks to be found."
+ (interactive)
+ (save-excursion
+ (when source-code-file (find-file source-code-file))
+ (goto-char (point-min))
+ (let ((counter 0) new-body end)
+ (while (re-search-forward org-bracket-link-analytic-regexp nil t)
+ (when (re-search-forward
+ (concat " " (regexp-quote (match-string 5)) " ends here"))
+ (setq end (match-end 0))
+ (forward-line -1)
+ (save-excursion
+ (when (setq new-body (org-babel-tangle-jump-to-org))
+ (org-babel-update-block-body new-body)))
+ (setq counter (+ 1 counter)))
+ (goto-char end))
+ (prog1 counter (message "detangled %d code blocks" counter)))))
+
+(defun org-babel-tangle-jump-to-org ()
+ "Jump from a tangled code file to the related Org-mode file."
+ (interactive)
+ (let ((mid (point))
+ target-buffer target-char
+ start end link path block-name body)
+ (save-window-excursion
+ (save-excursion
+ (unless (and (re-search-backward org-bracket-link-analytic-regexp nil t)
+ (setq start (point-at-eol))
+ (setq link (match-string 0))
+ (setq path (match-string 3))
+ (setq block-name (match-string 5))
+ (re-search-forward
+ (concat " " (regexp-quote block-name) " ends here") nil t)
+ (setq end (point-at-bol))
+ (< start mid) (< mid end))
+ (error "not in tangled code"))
+ (setq body (org-babel-trim (buffer-substring start end))))
+ (when (string-match "::" path)
+ (setq path (substring path 0 (match-beginning 0))))
+ (find-file path) (setq target-buffer (current-buffer))
+ (goto-char start) (org-open-link-from-string link)
+ (if (string-match "[^ \t\n\r]:\\([[:digit:]]+\\)" block-name)
+ (org-babel-next-src-block
+ (string-to-number (match-string 1 block-name)))
+ (org-babel-goto-named-src-block block-name))
+ (setq target-char (point)))
+ (pop-to-buffer target-buffer)
+ (prog1 body (goto-char target-char))))
+
+(provide 'ob-tangle)
+
+;; arch-tag: 413ced93-48f5-4216-86e4-3fc5df8c8f24
+
+;;; ob-tangle.el ends here
diff --git a/lisp/org/ob.el b/lisp/org/ob.el
new file mode 100644
index 00000000000..fe068de549f
--- /dev/null
+++ b/lisp/org/ob.el
@@ -0,0 +1,1886 @@
+;;; ob.el --- working with code blocks in org-mode
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Eric Schulte
+;; Dan Davison
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; See the online documentation for more information
+;;
+;; http://orgmode.org/worg/org-contrib/babel/
+
+;;; Code:
+(eval-when-compile
+ (require 'cl))
+(require 'org-macs)
+
+(defvar org-babel-call-process-region-original)
+(declare-function show-all "outline" ())
+(declare-function tramp-compat-make-temp-file "tramp-compat"
+ (filename &optional dir-flag))
+(declare-function tramp-dissect-file-name "tramp" (name &optional nodefault))
+(declare-function tramp-file-name-user "tramp" (vec))
+(declare-function tramp-file-name-host "tramp" (vec))
+(declare-function with-parsed-tramp-file-name "tramp" (filename var &rest body))
+(declare-function org-icompleting-read "org" (&rest args))
+(declare-function org-edit-src-code "org-src"
+ (&optional context code edit-buffer-name quietp))
+(declare-function org-edit-src-exit "org-src" (&optional context))
+(declare-function org-open-at-point "org" (&optional in-emacs reference-buffer))
+(declare-function org-save-outline-visibility "org" (use-markers &rest body))
+(declare-function org-outline-overlay-data "org" (&optional use-markers))
+(declare-function org-set-outline-overlay-data "org" (data))
+(declare-function org-narrow-to-subtree "org" ())
+(declare-function org-entry-get "org"
+ (pom property &optional inherit literal-nil))
+(declare-function org-make-options-regexp "org" (kwds &optional extra))
+(declare-function org-do-remove-indentation "org" (&optional n))
+(declare-function org-show-context "org" (&optional key))
+(declare-function org-at-table-p "org" (&optional table-type))
+(declare-function org-cycle "org" (&optional arg))
+(declare-function org-uniquify "org" (list))
+(declare-function org-current-level "org" ())
+(declare-function org-table-import "org-table" (file arg))
+(declare-function org-add-hook "org-compat"
+ (hook function &optional append local))
+(declare-function org-table-align "org-table" ())
+(declare-function org-table-end "org-table" (&optional table-type))
+(declare-function orgtbl-to-generic "org-table" (table params))
+(declare-function orgtbl-to-orgtbl "org-table" (table params))
+(declare-function org-babel-lob-get-info "ob-lob" nil)
+(declare-function org-babel-ref-split-args "ob-ref" (arg-string))
+(declare-function org-babel-ref-parse "ob-ref" (assignment))
+(declare-function org-babel-ref-resolve "ob-ref" (ref))
+(declare-function org-babel-lob-execute-maybe "ob-lob" ())
+(declare-function org-number-sequence "org-compat" (from &optional to inc))
+
+(defgroup org-babel nil
+ "Code block evaluation and management in `org-mode' documents."
+ :tag "Babel"
+ :group 'org)
+
+(defcustom org-confirm-babel-evaluate t
+ "Confirm before evaluation.
+Require confirmation before interactively evaluating code
+blocks in Org-mode buffers. The default value of this variable
+is t, meaning confirmation is required for any code block
+evaluation. This variable can be set to nil to inhibit any
+future confirmation requests. This variable can also be set to a
+function which takes two arguments the language of the code block
+and the body of the code block. Such a function should then
+return a non-nil value if the user should be prompted for
+execution or nil if no prompt is required.
+
+Warning: Disabling confirmation may result in accidental
+evaluation of potentially harmful code. It may be advisable
+remove code block execution from C-c C-c as further protection
+against accidental code block evaluation. The
+`org-babel-no-eval-on-ctrl-c-ctrl-c' variable can be used to
+remove code block execution from the C-c C-c keybinding."
+ :group 'org-babel
+ :type '(choice boolean function))
+;; don't allow this variable to be changed through file settings
+(put 'org-confirm-babel-evaluate 'safe-local-variable (lambda (x) (eq x t)))
+
+(defcustom org-babel-no-eval-on-ctrl-c-ctrl-c nil
+ "Remove code block evaluation from the C-c C-c key binding."
+ :group 'org-babel
+ :type 'boolean)
+
+(defvar org-babel-src-name-regexp
+ "^[ \t]*#\\+\\(srcname\\|source\\|function\\):[ \t]*"
+ "Regular expression used to match a source name line.")
+
+(defvar org-babel-multi-line-header-regexp
+ "^[ \t]*#\\+headers?:[ \t]*\\([^\n]*\\)$"
+ "Regular expression used to match multi-line header arguments.")
+
+(defvar org-babel-src-name-w-name-regexp
+ (concat org-babel-src-name-regexp
+ "\\("
+ org-babel-multi-line-header-regexp
+ "\\)*"
+ "\\([^ ()\f\t\n\r\v]+\\)\\(\(\\(.*\\)\)\\|\\)")
+ "Regular expression matching source name lines with a name.")
+
+(defvar org-babel-src-block-regexp
+ (concat
+ ;; (1) indentation (2) lang
+ "^\\([ \t]*\\)#\\+begin_src[ \t]+\\([^ \f\t\n\r\v]+\\)[ \t]*"
+ ;; (3) switches
+ "\\([^\":\n]*\"[^\"\n*]*\"[^\":\n]*\\|[^\":\n]*\\)"
+ ;; (4) header arguments
+ "\\([^\n]*\\)\n"
+ ;; (5) body
+ "\\([^\000]+?\n\\)[ \t]*#\\+end_src")
+ "Regexp used to identify code blocks.")
+
+(defvar org-babel-inline-src-block-regexp
+ (concat
+ ;; (1) replacement target (2) lang
+ "[ \f\t\n\r\v]\\(src_\\([^ \f\t\n\r\v]+\\)"
+ ;; (3,4) (unused, headers)
+ "\\(\\|\\[\\(.*?\\)\\]\\)"
+ ;; (5) body
+ "{\\([^\f\n\r\v]+?\\)}\\)")
+ "Regexp used to identify inline src-blocks.")
+
+(defun org-babel-get-header (params key &optional others)
+ "Select only header argument of type KEY from a list.
+Optional argument OTHERS indicates that only the header that do
+not match KEY should be returned."
+ (delq nil
+ (mapcar
+ (lambda (p) (when (funcall (if others #'not #'identity) (eq (car p) key)) p))
+ params)))
+
+(defun org-babel-get-src-block-info (&optional light)
+ "Get information on the current source block.
+
+Optional argument LIGHT does not resolve remote variable
+references; a process which could likely result in the execution
+of other code blocks.
+
+Returns a list
+ (language body header-arguments-alist switches name indent)."
+ (let ((case-fold-search t) head info name indent)
+ ;; full code block
+ (if (setq head (org-babel-where-is-src-block-head))
+ (save-excursion
+ (goto-char head)
+ (setq info (org-babel-parse-src-block-match))
+ (setq indent (car (last info)))
+ (setq info (butlast info))
+ (while (and (forward-line -1)
+ (looking-at org-babel-multi-line-header-regexp))
+ (setf (nth 2 info)
+ (org-babel-merge-params
+ (org-babel-parse-header-arguments (match-string 1))
+ (nth 2 info))))
+ (when (looking-at org-babel-src-name-w-name-regexp)
+ (setq name (org-babel-clean-text-properties (match-string 4)))
+ (when (match-string 6)
+ (setf (nth 2 info) ;; merge functional-syntax vars and header-args
+ (org-babel-merge-params
+ (mapcar (lambda (ref) (cons :var ref))
+ (org-babel-ref-split-args (match-string 6)))
+ (nth 2 info))))))
+ ;; inline source block
+ (when (save-excursion (re-search-backward "[ \f\t\n\r\v]" nil t)
+ (looking-at org-babel-inline-src-block-regexp))
+ (setq info (org-babel-parse-inline-src-block-match))))
+ ;; resolve variable references and add summary parameters
+ (when (and info (not light))
+ (setf (nth 2 info) (org-babel-process-params (nth 2 info))))
+ (when info (append info (list name indent)))))
+
+(defun org-babel-confirm-evaluate (info)
+ "Confirm evaluation of the code block INFO.
+This behavior can be suppressed by setting the value of
+`org-confirm-babel-evaluate' to nil, in which case all future
+interactive code block evaluations will proceed without any
+confirmation from the user.
+
+Note disabling confirmation may result in accidental evaluation
+of potentially harmful code."
+ (let* ((eval (or (cdr (assoc :eval (nth 2 info)))
+ (when (assoc :noeval (nth 2 info)) "no")))
+ (query (or (equal eval "query")
+ (if (functionp org-confirm-babel-evaluate)
+ (funcall org-confirm-babel-evaluate
+ (nth 0 info) (nth 1 info))
+ org-confirm-babel-evaluate))))
+ (if (or (equal eval "never") (equal eval "no")
+ (and query
+ (not (yes-or-no-p
+ (format "Evaluate this%scode on your system? "
+ (if info (format " %s " (nth 0 info)) " "))))))
+ (prog1 nil (message "evaluation aborted"))
+ t)))
+
+;;;###autoload
+(defun org-babel-execute-safely-maybe ()
+ (unless org-babel-no-eval-on-ctrl-c-ctrl-c
+ (org-babel-execute-maybe)))
+
+(add-hook 'org-ctrl-c-ctrl-c-hook 'org-babel-execute-safely-maybe)
+
+;;;###autoload
+(defun org-babel-execute-maybe ()
+ (interactive)
+ (or (org-babel-execute-src-block-maybe)
+ (org-babel-lob-execute-maybe)))
+
+(defun org-babel-execute-src-block-maybe ()
+ "Conditionally execute a source block.
+Detect if this is context for a Babel src-block and if so
+then run `org-babel-execute-src-block'."
+ (interactive)
+ (let ((info (org-babel-get-src-block-info)))
+ (if info
+ (progn (org-babel-execute-src-block current-prefix-arg info) t) nil)))
+
+;;;###autoload
+(defun org-babel-expand-src-block-maybe ()
+ "Conditionally expand a source block.
+Detect if this is context for a org-babel src-block and if so
+then run `org-babel-expand-src-block'."
+ (interactive)
+ (let ((info (org-babel-get-src-block-info)))
+ (if info
+ (progn (org-babel-expand-src-block current-prefix-arg info) t)
+ nil)))
+
+;;;###autoload
+(defun org-babel-load-in-session-maybe ()
+ "Conditionally load a source block in a session.
+Detect if this is context for a org-babel src-block and if so
+then run `org-babel-load-in-session'."
+ (interactive)
+ (let ((info (org-babel-get-src-block-info)))
+ (if info
+ (progn (org-babel-load-in-session current-prefix-arg info) t)
+ nil)))
+
+(add-hook 'org-metaup-hook 'org-babel-load-in-session-maybe)
+
+;;;###autoload
+(defun org-babel-pop-to-session-maybe ()
+ "Conditionally pop to a session.
+Detect if this is context for a org-babel src-block and if so
+then run `org-babel-pop-to-session'."
+ (interactive)
+ (let ((info (org-babel-get-src-block-info)))
+ (if info (progn (org-babel-pop-to-session current-prefix-arg info) t) nil)))
+
+(add-hook 'org-metadown-hook 'org-babel-pop-to-session-maybe)
+
+(defconst org-babel-header-arg-names
+ '(cache cmdline colnames dir exports file noweb results
+ session tangle var eval noeval comments)
+ "Common header arguments used by org-babel.
+Note that individual languages may define their own language
+specific header arguments as well.")
+
+(defvar org-babel-default-header-args
+ '((:session . "none") (:results . "replace") (:exports . "code")
+ (:cache . "no") (:noweb . "no") (:hlines . "no") (:tangle . "no"))
+ "Default arguments to use when evaluating a source block.")
+
+(defvar org-babel-default-inline-header-args
+ '((:session . "none") (:results . "silent") (:exports . "results"))
+ "Default arguments to use when evaluating an inline source block.")
+
+(defvar org-babel-current-buffer-properties nil
+ "Local cache for buffer properties.")
+(make-variable-buffer-local 'org-babel-current-buffer-properties)
+
+(defvar org-babel-result-regexp
+ "^[ \t]*#\\+res\\(ults\\|name\\)\\(\\[\\([[:alnum:]]+\\)\\]\\)?\\:[ \t]*"
+ "Regular expression used to match result lines.
+If the results are associated with a hash key then the hash will
+be saved in the second match data.")
+
+(defvar org-babel-result-w-name-regexp
+ (concat org-babel-result-regexp
+ "\\([^ ()\f\t\n\r\v]+\\)\\(\(\\(.*\\)\)\\|\\)"))
+
+(defvar org-babel-min-lines-for-block-output 10
+ "The minimum number of lines for block output.
+If number of lines of output is equal to or exceeds this
+value, the output is placed in a #+begin_example...#+end_example
+block. Otherwise the output is marked as literal by inserting
+colons at the starts of the lines. This variable only takes
+effect if the :results output option is in effect.")
+
+(defvar org-babel-noweb-error-langs nil
+ "Languages for which Babel will raise literate programming errors.
+List of languages for which errors should be raised when the
+source code block satisfying a noweb reference in this language
+can not be resolved.")
+
+(defvar org-babel-hash-show 4
+ "Number of initial characters to show of a hidden results hash.")
+
+(defvar org-babel-after-execute-hook nil
+ "Hook for functions to be called after `org-babel-execute-src-block'")
+(defun org-babel-named-src-block-regexp-for-name (name)
+ "This generates a regexp used to match a src block named NAME."
+ (concat org-babel-src-name-regexp (regexp-quote name) "[ \t\n]*"
+ (substring org-babel-src-block-regexp 1)))
+
+;;; functions
+(defvar call-process-region)
+;;;###autoload
+
+(defun org-babel-execute-src-block (&optional arg info params)
+ "Execute the current source code block.
+Insert the results of execution into the buffer. Source code
+execution and the collection and formatting of results can be
+controlled through a variety of header arguments.
+
+With prefix argument ARG, force re-execution even if a an
+existing result cached in the buffer would otherwise have been
+returned.
+
+Optionally supply a value for INFO in the form returned by
+`org-babel-get-src-block-info'.
+
+Optionally supply a value for PARAMS which will be merged with
+the header arguments specified at the front of the source code
+block."
+ (interactive)
+ (let ((info (or info (org-babel-get-src-block-info))))
+ (when (org-babel-confirm-evaluate info)
+ (let* ((lang (nth 0 info))
+ (params (if params
+ (org-babel-process-params
+ (org-babel-merge-params (nth 2 info) params))
+ (nth 2 info)))
+ (cache? (and (not arg) (cdr (assoc :cache params))
+ (string= "yes" (cdr (assoc :cache params)))))
+ (result-params (cdr (assoc :result-params params)))
+ (new-hash (when cache? (org-babel-sha1-hash info)))
+ (old-hash (when cache? (org-babel-result-hash info)))
+ (body (setf (nth 1 info)
+ (if (and (cdr (assoc :noweb params))
+ (string= "yes" (cdr (assoc :noweb params))))
+ (org-babel-expand-noweb-references info)
+ (nth 1 info))))
+ (cmd (intern (concat "org-babel-execute:" lang)))
+ (dir (cdr (assoc :dir params)))
+ (default-directory
+ (or (and dir (file-name-as-directory dir)) default-directory))
+ (org-babel-call-process-region-original
+ (if (boundp 'org-babel-call-process-region-original)
+ org-babel-call-process-region-original
+ (symbol-function 'call-process-region)))
+ (indent (car (last info)))
+ result)
+ (unwind-protect
+ (flet ((call-process-region (&rest args)
+ (apply 'org-babel-tramp-handle-call-process-region args)))
+ (unless (fboundp cmd)
+ (error "No org-babel-execute function for %s!" lang))
+ (if (and (not arg) new-hash (equal new-hash old-hash))
+ (save-excursion ;; return cached result
+ (goto-char (org-babel-where-is-src-block-result nil info))
+ (end-of-line 1) (forward-char 1)
+ (setq result (org-babel-read-result))
+ (message (replace-regexp-in-string
+ "%" "%%" (format "%S" result))) result)
+ (message "executing %s code block%s..."
+ (capitalize lang)
+ (if (nth 4 info) (format " (%s)" (nth 4 info)) ""))
+ (setq result
+ ((lambda (result)
+ (cond
+ ((member "file" result-params)
+ (cdr (assoc :file params)))
+ ((and (eq (cdr (assoc :result-type params)) 'value)
+ (or (member "vector" result-params)
+ (member "table" result-params))
+ (not (listp result)))
+ (list (list result)))
+ (t result)))
+ (funcall cmd body params)))
+ (org-babel-insert-result
+ result result-params info new-hash indent lang)
+ (run-hooks 'org-babel-after-execute-hook)
+ result))
+ (setq call-process-region 'org-babel-call-process-region-original))))))
+
+(defun org-babel-expand-body:generic (body params &optional var-lines)
+ "Expand BODY with PARAMS.
+Expand a block of code with org-babel according to it's header
+arguments. This generic implementation of body expansion is
+called for languages which have not defined their own specific
+org-babel-expand-body:lang function."
+ (mapconcat #'identity (append var-lines (list body)) "\n"))
+
+;;;###autoload
+(defun org-babel-expand-src-block (&optional arg info params)
+ "Expand the current source code block.
+Expand according to the source code block's header
+arguments and pop open the results in a preview buffer."
+ (interactive)
+ (let* ((info (or info (org-babel-get-src-block-info)))
+ (lang (nth 0 info))
+ (params (setf (nth 2 info)
+ (sort (org-babel-merge-params (nth 2 info) params)
+ (lambda (el1 el2) (string< (symbol-name (car el1))
+ (symbol-name (car el2)))))))
+ (body (setf (nth 1 info)
+ (if (and (cdr (assoc :noweb params))
+ (string= "yes" (cdr (assoc :noweb params))))
+ (org-babel-expand-noweb-references info) (nth 1 info))))
+ (expand-cmd (intern (concat "org-babel-expand-body:" lang)))
+ (assignments-cmd (intern (concat "org-babel-variable-assignments:" lang)))
+ (expanded
+ (if (fboundp expand-cmd) (funcall expand-cmd body params)
+ (org-babel-expand-body:generic
+ body params (and (fboundp assignments-cmd) (funcall assignments-cmd params))))))
+ (org-edit-src-code
+ nil expanded (concat "*Org-Babel Preview " (buffer-name) "[ " lang " ]*"))))
+
+;;;###autoload
+(defun org-babel-load-in-session (&optional arg info)
+ "Load the body of the current source-code block.
+Evaluate the header arguments for the source block before
+entering the session. After loading the body this pops open the
+session."
+ (interactive)
+ (let* ((info (or info (org-babel-get-src-block-info)))
+ (lang (nth 0 info))
+ (params (nth 2 info))
+ (body (setf (nth 1 info)
+ (if (and (cdr (assoc :noweb params))
+ (string= "yes" (cdr (assoc :noweb params))))
+ (org-babel-expand-noweb-references info)
+ (nth 1 info))))
+ (session (cdr (assoc :session params)))
+ (dir (cdr (assoc :dir params)))
+ (default-directory
+ (or (and dir (file-name-as-directory dir)) default-directory))
+ (cmd (intern (concat "org-babel-load-session:" lang))))
+ (unless (fboundp cmd)
+ (error "No org-babel-load-session function for %s!" lang))
+ (pop-to-buffer (funcall cmd session body params))
+ (end-of-line 1)))
+
+;;;###autoload
+(defun org-babel-initiate-session (&optional arg info)
+ "Initiate session for current code block.
+If called with a prefix argument then resolve any variable
+references in the header arguments and assign these variables in
+the session. Copy the body of the code block to the kill ring."
+ (interactive "P")
+ (let* ((info (or info (org-babel-get-src-block-info (not arg))))
+ (lang (nth 0 info))
+ (body (nth 1 info))
+ (params (nth 2 info))
+ (session (cdr (assoc :session params)))
+ (dir (cdr (assoc :dir params)))
+ (default-directory
+ (or (and dir (file-name-as-directory dir)) default-directory))
+ (init-cmd (intern (format "org-babel-%s-initiate-session" lang)))
+ (prep-cmd (intern (concat "org-babel-prep-session:" lang))))
+ (if (and (stringp session) (string= session "none"))
+ (error "This block is not using a session!"))
+ (unless (fboundp init-cmd)
+ (error "No org-babel-initiate-session function for %s!" lang))
+ (with-temp-buffer (insert (org-babel-trim body))
+ (copy-region-as-kill (point-min) (point-max)))
+ (when arg
+ (unless (fboundp prep-cmd)
+ (error "No org-babel-prep-session function for %s!" lang))
+ (funcall prep-cmd session params))
+ (funcall init-cmd session params)))
+
+;;;###autoload
+(defun org-babel-switch-to-session (&optional arg info)
+ "Switch to the session of the current code block.
+Uses `org-babel-initiate-session' to start the session. If called
+with a prefix argument then this is passed on to
+`org-babel-initiate-session'."
+ (interactive "P")
+ (pop-to-buffer (org-babel-initiate-session arg info))
+ (end-of-line 1))
+
+(defalias 'org-babel-pop-to-session 'org-babel-switch-to-session)
+
+;;;###autoload
+(defun org-babel-switch-to-session-with-code (&optional arg info)
+ "Switch to code buffer and display session."
+ (interactive "P")
+ (flet ((swap-windows
+ ()
+ (let ((other-window-buffer (window-buffer (next-window))))
+ (set-window-buffer (next-window) (current-buffer))
+ (set-window-buffer (selected-window) other-window-buffer))
+ (other-window 1)))
+ (let ((info (org-babel-get-src-block-info))
+ (org-src-window-setup 'reorganize-frame))
+ (save-excursion
+ (org-babel-switch-to-session arg info))
+ (org-edit-src-code))
+ (swap-windows)))
+
+(defmacro org-babel-do-in-edit-buffer (&rest body)
+ "Evaluate BODY in edit buffer if there is a code block at point.
+Return t if a code block was found at point, nil otherwise."
+ `(let ((org-src-window-setup 'switch-invisibly))
+ (when (and (org-babel-where-is-src-block-head)
+ (org-edit-src-code nil nil nil 'quietly))
+ (unwind-protect (progn ,@body)
+ (if (org-bound-and-true-p org-edit-src-from-org-mode)
+ (org-edit-src-exit)))
+ t)))
+
+(defun org-babel-do-key-sequence-in-edit-buffer (key)
+ "Read key sequence and execute the command in edit buffer.
+Enter a key sequence to be executed in the language major-mode
+edit buffer. For example, TAB will alter the contents of the
+Org-mode code block according to the effect of TAB in the
+language major-mode buffer. For languages that support
+interactive sessions, this can be used to send code from the Org
+buffer to the session for evaluation using the native major-mode
+evaluation mechanisms."
+ (interactive "kEnter key-sequence to execute in edit buffer: ")
+ (org-babel-do-in-edit-buffer
+ (call-interactively
+ (key-binding (or key (read-key-sequence nil))))))
+
+(defvar org-bracket-link-regexp)
+;;;###autoload
+(defun org-babel-open-src-block-result (&optional re-run)
+ "If `point' is on a src block then open the results of the
+source code block, otherwise return nil. With optional prefix
+argument RE-RUN the source-code block is evaluated even if
+results already exist."
+ (interactive "P")
+ (when (org-babel-get-src-block-info)
+ (save-excursion
+ ;; go to the results, if there aren't any then run the block
+ (goto-char (or (and (not re-run) (org-babel-where-is-src-block-result))
+ (progn (org-babel-execute-src-block)
+ (org-babel-where-is-src-block-result))))
+ (end-of-line 1)
+ (while (looking-at "[\n\r\t\f ]") (forward-char 1))
+ ;; open the results
+ (if (looking-at org-bracket-link-regexp)
+ ;; file results
+ (org-open-at-point)
+ (let ((results (org-babel-read-result)))
+ (flet ((echo-res (result)
+ (if (stringp result) result (format "%S" result))))
+ (pop-to-buffer (get-buffer-create "org-babel-results"))
+ (delete-region (point-min) (point-max))
+ (if (listp results)
+ ;; table result
+ (insert (orgtbl-to-generic results '(:sep "\t" :fmt echo-res)))
+ ;; scalar result
+ (insert (echo-res results))))))
+ t)))
+
+;;;###autoload
+(defun org-babel-execute-buffer (&optional arg)
+ "Execute source code blocks in a buffer.
+Call `org-babel-execute-src-block' on every source block in
+the current buffer."
+ (interactive "P")
+ (org-save-outline-visibility t
+ (org-babel-map-src-blocks nil
+ (org-babel-execute-src-block arg))))
+
+;;;###autoload
+(defun org-babel-execute-subtree (&optional arg)
+ "Execute source code blocks in a subtree.
+Call `org-babel-execute-src-block' on every source block in
+the current subtree."
+ (interactive "P")
+ (save-restriction
+ (save-excursion
+ (org-narrow-to-subtree)
+ (org-babel-execute-buffer arg)
+ (widen))))
+
+;;;###autoload
+(defun org-babel-sha1-hash (&optional info)
+ "Generate an sha1 hash based on the value of info."
+ (interactive)
+ (let ((print-level nil)
+ (info (or info (org-babel-get-src-block-info))))
+ (setf (nth 2 info)
+ (sort (copy-sequence (nth 2 info))
+ (lambda (a b) (string< (car a) (car b)))))
+ (let ((hash (sha1
+ (format "%s-%s"
+ (mapconcat
+ #'identity
+ (delq nil
+ (mapcar
+ (lambda (arg)
+ (let ((v (cdr arg)))
+ (when (and v (not (and (sequencep v)
+ (not (consp v))
+ (= (length v) 0))))
+ (format "%S" v))))
+ (nth 2 info))) ":")
+ (nth 1 info)))))
+ (when (interactive-p) (message hash))
+ hash)))
+
+(defun org-babel-result-hash (&optional info)
+ "Return the in-buffer hash associated with INFO."
+ (org-babel-where-is-src-block-result nil info)
+ (org-babel-clean-text-properties (match-string 3)))
+
+(defun org-babel-hide-hash ()
+ "Hide the hash in the current results line.
+Only the initial `org-babel-hash-show' characters of the hash
+will remain visible."
+ (add-to-invisibility-spec '(org-babel-hide-hash . t))
+ (save-excursion
+ (when (and (re-search-forward org-babel-result-regexp nil t)
+ (match-string 3))
+ (let* ((start (match-beginning 3))
+ (hide-start (+ org-babel-hash-show start))
+ (end (match-end 3))
+ (hash (match-string 3))
+ ov1 ov2)
+ (setq ov1 (make-overlay start hide-start))
+ (setq ov2 (make-overlay hide-start end))
+ (overlay-put ov2 'invisible 'org-babel-hide-hash)
+ (overlay-put ov1 'babel-hash hash)))))
+
+(defun org-babel-hide-all-hashes ()
+ "Hide the hash in the current buffer.
+Only the initial `org-babel-hash-show' characters of each hash
+will remain visible. This function should be called as part of
+the `org-mode-hook'."
+ (save-excursion
+ (while (re-search-forward org-babel-result-regexp nil t)
+ (goto-char (match-beginning 0))
+ (org-babel-hide-hash)
+ (goto-char (match-end 0)))))
+(add-hook 'org-mode-hook 'org-babel-hide-all-hashes)
+
+(defun org-babel-hash-at-point (&optional point)
+ "Return the value of the hash at POINT.
+The hash is also added as the last element of the kill ring.
+This can be called with C-c C-c."
+ (interactive)
+ (let ((hash (car (delq nil (mapcar
+ (lambda (ol) (overlay-get ol 'babel-hash))
+ (overlays-at (or point (point))))))))
+ (when hash (kill-new hash) (message hash))))
+(add-hook 'org-ctrl-c-ctrl-c-hook 'org-babel-hash-at-point)
+
+(defun org-babel-result-hide-spec ()
+ "Hide portions of results lines.
+Add `org-babel-hide-result' as an invisibility spec for hiding
+portions of results lines."
+ (add-to-invisibility-spec '(org-babel-hide-result . t)))
+(add-hook 'org-mode-hook 'org-babel-result-hide-spec)
+
+(defvar org-babel-hide-result-overlays nil
+ "Overlays hiding results.")
+
+(defun org-babel-result-hide-all ()
+ "Fold all results in the current buffer."
+ (interactive)
+ (org-babel-show-result-all)
+ (save-excursion
+ (while (re-search-forward org-babel-result-regexp nil t)
+ (save-excursion (goto-char (match-beginning 0))
+ (org-babel-hide-result-toggle-maybe)))))
+
+(defun org-babel-show-result-all ()
+ "Unfold all results in the current buffer."
+ (mapc 'delete-overlay org-babel-hide-result-overlays)
+ (setq org-babel-hide-result-overlays nil))
+
+;;;###autoload
+(defun org-babel-hide-result-toggle-maybe ()
+ "Toggle visibility of result at point."
+ (interactive)
+ (let ((case-fold-search t))
+ (if (save-excursion
+ (beginning-of-line 1)
+ (looking-at org-babel-result-regexp))
+ (progn (org-babel-hide-result-toggle)
+ t) ;; to signal that we took action
+ nil))) ;; to signal that we did not
+
+(defun org-babel-hide-result-toggle (&optional force)
+ "Toggle the visibility of the current result."
+ (interactive)
+ (save-excursion
+ (beginning-of-line)
+ (if (re-search-forward org-babel-result-regexp nil t)
+ (let ((start (progn (beginning-of-line 2) (- (point) 1)))
+ (end (progn (goto-char (- (org-babel-result-end) 1)) (point)))
+ ov)
+ (if (memq t (mapcar (lambda (overlay)
+ (eq (overlay-get overlay 'invisible)
+ 'org-babel-hide-result))
+ (overlays-at start)))
+ (if (or (not force) (eq force 'off))
+ (mapc (lambda (ov)
+ (when (member ov org-babel-hide-result-overlays)
+ (setq org-babel-hide-result-overlays
+ (delq ov org-babel-hide-result-overlays)))
+ (when (eq (overlay-get ov 'invisible)
+ 'org-babel-hide-result)
+ (delete-overlay ov)))
+ (overlays-at start)))
+ (setq ov (make-overlay start end))
+ (overlay-put ov 'invisible 'org-babel-hide-result)
+ ;; make the block accessible to isearch
+ (overlay-put
+ ov 'isearch-open-invisible
+ (lambda (ov)
+ (when (member ov org-babel-hide-result-overlays)
+ (setq org-babel-hide-result-overlays
+ (delq ov org-babel-hide-result-overlays)))
+ (when (eq (overlay-get ov 'invisible)
+ 'org-babel-hide-result)
+ (delete-overlay ov))))
+ (push ov org-babel-hide-result-overlays)))
+ (error "Not looking at a result line"))))
+
+;; org-tab-after-check-for-cycling-hook
+(add-hook 'org-tab-first-hook 'org-babel-hide-result-toggle-maybe)
+;; Remove overlays when changing major mode
+(add-hook 'org-mode-hook
+ (lambda () (org-add-hook 'change-major-mode-hook
+ 'org-babel-show-result-all 'append 'local)))
+
+(defmacro org-babel-map-src-blocks (file &rest body)
+ "Evaluate BODY forms on each source-block in FILE.
+If FILE is nil evaluate BODY forms on source blocks in current
+buffer. During evaluation of BODY the following local variables
+are set relative to the currently matched code block.
+
+full-block ------- string holding the entirety of the code block
+beg-block -------- point at the beginning of the code block
+end-block -------- point at the end of the matched code block
+lang ------------- string holding the language of the code block
+beg-lang --------- point at the beginning of the lang
+end-lang --------- point at the end of the lang
+switches --------- string holding the switches
+beg-switches ----- point at the beginning of the switches
+end-switches ----- point at the end of the switches
+header-args ------ string holding the header-args
+beg-header-args -- point at the beginning of the header-args
+end-header-args -- point at the end of the header-args
+body ------------- string holding the body of the code block
+beg-body --------- point at the beginning of the body
+end-body --------- point at the end of the body"
+ (declare (indent 1))
+ `(let ((visited-p (or (null ,file)
+ (get-file-buffer (expand-file-name ,file))))
+ (point (point)) to-be-removed)
+ (save-window-excursion
+ (when ,file (find-file ,file))
+ (setq to-be-removed (current-buffer))
+ (goto-char (point-min))
+ (while (re-search-forward org-babel-src-block-regexp nil t)
+ (goto-char (match-beginning 0))
+ (let ((full-block (match-string 0))
+ (beg-block (match-beginning 0))
+ (end-block (match-end 0))
+ (lang (match-string 2))
+ (beg-lang (match-beginning 2))
+ (end-lang (match-end 2))
+ (switches (match-string 3))
+ (beg-switches (match-beginning 3))
+ (end-switches (match-end 3))
+ (header-args (match-string 4))
+ (beg-header-args (match-beginning 4))
+ (end-header-args (match-end 4))
+ (body (match-string 5))
+ (beg-body (match-beginning 5))
+ (end-body (match-end 5)))
+ ,@body
+ (goto-char end-block))))
+ (unless visited-p (kill-buffer to-be-removed))
+ (goto-char point)))
+
+(defvar org-file-properties)
+(defun org-babel-params-from-properties (&optional lang)
+ "Retrieve parameters specified as properties.
+Return an association list of any source block params which
+may be specified in the properties of the current outline entry."
+ (save-match-data
+ (let (val sym)
+ (delq nil
+ (mapcar
+ (lambda (header-arg)
+ (and (setq val
+ (or (condition-case nil
+ (org-entry-get (point) header-arg t)
+ (error nil))
+ (cdr (assoc header-arg org-file-properties))))
+ (cons (intern (concat ":" header-arg))
+ (org-babel-read val))))
+ (mapcar
+ 'symbol-name
+ (append
+ org-babel-header-arg-names
+ (progn
+ (setq sym (intern (concat "org-babel-header-arg-names:" lang)))
+ (and (boundp sym) (eval sym))))))))))
+
+(defun org-babel-params-from-buffer ()
+ "Retrieve per-buffer parameters.
+ Return an association list of any source block params which
+may be specified at the top of the current buffer."
+ (or org-babel-current-buffer-properties
+ (setq org-babel-current-buffer-properties
+ (save-match-data
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (when (re-search-forward
+ (org-make-options-regexp (list "BABEL")) nil t)
+ (org-babel-parse-header-arguments
+ (org-match-string-no-properties 2)))))))))
+
+(defvar org-src-preserve-indentation)
+(defun org-babel-parse-src-block-match ()
+ "Parse the results from a match of the `org-babel-src-block-regexp'."
+ (let* ((block-indentation (length (match-string 1)))
+ (lang (org-babel-clean-text-properties (match-string 2)))
+ (lang-headers (intern (concat "org-babel-default-header-args:" lang)))
+ (switches (match-string 3))
+ (body (org-babel-clean-text-properties (match-string 5)))
+ (preserve-indentation (or org-src-preserve-indentation
+ (string-match "-i\\>" switches))))
+ (list lang
+ ;; get block body less properties, protective commas, and indentation
+ (with-temp-buffer
+ (save-match-data
+ (insert (org-babel-strip-protective-commas body))
+ (unless preserve-indentation (org-do-remove-indentation))
+ (buffer-string)))
+ (org-babel-merge-params
+ org-babel-default-header-args
+ (org-babel-params-from-buffer)
+ (org-babel-params-from-properties lang)
+ (if (boundp lang-headers) (eval lang-headers) nil)
+ (org-babel-parse-header-arguments
+ (org-babel-clean-text-properties (or (match-string 4) ""))))
+ switches
+ block-indentation)))
+
+(defun org-babel-parse-inline-src-block-match ()
+ "Parse the results from a match of the `org-babel-inline-src-block-regexp'."
+ (let* ((lang (org-babel-clean-text-properties (match-string 2)))
+ (lang-headers (intern (concat "org-babel-default-header-args:" lang))))
+ (list lang
+ (org-babel-strip-protective-commas
+ (org-babel-clean-text-properties (match-string 5)))
+ (org-babel-merge-params
+ org-babel-default-inline-header-args
+ (org-babel-params-from-buffer)
+ (org-babel-params-from-properties lang)
+ (if (boundp lang-headers) (eval lang-headers) nil)
+ (org-babel-parse-header-arguments
+ (org-babel-clean-text-properties (or (match-string 4) "")))))))
+
+(defun org-babel-parse-header-arguments (arg-string)
+ "Parse a string of header arguments returning an alist."
+ (if (> (length arg-string) 0)
+ (delq nil
+ (mapcar
+ (lambda (arg)
+ (if (string-match
+ "\\([^ \f\t\n\r\v]+\\)[ \f\t\n\r\v]+\\([^ \f\t\n\r\v]+.*\\)"
+ arg)
+ (cons (intern (concat ":" (match-string 1 arg)))
+ (org-babel-read (org-babel-chomp (match-string 2 arg))))
+ (cons (intern (concat ":" arg)) nil)))
+ (split-string (concat " " arg-string) "[ \f\t\n\r\v]+:" t)))))
+
+(defun org-babel-process-params (params)
+ "Expand variables in PARAMS and add summary parameters."
+ (let* ((vars-and-names (org-babel-disassemble-tables
+ (mapcar (lambda (el)
+ (if (consp (cdr el))
+ (cdr el) (org-babel-ref-parse (cdr el))))
+ (org-babel-get-header params :var))
+ (cdr (assoc :hlines params))
+ (cdr (assoc :colnames params))
+ (cdr (assoc :rownames params))))
+ (result-params (append
+ (split-string (or (cdr (assoc :results params)) ""))
+ (cdr (assoc :result-params params)))))
+ (append
+ (mapcar (lambda (var) (cons :var var)) (car vars-and-names))
+ (list
+ (cons :colname-names (cadr vars-and-names))
+ (cons :rowname-names (caddr vars-and-names))
+ (cons :result-params result-params)
+ (cons :result-type (cond ((member "output" result-params) 'output)
+ ((member "value" result-params) 'value)
+ (t 'value))))
+ (org-babel-get-header params :var 'other))))
+
+;; row and column names
+(defun org-babel-del-hlines (table)
+ "Remove all 'hlines from TABLE."
+ (remove 'hline table))
+
+(defun org-babel-get-colnames (table)
+ "Return the column names of TABLE.
+Return a cons cell, the `car' of which contains the TABLE less
+colnames, and the `cdr' of which contains a list of the column
+names."
+ (if (equal 'hline (nth 1 table))
+ (cons (cddr table) (car table))
+ (cons (cdr table) (car table))))
+
+(defun org-babel-get-rownames (table)
+ "Return the row names of TABLE.
+Return a cons cell, the `car' of which contains the TABLE less
+colnames, and the `cdr' of which contains a list of the column
+names. Note: this function removes any hlines in TABLE."
+ (flet ((trans (table) (apply #'mapcar* #'list table)))
+ (let* ((width (apply 'max
+ (mapcar (lambda (el) (if (listp el) (length el) 0)) table)))
+ (table (trans (mapcar (lambda (row)
+ (if (not (equal row 'hline))
+ row
+ (setq row '())
+ (dotimes (n width)
+ (setq row (cons 'hline row)))
+ row))
+ table))))
+ (cons (mapcar (lambda (row) (if (equal (car row) 'hline) 'hline row))
+ (trans (cdr table)))
+ (remove 'hline (car table))))))
+
+(defun org-babel-put-colnames (table colnames)
+ "Add COLNAMES to TABLE if they exist."
+ (if colnames (apply 'list colnames 'hline table) table))
+
+(defun org-babel-put-rownames (table rownames)
+ "Add ROWNAMES to TABLE if they exist."
+ (if rownames
+ (mapcar (lambda (row)
+ (if (listp row)
+ (cons (or (pop rownames) "") row)
+ row)) table)
+ table))
+
+(defun org-babel-pick-name (names selector)
+ "Select one out of an alist of row or column names.
+SELECTOR can be either a list of names in which case those names
+will be returned directly, or an index into the list NAMES in
+which case the indexed names will be return."
+ (if (listp selector)
+ selector
+ (when names
+ (if (and selector (symbolp selector) (not (equal t selector)))
+ (cdr (assoc selector names))
+ (if (integerp selector)
+ (nth (- selector 1) names)
+ (cdr (car (last names))))))))
+
+(defun org-babel-disassemble-tables (vars hlines colnames rownames)
+ "Parse tables for further processing.
+Process the variables in VARS according to the HLINES,
+ROWNAMES and COLNAMES header arguments. Return a list consisting
+of the vars, cnames and rnames."
+ (let (cnames rnames)
+ (list
+ (mapcar
+ (lambda (var)
+ (when (listp (cdr var))
+ (when (and (not (equal colnames "no"))
+ (or colnames (and (equal (nth 1 (cdr var)) 'hline)
+ (not (member 'hline (cddr (cdr var)))))))
+ (let ((both (org-babel-get-colnames (cdr var))))
+ (setq cnames (cons (cons (car var) (cdr both))
+ cnames))
+ (setq var (cons (car var) (car both)))))
+ (when (and rownames (not (equal rownames "no")))
+ (let ((both (org-babel-get-rownames (cdr var))))
+ (setq rnames (cons (cons (car var) (cdr both))
+ rnames))
+ (setq var (cons (car var) (car both)))))
+ (when (and hlines (not (equal hlines "yes")))
+ (setq var (cons (car var) (org-babel-del-hlines (cdr var))))))
+ var)
+ vars)
+ cnames rnames)))
+
+(defun org-babel-reassemble-table (table colnames rownames)
+ "Add column and row names to a table.
+Given a TABLE and set of COLNAMES and ROWNAMES add the names
+to the table for reinsertion to org-mode."
+ (if (listp table)
+ ((lambda (table)
+ (if (and colnames (listp (car table)) (= (length (car table))
+ (length colnames)))
+ (org-babel-put-colnames table colnames) table))
+ (if (and rownames (= (length table) (length rownames)))
+ (org-babel-put-rownames table rownames) table))
+ table))
+
+(defun org-babel-where-is-src-block-head ()
+ "Find where the current source block begins.
+Return the point at the beginning of the current source
+block. Specifically at the beginning of the #+BEGIN_SRC line.
+If the point is not on a source block then return nil."
+ (let ((initial (point)) top bottom)
+ (or
+ (save-excursion ;; on a source name line
+ (beginning-of-line 1)
+ (and (looking-at org-babel-src-name-regexp) (forward-line 1)
+ (looking-at org-babel-src-block-regexp)
+ (point)))
+ (save-excursion ;; on a #+begin_src line
+ (beginning-of-line 1)
+ (and (looking-at org-babel-src-block-regexp)
+ (point)))
+ (save-excursion ;; inside a src block
+ (and
+ (re-search-backward "^[ \t]*#\\+begin_src" nil t) (setq top (point))
+ (re-search-forward "^[ \t]*#\\+end_src" nil t) (setq bottom (point))
+ (< top initial) (< initial bottom)
+ (progn (goto-char top) (beginning-of-line 1)
+ (looking-at org-babel-src-block-regexp))
+ (point))))))
+
+;;;###autoload
+(defun org-babel-goto-src-block-head ()
+ "Go to the beginning of the current code block."
+ (interactive)
+ ((lambda (head)
+ (if head (goto-char head) (error "not currently in a code block")))
+ (org-babel-where-is-src-block-head)))
+
+;;;###autoload
+(defun org-babel-goto-named-src-block (name)
+ "Go to a named source-code block."
+ (interactive
+ (let ((completion-ignore-case t))
+ (list (org-icompleting-read "source-block name: "
+ (org-babel-src-block-names) nil t))))
+ (let ((point (org-babel-find-named-block name)))
+ (if point
+ ;; taken from `org-open-at-point'
+ (progn (goto-char point) (org-show-context))
+ (message "source-code block '%s' not found in this buffer" name))))
+
+(defun org-babel-find-named-block (name)
+ "Find a named source-code block.
+Return the location of the source block identified by source
+NAME, or nil if no such block exists. Set match data according to
+org-babel-named-src-block-regexp."
+ (save-excursion
+ (let ((case-fold-search t)
+ (regexp (org-babel-named-src-block-regexp-for-name name)) msg)
+ (goto-char (point-min))
+ (when (or (re-search-forward regexp nil t)
+ (re-search-backward regexp nil t))
+ (match-beginning 0)))))
+
+(defun org-babel-src-block-names (&optional file)
+ "Returns the names of source blocks in FILE or the current buffer."
+ (save-excursion
+ (when file (find-file file)) (goto-char (point-min))
+ (let (names)
+ (while (re-search-forward org-babel-src-name-w-name-regexp nil t)
+ (setq names (cons (org-babel-clean-text-properties (match-string 3))
+ names)))
+ names)))
+
+;;;###autoload
+(defun org-babel-goto-named-result (name)
+ "Go to a named result."
+ (interactive
+ (let ((completion-ignore-case t))
+ (list (org-icompleting-read "source-block name: "
+ (org-babel-result-names) nil t))))
+ (let ((point (org-babel-find-named-result name)))
+ (if point
+ ;; taken from `org-open-at-point'
+ (progn (goto-char point) (org-show-context))
+ (message "result '%s' not found in this buffer" name))))
+
+(defun org-babel-find-named-result (name)
+ "Find a named result.
+Return the location of the result named NAME in the current
+buffer or nil if no such result exists."
+ (save-excursion
+ (goto-char (point-min))
+ (when (re-search-forward
+ (concat org-babel-result-regexp
+ "[ \t]" (regexp-quote name) "[ \t\n\f\v\r]") nil t)
+ (beginning-of-line 0) (point))))
+
+(defun org-babel-result-names (&optional file)
+ "Returns the names of results in FILE or the current buffer."
+ (save-excursion
+ (when file (find-file file)) (goto-char (point-min))
+ (let (names)
+ (while (re-search-forward org-babel-result-w-name-regexp nil t)
+ (setq names (cons (org-babel-clean-text-properties (match-string 4))
+ names)))
+ names)))
+
+;;;###autoload
+(defun org-babel-next-src-block (&optional arg)
+ "Jump to the next source block.
+With optional prefix argument ARG, jump forward ARG many source blocks."
+ (interactive "P")
+ (when (looking-at org-babel-src-block-regexp) (forward-char 1))
+ (condition-case nil
+ (re-search-forward org-babel-src-block-regexp nil nil (or arg 1))
+ (error (error "No further code blocks")))
+ (goto-char (match-beginning 0)) (org-show-context))
+
+;;;###autoload
+(defun org-babel-previous-src-block (&optional arg)
+ "Jump to the previous source block.
+With optional prefix argument ARG, jump backward ARG many source blocks."
+ (interactive "P")
+ (condition-case nil
+ (re-search-backward org-babel-src-block-regexp nil nil (or arg 1))
+ (error (error "No previous code blocks")))
+ (goto-char (match-beginning 0)) (org-show-context))
+
+(defvar org-babel-load-languages)
+
+;;;###autoload
+(defun org-babel-mark-block ()
+ "Mark current src block"
+ (interactive)
+ ((lambda (head)
+ (when head
+ (save-excursion
+ (goto-char head)
+ (looking-at org-babel-src-block-regexp))
+ (push-mark (match-end 5) nil t)
+ (goto-char (match-beginning 5))))
+ (org-babel-where-is-src-block-head)))
+
+(defun org-babel-demarcate-block (&optional arg)
+ "Wrap or split the code in the region or on the point.
+When called from inside of a code block the current block is
+split. When called from outside of a code block a new code block
+is created. In both cases if the region is demarcated and if the
+region is not active then the point is demarcated."
+ (interactive "P")
+ (let ((info (org-babel-get-src-block-info 'light))
+ (stars (concat (make-string (or (org-current-level) 1) ?*) " ")))
+ (if info
+ (mapc
+ (lambda (place)
+ (save-excursion
+ (goto-char place)
+ (let ((lang (nth 0 info))
+ (indent (make-string (nth 5 info) ? )))
+ (when (string-match "^[[:space:]]*$"
+ (buffer-substring (point-at-bol)
+ (point-at-eol)))
+ (delete-region (point-at-bol) (point-at-eol)))
+ (insert (concat (if (looking-at "^") "" "\n")
+ indent "#+end_src\n"
+ (if arg stars indent) "\n"
+ indent "#+begin_src " lang
+ (if (looking-at "[\n\r]") "" "\n")))))
+ (move-end-of-line 2))
+ (sort (if (region-active-p) (list (mark) (point)) (list (point))) #'>))
+ (let ((start (point))
+ (lang (org-icompleting-read "Lang: "
+ (mapcar (lambda (el) (symbol-name (car el)))
+ org-babel-load-languages)))
+ (body (delete-and-extract-region
+ (if (region-active-p) (mark) (point)) (point))))
+ (insert (concat (if (looking-at "^") "" "\n")
+ (if arg (concat stars "\n") "")
+ "#+begin_src " lang "\n"
+ body
+ (if (or (= (length body) 0)
+ (string-match "[\r\n]$" body)) "" "\n")
+ "#+end_src\n"))
+ (goto-char start) (move-end-of-line 1)))))
+
+(defvar org-babel-lob-one-liner-regexp)
+(defun org-babel-where-is-src-block-result (&optional insert info hash indent)
+ "Find where the current source block results begin.
+Return the point at the beginning of the result of the current
+source block. Specifically at the beginning of the results line.
+If no result exists for this block then create a results line
+following the source block."
+ (save-excursion
+ (let* ((on-lob-line (progn (beginning-of-line 1)
+ (looking-at org-babel-lob-one-liner-regexp)))
+ (name (if on-lob-line
+ (nth 0 (org-babel-lob-get-info))
+ (nth 4 (or info (org-babel-get-src-block-info)))))
+ (head (unless on-lob-line (org-babel-where-is-src-block-head)))
+ found beg end)
+ (when head (goto-char head))
+ (setq
+ found ;; was there a result (before we potentially insert one)
+ (or
+ (and
+ ;; named results:
+ ;; - return t if it is found, else return nil
+ ;; - if it does not need to be rebuilt, then don't set end
+ ;; - if it does need to be rebuilt then do set end
+ name (setq beg (org-babel-find-named-result name))
+ (prog1 beg
+ (when (and hash (not (string= hash (match-string 3))))
+ (goto-char beg) (setq end beg) ;; beginning of result
+ (forward-line 1)
+ (delete-region end (org-babel-result-end)) nil)))
+ (and
+ ;; unnamed results:
+ ;; - return t if it is found, else return nil
+ ;; - if it is found, and the hash doesn't match, delete and set end
+ (or on-lob-line (re-search-forward "^[ \t]*#\\+end_src" nil t))
+ (progn (end-of-line 1)
+ (if (eobp) (insert "\n") (forward-char 1))
+ (setq end (point))
+ (or (and (not name)
+ (progn ;; unnamed results line already exists
+ (re-search-forward "[^ \f\t\n\r\v]" nil t)
+ (beginning-of-line 1)
+ (looking-at
+ (concat org-babel-result-regexp "\n")))
+ (prog1 (point)
+ ;; must remove and rebuild if hash!=old-hash
+ (if (and hash (not (string= hash (match-string 3))))
+ (prog1 nil
+ (forward-line 1)
+ (delete-region
+ end (org-babel-result-end)))
+ (setq end nil)))))))))
+ (if (and insert end)
+ (progn
+ (goto-char end)
+ (unless beg
+ (if (looking-at "[\n\r]") (forward-char 1) (insert "\n")))
+ (insert (concat
+ (if indent
+ (mapconcat
+ (lambda (el) " ")
+ (org-number-sequence 1 indent) "")
+ "")
+ "#+results"
+ (when hash (concat "["hash"]"))
+ ":"
+ (when name (concat " " name)) "\n"))
+ (unless beg (insert "\n") (backward-char))
+ (beginning-of-line 0)
+ (if hash (org-babel-hide-hash))
+ (point))
+ found))))
+
+(defvar org-block-regexp)
+(defun org-babel-read-result ()
+ "Read the result at `point' into emacs-lisp."
+ (let ((case-fold-search t) result-string)
+ (cond
+ ((org-at-table-p) (org-babel-read-table))
+ ((looking-at org-bracket-link-regexp) (org-babel-read-link))
+ ((looking-at org-block-regexp) (org-babel-trim (match-string 4)))
+ ((looking-at "^[ \t]*: ")
+ (setq result-string
+ (org-babel-trim
+ (mapconcat (lambda (line)
+ (if (and (> (length line) 1)
+ (string-match "^[ \t]*: \\(.+\\)" line))
+ (match-string 1 line)
+ line))
+ (split-string
+ (buffer-substring
+ (point) (org-babel-result-end)) "[\r\n]+")
+ "\n")))
+ (or (org-babel-number-p result-string) result-string))
+ ((looking-at org-babel-result-regexp)
+ (save-excursion (forward-line 1) (org-babel-read-result))))))
+
+(defun org-babel-read-table ()
+ "Read the table at `point' into emacs-lisp."
+ (mapcar (lambda (row)
+ (if (and (symbolp row) (equal row 'hline)) row
+ (mapcar #'org-babel-read row)))
+ (org-table-to-lisp)))
+
+(defvar org-link-types-re)
+(defun org-babel-read-link ()
+ "Read the link at `point' into emacs-lisp.
+If the path of the link is a file path it is expanded using
+`expand-file-name'."
+ (let* ((case-fold-search t)
+ (raw (and (looking-at org-bracket-link-regexp)
+ (org-babel-clean-text-properties (match-string 1))))
+ (type (and (string-match org-link-types-re raw)
+ (match-string 1 raw))))
+ (cond
+ ((not type) (expand-file-name raw))
+ ((string= type "file")
+ (and (string-match "file\\(.*\\):\\(.+\\)" raw)
+ (expand-file-name (match-string 2 raw))))
+ (t raw))))
+
+(defun org-babel-insert-result
+ (result &optional result-params info hash indent lang)
+ "Insert RESULT into the current buffer.
+By default RESULT is inserted after the end of the
+current source block. With optional argument RESULT-PARAMS
+controls insertion of results in the org-mode file.
+RESULT-PARAMS can take the following values...
+
+replace - (default option) insert results after the source block
+ replacing any previously inserted results
+
+silent -- no results are inserted
+
+file ---- the results are interpreted as a file path, and are
+ inserted into the buffer using the Org-mode file syntax
+
+raw ----- results are added directly to the org-mode file. This
+ is a good option if you code block will output org-mode
+ formatted text.
+
+org ----- similar in effect to raw, only the results are wrapped
+ in an org code block. Similar to the raw option, on
+ export the results will be interpreted as org-formatted
+ text, however by wrapping the results in an org code
+ block they can be replaced upon re-execution of the
+ code block.
+
+html ---- results are added inside of a #+BEGIN_HTML block. This
+ is a good option if you code block will output html
+ formatted text.
+
+latex --- results are added inside of a #+BEGIN_LATEX block.
+ This is a good option if you code block will output
+ latex formatted text.
+
+code ---- the results are extracted in the syntax of the source
+ code of the language being evaluated and are added
+ inside of a #+BEGIN_SRC block with the source-code
+ language set appropriately. Note this relies on the
+ optional LANG argument."
+ (if (stringp result)
+ (progn
+ (setq result (org-babel-clean-text-properties result))
+ (when (member "file" result-params)
+ (setq result (org-babel-result-to-file result))))
+ (unless (listp result) (setq result (format "%S" result))))
+ (if (and result-params (member "silent" result-params))
+ (progn
+ (message (replace-regexp-in-string "%" "%%" (format "%S" result)))
+ result)
+ (when (and (stringp result) ;; ensure results end in a newline
+ (> (length result) 0)
+ (not (or (string-equal (substring result -1) "\n")
+ (string-equal (substring result -1) "\r"))))
+ (setq result (concat result "\n")))
+ (save-excursion
+ (let ((existing-result (org-babel-where-is-src-block-result
+ t info hash indent))
+ (results-switches
+ (cdr (assoc :results_switches (nth 2 info))))
+ beg end)
+ (if (not existing-result)
+ (setq beg (point))
+ (goto-char existing-result)
+ (save-excursion
+ (re-search-forward "#" nil t)
+ (setq indent (- (current-column) 1)))
+ (forward-line 1)
+ (setq beg (point))
+ (cond
+ ((member "replace" result-params)
+ (delete-region (point) (org-babel-result-end)))
+ ((member "append" result-params)
+ (goto-char (org-babel-result-end)) (setq beg (point)))
+ ((member "prepend" result-params) ;; already there
+ )))
+ (setq results-switches
+ (if results-switches (concat " " results-switches) ""))
+ (cond
+ ;; do nothing for an empty result
+ ((= (length result) 0))
+ ;; assume the result is a table if it's not a string
+ ((not (stringp result))
+ (insert (concat (orgtbl-to-orgtbl
+ (if (or (eq 'hline (car result))
+ (and (listp (car result))
+ (listp (cdr (car result)))))
+ result (list result))
+ '(:fmt (lambda (cell) (format "%s" cell)))) "\n"))
+ (goto-char beg) (when (org-at-table-p) (org-table-align)))
+ ((member "file" result-params)
+ (insert result))
+ ((member "html" result-params)
+ (insert (format "#+BEGIN_HTML%s\n%s#+END_HTML\n"
+ results-switches result)))
+ ((member "latex" result-params)
+ (insert (format "#+BEGIN_LaTeX%s\n%s#+END_LaTeX\n"
+ results-switches result)))
+ ((member "code" result-params)
+ (insert (format "#+BEGIN_SRC %s%s\n%s#+END_SRC\n"
+ (or lang "none") results-switches result)))
+ ((member "org" result-params)
+ (insert (format "#+BEGIN_SRC org\n%s#+END_SRC\n" result)))
+ ((member "raw" result-params)
+ (save-excursion (insert result)) (if (org-at-table-p) (org-cycle)))
+ (t
+ (org-babel-examplize-region
+ (point) (progn (insert result) (point)) results-switches)))
+ ;; possibly indent the results to match the #+results line
+ (setq end (if (listp result) (org-table-end) (point)))
+ (when (and indent (> indent 0)
+ ;; in this case `table-align' does the work for us
+ (not (and (listp result)
+ (member "append" result-params))))
+ (indent-rigidly beg end indent))))
+ (if (= (length result) 0)
+ (if (member "value" result-params)
+ (message "No result returned by source block")
+ (message "Source block produced no output"))
+ (message "finished"))))
+
+(defun org-babel-remove-result (&optional info)
+ "Remove the result of the current source block."
+ (interactive)
+ (let ((location (org-babel-where-is-src-block-result nil info)) start)
+ (when location
+ (save-excursion
+ (goto-char location) (setq start (point)) (forward-line 1)
+ (delete-region start (org-babel-result-end))))))
+
+(defun org-babel-result-end ()
+ "Return the point at the end of the current set of results"
+ (save-excursion
+ (if (org-at-table-p)
+ (progn (goto-char (org-table-end)) (point))
+ (let ((case-fold-search t))
+ (cond
+ ((looking-at "[ \t]*#\\+begin_latex")
+ (re-search-forward "[ \t]*#\\+end_latex" nil t)
+ (forward-line 1))
+ ((looking-at "[ \t]*#\\+begin_html")
+ (re-search-forward "[ \t]*#\\+end_html" nil t)
+ (forward-line 1))
+ ((looking-at "[ \t]*#\\+begin_example")
+ (re-search-forward "[ \t]*#\\+end_example" nil t)
+ (forward-line 1))
+ ((looking-at "[ \t]*#\\+begin_src")
+ (re-search-forward "[ \t]*#\\+end_src" nil t)
+ (forward-line 1))
+ (t (progn (while (looking-at "[ \t]*\\(: \\|\\[\\[\\)")
+ (forward-line 1))))))
+ (point))))
+
+(defun org-babel-result-to-file (result)
+ "Convert RESULT into an `org-mode' link.
+If the `default-directory' is different from the containing
+file's directory then expand relative links."
+ (format
+ "[[file:%s]]"
+ (if (and default-directory
+ buffer-file-name
+ (not (string= (expand-file-name default-directory)
+ (expand-file-name
+ (file-name-directory buffer-file-name)))))
+ (expand-file-name result default-directory)
+ result)))
+
+(defun org-babel-examplize-region (beg end &optional results-switches)
+ "Comment out region using the ': ' org example quote."
+ (interactive "*r")
+ (let ((size (count-lines beg end)))
+ (save-excursion
+ (cond ((= size 0)
+ (error (concat "This should not be impossible:"
+ "a newline was appended to result if missing")))
+ ((< size org-babel-min-lines-for-block-output)
+ (goto-char beg)
+ (dotimes (n size)
+ (beginning-of-line 1) (insert ": ") (forward-line 1)))
+ (t
+ (goto-char beg)
+ (insert (if results-switches
+ (format "#+begin_example%s\n" results-switches)
+ "#+begin_example\n"))
+ (forward-char (- end beg))
+ (insert "#+end_example\n"))))))
+
+(defun org-babel-update-block-body (new-body)
+ "Update the body of the current code block to NEW-BODY."
+ (if (not (org-babel-where-is-src-block-head))
+ (error "not in source block")
+ (save-match-data
+ (replace-match (concat (org-babel-trim new-body) "\n") nil nil nil 5))
+ (indent-rigidly (match-beginning 5) (match-end 5) 2)))
+
+(defun org-babel-merge-params (&rest plists)
+ "Combine all parameter association lists in PLISTS.
+Later elements of PLISTS override the values of previous element.
+This takes into account some special considerations for certain
+parameters when merging lists."
+ (let ((results-exclusive-groups
+ '(("file" "vector" "table" "scalar" "raw" "org"
+ "html" "latex" "code" "pp")
+ ("replace" "silent" "append" "prepend")
+ ("output" "value")))
+ (exports-exclusive-groups
+ '(("code" "results" "both" "none")))
+ params results exports tangle noweb cache vars shebang comments)
+ (flet ((e-merge (exclusive-groups &rest result-params)
+ ;; maintain exclusivity of mutually exclusive parameters
+ (let (output)
+ (mapc (lambda (new-params)
+ (mapc (lambda (new-param)
+ (mapc (lambda (exclusive-group)
+ (when (member new-param exclusive-group)
+ (mapcar (lambda (excluded-param)
+ (setq output
+ (delete
+ excluded-param
+ output)))
+ exclusive-group)))
+ exclusive-groups)
+ (setq output (org-uniquify
+ (cons new-param output))))
+ new-params))
+ result-params)
+ output)))
+ (mapc
+ (lambda (plist)
+ (mapc
+ (lambda (pair)
+ (case (car pair)
+ (:var
+ (let ((name (if (listp (cdr pair))
+ (cadr pair)
+ (and (string-match "^\\([^= \f\t\n\r\v]+\\)[ \t]*="
+ (cdr pair))
+ (intern (match-string 1 (cdr pair)))))))
+ (when name
+ (setq vars
+ (cons (cons name pair)
+ (if (member name (mapcar #'car vars))
+ (delq nil
+ (mapcar
+ (lambda (p) (unless (equal (car p) name) p))
+ vars))
+ vars))))))
+ (:results
+ (setq results (e-merge results-exclusive-groups
+ results (split-string (cdr pair)))))
+ (:file
+ (when (cdr pair)
+ (setq results (e-merge results-exclusive-groups
+ results '("file")))
+ (unless (or (member "both" exports)
+ (member "none" exports)
+ (member "code" exports))
+ (setq exports (e-merge exports-exclusive-groups
+ exports '("results"))))
+ (setq params (cons pair (assq-delete-all (car pair) params)))))
+ (:exports
+ (setq exports (e-merge exports-exclusive-groups
+ exports (split-string (cdr pair)))))
+ (:tangle ;; take the latest -- always overwrite
+ (setq tangle (or (list (cdr pair)) tangle)))
+ (:noweb
+ (setq noweb (e-merge '(("yes" "no")) noweb
+ (split-string (or (cdr pair) "")))))
+ (:cache
+ (setq cache (e-merge '(("yes" "no")) cache
+ (split-string (or (cdr pair) "")))))
+ (:shebang ;; take the latest -- always overwrite
+ (setq shebang (or (list (cdr pair)) shebang)))
+ (:comments
+ (setq comments (e-merge '(("yes" "no")) comments
+ (split-string (or (cdr pair) "")))))
+ (t ;; replace: this covers e.g. :session
+ (setq params (cons pair (assq-delete-all (car pair) params))))))
+ plist))
+ plists))
+ (while vars (setq params (cons (cons :var (cddr (pop vars))) params)))
+ (cons (cons :comments (mapconcat 'identity comments " "))
+ (cons (cons :shebang (mapconcat 'identity shebang " "))
+ (cons (cons :cache (mapconcat 'identity cache " "))
+ (cons (cons :noweb (mapconcat 'identity noweb " "))
+ (cons (cons :tangle (mapconcat 'identity tangle " "))
+ (cons (cons :exports
+ (mapconcat 'identity exports " "))
+ (cons
+ (cons :results
+ (mapconcat 'identity results " "))
+ params)))))))))
+
+(defun org-babel-expand-noweb-references (&optional info parent-buffer)
+ "Expand Noweb references in the body of the current source code block.
+
+For example the following reference would be replaced with the
+body of the source-code block named 'example-block'.
+
+<<example-block>>
+
+Note that any text preceding the <<foo>> construct on a line will
+be interposed between the lines of the replacement text. So for
+example if <<foo>> is placed behind a comment, then the entire
+replacement text will also be commented.
+
+This function must be called from inside of the buffer containing
+the source-code block which holds BODY.
+
+In addition the following syntax can be used to insert the
+results of evaluating the source-code block named 'example-block'.
+
+<<example-block()>>
+
+Any optional arguments can be passed to example-block by placing
+the arguments inside the parenthesis following the convention
+defined by `org-babel-lob'. For example
+
+<<example-block(a=9)>>
+
+would set the value of argument \"a\" equal to \"9\". Note that
+these arguments are not evaluated in the current source-code
+block but are passed literally to the \"example-block\"."
+ (let* ((parent-buffer (or parent-buffer (current-buffer)))
+ (info (or info (org-babel-get-src-block-info)))
+ (lang (nth 0 info))
+ (body (nth 1 info))
+ (new-body "") index source-name evaluate prefix)
+ (flet ((nb-add (text)
+ (setq new-body (concat new-body text))))
+ (with-temp-buffer
+ (insert body) (goto-char (point-min))
+ (setq index (point))
+ (while (and (re-search-forward "<<\\(.+?\\)>>" nil t))
+ (save-match-data (setf source-name (match-string 1)))
+ (save-match-data (setq evaluate (string-match "\(.*\)" source-name)))
+ (save-match-data
+ (setq prefix
+ (buffer-substring (match-beginning 0)
+ (save-excursion
+ (beginning-of-line 1) (point)))))
+ ;; add interval to new-body (removing noweb reference)
+ (goto-char (match-beginning 0))
+ (nb-add (buffer-substring index (point)))
+ (goto-char (match-end 0))
+ (setq index (point))
+ (nb-add (with-current-buffer parent-buffer
+ (mapconcat ;; interpose PREFIX between every line
+ #'identity
+ (split-string
+ (if evaluate
+ (let ((raw (org-babel-ref-resolve source-name)))
+ (if (stringp raw) raw (format "%S" raw)))
+ (save-restriction
+ (widen)
+ (let ((point (org-babel-find-named-block
+ source-name)))
+ (if point
+ (save-excursion
+ (goto-char point)
+ (org-babel-trim
+ (org-babel-expand-noweb-references
+ (org-babel-get-src-block-info))))
+ ;; optionally raise an error if named
+ ;; source-block doesn't exist
+ (if (member lang org-babel-noweb-error-langs)
+ (error "%s"
+ (concat
+ "<<" source-name ">> "
+ "could not be resolved (see "
+ "`org-babel-noweb-error-langs')"))
+ "")))))
+ "[\n\r]") (concat "\n" prefix)))))
+ (nb-add (buffer-substring index (point-max)))))
+ new-body))
+
+(defun org-babel-clean-text-properties (text)
+ "Strip all properties from text return."
+ (when text
+ (set-text-properties 0 (length text) nil text) text))
+
+(defun org-babel-strip-protective-commas (body)
+ "Strip protective commas from bodies of source blocks."
+ (replace-regexp-in-string "^,#" "#" body))
+
+(defun org-babel-read (cell)
+ "Convert the string value of CELL to a number if appropriate.
+Otherwise if cell looks like lisp (meaning it starts with a
+\"(\" or a \"'\") then read it as lisp, otherwise return it
+unmodified as a string.
+
+This is taken almost directly from `org-read-prop'."
+ (if (and (stringp cell) (not (equal cell "")))
+ (or (org-babel-number-p cell)
+ (if (or (equal "(" (substring cell 0 1))
+ (equal "'" (substring cell 0 1))
+ (equal "`" (substring cell 0 1)))
+ (eval (read cell))
+ (progn (set-text-properties 0 (length cell) nil cell) cell)))
+ cell))
+
+(defun org-babel-number-p (string)
+ "If STRING represents a number return it's value."
+ (if (and (string-match "^-?[0-9]*\\.?[0-9]*$" string)
+ (= (length (substring string (match-beginning 0)
+ (match-end 0)))
+ (length string)))
+ (string-to-number string)))
+
+(defun org-babel-import-elisp-from-file (file-name &optional separator)
+ "Read the results located at FILE-NAME into an elisp table.
+If the table is trivial, then return it as a scalar."
+ (let (result)
+ (save-window-excursion
+ (with-temp-buffer
+ (condition-case nil
+ (progn
+ (org-table-import file-name separator)
+ (delete-file file-name)
+ (setq result (mapcar (lambda (row)
+ (mapcar #'org-babel-string-read row))
+ (org-table-to-lisp))))
+ (error nil)))
+ (if (null (cdr result)) ;; if result is trivial vector, then scalarize it
+ (if (consp (car result))
+ (if (null (cdr (car result)))
+ (caar result)
+ result)
+ (car result))
+ result))))
+
+(defun org-babel-string-read (cell)
+ "Strip nested \"s from around strings."
+ (org-babel-read (or (and (stringp cell)
+ (string-match "\\\"\\(.+\\)\\\"" cell)
+ (match-string 1 cell))
+ cell)))
+
+(defun org-babel-reverse-string (string)
+ "Return the reverse of STRING."
+ (apply 'string (reverse (string-to-list string))))
+
+(defun org-babel-chomp (string &optional regexp)
+ "Strip trailing spaces and carriage returns from STRING.
+Default regexp used is \"[ \f\t\n\r\v]\" but can be
+overwritten by specifying a regexp as a second argument."
+ (let ((regexp (or regexp "[ \f\t\n\r\v]")))
+ (while (and (> (length string) 0)
+ (string-match regexp (substring string -1)))
+ (setq string (substring string 0 -1)))
+ string))
+
+(defun org-babel-trim (string &optional regexp)
+ "Strip leading and trailing spaces and carriage returns from STRING.
+Like `org-babel-chomp' only it runs on both the front and back
+of the string."
+ (org-babel-chomp (org-babel-reverse-string
+ (org-babel-chomp (org-babel-reverse-string string) regexp))
+ regexp))
+
+(defvar org-babel-org-babel-call-process-region-original nil)
+(defun org-babel-tramp-handle-call-process-region
+ (start end program &optional delete buffer display &rest args)
+ "Use tramp to handle call-process-region.
+Fixes a bug in `tramp-handle-call-process-region'."
+ (if (and (featurep 'tramp) (file-remote-p default-directory))
+ (let ((tmpfile (tramp-compat-make-temp-file "")))
+ (write-region start end tmpfile)
+ (when delete (delete-region start end))
+ (unwind-protect
+ ;; (apply 'call-process program tmpfile buffer display args)
+ ;; bug in tramp
+ (apply 'process-file program tmpfile buffer display args)
+ (delete-file tmpfile)))
+ ;; org-babel-call-process-region-original is the original emacs
+ ;; definition. It is in scope from the let binding in
+ ;; org-babel-execute-src-block
+ (apply org-babel-call-process-region-original
+ start end program delete buffer display args)))
+
+(defun org-babel-local-file-name (file)
+ "Return the local name component of FILE."
+ (if (file-remote-p file)
+ (let (localname)
+ (with-parsed-tramp-file-name file nil
+ localname))
+ file))
+
+(defun org-babel-process-file-name (name &optional no-quote-p)
+ "Prepare NAME to be used in an external process.
+If NAME specifies a remote location, the remote portion of the
+name is removed, since in that case the process will be executing
+remotely. The file name is then processed by
+`expand-file-name'. Unless second argument NO-QUOTE-P is non-nil,
+the file name is additionally processed by
+`shell-quote-argument'"
+ ((lambda (f) (if no-quote-p f (shell-quote-argument f)))
+ (expand-file-name (org-babel-local-file-name name))))
+
+(defvar org-babel-temporary-directory)
+(unless (or noninteractive (boundp 'org-babel-temporary-directory))
+ (defvar org-babel-temporary-directory
+ (or (and (boundp 'org-babel-temporary-directory)
+ (file-exists-p org-babel-temporary-directory)
+ org-babel-temporary-directory)
+ (make-temp-file "babel-" t))
+ "Directory to hold temporary files created to execute code blocks.
+Used by `org-babel-temp-file'. This directory will be removed on
+Emacs shutdown."))
+
+(defun org-babel-temp-file (prefix &optional suffix)
+ "Create a temporary file in the `org-babel-temporary-directory'.
+Passes PREFIX and SUFFIX directly to `make-temp-file' with the
+value of `temporary-file-directory' temporarily set to the value
+of `org-babel-temporary-directory'."
+ (if (file-remote-p default-directory)
+ (make-temp-file
+ (concat (file-remote-p default-directory)
+ (expand-file-name
+ prefix temporary-file-directory)
+ nil suffix))
+ (let ((temporary-file-directory
+ (or (and (file-exists-p org-babel-temporary-directory)
+ org-babel-temporary-directory)
+ temporary-file-directory)))
+ (make-temp-file prefix nil suffix))))
+
+(defun org-babel-remove-temporary-directory ()
+ "Remove `org-babel-temporary-directory' on Emacs shutdown."
+ (when (and (boundp 'org-babel-temporary-directory)
+ (file-exists-p org-babel-temporary-directory))
+ ;; taken from `delete-directory' in files.el
+ (mapc (lambda (file)
+ ;; This test is equivalent to
+ ;; (and (file-directory-p fn) (not (file-symlink-p fn)))
+ ;; but more efficient
+ (if (eq t (car (file-attributes file)))
+ (delete-directory file)
+ (delete-file file)))
+ ;; We do not want to delete "." and "..".
+ (directory-files org-babel-temporary-directory 'full
+ "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*"))
+ (delete-directory org-babel-temporary-directory)))
+
+(add-hook 'kill-emacs-hook 'org-babel-remove-temporary-directory)
+
+(provide 'ob)
+
+;; arch-tag: 01a7ebee-06c5-4ee4-a709-e660d28c0af1
+
+;;; ob.el ends here
diff --git a/lisp/org/org-agenda.el b/lisp/org/org-agenda.el
index 856e7f34e32..1c9d6d4a3de 100644
--- a/lisp/org/org-agenda.el
+++ b/lisp/org/org-agenda.el
@@ -6,7 +6,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -32,8 +32,7 @@
(require 'org)
(eval-when-compile
- (require 'cl)
- (require 'calendar))
+ (require 'cl))
(declare-function diary-add-to-list "diary-lib"
(date string specifier &optional marker globcolor literal))
@@ -63,6 +62,7 @@
(declare-function org-habit-parse-todo "org-habit" (&optional pom))
(declare-function org-habit-get-priority "org-habit" (habit &optional moment))
(defvar calendar-mode-map)
+(defvar org-clock-current-task) ; defined in org-clock.el
(defvar org-mobile-force-id-on-agenda-items) ; defined in org-mobile.el
(defvar org-habit-show-habits)
(defvar org-habit-show-habits-only-for-today)
@@ -88,7 +88,7 @@ only needed when the text to be killed contains more than N non-white lines."
(integer :tag "When more than N lines")))
(defcustom org-agenda-compact-blocks nil
- "Non-nil means, make the block agenda more compact.
+ "Non-nil means make the block agenda more compact.
This is done by leaving out unnecessary lines."
:group 'org-agenda
:type 'boolean)
@@ -108,7 +108,7 @@ If it is a character, it will be repeated to fill the window width."
:group 'org-agenda)
(defcustom org-agenda-with-colors t
- "Non-nil means, use colors in agenda views."
+ "Non-nil means use colors in agenda views."
:group 'org-agenda-export
:type 'boolean)
@@ -143,13 +143,13 @@ specifies the maximum number of lines that will be added for each entry
that is listed in the agenda view.
Note that this variable is not used during display, only when exporting
-the agenda. For agenda display, see org-agenda-entry-text-mode and the
-variable `org-agenda-entry-text-maxlines'."
+the agenda. For agenda display, see the variables `org-agenda-entry-text-mode'
+and `org-agenda-entry-text-maxlines'."
:group 'org-agenda
:type 'integer)
(defcustom org-agenda-add-entry-text-descriptive-links t
- "Non-nil means, export org-links as descriptive links in agenda added text.
+ "Non-nil means export org-links as descriptive links in agenda added text.
This variable applies to the text added to the agenda when
`org-agenda-add-entry-text-maxlines' is larger than 0.
When this variable nil, the URL will (also) be shown."
@@ -198,6 +198,11 @@ you can \"misuse\" it to also add other text to the header. However,
:group 'org-export-html
:type 'string)
+(defcustom org-agenda-persistent-filter nil
+ "When set, keep filters from one agenda view to the next."
+ :group 'org-agenda
+ :type 'boolean)
+
(defgroup org-agenda-custom-commands nil
"Options concerning agenda views in Org-mode."
:tag "Org Agenda Custom Commands"
@@ -212,6 +217,7 @@ you can \"misuse\" it to also add other text to the header. However,
(const todo-state-up) (const todo-state-down)
(const effort-up) (const effort-down)
(const habit-up) (const habit-down)
+ (const alpha-up) (const alpha-down)
(const user-defined-up) (const user-defined-down))
"Sorting choices.")
@@ -258,6 +264,13 @@ you can \"misuse\" it to also add other text to the header. However,
(const :format "" quote)
(repeat
(string :tag "+tag or -tag"))))
+ (list :tag "Set daily/weekly entry types"
+ (const org-agenda-entry-types)
+ (set :greedy t :value (:deadline :scheduled :timestamp :sexp)
+ (const :deadline)
+ (const :scheduled)
+ (const :timestamp)
+ (const :sexp)))
(list :tag "Standard skipping condition"
:value (org-agenda-skip-function '(org-agenda-skip-entry-if))
(const org-agenda-skip-function)
@@ -273,6 +286,24 @@ you can \"misuse\" it to also add other text to the header. However,
:tag "Condition type"
(list :tag "Regexp matches" :inline t (const :format "" 'regexp) (regexp))
(list :tag "Regexp does not match" :inline t (const :format "" 'notregexp) (regexp))
+ (list :tag "TODO state is" :inline t
+ (const 'todo)
+ (choice
+ (const :tag "any not-done state" 'todo)
+ (const :tag "any done state" 'done)
+ (const :tag "any state" 'any)
+ (list :tag "Keyword list"
+ (const :format "" quote)
+ (repeat (string :tag "Keyword")))))
+ (list :tag "TODO state is not" :inline t
+ (const 'nottodo)
+ (choice
+ (const :tag "any not-done state" 'todo)
+ (const :tag "any done state" 'done)
+ (const :tag "any state" 'any)
+ (list :tag "Keyword list"
+ (const :format "" quote)
+ (repeat (string :tag "Keyword")))))
(const :tag "scheduled" 'scheduled)
(const :tag "not scheduled" 'notscheduled)
(const :tag "deadline" 'deadline)
@@ -499,20 +530,20 @@ this one will be used."
:group 'org-agenda)
(defvar org-agenda-archives-mode nil
- "Non-nil means, the agenda will include archived items.
+ "Non-nil means the agenda will include archived items.
If this is the symbol `trees', trees in the selected agenda scope
that are marked with the ARCHIVE tag will be included anyway. When this is
t, also all archive files associated with the current selection of agenda
files will be included.")
(defcustom org-agenda-skip-comment-trees t
- "Non-nil means, skip trees that start with the COMMENT keyword.
+ "Non-nil means skip trees that start with the COMMENT keyword.
When nil, these trees are also scanned by agenda commands."
:group 'org-agenda-skip
:type 'boolean)
(defcustom org-agenda-todo-list-sublevels t
- "Non-nil means, check also the sublevels of a TODO entry for TODO entries.
+ "Non-nil means check also the sublevels of a TODO entry for TODO entries.
When nil, the sublevels of a TODO entry are not checked, resulting in
potentially much shorter TODO lists."
:group 'org-agenda-skip
@@ -520,7 +551,7 @@ potentially much shorter TODO lists."
:type 'boolean)
(defcustom org-agenda-todo-ignore-with-date nil
- "Non-nil means, don't show entries with a date in the global todo list.
+ "Non-nil means don't show entries with a date in the global todo list.
You can use this if you prefer to mark mere appointments with a TODO keyword,
but don't want them to show up in the TODO list.
When this is set, it also covers deadlines and scheduled items, the settings
@@ -532,27 +563,73 @@ See also the variable `org-agenda-tags-todo-honor-ignore-options'."
:type 'boolean)
(defcustom org-agenda-todo-ignore-scheduled nil
- "Non-nil means, don't show scheduled entries in the global todo list.
-The idea behind this is that by scheduling it, you have already taken care
-of this item.
+ "Non-nil means, ignore some scheduled TODO items when making TODO list.
+This applies when creating the global todo list.
+Valid values are:
+
+past Don't show entries scheduled today or in the past.
+
+future Don't show entries scheduled in the future.
+ The idea behind this is that by scheduling it, you don't want to
+ think about it until the scheduled date.
+
+all Don't show any scheduled entries in the global todo list.
+ The idea behind this is that by scheduling it, you have already
+ \"taken care\" of this item.
+
+t Same as `all', for backward compatibility.
+
See also `org-agenda-todo-ignore-with-date'.
-See also the variable `org-agenda-tags-todo-honor-ignore-options'."
+See also the variable `org-agenda-tags-todo-honor-ignore-options' if you want
+to make his option also apply to the tags-todo list."
:group 'org-agenda-skip
:group 'org-agenda-todo-list
- :type 'boolean)
+ :type '(choice
+ (const :tag "Ignore future-scheduled todos" future)
+ (const :tag "Ignore past- or present-scheduled todos" past)
+ (const :tag "Ignore all scheduled todos" all)
+ (const :tag "Ignore all scheduled todos (compatibility)" t)
+ (const :tag "Show scheduled todos" nil)))
(defcustom org-agenda-todo-ignore-deadlines nil
- "Non-nil means, don't show near deadline entries in the global todo list.
-Near means closer than `org-deadline-warning-days' days.
-The idea behind this is that such items will appear in the agenda anyway.
+ "Non-nil means ignore some deadlined TODO items when making TODO list.
+There are different motivations for using different values, please think
+carefully when configuring this variable.
+
+This applies when creating the global todo list.
+Valid values are:
+
+near Don't show near deadline entries. A deadline is near when it is
+ closer than `org-deadline-warning-days' days. The idea behind this
+ is that such items will appear in the agenda anyway.
+
+far Don't show TODO entries where a deadline has been defined, but
+ the deadline is not near. This is useful if you don't want to
+ use the todo list to figure out what to do now.
+
+past Don't show entries with a deadline timestamp for today or in the past.
+
+future Don't show entries with a deadline timestamp in the future, not even
+ when they become `near' ones. Use it with caution.
+
+all Ignore all TODO entries that do have a deadline.
+
+t Same as `near', for backward compatibility.
+
See also `org-agenda-todo-ignore-with-date'.
-See also the variable `org-agenda-tags-todo-honor-ignore-options'."
+See also the variable `org-agenda-tags-todo-honor-ignore-options' if you want
+to make his option also apply to the tags-todo list."
:group 'org-agenda-skip
:group 'org-agenda-todo-list
- :type 'boolean)
+ :type '(choice
+ (const :tag "Ignore near deadlines" near)
+ (const :tag "Ignore near deadlines (compatibility)" t)
+ (const :tag "Ignore far deadlines" far)
+ (const :tag "Ignore all TODOs with a deadlines" all)
+ (const :tag "Show all TODOs, even if they have a deadline" nil)))
(defcustom org-agenda-tags-todo-honor-ignore-options nil
- "Non-nil means, honor todo-list ...ignore options also in tags-todo search.
+ "Non-nil means honor todo-list ...ignore options also in tags-todo search.
The variables
`org-agenda-todo-ignore-with-date',
`org-agenda-todo-ignore-scheduled'
@@ -603,6 +680,24 @@ deadlines are always turned off when the item is DONE."
:group 'org-agenda-daily/weekly
:type 'boolean)
+(defcustom org-agenda-skip-deadline-prewarning-if-scheduled nil
+ "Non-nil means skip deadline prewarning when entry is also scheduled.
+This will apply on all days where a prewarning for the deadline would
+be shown, but not at the day when the entry is actually due. On that day,
+the deadline will be shown anyway.
+This variable may be set to nil, t, or a number which will then give
+the number of days before the actual deadline when the prewarnings
+should resume.
+This can be used in a workflow where the first showing of the deadline will
+trigger you to schedule it, and then you don't want to be reminded of it
+because you will take care of it on the day when scheduled."
+ :group 'org-agenda-skip
+ :group 'org-agenda-daily/weekly
+ :type '(choice
+ (const :tag "Alwas show prewarning" nil)
+ (const :tag "Remove prewarning if entry is scheduled" t)
+ (integer :tag "Restart prewarning N days before deadline")))
+
(defcustom org-agenda-skip-additional-timestamps-same-entry t
"When nil, multiple same-day timestamps in entry make multiple agenda lines.
When non-nil, after the search for timestamps has matched once in an
@@ -617,7 +712,7 @@ entry, the rest of the entry will not be searched."
:type 'boolean)
(defcustom org-agenda-dim-blocked-tasks t
- "Non-nil means, dim blocked tasks in the agenda display.
+ "Non-nil means dim blocked tasks in the agenda display.
This causes some overhead during agenda construction, but if you
have turned on `org-enforce-todo-dependencies',
`org-enforce-todo-checkbox-dependencies', or any other blocking
@@ -639,7 +734,7 @@ will only be dimmed."
(const :tag "Make invisible" invisible)))
(defcustom org-timeline-show-empty-dates 3
- "Non-nil means, `org-timeline' also shows dates without an entry.
+ "Non-nil means `org-timeline' also shows dates without an entry.
When nil, only the days which actually have entries are shown.
When t, all days between the first and the last date are shown.
When an integer, show also empty dates, but if there is a gap of more than
@@ -655,25 +750,41 @@ N days, just insert a special line indicating the size of the gap."
:tag "Org Agenda Startup"
:group 'org-agenda)
+(defcustom org-agenda-menu-show-matcher t
+ "Non-nil menas show the match string in the agenda dispatcher menu.
+When nil, the matcher string is not shown, but is put into the help-echo
+property so than moving the mouse over the command shows it.
+Setting it to nil is good if matcher strings are very long and/or if
+you wnat to use two-column display (see `org-agenda-menu-two-column')."
+ :group 'org-agenda
+ :type 'boolean)
+
+(defcustom org-agenda-menu-two-column nil
+ "Non-nil means, use two columns to show custom commands in the dispatcher.
+If you use this, you probably want to set `org-agenda-menu-show-matcher'
+to nil."
+ :group 'org-agenda
+ :type 'boolean)
+
(defcustom org-finalize-agenda-hook nil
"Hook run just before displaying an agenda buffer."
:group 'org-agenda-startup
:type 'hook)
(defcustom org-agenda-mouse-1-follows-link nil
- "Non-nil means, mouse-1 on a link will follow the link in the agenda.
+ "Non-nil means mouse-1 on a link will follow the link in the agenda.
A longer mouse click will still set point. Does not work on XEmacs.
Needs to be set before org.el is loaded."
:group 'org-agenda-startup
:type 'boolean)
(defcustom org-agenda-start-with-follow-mode nil
- "The initial value of follow-mode in a newly created agenda window."
+ "The initial value of follow mode in a newly created agenda window."
:group 'org-agenda-startup
:type 'boolean)
(defcustom org-agenda-show-outline-path t
- "Non-il means, show outline path in echo area after line motion."
+ "Non-nil means show outline path in echo area after line motion."
:group 'org-agenda-startup
:type 'boolean)
@@ -707,7 +818,7 @@ have been removed when this is called, as will any matches for regular
expressions listed in `org-agenda-entry-text-exclude-regexps'.")
(defvar org-agenda-include-inactive-timestamps nil
- "Non-nil means, include inactive time stamps in agenda and timeline.")
+ "Non-nil means include inactive time stamps in agenda and timeline.")
(defgroup org-agenda-windows nil
"Options concerning the windows used by the Agenda in Org Mode."
@@ -740,7 +851,7 @@ It only matters if `org-agenda-window-setup' is `reorganize-frame'."
:type '(cons (number :tag "Minimum") (number :tag "Maximum")))
(defcustom org-agenda-restore-windows-after-quit nil
- "Non-nil means, restore window configuration open exiting agenda.
+ "Non-nil means restore window configuration open exiting agenda.
Before the window configuration is changed for displaying the agenda,
the current status is recorded. When the agenda is exited with
`q' or `x' and this option is set, the old state is restored. If
@@ -757,7 +868,7 @@ Custom commands can set this variable in the options section."
:type 'integer)
(defcustom org-agenda-start-on-weekday 1
- "Non-nil means, start the overview always on the specified weekday.
+ "Non-nil means start the overview always on the specified weekday.
0 denotes Sunday, 1 denotes Monday etc.
When nil, always start on the current day.
Custom commands can set this variable in the options section."
@@ -766,7 +877,7 @@ Custom commands can set this variable in the options section."
(integer :tag "Weekday No.")))
(defcustom org-agenda-show-all-dates t
- "Non-nil means, `org-agenda' shows every day in the selected range.
+ "Non-nil means `org-agenda' shows every day in the selected range.
When nil, only the days which actually have entries are shown."
:group 'org-agenda-daily/weekly
:type 'boolean)
@@ -805,6 +916,12 @@ This function makes sure that dates are aligned for easy reading."
(format "%-10s %2d %s %4d%s"
dayname day monthname year weekstring)))
+(defcustom org-agenda-time-leading-zero nil
+ "Non-nil means use leading zero for military times in agenda.
+For example, 9:30am would become 09:30 rather than 9:30."
+ :group 'org-agenda-daily/weekly
+ :type 'boolean)
+
(defcustom org-agenda-weekend-days '(6 0)
"Which days are weekend?
These days get the special face `org-agenda-date-weekend' in the agenda
@@ -825,6 +942,12 @@ Custom commands can set this variable in the options section."
:group 'org-agenda-daily/weekly
:type 'boolean)
+(defcustom org-agenda-include-deadlines t
+ "If non-nil, include entries within their deadline warning period.
+Custom commands can set this variable in the options section."
+ :group 'org-agenda-daily/weekly
+ :type 'boolean)
+
(defcustom org-agenda-include-all-todo nil
"Set means weekly/daily agenda will always contain all TODO entries.
The TODO entries will be listed at the top of the agenda, before
@@ -834,7 +957,7 @@ This option is deprecated, it is better to define a block agenda instead."
:type 'boolean)
(defcustom org-agenda-repeating-timestamp-show-all t
- "Non-nil means, show all occurrences of a repeating stamp in the agenda.
+ "Non-nil means show all occurrences of a repeating stamp in the agenda.
When nil, only one occurrence is shown, either today or the
nearest into the future."
:group 'org-agenda-daily/weekly
@@ -861,7 +984,7 @@ the agenda to display all available LOG items temporarily."
:type '(set :greedy t (const closed) (const clock) (const state)))
(defcustom org-agenda-log-mode-add-notes t
- "Non-nil means, add first line of notes to log entries in agenda views.
+ "Non-nil means add first line of notes to log entries in agenda views.
If a log item like a state change or a clock entry is associated with
notes, the first line of these notes will be added to the entry in the
agenda display."
@@ -891,14 +1014,40 @@ current display in the agenda."
:group 'org-agenda-daily/weekly
:type 'plist)
-(defcustom org-agenda-search-view-search-words-only nil
- "Non-nil means, the search string is interpreted as individual words
-The search then looks for each word separately in each entry and
-selects entries that have matches for all words.
-When nil, matching as loose words will only take place if the first
-word is preceded by + or -. If that is not the case, the search
-string will just be matched as a substring in the entry, but with
-each space character allowing for any whitespace, including newlines."
+(defcustom org-agenda-search-view-always-boolean nil
+ "Non-nil means the search string is interpreted as individual parts.
+
+The search string for search view can either be interpreted as a phrase,
+or as a list of snippets that define a boolean search for a number of
+strings.
+
+When this is non-nil, the string will be split on whitespace, and each
+snippet will be searched individually, and all must match in order to
+select an entry. A snippet is then a single string of non-white
+characters, or a string in double quotes, or a regexp in {} braces.
+If a snippet is preceded by \"-\", the snippet must *not* match.
+\"+\" is syntactic sugar for positive selection. Each snippet may
+be found as a full word or a partial word, but see the variable
+`org-agenda-search-view-force-full-words'.
+
+When this is nil, search will look for the entire search phrase as one,
+with each space character matching any amount of whitespace, including
+line breaks.
+
+Even when this is nil, you can still switch to Boolean search dynamically
+by preceding the first snippet with \"+\" or \"-\". If the first snippet
+is a regexp marked with braces like \"{abc}\", this will also switch to
+boolean search."
+ :group 'org-agenda-search-view
+ :type 'boolean)
+
+(if (fboundp 'defvaralias)
+ (defvaralias 'org-agenda-search-view-search-words-only
+ 'org-agenda-search-view-always-boolean))
+
+(defcustom org-agenda-search-view-force-full-words nil
+ "Non-nil means, search words must be matches as complete words.
+When nil, they may also match part of a word."
:group 'org-agenda-search-view
:type 'boolean)
@@ -908,7 +1057,7 @@ each space character allowing for any whitespace, including newlines."
:group 'org-agenda)
(defcustom org-agenda-search-headline-for-time t
- "Non-nil means, search headline for a time-of-day.
+ "Non-nil means search headline for a time-of-day.
If the headline contains a time-of-day in one format or another, it will
be used to sort the entry into the time sequence of items for a day.
Some people have time stamps in the headline that refer to the creation
@@ -919,7 +1068,7 @@ for a time."
:type 'boolean)
(defcustom org-agenda-use-time-grid t
- "Non-nil means, show a time grid in the agenda schedule.
+ "Non-nil means show a time grid in the agenda schedule.
A time grid is a set of lines for specific times (like every two hours between
8:00 and 20:00). The items scheduled for a day at specific times are
sorted in between these lines.
@@ -993,6 +1142,8 @@ user-defined-up Sort according to `org-agenda-cmp-user-defined', high last.
user-defined-down Sort according to `org-agenda-cmp-user-defined', high first.
habit-up Put entries that are habits first
habit-down Put entries that are habits last
+alpha-up Sort headlines alphabetically
+alpha-down Sort headlines alphabetically, reversed
The different possibilities will be tried in sequence, and testing stops
if one comparison returns a \"not-equal\". For example, the default
@@ -1036,7 +1187,7 @@ part of an agenda sorting strategy."
:type 'symbol)
(defcustom org-sort-agenda-notime-is-late t
- "Non-nil means, items without time are considered late.
+ "Non-nil means items without time are considered late.
This is only relevant for sorting. When t, items which have no explicit
time like 15:30 will be considered as 99:01, i.e. later than any items which
do have a time. When nil, the default time is before 0:00. You can use this
@@ -1046,7 +1197,7 @@ agenda entries."
:type 'boolean)
(defcustom org-sort-agenda-noeffort-is-high t
- "Non-nil means, items without effort estimate are sorted as high effort.
+ "Non-nil means items without effort estimate are sorted as high effort.
This also applies when filtering an agenda view with respect to the
< or > effort operator. Then, tasks with no effort defined will be treated
as tasks with high effort.
@@ -1151,7 +1302,7 @@ range, respectively."
(function))))
(defcustom org-agenda-scheduled-leaders '("Scheduled: " "Sched.%2dx: ")
- "Text preceeding scheduled items in the agenda view.
+ "Text preceding scheduled items in the agenda view.
This is a list with two strings. The first applies when the item is
scheduled on the current day. The second applies when it has been scheduled
previously, it may contain a %d indicating that this is the nth time that
@@ -1163,8 +1314,16 @@ that passed since this item was scheduled first."
(string :tag "Scheduled today ")
(string :tag "Scheduled previously")))
+(defcustom org-agenda-inactive-leader "["
+ "Text preceding item pulled into the agenda by inactive time stamps.
+These entries are added to the agenda when pressing \"[\"."
+ :group 'org-agenda-line-format
+ :type '(list
+ (string :tag "Scheduled today ")
+ (string :tag "Scheduled previously")))
+
(defcustom org-agenda-deadline-leaders '("Deadline: " "In %3d d.: ")
- "Text preceeding deadline items in the agenda view.
+ "Text preceding deadline items in the agenda view.
This is a list with two strings. The first applies when the item has its
deadline on the current day. The second applies when it is in the past or
in the future, it may contain %d to capture how many days away the deadline
@@ -1177,7 +1336,7 @@ is (was)."
(function))))
(defcustom org-agenda-remove-times-when-in-prefix t
- "Non-nil means, remove duplicate time specifications in agenda items.
+ "Non-nil means remove duplicate time specifications in agenda items.
When the format `org-agenda-prefix-format' contains a `%t' specifier, a
time-of-day specification in a headline or diary entry is extracted and
placed into the prefix. If this option is non-nil, the original specification
@@ -1185,7 +1344,7 @@ placed into the prefix. If this option is non-nil, the original specification
11:30-4pm) will be removed for agenda display. This makes the agenda less
cluttered.
The option can be t or nil. It may also be the symbol `beg', indicating
-that the time should only be removed what it is located at the beginning of
+that the time should only be removed when it is located at the beginning of
the headline/diary entry."
:group 'org-agenda-line-format
:type '(choice
@@ -1193,6 +1352,11 @@ the headline/diary entry."
(const :tag "Never" nil)
(const :tag "When at beginning of entry" beg)))
+(defcustom org-agenda-remove-timeranges-from-blocks nil
+ "Non-nil means remove time ranges specifications in agenda
+items that span on several days."
+ :group 'org-agenda-line-format
+ :type 'boolean)
(defcustom org-agenda-default-appointment-duration nil
"Default duration for appointments that only have a starting time.
@@ -1204,14 +1368,14 @@ When non-nil, this must be the number of minutes, e.g. 60 for one hour."
(const :tag "No default duration")))
(defcustom org-agenda-show-inherited-tags t
- "Non-nil means, show inherited tags in each agenda line."
+ "Non-nil means show inherited tags in each agenda line."
:group 'org-agenda-line-format
:type 'boolean)
(defcustom org-agenda-hide-tags-regexp nil
"Regular expression used to filter away specific tags in agenda views.
This means that these tags will be present, but not be shown in the agenda
-line. Secondayt filltering will still work on the hidden tags.
+line. Secondary filtering will still work on the hidden tags.
Nil means don't hide any tags."
:group 'org-agenda-line-format
:type '(choice
@@ -1219,7 +1383,7 @@ Nil means don't hide any tags."
(string :tag "Regexp ")))
(defcustom org-agenda-remove-tags nil
- "Non-nil means, remove the tags from the headline copy in the agenda.
+ "Non-nil means remove the tags from the headline copy in the agenda.
When this is the symbol `prefix', only remove tags when
`org-agenda-prefix-format' contains a `%T' specifier."
:group 'org-agenda-line-format
@@ -1244,16 +1408,18 @@ it means that the tags should be flushright to that column. For example,
(defvaralias 'org-agenda-align-tags-to-column 'org-agenda-tags-column))
(defcustom org-agenda-fontify-priorities 'cookies
- "Non-nil means, highlight low and high priorities in agenda.
+ "Non-nil means highlight low and high priorities in agenda.
When t, the highest priority entries are bold, lowest priority italic.
-However, settings in org-priority-faces will overrule these faces.
+However, settings in `org-priority-faces' will overrule these faces.
When this variable is the symbol `cookies', only fontify the
cookies, not the entire task.
This may also be an association list of priority faces, whose
keys are the character values of `org-highest-priority',
`org-default-priority', and `org-lowest-priority' (the default values
-are ?A, ?B, and ?C, respectively). The face may be a named face,
-or a list like `(:background \"Red\")'."
+are ?A, ?B, and ?C, respectively). The face may be a named face, a
+color as a string, or a list like `(:background \"Red\")'.
+If it is a color, the variable `org-faces-easy-properties'
+determines if it is a foreground or a background color."
:group 'org-agenda-line-format
:type '(choice
(const :tag "Never" nil)
@@ -1261,7 +1427,9 @@ or a list like `(:background \"Red\")'."
(const :tag "Cookies only" cookies)
(repeat :tag "Specify"
(list (character :tag "Priority" :value ?A)
- (sexp :tag "face")))))
+ (choice :tag "Face "
+ (string :tag "Color")
+ (sexp :tag "Face"))))))
(defgroup org-agenda-column-view nil
"Options concerning column view in the agenda."
@@ -1269,12 +1437,12 @@ or a list like `(:background \"Red\")'."
:group 'org-agenda)
(defcustom org-agenda-columns-show-summaries t
- "Non-nil means, show summaries for columns displayed in the agenda view."
+ "Non-nil means show summaries for columns displayed in the agenda view."
:group 'org-agenda-column-view
:type 'boolean)
(defcustom org-agenda-columns-remove-prefix-from-item t
- "Non-nil means, remove the prefix from a headline for agenda column view.
+ "Non-nil means remove the prefix from a headline for agenda column view.
The special ITEM field in the columns format contains the current line, with
all information shown in other columns (like the TODO state or a tag).
When this variable is non-nil, also the agenda prefix will be removed from
@@ -1284,7 +1452,7 @@ headline can be shown in the limited width of the field."
:type 'boolean)
(defcustom org-agenda-columns-compute-summary-properties t
- "Non-nil means, recompute all summary properties before column view.
+ "Non-nil means recompute all summary properties before column view.
When column view in the agenda is listing properties that have a summary
operator, it can go to all relevant buffers and recompute the summaries
there. This can mean overhead for the agenda column view, but is necessary
@@ -1295,7 +1463,7 @@ computations are current."
:type 'boolean)
(defcustom org-agenda-columns-add-appointments-to-effort-sum nil
- "Non-nil means, the duration of an appointment will add to day effort.
+ "Non-nil means the duration of an appointment will add to day effort.
The property to which appointment durations will be added is the one given
in the option `org-effort-property'. If an appointment does not have
an end time, `org-agenda-default-appointment-duration' will be used. If that
@@ -1309,7 +1477,10 @@ estimate."
The sole argument to the function, which is called once for each
possible tag, is a string giving the name of the tag. The
function should return either nil if the tag should be included
-as normal, or \"-<TAG>\" to exclude the tag."
+as normal, or \"-<TAG>\" to exclude the tag.
+Note that for the purpose of tag filtering, only the lower-case version of
+all tags will be considered, so that this function will only ever see
+the lower-case version of all tags."
:group 'org-agenda
:type 'function)
@@ -1317,6 +1488,18 @@ as normal, or \"-<TAG>\" to exclude the tag."
(require 'cl))
(require 'org)
+(defmacro org-agenda-with-point-at-orig-entry (string &rest body)
+ "Execute BODY with point at location given by `org-hd-marker' property.
+If STRING is non-nil, the text property will be fetched from position 0
+in that string. If STRING is nil, it will be fetched from the beginning
+of the current line."
+ `(let ((marker (get-text-property (if string 0 (point-at-bol))
+ 'org-hd-marker string)))
+ (with-current-buffer (marker-buffer marker)
+ (save-excursion
+ (goto-char marker)
+ ,@body))))
+
(defun org-add-agenda-custom-command (entry)
"Replace or add a command in `org-agenda-custom-commands'.
This is mostly for hacking and trying a new command - once the command
@@ -1342,7 +1525,7 @@ works you probably want to add it to `org-agenda-custom-commands' for good."
(defvar org-agenda-redo-command nil)
(defvar org-agenda-query-string nil)
(defvar org-agenda-mode-hook nil
- "Hook for org-agenda-mode, run after the mode is turned on.")
+ "Hook for `org-agenda-mode', run after the mode is turned on.")
(defvar org-agenda-type nil)
(defvar org-agenda-force-single-file nil)
(defvar org-agenda-bulk-marked-entries) ;; Defined further down in this file
@@ -1456,6 +1639,7 @@ The following commands are available:
(org-defkey org-agenda-mode-map "l" 'org-agenda-log-mode)
(org-defkey org-agenda-mode-map "v" 'org-agenda-view-mode-dispatch)
(org-defkey org-agenda-mode-map "D" 'org-agenda-toggle-diary)
+(org-defkey org-agenda-mode-map "!" 'org-agenda-toggle-deadlines)
(org-defkey org-agenda-mode-map "G" 'org-agenda-toggle-time-grid)
(org-defkey org-agenda-mode-map "r" 'org-agenda-redo)
(org-defkey org-agenda-mode-map "g" 'org-agenda-redo)
@@ -1496,7 +1680,7 @@ The following commands are available:
(org-defkey org-agenda-mode-map "\C-c\C-x\C-x" 'org-agenda-clock-cancel)
(org-defkey org-agenda-mode-map "X" 'org-agenda-clock-cancel)
(org-defkey org-agenda-mode-map "\C-c\C-x\C-j" 'org-clock-goto)
-(org-defkey org-agenda-mode-map "J" 'org-clock-goto)
+(org-defkey org-agenda-mode-map "J" 'org-agenda-clock-goto)
(org-defkey org-agenda-mode-map "+" 'org-agenda-priority-up)
(org-defkey org-agenda-mode-map "-" 'org-agenda-priority-down)
(org-defkey org-agenda-mode-map [(shift up)] 'org-agenda-priority-up)
@@ -1519,10 +1703,8 @@ The following commands are available:
(org-defkey org-agenda-mode-map "\C-c\C-x\C-mg" 'org-mobile-pull)
(org-defkey org-agenda-mode-map "\C-c\C-x\C-mp" 'org-mobile-push)
-(org-defkey org-agenda-mode-map
- (if (featurep 'xemacs) [(button2)] [(mouse-2)]) 'org-agenda-goto-mouse)
-(org-defkey org-agenda-mode-map
- (if (featurep 'xemacs) [(button3)] [(mouse-3)]) 'org-agenda-show-mouse)
+(org-defkey org-agenda-mode-map [mouse-2] 'org-agenda-goto-mouse)
+(org-defkey org-agenda-mode-map [mouse-3] 'org-agenda-show-mouse)
(when org-agenda-mouse-1-follows-link
(org-defkey org-agenda-mode-map [follow-link] 'mouse-face))
(easy-menu-define org-agenda-menu org-agenda-mode-map "Agenda menu"
@@ -1556,6 +1738,9 @@ The following commands are available:
["Include Diary" org-agenda-toggle-diary
:style toggle :selected org-agenda-include-diary
:active (org-agenda-check-type nil 'agenda)]
+ ["Include Deadlines" org-agenda-toggle-deadlines
+ :style toggle :selected org-agenda-include-deadlines
+ :active (org-agenda-check-type nil 'agenda)]
["Use Time Grid" org-agenda-toggle-time-grid
:style toggle :selected org-agenda-use-time-grid
:active (org-agenda-check-type nil 'agenda)]
@@ -1674,7 +1859,7 @@ The following commands are available:
;;; Agenda undo
(defvar org-agenda-allow-remote-undo t
- "Non-nil means, allow remote undo from the agenda buffer.")
+ "Non-nil means allow remote undo from the agenda buffer.")
(defvar org-agenda-undo-list nil
"List of undoable operations in the agenda since last refresh.")
(defvar org-agenda-undo-has-started-in nil
@@ -1820,7 +2005,6 @@ Pressing `<' twice means to restrict to the current subtree or region
(move-marker org-agenda-restrict-end
(progn (org-end-of-subtree t)))))))
- (require 'calendar) ; FIXME: can we avoid this for some commands?
;; For example the todo list should not need it (but does...)
(cond
((setq entry (assoc keys org-agenda-custom-commands))
@@ -1918,7 +2102,8 @@ Pressing `<' twice means to restrict to the current subtree or region
(custom org-agenda-custom-commands)
(selstring "")
restriction second-time
- c entry key type match prefixes rmheader header-end custom1 desc)
+ c entry key type match prefixes rmheader header-end custom1 desc
+ line lines left right n n1)
(save-window-excursion
(delete-other-windows)
(org-switch-to-buffer-other-window " *Agenda Commands*")
@@ -1956,56 +2141,91 @@ s Search for keywords C Configure custom agenda commands
(move-marker header-end (match-end 0)))
(goto-char header-end)
(delete-region (point) (point-max))
+
+ ;; Produce all the lines that describe custom commands and prefixes
+ (setq lines nil)
(while (setq entry (pop custom1))
(setq key (car entry) desc (nth 1 entry)
type (nth 2 entry)
match (nth 3 entry))
(if (> (length key) 1)
(add-to-list 'prefixes (string-to-char key))
- (insert
- (format
- "\n%-4s%-14s: %s"
- (org-add-props (copy-sequence key)
- '(face bold))
- (cond
- ((string-match "\\S-" desc) desc)
- ((eq type 'agenda) "Agenda for current week or day")
- ((eq type 'alltodo) "List of all TODO entries")
- ((eq type 'search) "Word search")
- ((eq type 'stuck) "List of stuck projects")
- ((eq type 'todo) "TODO keyword")
- ((eq type 'tags) "Tags query")
- ((eq type 'tags-todo) "Tags (TODO)")
- ((eq type 'tags-tree) "Tags tree")
- ((eq type 'todo-tree) "TODO kwd tree")
- ((eq type 'occur-tree) "Occur tree")
- ((functionp type) (if (symbolp type)
- (symbol-name type)
- "Lambda expression"))
- (t "???"))
- (cond
- ((stringp match)
- (setq match (copy-sequence match))
- (org-add-props match nil 'face 'org-warning))
- (match
- (format "set of %d commands" (length match)))
- (t ""))))))
+ (setq line
+ (format
+ "%-4s%-14s"
+ (org-add-props (copy-sequence key)
+ '(face bold))
+ (cond
+ ((string-match "\\S-" desc) desc)
+ ((eq type 'agenda) "Agenda for current week or day")
+ ((eq type 'alltodo) "List of all TODO entries")
+ ((eq type 'search) "Word search")
+ ((eq type 'stuck) "List of stuck projects")
+ ((eq type 'todo) "TODO keyword")
+ ((eq type 'tags) "Tags query")
+ ((eq type 'tags-todo) "Tags (TODO)")
+ ((eq type 'tags-tree) "Tags tree")
+ ((eq type 'todo-tree) "TODO kwd tree")
+ ((eq type 'occur-tree) "Occur tree")
+ ((functionp type) (if (symbolp type)
+ (symbol-name type)
+ "Lambda expression"))
+ (t "???"))))
+ (if org-agenda-menu-show-matcher
+ (setq line
+ (concat line ": "
+ (cond
+ ((stringp match)
+ (setq match (copy-sequence match))
+ (org-add-props match nil 'face 'org-warning))
+ (match
+ (format "set of %d commands" (length match)))
+ (t ""))))
+ (if (org-string-nw-p match)
+ (add-text-properties
+ 0 (length line) (list 'help-echo
+ (concat "Matcher: "match)) line)))
+ (push line lines)))
+ (setq lines (nreverse lines))
(when prefixes
(mapc (lambda (x)
- (insert
- (format "\n%s %s"
+ (push
+ (format "%s %s"
(org-add-props (char-to-string x)
- nil 'face 'bold)
- (or (cdr (assoc (concat selstring (char-to-string x))
+ nil 'face 'bold)
+ (or (cdr (assoc (concat selstring
+ (char-to-string x))
prefix-descriptions))
- "Prefix key"))))
+ "Prefix key"))
+ lines))
prefixes))
+
+ ;; Check if we should display in two columns
+ (if org-agenda-menu-two-column
+ (progn
+ (setq n (length lines)
+ n1 (+ (/ n 2) (mod n 2))
+ right (nthcdr n1 lines)
+ left (copy-sequence lines))
+ (setcdr (nthcdr (1- n1) left) nil))
+ (setq left lines right nil))
+ (while left
+ (insert "\n" (pop left))
+ (when right
+ (if (< (current-column) 40)
+ (move-to-column 40 t)
+ (insert " "))
+ (insert (pop right))))
+
+ ;; Make the window the right size
(goto-char (point-min))
(if second-time
(if (not (pos-visible-in-window-p (point-max)))
(org-fit-window-to-buffer))
(setq second-time t)
(org-fit-window-to-buffer))
+
+ ;; Ask for selection
(message "Press key for agenda command%s:"
(if (or restrict-ok org-agenda-overriding-restriction)
(if org-agenda-overriding-restriction
@@ -2109,7 +2329,7 @@ s Search for keywords C Configure custom agenda commands
If CMD-KEY is a string of length 1, it is used as a key in
`org-agenda-custom-commands' and triggers this command. If it is a
longer string it is used as a tags/todo match string.
-Paramters are alternating variable names and values that will be bound
+Parameters are alternating variable names and values that will be bound
before running the agenda command."
(let (pars)
(while parameters
@@ -2137,7 +2357,7 @@ before running the agenda command."
If CMD-KEY is a string of length 1, it is used as a key in
`org-agenda-custom-commands' and triggers this command. If it is a
longer string it is used as a tags/todo match string.
-Paramters are alternating variable names and values that will be bound
+Parameters are alternating variable names and values that will be bound
before running the agenda command.
The output gives a line for each selected agenda item. Each
@@ -2186,14 +2406,14 @@ agenda-day The day in the agenda where this is listed"
(princ
(org-encode-for-stdout
(mapconcat 'org-agenda-export-csv-mapper
- '(org-category txt type todo tags date time-of-day extra
+ '(org-category txt type todo tags date time extra
priority-letter priority agenda-day)
",")))
(princ "\n"))))))
(defun org-fix-agenda-info (props)
- "Make sure all properties on an agenda item have a canonical form,
-so the export commands can easily use it."
+ "Make sure all properties on an agenda item have a canonical form.
+This ensures the export commands can easily use it."
(let (tmp re)
(when (setq tmp (plist-get props 'tags))
(setq props (plist-put props 'tags (mapconcat 'identity tmp ":"))))
@@ -2295,9 +2515,6 @@ higher priority settings."
(interactive "FWrite agenda to file: \nP")
(if (not (file-writable-p file))
(error "Cannot write agenda to file %s" file))
- (cond
- ((string-match "\\.html?\\'" file) (require 'htmlize))
- ((string-match "\\.ps\\'" file) (require 'ps-print)))
(org-let (if nosettings nil org-agenda-exporter-settings)
'(save-excursion
(save-window-excursion
@@ -2305,6 +2522,8 @@ higher priority settings."
(let ((bs (copy-sequence (buffer-string))) beg)
(org-agenda-unmark-filtered-text)
(with-temp-buffer
+ (rename-buffer "Agenda View" t)
+ (set-buffer-modified-p nil)
(insert bs)
(org-agenda-remove-marked-text 'org-filtered)
(while (setq beg (text-property-any (point-min) (point-max)
@@ -2317,6 +2536,7 @@ higher priority settings."
((org-bound-and-true-p org-mobile-creating-agendas)
(org-mobile-write-agenda-for-mobile file))
((string-match "\\.html?\\'" file)
+ (require 'htmlize)
(set-buffer (htmlize-buffer (current-buffer)))
(when (and org-agenda-export-html-style
@@ -2331,18 +2551,17 @@ higher priority settings."
(message "HTML written to %s" file))
((string-match "\\.ps\\'" file)
(require 'ps-print)
- (flet ((ps-get-buffer-name () "Agenda View"))
- (ps-print-buffer-with-faces file))
+ (ps-print-buffer-with-faces file)
(message "Postscript written to %s" file))
((string-match "\\.pdf\\'" file)
(require 'ps-print)
- (flet ((ps-get-buffer-name () "Agenda View"))
- (ps-print-buffer-with-faces
- (concat (file-name-sans-extension file) ".ps")))
+ (ps-print-buffer-with-faces
+ (concat (file-name-sans-extension file) ".ps"))
(call-process "ps2pdf" nil nil nil
(expand-file-name
(concat (file-name-sans-extension file) ".ps"))
(expand-file-name file))
+ (delete-file (concat (file-name-sans-extension file) ".ps"))
(message "PDF written to %s" file))
((string-match "\\.ics\\'" file)
(require 'org-icalendar)
@@ -2371,9 +2590,9 @@ higher priority settings."
(let ((inhibit-read-only t))
(mapc
(lambda (o)
- (when (equal (org-overlay-buffer o) (current-buffer))
+ (when (equal (overlay-buffer o) (current-buffer))
(put-text-property
- (org-overlay-start o) (org-overlay-end o)
+ (overlay-start o) (overlay-end o)
'org-filtered t)))
org-agenda-filter-overlays)))
@@ -2408,7 +2627,9 @@ Drawers will be excluded, also the line with scheduling/deadline info."
(setq txt (org-agenda-get-some-entry-text
m org-agenda-add-entry-text-maxlines " > "))
(end-of-line 1)
- (if (string-match "\\S-" txt) (insert "\n" txt)))))))
+ (if (string-match "\\S-" txt)
+ (insert "\n" txt)
+ (or (eobp) (forward-char 1))))))))
(defun org-agenda-get-some-entry-text (marker n-lines &optional indent
&rest keep)
@@ -2559,16 +2780,20 @@ removed from the entry content. Currently only `planning' is allowed here."
(defvar org-agenda-filter nil)
(defvar org-agenda-filter-preset nil
"A preset of the tags filter used for secondary agenda filtering.
-This must be a list of strings, each string must be a single tag preceeded
+This must be a list of strings, each string must be a single tag preceded
by \"+\" or \"-\".
This variable should not be set directly, but agenda custom commands can
-bind it in the options section.")
+bind it in the options section. The preset filter is a global property of
+the entire agenda view. In a block agenda, it will not work reliably to
+define a filter for one of the individual blocks. You need to set it in
+the global options and expect it to be applied to the entire view.")
(defun org-prepare-agenda (&optional name)
(setq org-todo-keywords-for-agenda nil)
(setq org-done-keywords-for-agenda nil)
(setq org-drawers-for-agenda nil)
- (setq org-agenda-filter nil)
+ (unless org-agenda-persistent-filter
+ (setq org-agenda-filter nil))
(put 'org-agenda-filter :preset-filter org-agenda-filter-preset)
(if org-agenda-multi
(progn
@@ -2604,7 +2829,11 @@ bind it in the options section.")
(switch-to-buffer-other-frame abuf))
((equal org-agenda-window-setup 'reorganize-frame)
(delete-other-windows)
- (org-switch-to-buffer-other-window abuf))))
+ (org-switch-to-buffer-other-window abuf)))
+ ;; additional test in case agenda is invoked from within agenda
+ ;; buffer via elisp link
+ (unless (equal (current-buffer) abuf)
+ (switch-to-buffer abuf)))
(setq buffer-read-only nil)
(let ((inhibit-read-only t)) (erase-buffer))
(org-agenda-mode)
@@ -2643,16 +2872,16 @@ bind it in the options section.")
(org-habit-insert-consistency-graphs))
(run-hooks 'org-finalize-agenda-hook)
(setq org-agenda-type (org-get-at-bol 'org-agenda-type))
- (when (get 'org-agenda-filter :preset-filter)
+ (when (or org-agenda-filter (get 'org-agenda-filter :preset-filter))
(org-agenda-filter-apply org-agenda-filter))
)))
(defun org-agenda-mark-clocking-task ()
"Mark the current clock entry in the agenda if it is present."
(mapc (lambda (o)
- (if (eq (org-overlay-get o 'type) 'org-agenda-clocking)
- (org-delete-overlay o)))
- (org-overlays-in (point-min) (point-max)))
+ (if (eq (overlay-get o 'type) 'org-agenda-clocking)
+ (delete-overlay o)))
+ (overlays-in (point-min) (point-max)))
(when (marker-buffer org-clock-hd-marker)
(save-excursion
(goto-char (point-min))
@@ -2661,18 +2890,18 @@ bind it in the options section.")
(goto-char s)
(when (equal (org-get-at-bol 'org-hd-marker)
org-clock-hd-marker)
- (setq ov (org-make-overlay (point-at-bol) (1+ (point-at-eol))))
- (org-overlay-put ov 'type 'org-agenda-clocking)
- (org-overlay-put ov 'face 'org-agenda-clocking)
- (org-overlay-put ov 'help-echo
+ (setq ov (make-overlay (point-at-bol) (1+ (point-at-eol))))
+ (overlay-put ov 'type 'org-agenda-clocking)
+ (overlay-put ov 'face 'org-agenda-clocking)
+ (overlay-put ov 'help-echo
"The clock is running in this item")))))))
(defun org-agenda-fontify-priorities ()
"Make highest priority lines bold, and lowest italic."
(interactive)
- (mapc (lambda (o) (if (eq (org-overlay-get o 'org-type) 'org-priority)
- (org-delete-overlay o)))
- (org-overlays-in (point-min) (point-max)))
+ (mapc (lambda (o) (if (eq (overlay-get o 'org-type) 'org-priority)
+ (delete-overlay o)))
+ (overlays-in (point-min) (point-max)))
(save-excursion
(let ((inhibit-read-only t)
b e p ov h l)
@@ -2687,21 +2916,25 @@ bind it in the options section.")
e (if (eq org-agenda-fontify-priorities 'cookies)
(match-end 0)
(point-at-eol))
- ov (org-make-overlay b e))
- (org-overlay-put
+ ov (make-overlay b e))
+ (overlay-put
ov 'face
- (cond ((cdr (assoc p org-priority-faces)))
+ (cond ((org-face-from-face-or-color
+ 'priority nil
+ (cdr (assoc p org-priority-faces))))
((and (listp org-agenda-fontify-priorities)
- (cdr (assoc p org-agenda-fontify-priorities))))
+ (org-face-from-face-or-color
+ 'priority nil
+ (cdr (assoc p org-agenda-fontify-priorities)))))
((equal p l) 'italic)
((equal p h) 'bold)))
- (org-overlay-put ov 'org-type 'org-priority)))))
+ (overlay-put ov 'org-type 'org-priority)))))
(defun org-agenda-dim-blocked-tasks ()
"Dim currently blocked TODO's in the agenda display."
- (mapc (lambda (o) (if (eq (org-overlay-get o 'org-type) 'org-blocked-todo)
- (org-delete-overlay o)))
- (org-overlays-in (point-min) (point-max)))
+ (mapc (lambda (o) (if (eq (overlay-get o 'org-type) 'org-blocked-todo)
+ (delete-overlay o)))
+ (overlays-in (point-min) (point-max)))
(save-excursion
(let ((inhibit-read-only t)
(org-depend-tag-blocked nil)
@@ -2730,11 +2963,11 @@ bind it in the options section.")
(max (point-min) (1- (point-at-bol)))
(point-at-bol))
e (point-at-eol)
- ov (org-make-overlay b e))
+ ov (make-overlay b e))
(if invis1
- (org-overlay-put ov 'invisible t)
- (org-overlay-put ov 'face 'org-agenda-dimmed-todo-face))
- (org-overlay-put ov 'org-type 'org-blocked-todo)))))))
+ (overlay-put ov 'invisible t)
+ (overlay-put ov 'face 'org-agenda-dimmed-todo-face))
+ (overlay-put ov 'org-type 'org-blocked-todo)))))))
(defvar org-agenda-skip-function nil
"Function to be called at each match during agenda construction.
@@ -2745,7 +2978,7 @@ This may also be a Lisp form, it will be evaluated.
Never set this variable using `setq' or so, because then it will apply
to all future agenda commands. Instead, bind it with `let' to scope
it dynamically into the agenda-constructing command. A good way to set
-it is through options in org-agenda-custom-commands.")
+it is through options in `org-agenda-custom-commands'.")
(defun org-agenda-skip ()
"Throw to `:skip' in places that should be skipped.
@@ -2807,10 +3040,10 @@ no longer in use."
(org-agenda-get-some-entry-text
m org-agenda-entry-text-maxlines " > "))))
(when (string-match "\\S-" txt)
- (setq o (org-make-overlay (point-at-bol) (point-at-eol)))
- (org-overlay-put o 'evaporate t)
- (org-overlay-put o 'org-overlay-type 'agenda-entry-content)
- (org-overlay-put o 'after-string txt))))
+ (setq o (make-overlay (point-at-bol) (point-at-eol)))
+ (overlay-put o 'evaporate t)
+ (overlay-put o 'org-overlay-type 'agenda-entry-content)
+ (overlay-put o 'after-string txt))))
(defun org-agenda-entry-text-show ()
"Add entry context for all agenda lines."
@@ -2827,10 +3060,10 @@ no longer in use."
"Remove any shown entry context."
(delq nil
(mapcar (lambda (o)
- (if (eq (org-overlay-get o 'org-overlay-type)
+ (if (eq (overlay-get o 'org-overlay-type)
'agenda-entry-content)
- (progn (org-delete-overlay o) t)))
- (org-overlays-in (point-min) (point-max)))))
+ (progn (delete-overlay o) t)))
+ (overlays-in (point-min) (point-max)))))
;;; Agenda timeline
@@ -2844,13 +3077,13 @@ under the current date.
If the buffer contains an active region, only check the region for
dates."
(interactive "P")
- (require 'calendar)
(org-compile-prefix-format 'timeline)
(org-set-sorting-strategy 'timeline)
(let* ((dopast t)
(dotodo include-all)
(doclosed org-agenda-show-log)
- (entry buffer-file-name)
+ (entry (buffer-file-name (or (buffer-base-buffer (current-buffer))
+ (current-buffer))))
(date (calendar-current-date))
(beg (if (org-region-active-p) (region-beginning) (point-min)))
(end (if (org-region-active-p) (region-end) (point-max)))
@@ -2872,8 +3105,7 @@ dates."
(setq day-numbers (delq nil (mapcar (lambda(x)
(if (>= x today) x nil))
day-numbers))))
- (org-prepare-agenda (concat "Timeline "
- (file-name-nondirectory buffer-file-name)))
+ (org-prepare-agenda (concat "Timeline " (file-name-nondirectory entry)))
(if doclosed (push :closed args))
(push :timestamp args)
(push :deadline args)
@@ -2976,11 +3208,44 @@ When EMPTY is non-nil, also include days without any entries."
(defvar org-agenda-start-day nil ; dynamically scoped parameter
"Custom commands can set this variable in the options section.")
(defvar org-agenda-last-arguments nil
- "The arguments of the previous call to org-agenda")
+ "The arguments of the previous call to `org-agenda'.")
(defvar org-starting-day nil) ; local variable in the agenda buffer
(defvar org-agenda-span nil) ; local variable in the agenda buffer
(defvar org-include-all-loc nil) ; local variable
+(defvar org-agenda-entry-types '(:deadline :scheduled :timestamp :sexp)
+ "List of types searched for when creating the daily/weekly agenda.
+This variable is a list of symbols that controls the types of
+items that appear in the daily/weekly agenda. Allowed symbols in this
+list are are
+
+ :timestamp List items containing a date stamp or date range matching
+ the selected date. This includes sexp entries in
+ angular brackets.
+
+ :sexp List entries resulting from plain diary-like sexps.
+
+ :deadline List deadline due on that date. When the date is today,
+ also list any deadlines past due, or due within
+ `org-deadline-warning-days'. `:deadline' must appear before
+ `:scheduled' if the setting of
+ `org-agenda-skip-scheduled-if-deadline-is-shown' is to have
+ any effect.
+
+ :scheduled List all items which are scheduled for the given date.
+ The diary for *today* also contains items which were
+ scheduled earlier and are not yet marked DONE.
+
+By default, all four types are turned on.
+
+Never set this variable globally using `setq', because then it
+will apply to all future agenda commands. Instead, bind it with
+`let' to scope it dynamically into the the agenda-constructing
+command. A good way to set it is through options in
+`org-agenda-custom-commands'. For a more flexible (though
+somewhat less efficient) way of determining what is included in
+the daily/weekly agenda, see `org-agenda-skip-function'.")
+
;;;###autoload
(defun org-agenda-list (&optional include-all start-day ndays)
"Produce a daily/weekly view from all files in variable `org-agenda-files'.
@@ -3013,7 +3278,6 @@ given in `org-agenda-start-on-weekday'."
(setq org-agenda-last-arguments (list include-all start-day ndays))
(org-compile-prefix-format 'agenda)
(org-set-sorting-strategy 'agenda)
- (require 'calendar)
(let* ((org-agenda-start-on-weekday
(if (or (equal ndays 7) (and (null ndays) (equal 7 org-agenda-ndays)))
org-agenda-start-on-weekday nil))
@@ -3104,18 +3368,22 @@ given in `org-agenda-start-on-weekday'."
(while (setq file (pop files))
(catch 'nextfile
(org-check-agenda-file file)
- (cond
- ((eq org-agenda-show-log 'only)
- (setq rtn (org-agenda-get-day-entries
- file date :closed)))
- (org-agenda-show-log
- (setq rtn (org-agenda-get-day-entries
- file date
- :deadline :scheduled :timestamp :sexp :closed)))
- (t
- (setq rtn (org-agenda-get-day-entries
- file date
- :deadline :scheduled :sexp :timestamp))))
+ (let ((org-agenda-entry-types org-agenda-entry-types))
+ (unless org-agenda-include-deadlines
+ (setq org-agenda-entry-types
+ (delq :deadline org-agenda-entry-types)))
+ (cond
+ ((eq org-agenda-show-log 'only)
+ (setq rtn (org-agenda-get-day-entries
+ file date :closed)))
+ (org-agenda-show-log
+ (setq rtn (apply 'org-agenda-get-day-entries
+ file date
+ (append '(:closed) org-agenda-entry-types))))
+ (t
+ (setq rtn (apply 'org-agenda-get-day-entries
+ file date
+ org-agenda-entry-types)))))
(setq rtnall (append rtnall rtn))))
(if org-agenda-include-diary
(let ((org-agenda-search-headline-for-time t))
@@ -3195,11 +3463,11 @@ that when \"+Ameli\" is searched as a work, it will also match \"Ameli's\"")
(modify-syntax-entry ?` "." org-search-syntax-table))
org-search-syntax-table)
+(defvar org-agenda-last-search-view-search-was-boolean nil)
+
;;;###autoload
(defun org-search-view (&optional todo-only string edit-at)
- "Show all entries that contain words or regular expressions.
-If the first character of the search string is an asterisks,
-search only the headlines.
+ "Show all entries that contain a phrase or words or regular expressions.
With optional prefix argument TODO-ONLY, only consider entries that are
TODO entries. The argument STRING can be used to pass a default search
@@ -3207,28 +3475,37 @@ string into this function. If EDIT-AT is non-nil, it means that the
user should get a chance to edit this string, with cursor at position
EDIT-AT.
-The search string is broken into \"words\" by splitting at whitespace.
-Depending on the variable `org-agenda-search-view-search-words-only'
-and on whether the first character in the search string is \"+\" or \"-\",
-The string is then interpreted either as a substring with variable amounts
-of whitespace, or as a list or individual words that should be matched.
-
-The default is a substring match, where each space in the search string
-can expand to an arbitrary amount of whitespace, including newlines.
-
-If matching individual words, these words are then interpreted as a
-boolean expression with logical AND. Words prefixed with a minus must
-not occur in the entry. Words without a prefix or prefixed with a plus
-must occur in the entry. Matching is case-insensitive and the words
-are enclosed by word delimiters.
-
-Words enclosed by curly braces are interpreted as regular expressions
-that must or must not match in the entry.
-
-If the search string starts with an asterisk, search only in headlines.
-If (possibly after the leading star) the search string starts with an
-exclamation mark, this also means to look at TODO entries only, an effect
-that can also be achieved with a prefix argument.
+The search string can be viewed either as a phrase that should be found as
+is, or it can be broken into a number of snippets, each of which must match
+in a Boolean way to select an entry. The default depends on the variable
+`org-agenda-search-view-always-boolean'.
+Even if this is turned off (the default) you can always switch to
+Boolean search dynamically by preceding the first word with \"+\" or \"-\".
+
+The default is a direct search of the whole phrase, where each space in
+the search string can expand to an arbitrary amount of whitespace,
+including newlines.
+
+If using a Boolean search, the search string is split on whitespace and
+each snippet is searched separately, with logical AND to select an entry.
+Words prefixed with a minus must *not* occur in the entry. Words without
+a prefix or prefixed with a plus must occur in the entry. Matching is
+case-insensitive. Words are enclosed by word delimiters (i.e. they must
+match whole words, not parts of a word) if
+`org-agenda-search-view-force-full-words' is set (default is nil).
+
+Boolean search snippets enclosed by curly braces are interpreted as
+regular expressions that must or (when preceded with \"-\") must not
+match in the entry. Snippets enclosed into double quotes will be taken
+as a whole, to include whitespace.
+
+- If the search string starts with an asterisk, search only in headlines.
+- If (possibly after the leading star) the search string starts with an
+ exclamation mark, this also means to look at TODO entries only, an effect
+ that can also be achieved with a prefix argument.
+- If (possibly after star and exclamation mark) the search string starts
+ with a colon, this will mean that the (non-regexp) snippets of the
+ Boolean search must match as full words.
This command searches the agenda files, and in addition the files listed
in `org-agenda-text-search-extra-files'."
@@ -3243,17 +3520,22 @@ in `org-agenda-text-search-extra-files'."
'org-complex-heading-regexp org-complex-heading-regexp
'mouse-face 'highlight
'help-echo (format "mouse-2 or RET jump to location")))
+ (full-words org-agenda-search-view-force-full-words)
+ (org-agenda-text-search-extra-files org-agenda-text-search-extra-files)
regexp rtn rtnall files file pos
- marker category tags c neg re as-words
+ marker category tags c neg re boolean
ee txt beg end words regexps+ regexps- hdl-only buffer beg1 str)
(unless (and (not edit-at)
(stringp string)
(string-match "\\S-" string))
- (setq string (read-string "[+-]Word/{Regexp} ...: "
- (cond
- ((integerp edit-at) (cons string edit-at))
- (edit-at string))
- 'org-agenda-search-history)))
+ (setq string (read-string
+ (if org-agenda-search-view-always-boolean
+ "[+-]Word/{Regexp} ...: "
+ "Phrase, or [+-]Word/{Regexp} ...: ")
+ (cond
+ ((integerp edit-at) (cons string edit-at))
+ (edit-at string))
+ 'org-agenda-search-history)))
(org-set-local 'org-todo-only todo-only)
(setq org-agenda-redo-command
(list 'org-search-view (if todo-only t nil) string
@@ -3267,21 +3549,55 @@ in `org-agenda-text-search-extra-files'."
(when (equal (string-to-char words) ?!)
(setq todo-only t
words (substring words 1)))
- (if (or org-agenda-search-view-search-words-only
- (member (string-to-char string) '(?- ?+)))
- (setq as-words t))
+ (when (equal (string-to-char words) ?:)
+ (setq full-words t
+ words (substring words 1)))
+ (if (or org-agenda-search-view-always-boolean
+ (member (string-to-char words) '(?- ?+ ?\{)))
+ (setq boolean t))
(setq words (org-split-string words))
- (if as-words
+ (let (www w)
+ (while (setq w (pop words))
+ (while (and (string-match "\\\\\\'" w) words)
+ (setq w (concat (substring w 0 -1) " " (pop words))))
+ (push w www))
+ (setq words (nreverse www) www nil)
+ (while (setq w (pop words))
+ (when (and (string-match "\\`[-+]?{" w)
+ (not (string-match "}\\'" w)))
+ (while (and words (not (string-match "}\\'" (car words))))
+ (setq w (concat w " " (pop words))))
+ (setq w (concat w " " (pop words))))
+ (push w www))
+ (setq words (nreverse www)))
+ (setq org-agenda-last-search-view-search-was-boolean boolean)
+ (when boolean
+ (let (wds w)
+ (while (setq w (pop words))
+ (if (or (equal (substring w 0 1) "\"")
+ (and (> (length w) 1)
+ (member (substring w 0 1) '("+" "-"))
+ (equal (substring w 1 2) "\"")))
+ (while (and words (not (equal (substring w -1) "\"")))
+ (setq w (concat w " " (pop words)))))
+ (and (string-match "\\`\\([-+]?\\)\"" w)
+ (setq w (replace-match "\\1" nil nil w)))
+ (and (equal (substring w -1) "\"") (setq w (substring w 0 -1)))
+ (push w wds))
+ (setq words (nreverse wds))))
+ (if boolean
(mapc (lambda (w)
(setq c (string-to-char w))
(if (equal c ?-)
(setq neg t w (substring w 1))
(if (equal c ?+)
(setq neg nil w (substring w 1))
- (setq neg nil)))
+ (setq neg nil)))
(if (string-match "\\`{.*}\\'" w)
(setq re (substring w 1 -1))
- (setq re (concat "\\<" (regexp-quote (downcase w)) "\\>")))
+ (if full-words
+ (setq re (concat "\\<" (regexp-quote (downcase w)) "\\>"))
+ (setq re (regexp-quote (downcase w)))))
(if neg (push re regexps-) (push re regexps+)))
words)
(push (mapconcat (lambda (w) (regexp-quote w)) words "\\s-+")
@@ -3397,16 +3713,16 @@ in `org-agenda-text-search-extra-files'."
;;;###autoload
(defun org-todo-list (arg)
- "Show all TODO entries from all agenda file in a single list.
+ "Show all (not done) TODO entries from all agenda file in a single list.
The prefix arg can be used to select a specific TODO keyword and limit
the list to these. When using \\[universal-argument], you will be prompted
for a keyword. A numeric prefix directly selects the Nth keyword in
`org-todo-keywords-1'."
(interactive "P")
- (require 'calendar)
(org-compile-prefix-format 'todo)
(org-set-sorting-strategy 'todo)
(org-prepare-agenda "TODO")
+ (if (and (stringp arg) (not (string-match "\\S-" arg))) (setq arg nil))
(let* ((today (time-to-days (current-time)))
(date (calendar-gregorian-from-absolute today))
(kwds org-todo-keywords-for-agenda)
@@ -3475,11 +3791,12 @@ The prefix arg TODO-ONLY limits the search to TODO entries."
(org-compile-prefix-format 'tags)
(org-set-sorting-strategy 'tags)
(let* ((org-tags-match-list-sublevels
-;?????? (if todo-only t org-tags-match-list-sublevels))
org-tags-match-list-sublevels)
(completion-ignore-case t)
rtn rtnall files file pos matcher
buffer)
+ (when (and (stringp match) (not (string-match "\\S-" match)))
+ (setq match nil))
(setq matcher (org-make-tags-matcher match)
match (car matcher) matcher (cdr matcher))
(org-prepare-agenda (concat "TAGS " match))
@@ -3548,7 +3865,7 @@ This variable should not be set directly, but custom commands can bind it
in the options section.")
(defun org-agenda-skip-entry-when-regexp-matches ()
- "Checks if the current entry contains match for `org-agenda-skip-regexp'.
+ "Check if the current entry contains match for `org-agenda-skip-regexp'.
If yes, it returns the end position of this entry, causing agenda commands
to skip the entry but continuing the search in the subtree. This is a
function that can be put into `org-agenda-skip-function' for the duration
@@ -3560,7 +3877,7 @@ of a command."
(and skip end)))
(defun org-agenda-skip-subtree-when-regexp-matches ()
- "Checks if the current subtree contains match for `org-agenda-skip-regexp'.
+ "Check if the current subtree contains match for `org-agenda-skip-regexp'.
If yes, it returns the end position of this tree, causing agenda commands
to skip this subtree. This is a function that can be put into
`org-agenda-skip-function' for the duration of a command."
@@ -3571,7 +3888,7 @@ to skip this subtree. This is a function that can be put into
(and skip end)))
(defun org-agenda-skip-entry-when-regexp-matches-in-subtree ()
- "Checks if the current subtree contains match for `org-agenda-skip-regexp'.
+ "Check if the current subtree contains match for `org-agenda-skip-regexp'.
If yes, it returns the end position of the current entry (NOT the tree),
causing agenda commands to skip the entry but continuing the search in
the subtree. This is a function that can be put into
@@ -3610,10 +3927,26 @@ timestamp Check if there is a timestamp (also deadline or scheduled)
nottimestamp Check if there is no timestamp (also deadline or scheduled)
regexp Check if regexp matches
notregexp Check if regexp does not match.
+todo Check if TODO keyword matches
+nottodo Check if TODO keyword does not match
The regexp is taken from the conditions list, it must come right after
the `regexp' or `notregexp' element.
+`todo' and `nottodo' accept as an argument a list of todo
+keywords, which may include \"*\" to match any todo keyword.
+
+ (org-agenda-skip-entry-if 'todo '(\"TODO\" \"WAITING\"))
+
+would skip all entries with \"TODO\" or \"WAITING\" keywords.
+
+Instead of a list a keyword class may be given
+
+ (org-agenda-skip-entry-if 'nottodo 'done)
+
+would skip entries that haven't been marked with any of \"DONE\"
+keywords. Possible classes are: `todo', `done', `any'.
+
If any of these conditions is met, this function returns the end point of
the entity, causing the search to continue from there. This is a function
that can be put into `org-agenda-skip-function' for the duration of a command."
@@ -3643,16 +3976,51 @@ that can be put into `org-agenda-skip-function' for the duration of a command."
(re-search-forward (nth 1 m) end t))
(and (setq m (memq 'notregexp conditions))
(stringp (nth 1 m))
- (not (re-search-forward (nth 1 m) end t))))
+ (not (re-search-forward (nth 1 m) end t)))
+ (and (or
+ (setq m (memq 'todo conditions))
+ (setq m (memq 'nottodo conditions)))
+ (org-agenda-skip-if-todo m end)))
end)))
+(defun org-agenda-skip-if-todo (args end)
+ "Helper function for `org-agenda-skip-if', do not use it directly.
+ARGS is a list with first element either `todo' or `nottodo'.
+The remainder is either a list of TODO keywords, or a state symbol
+`todo' or `done' or `any'."
+ (let ((kw (car args))
+ (arg (cadr args))
+ todo-wds todo-re)
+ (setq todo-wds
+ (org-uniquify
+ (cond
+ ((listp arg) ;; list of keywords
+ (if (member "*" arg)
+ (mapcar 'substring-no-properties org-todo-keywords-1)
+ arg))
+ ((symbolp arg) ;; keyword class name
+ (cond
+ ((eq arg 'todo)
+ (org-delete-all org-done-keywords
+ (mapcar 'substring-no-properties
+ org-todo-keywords-1)))
+ ((eq arg 'done) org-done-keywords)
+ ((eq arg 'any)
+ (mapcar 'substring-no-properties org-todo-keywords-1)))))))
+ (setq todo-re
+ (concat "^\\*+[ \t]+\\<\\("
+ (mapconcat 'identity todo-wds "\\|")
+ "\\)\\>"))
+ (if (eq kw 'todo)
+ (re-search-forward todo-re end t)
+ (not (re-search-forward todo-re end t)))))
+
;;;###autoload
(defun org-agenda-list-stuck-projects (&rest ignore)
"Create agenda view for projects that are stuck.
Stuck projects are project that have no next actions. For the definitions
of what a project is and how to check if it stuck, customize the variable
-`org-stuck-projects'.
-MATCH is being ignored."
+`org-stuck-projects'."
(interactive)
(let* ((org-agenda-skip-function
'org-agenda-skip-entry-when-regexp-matches-in-subtree)
@@ -3674,11 +4042,11 @@ MATCH is being ignored."
"\\)\\>"))
(tags (nth 2 org-stuck-projects))
(tags-re (if (member "*" tags)
- (org-re "^\\*+ .*:[[:alnum:]_@]+:[ \t]*$")
+ (org-re "^\\*+ .*:[[:alnum:]_@#%]+:[ \t]*$")
(if tags
(concat "^\\*+ .*:\\("
(mapconcat 'identity tags "\\|")
- (org-re "\\):[[:alnum:]_@:]*[ \t]*$")))))
+ (org-re "\\):[[:alnum:]_@#%:]*[ \t]*$")))))
(gen-re (nth 3 org-stuck-projects))
(re-list
(delq nil
@@ -3706,7 +4074,6 @@ MATCH is being ignored."
"Get the (Emacs Calendar) diary entries for DATE."
(require 'diary-lib)
(let* ((diary-fancy-buffer "*temporary-fancy-diary-buffer*")
- (fancy-diary-buffer diary-fancy-buffer)
(diary-display-hook '(fancy-diary-display))
(diary-display-function 'fancy-diary-display)
(pop-up-frames nil)
@@ -3744,7 +4111,7 @@ MATCH is being ignored."
(setq x (org-format-agenda-item "" x "Diary" nil 'time))
;; Extend the text properties to the beginning of the line
(org-add-props x (text-properties-at (1- (length x)) x)
- 'type "diary" 'date date))
+ 'type "diary" 'date date 'face 'org-agenda-diary))
entries)))))
(defvar org-agenda-cleanup-fancy-diary-hook nil
@@ -3811,33 +4178,16 @@ Needed to avoid empty dates which mess up holiday display."
(apply 'diary-add-to-list args)
(apply 'add-to-diary-list args)))
+(defvar org-diary-last-run-time nil)
+
;;;###autoload
(defun org-diary (&rest args)
"Return diary information from org-files.
This function can be used in a \"sexp\" diary entry in the Emacs calendar.
It accesses org files and extracts information from those files to be
listed in the diary. The function accepts arguments specifying what
-items should be listed. The following arguments are allowed:
-
- :timestamp List the headlines of items containing a date stamp or
- date range matching the selected date. Deadlines will
- also be listed, on the expiration day.
-
- :sexp List entries resulting from diary-like sexps.
-
- :deadline List any deadlines past due, or due within
- `org-deadline-warning-days'. The listing occurs only
- in the diary for *today*, not at any other date. If
- an entry is marked DONE, it is no longer listed.
-
- :scheduled List all items which are scheduled for the given date.
- The diary for *today* also contains items which were
- scheduled earlier and are not yet marked DONE.
-
- :todo List all TODO items from the org-file. This may be a
- long list - so this is not turned on by default.
- Like deadlines, these entries only show up in the
- diary for *today*, not at any other date.
+items should be listed. For a list of arguments allowed here, see the
+variable `org-agenda-entry-types'.
The call in the diary file should look like this:
@@ -3867,8 +4217,14 @@ function from a program - use `org-agenda-get-day-entries' instead."
(let* ((files (if (and entry (stringp entry) (string-match "\\S-" entry))
(list entry)
(org-agenda-files t)))
+ (time (org-float-time))
file rtn results)
- (org-prepare-agenda-buffers files)
+ (when (or (not org-diary-last-run-time)
+ (> (- time
+ org-diary-last-run-time)
+ 3))
+ (org-prepare-agenda-buffers files))
+ (setq org-diary-last-run-time time)
;; If this is called during org-agenda, don't return any entries to
;; the calendar. Org Agenda will list these entries itself.
(if org-disable-agenda-to-diary (setq files nil))
@@ -3986,8 +4342,9 @@ the documentation of `org-diary'."
(nreverse ee)))
;;;###autoload
-(defun org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item (&optional end)
- "Do we have a reason to ignore this todo entry because it has a time stamp?"
+(defun org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item
+ (&optional end)
+ "Do we have a reason to ignore this TODO entry because it has a time stamp?"
(when (or org-agenda-todo-ignore-with-date
org-agenda-todo-ignore-scheduled
org-agenda-todo-ignore-deadlines)
@@ -3996,10 +4353,24 @@ the documentation of `org-diary'."
(or (and org-agenda-todo-ignore-with-date
(re-search-forward org-ts-regexp end t))
(and org-agenda-todo-ignore-scheduled
- (re-search-forward org-scheduled-time-regexp end t))
+ (re-search-forward org-scheduled-time-regexp end t)
+ (cond
+ ((eq org-agenda-todo-ignore-scheduled 'future)
+ (> (org-days-to-time (match-string 1)) 0))
+ ((eq org-agenda-todo-ignore-scheduled 'past)
+ (<= (org-days-to-time (match-string 1)) 0))
+ (t)))
(and org-agenda-todo-ignore-deadlines
(re-search-forward org-deadline-time-regexp end t)
- (org-deadline-close (match-string 1)))))))
+ (cond
+ ((memq org-agenda-todo-ignore-deadlines '(t all)) t)
+ ((eq org-agenda-todo-ignore-deadlines 'far)
+ (not (org-deadline-close (match-string 1))))
+ ((eq org-agenda-todo-ignore-deadlines 'future)
+ (> (org-days-to-time (match-string 1)) 0))
+ ((eq org-agenda-todo-ignore-deadlines 'past)
+ (<= (org-days-to-time (match-string 1)) 0))
+ (t (org-deadline-close (match-string 1)))))))))
(defconst org-agenda-no-heading-message
"No heading for this item in buffer or region.")
@@ -4064,7 +4435,7 @@ the documentation of `org-diary'."
clockp (and org-agenda-include-inactive-timestamps
(or (string-match org-clock-string tmp)
(string-match "]-+\\'" tmp)))
- todo-state (org-get-todo-state)
+ todo-state (ignore-errors (org-get-todo-state))
donep (member todo-state org-done-keywords))
(if (or scheduledp deadlinep closedp clockp
(and donep org-agenda-skip-timestamp-if-done))
@@ -4083,7 +4454,7 @@ the documentation of `org-diary'."
(looking-at "\\*+[ \t]+\\([^\r\n]+\\)")
(setq head (match-string 1))
(setq txt (org-format-agenda-item
- (if inactivep "[" nil)
+ (if inactivep org-agenda-inactive-leader nil)
head category tags timestr nil
remove-re)))
(setq priority (org-get-priority txt))
@@ -4128,19 +4499,46 @@ the documentation of `org-diary'."
category (org-get-category beg)
todo-state (org-get-todo-state))
- (if (string-match "\\S-" result)
- (setq txt result)
- (setq txt "SEXP entry returned empty string"))
-
- (setq txt (org-format-agenda-item
- "" txt category tags 'time))
- (org-add-props txt props 'org-marker marker)
- (org-add-props txt nil
- 'org-category category 'date date 'todo-state todo-state
- 'type "sexp")
- (push txt ee))))
+ (dolist (r (if (stringp result)
+ (list result)
+ result)) ;; we expect a list here
+ (if (string-match "\\S-" r)
+ (setq txt r)
+ (setq txt "SEXP entry returned empty string"))
+
+ (setq txt (org-format-agenda-item
+ "" txt category tags 'time))
+ (org-add-props txt props 'org-marker marker)
+ (org-add-props txt nil
+ 'org-category category 'date date 'todo-state todo-state
+ 'type "sexp")
+ (push txt ee)))))
(nreverse ee)))
+(defun org-diary-class (m1 d1 y1 m2 d2 y2 dayname &rest skip-weeks)
+ "Entry applies if date is between dates on DAYNAME, but skips SKIP-WEEKS.
+The order of the first 2 times 3 arguments depends on the variable
+`calendar-date-style' or, if that is not defined, on `european-calendar-style'.
+So for American calendars, give this as MONTH DAY YEAR, for European as
+DAY MONTH YEAR, and for ISO as YEAR MONTH DAY.
+DAYNAME is a number between 0 (Sunday) and 6 (Saturday). SKIP-WEEKS
+is any number of ISO weeks in the block period for which the item should
+be skipped."
+ (let* ((date1 (calendar-absolute-from-gregorian
+ (org-order-calendar-date-args m1 d1 y1)))
+ (date2 (calendar-absolute-from-gregorian
+ (org-order-calendar-date-args m2 d2 y2)))
+ (d (calendar-absolute-from-gregorian date)))
+ (and
+ (<= date1 d)
+ (<= d date2)
+ (= (calendar-day-of-week date) dayname)
+ (or (not skip-weeks)
+ (progn
+ (require 'cal-iso)
+ (not (member (car (calendar-iso-from-absolute d)) skip-weeks))))
+ entry)))
+
(defalias 'org-get-closed 'org-agenda-get-progress)
(defun org-agenda-get-progress ()
"Return the logged TODO entries for agenda display."
@@ -4198,15 +4596,15 @@ the documentation of `org-diary'."
(setq clocked (match-string 2 rest)))
(setq clocked "-")))
(save-excursion
+ (setq extra nil)
(cond
- ((not org-agenda-log-mode-add-notes) (setq extra nil))
+ ((not org-agenda-log-mode-add-notes))
(statep
(and (looking-at ".*\n[ \t]*\\([^-\n \t].*?\\)[ \t]*$")
(setq extra (match-string 1))))
(clockp
(and (looking-at ".*\n[ \t]*-[ \t]+\\([^-\n \t].*?\\)[ \t]*$")
- (setq extra (match-string 1))))
- (t (setq extra nil)))
+ (setq extra (match-string 1)))))
(if (not (re-search-backward "^\\*+ " nil t))
(setq txt org-agenda-no-heading-message)
(goto-char (match-beginning 0))
@@ -4248,11 +4646,22 @@ the documentation of `org-diary'."
(todayp (org-agenda-todayp date)) ; DATE bound by calendar
(d1 (calendar-absolute-from-gregorian date)) ; DATE bound by calendar
d2 diff dfrac wdays pos pos1 category tags
+ suppress-prewarning
ee txt head face s todo-state upcomingp donep timestr)
(goto-char (point-min))
(while (re-search-forward regexp nil t)
+ (setq suppress-prewarning nil)
(catch :skip
(org-agenda-skip)
+ (when (and org-agenda-skip-deadline-prewarning-if-scheduled
+ (save-match-data
+ (string-match org-scheduled-time-regexp
+ (buffer-substring (point-at-bol)
+ (point-at-eol)))))
+ (setq suppress-prewarning
+ (if (integerp org-agenda-skip-deadline-prewarning-if-scheduled)
+ org-agenda-skip-deadline-prewarning-if-scheduled
+ 0)))
(setq s (match-string 1)
txt nil
pos (1- (match-beginning 1))
@@ -4260,7 +4669,10 @@ the documentation of `org-diary'."
(match-string 1) d1 'past
org-agenda-repeating-timestamp-show-all)
diff (- d2 d1)
- wdays (org-get-wdays s)
+ wdays (if suppress-prewarning
+ (let ((org-deadline-warning-days suppress-prewarning))
+ (org-get-wdays s))
+ (org-get-wdays s))
dfrac (/ (* 1.0 (- wdays diff)) (max wdays 1))
upcomingp (and todayp (> diff 0)))
;; When to show a deadline in the calendar:
@@ -4472,13 +4884,20 @@ FRACTION is what fraction of the head-warning time has passed."
(setq tags (org-get-tags-at))
(looking-at "\\*+[ \t]+\\([^\r\n]+\\)")
(setq head (match-string 1))
- (setq txt (org-format-agenda-item
- (format
- (nth (if (= d1 d2) 0 1)
- org-agenda-timerange-leaders)
- (1+ (- d0 d1)) (1+ (- d2 d1)))
- head category tags
- (if (= d0 d1) timestr))))
+ (let ((remove-re
+ (if org-agenda-remove-timeranges-from-blocks
+ (concat
+ "<" (regexp-quote s1) ".*?>"
+ "--"
+ "<" (regexp-quote s2) ".*?>")
+ nil)))
+ (setq txt (org-format-agenda-item
+ (format
+ (nth (if (= d1 d2) 0 1)
+ org-agenda-timerange-leaders)
+ (1+ (- d0 d1)) (1+ (- d2 d1)))
+ head category tags
+ timestr nil remove-re))))
(org-add-props txt props
'org-marker marker 'org-hd-marker hdmarker
'type "block" 'date date
@@ -4589,7 +5008,7 @@ Any match of REMOVE-RE will be removed from TXT."
(setq h (/ m 60) m (- m (* h 60)))
(setq s2 (format "%02d:%02d" h m))))
- (when (string-match (org-re "\\([ \t]+\\)\\(:[[:alnum:]_@:]+:\\)[ \t]*$")
+ (when (string-match (org-re "\\([ \t]+\\)\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$")
txt)
;; Tags are in the string
(if (or (eq org-agenda-remove-tags t)
@@ -4663,18 +5082,18 @@ Any match of REMOVE-RE will be removed from TXT."
The modified list may contain inherited tags, and tags matched by
`org-agenda-hide-tags-regexp' will be removed."
(when (or add-inherited hide-re)
- (if (string-match (org-re "\\([ \t]+\\)\\(:[[:alnum:]_@:]+:\\)[ \t]*$") txt)
+ (if (string-match (org-re "\\([ \t]+\\)\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$") txt)
(setq txt (substring txt 0 (match-beginning 0))))
+ (setq tags
+ (delq nil
+ (mapcar (lambda (tg)
+ (if (or (and hide-re (string-match hide-re tg))
+ (and (not add-inherited)
+ (get-text-property 0 'inherited tg)))
+ nil
+ tg))
+ tags)))
(when tags
- (setq tags
- (delq nil
- (mapcar (lambda (tg)
- (if (or (and hide-re (string-match hide-re tg))
- (and (not add-inherited)
- (get-text-property 0 'inherited tg)))
- nil
- tg))
- tags)))
(let ((have-i (get-text-property 0 'inherited (car tags)))
i)
(setq txt (concat txt " :"
@@ -4719,13 +5138,13 @@ The modified list may contain inherited tags, and tags matched by
(throw 'exit list))
(while (setq time (pop gridtimes))
(unless (and remove (member time have))
- (setq time (int-to-string time))
+ (setq time (replace-regexp-in-string " " "0" (format "%04s" time)))
(push (org-format-agenda-item
nil string "" nil
(concat (substring time 0 -2) ":" (substring time -2)))
new)
(put-text-property
- 1 (length (car new)) 'face 'org-time-grid (car new))))
+ 2 (length (car new)) 'face 'org-time-grid (car new))))
(if (member 'time-up org-agenda-sorting-strategy-selected)
(append new list)
(append list new)))))
@@ -4805,20 +5224,45 @@ HH:MM."
(mod h1 24) h1))
(t0 (+ (* 100 h2) m))
(t1 (concat (if (>= h1 24) "+" " ")
+ (if (and org-agenda-time-leading-zero
+ (< t0 1000)) "0" "")
(if (< t0 100) "0" "")
(if (< t0 10) "0" "")
(int-to-string t0))))
(if string (concat (substring t1 -4 -2) ":" (substring t1 -2)) t0)))))
+(defvar org-agenda-before-sorting-filter-function nil
+ "Function to be applied to agenda items prior to sorting.
+Prior to sorting also means just before they are inserted into the agenda.
+
+To aid sorting, you may revisit the original entries and add more text
+properties which will later be used by the sorting functions.
+
+The function should take a string argument, an agenda line.
+It has access to the text properties in that line, which contain among
+other things, the property `org-hd-marker' that points to the entry
+where the line comes from. Note that not all lines going into the agenda
+have this property, only most.
+
+The function should return the modified string. It is probably best
+to ONLY change text properties.
+
+You can also use this function as a filter, by returning nil for lines
+you don't want to have in the agenda at all. For this application, you
+could bind the variable in the options section of a custom command.")
+
(defun org-finalize-agenda-entries (list &optional nosort)
"Sort and concatenate the agenda items."
(setq list (mapcar 'org-agenda-highlight-todo list))
(if nosort
list
+ (when org-agenda-before-sorting-filter-function
+ (setq list (delq nil (mapcar org-agenda-before-sorting-filter-function list))))
(mapconcat 'identity (sort list 'org-entries-lessp) "\n")))
(defun org-agenda-highlight-todo (x)
(let ((org-done-keywords org-done-keywords-for-agenda)
+ (case-fold-search nil)
re pl)
(if (eq x 'line)
(save-excursion
@@ -4841,11 +5285,12 @@ HH:MM."
(or (match-end 1) (match-end 0)) (match-end 0)
(list 'face (org-get-todo-face (match-string 2 x)))
x)
- (setq x (concat (substring x 0 (match-end 1))
- (format org-agenda-todo-keyword-format
- (match-string 2 x))
- (org-add-props " " (text-properties-at 0 x))
- (substring x (match-end 3)))))
+ (when (match-end 1)
+ (setq x (concat (substring x 0 (match-end 1))
+ (format org-agenda-todo-keyword-format
+ (match-string 2 x))
+ (org-add-props " " (text-properties-at 0 x))
+ (substring x (match-end 3))))))
x)))
(defsubst org-cmp-priority (a b)
@@ -4896,6 +5341,28 @@ HH:MM."
((< lb la) +1)
(t nil))))
+(defsubst org-cmp-alpha (a b)
+ "Compare the headlines, alphabetically."
+ (let* ((pla (get-text-property 0 'prefix-length a))
+ (plb (get-text-property 0 'prefix-length b))
+ (ta (and pla (substring a pla)))
+ (tb (and plb (substring b plb))))
+ (when pla
+ (if (string-match (concat "\\`[ \t]*" (or (get-text-property 0 'org-todo-regexp a) "")
+ "\\([ \t]*\\[[a-zA-Z0-9]\\]\\)? *") ta)
+ (setq ta (substring ta (match-end 0))))
+ (setq ta (downcase ta)))
+ (when plb
+ (if (string-match (concat "\\`[ \t]*" (or (get-text-property 0 'org-todo-regexp b) "")
+ "\\([ \t]*\\[[a-zA-Z0-9]\\]\\)? *") tb)
+ (setq tb (substring tb (match-end 0))))
+ (setq tb (downcase tb)))
+ (cond ((not ta) +1)
+ ((not tb) -1)
+ ((string-lessp ta tb) -1)
+ ((string-lessp tb ta) +1)
+ (t nil))))
+
(defsubst org-cmp-tag (a b)
"Compare the string values of the first tags of A and B."
(let ((ta (car (last (get-text-property 1 'tags a))))
@@ -4923,27 +5390,42 @@ HH:MM."
((and (not ha) hb) +1)
(t nil))))
+(defsubst org-em (x y list) (or (memq x list) (memq y list)))
+
(defun org-entries-lessp (a b)
"Predicate for sorting agenda entries."
;; The following variables will be used when the form is evaluated.
;; So even though the compiler complains, keep them.
- (let* ((time-up (org-cmp-time a b))
- (time-down (if time-up (- time-up) nil))
- (priority-up (org-cmp-priority a b))
- (priority-down (if priority-up (- priority-up) nil))
- (effort-up (org-cmp-effort a b))
- (effort-down (if effort-up (- effort-up) nil))
- (category-up (org-cmp-category a b))
- (category-down (if category-up (- category-up) nil))
- (category-keep (if category-up +1 nil))
- (tag-up (org-cmp-tag a b))
- (tag-down (if tag-up (- tag-up) nil))
- (todo-state-up (org-cmp-todo-state a b))
+ (let* ((ss org-agenda-sorting-strategy-selected)
+ (time-up (and (org-em 'time-up 'time-down ss)
+ (org-cmp-time a b)))
+ (time-down (if time-up (- time-up) nil))
+ (priority-up (and (org-em 'priority-up 'priority-down ss)
+ (org-cmp-priority a b)))
+ (priority-down (if priority-up (- priority-up) nil))
+ (effort-up (and (org-em 'effort-up 'effort-down ss)
+ (org-cmp-effort a b)))
+ (effort-down (if effort-up (- effort-up) nil))
+ (category-up (and (or (org-em 'category-up 'category-down ss)
+ (memq 'category-keep ss))
+ (org-cmp-category a b)))
+ (category-down (if category-up (- category-up) nil))
+ (category-keep (if category-up +1 nil))
+ (tag-up (and (org-em 'tag-up 'tag-down ss)
+ (org-cmp-tag a b)))
+ (tag-down (if tag-up (- tag-up) nil))
+ (todo-state-up (and (org-em 'todo-state-up 'todo-state-down ss)
+ (org-cmp-todo-state a b)))
(todo-state-down (if todo-state-up (- todo-state-up) nil))
- (habit-up (org-cmp-habit-p a b))
- (habit-down (if habit-up (- habit-up) nil))
+ (habit-up (and (org-em 'habit-up 'habit-down ss)
+ (org-cmp-habit-p a b)))
+ (habit-down (if habit-up (- habit-up) nil))
+ (alpha-up (and (org-em 'alpha-up 'alpha-down ss)
+ (org-cmp-alpha a b)))
+ (alpha-down (if alpha-up (- alpha-up) nil))
+ (need-user-cmp (org-em 'user-defined-up 'user-defined-down ss))
user-defined-up user-defined-down)
- (if (and org-agenda-cmp-user-defined
+ (if (and need-user-cmp org-agenda-cmp-user-defined
(functionp org-agenda-cmp-user-defined))
(setq user-defined-up
(funcall org-agenda-cmp-user-defined a b)
@@ -4954,12 +5436,12 @@ HH:MM."
;;; Agenda restriction lock
-(defvar org-agenda-restriction-lock-overlay (org-make-overlay 1 1)
+(defvar org-agenda-restriction-lock-overlay (make-overlay 1 1)
"Overlay to mark the headline to which agenda commands are restricted.")
-(org-overlay-put org-agenda-restriction-lock-overlay
- 'face 'org-agenda-restriction-lock)
-(org-overlay-put org-agenda-restriction-lock-overlay
- 'help-echo "Agendas are currently limited to this subtree.")
+(overlay-put org-agenda-restriction-lock-overlay
+ 'face 'org-agenda-restriction-lock)
+(overlay-put org-agenda-restriction-lock-overlay
+ 'help-echo "Agendas are currently limited to this subtree.")
(org-detach-overlay org-agenda-restriction-lock-overlay)
(defun org-agenda-set-restriction-lock (&optional type)
@@ -4982,7 +5464,7 @@ in the file. Otherwise, restriction will be to the current subtree."
(put 'org-agenda-files 'org-restrict
(list (buffer-file-name (buffer-base-buffer))))
(org-back-to-heading t)
- (org-move-overlay org-agenda-restriction-lock-overlay (point) (point-at-eol))
+ (move-overlay org-agenda-restriction-lock-overlay (point) (point-at-eol))
(move-marker org-agenda-restrict-begin (point))
(move-marker org-agenda-restrict-end
(save-excursion (org-end-of-subtree t)))
@@ -5071,8 +5553,9 @@ Org-mode buffers visited directly by the user will not be touched."
(org-agenda-quit))
(defun org-agenda-execute (arg)
- "Execute another agenda command, keeping same window.\\<global-map>
-So this is just a shortcut for `\\[org-agenda]', available in the agenda."
+ "Execute another agenda command, keeping same window.
+So this is just a shortcut for \\<global-map>`\\[org-agenda]', available
+in the agenda."
(interactive "P")
(let ((org-agenda-window-setup 'current-window))
(org-agenda arg)))
@@ -5127,7 +5610,7 @@ to switch to narrowing."
(effort-prompt "")
(inhibit-read-only t)
(current org-agenda-filter)
- char a n tag)
+ a n tag)
(unless char
(message
"%s by tag [%s ], [TAB], %s[/]:off, [+-]:narrow, [>=<?]:effort: "
@@ -5168,9 +5651,8 @@ to switch to narrowing."
(org-agenda-filter-by-tag-show-all)
(when org-agenda-auto-exclude-function
(setq org-agenda-filter '())
- (dolist (tag org-tag-alist-for-agenda)
- (let ((modifier (funcall org-agenda-auto-exclude-function
- (car tag))))
+ (dolist (tag (org-agenda-get-represented-tags))
+ (let ((modifier (funcall org-agenda-auto-exclude-function tag)))
(if modifier
(push modifier org-agenda-filter))))
(if (not (null org-agenda-filter))
@@ -5197,6 +5679,17 @@ to switch to narrowing."
(org-agenda-filter-apply org-agenda-filter))
(t (error "Invalid tag selection character %c" char)))))
+(defun org-agenda-get-represented-tags ()
+ "Get a list of all tags currently represented in the agenda."
+ (let (p tags)
+ (save-excursion
+ (goto-char (point-min))
+ (while (setq p (next-single-property-change (point) 'tags))
+ (goto-char p)
+ (mapc (lambda (x) (add-to-list 'tags x))
+ (get-text-property (point) 'tags))))
+ tags))
+
(defun org-agenda-filter-by-tag-refine (strip &optional char)
"Refine the current filter. See `org-agenda-filter-by-tag."
(interactive "P")
@@ -5219,7 +5712,7 @@ to switch to narrowing."
(defun org-agenda-filter-effort-form (e)
"Return the form to compare the effort of the current line with what E says.
-E looks line \"+<2:25\"."
+E looks like \"+<2:25\"."
(let (op)
(setq e (substring e 1))
(setq op (string-to-char e) e (substring e 1))
@@ -5254,29 +5747,31 @@ If the line does not have an effort defined, return nil."
(if (not (eval org-agenda-filter-form))
(org-agenda-filter-by-tag-hide-line))
(beginning-of-line 2))
- (beginning-of-line 2))))))
+ (beginning-of-line 2))))
+ (if (get-char-property (point) 'invisible)
+ (org-agenda-previous-line))))
(defun org-agenda-filter-by-tag-hide-line ()
(let (ov)
- (setq ov (org-make-overlay (max (point-min) (1- (point-at-bol)))
+ (setq ov (make-overlay (max (point-min) (1- (point-at-bol)))
(point-at-eol)))
- (org-overlay-put ov 'invisible t)
- (org-overlay-put ov 'type 'tags-filter)
+ (overlay-put ov 'invisible t)
+ (overlay-put ov 'type 'tags-filter)
(push ov org-agenda-filter-overlays)))
(defun org-agenda-fix-tags-filter-overlays-at (&optional pos)
(setq pos (or pos (point)))
(save-excursion
- (dolist (ov (org-overlays-at pos))
- (when (and (org-overlay-get ov 'invisible)
- (eq (org-overlay-get ov 'type) 'tags-filter))
+ (dolist (ov (overlays-at pos))
+ (when (and (overlay-get ov 'invisible)
+ (eq (overlay-get ov 'type) 'tags-filter))
(goto-char pos)
- (if (< (org-overlay-start ov) (point-at-eol))
- (org-move-overlay ov (point-at-eol)
- (org-overlay-end ov)))))))
+ (if (< (overlay-start ov) (point-at-eol))
+ (move-overlay ov (point-at-eol)
+ (overlay-end ov)))))))
(defun org-agenda-filter-by-tag-show-all ()
- (mapc 'org-delete-overlay org-agenda-filter-overlays)
+ (mapc 'delete-overlay org-agenda-filter-overlays)
(setq org-agenda-filter-overlays nil)
(setq org-agenda-filter nil)
(setq org-agenda-filter-form nil)
@@ -5284,22 +5779,22 @@ If the line does not have an effort defined, return nil."
(defun org-agenda-manipulate-query-add ()
"Manipulate the query by adding a search term with positive selection.
-Positive selection means, the term must be matched for selection of an entry."
+Positive selection means the term must be matched for selection of an entry."
(interactive)
(org-agenda-manipulate-query ?\[))
(defun org-agenda-manipulate-query-subtract ()
"Manipulate the query by adding a search term with negative selection.
-Negative selection means, term must not be matched for selection of an entry."
+Negative selection means term must not be matched for selection of an entry."
(interactive)
(org-agenda-manipulate-query ?\]))
(defun org-agenda-manipulate-query-add-re ()
"Manipulate the query by adding a search regexp with positive selection.
-Positive selection means, the regexp must match for selection of an entry."
+Positive selection means the regexp must match for selection of an entry."
(interactive)
(org-agenda-manipulate-query ?\{))
(defun org-agenda-manipulate-query-subtract-re ()
"Manipulate the query by adding a search regexp with negative selection.
-Negative selection means, regexp must not match for selection of an entry."
+Negative selection means regexp must not match for selection of an entry."
(interactive)
(org-agenda-manipulate-query ?\}))
(defun org-agenda-manipulate-query (char)
@@ -5311,8 +5806,10 @@ Negative selection means, regexp must not match for selection of an entry."
((eq org-agenda-type 'search)
(org-add-to-string
'org-agenda-query-string
- (cdr (assoc char '((?\[ . " +") (?\] . " -")
- (?\{ . " +{}") (?\} . " -{}")))))
+ (if org-agenda-last-search-view-search-was-boolean
+ (cdr (assoc char '((?\[ . " +") (?\] . " -")
+ (?\{ . " +{}") (?\} . " -{}"))))
+ " "))
(setq org-agenda-redo-command
(list 'org-search-view
org-todo-only
@@ -5329,7 +5826,9 @@ Negative selection means, regexp must not match for selection of an entry."
(defun org-agenda-goto-date (date)
"Jump to DATE in agenda."
- (interactive (list (org-read-date)))
+ (interactive (list (let ((org-read-date-prefer-future
+ (eval org-agenda-jump-prefer-future)))
+ (org-read-date))))
(org-agenda-list nil date))
(defun org-agenda-goto-today ()
@@ -5397,8 +5896,9 @@ With prefix ARG, go backward that many times the current span."
(defun org-agenda-view-mode-dispatch ()
"Call one of the view mode commands."
(interactive)
- (message "View: [d]ay [w]eek [m]onth [y]ear [l]og [L]og-all [a]rch-trees [A]rch-files
- clock[R]eport time[G]rid [[]inactive [E]ntryText include[D]iary")
+ (message "View: [d]ay [w]eek [m]onth [y]ear [q]uit/abort
+ time[G]rid [[]inactive [f]ollow [l]og [L]og-all [E]ntryText
+ [a]rch-trees [A]rch-files clock[R]eport include[D]iary")
(let ((a (read-char-exclusive)))
(case a
(?d (call-interactively 'org-agenda-day-view))
@@ -5406,6 +5906,7 @@ With prefix ARG, go backward that many times the current span."
(?m (call-interactively 'org-agenda-month-view))
(?y (call-interactively 'org-agenda-year-view))
(?l (call-interactively 'org-agenda-log-mode))
+ (?L (org-agenda-log-mode '(4)))
((?F ?f) (call-interactively 'org-agenda-follow-mode))
(?a (call-interactively 'org-agenda-archives-mode))
(?A (org-agenda-archives-mode 'files))
@@ -5413,6 +5914,7 @@ With prefix ARG, go backward that many times the current span."
((?E ?e) (call-interactively 'org-agenda-entry-text-mode))
(?G (call-interactively 'org-agenda-toggle-time-grid))
(?D (call-interactively 'org-agenda-toggle-diary))
+ (?\! (call-interactively 'org-agenda-toggle-deadlines))
(?\[ (let ((org-agenda-include-inactive-timestamps t))
(org-agenda-check-type t 'timeline 'agenda)
(org-agenda-redo))
@@ -5546,17 +6048,16 @@ so that the date SD will be in that range."
(error "No previous date before this line in this buffer")))
;; Initialize the highlight
-(defvar org-hl (org-make-overlay 1 1))
-(org-overlay-put org-hl 'face 'highlight)
+(defvar org-hl (make-overlay 1 1))
+(overlay-put org-hl 'face 'highlight)
(defun org-highlight (begin end &optional buffer)
"Highlight a region with overlay."
- (funcall (if (featurep 'xemacs) 'set-extent-endpoints 'move-overlay)
- org-hl begin end (or buffer (current-buffer))))
+ (move-overlay org-hl begin end (or buffer (current-buffer))))
(defun org-unhighlight ()
"Detach overlay INDEX."
- (funcall (if (featurep 'xemacs) 'detach-extent 'delete-overlay) org-hl))
+ (org-detach-overlay org-hl))
;; FIXME this is currently not used.
(defun org-highlight-until-next-command (beg end &optional buffer)
@@ -5581,9 +6082,8 @@ so that the date SD will be in that range."
(defun org-agenda-entry-text-mode (&optional arg)
"Toggle entry text mode in an agenda buffer."
(interactive "P")
- (if (integerp arg)
- (setq org-agenda-entry-text-mode t)
- (setq org-agenda-entry-text-mode (not org-agenda-entry-text-mode)))
+ (setq org-agenda-entry-text-mode (or (integerp arg)
+ (not org-agenda-entry-text-mode)))
(org-agenda-entry-text-hide)
(and org-agenda-entry-text-mode
(let ((org-agenda-entry-text-maxlines
@@ -5650,6 +6150,16 @@ When called with a prefix argument, include all archive files as well."
(message "Diary inclusion turned %s"
(if org-agenda-include-diary "on" "off")))
+(defun org-agenda-toggle-deadlines ()
+ "Toggle diary inclusion in an agenda buffer."
+ (interactive)
+ (org-agenda-check-type t 'agenda)
+ (setq org-agenda-include-deadlines (not org-agenda-include-deadlines))
+ (org-agenda-redo)
+ (org-agenda-set-mode-name)
+ (message "Deadlines inclusion turned %s"
+ (if org-agenda-include-deadlines "on" "off")))
+
(defun org-agenda-toggle-time-grid ()
"Toggle time grid in an agenda buffer."
(interactive)
@@ -5664,11 +6174,13 @@ When called with a prefix argument, include all archive files as well."
"Set the mode name to indicate all the small mode settings."
(setq mode-name
(concat "Org-Agenda"
+ (if (get 'org-agenda-files 'org-restrict) " []" "")
(if (equal org-agenda-ndays 1) " Day" "")
(if (equal org-agenda-ndays 7) " Week" "")
(if org-agenda-follow-mode " Follow" "")
(if org-agenda-entry-text-mode " ETxt" "")
(if org-agenda-include-diary " Diary" "")
+ (if org-agenda-include-deadlines " Ddl" "")
(if org-agenda-use-time-grid " Grid" "")
(if (and (boundp 'org-habit-show-habits)
org-habit-show-habits) " Habit" "")
@@ -5697,7 +6209,7 @@ When called with a prefix argument, include all archive files as well."
'org-agenda-type))))
(defun org-agenda-next-line ()
- "Move cursor to the next line, and show if follow-mode is active."
+ "Move cursor to the next line, and show if follow mode is active."
(interactive)
(call-interactively 'next-line)
(org-agenda-do-context-action))
@@ -5710,7 +6222,7 @@ When called with a prefix argument, include all archive files as well."
(org-agenda-do-context-action))
(defun org-agenda-do-context-action ()
- "Show outline path and, maybe, follow-mode window."
+ "Show outline path and, maybe, follow mode window."
(let ((m (org-get-at-bol 'org-marker)))
(if (and org-agenda-follow-mode m)
(org-agenda-show))
@@ -5744,6 +6256,7 @@ and by additional input from the age of a schedules or deadline entry."
(pos (marker-position marker)))
(switch-to-buffer-other-window buffer)
(widen)
+ (push-mark)
(goto-char pos)
(when (org-mode-p)
(org-show-context 'agenda)
@@ -5860,7 +6373,7 @@ If this information is not given, the function uses the tree at point."
(delete-region (point-at-bol) (1+ (point-at-eol)))))
(beginning-of-line 0))))))
-(defun org-agenda-refile (&optional goto rfloc)
+(defun org-agenda-refile (&optional goto rfloc no-update)
"Refile the item at point."
(interactive "P")
(if (equal goto '(16))
@@ -5879,7 +6392,8 @@ If this information is not given, the function uses the tree at point."
(widen)
(goto-char marker)
(org-remove-subtree-entries-from-agenda)
- (org-refile goto buffer rfloc)))))))
+ (org-refile goto buffer rfloc)))))
+ (unless no-update (org-agenda-redo))))
(defun org-agenda-open-link (&optional arg)
"Follow the link in the current line, if any.
@@ -6089,8 +6603,8 @@ docstring of `org-agenda-show-1'."
This calls the command `org-tree-to-indirect-buffer' from the original
Org-mode buffer.
With numerical prefix arg ARG, go up to this level and then take that tree.
-With a C-u prefix, make a separate frame for this tree (i.e. don't use the
-dedicated frame)."
+With a \\[universal-argument] prefix, make a separate frame for this tree (i.e. don't
+use the dedicated frame)."
(interactive)
(org-agenda-check-no-diary)
(let* ((marker (or (org-get-at-bol 'org-marker)
@@ -6238,7 +6752,7 @@ If FORCE-TAGS is non nil, the car of it returns the new tags."
(let ((inhibit-read-only t) l c)
(save-excursion
(goto-char (if line (point-at-bol) (point-min)))
- (while (re-search-forward (org-re "\\([ \t]+\\)\\(:[[:alnum:]_@:]+:\\)[ \t]*$")
+ (while (re-search-forward (org-re "\\([ \t]+\\)\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$")
(if line (point-at-eol) nil) t)
(add-text-properties
(match-beginning 2) (match-end 2)
@@ -6256,7 +6770,8 @@ If FORCE-TAGS is non nil, the car of it returns the new tags."
(goto-char (match-beginning 1))
(insert (org-add-props
(make-string (max 1 (- c (current-column))) ?\ )
- (text-properties-at (point)))))
+ (plist-put (copy-sequence (text-properties-at (point)))
+ 'face nil))))
(goto-char (point-min))
(org-font-lock-add-tag-faces (point-max)))))
@@ -6523,14 +7038,15 @@ be used to request time specification in the time stamp."
(with-current-buffer buffer
(widen)
(goto-char pos)
- (if (not (org-at-timestamp-p))
+ (if (not (org-at-timestamp-p t))
(error "Cannot find time stamp"))
- (org-time-stamp arg))
+ (org-time-stamp arg (equal (char-after (match-beginning 0)) ?\[)))
(org-agenda-show-new-time marker org-last-changed-timestamp))
(message "Time stamp changed to %s" org-last-changed-timestamp)))
(defun org-agenda-schedule (arg)
- "Schedule the item at point."
+ "Schedule the item at point.
+Arg is passed through to `org-schedule'."
(interactive "P")
(org-agenda-check-type t 'agenda 'timeline 'todo 'tags 'search)
(org-agenda-check-no-diary)
@@ -6551,7 +7067,8 @@ be used to request time specification in the time stamp."
(message "Item scheduled for %s" ts)))
(defun org-agenda-deadline (arg)
- "Schedule the item at point."
+ "Schedule the item at point.
+Arg is passed through to `org-deadline'."
(interactive "P")
(org-agenda-check-type t 'agenda 'timeline 'todo 'tags 'search)
(org-agenda-check-no-diary)
@@ -6577,13 +7094,14 @@ m Mark the entry at point for an agenda action
s Schedule the marked entry to the date at the cursor
d Set the deadline of the marked entry to the date at the cursor
r Call `org-remember' with cursor date as the default date
+c Call `org-capture' with cursor date as the default date
SPC Show marked entry in other window
TAB Visit marked entry in other window
The cursor may be at a date in the calendar, or in the Org agenda."
(interactive)
(let (ans)
- (message "Select action: [m]ark | [s]chedule [d]eadline [r]emember [ ]show")
+ (message "Select action: [m]ark | [s]chedule [d]eadline [r]emember [c]apture [ ]show")
(setq ans (read-char-exclusive))
(cond
((equal ans ?m)
@@ -6604,6 +7122,8 @@ The cursor may be at a date in the calendar, or in the Org agenda."
(org-agenda-do-action '(org-deadline nil org-overriding-default-time)))
((equal ans ?r)
(org-agenda-do-action '(org-remember) t))
+ ((equal ans ?c)
+ (org-agenda-do-action '(org-capture) t))
((equal ans ?\ )
(let ((cw (selected-window)))
(org-switch-to-buffer-other-window
@@ -6655,9 +7175,9 @@ The cursor may be at a date in the calendar, or in the Org agenda."
(setq newhead (org-get-heading)))
(org-agenda-change-all-lines newhead hdmarker)))))
-(defun org-agenda-clock-out (&optional arg)
+(defun org-agenda-clock-out ()
"Stop the currently running clock."
- (interactive "P")
+ (interactive)
(unless (marker-buffer org-clock-marker)
(error "No running clock"))
(let ((marker (make-marker)) newhead)
@@ -6682,6 +7202,23 @@ The cursor may be at a date in the calendar, or in the Org agenda."
(org-with-remote-undo (marker-buffer org-clock-marker)
(org-clock-cancel)))
+(defun org-agenda-clock-goto ()
+ "Jump to the currently clocked in task within the agenda.
+If the currently clocked in task is not listed in the agenda
+buffer, display it in another window."
+ (interactive)
+ (let (pos)
+ (mapc (lambda (o)
+ (if (eq (overlay-get o 'type) 'org-agenda-clocking)
+ (setq pos (overlay-start o))))
+ (overlays-in (point-min) (point-max)))
+ (cond (pos (goto-char pos))
+ ;; If the currently clocked entry is not in the agenda
+ ;; buffer, we visit it in another window:
+ (org-clock-current-task
+ (org-switch-to-buffer-other-window (org-clock-goto)))
+ (t (message "No running clock, use `C-c C-x C-j' to jump to the most recent one")))))
+
(defun org-agenda-diary-entry-in-org-file ()
"Make a diary entry in the file `org-agenda-diary-file'."
(let (d1 d2 char (text "") dp1 dp2)
@@ -6719,6 +7256,7 @@ The cursor may be at a date in the calendar, or in the Org agenda."
((equal char ?j)
(org-switch-to-buffer-other-window
(find-file-noselect org-agenda-diary-file))
+ (require 'org-datetree)
(org-datetree-find-date-create d1)
(org-reveal t))
(t (error "Invalid selection character `%c'" char)))))
@@ -6734,6 +7272,11 @@ top-level as top-level entries at the end of the file."
(const :tag "in a date tree" date-tree)
(const :tag "as top level at end of file" top-level)))
+(defcustom org-agenda-insert-diary-extract-time nil
+ "Non-nil means extract any time specification from the diary entry."
+ :group 'org-agenda
+ :type 'boolean)
+
(defun org-agenda-add-entry-to-org-agenda-diary-file (type text &optional d1 d2)
"Add a diary entry with TYPE to `org-agenda-diary-file'.
If TEXT is not empty, it will become the headline of the new entry, and
@@ -6761,20 +7304,38 @@ the resulting entry will not be shown. When TEXT is empty, switch to
(let ((calendar-date-display-form
(if (if (boundp 'calendar-date-style)
(eq calendar-date-style 'european)
- european-calendar-style) ; Emacs 22
+ (with-no-warnings ;; european-calendar-style is obsolete as of version 23.1
+ (org-bound-and-true-p european-calendar-style))) ; Emacs 22
'(day " " month " " year)
'(month " " day " " year))))
(insert (format "%%%%(diary-anniversary %s) %s"
(calendar-date-string d1 nil t) text))))
((eq type 'day)
- (if (eq org-agenda-insert-diary-strategy 'top-level)
- (org-agenda-insert-diary-as-top-level text)
- (require 'org-datetree)
- (org-datetree-find-date-create d1)
- (org-agenda-insert-diary-make-new-entry text))
- (org-insert-time-stamp (org-time-from-absolute
- (calendar-absolute-from-gregorian d1)))
+ (let ((org-prefix-has-time t)
+ (org-agenda-time-leading-zero t)
+ fmt time time2)
+ (if org-agenda-insert-diary-extract-time
+ ;; Use org-format-agenda-item to parse text for a time-range and
+ ;; remove it. FIXME: This is a hack, we should refactor
+ ;; that function to make time extraction available separately
+ (setq fmt (org-format-agenda-item nil text nil nil t)
+ time (get-text-property 0 'time fmt)
+ time2 (if (> (length time) 0)
+ ;; split-string removes trailing ...... if
+ ;; no end time given. First space
+ ;; separates time from date.
+ (concat " " (car (split-string time "\\.")))
+ nil)
+ text (get-text-property 0 'txt fmt)))
+ (if (eq org-agenda-insert-diary-strategy 'top-level)
+ (org-agenda-insert-diary-as-top-level text)
+ (require 'org-datetree)
+ (org-datetree-find-date-create d1)
+ (org-agenda-insert-diary-make-new-entry text))
+ (org-insert-time-stamp (org-time-from-absolute
+ (calendar-absolute-from-gregorian d1))
+ nil nil nil nil time2))
(end-of-line 0))
((eq type 'block)
(if (> (calendar-absolute-from-gregorian d1)
@@ -6823,7 +7384,7 @@ a timestamp can be added there."
(org-back-over-empty-lines)
(or (looking-at "[ \t]*$")
(progn (insert "\n") (backward-char 1)))
- (org-insert-heading)
+ (org-insert-heading nil t)
(org-do-demote)
(setq col (current-column))
(insert text "\n")
@@ -6940,9 +7501,7 @@ argument, latitude and longitude will be prompted for."
(date (calendar-gregorian-from-absolute day))
(calendar-move-hook nil)
(calendar-view-holidays-initially-flag nil)
- (calendar-view-diary-initially-flag nil)
- (view-calendar-holidays-initially nil)
- (view-diary-entries-initially nil))
+ (calendar-view-diary-initially-flag nil))
(calendar)
(calendar-goto-date date)))
@@ -7001,12 +7560,14 @@ This is a command that has to be installed in `calendar-mode-map'."
(unless (org-agenda-bulk-marked-p)
(unless m (error "Nothing to mark at point"))
(push m org-agenda-bulk-marked-entries)
- (setq ov (org-make-overlay (point-at-bol) (+ 2 (point-at-bol))))
+ (setq ov (make-overlay (point-at-bol) (+ 2 (point-at-bol))))
(org-overlay-display ov "> "
(org-get-todo-face "TODO")
'evaporate)
- (org-overlay-put ov 'type 'org-marked-entry-overlay))
+ (overlay-put ov 'type 'org-marked-entry-overlay))
(beginning-of-line 2)
+ (while (and (get-char-property (point) 'invisible) (not (eobp)))
+ (beginning-of-line 2))
(message "%d entries marked for bulk action"
(length org-agenda-bulk-marked-entries))))
@@ -7020,6 +7581,8 @@ This is a command that has to be installed in `calendar-mode-map'."
(delete (org-get-at-bol 'org-hd-marker)
org-agenda-bulk-marked-entries)))
(beginning-of-line 2)
+ (while (and (get-char-property (point) 'invisible) (not (eobp)))
+ (beginning-of-line 2))
(message "%d entries marked for bulk action"
(length org-agenda-bulk-marked-entries)))
@@ -7038,9 +7601,9 @@ This only removes the overlays, it does not remove the markers
from the list in `org-agenda-bulk-marked-entries'."
(interactive)
(mapc (lambda (ov)
- (and (eq (org-overlay-get ov 'type) 'org-marked-entry-overlay)
- (org-delete-overlay ov)))
- (org-overlays-in (or beg (point-min)) (or end (point-max)))))
+ (and (eq (overlay-get ov 'type) 'org-marked-entry-overlay)
+ (delete-overlay ov)))
+ (overlays-in (or beg (point-min)) (or end (point-max)))))
(defun org-agenda-bulk-remove-all-marks ()
"Remove all marks in the agenda buffer.
@@ -7050,14 +7613,17 @@ This will remove the markers, and the overlays."
(setq org-agenda-bulk-marked-entries nil)
(org-agenda-bulk-remove-overlays (point-min) (point-max)))
-(defun org-agenda-bulk-action ()
- "Execute an remote-editing action on all marked entries."
- (interactive)
+(defun org-agenda-bulk-action (&optional arg)
+ "Execute an remote-editing action on all marked entries.
+The prefix arg is passed through to the command if possible."
+ (interactive "P")
(unless org-agenda-bulk-marked-entries
(error "No entries are marked"))
(message "Bulk: [r]efile [$]archive [A]rch->sib [t]odo [+/-]tag [s]chedule [d]eadline")
(let* ((action (read-char-exclusive))
+ (org-log-refile (if org-log-refile 'time nil))
(entries (reverse org-agenda-bulk-marked-entries))
+ redo-at-end
cmd rfloc state e tag pos (cnt 0) (cntskip 0))
(cond
((equal action ?$)
@@ -7071,13 +7637,15 @@ This will remove the markers, and the overlays."
"Refile to: "
(marker-buffer (car org-agenda-bulk-marked-entries))
org-refile-allow-creating-parent-nodes))
- (setcar (nthcdr 3 rfloc)
- (move-marker (make-marker) (nth 3 rfloc)
- (or (get-file-buffer (nth 1 rfloc))
- (find-buffer-visiting (nth 1 rfloc))
- (error "This should not happen"))))
+ (if (nth 3 rfloc)
+ (setcar (nthcdr 3 rfloc)
+ (move-marker (make-marker) (nth 3 rfloc)
+ (or (get-file-buffer (nth 1 rfloc))
+ (find-buffer-visiting (nth 1 rfloc))
+ (error "This should not happen")))))
- (setq cmd (list 'org-agenda-refile nil (list 'quote rfloc))))
+ (setq cmd (list 'org-agenda-refile nil (list 'quote rfloc) t)
+ redo-at-end t))
((equal action ?t)
(setq state (org-icompleting-read
@@ -7098,17 +7666,18 @@ This will remove the markers, and the overlays."
(setq cmd `(org-agenda-set-tags ,tag ,(if (eq action ?+) ''on ''off))))
((memq action '(?s ?d))
- (let* ((date (org-read-date
- nil nil nil
- (if (eq action ?s) "(Re)Schedule to" "Set Deadline to")))
- (ans org-read-date-final-answer)
+ (let* ((date (unless arg
+ (org-read-date
+ nil nil nil
+ (if (eq action ?s) "(Re)Schedule to" "Set Deadline to"))))
+ (ans (if arg nil org-read-date-final-answer))
(c1 (if (eq action ?s) 'org-agenda-schedule 'org-agenda-deadline)))
(setq cmd `(let* ((bound (fboundp 'read-string))
(old (and bound (symbol-function 'read-string))))
(unwind-protect
(progn
(fset 'read-string (lambda (&rest ignore) ,ans))
- (call-interactively ',c1))
+ (eval '(,c1 arg)))
(if bound
(fset 'read-string old)
(fmakunbound 'read-string)))))))
@@ -7137,6 +7706,7 @@ This will remove the markers, and the overlays."
(setq cnt (1+ cnt))))
(setq org-agenda-bulk-marked-entries nil)
(org-agenda-bulk-remove-all-marks)
+ (when redo-at-end (org-agenda-redo))
(message "Acted on %d entries%s"
cnt
(if (= cntskip 0)
@@ -7216,7 +7786,6 @@ either 'headline or 'category. For example:
will only add headlines containing IMPORTANT or headlines
belonging to the \"Work\" category."
(interactive "P")
- (require 'calendar)
(if refresh (setq appt-time-msg-list nil))
(if (eq filter t)
(setq filter (read-from-minibuffer "Regexp filter: ")))
diff --git a/lisp/org/org-archive.el b/lisp/org/org-archive.el
index 03f5e5d5a80..8c1f9a13a12 100644
--- a/lisp/org/org-archive.el
+++ b/lisp/org/org-archive.el
@@ -6,7 +6,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -40,7 +40,12 @@
:type '(choice
(const org-archive-subtree)
(const org-archive-to-archive-sibling)
- (const org-archive-set-tag)))
+ (const org-archive-set-tag)))
+
+(defcustom org-archive-reversed-order nil
+ "Non-nil means make the tree first child under the archive heading, not last."
+ :group 'org-archive
+ :type 'boolean)
(defcustom org-archive-sibling-heading "Archive"
"Name of the local archive sibling that is used to archive entries locally.
@@ -50,7 +55,7 @@ See `org-archive-to-archive-sibling' for more information."
:type 'string)
(defcustom org-archive-mark-done nil
- "Non-nil means, mark entries as DONE when they are moved to the archive file.
+ "Non-nil means mark entries as DONE when they are moved to the archive file.
This can be a string to set the keyword to use. When t, Org-mode will
use the first keyword in its list that means done."
:group 'org-archive
@@ -60,7 +65,7 @@ use the first keyword in its list that means done."
(string :tag "Use this keyword")))
(defcustom org-archive-stamp-time t
- "Non-nil means, add a time stamp to entries moved to an archive file.
+ "Non-nil means add a time stamp to entries moved to an archive file.
This variable is obsolete and has no effect anymore, instead add or remove
`time' from the variable `org-archive-save-context-info'."
:group 'org-archive
@@ -110,7 +115,7 @@ information."
((or (re-search-backward re nil t)
(re-search-forward re nil t))
(match-string 1))
- (t org-archive-location (match-string 1)))))))
+ (t org-archive-location))))))
(defun org-add-archive-files (files)
"Splice the archive files into the list of files.
@@ -263,7 +268,7 @@ this heading."
(progn
(if (re-search-forward
(concat "^" (regexp-quote heading)
- (org-re "[ \t]*\\(:[[:alnum:]_@:]+:\\)?[ \t]*\\($\\|\r\\)"))
+ (org-re "[ \t]*\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*\\($\\|\r\\)"))
nil t)
(goto-char (match-end 0))
;; Heading not found, just insert it at the end
@@ -273,7 +278,11 @@ this heading."
(end-of-line 0))
;; Make the subtree visible
(show-subtree)
- (org-end-of-subtree t)
+ (if org-archive-reversed-order
+ (progn
+ (org-back-to-heading t)
+ (outline-next-heading))
+ (org-end-of-subtree t))
(skip-chars-backward " \t\r\n")
(and (looking-at "[ \t\r\n]*")
(replace-match "\n\n")))
@@ -355,7 +364,9 @@ sibling does not exist, it will be created at the end of the subtree."
(beginning-of-line 0)
(org-toggle-tag org-archive-tag 'on))
(beginning-of-line 1)
- (org-end-of-subtree t t)
+ (if org-archive-reversed-order
+ (outline-next-heading)
+ (org-end-of-subtree t t))
(save-excursion
(goto-char pos)
(let ((this-command this-command)) (org-cut-subtree)))
@@ -389,7 +400,8 @@ When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag."
(progn
(setq re1 (concat "^" (regexp-quote
(make-string
- (1+ (- (match-end 0) (match-beginning 0) 1))
+ (+ (- (match-end 0) (match-beginning 0) 1)
+ (if org-odd-levels-only 2 1))
?*))
" "))
(move-marker begm (point))
diff --git a/lisp/org/org-ascii.el b/lisp/org/org-ascii.el
index 13603ce5134..b48f8efa1cd 100644
--- a/lisp/org/org-ascii.el
+++ b/lisp/org/org-ascii.el
@@ -6,7 +6,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -26,7 +26,10 @@
;;
;;; Commentary:
+;;; Code:
+
(require 'org-exp)
+
(eval-when-compile
(require 'cl))
@@ -52,19 +55,34 @@ Org-mode file."
:type '(repeat character))
(defcustom org-export-ascii-links-to-notes t
- "Non-nil means, convert links to notes before the next headline.
+ "Non-nil means convert links to notes before the next headline.
When nil, the link will be exported in place. If the line becomes long
in this way, it will be wrapped."
:group 'org-export-ascii
:type 'boolean)
(defcustom org-export-ascii-table-keep-all-vertical-lines nil
- "Non-nil means, keep all vertical lines in ASCII tables.
+ "Non-nil means keep all vertical lines in ASCII tables.
When nil, vertical lines will be removed except for those needed
for column grouping."
:group 'org-export-ascii
:type 'boolean)
+(defcustom org-export-ascii-table-widen-columns t
+ "Non-nil means widen narrowed columns for export.
+When nil, narrowed columns will look in ASCII export just like in org-mode,
+i.e. with \"=>\" as ellipsis."
+ :group 'org-export-ascii
+ :type 'boolean)
+
+(defvar org-export-ascii-entities 'ascii
+ "The ascii representation to be used during ascii export.
+Possible values are:
+
+ascii Only use plain ASCII characters
+latin1 Include Latin-1 character
+utf8 Use all UTF-8 characters")
+
;;; Hooks
(defvar org-export-ascii-final-hook nil
@@ -75,6 +93,41 @@ for column grouping."
(defvar org-ascii-current-indentation nil) ; For communication
;;;###autoload
+(defun org-export-as-latin1 (&rest args)
+ "Like `org-export-as-ascii', use latin1 encoding for special symbols."
+ (interactive)
+ (org-export-as-encoding 'org-export-as-ascii (interactive-p)
+ 'latin1 args))
+
+;;;###autoload
+(defun org-export-as-latin1-to-buffer (&rest args)
+ "Like `org-export-as-ascii-to-buffer', use latin1 encoding for symbols."
+ (interactive)
+ (org-export-as-encoding 'org-export-as-ascii-to-buffer (interactive-p)
+ 'latin1 args))
+
+;;;###autoload
+(defun org-export-as-utf8 (&rest args)
+ "Like `org-export-as-ascii', use use encoding for special symbols."
+ (interactive)
+ (org-export-as-encoding 'org-export-as-ascii (interactive-p)
+ 'utf8 args))
+
+;;;###autoload
+(defun org-export-as-utf8-to-buffer (&rest args)
+ "Like `org-export-as-ascii-to-buffer', use utf8 encoding for symbols."
+ (interactive)
+ (org-export-as-encoding 'org-export-as-ascii-to-buffer (interactive-p)
+ 'utf8 args))
+
+(defun org-export-as-encoding (command interactivep encoding &rest args)
+ (let ((org-export-ascii-entities encoding))
+ (if interactivep
+ (call-interactively command)
+ (apply command args))))
+
+
+;;;###autoload
(defun org-export-as-ascii-to-buffer (arg)
"Call `org-export-as-ascii` with output to a temporary buffer.
No file is created. The prefix ARG is passed through to `org-export-as-ascii'."
@@ -156,6 +209,7 @@ resulting ASCII as a string. When BODY-ONLY is set, don't produce
the file header and footer. When PUB-DIR is set, use this as the
publishing directory."
(interactive "P")
+ (run-hooks 'org-export-first-hook)
(setq-default org-todo-line-regexp org-todo-line-regexp)
(let* ((opt-plist (org-combine-plists (org-default-export-plist)
ext-plist
@@ -181,6 +235,11 @@ publishing directory."
(if subtree-p
(org-export-add-subtree-options opt-plist rbeg)
opt-plist)))
+ ;; The following two are dynamically scoped into other
+ ;; routines below.
+ (org-current-export-dir
+ (or pub-dir (org-export-directory :html opt-plist)))
+ (org-current-export-file buffer-file-name)
(custom-times org-display-custom-times)
(org-ascii-current-indentation '(0 . 0))
(level 0) line txt
@@ -219,8 +278,10 @@ publishing directory."
(and (not
(plist-get opt-plist :skip-before-1st-heading))
(org-export-grab-title-from-buffer))
- (file-name-sans-extension
- (file-name-nondirectory bfname))))
+ (and (buffer-file-name)
+ (file-name-sans-extension
+ (file-name-nondirectory bfname)))
+ "UNTITLED"))
(email (plist-get opt-plist :email))
(language (plist-get opt-plist :language))
(quote-re0 (concat "^[ \t]*" org-quote-string "\\>"))
@@ -250,7 +311,7 @@ publishing directory."
:add-text (plist-get opt-plist :text))
"\n"))
thetoc have-headings first-heading-pos
- table-open table-buffer link-buffer link desc desc0 rpl wrap)
+ table-open table-buffer link-buffer link type path desc desc0 rpl wrap fnc)
(let ((inhibit-read-only t))
(org-unmodified
(remove-text-properties (point-min) (point-max)
@@ -286,8 +347,10 @@ publishing directory."
(if (and (or author email)
org-export-author-info)
- (insert(concat (nth 1 lang-words) ": " (or author "")
- (if email (concat " <" email ">") "")
+ (insert (concat (nth 1 lang-words) ": " (or author "")
+ (if (and org-export-email-info
+ email (string-match "\\S-" email))
+ (concat " <" email ">") "")
"\n")))
(cond
@@ -337,7 +400,7 @@ publishing directory."
(if (and (memq org-export-with-tags '(not-in-toc nil))
(string-match
- (org-re "[ \t]+:[[:alnum:]_@:]+:[ \t]*$")
+ (org-re "[ \t]+:[[:alnum:]_@#%:]+:[ \t]*$")
txt))
(setq txt (replace-match "" t t txt)))
(if (string-match quote-re0 txt)
@@ -368,10 +431,12 @@ publishing directory."
;; Remove the quoted HTML tags.
(setq line (org-html-expand-for-ascii line))
;; Replace links with the description when possible
- (while (string-match org-bracket-link-regexp line)
- (setq link (match-string 1 line)
- desc0 (match-string 3 line)
- desc (or desc0 (match-string 1 line)))
+ (while (string-match org-bracket-link-analytic-regexp++ line)
+ (setq path (match-string 3 line)
+ link (concat (match-string 1 line) path)
+ type (match-string 2 line)
+ desc0 (match-string 5 line)
+ desc (or desc0 link))
(if (and (> (length link) 8)
(equal (substring link 0 8) "coderef:"))
(setq line (replace-match
@@ -380,15 +445,18 @@ publishing directory."
(substring link 8)
org-export-code-refs)))
t t line))
- (setq rpl (concat "["
- (or (match-string 3 line) (match-string 1 line))
- "]"))
- (when (and desc0 (not (equal desc0 link)))
- (if org-export-ascii-links-to-notes
- (push (cons desc0 link) link-buffer)
- (setq rpl (concat rpl " (" link ")")
- wrap (+ (length line) (- (length (match-string 0 line)))
- (length desc)))))
+ (setq rpl (concat "[" desc "]"))
+ (if (functionp (setq fnc (nth 2 (assoc type org-link-protocols))))
+ (setq rpl (or (save-match-data
+ (funcall fnc (org-link-unescape path)
+ desc0 'ascii))
+ rpl))
+ (when (and desc0 (not (equal desc0 link)))
+ (if org-export-ascii-links-to-notes
+ (push (cons desc0 link) link-buffer)
+ (setq rpl (concat rpl " (" link ")")
+ wrap (+ (length line) (- (length (match-string 0 line)))
+ (length desc))))))
(setq line (replace-match rpl t t line))))
(when custom-times
(setq line (org-translate-time line)))
@@ -419,7 +487,8 @@ publishing directory."
(org-format-table-ascii table-buffer)
"\n") "\n")))
(t
- (if (string-match "^\\([ \t]*\\)\\([-+*][ \t]+\\)\\(.*?\\)\\( ::\\)" line)
+ (if (string-match "^\\([ \t]*\\)\\([-+*][ \t]+\\)\\(.*?\\)\\( ::\\)"
+ line)
(setq line (replace-match "\\1\\3:" t nil line)))
(setq line (org-fix-indentation line org-ascii-current-indentation))
;; Remove forced line breaks
@@ -481,19 +550,39 @@ publishing directory."
(current-buffer))))
(defun org-export-ascii-preprocess (parameters)
- "Do extra work for ASCII export"
+ "Do extra work for ASCII export."
+ ;;
+ ;; Realign tables to get rid of narrowing
+ (when org-export-ascii-table-widen-columns
+ (let ((org-table-do-narrow nil))
+ (goto-char (point-min))
+ (org-ascii-replace-entities)
+ (goto-char (point-min))
+ (org-table-map-tables
+ (lambda () (org-if-unprotected (org-table-align)))
+ 'quietly)))
;; Put quotes around verbatim text
(goto-char (point-min))
(while (re-search-forward org-verbatim-re nil t)
- (goto-char (match-end 2))
- (backward-delete-char 1) (insert "'")
- (goto-char (match-beginning 2))
- (delete-char 1) (insert "`")
- (goto-char (match-end 2)))
+ (org-if-unprotected-at (match-beginning 4)
+ (goto-char (match-end 2))
+ (backward-delete-char 1) (insert "'")
+ (goto-char (match-beginning 2))
+ (delete-char 1) (insert "`")
+ (goto-char (match-end 2))))
;; Remove target markers
(goto-char (point-min))
(while (re-search-forward "<<<?\\([^<>]*\\)>>>?\\([ \t]*\\)" nil t)
- (replace-match "\\1\\2")))
+ (org-if-unprotected-at (match-beginning 1)
+ (replace-match "\\1\\2")))
+ ;; Remove list start counters
+ (goto-char (point-min))
+ (while (org-search-forward-unenclosed
+ "\\[@\\(?:start:\\)?[0-9]+\\][ \t]*" nil t)
+ (replace-match ""))
+ (remove-text-properties
+ (point-min) (point-max)
+ '(face nil font-lock-fontified nil font-lock-multiline nil line-prefix nil wrap-prefix nil)))
(defun org-html-expand-for-ascii (line)
"Handle quoted HTML for ASCII export."
@@ -503,6 +592,15 @@ publishing directory."
(setq line (replace-match "" nil nil line))))
line)
+(defun org-ascii-replace-entities ()
+ "Replace entities with the ASCII representation."
+ (let (e)
+ (while (re-search-forward "\\\\\\([a-zA-Z]+[0-9]*\\)\\({}\\)?" nil t)
+ (org-if-unprotected-at (match-beginning 1)
+ (setq e (org-entity-get-representation (match-string 1)
+ org-export-ascii-entities))
+ (and e (replace-match e t t))))))
+
(defun org-export-ascii-wrap (line where)
"Wrap LINE at or before WHERE."
(let ((ind (org-get-indentation line))
@@ -556,7 +654,7 @@ publishing directory."
(insert "\n"))
(setq char (nth (- umax level) (reverse org-export-ascii-underline)))
(unless org-export-with-tags
- (if (string-match (org-re "[ \t]+\\(:[[:alnum:]_@:]+:\\)[ \t]*$") title)
+ (if (string-match (org-re "[ \t]+\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$") title)
(setq title (replace-match "" t t title))))
(if org-export-with-section-numbers
(setq title (concat (org-section-number level) " " title)))
diff --git a/lisp/org/org-attach.el b/lisp/org/org-attach.el
index 692631b64c1..d98254cb659 100644
--- a/lisp/org/org-attach.el
+++ b/lisp/org/org-attach.el
@@ -4,7 +4,7 @@
;; Author: John Wiegley <johnw@newartisans.com>
;; Keywords: org data task
-;; Version: 6.33x
+;; Version: 7.3
;; This file is part of GNU Emacs.
;;
@@ -92,7 +92,7 @@ ln create a hard link. Note that this is not supported
:type 'boolean)
(defcustom org-attach-allow-inheritance t
- "Non-nil means, allow attachment directories be inherited."
+ "Non-nil means allow attachment directories be inherited."
:group 'org-attach
:type 'boolean)
@@ -241,12 +241,17 @@ the ATTACH_DIR property) their own attachment directory."
"Commit changes to git if `org-attach-directory' is properly initialized.
This checks for the existence of a \".git\" directory in that directory."
(let ((dir (expand-file-name org-attach-directory)))
- (if (file-exists-p (expand-file-name ".git" dir))
- (shell-command
- (concat "(cd " dir "; "
- " git add .; "
- " git ls-files --deleted -z | xargs -0 git rm; "
- " git commit -m 'Synchronized attachments')")))))
+ (when (file-exists-p (expand-file-name ".git" dir))
+ (with-temp-buffer
+ (cd dir)
+ (shell-command "git add .")
+ (shell-command "git ls-files --deleted" t)
+ (mapc '(lambda (file)
+ (unless (string= file "")
+ (shell-command
+ (concat "git rm \"" file "\""))))
+ (split-string (buffer-string) "\n"))
+ (shell-command "git commit -m 'Synchronized attachments'")))))
(defun org-attach-tag (&optional off)
"Turn the autotag on or (if OFF is set) off."
@@ -322,7 +327,8 @@ The attachment is created as an Emacs buffer."
(setq file (expand-file-name file attach-dir))
(unless (file-exists-p file)
(error "No such attachment: %s" file))
- (delete-file file)))
+ (delete-file file)
+ (org-attach-commit)))
(defun org-attach-delete-all (&optional force)
"Delete all attachments from the current task.
diff --git a/lisp/org/org-bbdb.el b/lisp/org/org-bbdb.el
index 1a91b5e7265..d5a09cab63b 100644
--- a/lisp/org/org-bbdb.el
+++ b/lisp/org/org-bbdb.el
@@ -7,7 +7,7 @@
;; Thomas Baumann <thomas dot baumann at ch dot tum dot de>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -207,7 +207,7 @@ date year)."
(defun org-bbdb-export (path desc format)
"Create the export version of a BBDB link specified by PATH or DESC.
If exporting to either HTML or LaTeX FORMAT the link will be
-italicised, in all other cases it is left unchanged."
+italicized, in all other cases it is left unchanged."
(cond
((eq format 'html) (format "<i>%s</i>" (or desc path)))
((eq format 'latex) (format "\\textit{%s}" (or desc path)))
@@ -322,8 +322,8 @@ This is used by Org to re-create the anniversary hash table."
(when rec
(let* ((class (or (nth 2 rec)
org-bbdb-default-anniversary-format))
- (form (or (cdr (assoc class
- org-bbdb-anniversary-format-alist))
+ (form (or (cdr (assoc-string
+ class org-bbdb-anniversary-format-alist t))
class)) ; (as format string)
(name (nth 1 rec))
(years (- y (car rec)))
@@ -338,8 +338,7 @@ This is used by Org to re-create the anniversary hash table."
(setq text (append text (list tmp)))
(setq text (list tmp)))))
))
- (when text
- (mapconcat 'identity text "; "))))
+ text))
(defun org-bbdb-complete-link ()
"Read a bbdb link with name completion."
diff --git a/lisp/org/org-beamer.el b/lisp/org/org-beamer.el
new file mode 100644
index 00000000000..d3f0f47e45c
--- /dev/null
+++ b/lisp/org/org-beamer.el
@@ -0,0 +1,636 @@
+;;; org-beamer.el --- Beamer-specific LaTeX export for org-mode
+;;
+;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;
+;; Version: 7.3
+;; Author: Carsten Dominik <carsten.dominik AT gmail DOT com>
+;; Maintainer: Carsten Dominik <carsten.dominik AT gmail DOT com>
+;; Keywords: org, wp, tex
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; This library implement the special treatment needed by using the
+;; beamer class during LaTeX export.
+
+;;; Code:
+
+(require 'org)
+(require 'org-exp)
+
+(defvar org-export-latex-header)
+(defvar org-export-latex-options-plist)
+(defvar org-export-opt-plist)
+
+(defgroup org-beamer nil
+ "Options specific for using the beamer class in LaTeX export."
+ :tag "Org Beamer"
+ :group 'org-export-latex)
+
+(defcustom org-beamer-use-parts nil
+ ""
+ :group 'org-beamer
+ :type 'boolean)
+
+(defcustom org-beamer-frame-level 1
+ "The level that should be interpreted as a frame.
+The levels above this one will be translated into a sectioning structure.
+Setting this to 2 will allow sections, 3 will allow subsections as well.
+You can set this to 4 as well, if you at the same time set
+`org-beamer-use-parts' to make the top levels `\part'."
+ :group 'org-beamer
+ :type '(choice
+ (const :tag "Frames need a BEAMER_env property" nil)
+ (integer :tag "Specific level makes a frame")))
+
+(defcustom org-beamer-frame-default-options ""
+ "Default options string to use for frames, should contains the [brackets].
+And example for this is \"[allowframebreaks]\"."
+ :group 'org-beamer
+ :type '(string :tag "[options]"))
+
+(defcustom org-beamer-column-view-format
+ "%45ITEM %10BEAMER_env(Env) %10BEAMER_envargs(Env Args) %4BEAMER_col(Col) %8BEAMER_extra(Extra)"
+ "Default column view format that should be used to fill the template."
+ :group 'org-beamer
+ :type '(choice
+ (const :tag "Do not insert Beamer column view format" nil)
+ (string :tag "Beamer column view format")))
+
+(defcustom org-beamer-themes
+ "\\usetheme{default}\\usecolortheme{default}"
+ "Default string to be used for extra heading stuff in beamer presentations.
+When a beamer template is filled, this will be the default for
+BEAMER_HEADER_EXTRA, which will be inserted just before \\begin{document}."
+ :group 'org-beamer
+ :type '(choice
+ (const :tag "Do not insert Beamer themes" nil)
+ (string :tag "Beamer themes")))
+
+(defconst org-beamer-column-widths
+ "0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 0.0 :ETC"
+"The column widths that should be installed as allowed property values.")
+
+(defconst org-beamer-transitions
+ "\transblindsvertical \transblindshorizontal \transboxin \transboxout \transdissolve \transduration \transglitter \transsplithorizontalin \transsplithorizontalout \transsplitverticalin \transsplitverticalout \transwipe :ETC"
+ "Transitions available for beamer.
+These are just a completion help.")
+
+(defconst org-beamer-environments-default
+ '(("frame" "f" "dummy- special handling hard coded" "dummy")
+ ("columns" "C" "\\begin{columns}%o %% %h%x" "\\end{columns}")
+ ("column" "c" "\\begin{column}%o{%h\\textwidth}%x" "\\end{column}")
+ ("block" "b" "\\begin{block}%a{%h}%x" "\\end{block}")
+ ("alertblock" "a" "\\begin{alertblock}%a{%h}%x" "\\end{alertblock}")
+ ("verse" "v" "\\begin{verse}%a %% %h%x" "\\end{verse}")
+ ("quotation" "q" "\\begin{quotation}%a %% %h%x" "\\end{quotation}")
+ ("quote" "Q" "\\begin{quote}%a %% %h%x" "\\end{quote}")
+ ("structureenv" "s" "\\begin{structureenv}%a %% %h%x" "\\end{structureenv}")
+ ("theorem" "t" "\\begin{theorem}%a%U%x" "\\end{theorem}")
+ ("definition" "d" "\\begin{definition}%a%U%x" "\\end{definition}")
+ ("example" "e" "\\begin{example}%a%U%x" "\\end{example}")
+ ("proof" "p" "\\begin{proof}%a%U%x" "\\end{proof}")
+ ("beamercolorbox" "o" "\\begin{beamercolorbox}%o{%h}%x" "\\end{beamercolorbox}")
+ ("normal" "h" "%h" "") ; Emit the heading as normal text
+ ("note" "n" "\\note%o%a{%h" "}")
+ ("noteNH" "N" "\\note%o%a{" "}") ; note, ignore heading
+ ("ignoreheading" "i" "%%%% %h" ""))
+ "Environments triggered by properties in Beamer export.
+These are the defaults - for user definitions, see
+`org-beamer-environments-extra'.
+\"normal\" is a special fake environment, which emit the heading as
+normal text. It is needed when an environment should be surrounded
+by normal text. Since beamer export converts nodes into environments,
+you need to have a node to end the environment.
+For example
+
+ ** a frame
+ some text
+ *** Blocktitle :B_block:
+ inside the block
+ *** After the block :B_normal:
+ continuing here
+ ** next frame")
+
+(defcustom org-beamer-environments-extra nil
+ "Environments triggered by tags in Beamer export.
+Each entry has 4 elements:
+
+name Name of the environment
+key Selection key for `org-beamer-select-environment'
+open The opening template for the environment, with the following escapes
+ %a the action/overlay specification
+ %A the default action/overlay specification
+ %o the options argument of the template
+ %h the headline text
+ %H if there is headline text, that text in {} braces
+ %U if there is headline text, that text in [] brackets
+close The closing string of the environment."
+
+ :group 'org-beamer
+ :type '(repeat
+ (list
+ (string :tag "Environment")
+ (string :tag "Selection key")
+ (string :tag "Begin")
+ (string :tag "End"))))
+
+(defvar org-beamer-frame-level-now nil)
+(defvar org-beamer-header-extra nil)
+(defvar org-beamer-export-is-beamer-p nil)
+(defvar org-beamer-inside-frame-at-level nil)
+(defvar org-beamer-columns-open nil)
+(defvar org-beamer-column-open nil)
+
+(defun org-beamer-cleanup-column-width (width)
+ "Make sure the width is not empty, and that it has a unit."
+ (setq width (org-trim (or width "")))
+ (unless (string-match "\\S-" width) (setq width "0.5"))
+ (if (string-match "\\`[.0-9]+\\'" width)
+ (setq width (concat width "\\textwidth")))
+ width)
+
+(defun org-beamer-open-column (&optional width opt)
+ (org-beamer-close-column-maybe)
+ (setq org-beamer-column-open t)
+ (setq width (org-beamer-cleanup-column-width width))
+ (insert (format "\\begin{column}%s{%s}\n" (or opt "") width)))
+(defun org-beamer-close-column-maybe ()
+ (when org-beamer-column-open
+ (setq org-beamer-column-open nil)
+ (insert "\\end{column}\n")))
+(defun org-beamer-open-columns-maybe (&optional opts)
+ (unless org-beamer-columns-open
+ (setq org-beamer-columns-open t)
+ (insert (format "\\begin{columns}%s\n" (or opts "")))))
+(defun org-beamer-close-columns-maybe ()
+ (org-beamer-close-column-maybe)
+ (when org-beamer-columns-open
+ (setq org-beamer-columns-open nil)
+ (insert "\\end{columns}\n")))
+
+(defun org-beamer-select-environment ()
+ "Select the environment to be used by beamer for this entry.
+While this uses (for convenience) a tag selection interface, the result
+of this command will be that the BEAMER_env *property* of the entry is set.
+
+In addition to this, the command will also set a tag as a visual aid, but
+the tag does not have any semantic meaning."
+ (interactive)
+ (let* ((envs (append org-beamer-environments-extra
+ org-beamer-environments-default))
+ (org-tag-alist
+ (append '((:startgroup))
+ (mapcar (lambda (e) (cons (concat "B_" (car e))
+ (string-to-char (nth 1 e))))
+ envs)
+ '((:endgroup))
+ '(("BMCOL" . ?|))))
+ (org-fast-tag-selection-single-key t))
+ (org-set-tags)
+ (let ((tags (or (ignore-errors (org-get-tags-string)) "")))
+ (cond
+ ((equal org-last-tag-selection-key ?|)
+ (if (string-match ":BMCOL:" tags)
+ (org-set-property "BEAMER_col" (read-string "Column width: "))
+ (org-delete-property "BEAMER_col")))
+ ((string-match (concat ":B_\\("
+ (mapconcat 'car envs "\\|")
+ "\\):")
+ tags)
+ (org-entry-put nil "BEAMER_env" (match-string 1 tags)))
+ (t (org-entry-delete nil "BEAMER_env"))))))
+
+
+(defun org-beamer-sectioning (level text)
+ "Return the sectioning entry for the current headline.
+LEVEL is the reduced level of the headline.
+TEXT is the text of the headline, everything except the leading stars.
+The return value is a cons cell. The car is the headline text, usually
+just TEXT, but possibly modified if options have been extracted from the
+text. The cdr is the sectioning entry, similar to what is given
+in org-export-latex-classes."
+ (let* ((frame-level (or org-beamer-frame-level-now org-beamer-frame-level))
+ (default
+ (if org-beamer-use-parts
+ '((1 . ("\\part{%s}" . "\\part*{%s}"))
+ (2 . ("\\section{%s}" . "\\section*{%s}"))
+ (3 . ("\\subsection{%s}" . "\\subsection*{%s}")))
+ '((1 . ("\\section{%s}" . "\\section*{%s}"))
+ (2 . ("\\subsection{%s}" . "\\subsection*{%s}")))))
+ (envs (append org-beamer-environments-extra
+ org-beamer-environments-default))
+ (props (org-get-text-property-any 0 'org-props text))
+ (in "") (out "") option action defaction environment extra
+ columns-option column-option
+ env have-text ass tmp)
+ (if (= frame-level 0) (setq frame-level nil))
+ (when (and org-beamer-inside-frame-at-level
+ (<= level org-beamer-inside-frame-at-level))
+ (setq org-beamer-inside-frame-at-level nil))
+ (when (setq tmp (org-beamer-assoc-not-empty "BEAMER_col" props))
+ (if (and (string-match "\\`[0-9.]+\\'" tmp)
+ (or (= (string-to-number tmp) 1.0)
+ (= (string-to-number tmp) 0.0)))
+ ;; column width 1 means cloase columns, go back to full width
+ (org-beamer-close-columns-maybe)
+ (when (setq ass (assoc "BEAMER_envargs" props))
+ (let (case-fold-search)
+ (when (string-match "C\\(\\[[^][]*\\]\\)" (cdr ass))
+ (setq columns-option (match-string 1 (cdr ass)))
+ (setcdr ass (replace-match "" t t (cdr ass))))
+ (when (string-match "c\\(\\[[^][]*\\]\\)" (cdr ass))
+ (setq column-option (match-string 1 (cdr ass)))
+ (setcdr ass (replace-match "" t t (cdr ass))))))
+ (org-beamer-open-columns-maybe columns-option)
+ (org-beamer-open-column tmp column-option)))
+ (cond
+ ((or (equal (cdr (assoc "BEAMER_env" props)) "frame")
+ (and frame-level (= level frame-level)))
+ ;; A frame
+ (org-beamer-get-special props)
+
+ (setq in (org-fill-template
+ "\\begin{frame}%a%A%o%T%S%x"
+ (list (cons "a" (or action ""))
+ (cons "A" (or defaction ""))
+ (cons "o" (or option org-beamer-frame-default-options ""))
+ (cons "x" (if extra (concat "\n" extra) ""))
+ (cons "h" "%s")
+ (cons "T" (if (string-match "\\S-" text)
+ "\n\\frametitle{%s}" ""))
+ (cons "S" (if (string-match "\\\\\\\\" text)
+ "\n\\framesubtitle{%s}" ""))))
+ out (copy-sequence "\\end{frame}"))
+ (org-add-props out
+ '(org-insert-hook org-beamer-close-columns-maybe))
+ (setq org-beamer-inside-frame-at-level level)
+ (cons text (list in out in out)))
+ ((and (setq env (cdr (assoc "BEAMER_env" props)))
+ (setq ass (assoc env envs)))
+ ;; A beamer environment selected by the BEAMER_env property
+ (if (string-match "[ \t]+:[ \t]*$" text)
+ (setq text (replace-match "" t t text)))
+ (if (member env '("note" "noteNH"))
+ ;; There should be no labels in a note, so we remove the targets
+ ;; FIXME???
+ (remove-text-properties 0 (length text) '(target nil) text))
+ (org-beamer-get-special props)
+ (setq text (org-trim text))
+ (setq have-text (string-match "\\S-" text))
+ (setq in (org-fill-template
+ (nth 2 ass)
+ (list (cons "a" (or action ""))
+ (cons "A" (or defaction ""))
+ (cons "o" (or option ""))
+ (cons "x" (if extra (concat "\n" extra) ""))
+ (cons "h" "%s")
+ (cons "H" (if have-text (concat "{" text "}") ""))
+ (cons "U" (if have-text (concat "[" text "]") ""))))
+ out (nth 3 ass))
+ (cond
+ ((equal out "\\end{columns}")
+ (setq org-beamer-columns-open t)
+ (setq out (org-add-props (copy-sequence out)
+ '(org-insert-hook
+ (lambda ()
+ (org-beamer-close-column-maybe)
+ (setq org-beamer-columns-open nil))))))
+ ((equal out "\\end{column}")
+ (org-beamer-open-columns-maybe)))
+ (cons text (list in out in out)))
+ ((and (not org-beamer-inside-frame-at-level)
+ (or (not frame-level)
+ (< level frame-level))
+ (assoc level default))
+ ;; Normal sectioning
+ (cons text (cdr (assoc level default))))
+ (t nil))))
+
+(defvar extra)
+(defvar option)
+(defvar action)
+(defvar defaction)
+(defvar environment)
+(defun org-beamer-get-special (props)
+ "Extract an option, action, and default action string from text.
+The variables option, action, defaction, extra are all scoped into
+this function dynamically."
+ (let (tmp)
+ (setq environment (org-beamer-assoc-not-empty "BEAMER_env" props))
+ (setq extra (org-beamer-assoc-not-empty "BEAMER_extra" props))
+ (when extra
+ (setq extra (replace-regexp-in-string "\\\\n" "\n" extra)))
+ (setq tmp (org-beamer-assoc-not-empty "BEAMER_envargs" props))
+ (when tmp
+ (setq tmp (copy-sequence tmp))
+ (if (string-match "\\[<[^][<>]*>\\]" tmp)
+ (setq defaction (match-string 0 tmp)
+ tmp (replace-match "" t t tmp)))
+ (if (string-match "\\[[^][]*\\]" tmp)
+ (setq option (match-string 0 tmp)
+ tmp (replace-match "" t t tmp)))
+ (if (string-match "<[^<>]*>" tmp)
+ (setq action (match-string 0 tmp)
+ tmp (replace-match "" t t tmp))))))
+
+(defun org-beamer-assoc-not-empty (elt list)
+ (let ((tmp (cdr (assoc elt list))))
+ (and tmp (string-match "\\S-" tmp) tmp)))
+
+
+(defvar org-beamer-mode-map (make-sparse-keymap)
+ "The keymap for `org-beamer-mode'.")
+(define-key org-beamer-mode-map "\C-c\C-b" 'org-beamer-select-environment)
+
+(define-minor-mode org-beamer-mode
+ "Special support for editing Org-mode files made to export to beamer."
+ nil " Bm" nil)
+(when (fboundp 'font-lock-add-keywords)
+ (font-lock-add-keywords
+ 'org-mode
+ '((":\\(B_[a-z]+\\|BMCOL\\):" 1 'org-beamer-tag prepend))
+ 'prepent))
+
+(defun org-beamer-place-default-actions-for-lists ()
+ "Find default overlay specifications in items, and move them.
+The need to be after the begin statement of the environment."
+ (when org-beamer-export-is-beamer-p
+ (let (dovl)
+ (goto-char (point-min))
+ (while (re-search-forward
+ "^[ \t]*\\\\begin{\\(itemize\\|enumerate\\|description\\)}[ \t\n]*\\\\item\\>\\( ?\\(<[^<>\n]*>\\|\\[[^][\n*]\\]\\)\\)?[ \t]*\\S-" nil t)
+ (if (setq dovl (cdr (assoc "BEAMER_dovl"
+ (get-text-property (match-end 0)
+ 'org-props))))
+ (save-excursion
+ (goto-char (1+ (match-end 1)))
+ (insert dovl)))))))
+
+(defun org-beamer-amend-header ()
+ "Add `org-beamer-header-extra' to the LaTeX header.
+If the file contains the string BEAMER-HEADER-EXTRA-HERE on a line
+by itself, it will be replaced with `org-beamer-header-extra'. If not,
+the value will be inserted right after the documentclass statement."
+ (when (and org-beamer-export-is-beamer-p
+ org-beamer-header-extra)
+ (goto-char (point-min))
+ (cond
+ ((re-search-forward
+ "^[ \t]*\\[?BEAMER-HEADER-EXTRA\\(-HERE\\)?\\]?[ \t]*$" nil t)
+ (replace-match org-beamer-header-extra t t)
+ (or (bolp) (insert "\n")))
+ ((re-search-forward "^[ \t]*\\\\begin{document}" nil t)
+ (beginning-of-line 1)
+ (insert org-beamer-header-extra)
+ (or (bolp) (insert "\n"))))))
+
+(defcustom org-beamer-fragile-re "^[ \t]*\\\\begin{\\(verbatim\\|lstlisting\\)}"
+ "If this regexp matches in a frame, the frame is marked as fragile."
+ :group 'org-beamer
+ :type 'regexp)
+
+(defface org-beamer-tag '((t (:box (:line-width 1 :color grey40))))
+ "The special face for beamer tags."
+ :group 'org-beamer)
+
+
+;; Functions to initialize and post-process
+;; These fuctions will be hooked into various places in the export process
+
+(defun org-beamer-initialize-open-trackers ()
+ "Reset variables that track if certain environments are open during export."
+ (setq org-beamer-columns-open nil)
+ (setq org-beamer-column-open nil)
+ (setq org-beamer-inside-frame-at-level nil)
+ (setq org-beamer-export-is-beamer-p nil))
+
+(defun org-beamer-after-initial-vars ()
+ "Find special settings for beamer and store them.
+The effect is that these values will be accessible during export."
+ ;; First verify that we are exporting using the beamer class
+ (setq org-beamer-export-is-beamer-p
+ (string-match "\\\\documentclass\\(\\[[^][]*?\\]\\)?{beamer}"
+ org-export-latex-header))
+ (when org-beamer-export-is-beamer-p
+ ;; Find the frame level
+ (setq org-beamer-frame-level-now
+ (or (and (org-region-active-p)
+ (save-excursion
+ (goto-char (region-beginning))
+ (and (looking-at org-complex-heading-regexp)
+ (org-entry-get nil "BEAMER_FRAME_LEVEL" 'selective))))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (and (re-search-forward
+ "^#\\+BEAMER_FRAME_LEVEL:[ \t]*\\(.*?\\)[ \t]*$" nil t)
+ (match-string 1))))
+ (plist-get org-export-latex-options-plist :beamer-frame-level)
+ org-beamer-frame-level))
+ ;; Normalize the value so that the functions can trust the value
+ (cond
+ ((not org-beamer-frame-level-now)
+ (setq org-beamer-frame-level-now nil))
+ ((stringp org-beamer-frame-level-now)
+ (setq org-beamer-frame-level-now
+ (string-to-number org-beamer-frame-level-now))))
+ ;; Find the header additons, most likely theme commands
+ (setq org-beamer-header-extra
+ (or (and (org-region-active-p)
+ (save-excursion
+ (goto-char (region-beginning))
+ (and (looking-at org-complex-heading-regexp)
+ (org-entry-get nil "BEAMER_HEADER_EXTRA"
+ 'selective))))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (let ((txt ""))
+ (goto-char (point-min))
+ (while (re-search-forward
+ "^#\\+BEAMER_HEADER_EXTRA:[ \t]*\\(.*?\\)[ \t]*$"
+ nil t)
+ (setq txt (concat txt "\n" (match-string 1))))
+ (if (> (length txt) 0) (substring txt 1)))))
+ (plist-get org-export-latex-options-plist
+ :beamer-header-extra)))
+ (let ((inhibit-read-only t)
+ (case-fold-search nil)
+ props)
+ (org-unmodified
+ (remove-text-properties (point-min) (point-max) '(org-props nil))
+ (org-map-entries
+ '(progn
+ (setq props (org-entry-properties nil 'standard))
+ (if (and (not (assoc "BEAMER_env" props))
+ (looking-at ".*?:B_\\(note\\(NH\\)?\\):"))
+ (push (cons "BEAMER_env" (match-string 1)) props))
+ (put-text-property (point-at-bol) (point-at-eol) 'org-props props)))
+ (setq org-export-latex-options-plist
+ (plist-put org-export-latex-options-plist :tags nil))))))
+
+(defun org-beamer-auto-fragile-frames ()
+ "Mark any frames containing verbatim environments as fragile.
+This function will run in the final LaTeX document."
+ (when org-beamer-export-is-beamer-p
+ (let (opts)
+ (goto-char (point-min))
+ ;; Find something that might be fragile
+ (while (re-search-forward org-beamer-fragile-re nil t)
+ (save-excursion
+ ;; Are we inside a frame here?
+ (when (and (re-search-backward "^[ \t]*\\\\\\(begin\\|end\\){frame}"
+ nil t)
+ (equal (match-string 1) "begin"))
+ ;; yes, inside a frame, make sure "fragile" is one of the options
+ (goto-char (match-end 0))
+ (if (not (looking-at "\\[.*?\\]"))
+ (insert "[fragile]")
+ (setq opts (substring (match-string 0) 1 -1))
+ (delete-region (match-beginning 0) (match-end 0))
+ (setq opts (org-split-string opts ","))
+ (add-to-list 'opts "fragile")
+ (insert "[" (mapconcat 'identity opts ",") "]"))))))))
+
+(defcustom org-beamer-outline-frame-title "Outline"
+ "Default title of a frame containing an outline."
+ :group 'org-beamer
+ :type '(string :tag "Outline frame title")
+)
+
+(defcustom org-beamer-outline-frame-options nil
+ "Outline frame options appended after \\begin{frame}.
+You might want to put e.g. [allowframebreaks=0.9] here. Remember to
+include square brackets."
+ :group 'org-beamer
+ :type '(string :tag "Outline frame options")
+)
+
+(defun org-beamer-fix-toc ()
+ "Fix the table of contents by removing the vspace line."
+ (when org-beamer-export-is-beamer-p
+ (save-excursion
+ (goto-char (point-min))
+ (when (re-search-forward "\\(\\\\setcounter{tocdepth.*\n\\\\tableofcontents.*\n\\)\\(\\\\vspace\\*.*\\)"
+ nil t)
+ (replace-match
+ (concat "\\\\begin{frame}" org-beamer-outline-frame-options
+ "\n\\\\frametitle{"
+ org-beamer-outline-frame-title
+ "}\n\\1\\\\end{frame}")
+ t nil)))))
+
+(defun org-beamer-property-changed (property value)
+ "Track the BEAMER_env property with tags."
+ (cond
+ ((equal property "BEAMER_env")
+ (save-excursion
+ (org-back-to-heading t)
+ (let ((tags (org-get-tags)))
+ (setq tags (delq nil (mapcar (lambda (x)
+ (if (string-match "^B_" x) nil x))
+ tags)))
+ (org-set-tags-to tags))
+ (when (and value (stringp value) (string-match "\\S-" value))
+ (org-toggle-tag (concat "B_" value) 'on))))
+ ((equal property "BEAMER_col")
+ (org-toggle-tag "BMCOL" (if (and value (string-match "\\S-" value))
+ 'on 'off)))))
+
+(defun org-beamer-select-beamer-code ()
+ "Take code marked for BEAMER and turn it into marked for LaTeX."
+ (when org-beamer-export-is-beamer-p
+ (goto-char (point-min))
+ (while (re-search-forward
+ "^\\([ \]*#\\+\\(begin_\\|end_\\)?\\)\\(beamer\\)\\>" nil t)
+ (replace-match "\\1latex"))))
+
+;; OK, hook all these functions into appropriate places
+(add-hook 'org-export-first-hook
+ 'org-beamer-initialize-open-trackers)
+(add-hook 'org-property-changed-functions
+ 'org-beamer-property-changed)
+(add-hook 'org-export-latex-after-initial-vars-hook
+ 'org-beamer-after-initial-vars)
+(add-hook 'org-export-latex-final-hook
+ 'org-beamer-place-default-actions-for-lists)
+(add-hook 'org-export-latex-final-hook
+ 'org-beamer-auto-fragile-frames)
+(add-hook 'org-export-latex-final-hook
+ 'org-beamer-fix-toc)
+(add-hook 'org-export-latex-final-hook
+ 'org-beamer-amend-header)
+(add-hook 'org-export-preprocess-before-selecting-backend-code-hook
+ 'org-beamer-select-beamer-code)
+
+(defun org-insert-beamer-options-template (kind)
+ "Insert a settings template, to make sure users do this right."
+ (interactive (progn
+ (message "Current [s]ubtree or [g]lobal?")
+ (if (equal (read-char-exclusive) ?g)
+ (list 'global)
+ (list 'subtree))))
+ (if (eq kind 'subtree)
+ (progn
+ (org-back-to-heading t)
+ (org-reveal)
+ (org-entry-put nil "LaTeX_CLASS" "beamer")
+ (org-entry-put nil "LaTeX_CLASS_OPTIONS" "[presentation]")
+ (org-entry-put nil "EXPORT_FILE_NAME" "presentation.pdf")
+ (org-entry-put nil "BEAMER_FRAME_LEVEL" (number-to-string
+ org-beamer-frame-level))
+ (when org-beamer-themes
+ (org-entry-put nil "BEAMER_HEADER_EXTRA" org-beamer-themes))
+ (when org-beamer-column-view-format
+ (org-entry-put nil "COLUMNS" org-beamer-column-view-format))
+ (org-entry-put nil "BEAMER_col_ALL" "0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 1.0 :ETC"))
+ (insert "#+LaTeX_CLASS: beamer\n")
+ (insert "#+LaTeX_CLASS_OPTIONS: [presentation]\n")
+ (insert (format "#+BEAMER_FRAME_LEVEL: %d\n" org-beamer-frame-level) "\n")
+ (when org-beamer-themes
+ (insert "#+BEAMER_HEADER_EXTRA: " org-beamer-themes "\n"))
+ (when org-beamer-column-view-format
+ (insert "#+COLUMNS: " org-beamer-column-view-format "\n"))
+ (insert "#+PROPERTY: BEAMER_col_ALL 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 1.0 :ETC\n")))
+
+
+(defun org-beamer-allowed-property-values (property)
+ "Supply allowed values for BEAMER properties."
+ (cond
+ ((and (equal property "BEAMER_env")
+ (not (org-entry-get nil (concat property "_ALL") 'inherit)))
+ ;; If no allowed values for BEAMER_env have been defined,
+ ;; supply all defined environments
+ (mapcar 'car (append org-beamer-environments-extra
+ org-beamer-environments-default)))
+ ((and (equal property "BEAMER_col")
+ (not (org-entry-get nil (concat property "_ALL") 'inherit)))
+ ;; If no allowed values for BEAMER_col have been defined,
+ ;; supply some
+ '("0.1" "0.2" "0.3" "0.4" "0.5" "0.6" "0.7" "0.8" "0.9" "" ":ETC"))
+ (t nil)))
+
+(add-hook 'org-property-allowed-value-functions
+ 'org-beamer-allowed-property-values)
+
+(provide 'org-beamer)
+
+;; arch-tag: 68bac91a-a946-43a3-8173-a9269306f67c
+
+;;; org-beamer.el ends here
diff --git a/lisp/org/org-bibtex.el b/lisp/org/org-bibtex.el
index 7f9d99a180d..b9018b023ba 100644
--- a/lisp/org/org-bibtex.el
+++ b/lisp/org/org-bibtex.el
@@ -5,7 +5,7 @@
;; Author: Bastien Guerry <bzg at altern dot org>
;; Carsten Dominik <carsten dot dominik at gmail dot com>
;; Keywords: org, wp, remember
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
diff --git a/lisp/org/org-capture.el b/lisp/org/org-capture.el
new file mode 100644
index 00000000000..2abe5c72bf6
--- /dev/null
+++ b/lisp/org/org-capture.el
@@ -0,0 +1,1362 @@
+;;; org-capture.el --- Fast note taking in Org-mode
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Carsten Dominik <carsten at orgmode dot org>
+;; Keywords: outlines, hypermedia, calendar, wp
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+;;
+;; This file is part of GNU Emacs.
+;;
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;; Commentary:
+
+;; This file contains an alternative implementation of the same functionality
+;; that is also provided by org-remember.el. The implementation is more
+;; streamlined, can produce more target types (e.g. plain list items or
+;; table lines). Also, it does not use a temporary buffer for editing
+;; the captured entry - instead it uses an indirect buffer that visits
+;; the new entry already in the target buffer (this was an idea by Samuel
+;; Wales). John Wiegley's excellent `remember.el' is not needed for this
+;; implementation, even though we borrow heavily from its ideas.
+
+;; This implementation heavily draws on ideas by James TD Smith and
+;; Samuel Wales, and, of cause, uses John Wiegley's remember.el as inspiration.
+
+;;; TODO
+
+;; - find a clever way to not always insert an annotation maybe a
+;; predicate function that can check for conditions for %a to be
+;; used. This could be one of the properties.
+
+;; - Should there be plist members that arrange for properties to be
+;; asked for, like James proposed in his RFC?
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+(require 'org)
+(require 'org-mks)
+
+(declare-function org-datetree-find-date-create "org-datetree"
+ (DATE &optional KEEP-RESTRICTION))
+(declare-function org-table-get-specials "org-table" ())
+(declare-function org-table-goto-line "org-table" (N))
+(defvar org-remember-default-headline)
+(defvar org-remember-templates)
+(defvar org-table-hlines)
+
+(defvar org-capture-clock-was-started nil
+ "Internal flag, noting if the clock was started.")
+
+(defvar org-capture-last-stored-marker (make-marker)
+ "Marker pointing to the entry most recently stored with `org-capture'.")
+
+;; The following variable is scoped dynamically by org-protocol
+;; to indicate that the link properties have already been stored
+(defvar org-capture-link-is-already-stored nil)
+
+(defgroup org-capture nil
+ "Options concerning capturing new entries."
+ :tag "Org Capture"
+ :group 'org)
+
+(defcustom org-capture-templates nil
+ "Templates for the creation of new entries.
+
+Each entry is a list with the following items:
+
+keys The keys that will select the template, as a string, characters
+ only, for example \"a\" for a template to be selected with a
+ single key, or \"bt\" for selection with two keys. When using
+ several keys, keys using the same prefix key must be together
+ in the list and preceded by a 2-element entry explaining the
+ prefix key, for example
+
+ (\"b\" \"Templates for marking stuff to buy\")
+
+ The \"C\" key is used by default for quick access to the
+ customization of the template variable. But if you want to use
+ that key for a template, you can.
+
+description A short string describing the template, will be shown during
+ selection.
+
+type The type of entry. Valid types are:
+ entry an Org-mode node, with a headline. Will be
+ filed as the child of the target entry or as
+ a top-level entry.
+ item a plain list item, will be placed in the
+ first plain list at the target
+ location.
+ checkitem a checkbox item. This differs from the
+ plain list item only is so far as it uses a
+ different default template.
+ table-line a new line in the first table at target location.
+ plain text to be inserted as it is.
+
+target Specification of where the captured item should be placed.
+ In Org-mode files, targets usually define a node. Entries will
+ become children of this node, other types will be added to the
+ table or list in the body of this node.
+
+ Valid values are:
+
+ (file \"path/to/file\")
+ Text will be placed at the beginning or end of that file
+
+ (id \"id of existing org entry\")
+ File as child of this entry, or in the body of the entry
+
+ (file+headline \"path/to/file\" \"node headline\")
+ Fast configuration if the target heading is unique in the file
+
+ (file+olp \"path/to/file\" \"Level 1 heading\" \"Level 2\" ...)
+ For non-unique headings, the full path is safer
+
+ (file+regexp \"path/to/file\" \"regexp to find location\")
+ File to the entry matching regexp
+
+ (file+datetree \"path/to/file\")
+ Will create a heading in a date tree
+
+ (file+function \"path/to/file\" function-finding-location)
+ A function to find the right location in the file
+
+ (clock)
+ File to the entry that is currently being clocked
+
+ (function function-finding-location)
+ Most general way, write your own function to find both
+ file and location
+
+template The template for creating the capture item. If you leave this
+ empty, an appropriate default template will be used. See below
+ for more details. Instead of a string, this may also be one of
+
+ (file \"/path/to/template-file\")
+ (function function-returning-the-template)
+
+ in order to get a template from a file, or dynamically
+ from a function.
+
+The rest of the entry is a property list of additional options. Recognized
+properties are:
+
+ :prepend Normally newly captured information will be appended at
+ the target location (last child, last table line,
+ last list item...). Setting this property will
+ change that.
+
+ :immediate-finish When set, do not offer to edit the information, just
+ file it away immediately. This makes sense if the
+ template only needs information that can be added
+ automatically.
+
+ :empty-lines Set this to the number of lines the should be inserted
+ before and after the new item. Default 0, only common
+ other value is 1.
+
+ :clock-in Start the clock in this item.
+
+ :clock-resume Start the interrupted clock when finishing the capture.
+
+ :unnarrowed Do not narrow the target buffer, simply show the
+ full buffer. Default is to narrow it so that you
+ only see the new stuff.
+
+ :table-line-pos Specification of the location in the table where the
+ new line should be inserted. It looks like \"II-3\"
+ which means that the new line should become the third
+ line before the second horizontal separator line.
+
+ :kill-buffer If the target file was not yet visited by a buffer when
+ capture was invoked, kill the buffer again after capture
+ is finalized.
+
+The template defines the text to be inserted. Often this is an org-mode
+entry (so the first line should start with a star) that will be filed as a
+child of the target headline. It can also be freely formatted text.
+Furthermore, the following %-escapes will be replaced with content:
+
+ %^{prompt} prompt the user for a string and replace this sequence with it.
+ A default value and a completion table ca be specified like this:
+ %^{prompt|default|completion2|completion3|...}
+ %t time stamp, date only
+ %T time stamp with date and time
+ %u, %U like the above, but inactive time stamps
+ %^t like %t, but prompt for date. Similarly %^T, %^u, %^U.
+ You may define a prompt like %^{Please specify birthday
+ %n user name (taken from `user-full-name')
+ %a annotation, normally the link created with `org-store-link'
+ %i initial content, copied from the active region. If %i is
+ indented, the entire inserted text will be indented as well.
+ %c current kill ring head
+ %x content of the X clipboard
+ %^C interactive selection of which kill or clip to use
+ %^L like %^C, but insert as link
+ %k title of currently clocked task
+ %K link to currently clocked task
+ %^g prompt for tags, with completion on tags in target file
+ %^G prompt for tags, with completion on all tags in all agenda files
+ %^{prop}p prompt the user for a value for property `prop'
+ %:keyword specific information for certain link types, see below
+ %[pathname] insert the contents of the file given by `pathname'
+ %(sexp) evaluate elisp `(sexp)' and replace with the result
+
+ %? After completing the template, position cursor here.
+
+Apart from these general escapes, you can access information specific to the
+link type that is created. For example, calling `org-capture' in emails
+or gnus will record the author and the subject of the message, which you
+can access with \"%:from\" and \"%:subject\", respectively. Here is a
+complete list of what is recorded for each link type.
+
+Link type | Available information
+------------------------+------------------------------------------------------
+bbdb | %:type %:name %:company
+vm, wl, mh, mew, rmail | %:type %:subject %:message-id
+ | %:from %:fromname %:fromaddress
+ | %:to %:toname %:toaddress
+ | %:fromto (either \"to NAME\" or \"from NAME\")
+ | %:date
+ | %:date-timestamp (as active timestamp)
+ | %:date-timestamp-inactive (as inactive timestamp)
+gnus | %:group, for messages also all email fields
+w3, w3m | %:type %:url
+info | %:type %:file %:node
+calendar | %:type %:date"
+ :group 'org-capture
+ :type
+ '(repeat
+ (choice :value ("" "" entry (file "~/org/notes.org") "")
+ (list :tag "Multikey description"
+ (string :tag "Keys ")
+ (string :tag "Description"))
+ (list :tag "Template entry"
+ (string :tag "Keys ")
+ (string :tag "Description ")
+ (choice :tag "Capture Type " :value entry
+ (const :tag "Org entry" entry)
+ (const :tag "Plain list item" item)
+ (const :tag "Checkbox item" checkitem)
+ (const :tag "Plain text" plain)
+ (const :tag "Table line" table-line))
+ (choice :tag "Target location"
+ (list :tag "File"
+ (const :format "" file)
+ (file :tag " File"))
+ (list :tag "ID"
+ (const :format "" id)
+ (string :tag " ID"))
+ (list :tag "File & Headline"
+ (const :format "" file+headline)
+ (file :tag " File ")
+ (string :tag " Headline"))
+ (list :tag "File & Outline path"
+ (const :format "" file+olp)
+ (file :tag " File ")
+ (repeat :tag "Outline path" :inline t
+ (string :tag "Headline")))
+ (list :tag "File & Regexp"
+ (const :format "" file+regexp)
+ (file :tag " File ")
+ (regexp :tag " Regexp"))
+ (list :tag "File & Date tree"
+ (const :format "" file+datetree)
+ (file :tag " File"))
+ (list :tag "File & function"
+ (const :format "" file+function)
+ (file :tag " File ")
+ (sexp :tag " Function"))
+ (list :tag "Current clocking task"
+ (const :format "" clock))
+ (list :tag "Function"
+ (const :format "" function)
+ (sexp :tag " Function")))
+ (choice :tag "Template"
+ (string)
+ (list :tag "File"
+ (const :format "" file)
+ (file :tag "Template file"))
+ (list :tag "Function"
+ (const :format "" function)
+ (function :tag "Template function")))
+ (plist :inline t
+ ;; Give the most common options as checkboxes
+ :options (((const :format "%v " :prepend) (const t))
+ ((const :format "%v " :immediate-finish) (const t))
+ ((const :format "%v " :empty-lines) (const 1))
+ ((const :format "%v " :clock-in) (const t))
+ ((const :format "%v " :clock-resume) (const t))
+ ((const :format "%v " :unnarrowed) (const t))
+ ((const :format "%v " :kill-buffer) (const t))))))))
+
+(defcustom org-capture-before-finalize-hook nil
+ "Hook that is run right before a remember process is finalized.
+The remember buffer is still current when this hook runs."
+ :group 'org-capture
+ :type 'hook)
+
+;;; The property list for keeping information about the capture process
+
+(defvar org-capture-plist nil
+ "Plist for the current capture process, global, to avoid having to pass it.")
+(defvar org-capture-current-plist nil
+ "Local variable holding the plist in a capture buffer.
+This is used to store the plist for use when finishing a capture process.
+Another such process might have changed the global variable by then.")
+
+(defun org-capture-put (&rest stuff)
+ (while stuff
+ (setq org-capture-plist (plist-put org-capture-plist
+ (pop stuff) (pop stuff)))))
+(defun org-capture-get (prop &optional local)
+ (plist-get (if local org-capture-current-plist org-capture-plist) prop))
+
+(defun org-capture-member (prop)
+ (plist-get org-capture-plist prop))
+
+;;; The minor mode
+
+(defvar org-capture-mode-map (make-sparse-keymap)
+ "Keymap for `org-capture-mode', a minor mode.
+Use this map to set additional keybindings for when Org-mode is used
+for a Remember buffer.")
+
+(defvar org-capture-mode-hook nil
+ "Hook for the minor `org-capture-mode'.")
+
+(define-minor-mode org-capture-mode
+ "Minor mode for special key bindings in a remember buffer."
+ nil " Rem" org-capture-mode-map
+ (org-set-local
+ 'header-line-format
+ "Capture buffer. Finish `C-c C-c', refile `C-c C-w', abort `C-c C-k'.")
+ (run-hooks 'org-capture-mode-hook))
+(define-key org-capture-mode-map "\C-c\C-c" 'org-capture-finalize)
+(define-key org-capture-mode-map "\C-c\C-k" 'org-capture-kill)
+(define-key org-capture-mode-map "\C-c\C-w" 'org-capture-refile)
+
+;;; The main commands
+
+;;;###autoload
+(defun org-capture (&optional goto keys)
+ "Capture something.
+\\<org-capture-mode-map>
+This will let you select a template from `org-capture-templates', and then
+file the newly captured information. The text is immediately inserted
+at the target location, and an indirect buffer is shown where you can
+edit it. Pressing \\[org-capture-finalize] brings you back to the previous state
+of Emacs, so that you can continue your work.
+
+When called interactively with a \\[universal-argument] prefix argument GOTO, don't capture
+anything, just go to the file/headline where the selected template
+stores its notes. With a double prefix argument \
+\\[universal-argument] \\[universal-argument], go to the last note
+stored.
+
+When called with a `C-0' (zero) prefix, insert a template at point.
+
+Lisp programs can set KEYS to a string associated with a template in
+`org-capture-templates'. In this case, interactive selection will be
+bypassed."
+ (interactive "P")
+ (cond
+ ((equal goto '(4)) (org-capture-goto-target))
+ ((equal goto '(16)) (org-capture-goto-last-stored))
+ (t
+ ;; FIXME: Are these needed?
+ (let* ((orig-buf (current-buffer))
+ (annotation (if (and (boundp 'org-capture-link-is-already-stored)
+ org-capture-link-is-already-stored)
+ (plist-get org-store-link-plist :annotation)
+ (org-store-link nil)))
+ (initial (and (org-region-active-p)
+ (buffer-substring (point) (mark))))
+ (entry (org-capture-select-template keys)))
+ (when (stringp initial)
+ (remove-text-properties 0 (length initial) '(read-only t) initial))
+ (when (stringp annotation)
+ (remove-text-properties 0 (length annotation)
+ '(read-only t) annotation))
+ (cond
+ ((equal entry "C")
+ (customize-variable 'org-capture-templates))
+ ((equal entry "q")
+ (error "Abort"))
+ (t
+ (org-capture-set-plist entry)
+ (org-capture-get-template)
+ (org-capture-put :original-buffer orig-buf :annotation annotation
+ :initial initial)
+ (org-capture-put :default-time
+ (or org-overriding-default-time
+ (org-current-time)))
+ (org-capture-set-target-location)
+ (condition-case error
+ (org-capture-put :template (org-capture-fill-template))
+ ((error quit)
+ (if (get-buffer "*Capture*") (kill-buffer "*Capture*"))
+ (error "Capture abort: %s" error)))
+
+ (if (equal goto 0)
+ ;;insert at point
+ (org-capture-insert-template-here)
+ (condition-case error
+ (org-capture-place-template)
+ ((error quit)
+ (if (and (buffer-base-buffer (current-buffer))
+ (string-match "\\`CAPTURE-" (buffer-name)))
+ (kill-buffer (current-buffer)))
+ (set-window-configuration (org-capture-get :return-to-wconf))
+ (error "Capture template `%s': %s"
+ (org-capture-get :key)
+ (nth 1 error))))
+ (if (org-capture-get :immediate-finish)
+ (org-capture-finalize)
+ (if (and (org-mode-p)
+ (org-capture-get :clock-in))
+ (condition-case nil
+ (progn
+ (if (org-clock-is-active)
+ (org-capture-put :interrupted-clock
+ (copy-marker org-clock-marker)))
+ (org-clock-in)
+ (org-set-local 'org-capture-clock-was-started t))
+ (error
+ "Could not start the clock in this capture buffer")))))))))))
+
+
+(defun org-capture-get-template ()
+ "Get the template from a file or a function if necessary."
+ (let ((txt (org-capture-get :template)) file)
+ (cond
+ ((and (listp txt) (eq (car txt) 'file))
+ (if (file-exists-p
+ (setq file (expand-file-name (nth 1 txt) org-directory)))
+ (setq txt (org-file-contents file))
+ (setq txt (format "* Template file %s not found" (nth 1 txt)))))
+ ((and (listp txt) (eq (car txt) 'function))
+ (if (fboundp (nth 1 txt))
+ (setq txt (funcall (nth 1 txt)))
+ (setq txt (format "* Template function %s not found" (nth 1 txt)))))
+ ((not txt) (setq txt ""))
+ ((stringp txt))
+ (t (setq txt "* Invalid capture template")))
+ (org-capture-put :template txt)))
+
+(defun org-capture-finalize ()
+ "Finalize the capture process."
+ (interactive)
+ (unless (and org-capture-mode
+ (buffer-base-buffer (current-buffer)))
+ (error "This does not seem to be a capture buffer for Org-mode"))
+
+ ;; Did we start the clock in this capture buffer?
+ (when (and org-capture-clock-was-started
+ org-clock-marker (marker-buffer org-clock-marker)
+ (equal (marker-buffer org-clock-marker) (buffer-base-buffer))
+ (> org-clock-marker (point-min))
+ (< org-clock-marker (point-max)))
+ ;; Looks like the clock we started is still running. Clock out.
+ (let (org-log-note-clock-out) (org-clock-out))
+ (when (and (org-capture-get :clock-resume 'local)
+ (markerp (org-capture-get :interrupted-clock 'local))
+ (buffer-live-p (marker-buffer
+ (org-capture-get :interrupted-clock 'local))))
+ (let ((clock-in-task (org-capture-get :interrupted-clock 'local)))
+ (org-with-point-at clock-in-task
+ (org-clock-in)))
+ (message "Interrupted clock has been resumed")))
+
+ (let ((beg (point-min))
+ (end (point-max))
+ (abort-note nil))
+ (widen)
+
+ (if org-note-abort
+ (let ((m1 (org-capture-get :begin-marker 'local))
+ (m2 (org-capture-get :end-marker 'local)))
+ (if (and m1 m2 (= m1 beg) (= m2 end))
+ (progn
+ (setq abort-note 'clean)
+ (kill-region m1 m2))
+ (setq abort-note 'dirty)))
+
+ ;; Make sure that the empty lines after are correct
+ (when (and (> (point-max) end) ; indeed, the buffer was still narrowed
+ (member (org-capture-get :type 'local)
+ '(entry item checkitem plain)))
+ (save-excursion
+ (goto-char end)
+ (or (bolp) (newline))
+ (org-capture-empty-lines-after
+ (or (org-capture-get :empty-lines 'local) 0))))
+ ;; Postprocessing: Update Statistics cookies, do the sorting
+ (when (org-mode-p)
+ (save-excursion
+ (when (ignore-errors (org-back-to-heading))
+ (org-update-parent-todo-statistics)
+ (org-update-checkbox-count)))
+ ;; FIXME Here we should do the sorting
+ ;; If we have added a table line, maybe recompute?
+ (when (and (eq (org-capture-get :type 'local) 'table-line)
+ (org-at-table-p))
+ (if (org-table-get-stored-formulas)
+ (org-table-recalculate 'all) ;; FIXME: Should we iterate???
+ (org-table-align)))
+ )
+ ;; Store this place as the last one where we stored something
+ ;; Do the marking in the base buffer, so that it makes sense after
+ ;; the indirect buffer has been killed.
+ (org-capture-bookmark-last-stored-position)
+
+ ;; Run the hook
+ (run-hooks 'org-capture-before-finalize-hook)
+ )
+
+ ;; Kill the indirect buffer
+ (save-buffer)
+ (let ((return-wconf (org-capture-get :return-to-wconf 'local))
+ (new-buffer (org-capture-get :new-buffer 'local))
+ (kill-buffer (org-capture-get :kill-buffer 'local))
+ (base-buffer (buffer-base-buffer (current-buffer))))
+
+ ;; Kill the indiret buffer
+ (kill-buffer (current-buffer))
+
+ ;; Kill the target buffer if that is desired
+ (when (and base-buffer new-buffer kill-buffer)
+ (with-current-buffer base-buffer (save-buffer))
+ (kill-buffer base-buffer))
+
+ ;; Restore the window configuration before capture
+ (set-window-configuration return-wconf))
+ (when abort-note
+ (cond
+ ((equal abort-note 'clean)
+ (message "Capture process aborted and target buffer cleaned up"))
+ ((equal abort-note 'dirty)
+ (error "Capture process aborted, but target buffer could not be cleaned up correctly"))))))
+
+(defun org-capture-refile ()
+ "Finalize the current capture and then refile the entry.
+Refiling is done from the base buffer, because the indirect buffer is then
+already gone."
+ (interactive)
+ (unless (eq (org-capture-get :type 'local) 'entry)
+ (error
+ "Refiling from a capture buffer makes only sense for `entry'-type templates"))
+ (let ((pos (point))
+ (base (buffer-base-buffer (current-buffer)))
+ (org-refile-for-capture t))
+ (org-capture-finalize)
+ (save-window-excursion
+ (with-current-buffer (or base (current-buffer))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char pos)
+ (call-interactively 'org-refile)))))))
+
+(defun org-capture-kill ()
+ "Abort the current capture process."
+ (interactive)
+ ;; FIXME: This does not do the right thing, we need to remove the new stuff
+ ;; By hand it is easy: undo, then kill the buffer
+ (let ((org-note-abort t) (org-capture-before-finalize-hook nil))
+ (org-capture-finalize)))
+
+(defun org-capture-goto-last-stored ()
+ "Go to the location where the last remember note was stored."
+ (interactive)
+ (org-goto-marker-or-bmk org-capture-last-stored-marker
+ "org-capture-last-stored")
+ (message "This is the last note stored by a capture process"))
+
+;;; Supporting functions for handling the process
+
+(defun org-capture-set-target-location (&optional target)
+ "Find target buffer and position and store then in the property list."
+ (let ((target-entry-p t))
+ (setq target (or target (org-capture-get :target)))
+ (save-excursion
+ (cond
+ ((eq (car target) 'file)
+ (set-buffer (org-capture-target-buffer (nth 1 target)))
+ (setq target-entry-p nil))
+
+ ((eq (car target) 'id)
+ (let ((loc (org-id-find (nth 1 target))))
+ (if (not loc)
+ (error "Cannot find target ID \"%s\"" (nth 1 target))
+ (set-buffer (org-capture-target-buffer (car loc)))
+ (goto-char (cdr loc)))))
+
+ ((eq (car target) 'file+headline)
+ (set-buffer (org-capture-target-buffer (nth 1 target)))
+ (let ((hd (nth 2 target)))
+ (goto-char (point-min))
+ (unless (org-mode-p)
+ (error "Target buffer for file+headline should be in Org mode"))
+ (if (re-search-forward
+ (format org-complex-heading-regexp-format (regexp-quote hd))
+ nil t)
+ (goto-char (point-at-bol))
+ (goto-char (point-max))
+ (or (bolp) (insert "\n"))
+ (insert "* " hd "\n")
+ (beginning-of-line 0))))
+
+ ((eq (car target) 'file+olp)
+ (let ((m (org-find-olp (cdr target))))
+ (set-buffer (marker-buffer m))
+ (goto-char m)))
+
+ ((eq (car target) 'file+regexp)
+ (set-buffer (org-capture-target-buffer (nth 1 target)))
+ (goto-char (point-min))
+ (if (re-search-forward (nth 2 target) nil t)
+ (progn
+ (goto-char (if (org-capture-get :prepend)
+ (match-beginning 0) (match-end 0)))
+ (org-capture-put :exact-position (point))
+ (setq target-entry-p (and (org-mode-p) (org-at-heading-p))))
+ (error "No match for target regexp in file %s" (nth 1 target))))
+
+ ((eq (car target) 'file+datetree)
+ (require 'org-datetree)
+ (set-buffer (org-capture-target-buffer (nth 1 target)))
+ ;; Make a date tree entry, with the current date (or yesterday,
+ ;; if we are extending dates for a couple of hours)
+ (org-datetree-find-date-create
+ (calendar-gregorian-from-absolute
+ (if org-overriding-default-time
+ (time-to-days org-overriding-default-time)
+ (time-to-days
+ (time-subtract (current-time)
+ (list 0 (* 3600 org-extend-today-until) 0)))))))
+
+ ((eq (car target) 'file+function)
+ (set-buffer (org-capture-target-buffer (nth 1 target)))
+ (funcall (nth 2 target))
+ (org-capture-put :exact-position (point))
+ (setq target-entry-p (and (org-mode-p) (org-at-heading-p))))
+
+ ((eq (car target) 'function)
+ (funcall (nth 1 target))
+ (org-capture-put :exact-position (point))
+ (setq target-entry-p (and (org-mode-p) (org-at-heading-p))))
+
+ ((eq (car target) 'clock)
+ (if (and (markerp org-clock-hd-marker)
+ (marker-buffer org-clock-hd-marker))
+ (progn (set-buffer (marker-buffer org-clock-hd-marker))
+ (goto-char org-clock-hd-marker))
+ (error "No running clock that could be used as capture target")))
+
+ (t (error "Invalid capture target specification")))
+
+ (org-capture-put :buffer (current-buffer) :pos (point)
+ :target-entry-p target-entry-p))))
+
+(defun org-capture-target-buffer (file)
+ "Get a buffer for FILE."
+ (setq file (or (org-string-nw-p file)
+ org-default-notes-file
+ (error "No notes file specified, and no default available")))
+ (or (org-find-base-buffer-visiting file)
+ (progn (org-capture-put :new-buffer t)
+ (find-file-noselect (expand-file-name file org-directory)))))
+
+(defun org-capture-steal-local-variables (buffer)
+ "Install Org-mode local variables."
+ (mapc (lambda (v)
+ (ignore-errors (org-set-local (car v) (cdr v))))
+ (buffer-local-variables buffer)))
+
+(defun org-capture-place-template ()
+ "Insert the template at the target location, and display the buffer."
+ (org-capture-put :return-to-wconf (current-window-configuration))
+ (delete-other-windows)
+ (org-switch-to-buffer-other-window
+ (org-capture-get-indirect-buffer (org-capture-get :buffer) "CAPTURE"))
+ (widen)
+ (show-all)
+ (goto-char (org-capture-get :pos))
+ (org-set-local 'org-capture-target-marker
+ (move-marker (make-marker) (point)))
+ (let* ((template (org-capture-get :template))
+ (type (org-capture-get :type)))
+ (case type
+ ((nil entry) (org-capture-place-entry))
+ (table-line (org-capture-place-table-line))
+ (plain (org-capture-place-plain-text))
+ (item (org-capture-place-item))
+ (checkitem (org-capture-place-item))))
+ (org-capture-mode 1)
+ (org-set-local 'org-capture-current-plist org-capture-plist))
+
+(defun org-capture-place-entry ()
+ "Place the template as a new Org entry."
+ (let* ((txt (org-capture-get :template))
+ (reversed (org-capture-get :prepend))
+ (target-entry-p (org-capture-get :target-entry-p))
+ level beg end file)
+
+ (cond
+ ((org-capture-get :exact-position)
+ (goto-char (org-capture-get :exact-position)))
+ ((not target-entry-p)
+ ;; Insert as top-level entry, either at beginning or at end of file
+ (setq level 1)
+ (if reversed
+ (progn (goto-char (point-min))
+ (or (org-at-heading-p)
+ (outline-next-heading)))
+ (goto-char (point-max))
+ (or (bolp) (insert "\n"))))
+ (t
+ ;; Insert as a child of the current entry
+ (and (looking-at "\\*+")
+ (setq level (- (match-end 0) (match-beginning 0))))
+ (setq level (org-get-valid-level (or level 1) 1))
+ (if reversed
+ (progn
+ (outline-next-heading)
+ (or (bolp) (insert "\n")))
+ (org-end-of-subtree t t)
+ (or (bolp) (insert "\n")))))
+ (org-capture-empty-lines-before)
+ (setq beg (point))
+ (org-paste-subtree level txt 'for-yank)
+ (org-capture-empty-lines-after 1)
+ (org-capture-position-for-last-stored beg)
+ (outline-next-heading)
+ (setq end (point))
+ (org-capture-mark-kill-region beg (1- end))
+ (org-capture-narrow beg (1- end))
+ (goto-char beg)
+ (if (re-search-forward "%\\?" end t) (replace-match ""))))
+
+(defun org-capture-place-item ()
+ "Place the template as a new plain list item."
+ (let* ((txt (org-capture-get :template))
+ (target-entry-p (org-capture-get :target-entry-p))
+ (ind 0)
+ beg end)
+ (cond
+ ((org-capture-get :exact-position)
+ (goto-char (org-capture-get :exact-position)))
+ ((not target-entry-p)
+ ;; Insert as top-level entry, either at beginning or at end of file
+ (setq beg (point-min) end (point-max)))
+ (t
+ (setq beg (1+ (point-at-eol))
+ end (save-excursion (outline-next-heading) (point)))))
+ (if (org-capture-get :prepend)
+ (progn
+ (goto-char beg)
+ (if (org-search-forward-unenclosed org-item-beginning-re end t)
+ (progn
+ (goto-char (match-beginning 0))
+ (setq ind (org-get-indentation)))
+ (goto-char end)
+ (setq ind 0)))
+ (goto-char end)
+ (if (org-search-backward-unenclosed org-item-beginning-re beg t)
+ (progn
+ (setq ind (org-get-indentation))
+ (org-end-of-item))
+ (setq ind 0)))
+ ;; Remove common indentation
+ (setq txt (org-remove-indentation txt))
+ ;; Make sure this is indeed an item
+ (unless (string-match (concat "\\`" (org-item-re)) txt)
+ (setq txt (concat "- "
+ (mapconcat 'identity (split-string txt "\n")
+ "\n "))))
+ ;; Set the correct indentation, depending on context
+ (setq ind (make-string ind ?\ ))
+ (setq txt (concat ind
+ (mapconcat 'identity (split-string txt "\n")
+ (concat "\n" ind))
+ "\n"))
+ ;; Insert, with surrounding empty lines
+ (org-capture-empty-lines-before)
+ (setq beg (point))
+ (insert txt)
+ (or (bolp) (insert "\n"))
+ (org-capture-empty-lines-after 1)
+ (org-capture-position-for-last-stored beg)
+ (forward-char 1)
+ (setq end (point))
+ (org-capture-mark-kill-region beg (1- end))
+ (org-capture-narrow beg (1- end))
+ (if (re-search-forward "%\\?" end t) (replace-match ""))))
+
+(defun org-capture-place-table-line ()
+ "Place the template as a table line."
+ (require 'org-table)
+ (let* ((txt (org-capture-get :template))
+ (target-entry-p (org-capture-get :target-entry-p))
+ (table-line-pos (org-capture-get :table-line-pos))
+ ind beg end)
+ (cond
+ ((org-capture-get :exact-position)
+ (goto-char (org-capture-get :exact-position)))
+ ((not target-entry-p)
+ ;; Table is not necessarily under a heading
+ (setq beg (point-min) end (point-max)))
+ (t
+ ;; WE are at a heading, limit search to the body
+ (setq beg (1+ (point-at-eol))
+ end (save-excursion (outline-next-heading) (point)))))
+ (if (re-search-forward org-table-dataline-regexp end t)
+ (let ((b (org-table-begin)) (e (org-table-end)))
+ (goto-char e)
+ (if (looking-at "[ \t]*#\\+TBLFM:")
+ (forward-line 1))
+ (narrow-to-region b (point)))
+ (goto-char end)
+ (insert "\n| |\n|----|\n| |\n")
+ (narrow-to-region (1+ end) (point)))
+ ;; We are narrowed to the table, or to an empty line if there was no table
+
+ ;; Check if the template is good
+ (if (not (string-match org-table-dataline-regexp txt))
+ (setq txt "| %?Bad template |\n"))
+ (cond
+ ((and table-line-pos
+ (string-match "\\(I+\\)\\([-+][0-9]\\)" table-line-pos))
+ ;; we have a complex line specification
+ (goto-char (point-min))
+ (let ((nh (- (match-end 1) (match-beginning 1)))
+ (delta (string-to-number (match-string 2 table-line-pos)))
+ ll)
+ ;; The user wants a special position in the table
+ (org-table-get-specials)
+ (setq ll (ignore-errors (aref org-table-hlines nh)))
+ (unless ll (error "Invalid table line specification \"%s\""
+ table-line-pos))
+ (setq ll (+ ll delta (if (< delta 0) 0 -1)))
+ (org-goto-line ll)
+ (org-table-insert-row 'below)
+ (beginning-of-line 1)
+ (delete-region (point) (1+ (point-at-eol)))
+ (setq beg (point))
+ (insert txt)
+ (setq end (point))))
+ ((org-capture-get :prepend)
+ (goto-char (point-min))
+ (re-search-forward org-table-hline-regexp nil t)
+ (beginning-of-line 1)
+ (re-search-forward org-table-dataline-regexp nil t)
+ (beginning-of-line 1)
+ (setq beg (point))
+ (org-table-insert-row)
+ (beginning-of-line 1)
+ (delete-region (point) (1+ (point-at-eol)))
+ (insert txt)
+ (setq end (point)))
+ (t
+ (goto-char (point-max))
+ (re-search-backward org-table-dataline-regexp nil t)
+ (beginning-of-line 1)
+ (org-table-insert-row 'below)
+ (beginning-of-line 1)
+ (delete-region (point) (1+ (point-at-eol)))
+ (setq beg (point))
+ (insert txt)
+ (setq end (point))))
+ (goto-char beg)
+ (org-capture-position-for-last-stored 'table-line)
+ (if (re-search-forward "%\\?" end t) (replace-match ""))
+ (org-table-align)))
+
+(defun org-capture-place-plain-text ()
+ "Place the template plainly."
+ (let* ((txt (org-capture-get :template))
+ beg end)
+ (goto-char (cond
+ ((org-capture-get :exact-position))
+ ((org-capture-get :prepend) (point-min))
+ (t (point-max))))
+ (or (bolp) (newline))
+ (org-capture-empty-lines-before)
+ (setq beg (point))
+ (insert txt)
+ (org-capture-empty-lines-after 1)
+ (org-capture-position-for-last-stored beg)
+ (setq end (point))
+ (org-capture-mark-kill-region beg (1- end))
+ (org-capture-narrow beg (1- end))
+ (if (re-search-forward "%\\?" end t) (replace-match ""))))
+
+(defun org-capture-mark-kill-region (beg end)
+ "Mark the region that will have to be killed when aborting capture."
+ (let ((m1 (move-marker (make-marker) beg))
+ (m2 (move-marker (make-marker) end)))
+ (org-capture-put :begin-marker m1)
+ (org-capture-put :end-marker m2)))
+
+(defun org-capture-position-for-last-stored (where)
+ "Memorize the position that should later become the position of last capture."
+ (cond
+ ((integerp where)
+ (org-capture-put :position-for-last-stored
+ (move-marker (make-marker) where
+ (or (buffer-base-buffer (current-buffer))
+ (current-buffer)))))
+ ((eq where 'table-line)
+ (org-capture-put :position-for-last-stored
+ (list 'table-line
+ (org-table-current-dline))))
+ (t (error "This should not happen"))))
+
+(defun org-capture-bookmark-last-stored-position ()
+ "Bookmark the last-captured position."
+ (let* ((where (org-capture-get :position-for-last-stored 'local))
+ (pos (cond
+ ((markerp where)
+ (prog1 (marker-position where)
+ (move-marker where nil)))
+ ((and (listp where) (eq (car where) 'table-line))
+ (if (org-at-table-p)
+ (save-excursion
+ (org-table-goto-line (nth 1 where))
+ (point-at-bol))
+ (point))))))
+ (with-current-buffer (buffer-base-buffer (current-buffer))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char pos)
+ (bookmark-set "org-capture-last-stored")
+ (move-marker org-capture-last-stored-marker (point)))))))
+
+(defun org-capture-narrow (beg end)
+ "Narrow, unless configuration says not to narrow."
+ (unless (org-capture-get :unnarrowed)
+ (narrow-to-region beg end)
+ (goto-char beg)))
+
+(defun org-capture-empty-lines-before (&optional n)
+ "Arrange for the correct number of empty lines before the insertion point.
+Point will be after the empty lines, so insertion can directly be done."
+ (setq n (or n (org-capture-get :empty-lines) 0))
+ (let ((pos (point)))
+ (org-back-over-empty-lines)
+ (delete-region (point) pos)
+ (if (> n 0) (newline n))))
+
+(defun org-capture-empty-lines-after (&optional n)
+ "Arrange for the correct number of empty lines after the inserted string.
+Point will remain at the first line after the inserted text."
+ (setq n (or n (org-capture-get :empty-lines) 0))
+ (org-back-over-empty-lines)
+ (while (looking-at "[ \t]*\n") (replace-match ""))
+ (let ((pos (point)))
+ (if (> n 0) (newline n))
+ (goto-char pos)))
+
+(defvar org-clock-marker) ; Defined in org.el
+;;;###autoload
+(defun org-capture-insert-template-here ()
+ (let* ((template (org-capture-get :template))
+ (type (org-capture-get :type))
+ beg end pp)
+ (or (bolp) (newline))
+ (setq beg (point))
+ (cond
+ ((and (eq type 'entry) (org-mode-p))
+ (org-paste-subtree nil template t))
+ ((and (memq type '(item checkitem))
+ (org-mode-p)
+ (save-excursion (skip-chars-backward " \t\n")
+ (setq pp (point))
+ (org-in-item-p)))
+ (goto-char pp)
+ (org-insert-item)
+ (skip-chars-backward " ")
+ (skip-chars-backward "-+*0123456789).")
+ (delete-region (point) (point-at-eol))
+ (setq beg (point))
+ (org-remove-indentation template)
+ (insert template)
+ (org-capture-empty-lines-after)
+ (goto-char beg)
+ (org-list-repair)
+ (org-end-of-item)
+ (setq end (point)))
+ (t (insert template)))
+ (setq end (point))
+ (goto-char beg)
+ (if (re-search-forward "%\\?" end t)
+ (replace-match ""))))
+
+(defun org-capture-set-plist (entry)
+ "Initialize the property list from the template definition."
+ (setq org-capture-plist (copy-sequence (nthcdr 5 entry)))
+ (org-capture-put :key (car entry) :description (nth 1 entry)
+ :target (nth 3 entry))
+ (let ((txt (nth 4 entry)) (type (or (nth 2 entry) 'entry)))
+ (when (or (not txt) (and (stringp txt) (not (string-match "\\S-" txt))))
+ ;; The template may be empty or omitted for special types.
+ ;; Here we insert the default templates for such cases.
+ (cond
+ ((eq type 'item) (setq txt "- %?"))
+ ((eq type 'checkitem) (setq txt "- [ ] %?"))
+ ((eq type 'table-line) (setq txt "| %? |"))
+ ((member type '(nil entry)) (setq txt "* %?\n %a"))))
+ (org-capture-put :template txt :type type)))
+
+(defun org-capture-goto-target (&optional template-key)
+ "Go to the target location of a capture template.
+The user is queried for the template."
+ (interactive)
+ (let* (org-select-template-temp-major-mode
+ (entry (org-capture-select-template template-key)))
+ (unless entry
+ (error "No capture template selected"))
+ (org-capture-set-plist entry)
+ (org-capture-set-target-location)
+ (switch-to-buffer (org-capture-get :buffer))
+ (goto-char (org-capture-get :pos))))
+
+(defun org-capture-get-indirect-buffer (&optional buffer prefix)
+ "Make an indirect buffer for a capture process.
+Use PREFIX as a prefix for the name of the indirect buffer."
+ (setq buffer (or buffer (current-buffer)))
+ (let ((n 1) (base (buffer-name buffer)) bname)
+ (setq bname (concat prefix "-" base))
+ (while (buffer-live-p (get-buffer bname))
+ (setq bname (concat prefix "-" (number-to-string (incf n)) "-" base)))
+ (condition-case nil
+ (make-indirect-buffer buffer bname 'clone)
+ (error (make-indirect-buffer buffer bname)))))
+
+
+;;; The template code
+
+(defun org-capture-select-template (&optional keys)
+ "Select a capture template.
+Lisp programs can force the template by setting KEYS to a string."
+ (if org-capture-templates
+ (if keys
+ (or (assoc keys org-capture-templates)
+ (error "No capture template referred to by \"%s\" keys" keys))
+ (if (= 1 (length org-capture-templates))
+ (car org-capture-templates)
+ (org-mks org-capture-templates
+ "Select a capture template\n========================="
+ "Template key: "
+ '(("C" "Customize org-capture-templates")
+ ("q" "Abort")))))
+ ;; Use an arbitrary default template
+ '("t" "Task" entry (file+headline "" "Tasks") "* TODO %?\n %u\n %a")))
+
+(defun org-capture-fill-template (&optional template initial annotation)
+ "Fill a template and return the filled template as a string.
+The template may still contain \"%?\" for cursor positioning."
+ (setq template (or template (org-capture-get :template)))
+ (when (stringp initial)
+ (setq initial (org-no-properties initial))
+ (remove-text-properties 0 (length initial) '(read-only t) initial))
+ (let* ((buffer (org-capture-get :buffer))
+ (file (buffer-file-name (or (buffer-base-buffer buffer) buffer)))
+ (ct (org-capture-get :default-time))
+ (dct (decode-time ct))
+ (ct1
+ (if (< (nth 2 dct) org-extend-today-until)
+ (encode-time 0 59 23 (1- (nth 3 dct)) (nth 4 dct) (nth 5 dct))
+ ct))
+ (plist-p (if org-store-link-plist t nil))
+ (v-c (and (> (length kill-ring) 0) (current-kill 0)))
+ (v-x (or (org-get-x-clipboard 'PRIMARY)
+ (org-get-x-clipboard 'CLIPBOARD)
+ (org-get-x-clipboard 'SECONDARY)))
+ (v-t (format-time-string (car org-time-stamp-formats) ct))
+ (v-T (format-time-string (cdr org-time-stamp-formats) ct))
+ (v-u (concat "[" (substring v-t 1 -1) "]"))
+ (v-U (concat "[" (substring v-T 1 -1) "]"))
+ ;; `initial' and `annotation' might habe been passed.
+ ;; But if the property list has them, we prefer those values
+ (v-i (or (plist-get org-store-link-plist :initial)
+ initial
+ (org-capture-get :initial)
+ ""))
+ (v-a (or (plist-get org-store-link-plist :annotation)
+ annotation
+ (org-capture-get :annotation)
+ ""))
+ ;; Is the link empty? Then we do not want it...
+ (v-a (if (equal v-a "[[]]") "" v-a))
+ (clipboards (remove nil (list v-i
+ (org-get-x-clipboard 'PRIMARY)
+ (org-get-x-clipboard 'CLIPBOARD)
+ (org-get-x-clipboard 'SECONDARY)
+ v-c)))
+ (v-A (if (and v-a
+ (string-match
+ "\\[\\(\\[.*?\\]\\)\\(\\[.*?\\]\\)?\\]" v-a))
+ (replace-match "[\\1[%^{Link description}]]" nil nil v-a)
+ v-a))
+ (v-n user-full-name)
+ (v-k (if (marker-buffer org-clock-marker)
+ (org-substring-no-properties org-clock-heading)))
+ (v-K (if (marker-buffer org-clock-marker)
+ (org-make-link-string
+ (buffer-file-name (marker-buffer org-clock-marker))
+ org-clock-heading)))
+ v-I
+ (org-startup-folded nil)
+ (org-inhibit-startup t)
+ org-time-was-given org-end-time-was-given x
+ prompt completions char time pos default histvar)
+
+ (setq org-store-link-plist
+ (plist-put org-store-link-plist :annotation v-a)
+ org-store-link-plist
+ (plist-put org-store-link-plist :initial v-i))
+ (setq initial v-i)
+
+ (unless template (setq template "") (message "No template") (ding)
+ (sit-for 1))
+ (save-window-excursion
+ (delete-other-windows)
+ (switch-to-buffer (get-buffer-create "*Capture*"))
+ (erase-buffer)
+ (insert template)
+ (goto-char (point-min))
+ (org-capture-steal-local-variables buffer)
+ (setq buffer-file-name nil)
+
+ ;; %[] Insert contents of a file.
+ (goto-char (point-min))
+ (while (re-search-forward "%\\[\\(.+\\)\\]" nil t)
+ (unless (org-capture-escaped-%)
+ (let ((start (match-beginning 0))
+ (end (match-end 0))
+ (filename (expand-file-name (match-string 1))))
+ (goto-char start)
+ (delete-region start end)
+ (condition-case error
+ (insert-file-contents filename)
+ (error (insert (format "%%![Couldn't insert %s: %s]"
+ filename error)))))))
+ ;; %() embedded elisp
+ (goto-char (point-min))
+ (while (re-search-forward "%\\((.+)\\)" nil t)
+ (unless (org-capture-escaped-%)
+ (goto-char (match-beginning 0))
+ (let ((template-start (point)))
+ (forward-char 1)
+ (let ((result
+ (condition-case error
+ (eval (read (current-buffer)))
+ (error (format "%%![Error: %s]" error)))))
+ (delete-region template-start (point))
+ (insert result)))))
+
+ ;; Simple %-escapes
+ (goto-char (point-min))
+ (while (re-search-forward "%\\([tTuUaiAcxkKI]\\)" nil t)
+ (unless (org-capture-escaped-%)
+ (when (and initial (equal (match-string 0) "%i"))
+ (save-match-data
+ (let* ((lead (buffer-substring
+ (point-at-bol) (match-beginning 0))))
+ (setq v-i (mapconcat 'identity
+ (org-split-string initial "\n")
+ (concat "\n" lead))))))
+ (replace-match
+ (or (eval (intern (concat "v-" (match-string 1)))) "")
+ t t)))
+
+ ;; From the property list
+ (when plist-p
+ (goto-char (point-min))
+ (while (re-search-forward "%\\(:[-a-zA-Z]+\\)" nil t)
+ (unless (org-capture-escaped-%)
+ (and (setq x (or (plist-get org-store-link-plist
+ (intern (match-string 1))) ""))
+ (replace-match x t t)))))
+
+ ;; Turn on org-mode in temp buffer, set local variables
+ ;; This is to support completion in interactive prompts
+ (let ((org-inhibit-startup t)) (org-mode))
+ ;; Interactive template entries
+ (goto-char (point-min))
+ (while (re-search-forward "%^\\({\\([^}]*\\)}\\)?\\([gGtTuUCLp]\\)?"
+ nil t)
+ (unless (org-capture-escaped-%)
+ (setq char (if (match-end 3) (match-string 3))
+ prompt (if (match-end 2) (match-string 2)))
+ (goto-char (match-beginning 0))
+ (replace-match "")
+ (setq completions nil default nil)
+ (when prompt
+ (setq completions (org-split-string prompt "|")
+ prompt (pop completions)
+ default (car completions)
+ histvar (intern (concat
+ "org-capture-template-prompt-history::"
+ (or prompt "")))
+ completions (mapcar 'list completions)))
+ (unless (boundp histvar) (set histvar nil))
+ (cond
+ ((member char '("G" "g"))
+ (let* ((org-last-tags-completion-table
+ (org-global-tags-completion-table
+ (if (equal char "G")
+ (org-agenda-files)
+ (and file (list file)))))
+ (org-add-colon-after-tag-completion t)
+ (ins (org-icompleting-read
+ (if prompt (concat prompt ": ") "Tags: ")
+ 'org-tags-completion-function nil nil nil
+ 'org-tags-history)))
+ (setq ins (mapconcat 'identity
+ (org-split-string
+ ins (org-re "[^[:alnum:]_@#%]+"))
+ ":"))
+ (when (string-match "\\S-" ins)
+ (or (equal (char-before) ?:) (insert ":"))
+ (insert ins)
+ (or (equal (char-after) ?:) (insert ":"))
+ (and (org-on-heading-p) (org-set-tags nil 'align)))))
+ ((equal char "C")
+ (cond ((= (length clipboards) 1) (insert (car clipboards)))
+ ((> (length clipboards) 1)
+ (insert (read-string "Clipboard/kill value: "
+ (car clipboards) '(clipboards . 1)
+ (car clipboards))))))
+ ((equal char "L")
+ (cond ((= (length clipboards) 1)
+ (org-insert-link 0 (car clipboards)))
+ ((> (length clipboards) 1)
+ (org-insert-link 0 (read-string "Clipboard/kill value: "
+ (car clipboards)
+ '(clipboards . 1)
+ (car clipboards))))))
+ ((equal char "p")
+ (let*
+ ((prop (org-substring-no-properties prompt))
+ (pall (concat prop "_ALL"))
+ (allowed
+ (with-current-buffer
+ (get-buffer (file-name-nondirectory file))
+ (or (cdr (assoc pall org-file-properties))
+ (cdr (assoc pall org-global-properties))
+ (cdr (assoc pall org-global-properties-fixed)))))
+ (existing (with-current-buffer
+ (get-buffer (file-name-nondirectory file))
+ (mapcar 'list (org-property-values prop))))
+ (propprompt (concat "Value for " prop ": "))
+ (val (if allowed
+ (org-completing-read
+ propprompt
+ (mapcar 'list (org-split-string allowed
+ "[ \t]+"))
+ nil 'req-match)
+ (org-completing-read-no-i propprompt
+ existing nil nil
+ "" nil ""))))
+ (org-set-property prop val)))
+ (char
+ ;; These are the date/time related ones
+ (setq org-time-was-given (equal (upcase char) char))
+ (setq time (org-read-date (equal (upcase char) char) t nil
+ prompt))
+ (if (equal (upcase char) char) (setq org-time-was-given t))
+ (org-insert-time-stamp time org-time-was-given
+ (member char '("u" "U"))
+ nil nil (list org-end-time-was-given)))
+ (t
+ (let (org-completion-use-ido)
+ (insert (org-completing-read-no-i
+ (concat (if prompt prompt "Enter string")
+ (if default (concat " [" default "]"))
+ ": ")
+ completions nil nil nil histvar default)))))))
+ ;; Make sure there are no empty lines before the text, and that
+ ;; it ends with a newline character
+ (goto-char (point-min))
+ (while (looking-at "[ \t]*\n") (replace-match ""))
+ (if (re-search-forward "[ \t\n]*\\'" nil t) (replace-match "\n"))
+ ;; Return the expanded tempate and kill the temporary buffer
+ (untabify (point-min) (point-max))
+ (set-buffer-modified-p nil)
+ (prog1 (buffer-string) (kill-buffer (current-buffer))))))
+
+(defun org-capture-escaped-% ()
+ "Check if % was escaped - if yes, unescape it now."
+ (if (equal (char-before (match-beginning 0)) ?\\)
+ (progn
+ (delete-region (1- (match-beginning 0)) (match-beginning 0))
+ t)
+ nil))
+
+;;;###autoload
+(defun org-capture-import-remember-templates ()
+ "Set org-capture-templates to be similar to `org-remember-templates'."
+ (interactive)
+ (when (and (yes-or-no-p
+ "Import old remember templates into org-capture-templates? ")
+ (yes-or-no-p
+ "Note that this will remove any templates currently defined in `org-capture-templates'. Do you still want to go ahead? "))
+ (require 'org-remember)
+ (setq org-capture-templates
+ (mapcar
+ (lambda (entry)
+ (let ((desc (car entry))
+ (key (char-to-string (nth 1 entry)))
+ (template (nth 2 entry))
+ (file (or (nth 3 entry) org-default-notes-file))
+ (position (or (nth 4 entry) org-remember-default-headline))
+ (type 'entry)
+ (prepend org-reverse-note-order)
+ immediate target)
+ (cond
+ ((member position '(top bottom))
+ (setq target (list 'file file)
+ prepend (eq position 'top)))
+ ((eq position 'date-tree)
+ (setq target (list 'file+datetree file)
+ prepend nil))
+ (t (setq target (list 'file+headline file position))))
+
+ (when (string-match "%!" template)
+ (setq template (replace-match "" t t template)
+ immediate t))
+
+ (append (list key desc type target template)
+ (if prepend '(:prepend t))
+ (if immediate '(:immediate-finish t)))))
+
+ org-remember-templates))))
+
+(provide 'org-capture)
+
+;; arch-tag: 986bf41b-8ada-4e28-bf20-e8388a7205a0
+
+;;; org-capture.el ends here
+
+
diff --git a/lisp/org/org-clock.el b/lisp/org/org-clock.el
index 144741174ce..457a4dcb2f0 100644
--- a/lisp/org/org-clock.el
+++ b/lisp/org/org-clock.el
@@ -6,7 +6,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -29,11 +29,13 @@
;; This file contains the time clocking code for Org-mode
(require 'org)
+;;; Code:
+
(eval-when-compile
- (require 'cl)
- (require 'calendar))
+ (require 'cl))
(declare-function calendar-absolute-from-iso "cal-iso" (&optional date))
+(declare-function notifications-notify "notifications" (&rest params))
(defvar org-time-stamp-formats)
(defgroup org-clock nil
@@ -63,20 +65,27 @@ which see."
(defcustom org-clock-out-when-done t
"When non-nil, clock will be stopped when the clocked entry is marked DONE.
-A nil value means, clock will keep running until stopped explicitly with
-`C-c C-x C-o', or until the clock is started in a different item."
+DONE here means any DONE-like state.
+A nil value means clock will keep running until stopped explicitly with
+`C-c C-x C-o', or until the clock is started in a different item.
+Instead of t, this can also be a list of TODO states that should trigger
+clocking out."
:group 'org-clock
- :type 'boolean)
+ :type '(choice
+ (const :tag "No" nil)
+ (const :tag "Yes, when done" t)
+ (repeat :tag "State list"
+ (string :tag "TODO keyword"))))
(defcustom org-clock-out-remove-zero-time-clocks nil
- "Non-nil means, remove the clock line when the resulting time is zero."
+ "Non-nil means remove the clock line when the resulting time is zero."
:group 'org-clock
:type 'boolean)
(defcustom org-clock-in-switch-to-state nil
"Set task to a special todo state while clocking it.
The value should be the state to which the entry should be
-switched. If the value is a function, it must take one
+switched. If the value is a function, it must take one
parameter (the current TODO state of the item) and return the
state to switch it to."
:group 'org-clock
@@ -89,7 +98,7 @@ state to switch it to."
(defcustom org-clock-out-switch-to-state nil
"Set task to a special todo state after clocking out.
The value should be the state to which the entry should be
-switched. If the value is a function, it must take one
+switched. If the value is a function, it must take one
parameter (the current TODO state of the item) and return the
state to switch it to."
:group 'org-clock
@@ -105,7 +114,7 @@ state to switch it to."
:type 'integer)
(defcustom org-clock-goto-may-find-recent-task t
- "Non-nil means, `org-clock-goto' can go to recent task if no active clock."
+ "Non-nil means `org-clock-goto' can go to recent task if no active clock."
:group 'org-clock
:type 'boolean)
@@ -117,7 +126,7 @@ The function is called with point at the beginning of the headline."
:type 'function)
(defcustom org-clock-string-limit 0
- "Maximum length of clock strings in the modeline. 0 means no limit."
+ "Maximum length of clock strings in the modeline. 0 means no limit."
:group 'org-clock
:type 'integer)
@@ -129,8 +138,8 @@ the clock can be resumed from that point."
:type 'boolean)
(defcustom org-clock-persist nil
- "When non-nil, save the running clock when emacs is closed.
-The clock is resumed when emacs restarts.
+ "When non-nil, save the running clock when Emacs is closed.
+The clock is resumed when Emacs restarts.
When this is t, both the running clock, and the entire clock
history are saved. When this is the symbol `clock', only the
running clock is saved.
@@ -193,6 +202,17 @@ auto Automatically, either `all', or `repeat' for repeating tasks"
(const :tag "All task time" all)
(const :tag "Automatically, `all' or since `repeat'" auto)))
+(defcustom org-task-overrun-text nil
+ "The extra modeline text that should indicate that the clock is overrun.
+The can be nil to indicate that instead of adding text, the clock time
+should get a different face (`org-mode-line-clock-overrun').
+When this is a string, it is prepended to the clock string as an indication,
+also using the face `org-mode-line-clock-overrun'."
+ :group 'org-clock
+ :type '(choice
+ (const :tag "Just mark the time string" nil)
+ (string :tag "Text to prepend")))
+
(defcustom org-show-notification-handler nil
"Function or program to send notification with.
The function or program will be called with the notification
@@ -222,6 +242,16 @@ string as argument."
(const :tag "Always" t)
(const :tag "When no clock is running" when-no-clock-is-running)))
+(defcustom org-clock-report-include-clocking-task nil
+ "When non-nil, include the current clocking task time in clock reports."
+ :group 'org-clock
+ :type 'boolean)
+
+(defcustom org-clock-resolve-expert nil
+ "Non-nil means do not show the splash buffer with the clock resolver."
+ :group 'org-clock
+ :type 'boolean)
+
(defvar org-clock-in-prepare-hook nil
"Hook run when preparing the clock.
This hook is run before anything happens to the task that
@@ -250,11 +280,11 @@ to add an effort property.")
(defvar org-clock-heading-for-remember "")
(defvar org-clock-start-time "")
-(defvar org-clock-left-over-time nil
+(defvar org-clock-leftover-time nil
"If non-nil, user cancelled a clock; this is when leftover time started.")
(defvar org-clock-effort ""
- "Effort estimate of the currently clocking task")
+ "Effort estimate of the currently clocking task.")
(defvar org-clock-total-time nil
"Holds total time, spent previously on currently clocked item.
@@ -287,7 +317,10 @@ of a different task.")
(defun org-clock-history-push (&optional pos buffer)
"Push a marker to the clock history."
(setq org-clock-history-length (max 1 (min 35 org-clock-history-length)))
- (let ((m (move-marker (make-marker) (or pos (point)) buffer)) n l)
+ (let ((m (move-marker (make-marker)
+ (or pos (point)) (org-base-buffer
+ (or buffer (current-buffer)))))
+ n l)
(while (setq n (member m org-clock-history))
(move-marker (car n) nil))
(setq org-clock-history
@@ -310,6 +343,14 @@ of a different task.")
(mapc (lambda (m) (org-check-and-save-marker m beg end))
org-clock-history))
+(defun org-clocking-buffer ()
+ "Return the clocking buffer if we are currently clocking a task or nil."
+ (marker-buffer org-clock-marker))
+
+(defun org-clocking-p ()
+ "Return t when clocking a task."
+ (not (equal (org-clocking-buffer) nil)))
+
(defun org-clock-select-task (&optional prompt)
"Select a task that recently was associated with clocking."
(interactive)
@@ -326,7 +367,7 @@ of a different task.")
(insert (org-add-props "The task interrupted by starting the last one\n" nil 'face 'bold))
(setq s (org-clock-insert-selection-line ?i org-clock-interrupted-task))
(push s sel-list))
- (when (marker-buffer org-clock-marker)
+ (when (org-clocking-p)
(insert (org-add-props "Current Clocking Task\n" nil 'face 'bold))
(setq s (org-clock-insert-selection-line ?c org-clock-marker))
(push s sel-list))
@@ -339,6 +380,7 @@ of a different task.")
(if (< i 10)
(+ i ?0)
(+ i (- ?A 10))) m))
+ (if (fboundp 'int-to-char) (setf (car s) (int-to-char (car s))))
(push s sel-list)))
org-clock-history)
(org-fit-window-to-buffer)
@@ -360,56 +402,82 @@ pointing to it."
(save-excursion
(save-restriction
(widen)
- (goto-char marker)
- (setq file (buffer-file-name (marker-buffer marker))
- cat (or (org-get-category)
- (progn (org-refresh-category-properties)
- (org-get-category)))
- heading (org-get-heading 'notags)
- prefix (save-excursion
- (org-back-to-heading t)
- (looking-at "\\*+ ")
- (match-string 0))
- task (substring
- (org-fontify-like-in-org-mode
- (concat prefix heading)
- org-odd-levels-only)
- (length prefix))))))
+ (ignore-errors
+ (goto-char marker)
+ (setq file (buffer-file-name (marker-buffer marker))
+ cat (or (org-get-category)
+ (progn (org-refresh-category-properties)
+ (org-get-category)))
+ heading (org-get-heading 'notags)
+ prefix (save-excursion
+ (org-back-to-heading t)
+ (looking-at "\\*+ ")
+ (match-string 0))
+ task (substring
+ (org-fontify-like-in-org-mode
+ (concat prefix heading)
+ org-odd-levels-only)
+ (length prefix)))))))
(when (and cat task)
(insert (format "[%c] %-15s %s\n" i cat task))
(cons i marker)))))
+(defvar org-task-overrun nil
+ "Internal flag indicating if the clock has overrun the planned time.")
+(defvar org-clock-update-period 60
+ "Number of seconds between mode line clock string updates.")
+
(defun org-clock-get-clock-string ()
- "Form a clock-string, that will be show in the mode line.
-If an effort estimate was defined for current item, use
+ "Form a clock-string, that will be shown in the mode line.
+If an effort estimate was defined for the current item, use
01:30/01:50 format (clocked/estimated).
If not, show simply the clocked time like 01:50."
(let* ((clocked-time (org-clock-get-clocked-time))
(h (floor clocked-time 60))
(m (- clocked-time (* 60 h))))
- (if (and org-clock-effort)
- (let* ((effort-in-minutes (org-hh:mm-string-to-minutes org-clock-effort))
+ (if org-clock-effort
+ (let* ((effort-in-minutes
+ (org-hh:mm-string-to-minutes org-clock-effort))
(effort-h (floor effort-in-minutes 60))
- (effort-m (- effort-in-minutes (* effort-h 60))))
- (format (concat "-[" org-time-clocksum-format "/" org-time-clocksum-format " (%s)]")
- h m effort-h effort-m org-clock-heading))
- (format (concat "-[" org-time-clocksum-format " (%s)]")
- h m org-clock-heading))))
+ (effort-m (- effort-in-minutes (* effort-h 60)))
+ (work-done-str
+ (org-propertize
+ (format org-time-clocksum-format h m)
+ 'face (if (and org-task-overrun (not org-task-overrun-text))
+ 'org-mode-line-clock-overrun 'org-mode-line-clock)))
+ (effort-str (format org-time-clocksum-format effort-h effort-m))
+ (clockstr (org-propertize
+ (concat "[%s/" effort-str
+ "] (" (replace-regexp-in-string "%" "%%" org-clock-heading) ")")
+ 'face 'org-mode-line-clock)))
+ (format clockstr work-done-str))
+ (org-propertize (format
+ (concat "[" org-time-clocksum-format " (%s)]")
+ h m org-clock-heading)
+ 'face 'org-mode-line-clock))))
(defun org-clock-update-mode-line ()
+ (if org-clock-effort
+ (org-clock-notify-once-if-expired)
+ (setq org-task-overrun nil))
(setq org-mode-line-string
(org-propertize
(let ((clock-string (org-clock-get-clock-string))
(help-text "Org-mode clock is running.\nmouse-1 shows a menu\nmouse-2 will jump to task"))
(if (and (> org-clock-string-limit 0)
(> (length clock-string) org-clock-string-limit))
- (org-propertize (substring clock-string 0 org-clock-string-limit)
- 'help-echo (concat help-text ": " org-clock-heading))
+ (org-propertize
+ (substring clock-string 0 org-clock-string-limit)
+ 'help-echo (concat help-text ": " org-clock-heading))
(org-propertize clock-string 'help-echo help-text)))
'local-map org-clock-mode-line-map
'mouse-face (if (featurep 'xemacs) 'highlight 'mode-line-highlight)
- 'face 'org-mode-line-clock))
- (if org-clock-effort (org-clock-notify-once-if-expired))
+ ))
+ (if (and org-task-overrun org-task-overrun-text)
+ (setq org-mode-line-string
+ (concat (org-propertize
+ org-task-overrun-text
+ 'face 'org-mode-line-clock-overrun) org-mode-line-string)))
(force-mode-line-update))
(defun org-clock-get-clocked-time ()
@@ -443,7 +511,8 @@ the mode line."
;; A string. See if it is a delta
(setq sign (string-to-char value))
(if (member sign '(?- ?+))
- (setq current (org-hh:mm-string-to-minutes (substring current 1)))
+ (setq current (org-hh:mm-string-to-minutes current)
+ value (substring value 1))
(setq current 0))
(setq value (org-hh:mm-string-to-minutes value))
(if (equal ?- sign)
@@ -461,10 +530,13 @@ the mode line."
(defun org-clock-notify-once-if-expired ()
"Show notification if we spent more time than we estimated before.
Notification is shown only once."
- (when (marker-buffer org-clock-marker)
+ (when (org-clocking-p)
(let ((effort-in-minutes (org-hh:mm-string-to-minutes org-clock-effort))
(clocked-time (org-clock-get-clocked-time)))
- (if (>= clocked-time effort-in-minutes)
+ (if (setq org-task-overrun
+ (if (or (null effort-in-minutes) (zerop effort-in-minutes))
+ nil
+ (>= clocked-time effort-in-minutes)))
(unless org-clock-notification-was-shown
(setq org-clock-notification-was-shown t)
(org-notify
@@ -486,6 +558,14 @@ use libnotify if available, or fall back on a message."
((stringp org-show-notification-handler)
(start-process "emacs-timer-notification" nil
org-show-notification-handler notification))
+ ((featurep 'notifications)
+ (require 'notifications)
+ (notifications-notify
+ :title "Org-mode message"
+ :body notification
+ ;; FIXME how to link to the Org icon?
+ ;; :app-icon "~/.emacs.d/icons/mail.png"
+ :urgency 'low))
((org-program-exists "notify-send")
(start-process "emacs-timer-notification" nil
"notify-send" notification))
@@ -526,7 +606,7 @@ Use alsa's aplay tool if available."
(save-excursion
(goto-char (point-min))
(while (re-search-forward "CLOCK: \\(\\[.*?\\]\\)$" nil t)
- (push (cons (copy-marker (1- (match-end 1)) t)
+ (push (cons (copy-marker (match-end 1) t)
(org-time-string-to-time (match-string 1))) clocks))))
clocks))
@@ -563,12 +643,12 @@ This macro also protects the current active clock from being altered."
(put 'org-with-clock 'lisp-indent-function 1)
-(defsubst org-clock-clock-in (clock &optional resume)
+(defsubst org-clock-clock-in (clock &optional resume start-time)
"Clock in to the clock located by CLOCK.
If necessary, clock-out of the currently active clock."
(org-with-clock-position clock
(let ((org-clock-in-resume (or resume org-clock-in-resume)))
- (org-clock-in))))
+ (org-clock-in nil start-time))))
(defsubst org-clock-clock-out (clock &optional fail-quietly at-time)
"Clock out of the clock located by CLOCK."
@@ -594,39 +674,10 @@ If necessary, clock-out of the currently active clock."
(defvar org-clock-resolving-clocks nil)
(defvar org-clock-resolving-clocks-due-to-idleness nil)
-(defun org-clock-resolve-clock (clock resolve-to &optional close-p
- restart-p fail-quietly)
+(defun org-clock-resolve-clock (clock resolve-to clock-out-time
+ &optional close-p restart-p fail-quietly)
"Resolve `CLOCK' given the time `RESOLVE-TO', and the present.
-`CLOCK' is a cons cell of the form (MARKER START-TIME).
-This routine can do one of many things:
-
- if `RESOLVE-TO' is nil
- if `CLOSE-P' is non-nil, give an error
- if this clock is the active clock, cancel it
- else delete the clock line (as if it never happened)
- if `RESTART-P' is non-nil, start a new clock
-
- else if `RESOLVE-TO' is the symbol `now'
- if `RESTART-P' is non-nil, give an error
- if `CLOSE-P' is non-nil, clock out the entry and
- if this clock is the active clock, stop it
- else if this clock is the active clock, do nothing
- else if there is no active clock, resume this clock
- else ask to cancel the active clock, and if so,
- resume this clock after cancelling it
-
- else if `RESOLVE-TO' is some date in the future
- give an error about `RESOLVE-TO' being invalid
-
- else if `RESOLVE-TO' is some date in the past
- if `RESTART-P' is non-nil, give an error
- if `CLOSE-P' is non-nil, enter a closing time and
- if this clock is the active clock, stop it
- else if this clock is the active clock, enter a
- closing time, stop the current clock, then
- start a new clock for the same item
- else just enter a closing time for this clock
- and then start a new clock for the same item"
+`CLOCK' is a cons cell of the form (MARKER START-TIME)."
(let ((org-clock-resolving-clocks t))
(cond
((null resolve-to)
@@ -648,11 +699,41 @@ This routine can do one of many things:
(t
(if restart-p
(error "RESTART-P is not valid here"))
- (org-clock-clock-out clock fail-quietly resolve-to)
+ (org-clock-clock-out clock fail-quietly (or clock-out-time
+ resolve-to))
(unless org-clock-clocking-in
(if close-p
- (setq org-clock-left-over-time resolve-to)
- (org-clock-clock-in clock)))))))
+ (setq org-clock-leftover-time (and (null clock-out-time)
+ resolve-to))
+ (org-clock-clock-in clock nil (and clock-out-time
+ resolve-to))))))))
+
+(defun org-clock-jump-to-current-clock (&optional effective-clock)
+ (interactive)
+ (let ((clock (or effective-clock (cons org-clock-marker
+ org-clock-start-time))))
+ (unless (marker-buffer (car clock))
+ (error "No clock is currently running"))
+ (org-with-clock clock (org-clock-goto))
+ (with-current-buffer (marker-buffer (car clock))
+ (goto-char (car clock))
+ (if org-clock-into-drawer
+ (let ((logbook
+ (if (stringp org-clock-into-drawer)
+ (concat ":" org-clock-into-drawer ":")
+ ":LOGBOOK:")))
+ (ignore-errors
+ (outline-flag-region
+ (save-excursion
+ (outline-back-to-heading t)
+ (search-forward logbook)
+ (goto-char (match-beginning 0)))
+ (save-excursion
+ (outline-back-to-heading t)
+ (search-forward logbook)
+ (search-forward ":END:")
+ (goto-char (match-end 0)))
+ nil)))))))
(defun org-clock-resolve (clock &optional prompt-fn last-valid fail-quietly)
"Resolve an open org-mode clock.
@@ -678,44 +759,66 @@ was started."
(save-window-excursion
(save-excursion
(unless org-clock-resolving-clocks-due-to-idleness
- (org-with-clock clock (org-clock-goto))
- (with-current-buffer (marker-buffer (car clock))
- (goto-char (car clock))
- (if org-clock-into-drawer
- (let ((logbook
- (if (stringp org-clock-into-drawer)
- (concat ":" org-clock-into-drawer ":")
- ":LOGBOOK:")))
- (ignore-errors
- (outline-flag-region
- (save-excursion
- (outline-back-to-heading t)
- (search-forward logbook)
- (goto-char (match-beginning 0)))
- (save-excursion
- (outline-back-to-heading t)
- (search-forward logbook)
- (search-forward ":END:")
- (goto-char (match-end 0)))
- nil))))))
+ (org-clock-jump-to-current-clock clock))
+ (unless org-clock-resolve-expert
+ (with-output-to-temp-buffer "*Org Clock*"
+ (princ "Select a Clock Resolution Command:
+
+i/q/C-g Ignore this question; the same as keeping all the idle time.
+
+k/K Keep X minutes of the idle time (default is all). If this
+ amount is less than the default, you will be clocked out
+ that many minutes after the time that idling began, and then
+ clocked back in at the present time.
+g/G Indicate that you \"got back\" X minutes ago. This is quite
+ different from 'k': it clocks you out from the beginning of
+ the idle period and clock you back in X minutes ago.
+s/S Subtract the idle time from the current clock. This is the
+ same as keeping 0 minutes.
+C Cancel the open timer altogether. It will be as though you
+ never clocked in.
+j/J Jump to the current clock, to make manual adjustments.
+
+For all these options, using uppercase makes your final state
+to be CLOCKED OUT.")))
+ (org-fit-window-to-buffer (get-buffer-window "*Org Clock*"))
(let (char-pressed)
- (while (null char-pressed)
+ (when (featurep 'xemacs)
+ (message (concat (funcall prompt-fn clock)
+ " [jkKgGsScCiq]? "))
+ (setq char-pressed (read-char-exclusive)))
+ (while (or (null char-pressed)
+ (and (not (memq char-pressed
+ '(?k ?K ?g ?G ?s ?S ?C
+ ?j ?J ?i ?q)))
+ (or (ding) t)))
(setq char-pressed
(read-char (concat (funcall prompt-fn clock)
- " [(kK)eep (sS)ubtract (C)ancel]? ")
+ " [jkKgGSscCiq]? ")
nil 45)))
- char-pressed))))
- (default (floor (/ (org-float-time
- (time-subtract (current-time) last-valid)) 60)))
- (keep (and (memq ch '(?k ?K))
- (read-number "Keep how many minutes? " default)))
+ (and (not (memq char-pressed '(?i ?q))) char-pressed)))))
+ (default
+ (floor (/ (org-float-time
+ (time-subtract (current-time) last-valid)) 60)))
+ (keep
+ (and (memq ch '(?k ?K))
+ (read-number "Keep how many minutes? " default)))
+ (gotback
+ (and (memq ch '(?g ?G))
+ (read-number "Got back how many minutes ago? " default)))
(subtractp (memq ch '(?s ?S)))
(barely-started-p (< (- (org-float-time last-valid)
(org-float-time (cdr clock))) 45))
(start-over (and subtractp barely-started-p)))
- (if (or (null ch)
- (not (memq ch '(?k ?K ?s ?S ?C))))
- (message "")
+ (cond
+ ((memq ch '(?j ?J))
+ (if (eq ch ?J)
+ (org-clock-resolve-clock clock 'now nil t nil fail-quietly))
+ (org-clock-jump-to-current-clock clock))
+ ((or (null ch)
+ (not (memq ch '(?k ?K ?g ?G ?s ?S ?C))))
+ (message ""))
+ (t
(org-clock-resolve-clock
clock (cond
((or (eq ch ?C)
@@ -724,21 +827,29 @@ was started."
;; time...
start-over)
nil)
- (subtractp
+ ((or subtractp
+ (and gotback (= gotback 0)))
last-valid)
- ((= keep default)
+ ((or (and keep (= keep default))
+ (and gotback (= gotback default)))
'now)
+ (keep
+ (time-add last-valid (seconds-to-time (* 60 keep))))
+ (gotback
+ (time-subtract (current-time)
+ (seconds-to-time (* 60 gotback))))
(t
- (time-add last-valid (seconds-to-time (* 60 keep)))))
- (memq ch '(?K ?S))
+ (error "Unexpected, please report this as a bug")))
+ (and gotback last-valid)
+ (memq ch '(?K ?G ?S))
(and start-over
- (not (memq ch '(?K ?S ?C))))
- fail-quietly))))
+ (not (memq ch '(?K ?G ?S ?C))))
+ fail-quietly)))))
-(defun org-resolve-clocks (&optional also-non-dangling-p prompt-fn last-valid)
+(defun org-resolve-clocks (&optional only-dangling-p prompt-fn last-valid)
"Resolve all currently open org-mode clocks.
-If `also-non-dangling-p' is non-nil, also ask to resolve
-non-dangling (i.e., currently open and valid) clocks."
+If `only-dangling-p' is non-nil, only ask to resolve dangling
+\(i.e., not currently open and valid) clocks."
(interactive "P")
(unless org-clock-resolving-clocks
(let ((org-clock-resolving-clocks t))
@@ -747,7 +858,7 @@ non-dangling (i.e., currently open and valid) clocks."
(dolist (clock clocks)
(let ((dangling (or (not (org-clock-is-active))
(/= (car clock) org-clock-marker))))
- (unless (and (not dangling) (not also-non-dangling-p))
+ (if (or (not only-dangling-p) dangling)
(org-clock-resolve
clock
(or prompt-fn
@@ -769,27 +880,23 @@ non-dangling (i.e., currently open and valid) clocks."
0)))
(defun org-mac-idle-seconds ()
- "Return the current Mac idle time in seconds"
+ "Return the current Mac idle time in seconds."
(string-to-number (shell-command-to-string "ioreg -c IOHIDSystem | perl -ane 'if (/Idle/) {$idle=(pop @F)/1000000000; print $idle; last}'")))
(defun org-x11-idle-seconds ()
- "Return the current X11 idle time in seconds"
+ "Return the current X11 idle time in seconds."
(/ (string-to-number (shell-command-to-string "x11idle")) 1000))
(defun org-user-idle-seconds ()
"Return the number of seconds the user has been idle for.
This routine returns a floating point number."
- (if (or (eq system-type 'darwin) (eq window-system 'x))
- (let ((emacs-idle (org-emacs-idle-seconds)))
- ;; If Emacs has been idle for longer than the user's
- ;; `org-clock-idle-time' value, check whether the whole system has
- ;; really been idle for that long.
- (if (> emacs-idle (* 60 org-clock-idle-time))
- (min emacs-idle (if (eq system-type 'darwin)
- (org-mac-idle-seconds)
- (org-x11-idle-seconds)))
- emacs-idle))
- (org-emacs-idle-seconds)))
+ (cond
+ ((eq system-type 'darwin)
+ (org-mac-idle-seconds))
+ ((eq window-system 'x)
+ (org-x11-idle-seconds))
+ (t
+ (org-emacs-idle-seconds))))
(defvar org-clock-user-idle-seconds)
@@ -800,11 +907,11 @@ if the user really wants to stay clocked in after being idle for
so long."
(when (and org-clock-idle-time (not org-clock-resolving-clocks)
org-clock-marker)
- (let ((org-clock-user-idle-seconds (org-user-idle-seconds))
- (org-clock-user-idle-start
- (time-subtract (current-time)
- (seconds-to-time org-clock-user-idle-seconds)))
- (org-clock-resolving-clocks-due-to-idleness t))
+ (let* ((org-clock-user-idle-seconds (org-user-idle-seconds))
+ (org-clock-user-idle-start
+ (time-subtract (current-time)
+ (seconds-to-time org-clock-user-idle-seconds)))
+ (org-clock-resolving-clocks-due-to-idleness t))
(if (> org-clock-user-idle-seconds (* 60 org-clock-idle-time))
(org-clock-resolve
(cons org-clock-marker
@@ -818,27 +925,29 @@ so long."
60.0))))
org-clock-user-idle-start)))))
-(defun org-clock-in (&optional select)
+(defun org-clock-in (&optional select start-time)
"Start the clock on the current item.
If necessary, clock-out of the currently active clock.
-With prefix arg SELECT, offer a list of recently clocked tasks to
-clock into. When SELECT is `C-u C-u', clock into the current task and mark
+With a prefix argument SELECT (\\[universal-argument]), offer a list of \
+recently clocked tasks to
+clock into. When SELECT is \\[universal-argument] \\[universal-argument], \
+clock into the current task and mark
is as the default task, a special task that will always be offered in
the clocking selection, associated with the letter `d'."
(interactive "P")
(setq org-clock-notification-was-shown nil)
(catch 'abort
(let ((interrupting (and (not org-clock-resolving-clocks-due-to-idleness)
- (marker-buffer org-clock-marker)))
+ (org-clocking-p)))
ts selected-task target-pos (msg-extra "")
- (left-over (and (not org-clock-resolving-clocks)
- org-clock-left-over-time)))
+ (leftover (and (not org-clock-resolving-clocks)
+ org-clock-leftover-time)))
(when (and org-clock-auto-clock-resolution
(or (not interrupting)
(eq t org-clock-auto-clock-resolution))
(not org-clock-clocking-in)
(not org-clock-resolving-clocks))
- (setq org-clock-left-over-time nil)
+ (setq org-clock-leftover-time nil)
(let ((org-clock-clocking-in t))
(org-resolve-clocks))) ; check if any clocks are dangling
(when (equal select '(4))
@@ -849,15 +958,30 @@ the clocking selection, associated with the letter `d'."
(when interrupting
;; We are interrupting the clocking of a different task.
;; Save a marker to this task, so that we can go back.
+ ;; First check if we are trying to clock into the same task!
+ (when (save-excursion
+ (unless selected-task
+ (org-back-to-heading t))
+ (and (equal (marker-buffer org-clock-hd-marker)
+ (if selected-task
+ (marker-buffer selected-task)
+ (current-buffer)))
+ (= (marker-position org-clock-hd-marker)
+ (if selected-task
+ (marker-position selected-task)
+ (point)))))
+ (message "Clock continues in \"%s\"" org-clock-heading)
+ (throw 'abort nil))
(move-marker org-clock-interrupted-task
(marker-position org-clock-marker)
(marker-buffer org-clock-marker))
- (org-clock-out t))
-
+ (let ((org-clock-clocking-in t))
+ (org-clock-out t)))
+
(when (equal select '(16))
;; Mark as default clocking task
(org-clock-mark-default-task))
-
+
;; Clock in at which position?
(setq target-pos
(if (and (eobp) (not (org-on-heading-p)))
@@ -878,6 +1002,7 @@ the clocking selection, associated with the letter `d'."
(org-back-to-heading t)
(or interrupting (move-marker org-clock-interrupted-task nil))
(org-clock-history-push)
+ (org-clock-set-current)
(cond ((functionp org-clock-in-switch-to-state)
(looking-at org-complex-heading-regexp)
(let ((newstate (funcall org-clock-in-switch-to-state
@@ -898,7 +1023,9 @@ the clocking selection, associated with the letter `d'."
(functionp org-clock-heading-function))
(funcall org-clock-heading-function))
((looking-at org-complex-heading-regexp)
- (match-string 4))
+ (replace-regexp-in-string
+ "\\[\\[.*?\\]\\[\\(.*?\\)\\]\\]" "\\1"
+ (match-string 4)))
(t "???")))
(setq org-clock-heading (org-propertize org-clock-heading
'face nil))
@@ -939,13 +1066,14 @@ the clocking selection, associated with the letter `d'."
(setq org-clock-total-time (org-clock-sum-current-item
(org-clock-get-sum-start)))
(setq org-clock-start-time
- (or (and left-over
+ (or (and leftover
(y-or-n-p
(format
"You stopped another clock %d mins ago; start this one from then? "
(/ (- (org-float-time (current-time))
- (org-float-time left-over)) 60)))
- left-over)
+ (org-float-time leftover)) 60)))
+ leftover)
+ start-time
(current-time)))
(setq ts (org-insert-time-stamp org-clock-start-time
'with-hm 'inactive))))
@@ -963,7 +1091,9 @@ the clocking selection, associated with the letter `d'."
(cancel-timer org-clock-mode-line-timer)
(setq org-clock-mode-line-timer nil))
(setq org-clock-mode-line-timer
- (run-with-timer 60 60 'org-clock-update-mode-line))
+ (run-with-timer org-clock-update-period
+ org-clock-update-period
+ 'org-clock-update-mode-line))
(when org-clock-idle-timer
(cancel-timer org-clock-idle-timer)
(setq org-clock-idle-timer nil))
@@ -972,6 +1102,16 @@ the clocking selection, associated with the letter `d'."
(message "Clock starts at %s - %s" ts msg-extra)
(run-hooks 'org-clock-in-hook)))))))
+(defvar org-clock-current-task nil
+ "Task currently clocked in.")
+(defun org-clock-set-current ()
+ "Set `org-clock-current-task' to the task currently clocked in."
+ (setq org-clock-current-task (nth 4 (org-heading-components))))
+
+(defun org-clock-delete-current ()
+ "Reset `org-clock-current-task' to nil."
+ (setq org-clock-current-task nil))
+
(defun org-clock-mark-default-task ()
"Mark current task as default task."
(interactive)
@@ -1104,11 +1244,14 @@ line and position cursor in that line."
If there is no running clock, throw an error, unless FAIL-QUIETLY is set."
(interactive)
(catch 'exit
- (if (not (marker-buffer org-clock-marker))
- (if fail-quietly (throw 'exit t) (error "No active clock")))
+ (when (not (org-clocking-p))
+ (setq global-mode-string
+ (delq 'org-mode-line-string global-mode-string))
+ (force-mode-line-update)
+ (if fail-quietly (throw 'exit t) (error "No active clock")))
(let (ts te s h m remove)
- (save-excursion
- (set-buffer (marker-buffer org-clock-marker))
+ (save-excursion ; Do not replace this with `with-current-buffer'.
+ (with-no-warnings (set-buffer (org-clocking-buffer)))
(save-restriction
(widen)
(goto-char org-clock-marker)
@@ -1151,7 +1294,8 @@ If there is no running clock, throw an error, unless FAIL-QUIETLY is set."
(when org-clock-out-switch-to-state
(save-excursion
(org-back-to-heading t)
- (let ((org-inhibit-logging t))
+ (let ((org-inhibit-logging t)
+ (org-clock-out-when-done nil))
(cond
((functionp org-clock-out-switch-to-state)
(looking-at org-complex-heading-regexp)
@@ -1166,15 +1310,19 @@ If there is no running clock, throw an error, unless FAIL-QUIETLY is set."
(force-mode-line-update)
(message (concat "Clock stopped at %s after HH:MM = " org-time-clocksum-format "%s") te h m
(if remove " => LINE REMOVED" ""))
- (run-hooks 'org-clock-out-hook))))))
+ (run-hooks 'org-clock-out-hook)
+ (org-clock-delete-current))))))
(defun org-clock-cancel ()
- "Cancel the running clock be removing the start timestamp."
+ "Cancel the running clock by removing the start timestamp."
(interactive)
- (if (not (marker-buffer org-clock-marker))
- (error "No active clock"))
- (save-excursion
- (set-buffer (marker-buffer org-clock-marker))
+ (when (not (org-clocking-p))
+ (setq global-mode-string
+ (delq 'org-mode-line-string global-mode-string))
+ (force-mode-line-update)
+ (error "No active clock"))
+ (save-excursion ; Do not replace this with `with-current-buffer'.
+ (with-no-warnings (set-buffer (org-clocking-buffer)))
(goto-char org-clock-marker)
(delete-region (1- (point-at-bol)) (point-at-eol))
;; Just in case, remove any empty LOGBOOK left over
@@ -1196,7 +1344,7 @@ With prefix arg SELECT, offer recently clocked tasks for selection."
(select
(or (org-clock-select-task "Select task to go to: ")
(error "No task selected")))
- ((marker-buffer org-clock-marker) org-clock-marker)
+ ((org-clocking-p) org-clock-marker)
((and org-clock-goto-may-find-recent-task
(car org-clock-history)
(marker-buffer (car org-clock-history)))
@@ -1210,6 +1358,7 @@ With prefix arg SELECT, offer recently clocked tasks for selection."
(org-back-to-heading t)
(org-cycle-hide-drawers 'children)
(recenter)
+ (org-reveal)
(if recent
(message "No running clock, this is the most recently clocked task"))
(run-hooks 'org-clock-goto-hook)))
@@ -1218,10 +1367,13 @@ With prefix arg SELECT, offer recently clocked tasks for selection."
"Holds the file total time in minutes, after a call to `org-clock-sum'.")
(make-variable-buffer-local 'org-clock-file-total-minutes)
-(defun org-clock-sum (&optional tstart tend)
+(defun org-clock-sum (&optional tstart tend headline-filter)
"Sum the times for each subtree.
Puts the resulting times in minutes as a text property on each headline.
-TSTART and TEND can mark a time range to be considered."
+TSTART and TEND can mark a time range to be considered. HEADLINE-FILTER is a
+zero-arg function that, if specified, is called for each headline in the time
+range with point at the headline. Headlines for which HEADLINE-FILTER returns
+nil are excluded from the clock summation."
(interactive)
(let* ((bmp (buffer-modified-p))
(re (concat "^\\(\\*+\\)[ \t]\\|^[ \t]*"
@@ -1237,7 +1389,9 @@ TSTART and TEND can mark a time range to be considered."
(if (stringp tend) (setq tend (org-time-string-to-seconds tend)))
(if (consp tstart) (setq tstart (org-float-time tstart)))
(if (consp tend) (setq tend (org-float-time tend)))
- (remove-text-properties (point-min) (point-max) '(:org-clock-minutes t))
+ (remove-text-properties (point-min) (point-max)
+ '(:org-clock-minutes t
+ :org-clock-force-headline-inclusion t))
(save-excursion
(goto-char (point-max))
(while (re-search-backward re nil t)
@@ -1259,20 +1413,50 @@ TSTART and TEND can mark a time range to be considered."
(setq t1 (+ t1 (string-to-number (match-string 5))
(* 60 (string-to-number (match-string 4))))))
(t ;; A headline
- (setq level (- (match-end 1) (match-beginning 1)))
- (when (or (> t1 0) (> (aref ltimes level) 0))
- (loop for l from 0 to level do
- (aset ltimes l (+ (aref ltimes l) t1)))
- (setq t1 0 time (aref ltimes level))
- (loop for l from level to (1- lmax) do
- (aset ltimes l 0))
- (goto-char (match-beginning 0))
- (put-text-property (point) (point-at-eol) :org-clock-minutes time)))))
+ ;; Add the currently clocking item time to the total
+ (when (and org-clock-report-include-clocking-task
+ (equal (org-clocking-buffer) (current-buffer))
+ (equal (marker-position org-clock-hd-marker) (point))
+ tstart
+ tend
+ (>= (org-float-time org-clock-start-time) tstart)
+ (<= (org-float-time org-clock-start-time) tend))
+ (let ((time (floor (- (org-float-time)
+ (org-float-time org-clock-start-time)) 60)))
+ (setq t1 (+ t1 time))))
+ (let* ((headline-forced
+ (get-text-property (point)
+ :org-clock-force-headline-inclusion))
+ (headline-included
+ (or (null headline-filter)
+ (save-excursion
+ (save-match-data (funcall headline-filter))))))
+ (setq level (- (match-end 1) (match-beginning 1)))
+ (when (or (> t1 0) (> (aref ltimes level) 0))
+ (when (or headline-included headline-forced)
+ (if headline-included
+ (loop for l from 0 to level do
+ (aset ltimes l (+ (aref ltimes l) t1))))
+ (setq time (aref ltimes level))
+ (goto-char (match-beginning 0))
+ (put-text-property (point) (point-at-eol) :org-clock-minutes time)
+ (if headline-filter
+ (save-excursion
+ (save-match-data
+ (while
+ (> (funcall outline-level) 1)
+ (outline-up-heading 1 t)
+ (put-text-property
+ (point) (point-at-eol)
+ :org-clock-force-headline-inclusion t))))))
+ (setq t1 0)
+ (loop for l from level to (1- lmax) do
+ (aset ltimes l 0)))))))
(setq org-clock-file-total-minutes (aref ltimes 0)))
(set-buffer-modified-p bmp)))
(defun org-clock-sum-current-item (&optional tstart)
- "Returns time, clocked on current item in total"
+ "Return time, clocked on current item in total."
(save-excursion
(save-restriction
(org-narrow-to-subtree)
@@ -1328,7 +1512,7 @@ will be easy to remove."
(org-move-to-column c)
(unless (eolp) (skip-chars-backward "^ \t"))
(skip-chars-backward " \t")
- (setq ov (org-make-overlay (1- (point)) (point-at-eol))
+ (setq ov (make-overlay (1- (point)) (point-at-eol))
tx (concat (buffer-substring (1- (point)) (point))
(make-string (+ off (max 0 (- c (current-column)))) ?.)
(org-add-props (if org-time-clocksum-use-fractional
@@ -1342,9 +1526,9 @@ will be easy to remove."
(list 'face 'org-clock-overlay))
""))
(if (not (featurep 'xemacs))
- (org-overlay-put ov 'display tx)
- (org-overlay-put ov 'invisible t)
- (org-overlay-put ov 'end-glyph (make-glyph tx)))
+ (overlay-put ov 'display tx)
+ (overlay-put ov 'invisible t)
+ (overlay-put ov 'end-glyph (make-glyph tx)))
(push ov org-clock-overlays)))
(defun org-clock-remove-overlays (&optional beg end noremove)
@@ -1353,7 +1537,7 @@ BEG and END are ignored. If NOREMOVE is nil, remove this function
from the `before-change-functions' in the current buffer."
(interactive)
(unless org-inhibit-highlight-removal
- (mapc 'org-delete-overlay org-clock-overlays)
+ (mapc 'delete-overlay org-clock-overlays)
(setq org-clock-overlays nil)
(unless noremove
(remove-hook 'before-change-functions
@@ -1365,16 +1549,20 @@ from the `before-change-functions' in the current buffer."
This is used to stop the clock after a TODO entry is marked DONE,
and is only done if the variable `org-clock-out-when-done' is not nil."
(when (and org-clock-out-when-done
- (member state org-done-keywords)
- (equal (or (buffer-base-buffer (marker-buffer org-clock-marker))
- (marker-buffer org-clock-marker))
+ (or (and (eq t org-clock-out-when-done)
+ (member state org-done-keywords))
+ (and (listp org-clock-out-when-done)
+ (member state org-clock-out-when-done)))
+ (equal (or (buffer-base-buffer (org-clocking-buffer))
+ (org-clocking-buffer))
(or (buffer-base-buffer (current-buffer))
(current-buffer)))
(< (point) org-clock-marker)
(> (save-excursion (outline-next-heading) (point))
org-clock-marker))
;; Clock out, but don't accept a logging message for this.
- (let ((org-log-note-clock-out nil))
+ (let ((org-log-note-clock-out nil)
+ (org-clock-out-switch-to-state nil))
(org-clock-out))))
(add-hook 'org-after-todo-state-change-hook
@@ -1583,6 +1771,8 @@ the currently selected interval size."
(te (plist-get params :tend))
(block (plist-get params :block))
(link (plist-get params :link))
+ (tags (plist-get params :tags))
+ (matcher (if tags (cdr (org-make-tags-matcher tags))))
ipos time p level hlc hdl tsp props content recalc formula pcol
cc beg end pos tbl tbl1 range-text rm-file-column scope-is-list st)
(setq org-clock-file-total-minutes nil)
@@ -1650,6 +1840,7 @@ the currently selected interval size."
(org-prepare-agenda-buffers files)
(while (setq file (pop files))
(with-current-buffer (find-buffer-visiting file)
+ (setq org-clock-file-total-minutes 0)
(setq tbl1 (org-dblock-write:clocktable p1))
(when tbl1
(push (org-clocktable-add-file
@@ -1664,7 +1855,14 @@ the currently selected interval size."
(goto-char pos)
(unless scope-is-list
- (org-clock-sum ts te)
+ (org-clock-sum ts te
+ (unless (null matcher)
+ (lambda ()
+ (let ((tags-list
+ (org-split-string
+ (or (org-entry-get (point) "ALLTAGS") "")
+ ":")))
+ (eval matcher)))))
(goto-char (point-min))
(setq st t)
(while (or (and (bobp) (prog1 st (setq st nil))
@@ -1675,7 +1873,7 @@ the currently selected interval size."
(when (setq time (get-text-property p :org-clock-minutes))
(save-excursion
(beginning-of-line 1)
- (when (and (looking-at (org-re "\\(\\*+\\)[ \t]+\\(.*?\\)\\([ \t]+:[[:alnum:]_@:]+:\\)?[ \t]*$"))
+ (when (and (looking-at (org-re "\\(\\*+\\)[ \t]+\\(.*?\\)\\([ \t]+:[[:alnum:]_@#%:]+:\\)?[ \t]*$"))
(setq level (org-reduced-level
(- (match-end 1) (match-beginning 1))))
(<= level maxlevel))
@@ -1768,7 +1966,8 @@ the currently selected interval size."
(org-table-recalculate 'all))
(when rm-file-column
(forward-char 1)
- (org-table-delete-column)))))))
+ (org-table-delete-column))
+ total-time)))))
(defun org-clocktable-steps (params)
(let* ((p1 (copy-sequence params))
@@ -1776,15 +1975,28 @@ the currently selected interval size."
(te (plist-get p1 :tend))
(step0 (plist-get p1 :step))
(step (cdr (assoc step0 '((day . 86400) (week . 604800)))))
+ (stepskip0 (plist-get p1 :stepskip0))
(block (plist-get p1 :block))
- cc range-text)
+ cc range-text step-time)
(when block
(setq cc (org-clock-special-range block nil t)
ts (car cc) te (nth 1 cc) range-text (nth 2 cc)))
- (if ts (setq ts (org-float-time
- (apply 'encode-time (org-parse-time-string ts)))))
- (if te (setq te (org-float-time
- (apply 'encode-time (org-parse-time-string te)))))
+ (cond
+ ((numberp ts)
+ ;; If ts is a number, it's an absolute day number from org-agenda.
+ (destructuring-bind (month day year) (calendar-gregorian-from-absolute ts)
+ (setq ts (org-float-time (encode-time 0 0 0 day month year)))))
+ (ts
+ (setq ts (org-float-time
+ (apply 'encode-time (org-parse-time-string ts))))))
+ (cond
+ ((numberp te)
+ ;; Likewise for te.
+ (destructuring-bind (month day year) (calendar-gregorian-from-absolute te)
+ (setq te (org-float-time (encode-time 0 0 0 day month year)))))
+ (te
+ (setq te (org-float-time
+ (apply 'encode-time (org-parse-time-string te))))))
(setq p1 (plist-put p1 :header ""))
(setq p1 (plist-put p1 :step nil))
(setq p1 (plist-put p1 :block nil))
@@ -1798,8 +2010,14 @@ the currently selected interval size."
(seconds-to-time (setq ts (+ ts step))))))
(insert "\n" (if (eq step0 'day) "Daily report: " "Weekly report starting on: ")
(plist-get p1 :tstart) "\n")
- (org-dblock-write:clocktable p1)
+ (setq step-time (org-dblock-write:clocktable p1))
(re-search-forward "#\\+END:")
+ (when (and (equal step-time 0) stepskip0)
+ ;; Remove the empty table
+ (delete-region (point-at-bol)
+ (save-excursion
+ (re-search-backward "^\\(Daily\\|Weekly\\) report" nil t)
+ (point))))
(end-of-line 0))))
(defun org-clocktable-add-file (file table)
@@ -1857,7 +2075,7 @@ The details of what will be saved are regulated by the variable
system-name (format-time-string
(cdr org-time-stamp-formats))))
(if (and (memq org-clock-persist '(t clock))
- (setq b (marker-buffer org-clock-marker))
+ (setq b (org-clocking-buffer))
(setq b (or (buffer-base-buffer b) b))
(buffer-live-p b)
(buffer-file-name b)
@@ -1866,7 +2084,7 @@ The details of what will be saved are regulated by the variable
(substring-no-properties org-clock-heading)
") "))))
(insert "(setq resume-clock '(\""
- (buffer-file-name (marker-buffer org-clock-marker))
+ (buffer-file-name (org-clocking-buffer))
"\" . " (int-to-string (marker-position org-clock-marker))
"))\n"))
;; Store clocked task history. Tasks are stored reversed to make
@@ -1932,7 +2150,7 @@ The details of what will be saved are regulated by the variable
;;;###autoload
(defun org-clock-persistence-insinuate ()
- "Set up hooks for clock persistence"
+ "Set up hooks for clock persistence."
(add-hook 'org-mode-hook 'org-clock-load)
(add-hook 'kill-emacs-hook 'org-clock-save))
diff --git a/lisp/org/org-colview.el b/lisp/org/org-colview.el
index 4786be665ca..15dc7b37a62 100644
--- a/lisp/org/org-colview.el
+++ b/lisp/org/org-colview.el
@@ -6,7 +6,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -36,6 +36,9 @@
(declare-function org-agenda-redo "org-agenda" ())
(declare-function org-agenda-do-context-action "org-agenda" ())
+(when (featurep 'xemacs)
+ (error "Do not load this file into XEmacs, use 'org-colview-xemacs.el'."))
+
;;; Column View
(defvar org-columns-overlays nil
@@ -146,8 +149,8 @@ This is the compiled version of the format.")
(defun org-columns-new-overlay (beg end &optional string face)
"Create a new column overlay and add it to the list."
- (let ((ov (org-make-overlay beg end)))
- (org-overlay-put ov 'face (or face 'secondary-selection))
+ (let ((ov (make-overlay beg end)))
+ (overlay-put ov 'face (or face 'secondary-selection))
(org-overlay-display ov string face)
(push ov org-columns-overlays)
ov))
@@ -220,12 +223,14 @@ This is the compiled version of the format.")
(org-unmodified
(setq ov (org-columns-new-overlay
beg (setq beg (1+ beg)) string (if dateline face1 face)))
- (org-overlay-put ov 'keymap org-columns-map)
- (org-overlay-put ov 'org-columns-key property)
- (org-overlay-put ov 'org-columns-value (cdr ass))
- (org-overlay-put ov 'org-columns-value-modified modval)
- (org-overlay-put ov 'org-columns-pom pom)
- (org-overlay-put ov 'org-columns-format f))
+ (overlay-put ov 'keymap org-columns-map)
+ (overlay-put ov 'org-columns-key property)
+ (overlay-put ov 'org-columns-value (cdr ass))
+ (overlay-put ov 'org-columns-value-modified modval)
+ (overlay-put ov 'org-columns-pom pom)
+ (overlay-put ov 'org-columns-format f)
+ (overlay-put ov 'line-prefix "")
+ (overlay-put ov 'wrap-prefix ""))
(if (or (not (char-after beg))
(equal (char-after beg) ?\n))
(let ((inhibit-read-only t))
@@ -235,12 +240,14 @@ This is the compiled version of the format.")
;; Make the rest of the line disappear.
(org-unmodified
(setq ov (org-columns-new-overlay beg (point-at-eol)))
- (org-overlay-put ov 'invisible t)
- (org-overlay-put ov 'keymap org-columns-map)
- (org-overlay-put ov 'intangible t)
+ (overlay-put ov 'invisible t)
+ (overlay-put ov 'keymap org-columns-map)
+ (overlay-put ov 'intangible t)
+ (overlay-put ov 'line-prefix "")
+ (overlay-put ov 'wrap-prefix "")
(push ov org-columns-overlays)
- (setq ov (org-make-overlay (1- (point-at-eol)) (1+ (point-at-eol))))
- (org-overlay-put ov 'keymap org-columns-map)
+ (setq ov (make-overlay (1- (point-at-eol)) (1+ (point-at-eol))))
+ (overlay-put ov 'keymap org-columns-map)
(push ov org-columns-overlays)
(let ((inhibit-read-only t))
(put-text-property (max (point-min) (1- (point-at-bol)))
@@ -298,7 +305,7 @@ for the duration of the command.")
(org-add-hook 'post-command-hook 'org-columns-hscoll-title nil 'local)))
(defun org-columns-hscoll-title ()
- "Set the header-line-format so that it scrolls along with the table."
+ "Set the `header-line-format' so that it scrolls along with the table."
(sit-for .0001) ; need to force a redisplay to update window-hscroll
(when (not (= (window-hscroll) org-columns-previous-hscroll))
(setq header-line-format
@@ -323,7 +330,7 @@ for the duration of the command.")
(move-marker org-columns-begin-marker nil)
(move-marker org-columns-top-level-marker nil)
(org-unmodified
- (mapc 'org-delete-overlay org-columns-overlays)
+ (mapc 'delete-overlay org-columns-overlays)
(setq org-columns-overlays nil)
(let ((inhibit-read-only t))
(remove-text-properties (point-min) (point-max) '(read-only t))))
@@ -459,10 +466,16 @@ Where possible, use the standard interface for changing this line."
((equal key "SCHEDULED")
(setq eval '(org-with-point-at pom
(call-interactively 'org-schedule))))
+ ((equal key "BEAMER_env")
+ (setq eval '(org-with-point-at pom
+ (call-interactively 'org-beamer-select-environment))))
(t
(setq allowed (org-property-get-allowed-values pom key 'table))
(if allowed
- (setq nval (org-icompleting-read "Value: " allowed nil t))
+ (setq nval (org-icompleting-read
+ "Value: " allowed nil
+ (not (get-text-property 0 'org-unrestricted
+ (caar allowed)))))
(setq nval (read-string "Edit: " value)))
(setq nval (org-trim nval))
(when (not (equal nval value))
@@ -489,7 +502,7 @@ Where possible, use the standard interface for changing this line."
(progn
(setq org-columns-overlays
(org-delete-all line-overlays org-columns-overlays))
- (mapc 'org-delete-overlay line-overlays)
+ (mapc 'delete-overlay line-overlays)
(org-columns-eval eval))
(org-columns-display-here)))
(org-move-to-column col)
@@ -506,7 +519,7 @@ Where possible, use the standard interface for changing this line."
(txt (match-string 3))
(post "")
txt2)
- (if (string-match (org-re "[ \t]+:[[:alnum:]:_@]+:[ \t]*$") txt)
+ (if (string-match (org-re "[ \t]+:[[:alnum:]:_@#%]+:[ \t]*$") txt)
(setq post (match-string 0 txt)
txt (substring txt 0 (match-beginning 0))))
(setq txt2 (read-string "Edit: " txt))
@@ -618,7 +631,7 @@ an integer, select that value."
(progn
(setq org-columns-overlays
(org-delete-all line-overlays org-columns-overlays))
- (mapc 'org-delete-overlay line-overlays)
+ (mapc 'delete-overlay line-overlays)
(org-columns-eval '(org-entry-put pom key nval)))
(org-columns-display-here)))
(org-move-to-column col)
@@ -737,20 +750,21 @@ around it."
("@max" max_age max (lambda (x) (- org-columns-time x)))
("@mean" mean_age
(lambda (&rest x) (/ (apply '+ x) (float (length x))))
- (lambda (x) (- org-columns-time x))))
+ (lambda (x) (- org-columns-time x)))
+ ("est+" estimate org-estimate-combine))
"Operator <-> format,function,calc map.
Used to compile/uncompile columns format and completing read in
-interactive function org-columns-new.
+interactive function `org-columns-new'.
operator string used in #+COLUMNS definition describing the
summary type
format symbol describing summary type selected interactively in
- org-columns-new and internally in
- org-columns-number-to-string and
- org-columns-string-to-number
+ `org-columns-new' and internally in
+ `org-columns-number-to-string' and
+ `org-columns-string-to-number'
function called with a list of values as argument to calculate
the summary value
-calc function called on every element before summarizing. This is
+calc function called on every element before summarizing. This is
optional and should only be specified if needed")
(defun org-columns-new (&optional prop title width op fmt fun &rest rest)
@@ -912,15 +926,15 @@ Don't set this, this is meant for dynamic scoping.")
(let (fmt val pos)
(save-excursion
(mapc (lambda (ov)
- (when (equal (org-overlay-get ov 'org-columns-key) property)
- (setq pos (org-overlay-start ov))
+ (when (equal (overlay-get ov 'org-columns-key) property)
+ (setq pos (overlay-start ov))
(goto-char pos)
(when (setq val (cdr (assoc property
(get-text-property
(point-at-bol) 'org-summaries))))
- (setq fmt (org-overlay-get ov 'org-columns-format))
- (org-overlay-put ov 'org-columns-value val)
- (org-overlay-put ov 'display (format fmt val)))))
+ (setq fmt (overlay-get ov 'org-columns-format))
+ (overlay-put ov 'org-columns-value val)
+ (overlay-put ov 'display (format fmt val)))))
org-columns-overlays))))
(defun org-columns-compute (property)
@@ -1022,6 +1036,7 @@ Don't set this, this is meant for dynamic scoping.")
(defun org-columns-number-to-string (n fmt &optional printf)
"Convert a computed column number to a string value, according to FMT."
(cond
+ ((memq fmt '(estimate)) (org-estimate-print n printf))
((not (numberp n)) "")
((memq fmt '(add_times max_times min_times mean_times))
(let* ((h (floor n)) (m (floor (+ 0.5 (* 60 (- n h))))))
@@ -1045,28 +1060,30 @@ Don't set this, this is meant for dynamic scoping.")
(format "[%d/%d]" n m)
(format "[%d%%]"(floor (+ 0.5 (* 100. (/ (* 1.0 n) m)))))))
+
(defun org-columns-string-to-number (s fmt)
"Convert a column value to a number that can be used for column computing."
(if s
(cond
((memq fmt '(min_age max_age mean_age))
- (cond ((string= s "") org-columns-time)
- ((string-match
- "\\([0-9]+\\)d \\([0-9]+\\)h \\([0-9]+\\)m \\([0-9]+\\)s"
- s)
- (+ (* 60 (+ (* 60 (+ (* 24 (string-to-number (match-string 1 s)))
- (string-to-number (match-string 2 s))))
- (string-to-number (match-string 3 s))))
- (string-to-number (match-string 4 s))))
- (t (time-to-number-of-days (apply 'encode-time
- (org-parse-time-string s t))))))
+ (cond ((string= s "") org-columns-time)
+ ((string-match
+ "\\([0-9]+\\)d \\([0-9]+\\)h \\([0-9]+\\)m \\([0-9]+\\)s"
+ s)
+ (+ (* 60 (+ (* 60 (+ (* 24 (string-to-number (match-string 1 s)))
+ (string-to-number (match-string 2 s))))
+ (string-to-number (match-string 3 s))))
+ (string-to-number (match-string 4 s))))
+ (t (time-to-number-of-days (apply 'encode-time
+ (org-parse-time-string s t))))))
((string-match ":" s)
- (let ((l (nreverse (org-split-string s ":"))) (sum 0.0))
- (while l
- (setq sum (+ (string-to-number (pop l)) (/ sum 60))))
- sum))
+ (let ((l (nreverse (org-split-string s ":"))) (sum 0.0))
+ (while l
+ (setq sum (+ (string-to-number (pop l)) (/ sum 60))))
+ sum))
((memq fmt '(checkbox checkbox-n-of-m checkbox-percent))
- (if (equal s "[X]") 1. 0.000001))
+ (if (equal s "[X]") 1. 0.000001))
+ ((memq fmt '(estimate)) (org-string-to-estimate s))
(t (string-to-number s)))))
(defun org-columns-uncompile-format (cfmt)
@@ -1103,8 +1120,7 @@ operator the operator if any
format the output format for computed results, derived from operator
printf a printf format for computed values
fun the lisp function to compute summary values, derived from operator
-calc function to get values from base elements
-"
+calc function to get values from base elements"
(let ((start 0) width prop title op op-match f printf fun calc)
(setq org-columns-current-fmt-compiled nil)
(while (string-match
@@ -1377,10 +1393,11 @@ and tailing newline characters."
This will add overlays to the date lines, to show the summary for each day."
(let* ((fmt (mapcar (lambda (x)
(if (equal (car x) "CLOCKSUM")
- (list "CLOCKSUM" (nth 2 x) nil 'add_times nil '+ 'identity)
- (cdr x)))
+ (list "CLOCKSUM" (nth 1 x) (nth 2 x) ":" 'add_times
+ nil '+ nil)
+ x))
org-columns-current-fmt-compiled))
- line c c1 stype calc sumfunc props lsum entries prop v)
+ line c c1 stype calc sumfunc props lsum entries prop v title)
(catch 'exit
(when (delq nil (mapcar 'cadr fmt))
;; OK, at least one summation column, it makes sense to try this
@@ -1404,9 +1421,10 @@ This will add overlays to the date lines, to show the summary for each day."
(mapcar
(lambda (f)
(setq prop (car f)
- stype (nth 3 f)
- sumfunc (nth 5 f)
- calc (or (nth 6 f) 'identity))
+ title (nth 1 f)
+ stype (nth 4 f)
+ sumfunc (nth 6 f)
+ calc (or (nth 7 f) 'identity))
(cond
((equal prop "ITEM")
(cons prop (buffer-substring (point-at-bol)
@@ -1471,7 +1489,7 @@ This will add overlays to the date lines, to show the summary for each day."
(org-columns-compute (car fm)))))))))))
(defun org-format-time-period (interval)
- "Convert time in fractional days to days/hours/minutes/seconds"
+ "Convert time in fractional days to days/hours/minutes/seconds."
(if (numberp interval)
(let* ((days (floor interval))
(frac-hours (* 24 (- interval days)))
@@ -1481,6 +1499,41 @@ This will add overlays to the date lines, to show the summary for each day."
(format "%dd %02dh %02dm %02ds" days hours minutes seconds))
""))
+(defun org-estimate-mean-and-var (v)
+ "Return the mean and variance of an estimate."
+ (let* ((low (float (car v)))
+ (high (float (cadr v)))
+ (mean (/ (+ low high) 2.0))
+ (var (/ (+ (expt (- mean low) 2.0) (expt (- high mean) 2.0)) 2.0)))
+ (list mean var)))
+
+(defun org-estimate-combine (&rest el)
+ "Combine a list of estimates, using mean and variance.
+The mean and variance of the result will be the sum of the means
+and variances (respectively) of the individual estimates."
+ (let ((mean 0)
+ (var 0))
+ (mapc (lambda (e)
+ (let ((stats (org-estimate-mean-and-var e)))
+ (setq mean (+ mean (car stats)))
+ (setq var (+ var (cadr stats)))))
+ el)
+ (let ((stdev (sqrt var)))
+ (list (- mean stdev) (+ mean stdev)))))
+
+(defun org-estimate-print (e &optional fmt)
+ "Prepare a string representation of an estimate.
+This formats these numbers as two numbers with a \"-\" between them."
+ (if (null fmt) (set 'fmt "%.0f"))
+ (format "%s" (mapconcat (lambda (n) (format fmt n)) e "-")))
+
+(defun org-string-to-estimate (s)
+ "Convert a string to an estimate.
+The string should be two numbers joined with a \"-\"."
+ (if (string-match "\\(.*\\)-\\(.*\\)" s)
+ (list (string-to-number (match-string 1 s))
+ (string-to-number(match-string 2 s)))
+ (list (string-to-number s) (string-to-number s))))
(provide 'org-colview)
diff --git a/lisp/org/org-compat.el b/lisp/org/org-compat.el
index 5ba62214be1..324464803f2 100644
--- a/lisp/org/org-compat.el
+++ b/lisp/org/org-compat.el
@@ -6,7 +6,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -39,7 +39,10 @@
(declare-function find-library-name "find-func" (library))
(declare-function w32-focus-frame "term/w32-win" (frame))
-(defconst org-xemacs-p (featurep 'xemacs)) ; not used by org.el itself
+;; The following constant is for backward compatibility. We do not use
+;; it in org-mode, because the Byte compiler evaluates (featurep 'xemacs)
+;; at compilation time and can therefore optimize code better.
+(defconst org-xemacs-p (featurep 'xemacs))
(defconst org-format-transports-properties-p
(let ((x "a"))
(add-text-properties 0 1 '(test t) x)
@@ -86,25 +89,44 @@ any other entries, and any resulting duplicates will be removed entirely."
(t specs)))
(put 'org-compatible-face 'lisp-indent-function 1)
+(defun org-version-check (version feature level)
+ (let* ((v1 (mapcar 'string-to-number (split-string version "[.]")))
+ (v2 (mapcar 'string-to-number (split-string emacs-version "[.]")))
+ (rmaj (or (nth 0 v1) 99))
+ (rmin (or (nth 1 v1) 99))
+ (rbld (or (nth 2 v1) 99))
+ (maj (or (nth 0 v2) 0))
+ (min (or (nth 1 v2) 0))
+ (bld (or (nth 2 v2) 0)))
+ (if (or (< maj rmaj)
+ (and (= maj rmaj)
+ (< min rmin))
+ (and (= maj rmaj)
+ (= min rmin)
+ (< bld rbld)))
+ (if (eq level :predicate)
+ ;; just return if we have the version
+ nil
+ (let ((msg (format "Emacs %s or greater is recommended for %s"
+ version feature)))
+ (display-warning 'org msg level)
+ t))
+ t)))
+
;;;; Emacs/XEmacs compatibility
+;; Keys
+(defconst org-xemacs-key-equivalents
+ '(([mouse-1] . [button1])
+ ([mouse-2] . [button2])
+ ([mouse-3] . [button3])
+ ([C-mouse-4] . [(control mouse-4)])
+ ([C-mouse-5] . [(control mouse-5)]))
+ "Translation alist for a couple of keys.")
+
;; Overlay compatibility functions
-(defun org-make-overlay (beg end &optional buffer)
- (if (featurep 'xemacs)
- (make-extent beg end buffer)
- (make-overlay beg end buffer)))
-(defun org-delete-overlay (ovl)
- (if (featurep 'xemacs) (progn (delete-extent ovl) nil) (delete-overlay ovl)))
(defun org-detach-overlay (ovl)
(if (featurep 'xemacs) (detach-extent ovl) (delete-overlay ovl)))
-(defun org-move-overlay (ovl beg end &optional buffer)
- (if (featurep 'xemacs)
- (set-extent-endpoints ovl beg end (or buffer (current-buffer)))
- (move-overlay ovl beg end buffer)))
-(defun org-overlay-put (ovl prop value)
- (if (featurep 'xemacs)
- (set-extent-property ovl prop value)
- (overlay-put ovl prop value)))
(defun org-overlay-display (ovl text &optional face evap)
"Make overlay OVL display TEXT with face FACE."
(if (featurep 'xemacs)
@@ -124,32 +146,33 @@ any other entries, and any resulting duplicates will be removed entirely."
(if face (org-add-props text nil 'face face))
(overlay-put ovl 'before-string text)
(if evap (overlay-put ovl 'evaporate t))))
-(defun org-overlay-get (ovl prop)
- (if (featurep 'xemacs)
- (extent-property ovl prop)
- (overlay-get ovl prop)))
-(defun org-overlays-at (pos)
- (if (featurep 'xemacs) (extents-at pos) (overlays-at pos)))
-(defun org-overlays-in (&optional start end)
- (if (featurep 'xemacs)
- (extent-list nil start end)
- (overlays-in start end)))
-(defun org-overlay-start (o)
- (if (featurep 'xemacs) (extent-start-position o) (overlay-start o)))
-(defun org-overlay-end (o)
- (if (featurep 'xemacs) (extent-end-position o) (overlay-end o)))
-(defun org-overlay-buffer (o)
- (if (featurep 'xemacs) (extent-buffer o) (overlay-buffer o)))
(defun org-find-overlays (prop &optional pos delete)
"Find all overlays specifying PROP at POS or point.
If DELETE is non-nil, delete all those overlays."
- (let ((overlays (org-overlays-at (or pos (point))))
+ (let ((overlays (overlays-at (or pos (point))))
ov found)
(while (setq ov (pop overlays))
- (if (org-overlay-get ov prop)
- (if delete (org-delete-overlay ov) (push ov found))))
+ (if (overlay-get ov prop)
+ (if delete (delete-overlay ov) (push ov found))))
found))
+(defun org-get-x-clipboard (value)
+ "Get the value of the x clipboard, compatible with XEmacs, and GNU Emacs 21."
+ (if (eq window-system 'x)
+ (let ((x (org-get-x-clipboard-compat value)))
+ (if x (org-no-properties x)))))
+
+(defsubst org-decompose-region (beg end)
+ "Decompose from BEG to END."
+ (if (featurep 'xemacs)
+ (let ((modified-p (buffer-modified-p))
+ (buffer-read-only nil))
+ (remove-text-properties beg end '(composition nil))
+ (set-buffer-modified-p modified-p))
+ (decompose-region beg end)))
+
+;; Miscellaneous functions
+
(defun org-add-hook (hook function &optional append local)
"Add-hook, compatible with both Emacsen."
(if (and local (featurep 'xemacs))
@@ -170,7 +193,7 @@ that will be added to PLIST. Returns the string that was modified."
"Fit WINDOW to the buffer, but only if it is not a side-by-side window.
WINDOW defaults to the selected window. MAX-HEIGHT and MIN-HEIGHT are
passed through to `fit-window-to-buffer'. If SHRINK-ONLY is set, call
-`shrink-window-if-larger-than-buffer' instead, the hight limit are
+`shrink-window-if-larger-than-buffer' instead, the height limit is
ignored in this case."
(cond ((if (fboundp 'window-full-width-p)
(not (window-full-width-p window))
@@ -183,6 +206,26 @@ ignored in this case."
(shrink-window-if-larger-than-buffer window)))
(or window (selected-window)))
+(defun org-number-sequence (from &optional to inc)
+ "Call `number-sequence or emulate it."
+ (if (fboundp 'number-sequence)
+ (number-sequence from to inc)
+ (if (or (not to) (= from to))
+ (list from)
+ (or inc (setq inc 1))
+ (when (zerop inc) (error "The increment can not be zero"))
+ (let (seq (n 0) (next from))
+ (if (> inc 0)
+ (while (<= next to)
+ (setq seq (cons next seq)
+ n (1+ n)
+ next (+ from (* n inc))))
+ (while (>= next to)
+ (setq seq (cons next seq)
+ n (1+ n)
+ next (+ from (* n inc)))))
+ (nreverse seq)))))
+
;; Region compatibility
(defvar org-ignore-region nil
@@ -206,19 +249,6 @@ Works on both Emacs and XEmacs."
;; Invisibility compatibility
-(defun org-add-to-invisibility-spec (arg)
- "Add elements to `buffer-invisibility-spec'.
-See documentation for `buffer-invisibility-spec' for the kind of elements
-that can be added."
- (cond
- ((fboundp 'add-to-invisibility-spec)
- (add-to-invisibility-spec arg))
- ((or (null buffer-invisibility-spec) (eq buffer-invisibility-spec t))
- (setq buffer-invisibility-spec (list arg)))
- (t
- (setq buffer-invisibility-spec
- (cons arg buffer-invisibility-spec)))))
-
(defun org-remove-from-invisibility-spec (arg)
"Remove elements from `buffer-invisibility-spec'."
(if (fboundp 'remove-from-invisibility-spec)
@@ -233,62 +263,42 @@ that can be added."
(member arg buffer-invisibility-spec)
nil))
+(defmacro org-xemacs-without-invisibility (&rest body)
+ "Turn off exents with invisibility while executing BODY."
+ `(let ((ext-inv (extent-list nil (point-at-bol) (point-at-eol)
+ 'all-extents-closed-open 'invisible))
+ ext-inv-specs)
+ (dolist (ext ext-inv)
+ (when (extent-property ext 'invisible)
+ (add-to-list 'ext-inv-specs (list ext (extent-property
+ ext 'invisible)))
+ (set-extent-property ext 'invisible nil)))
+ ,@body
+ (dolist (ext-inv-spec ext-inv-specs)
+ (set-extent-property (car ext-inv-spec) 'invisible
+ (cadr ext-inv-spec)))))
+
(defun org-indent-to-column (column &optional minimum buffer)
"Work around a bug with extents with invisibility in XEmacs."
(if (featurep 'xemacs)
- (let ((ext-inv (extent-list
- nil (point-at-bol) (point-at-eol)
- 'all-extents-closed-open 'invisible))
- ext-inv-specs)
- (dolist (ext ext-inv)
- (when (extent-property ext 'invisible)
- (add-to-list 'ext-inv-specs (list ext (extent-property
- ext 'invisible)))
- (set-extent-property ext 'invisible nil)))
- (indent-to-column column minimum buffer)
- (dolist (ext-inv-spec ext-inv-specs)
- (set-extent-property (car ext-inv-spec) 'invisible
- (cadr ext-inv-spec))))
+ (org-xemacs-without-invisibility (indent-to-column column minimum buffer))
(indent-to-column column minimum)))
(defun org-indent-line-to (column)
"Work around a bug with extents with invisibility in XEmacs."
(if (featurep 'xemacs)
- (let ((ext-inv (extent-list
- nil (point-at-bol) (point-at-eol)
- 'all-extents-closed-open 'invisible))
- ext-inv-specs)
- (dolist (ext ext-inv)
- (when (extent-property ext 'invisible)
- (add-to-list 'ext-inv-specs (list ext (extent-property
- ext 'invisible)))
- (set-extent-property ext 'invisible nil)))
- (indent-line-to column)
- (dolist (ext-inv-spec ext-inv-specs)
- (set-extent-property (car ext-inv-spec) 'invisible
- (cadr ext-inv-spec))))
+ (org-xemacs-without-invisibility (indent-line-to column))
(indent-line-to column)))
(defun org-move-to-column (column &optional force buffer)
(if (featurep 'xemacs)
- (let ((ext-inv (extent-list
- nil (point-at-bol) (point-at-eol)
- 'all-extents-closed-open 'invisible))
- ext-inv-specs)
- (dolist (ext ext-inv)
- (when (extent-property ext 'invisible)
- (add-to-list 'ext-inv-specs (list ext (extent-property ext
- 'invisible)))
- (set-extent-property ext 'invisible nil)))
- (move-to-column column force buffer)
- (dolist (ext-inv-spec ext-inv-specs)
- (set-extent-property (car ext-inv-spec) 'invisible
- (cadr ext-inv-spec))))
+ (org-xemacs-without-invisibility (move-to-column column force buffer))
(move-to-column column force)))
(defun org-get-x-clipboard-compat (value)
- "Get the clipboard value on XEmacs or Emacs 21"
- (cond (org-xemacs-p (org-no-warnings (get-selection-no-error value)))
+ "Get the clipboard value on XEmacs or Emacs 21."
+ (cond ((featurep 'xemacs)
+ (org-no-warnings (get-selection-no-error value)))
((fboundp 'x-get-selection)
(condition-case nil
(or (x-get-selection value 'UTF8_STRING)
@@ -362,6 +372,52 @@ TIME defaults to the current time."
(time-to-seconds (or time (current-time)))
(float-time time)))
+(defun org-string-match-p (&rest args)
+ (if (fboundp 'string-match-p)
+ (apply 'string-match-p args)
+ (save-match-data
+ (apply 'string-match args))))
+
+(defun org-looking-at-p (&rest args)
+ (if (fboundp 'looking-at-p)
+ (apply 'looking-at-p args)
+ (save-match-data
+ (apply 'looking-at args))))
+
+; XEmacs does not have `looking-back'.
+(if (fboundp 'looking-back)
+ (defalias 'org-looking-back 'looking-back)
+ (defun org-looking-back (regexp &optional limit greedy)
+ "Return non-nil if text before point matches regular expression REGEXP.
+Like `looking-at' except matches before point, and is slower.
+LIMIT if non-nil speeds up the search by specifying a minimum
+starting position, to avoid checking matches that would start
+before LIMIT.
+
+If GREEDY is non-nil, extend the match backwards as far as
+possible, stopping when a single additional previous character
+cannot be part of a match for REGEXP. When the match is
+extended, its starting position is allowed to occur before
+LIMIT."
+ (let ((start (point))
+ (pos
+ (save-excursion
+ (and (re-search-backward (concat "\\(?:" regexp "\\)\\=") limit t)
+ (point)))))
+ (if (and greedy pos)
+ (save-restriction
+ (narrow-to-region (point-min) start)
+ (while (and (> pos (point-min))
+ (save-excursion
+ (goto-char pos)
+ (backward-char 1)
+ (looking-at (concat "\\(?:" regexp "\\)\\'"))))
+ (setq pos (1- pos)))
+ (save-excursion
+ (goto-char pos)
+ (looking-at (concat "\\(?:" regexp "\\)\\'")))))
+ (not (null pos)))))
+
(provide 'org-compat)
;; arch-tag: a0a0579f-e68c-4bdf-9e55-93768b846bbe
diff --git a/lisp/org/org-crypt.el b/lisp/org/org-crypt.el
index e4c096cd209..693f3ac6a87 100644
--- a/lisp/org/org-crypt.el
+++ b/lisp/org/org-crypt.el
@@ -4,7 +4,7 @@
;; Emacs Lisp Archive Entry
;; Filename: org-crypt.el
-;; Version: 6.33x
+;; Version: 7.3
;; Keywords: org-mode
;; Author: John Wiegley <johnw@gnu.org>
;; Maintainer: Peter Jones <pjones@pmade.com>
@@ -45,6 +45,7 @@
;; decrypt it. This makes it possible to leave secure notes that
;; only the intended recipient can read in a shared-org-mode-files
;; scenario.
+;; If the key is not set, org-crypt will default to symmetric encryption.
;;
;; 3. To later decrypt an entry, use `org-decrypt-entries' or
;; `org-decrypt-entry'. It might be useful to bind this to a key,
@@ -66,6 +67,8 @@
(require 'org)
+;;; Code:
+
(declare-function epg-decrypt-string "epg" (context cipher))
(declare-function epg-list-keys "epg" (context &optional name mode))
(declare-function epg-make-context "epg"
@@ -80,24 +83,25 @@
:tag "Org Crypt" :group 'org)
(defcustom org-crypt-tag-matcher "crypt"
- "The tag matcher used to find headings whose contents should be
-encrypted. See the \"Match syntax\" section of the org manual
-for more details."
+ "The tag matcher used to find headings whose contents should be encrypted.
+
+See the \"Match syntax\" section of the org manual for more details."
:type 'string :group 'org-crypt)
(defcustom org-crypt-key nil
- "The default key to use when encrypting the contents of a
-heading. This can also be overridden in the CRYPTKEY property."
+ "The default key to use when encrypting the contents of a heading.
+
+This setting can also be overridden in the CRYPTKEY property."
:type 'string :group 'org-crypt)
(defun org-crypt-key-for-heading ()
- "Returns the encryption key for the current heading."
+ "Return the encryption key for the current heading."
(save-excursion
(org-back-to-heading t)
- (or (org-entry-get nil "CRYPTKEY" 'selective)
+ (or (org-entry-get nil "CRYPTKEY" 'selective)
org-crypt-key
(and (boundp 'epa-file-encrypt-to) epa-file-encrypt-to)
- (error "No crypt key set"))))
+ (message "No crypt key set, using symmetric encryption."))))
(defun org-encrypt-entry ()
"Encrypt the content of the current headline."
@@ -105,71 +109,77 @@ heading. This can also be overridden in the CRYPTKEY property."
(require 'epg)
(save-excursion
(org-back-to-heading t)
- (forward-line)
- (when (not (looking-at "-----BEGIN PGP MESSAGE-----"))
- (let ((folded (org-invisible-p))
- (epg-context (epg-make-context nil t t))
- (crypt-key (org-crypt-key-for-heading))
- (beg (point))
- end encrypted-text)
- (org-end-of-subtree t t)
- (org-back-over-empty-lines)
- (setq end (point)
- encrypted-text
- (epg-encrypt-string
- epg-context
- (buffer-substring-no-properties beg end)
- (epg-list-keys epg-context crypt-key)))
- (delete-region beg end)
- (insert encrypted-text)
- (when folded
- (save-excursion
- (org-back-to-heading t)
- (hide-subtree)))
- nil))))
+ (let ((start-heading (point)))
+ (forward-line)
+ (when (not (looking-at "-----BEGIN PGP MESSAGE-----"))
+ (let ((folded (org-invisible-p))
+ (epg-context (epg-make-context nil t t))
+ (crypt-key (org-crypt-key-for-heading))
+ (beg (point))
+ end encrypted-text)
+ (goto-char start-heading)
+ (org-end-of-subtree t t)
+ (org-back-over-empty-lines)
+ (setq end (point)
+ encrypted-text
+ (epg-encrypt-string
+ epg-context
+ (buffer-substring-no-properties beg end)
+ (epg-list-keys epg-context crypt-key)))
+ (delete-region beg end)
+ (insert encrypted-text)
+ (when folded
+ (goto-char start-heading)
+ (hide-subtree))
+ nil)))))
(defun org-decrypt-entry ()
+ "Decrypt the content of the current headline."
(interactive)
(require 'epg)
- (save-excursion
- (org-back-to-heading t)
- (forward-line)
- (when (looking-at "-----BEGIN PGP MESSAGE-----")
- (let* ((beg (point))
- (end (save-excursion
- (search-forward "-----END PGP MESSAGE-----")
- (forward-line)
- (point)))
- (epg-context (epg-make-context nil t t))
- (decrypted-text
- (decode-coding-string
- (epg-decrypt-string
- epg-context
- (buffer-substring-no-properties beg end))
- 'utf-8)))
- (delete-region beg end)
- (insert decrypted-text)
- nil))))
+ (unless (org-before-first-heading-p)
+ (save-excursion
+ (org-back-to-heading t)
+ (forward-line)
+ (when (looking-at "-----BEGIN PGP MESSAGE-----")
+ (let* ((beg (point))
+ (end (save-excursion
+ (search-forward "-----END PGP MESSAGE-----")
+ (forward-line)
+ (point)))
+ (epg-context (epg-make-context nil t t))
+ (decrypted-text
+ (decode-coding-string
+ (epg-decrypt-string
+ epg-context
+ (buffer-substring-no-properties beg end))
+ 'utf-8)))
+ (delete-region beg end)
+ (insert decrypted-text)
+ nil)))))
(defun org-encrypt-entries ()
+ "Encrypt all top-level entries in the current buffer."
(interactive)
(org-scan-tags
'org-encrypt-entry
(cdr (org-make-tags-matcher org-crypt-tag-matcher))))
(defun org-decrypt-entries ()
+ "Decrypt all entries in the current buffer."
(interactive)
- (org-scan-tags
+ (org-scan-tags
'org-decrypt-entry
(cdr (org-make-tags-matcher org-crypt-tag-matcher))))
(defun org-crypt-use-before-save-magic ()
- "Adds a hook that will automatically encrypt entries before a
-file is saved to disk."
- (add-hook
- 'org-mode-hook
+ "Add a hook to automatically encrypt entries before a file is saved to disk."
+ (add-hook
+ 'org-mode-hook
(lambda () (add-hook 'before-save-hook 'org-encrypt-entries nil t))))
-
+
+(add-hook 'org-reveal-start-hook 'org-decrypt-entry)
+
(provide 'org-crypt)
;; arch-tag: 8202ed2c-221e-4001-9e4b-54674a7e846e
diff --git a/lisp/org/org-ctags.el b/lisp/org/org-ctags.el
new file mode 100644
index 00000000000..71e1b1b6a7e
--- /dev/null
+++ b/lisp/org/org-ctags.el
@@ -0,0 +1,541 @@
+;;; org-ctags.el - Integrate Emacs "tags" facility with org mode.
+;;
+;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Paul Sexton <eeeickythump@gmail.com>
+;; Version: 7.3
+
+;; Keywords: org, wp
+;; Version: 7.3
+;;
+;; This file is part of GNU Emacs.
+;;
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;
+;; Synopsis
+;; ========
+;;
+;; Allows org-mode to make use of the Emacs `etags' system. Defines tag
+;; destinations in org-mode files as any text between <<double angled
+;; brackets>>. This allows the tags-generation program `exuberant ctags' to
+;; parse these files and create tag tables that record where these
+;; destinations are found. Plain [[links]] in org mode files which do not have
+;; <<matching destinations>> within the same file will then be interpreted as
+;; links to these 'tagged' destinations, allowing seamless navigation between
+;; multiple org-mode files. Topics can be created in any org mode file and
+;; will always be found by plain links from other files. Other file types
+;; recognised by ctags (source code files, latex files, etc) will also be
+;; available as destinations for plain links, and similarly, org-mode links
+;; will be available as tags from source files. Finally, the function
+;; `org-ctags-find-tag-interactive' lets you choose any known tag, using
+;; autocompletion, and quickly jump to it.
+;;
+;; Installation
+;; ============
+;;
+;; Install org mode
+;; Ensure org-ctags.el is somewhere in your emacs load path.
+;; Download and install Exuberant ctags -- "http://ctags.sourceforge.net/"
+;; Edit your .emacs file (see next section) and load emacs.
+
+;; To put in your init file (.emacs):
+;; ==================================
+;;
+;; Assuming you already have org mode installed and set up:
+;;
+;; (setq org-ctags-path-to-ctags "/path/to/ctags/executable")
+;; (add-hook 'org-mode-hook
+;; (lambda ()
+;; (define-key org-mode-map "\C-co" 'org-ctags-find-tag-interactive)))
+;;
+;; By default, with org-ctags loaded, org will first try and visit the tag
+;; with the same name as the link; then, if unsuccessful, ask the user if
+;; he/she wants to rebuild the 'TAGS' database and try again; then ask if
+;; the user wishes to append 'tag' as a new toplevel heading at the end of
+;; the buffer; and finally, defer to org's default behaviour which is to
+;; search the entire text of the current buffer for 'tag'.
+;;
+;; This behaviour can be modified by changing the value of
+;; ORG-CTAGS-OPEN-LINK-FUNCTIONS. For example I have the following in my
+;; .emacs, which describes the same behaviour as the above paragraph with
+;; one difference:
+;;
+;; (setq org-ctags-open-link-functions
+;; '(org-ctags-find-tag
+;; org-ctags-ask-rebuild-tags-file-then-find-tag
+;; org-ctags-ask-append-topic
+;; org-ctags-fail-silently)) ; <-- prevents org default behaviour
+;;
+;;
+;; Usage
+;; =====
+;;
+;; When you click on a link "[[foo]]" and org cannot find a matching "<<foo>>"
+;; in the current buffer, the tags facility will take over. The file TAGS in
+;; the active directory is examined to see if the tags facility knows about
+;; "<<foo>>" in any other files. If it does, the matching file will be opened
+;; and the cursor will jump to the position of "<<foo>>" in that file.
+;;
+;; User-visible functions:
+;; - `org-ctags-find-tag-interactive': type a tag (plain link) name and visit
+;; it. With autocompletion. Bound to ctrl-O in the above setup.
+;; - All the etags functions should work. These include:
+;;
+;; M-. `find-tag' -- finds the tag at point
+;;
+;; C-M-. find-tag based on regular expression
+;;
+;; M-x tags-search RET -- like C-M-. but searches through ENTIRE TEXT
+;; of ALL the files referenced in the TAGS file. A quick way to
+;; search through an entire 'project'.
+;;
+;; M-* "go back" from a tag jump. Like `org-mark-ring-goto'.
+;; You may need to bind this key yourself with (eg)
+;; (global-set-key (kbd "<M-kp-multiply>") 'pop-tag-mark)
+;;
+;; (see etags chapter in Emacs manual for more)
+;;
+;;
+;; Keeping the TAGS file up to date
+;; ================================
+;;
+;; Tags mode has no way of knowing that you have created new tags by typing in
+;; your org-mode buffer. New tags make it into the TAGS file in 3 ways:
+;;
+;; 1. You re-run (org-ctags-create-tags "directory") to rebuild the file.
+;; 2. You put the function `org-ctags-ask-rebuild-tags-file-then-find-tag' in
+;; your `org-open-link-functions' list, as is done in the setup
+;; above. This will cause the TAGS file to be rebuilt whenever a link
+;; cannot be found. This may be slow with large file collections however.
+;; 3. You run the following from the command line (all 1 line):
+;;
+;; ctags --langdef=orgmode --langmap=orgmode:.org
+;; --regex-orgmode="/<<([^>]+)>>/\1/d,definition/"
+;; -f /your/path/TAGS -e -R /your/path/*.org
+;;
+;; If you are paranoid, you might want to run (org-ctags-create-tags
+;; "/path/to/org/files") at startup, by including the following toplevel form
+;; in .emacs. However this can cause a pause of several seconds if ctags has
+;; to scan lots of files.
+;;
+;; (progn
+;; (message "-- rebuilding tags tables...")
+;; (mapc 'org-create-tags tags-table-list))
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(require 'org)
+
+(defgroup org-ctags nil
+ "Options concerning use of ctags within org mode."
+ :tag "Org-Ctags"
+ :group 'org-link)
+
+(defvar org-ctags-enabled-p t
+ "Activate ctags support in org mode?")
+
+(defvar org-ctags-tag-regexp "/<<([^>]+)>>/\\1/d,definition/"
+ "Regexp expression used by ctags external program.
+The regexp matches tag destinations in org-mode files.
+Format is: /REGEXP/TAGNAME/FLAGS,TAGTYPE/
+See the ctags documentation for more information.")
+
+(defcustom org-ctags-path-to-ctags
+ (case system-type
+ (windows-nt "ctags.exe")
+ (darwin "ctags-exuberant")
+ (t "ctags-exuberant"))
+ "Full path to the ctags executable file."
+ :group 'org-ctags
+ :type 'file)
+
+(defcustom org-ctags-open-link-functions
+ '(org-ctags-find-tag
+ org-ctags-ask-rebuild-tags-file-then-find-tag
+ org-ctags-ask-append-topic)
+ "List of functions to be prepended to ORG-OPEN-LINK-FUNCTIONS when ORG-CTAGS is active."
+ :group 'org-ctags
+ :type 'hook
+ :options '(org-ctags-find-tag
+ org-ctags-ask-rebuild-tags-file-then-find-tag
+ org-ctags-rebuild-tags-file-then-find-tag
+ org-ctags-ask-append-topic
+ org-ctags-append-topic
+ org-ctags-ask-visit-buffer-or-file
+ org-ctags-visit-buffer-or-file
+ org-ctags-fail-silently))
+
+
+(defvar org-ctags-tag-list nil
+ "List of all tags in the active TAGS file.
+Created as a local variable in each buffer.")
+
+(defcustom org-ctags-new-topic-template
+ "* <<%t>>\n\n\n\n\n\n"
+ "Text to insert when creating a new org file via opening a hyperlink.
+The following patterns are replaced in the string:
+ `%t' - replaced with the capitalized title of the hyperlink"
+ :group 'org-ctags
+ :type 'string)
+
+
+(add-hook 'org-mode-hook
+ (lambda ()
+ (when (and org-ctags-enabled-p
+ (buffer-file-name))
+ ;; Make sure this file's directory is added to default
+ ;; directories in which to search for tags.
+ (let ((tags-filename
+ (expand-file-name
+ (concat (file-name-directory (buffer-file-name))
+ "/TAGS"))))
+ (when (file-exists-p tags-filename)
+ (visit-tags-table tags-filename))))))
+
+
+(defadvice visit-tags-table (after org-ctags-load-tag-list activate compile)
+ (when (and org-ctags-enabled-p tags-file-name)
+ (set (make-local-variable 'org-ctags-tag-list)
+ (org-ctags-all-tags-in-current-tags-table))))
+
+
+(defun org-ctags-enable ()
+ (put 'org-mode 'find-tag-default-function 'org-ctags-find-tag-at-point)
+ (setq org-ctags-enabled-p t)
+ (dolist (fn org-ctags-open-link-functions)
+ (add-hook 'org-open-link-functions fn t)))
+
+
+;;; General utility functions. ===============================================
+;; These work outside org-ctags mode.
+
+(defun org-ctags-get-filename-for-tag (tag)
+ "TAG is a string. Search the active TAGS file for a matching tag.
+If the tag is found, return a list containing the filename, line number, and
+buffer position where the tag is found."
+ (interactive "sTag: ")
+ (unless tags-file-name
+ (call-interactively (visit-tags-table)))
+ (save-excursion
+ (visit-tags-table-buffer 'same)
+ (when tags-file-name
+ (with-current-buffer (get-file-buffer tags-file-name)
+ (goto-char (point-min))
+ (cond
+ ((re-search-forward (format "^.*%s\\([0-9]+\\),\\([0-9]+\\)$"
+ (regexp-quote tag)) nil t)
+ (let ((line (string-to-number (match-string 1)))
+ (pos (string-to-number (match-string 2))))
+ (cond
+ ((re-search-backward " \n\\(.*\\),[0-9]+\n")
+ (list (match-string 1) line pos))
+ (t ; can't find a file name preceding the matched
+ ; tag??
+ (error "Malformed TAGS file: %s" (buffer-name))))))
+ (t ; tag not found
+ nil))))))
+
+
+(defun org-ctags-all-tags-in-current-tags-table ()
+ "Read all tags defined in the active TAGS file, into a list of strings.
+Return the list."
+ (interactive)
+ (let ((taglist nil))
+ (unless tags-file-name
+ (call-interactively (visit-tags-table)))
+ (save-excursion
+ (visit-tags-table-buffer 'same)
+ (with-current-buffer (get-file-buffer tags-file-name)
+ (goto-char (point-min))
+ (while (re-search-forward "^.*\\(.*\\)\\([0-9]+\\),\\([0-9]+\\)$"
+ nil t)
+ (push (substring-no-properties (match-string 1)) taglist)))
+ taglist)))
+
+
+(defun org-ctags-string-search-and-replace (search replace string)
+ "Replace all instances of SEARCH with REPLACE in STRING."
+ (replace-regexp-in-string (regexp-quote search) replace string t t))
+
+
+(defun y-or-n-minibuffer (prompt)
+ (let ((use-dialog-box nil))
+ (y-or-n-p prompt)))
+
+
+;;; Internal functions =======================================================
+
+
+(defun org-ctags-open-file (name &optional title)
+ "Visit or create a file called `NAME.org', and insert a new topic.
+The new topic will be titled NAME (or TITLE if supplied)."
+ (interactive "sFile name: ")
+ (let ((filename (substitute-in-file-name (expand-file-name name))))
+ (condition-case v
+ (progn
+ (org-open-file name t)
+ (message "Opened file OK")
+ (goto-char (point-max))
+ (insert (org-ctags-string-search-and-replace
+ "%t" (capitalize (or title name))
+ org-ctags-new-topic-template))
+ (message "Inserted new file text OK")
+ (org-mode-restart))
+ (error (error "Error %S in org-ctags-open-file" v)))))
+
+
+;;;; Misc interoperability with etags system =================================
+
+
+(defadvice find-tag (before org-ctags-set-org-mark-before-finding-tag
+ activate compile)
+ "Before trying to find a tag, save our current position on org mark ring."
+ (save-excursion
+ (if (and (org-mode-p) org-ctags-enabled-p)
+ (org-mark-ring-push))))
+
+
+
+(defun org-ctags-find-tag-at-point ()
+ "Determine default tag to search for, based on text at point.
+If there is no plausible default, return nil."
+ (let (from to bound)
+ (when (or (ignore-errors
+ ;; Look for hyperlink around `point'.
+ (save-excursion
+ (search-backward "[[") (setq from (+ 2 (point))))
+ (save-excursion
+ (goto-char from)
+ (search-forward "]") (setq to (- (point) 1)))
+ (and (> to from) (>= (point) from) (<= (point) to)))
+ (progn
+ ;; Look at text around `point'.
+ (save-excursion
+ (skip-syntax-backward "w_") (setq from (point)))
+ (save-excursion
+ (skip-syntax-forward "w_") (setq to (point)))
+ (> to from))
+ ;; Look between `line-beginning-position' and `point'.
+ (save-excursion
+ (and (setq bound (line-beginning-position))
+ (skip-syntax-backward "^w_" bound)
+ (> (setq to (point)) bound)
+ (skip-syntax-backward "w_")
+ (setq from (point))))
+ ;; Look between `point' and `line-end-position'.
+ (save-excursion
+ (and (setq bound (line-end-position))
+ (skip-syntax-forward "^w_" bound)
+ (< (setq from (point)) bound)
+ (skip-syntax-forward "w_")
+ (setq to (point)))))
+ (buffer-substring-no-properties from to))))
+
+
+;;; Functions for use with 'org-open-link-functions' hook =================
+
+
+(defun org-ctags-find-tag (name)
+ "This function is intended to be used in ORG-OPEN-LINK-FUNCTIONS.
+Look for a tag called `NAME' in the current TAGS table. If it is found,
+visit the file and location where the tag is found."
+ (interactive "sTag: ")
+ (let ((old-buf (current-buffer))
+ (old-pnt (point-marker))
+ (old-mark (copy-marker (mark-marker))))
+ (condition-case nil
+ (progn (find-tag name)
+ t)
+ (error
+ ;; only restore old location if find-tag raises error
+ (set-buffer old-buf)
+ (goto-char old-pnt)
+ (set-marker (mark-marker) old-mark)
+ nil))))
+
+
+(defun org-ctags-visit-buffer-or-file (name &optional create)
+ "This function is intended to be used in ORG-OPEN-LINK-FUNCTIONS.
+Visit buffer named `NAME.org'. If there is no such buffer, visit the file
+with the same name if it exists. If the file does not exist, then behavior
+depends on the value of CREATE.
+
+If CREATE is nil (default), then return nil. Do not create a new file.
+If CREATE is t, create the new file and visit it.
+If CREATE is the symbol `ask', then ask the user if they wish to create
+the new file."
+ (interactive)
+ (let ((filename (concat (substitute-in-file-name
+ (expand-file-name name))
+ ".org")))
+ (cond
+ ((get-buffer (concat name ".org"))
+ ;; Buffer is already open
+ (switch-to-buffer (get-buffer (concat name ".org"))))
+ ((file-exists-p filename)
+ ;; File exists but is not open --> open it
+ (message "Opening existing org file `%S'..."
+ filename)
+ (org-open-file filename t))
+ ((or (eql create t)
+ (and (eql create 'ask)
+ (y-or-n-p (format "File `%s.org' not found; create?" name))))
+ (org-ctags-open-file filename name))
+ (t ;; File does not exist, and we don't want to create it.
+ nil))))
+
+
+(defun org-ctags-ask-visit-buffer-or-file (name)
+ "This function is intended to be used in ORG-OPEN-LINK-FUNCTIONS.
+Wrapper for org-ctags-visit-buffer-or-file, which ensures the user is
+asked before creating a new file."
+ (org-ctags-visit-buffer-or-file name 'ask))
+
+
+(defun org-ctags-append-topic (name &optional narrowp)
+ "This function is intended to be used in ORG-OPEN-LINK-FUNCTIONS.
+Append a new toplevel heading to the end of the current buffer. The
+heading contains NAME surrounded by <<angular brackets>>, thus making
+the heading a destination for the tag `NAME'."
+ (interactive "sTopic: ")
+ (widen)
+ (goto-char (point-max))
+ (newline 2)
+ (message "Adding topic in buffer %s" (buffer-name))
+ (insert (org-ctags-string-search-and-replace
+ "%t" (capitalize name) org-ctags-new-topic-template))
+ (backward-char 4)
+ (org-update-radio-target-regexp)
+ (end-of-line)
+ (forward-line 2)
+ (when narrowp
+ ;;(org-tree-to-indirect-buffer 1) ;; opens new frame
+ (org-narrow-to-subtree))
+ t)
+
+
+(defun org-ctags-ask-append-topic (name &optional narrowp)
+ "This function is intended to be used in ORG-OPEN-LINK-FUNCTIONS.
+Wrapper for org-ctags-append-topic, which first asks the user if they want
+to append a new topic."
+ (if (y-or-n-p (format "Topic `%s' not found; append to end of buffer?"
+ name))
+ (org-ctags-append-topic name narrowp)
+ nil))
+
+
+(defun org-ctags-rebuild-tags-file-then-find-tag (name)
+ "This function is intended to be used in ORG-OPEN-LINK-FUNCTIONS.
+Like ORG-CTAGS-FIND-TAG, but calls the external ctags program first,
+to rebuild (update) the TAGS file."
+ (unless tags-file-name
+ (call-interactively (visit-tags-table)))
+ (when (buffer-file-name)
+ (org-ctags-create-tags))
+ (org-ctags-find-tag name))
+
+
+(defun org-ctags-ask-rebuild-tags-file-then-find-tag (name)
+ "This function is intended to be used in ORG-OPEN-LINK-FUNCTIONS.
+Wrapper for org-ctags-rebuild-tags-file-then-find-tag."
+ (if (and (buffer-file-name)
+ (y-or-n-p
+ (format
+ "Tag `%s' not found. Rebuild table `%s/TAGS' and look again?"
+ name
+ (file-name-directory (buffer-file-name)))))
+ (org-ctags-rebuild-tags-file-then-find-tag name)
+ nil))
+
+
+(defun org-ctags-fail-silently (name)
+ "This function is intended to be used in ORG-OPEN-LINK-FUNCTIONS.
+Put as the last function in the list if you want to prevent org's default
+behavior of free text search."
+ t)
+
+
+;;; User-visible functions ===================================================
+
+
+(defun org-ctags-create-tags (&optional directory-name)
+ "(Re)create tags file in the directory of the active buffer.
+The file will contain tag definitions for all the files in the
+directory and its subdirectories which are recognized by ctags.
+This will include files ending in `.org' as well as most other
+source files (.C, .H, .EL, .LISP, etc). All the resulting tags
+end up in one file, called TAGS, located in the directory. This
+function may take several seconds to finish if the directory or
+its subdirectories contain large numbers of taggable files."
+ (interactive)
+ (assert (buffer-file-name))
+ (let ((dir-name (or directory-name
+ (file-name-directory (buffer-file-name))))
+ (exitcode nil))
+ (save-excursion
+ (setq exitcode
+ (shell-command
+ (format (concat "%s --langdef=orgmode --langmap=orgmode:.org "
+ "--regex-orgmode=\"%s\" -f \"%s\" -e -R \"%s\"")
+ org-ctags-path-to-ctags
+ org-ctags-tag-regexp
+ (expand-file-name (concat dir-name "/TAGS"))
+ (expand-file-name (concat dir-name "/*")))))
+ (cond
+ ((eql 0 exitcode)
+ (set (make-local-variable 'org-ctags-tag-list)
+ (org-ctags-all-tags-in-current-tags-table)))
+ (t
+ ;; This seems to behave differently on Linux, so just ignore
+ ;; error codes for now
+ ;;(error "Calling ctags executable resulted in error code: %s"
+ ;; exitcode)
+ nil)))))
+
+
+(defvar org-ctags-find-tag-history nil
+ "History of tags visited by org-ctags-find-tag-interactive.")
+
+(defun org-ctags-find-tag-interactive ()
+ "Prompt for the name of a tag, with autocompletion, then visit the named tag.
+Uses `ido-mode' if available.
+If the user enters a string that does not match an existing tag, create
+a new topic."
+ (interactive)
+ (let* ((completing-read-fn (if (fboundp 'ido-completing-read)
+ 'ido-completing-read
+ 'completing-read))
+ (tag (funcall completing-read-fn "Topic: " org-ctags-tag-list
+ nil 'confirm nil 'org-ctags-find-tag-history)))
+ (when tag
+ (cond
+ ((member tag org-ctags-tag-list)
+ ;; Existing tag
+ (push tag org-ctags-find-tag-history)
+ (find-tag tag))
+ (t
+ ;; New tag
+ (run-hook-with-args-until-success
+ 'org-open-link-functions tag))))))
+
+
+(org-ctags-enable)
+
+(provide 'org-ctags)
+
+;; arch-tag: 4b1ddd5a-8529-4b17-bcde-96a922d26343
+;;; org-ctags.el ends here
diff --git a/lisp/org/org-datetree.el b/lisp/org/org-datetree.el
index c57fdc5f992..286cdc9a1ae 100644
--- a/lisp/org/org-datetree.el
+++ b/lisp/org/org-datetree.el
@@ -5,7 +5,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -36,13 +36,14 @@
(defvar org-datetree-base-level 1
"The level at which years should be placed in the date tree.
This is normally one, but if the buffer has an entry with a DATE_TREE
-property, the date tree will become a subtree under that entry, so the
-base level will be properly adjusted.")
+property (any value), the date tree will become a subtree under that entry,
+so the base level will be properly adjusted.")
+;;;###autoload
(defun org-datetree-find-date-create (date &optional keep-restriction)
"Find or create an entry for DATE.
If KEEP-RESTRICTION is non-nil, do not widen the buffer.
-When it is nit, the buffer will be widened to make sure an existing date
+When it is nil, the buffer will be widened to make sure an existing date
tree can be found."
(let ((year (nth 2 date))
(month (car date))
diff --git a/lisp/org/org-docbook.el b/lisp/org/org-docbook.el
index afc91daf3c2..7d90ec32fbe 100644
--- a/lisp/org/org-docbook.el
+++ b/lisp/org/org-docbook.el
@@ -4,7 +4,7 @@
;;
;; Emacs Lisp Archive Entry
;; Filename: org-docbook.el
-;; Version: 6.33x
+;; Version: 7.3
;; Author: Baoqiu Cui <cbaoqiu AT yahoo DOT com>
;; Maintainer: Baoqiu Cui <cbaoqiu AT yahoo DOT com>
;; Keywords: org, wp, docbook
@@ -26,7 +26,7 @@
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-;; Commentary:
+;;; Commentary:
;;
;; This library implements a DocBook exporter for org-mode. The basic
;; idea and design is very similar to what `org-export-as-html' has.
@@ -76,6 +76,7 @@
(require 'org)
(require 'org-exp)
(require 'org-html)
+(require 'format-spec)
;;; Variables:
@@ -141,8 +142,8 @@ people work on the same document."
:type 'string)
(defcustom org-export-docbook-footnote-id-prefix "fn-"
- "The prefix of footnote IDs used during exporting. Like
-`org-export-docbook-section-id-prefix', this variable can help
+ "The prefix of footnote IDs used during exporting.
+Like `org-export-docbook-section-id-prefix', this variable can help
avoid same set of footnote IDs being used multiple times."
:group 'org-export-docbook
:type 'string)
@@ -154,7 +155,7 @@ avoid same set of footnote IDs being used multiple times."
("=" "<code>" "</code>")
("~" "<literal>" "</literal>")
("+" "<emphasis role=\"strikethrough\">" "</emphasis>"))
- "Alist of DocBook expressions to convert emphasis fontifiers.
+ "A list of DocBook expressions to convert emphasis fontifiers.
Each element of the list is a list of three elements.
The first element is the character used as a marker for fontification.
The second element is a formatting string to wrap fontified text with.
@@ -183,32 +184,39 @@ default, but users can override them using `#+ATTR_DocBook:'."
:group 'org-export-docbook
:type 'coding-system)
+(defcustom org-export-docbook-xslt-stylesheet nil
+ "File name of the XSLT stylesheet used by DocBook exporter.
+This XSLT stylesheet is used by
+`org-export-docbook-xslt-proc-command' to generate the Formatting
+Object (FO) files. You can use either `fo/docbook.xsl' that
+comes with DocBook, or any customization layer you may have."
+ :group 'org-export-docbook
+ :type 'string)
+
(defcustom org-export-docbook-xslt-proc-command nil
- "XSLT processor command used by DocBook exporter.
-This is the command used to process a DocBook XML file to
-generate the formatting object (FO) file.
+ "Format of XSLT processor command used by DocBook exporter.
+This command is used to process a DocBook XML file to generate
+the Formatting Object (FO) file.
The value of this variable should be a format control string that
-includes two `%s' arguments: the first one is for the output FO
-file name, and the second one is for the input DocBook XML file
-name.
+includes three arguments: `%i', `%o', and `%s'. During exporting
+time, `%i' is replaced by the input DocBook XML file name, `%o'
+is replaced by the output FO file name, and `%s' is replaced by
+`org-export-docbook-xslt-stylesheet' (or the #+XSLT option if it
+is specified in the Org file).
For example, if you use Saxon as the XSLT processor, you may want
to set the variable to
- \"java com.icl.saxon.StyleSheet -o %s %s /path/to/docbook.xsl\"
+ \"java com.icl.saxon.StyleSheet -o %o %i %s\"
If you use Xalan, you can set it to
- \"java org.apache.xalan.xslt.Process -out %s -in %s -xsl /path/to/docbook.xsl\"
+ \"java org.apache.xalan.xslt.Process -out %o -in %i -xsl %s\"
For xsltproc, the following string should work:
- \"xsltproc --output %s /path/to/docbook.xsl %s\"
-
-You need to replace \"/path/to/docbook.xsl\" with the actual path
-to the DocBook stylesheet file on your machine. You can also
-replace it with your own customization layer if you have one.
+ \"xsltproc --output %o %s %i\"
You can include additional stylesheet parameters in this command.
Just make sure that they meet the syntax requirement of each
@@ -217,18 +225,19 @@ processor."
:type 'string)
(defcustom org-export-docbook-xsl-fo-proc-command nil
- "XSL-FO processor command used by DocBook exporter.
-This is the command used to process a formatting object (FO) file
-to generate the PDF file.
+ "Format of XSL-FO processor command used by DocBook exporter.
+This command is used to process a Formatting Object (FO) file to
+generate the PDF file.
The value of this variable should be a format control string that
-includes two `%s' arguments: the first one is for the input FO
-file name, and the second one is for the output PDF file name.
+includes two arguments: `%i' and `%o'. During exporting time,
+`%i' is replaced by the input FO file name, and `%o' is replaced
+by the output PDF file name.
For example, if you use FOP as the XSL-FO processor, you can set
the variable to
- \"fop %s %s\""
+ \"fop %i %o\""
:group 'org-export-docbook
:type 'string)
@@ -333,13 +342,18 @@ in a window. A non-interactive call will only return the buffer."
"Export as DocBook XML file, and generate PDF file."
(interactive "P")
(if (or (not org-export-docbook-xslt-proc-command)
- (not (string-match "%s.+%s" org-export-docbook-xslt-proc-command)))
+ (not (string-match "%[ios].+%[ios].+%[ios]" org-export-docbook-xslt-proc-command)))
(error "XSLT processor command is not set correctly"))
(if (or (not org-export-docbook-xsl-fo-proc-command)
- (not (string-match "%s.+%s" org-export-docbook-xsl-fo-proc-command)))
+ (not (string-match "%[io].+%[io]" org-export-docbook-xsl-fo-proc-command)))
(error "XSL-FO processor command is not set correctly"))
(message "Exporting to PDF...")
(let* ((wconfig (current-window-configuration))
+ (opt-plist
+ (org-export-process-option-filters
+ (org-combine-plists (org-default-export-plist)
+ ext-plist
+ (org-infile-export-plist))))
(docbook-buf (org-export-as-docbook hidden ext-plist
to-buffer body-only pub-dir))
(filename (buffer-file-name docbook-buf))
@@ -348,10 +362,17 @@ in a window. A non-interactive call will only return the buffer."
(pdffile (concat base ".pdf")))
(and (file-exists-p pdffile) (delete-file pdffile))
(message "Processing DocBook XML file...")
- (shell-command (format org-export-docbook-xslt-proc-command
- fofile (shell-quote-argument filename)))
- (shell-command (format org-export-docbook-xsl-fo-proc-command
- fofile pdffile))
+ (shell-command (format-spec org-export-docbook-xslt-proc-command
+ (format-spec-make
+ ?i (shell-quote-argument filename)
+ ?o (shell-quote-argument fofile)
+ ?s (shell-quote-argument
+ (or (plist-get opt-plist :xslt)
+ org-export-docbook-xslt-stylesheet)))))
+ (shell-command (format-spec org-export-docbook-xsl-fo-proc-command
+ (format-spec-make
+ ?i (shell-quote-argument fofile)
+ ?o (shell-quote-argument pdffile))))
(message "Processing DocBook file...done")
(if (not (file-exists-p pdffile))
(error "PDF file was not produced")
@@ -384,6 +405,8 @@ header and footer, simply return the content of the document (all
top-level sections). When PUB-DIR is set, use this as the
publishing directory."
(interactive "P")
+ (run-hooks 'org-export-first-hook)
+
;; Make sure we have a file name when we need it.
(when (and (not (or to-buffer body-only))
(not buffer-file-name))
@@ -529,9 +552,9 @@ publishing directory."
(nth 2 (assoc "=" org-export-docbook-emphasis-alist)))
table-open type
table-buffer table-orig-buffer
- ind item-type starter didclose
+ ind item-type starter
rpl path attr caption label desc descp desc1 desc2 link
- fnc item-tag
+ fnc item-tag item-number
footref-seen footnote-list
id-file
)
@@ -609,7 +632,9 @@ publishing directory."
</info>\n"
(org-docbook-expand title)
firstname othername surname
- (if email (concat "<email>" email "</email>") "")
+ (if (and org-export-email-info
+ email (string-match "\\S-" email))
+ (concat "<email>" email "</email>") "")
)))
(org-init-section-numbers)
@@ -622,7 +647,7 @@ publishing directory."
;; End of quote section?
(when (and inquote (string-match "^\\*+ " line))
- (insert "]]>\n</programlisting>\n")
+ (insert "]]></programlisting>\n")
(org-export-docbook-open-para)
(setq inquote nil))
;; Inside a quote section?
@@ -642,11 +667,25 @@ publishing directory."
(not (string-match "^[ \t]*\\(:.*\\)"
(car lines))))
(setq infixed nil)
- (insert "]]>\n</programlisting>\n")
+ (insert "]]></programlisting>\n")
(org-export-docbook-open-para))
(throw 'nextline nil))
- (org-export-docbook-close-lists-maybe line)
+ ;; List ender: close every open list.
+ (when (equal "ORG-LIST-END" line)
+ (while local-list-type
+ (let ((listtype (car local-list-type)))
+ (org-export-docbook-close-li listtype)
+ (insert (cond
+ ((equal listtype "o") "</orderedlist>\n")
+ ((equal listtype "u") "</itemizedlist>\n")
+ ((equal listtype "d") "</variablelist>\n"))))
+ (pop local-list-type))
+ ;; We did close a list, normal text follows: need <para>
+ (org-export-docbook-open-para)
+ (setq local-list-indent nil
+ in-local-list nil)
+ (throw 'nextline nil))
;; Protected HTML
(when (get-text-property 0 'org-protected line)
@@ -910,7 +949,8 @@ publishing directory."
(while (string-match "\\([^* \t].*?\\)\\[\\([0-9]+\\)\\]" line start)
(if (get-text-property (match-beginning 2) 'org-protected line)
(setq start (match-end 2))
- (let ((num (match-string 2 line)))
+ (let* ((num (match-string 2 line))
+ (footnote-def (assoc num footnote-list)))
(if (assoc num footref-seen)
(setq line (replace-match
(format "%s<footnoteref linkend=\"%s%s\"/>"
@@ -922,9 +962,10 @@ publishing directory."
(match-string 1 line)
org-export-docbook-footnote-id-prefix
num
- (save-match-data
- (org-docbook-expand
- (cdr (assoc num footnote-list)))))
+ (if footnote-def
+ (save-match-data
+ (org-docbook-expand (cdr footnote-def)))
+ (format "FOOTNOTE DEFINITION NOT FOUND: %s" num)))
t t line))
(push (cons num 1) footref-seen))))))
@@ -936,18 +977,6 @@ publishing directory."
txt (match-string 2 line))
(if (string-match quote-re0 txt)
(setq txt (replace-match "" t t txt)))
- (when in-local-list
- ;; Close any local lists before inserting a new header line
- (while local-list-type
- (let ((listtype (car local-list-type)))
- (org-export-docbook-close-li listtype)
- (insert (cond
- ((equal listtype "o") "</orderedlist>\n")
- ((equal listtype "u") "</itemizedlist>\n")
- ((equal listtype "d") "</variablelist>\n"))))
- (pop local-list-type))
- (setq local-list-indent nil
- in-local-list nil))
(org-export-docbook-level-start level txt)
;; QUOTES
(when (string-match quote-re line)
@@ -976,7 +1005,9 @@ publishing directory."
table-orig-buffer (nreverse table-orig-buffer))
(org-export-docbook-close-para-maybe)
(insert (org-export-docbook-finalize-table
- (org-format-table-html table-buffer table-orig-buffer)))))
+ (org-format-table-html table-buffer table-orig-buffer
+ 'no-css)))))
+
(t
;; Normal lines
(when (string-match
@@ -992,31 +1023,15 @@ publishing directory."
starter (if (match-beginning 2)
(substring (match-string 2 line) 0 -1))
line (substring line (match-beginning 5))
- item-tag nil)
+ item-tag nil
+ item-number nil)
+ (if (string-match "\\[@\\(?:start:\\)?\\([0-9]+\\)\\][ \t]?" line)
+ (setq item-number (match-string 1 line)
+ line (replace-match "" t t line)))
(if (and starter (string-match "\\(.*?\\) ::[ \t]*" line))
(setq item-type "d"
item-tag (match-string 1 line)
line (substring line (match-end 0))))
- (when (and (not (equal item-type "d"))
- (not (string-match "[^ \t]" line)))
- ;; Empty line. Pretend indentation is large.
- (setq ind (if org-empty-line-terminates-plain-lists
- 0
- (1+ (or (car local-list-indent) 1)))))
- (setq didclose nil)
- (while (and in-local-list
- (or (and (= ind (car local-list-indent))
- (not starter))
- (< ind (car local-list-indent))))
- (setq didclose t)
- (let ((listtype (car local-list-type)))
- (org-export-docbook-close-li listtype)
- (insert (cond
- ((equal listtype "o") "</orderedlist>\n")
- ((equal listtype "u") "</itemizedlist>\n")
- ((equal listtype "d") "</variablelist>\n"))))
- (pop local-list-type) (pop local-list-indent)
- (setq in-local-list local-list-indent))
(cond
((and starter
(or (not in-local-list)
@@ -1025,6 +1040,15 @@ publishing directory."
(org-export-docbook-close-para-maybe)
(insert (cond
((equal item-type "u") "<itemizedlist>\n<listitem>\n")
+ ((and (equal item-type "o") item-number)
+ ;; Check for a specific start number. If it
+ ;; is specified, we use the ``override''
+ ;; attribute of element <listitem> to pass the
+ ;; info to DocBook. We could also use the
+ ;; ``startingnumber'' attribute of element
+ ;; <orderedlist>, but the former works on both
+ ;; DocBook 5.0 and prior versions.
+ (format "<orderedlist>\n<listitem override=\"%s\">\n" item-number))
((equal item-type "o") "<orderedlist>\n<listitem>\n")
((equal item-type "d")
(format "<variablelist>\n<varlistentry><term>%s</term><listitem>\n" item-tag))))
@@ -1034,11 +1058,27 @@ publishing directory."
(push item-type local-list-type)
(push ind local-list-indent)
(setq in-local-list t))
- (starter
;; Continue current list
+ (starter
+ ;; terminate any previous sublist but first ensure
+ ;; list is not ill-formed
+ (let ((min-ind (apply 'min local-list-indent)))
+ (when (< ind min-ind) (setq ind min-ind)))
+ (while (< ind (car local-list-indent))
+ (let ((listtype (car local-list-type)))
+ (org-export-docbook-close-li listtype)
+ (insert (cond
+ ((equal listtype "o") "</orderedlist>\n")
+ ((equal listtype "u") "</itemizedlist>\n")
+ ((equal listtype "d") "</variablelist>\n"))))
+ (pop local-list-type) (pop local-list-indent)
+ (setq in-local-list local-list-indent))
+ ;; insert new item
(let ((listtype (car local-list-type)))
(org-export-docbook-close-li listtype)
(insert (cond
+ ((and (equal listtype "o") item-number)
+ (format "<listitem override=\"%s\">" item-number))
((equal listtype "o") "<listitem>")
((equal listtype "u") "<listitem>")
((equal listtype "d") (format
@@ -1047,9 +1087,6 @@ publishing directory."
"???"))))))
;; For DocBook, we need to open a para right after tag
;; <listitem>.
- (org-export-docbook-open-para))
- (didclose
- ;; We did close a list, normal text follows: need <para>
(org-export-docbook-open-para)))
;; Checkboxes.
(if (string-match "^[ \t]*\\(\\[[X -]\\]\\)" line)
@@ -1090,20 +1127,9 @@ publishing directory."
;; Properly close all local lists and other lists
(when inquote
- (insert "]]>\n</programlisting>\n")
+ (insert "]]></programlisting>\n")
(org-export-docbook-open-para))
- (when in-local-list
- ;; Close any local lists before inserting a new header line
- (while local-list-type
- (let ((listtype (car local-list-type)))
- (org-export-docbook-close-li listtype)
- (insert (cond
- ((equal listtype "o") "</orderedlist>\n")
- ((equal listtype "u") "</itemizedlist>\n")
- ((equal listtype "d") "</variablelist>\n"))))
- (pop local-list-type))
- (setq local-list-indent nil
- in-local-list nil))
+
;; Close all open sections.
(org-export-docbook-level-start 1 nil)
@@ -1119,6 +1145,13 @@ publishing directory."
"[ \r\n\t]*\\(<para>\\)[ \r\n\t]*</para>[ \r\n\t]*" nil t)
(when (not (get-text-property (match-beginning 1) 'org-protected))
(replace-match "\n")
+ ;; Avoid empty <listitem></listitem> caused by inline tasks.
+ ;; We should add an empty para to make everything valid.
+ (when (and (looking-at "</listitem>")
+ (save-excursion
+ (backward-char (length "<listitem>\n"))
+ (looking-at "<listitem>")))
+ (insert "<para></para>"))
(backward-char 1)))
;; Fill empty sections with <para></para>. This is to make sure
;; that the DocBook document generated is valid and well-formed.
@@ -1163,24 +1196,6 @@ publishing directory."
(defvar in-local-list)
(defvar local-list-indent)
(defvar local-list-type)
-(defun org-export-docbook-close-lists-maybe (line)
- (let ((ind (or (get-text-property 0 'original-indentation line)))
-; (and (string-match "\\S-" line)
-; (org-get-indentation line))))
- didclose)
- (when ind
- (while (and in-local-list
- (<= ind (car local-list-indent)))
- (setq didclose t)
- (let ((listtype (car local-list-type)))
- (org-export-docbook-close-li listtype)
- (insert (cond
- ((equal listtype "o") "</orderedlist>\n")
- ((equal listtype "u") "</itemizedlist>\n")
- ((equal listtype "d") "</variablelist>\n"))))
- (pop local-list-type) (pop local-list-indent)
- (setq in-local-list local-list-indent))
- (and didclose (org-export-docbook-open-para)))))
(defun org-export-docbook-level-start (level title)
"Insert a new level in DocBook export.
@@ -1200,7 +1215,7 @@ When TITLE is nil, just close all open levels."
;; all levels, so the rest is done only if title is given.
;;
;; Format tags: put them into a superscript like format.
- (when (string-match (org-re "\\(:[[:alnum:]_@:]+:\\)[ \t]*$") title)
+ (when (string-match (org-re "\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$") title)
(setq title
(replace-match
(if org-export-with-tags
@@ -1215,7 +1230,8 @@ When TITLE is nil, just close all open levels."
(setq section-number (org-section-number level))
(insert (format "\n<section xml:id=\"%s%s\">\n<title>%s</title>"
org-export-docbook-section-id-prefix
- section-number title))
+ (replace-regexp-in-string "\\." "_" section-number)
+ title))
(org-export-docbook-open-para))))
(defun org-docbook-expand (string)
@@ -1223,7 +1239,7 @@ When TITLE is nil, just close all open levels."
Applies all active conversions. If there are links in the
string, don't modify these."
(let* ((re (concat org-bracket-link-regexp "\\|"
- (org-re "[ \t]+\\(:[[:alnum:]_@:]+:\\)[ \t]*$")))
+ (org-re "[ \t]+\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$")))
m s l res)
(while (setq m (string-match re string))
(setq s (substring string 0 m)
@@ -1246,16 +1262,14 @@ string, don't modify these."
(if org-export-with-sub-superscripts
(setq s (org-export-docbook-convert-sub-super s)))
(if org-export-with-TeX-macros
- (let ((start 0) wd ass)
+ (let ((start 0) wd rep)
(while (setq start (string-match "\\\\\\([a-zA-Z]+\\)\\({}\\)?"
s start))
(if (get-text-property (match-beginning 0) 'org-protected s)
(setq start (match-end 0))
(setq wd (match-string 1 s))
- (if (setq ass (assoc wd org-html-entities))
- (setq s (replace-match (or (cdr ass)
- (concat "&" (car ass) ";"))
- t t s))
+ (if (setq rep (org-entity-get-representation wd 'html))
+ (setq s (replace-match rep t t s))
(setq start (+ start (length wd))))))))
s)
@@ -1312,6 +1326,7 @@ string, don't modify these."
(label (org-find-text-property-in-string 'org-label src))
(default-attr org-export-docbook-default-image-attributes)
tmp)
+ (setq caption (and caption (org-html-do-expand caption)))
(while (setq tmp (pop default-attr))
(if (not (string-match (concat (car tmp) "=") attr))
(setq attr (concat attr " " (car tmp) "=" (cdr tmp)))))
@@ -1337,18 +1352,33 @@ string, don't modify these."
(replace-match ""))))
(defun org-export-docbook-finalize-table (table)
- "Change TABLE to informaltable if caption does not exist.
+ "Clean up TABLE and turn it into DocBook format.
+This function adds a label to the table if it is available, and
+also changes TABLE to informaltable if caption does not exist.
TABLE is a string containing the HTML code generated by
`org-format-table-html' for a table in Org-mode buffer."
- (if (string-match
- "^<table \\(\\(.\\|\n\\)+\\)<caption></caption>\n\\(\\(.\\|\n\\)+\\)</table>"
- table)
- (replace-match (concat "<informaltable "
- (match-string 1 table)
- (match-string 3 table)
- "</informaltable>")
- nil nil table)
- table))
+ (let (table-with-label)
+ ;; Get the label if it exists, and move it into the <table> element.
+ (setq table-with-label
+ (if (string-match
+ "^<table \\(\\(.\\|\n\\)+\\)<a name=\"\\(.+\\)\" id=\".+\"></a>\n\\(\\(.\\|\n\\)+\\)</table>"
+ table)
+ (replace-match (concat "<table xml:id=\"" (match-string 3 table) "\" "
+ (match-string 1 table)
+ (match-string 4 table)
+ "</table>")
+ nil nil table)
+ table))
+ ;; Change <table> into <informaltable> if caption does not exist.
+ (if (string-match
+ "^<table \\(\\(.\\|\n\\)+\\)<caption></caption>\n\\(\\(.\\|\n\\)+\\)</table>"
+ table-with-label)
+ (replace-match (concat "<informaltable "
+ (match-string 1 table-with-label)
+ (match-string 3 table-with-label)
+ "</informaltable>")
+ nil nil table-with-label)
+ table-with-label)))
;; Note: This function is very similar to
;; org-export-html-convert-sub-super. They can be merged in the future.
diff --git a/lisp/org/org-docview.el b/lisp/org/org-docview.el
new file mode 100644
index 00000000000..0c77b690765
--- /dev/null
+++ b/lisp/org/org-docview.el
@@ -0,0 +1,93 @@
+;;; org-docview.el --- support for links to doc-view-mode buffers
+
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Jan Böcker <jan.boecker at jboecker dot de>
+;; Keywords: outlines, hypermedia, calendar, wp
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+;;
+;; This file is part of GNU Emacs.
+;;
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;; Commentary:
+
+;; This file implements links to open files in doc-view-mode.
+;; Org-mode loads this module by default - if this is not what you want,
+;; configure the variable `org-modules'.
+
+;; The links take the form
+;;
+;; docview:<file path>::<page number>
+;;
+;; for example: [[docview:~/.elisp/org/doc/org.pdf::1][Org-Mode Manual]]
+;;
+;; Autocompletion for inserting links is supported; you will be
+;; prompted for a file and a page number.
+;;
+;; If you use org-store-link in a doc-view mode buffer, the stored
+;; link will point to the current page.
+
+;;; Code:
+
+
+(require 'org)
+
+(declare-function doc-view-goto-page "ext:doc-view" (page))
+(declare-function image-mode-window-get "ext:image-mode"
+ (prop &optional winprops))
+
+(autoload 'doc-view-goto-page "doc-view")
+
+(org-add-link-type "docview" 'org-docview-open)
+(add-hook 'org-store-link-functions 'org-docview-store-link)
+
+(defun org-docview-open (link)
+ (when (string-match "\\(.*\\)::\\([0-9]+\\)$" link)
+ (let* ((path (match-string 1 link))
+ (page (string-to-number (match-string 2 link))))
+ (org-open-file path 1) ;; let org-mode open the file (in-emacs = 1)
+ ;; to ensure org-link-frame-setup is respected
+ (doc-view-goto-page page)
+ )))
+
+(defun org-docview-store-link ()
+ "Store a link to a docview buffer."
+ (when (eq major-mode 'doc-view-mode)
+ ;; This buffer is in doc-view-mode
+ (let* ((path buffer-file-name)
+ (page (image-mode-window-get 'page))
+ (link (concat "docview:" path "::" (number-to-string page)))
+ (description ""))
+ (org-store-link-props
+ :type "docview"
+ :link link
+ :description path))))
+
+(defun org-docview-complete-link ()
+ "Use the existing file name completion for file.
+Links to get the file name, then ask the user for the page number
+and append it."
+ (concat (replace-regexp-in-string "^file:" "docview:" (org-file-complete-link))
+ "::"
+ (read-from-minibuffer "Page:" "1")))
+
+
+(provide 'org-docview)
+
+;; arch-tag: dd147a78-cce1-481b-b40a-15869417debe
+
+;;; org-docview.el ends here
diff --git a/lisp/org/org-entities.el b/lisp/org/org-entities.el
new file mode 100644
index 00000000000..5ce5fd7531c
--- /dev/null
+++ b/lisp/org/org-entities.el
@@ -0,0 +1,573 @@
+;;; org-entities.el --- Support for special entities in Org-mode
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Carsten Dominik <carsten at orgmode dot org>,
+;; Ulf Stegemann <ulf at zeitform dot de>
+;; Keywords: outlines, calendar, wp
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+;;
+;; This file is part of GNU Emacs.
+;;
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;; Commentary:
+
+;;; Code:
+
+(require 'org-macs)
+
+(declare-function org-table-align "org-table" ())
+
+(eval-when-compile
+ (require 'cl))
+
+(defgroup org-entities nil
+ "Options concerning entities in Org-mode."
+ :tag "Org Entities"
+ :group 'org)
+
+(defcustom org-entities-ascii-explanatory nil
+ "Non-nil means replace special entities in ASCII.
+For example, this will replace \"\\nsup\" with \"[not a superset of]\"
+in backends where the corresponding character is not available."
+ :group 'org-entities
+ :type 'boolean)
+
+(defcustom org-entities-user nil
+ "User-defined entities used in Org-mode to produce special characters.
+Each entry in this list is a list of strings. It associates the name
+of the entity that can be inserted into an Org file as \\name with the
+appropriate replacements for the different export backends. The order
+of the fields is the following
+
+name As a string, without the leading backslash
+LaTeX replacement In ready LaTeX, no further processing will take place
+LaTeX mathp A Boolean, either t or nil. t if this entity needs
+ to be in math mode.
+HTML replacement In ready HTML, no further processing will take place.
+ Usually this will be an &...; entity.
+ASCII replacement Plain ASCII, no extensions. Symbols that cannot be
+ represented will be left as they are, but see the.
+ variable `org-entities-ascii-explanatory'.
+Latin1 replacement Use the special characters available in latin1.
+utf-8 replacement Use the special characters available in utf-8.
+
+If you define new entities here that require specific LaTeX packages to be
+loaded, add these packages to `org-export-latex-packages-alist'."
+ :group 'org-entities
+ :type '(repeat
+ (list
+ (string :tag "name ")
+ (string :tag "LaTeX ")
+ (boolean :tag "Require LaTeX math?")
+ (string :tag "HTML ")
+ (string :tag "ASCII ")
+ (string :tag "Latin1")
+ (string :tag "utf-8 "))))
+
+(defconst org-entities
+ '(
+ "* Letters"
+ "** Latin"
+ ("Agrave" "\\`{A}" nil "&Agrave;" "A" "À" "À")
+ ("agrave" "\\`{a}" nil "&agrave;" "a" "à" "à")
+ ("Aacute" "\\'{A}" nil "&Aacute;" "A" "Á" "Á")
+ ("aacute" "\\'{a}" nil "&aacute;" "a" "á" "á")
+ ("Acirc" "\\^{A}" nil "&Acirc;" "A" "Â" "Â")
+ ("acirc" "\\^{a}" nil "&acirc;" "a" "â" "â")
+ ("Atilde" "\\~{A}" nil "&Atilde;" "A" "Ã" "Ã")
+ ("atilde" "\\~{a}" nil "&atilde;" "a" "ã" "ã")
+ ("Auml" "\\\"{A}" nil "&Auml;" "Ae" "Ä" "Ä")
+ ("auml" "\\\"{a}" nil "&auml;" "ae" "ä" "ä")
+ ("Aring" "\\AA{}" nil "&Aring;" "A" "Å" "Å")
+ ("AA" "\\AA{}" nil "&Aring;" "A" "Å" "Å")
+ ("aring" "\\aa{}" nil "&aring;" "a" "å" "å")
+ ("AElig" "\\AE{}" nil "&AElig;" "AE" "Æ" "Æ")
+ ("aelig" "\\ae{}" nil "&aelig;" "ae" "æ" "æ")
+ ("Ccedil" "\\c{C}" nil "&Ccedil;" "C" "Ç" "Ç")
+ ("ccedil" "\\c{c}" nil "&ccedil;" "c" "ç" "ç")
+ ("Egrave" "\\`{E}" nil "&Egrave;" "E" "È" "È")
+ ("egrave" "\\`{e}" nil "&egrave;" "e" "è" "è")
+ ("Eacute" "\\'{E}" nil "&Eacute;" "E" "É" "É")
+ ("eacute" "\\'{e}" nil "&eacute;" "e" "é" "é")
+ ("Ecirc" "\\^{E}" nil "&Ecirc;" "E" "Ê" "Ê")
+ ("ecirc" "\\^{e}" nil "&ecirc;" "e" "ê" "ê")
+ ("Euml" "\\\"{E}" nil "&Euml;" "E" "Ë" "Ë")
+ ("euml" "\\\"{e}" nil "&euml;" "e" "ë" "ë")
+ ("Igrave" "\\`{I}" nil "&Igrave;" "I" "Ì" "Ì")
+ ("igrave" "\\`{i}" nil "&igrave;" "i" "ì" "ì")
+ ("Iacute" "\\'{I}" nil "&Iacute;" "I" "Í" "Í")
+ ("iacute" "\\'{i}" nil "&iacute;" "i" "í" "í")
+ ("Icirc" "\\^{I}" nil "&Icirc;" "I" "Î" "Î")
+ ("icirc" "\\^{i}" nil "&icirc;" "i" "î" "î")
+ ("Iuml" "\\\"{I}" nil "&Iuml;" "I" "Ï" "Ï")
+ ("iuml" "\\\"{i}" nil "&iuml;" "i" "ï" "ï")
+ ("Ntilde" "\\~{N}" nil "&Ntilde;" "N" "Ñ" "Ñ")
+ ("ntilde" "\\~{n}" nil "&ntilde;" "n" "ñ" "ñ")
+ ("Ograve" "\\`{O}" nil "&Ograve;" "O" "Ò" "Ò")
+ ("ograve" "\\`{o}" nil "&ograve;" "o" "ò" "ò")
+ ("Oacute" "\\'{O}" nil "&Oacute;" "O" "Ó" "Ó")
+ ("oacute" "\\'{o}" nil "&oacute;" "o" "ó" "ó")
+ ("Ocirc" "\\^{O}" nil "&Ocirc;" "O" "Ô" "Ô")
+ ("ocirc" "\\^{o}" nil "&ocirc;" "o" "ô" "ô")
+ ("Otilde" "\\~{O}" nil "&Otilde;" "O" "Õ" "Õ")
+ ("otilde" "\\~{o}" nil "&otilde;" "o" "õ" "õ")
+ ("Ouml" "\\\"{O}" nil "&Ouml;" "Oe" "Ö" "Ö")
+ ("ouml" "\\\"{o}" nil "&ouml;" "oe" "ö" "ö")
+ ("Oslash" "\\O" nil "&Oslash;" "O" "Ø" "Ø")
+ ("oslash" "\\o{}" nil "&oslash;" "o" "ø" "ø")
+ ("OElig" "\\OE{}" nil "&OElig;" "OE" "OE" "Œ")
+ ("oelig" "\\oe{}" nil "&oelig;" "oe" "oe" "œ")
+ ("Scaron" "\\v{S}" nil "&Scaron;" "S" "S" "Š")
+ ("scaron" "\\v{s}" nil "&scaron;" "s" "s" "š")
+ ("szlig" "\\ss{}" nil "&szlig;" "ss" "ß" "ß")
+ ("Ugrave" "\\`{U}" nil "&Ugrave;" "U" "Ù" "Ù")
+ ("ugrave" "\\`{u}" nil "&ugrave;" "u" "ù" "ù")
+ ("Uacute" "\\'{U}" nil "&Uacute;" "U" "Ú" "Ú")
+ ("uacute" "\\'{u}" nil "&uacute;" "u" "ú" "ú")
+ ("Ucirc" "\\^{U}" nil "&Ucirc;" "U" "Û" "Û")
+ ("ucirc" "\\^{u}" nil "&ucirc;" "u" "û" "û")
+ ("Uuml" "\\\"{U}" nil "&Uuml;" "Ue" "Ü" "Ü")
+ ("uuml" "\\\"{u}" nil "&uuml;" "ue" "ü" "ü")
+ ("Yacute" "\\'{Y}" nil "&Yacute;" "Y" "Ý" "Ý")
+ ("yacute" "\\'{y}" nil "&yacute;" "y" "ý" "ý")
+ ("Yuml" "\\\"{Y}" nil "&Yuml;" "Y" "Y" "Ÿ")
+ ("yuml" "\\\"{y}" nil "&yuml;" "y" "ÿ" "ÿ")
+
+ "** Latin (special face)"
+ ("fnof" "\\textit{f}" nil "&fnof;" "f" "f" "ƒ")
+ ("real" "\\Re" t "&real;" "R" "R" "ℜ")
+ ("image" "\\Im" t "&image;" "I" "I" "ℑ")
+ ("weierp" "\\wp" t "&weierp;" "P" "P" "℘")
+
+ "** Greek"
+ ("Alpha" "A" nil "&Alpha;" "Alpha" "Alpha" "Α")
+ ("alpha" "\\alpha" t "&alpha;" "alpha" "alpha" "α")
+ ("Beta" "B" nil "&Beta;" "Beta" "Beta" "Β")
+ ("beta" "\\beta" t "&beta;" "beta" "beta" "β")
+ ("Gamma" "\\Gamma" t "&Gamma;" "Gamma" "Gamma" "Γ")
+ ("gamma" "\\gamma" t "&gamma;" "gamma" "gamma" "γ")
+ ("Delta" "\\Delta" t "&Delta;" "Delta" "Gamma" "Δ")
+ ("delta" "\\delta" t "&delta;" "delta" "delta" "δ")
+ ("Epsilon" "E" nil "&Epsilon;" "Epsilon" "Epsilon" "Ε")
+ ("epsilon" "\\epsilon" t "&epsilon;" "epsilon" "epsilon" "ε")
+ ("varepsilon" "\\varepsilon" t "&epsilon;" "varepsilon" "varepsilon" "ε")
+ ("Zeta" "Z" nil "&Zeta;" "Zeta" "Zeta" "Ζ")
+ ("zeta" "\\zeta" t "&zeta;" "zeta" "zeta" "ζ")
+ ("Eta" "H" nil "&Eta;" "Eta" "Eta" "Η")
+ ("eta" "\\eta" t "&eta;" "eta" "eta" "η")
+ ("Theta" "\\Theta" t "&Theta;" "Theta" "Theta" "Θ")
+ ("theta" "\\theta" t "&theta;" "theta" "theta" "θ")
+ ("thetasym" "\\vartheta" t "&thetasym;" "theta" "theta" "ϑ")
+ ("vartheta" "\\vartheta" t "&thetasym;" "theta" "theta" "ϑ")
+ ("Iota" "I" nil "&Iota;" "Iota" "Iota" "Ι")
+ ("iota" "\\iota" t "&iota;" "iota" "iota" "ι")
+ ("Kappa" "K" nil "&Kappa;" "Kappa" "Kappa" "Κ")
+ ("kappa" "\\kappa" t "&kappa;" "kappa" "kappa" "κ")
+ ("Lambda" "\\Lambda" t "&Lambda;" "Lambda" "Lambda" "Λ")
+ ("lambda" "\\lambda" t "&lambda;" "lambda" "lambda" "λ")
+ ("Mu" "M" nil "&Mu;" "Mu" "Mu" "Μ")
+ ("mu" "\\mu" t "&mu;" "mu" "mu" "μ")
+ ("nu" "\\nu" t "&nu;" "nu" "nu" "ν")
+ ("Nu" "N" nil "&Nu;" "Nu" "Nu" "Ν")
+ ("Xi" "\\Xi" t "&Xi;" "Xi" "Xi" "Ξ")
+ ("xi" "\\xi" t "&xi;" "xi" "xi" "ξ")
+ ("Omicron" "O" nil "&Omicron;" "Omicron" "Omicron" "Ο")
+ ("omicron" "\\textit{o}" nil "&omicron;" "omicron" "omicron" "ο")
+ ("Pi" "\\Pi" t "&Pi;" "Pi" "Pi" "Π")
+ ("pi" "\\pi" t "&pi;" "pi" "pi" "π")
+ ("Rho" "P" nil "&Rho;" "Rho" "Rho" "Ρ")
+ ("rho" "\\rho" t "&rho;" "rho" "rho" "ρ")
+ ("Sigma" "\\Sigma" t "&Sigma;" "Sigma" "Sigma" "Σ")
+ ("sigma" "\\sigma" t "&sigma;" "sigma" "sigma" "σ")
+ ("sigmaf" "\\varsigma" t "&sigmaf;" "sigmaf" "sigmaf" "ς")
+ ("varsigma" "\\varsigma" t "&sigmaf;" "varsigma" "varsigma" "ς")
+ ("Tau" "T" nil "&Tau;" "Tau" "Tau" "Τ")
+ ("Upsilon" "\\Upsilon" t "&Upsilon;" "Upsilon" "Upsilon" "Υ")
+ ("upsih" "\\Upsilon" t "&upsih;" "upsilon" "upsilon" "ϒ")
+ ("upsilon" "\\upsilon" t "&upsilon;" "upsilon" "upsilon" "υ")
+ ("Phi" "\\Phi" t "&Phi;" "Phi" "Phi" "Φ")
+ ("phi" "\\phi" t "&phi;" "phi" "phi" "φ")
+ ("Chi" "X" nil "&Chi;" "Chi" "Chi" "Χ")
+ ("chi" "\\chi" t "&chi;" "chi" "chi" "χ")
+ ("acutex" "\\acute x" t "&acute;x" "'x" "'x" "𝑥́")
+ ("Psi" "\\Psi" t "&Psi;" "Psi" "Psi" "Ψ")
+ ("psi" "\\psi" t "&psi;" "psi" "psi" "ψ")
+ ("tau" "\\tau" t "&tau;" "tau" "tau" "τ")
+ ("Omega" "\\Omega" t "&Omega;" "Omega" "Omega" "Ω")
+ ("omega" "\\omega" t "&omega;" "omega" "omega" "ω")
+ ("piv" "\\varpi" t "&piv;" "omega-pi" "omega-pi" "ϖ")
+ ("partial" "\\partial" t "&part;" "[partial differential]" "[partial differential]" "∂")
+
+ "** Hebrew"
+ ("alefsym" "\\aleph" t "&alefsym;" "aleph" "aleph" "ℵ")
+
+ "** Dead languages"
+ ("ETH" "\\DH{}" nil "&ETH;" "D" "Ð" "Ð")
+ ("eth" "\\dh{}" nil "&eth;" "dh" "ð" "ð")
+ ("THORN" "\\TH{}" nil "&THORN;" "TH" "Þ" "Þ")
+ ("thorn" "\\th{}" nil "&thorn;" "th" "þ" "þ")
+
+ "* Punctuation"
+ "** Dots and Marks"
+ ("dots" "\\dots{}" nil "&hellip;" "..." "..." "…")
+ ("hellip" "\\dots{}" nil "&hellip;" "..." "..." "…")
+ ("middot" "\\textperiodcentered{}" nil "&middot;" "." "·" "·")
+ ("iexcl" "!`" nil "&iexcl;" "!" "¡" "¡")
+ ("iquest" "?`" nil "&iquest;" "?" "¿" "¿")
+
+ "** Dash-like"
+ ("shy" "\\-" nil "&shy;" "" "" "")
+ ("ndash" "--" nil "&ndash;" "-" "-" "–")
+ ("mdash" "---" nil "&mdash;" "--" "--" "—")
+
+ "** Quotations"
+ ("quot" "\\textquotedbl{}" nil "&quot;" "\"" "\"" "\"")
+ ("acute" "\\textasciiacute{}" nil "&acute;" "'" "´" "´")
+ ("ldquo" "\\textquotedblleft{}" nil "&ldquo;" "\"" "\"" "“")
+ ("rdquo" "\\textquotedblright{}" nil "&rdquo;" "\"" "\"" "”")
+ ("bdquo" "\\quotedblbase{}" nil "&bdquo;" "\"" "\"" "„")
+ ("lsquo" "\\textquoteleft{}" nil "&lsquo;" "`" "`" "‘")
+ ("rsquo" "\\textquoteright{}" nil "&rsquo;" "'" "'" "’")
+ ("sbquo" "\\quotesinglbase{}" nil "&sbquo;" "," "," "‚")
+ ("laquo" "\\guillemotleft{}" nil "&laquo;" "<<" "«" "«")
+ ("raquo" "\\guillemotright{}" nil "&raquo;" ">>" "»" "»")
+ ("lsaquo" "\\guilsinglleft{}" nil "&lsaquo;" "<" "<" "‹")
+ ("rsaquo" "\\guilsinglright{}" nil "&rsaquo;" ">" ">" "›")
+
+ "* Other"
+ "** Misc. (often used)"
+ ("circ" "\\circ" t "&circ;" "^" "^" "ˆ")
+ ("vert" "\\vert{}" t "&#124;" "|" "|" "|")
+ ("brvbar" "\\textbrokenbar{}" nil "&brvbar;" "|" "¦" "¦")
+ ("sect" "\\S" nil "&sect;" "paragraph" "§" "§")
+ ("amp" "\\&" nil "&amp;" "&" "&" "&")
+ ("lt" "\\textless{}" nil "&lt;" "<" "<" "<")
+ ("gt" "\\textgreater{}" nil "&gt;" ">" ">" ">")
+ ("tilde" "\\~{}" nil "&tilde;" "~" "~" "~")
+ ("dagger" "\\textdagger{}" nil "&dagger;" "[dagger]" "[dagger]" "†")
+ ("Dagger" "\\textdaggerdbl{}" nil "&Dagger;" "[doubledagger]" "[doubledagger]" "‡")
+
+ "** Whitespace"
+ ("nbsp" "~" nil "&nbsp;" " " " " " ")
+ ("ensp" "\\hspace*{.5em}" nil "&ensp;" " " " " " ")
+ ("emsp" "\\hspace*{1em}" nil "&emsp;" " " " " " ")
+ ("thinsp" "\\hspace*{.2em}" nil "&thinsp;" " " " " " ")
+
+ "** Currency"
+ ("curren" "\\textcurrency{}" nil "&curren;" "curr." "¤" "¤")
+ ("cent" "\\textcent{}" nil "&cent;" "cent" "¢" "¢")
+ ("pound" "\\pounds{}" nil "&pound;" "pound" "£" "£")
+ ("yen" "\\textyen{}" nil "&yen;" "yen" "¥" "¥")
+ ("euro" "\\texteuro{}" nil "&euro;" "EUR" "EUR" "€")
+ ("EUR" "\\EUR{}" nil "&euro;" "EUR" "EUR" "€")
+ ("EURdig" "\\EURdig{}" nil "&euro;" "EUR" "EUR" "€")
+ ("EURhv" "\\EURhv{}" nil "&euro;" "EUR" "EUR" "€")
+ ("EURcr" "\\EURcr{}" nil "&euro;" "EUR" "EUR" "€")
+ ("EURtm" "\\EURtm{}" nil "&euro;" "EUR" "EUR" "€")
+
+ "** Property Marks"
+ ("copy" "\\textcopyright{}" nil "&copy;" "(c)" "©" "©")
+ ("reg" "\\textregistered{}" nil "&reg;" "(r)" "®" "®")
+ ("trade" "\\texttrademark{}" nil "&trade;" "TM" "TM" "™")
+
+ "** Science et al."
+ ("minus" "\\minus" t "&minus;" "-" "-" "−")
+ ("pm" "\\textpm{}" nil "&plusmn;" "+-" "±" "±")
+ ("plusmn" "\\textpm{}" nil "&plusmn;" "+-" "±" "±")
+ ("times" "\\texttimes{}" nil "&times;" "*" "×" "×")
+ ("frasl" "/" nil "&frasl;" "/" "/" "⁄")
+ ("div" "\\textdiv{}" nil "&divide;" "/" "÷" "÷")
+ ("frac12" "\\textonehalf{}" nil "&frac12;" "1/2" "½" "½")
+ ("frac14" "\\textonequarter{}" nil "&frac14;" "1/4" "¼" "¼")
+ ("frac34" "\\textthreequarters{}" nil "&frac34;" "3/4" "¾" "¾")
+ ("permil" "\\textperthousand{}" nil "&permil;" "per thousand" "per thousand" "‰")
+ ("sup1" "\\textonesuperior{}" nil "&sup1;" "^1" "¹" "¹")
+ ("sup2" "\\texttwosuperior{}" nil "&sup2;" "^2" "²" "²")
+ ("sup3" "\\textthreesuperior{}" nil "&sup3;" "^3" "³" "³")
+ ("radic" "\\sqrt{\\,}" t "&radic;" "[square root]" "[square root]" "√")
+ ("sum" "\\sum" t "&sum;" "[sum]" "[sum]" "∑")
+ ("prod" "\\prod" t "&prod;" "[product]" "[n-ary product]" "∏")
+ ("micro" "\\textmu{}" nil "&micro;" "micro" "µ" "µ")
+ ("macr" "\\textasciimacron{}" nil "&macr;" "[macron]" "¯" "¯")
+ ("deg" "\\textdegree{}" nil "deg" "degree" "°" "°")
+ ("prime" "\\prime" t "&prime;" "'" "'" "′")
+ ("Prime" "\\prime{}\\prime" t "&Prime;" "''" "''" "″")
+ ("infin" "\\propto" t "&infin;" "[infinity]" "[infinity]" "∞")
+ ("infty" "\\infty" t "&infin;" "[infinity]" "[infinity]" "∞")
+ ("prop" "\\propto" t "&prop;" "[proportional to]" "[proportional to]" "∝")
+ ("proptp" "\\propto" t "&prop;" "[proportional to]" "[proportional to]" "∝")
+ ("not" "\\textlnot{}" nil "&not;" "[angled dash]" "¬" "¬")
+ ("land" "\\land" t "&and;" "[logical and]" "[logical and]" "∧")
+ ("wedge" "\\wedge" t "&and;" "[logical and]" "[logical and]" "∧")
+ ("lor" "\\lor" t "&or;" "[logical or]" "[logical or]" "∨")
+ ("vee" "\\vee" t "&or;" "[logical or]" "[logical or]" "∨")
+ ("cap" "\\cap" t "&cap;" "[intersection]" "[intersection]" "∩")
+ ("cup" "\\cup" t "&cup;" "[union]" "[union]" "∪")
+ ("int" "\\int" t "&int;" "[integral]" "[integral]" "∫")
+ ("there4" "\\therefore" t "&there4;" "[therefore]" "[therefore]" "∴")
+ ("sim" "\\sim" t "&sim;" "~" "~" "∼")
+ ("cong" "\\cong" t "&cong;" "[approx. equal to]" "[approx. equal to]" "≅")
+ ("simeq" "\\simeq" t "&cong;" "[approx. equal to]" "[approx. equal to]" "≅")
+ ("asymp" "\\asymp" t "&asymp;" "[almost equal to]" "[almost equal to]" "≈")
+ ("approx" "\\approx" t "&asymp;" "[almost equal to]" "[almost equal to]" "≈")
+ ("ne" "\\ne" t "&ne;" "[not equal to]" "[not equal to]" "≠")
+ ("neq" "\\neq" t "&ne;" "[not equal to]" "[not equal to]" "≠")
+ ("equiv" "\\equiv" t "&equiv;" "[identical to]" "[identical to]" "≡")
+ ("le" "\\le" t "&le;" "<=" "<=" "≤")
+ ("ge" "\\ge" t "&ge;" ">=" ">=" "≥")
+ ("sub" "\\subset" t "&sub;" "[subset of]" "[subset of]" "⊂")
+ ("subset" "\\subset" t "&sub;" "[subset of]" "[subset of]" "⊂")
+ ("sup" "\\supset" t "&sup;" "[superset of]" "[superset of]" "⊃")
+ ("supset" "\\supset" t "&sup;" "[superset of]" "[superset of]" "⊃")
+ ("nsub" "\\not\\subset" t "&nsub;" "[not a subset of]" "[not a subset of" "⊄")
+ ("sube" "\\subseteq" t "&sube;" "[subset of or equal to]" "[subset of or equal to]" "⊆")
+ ("nsup" "\\not\\supset" t "&nsup;" "[not a superset of]" "[not a superset of]" "⊅")
+ ("supe" "\\supseteq" t "&supe;" "[superset of or equal to]" "[superset of or equal to]" "⊇")
+ ("forall" "\\forall" t "&forall;" "[for all]" "[for all]" "∀")
+ ("exist" "\\exists" t "&exist;" "[there exists]" "[there exists]" "∃")
+ ("exists" "\\exists" t "&exist;" "[there exists]" "[there exists]" "∃")
+ ("empty" "\\empty" t "&empty;" "[empty set]" "[empty set]" "∅")
+ ("emptyset" "\\emptyset" t "&empty;" "[empty set]" "[empty set]" "∅")
+ ("isin" "\\in" t "&isin;" "[element of]" "[element of]" "∈")
+ ("in" "\\in" t "&isin;" "[element of]" "[element of]" "∈")
+ ("notin" "\\notin" t "&notin;" "[not an element of]" "[not an element of]" "∉")
+ ("ni" "\\ni" t "&ni;" "[contains as member]" "[contains as member]" "∋")
+ ("nabla" "\\nabla" t "&nabla;" "[nabla]" "[nabla]" "∇")
+ ("ang" "\\angle" t "&ang;" "[angle]" "[angle]" "∠")
+ ("angle" "\\angle" t "&ang;" "[angle]" "[angle]" "∠")
+ ("perp" "\\perp" t "&perp;" "[up tack]" "[up tack]" "⊥")
+ ("sdot" "\\cdot" t "&sdot;" "[dot]" "[dot]" "⋅")
+ ("cdot" "\\cdot" t "&sdot;" "[dot]" "[dot]" "⋅")
+ ("lceil" "\\lceil" t "&lceil;" "[left ceiling]" "[left ceiling]" "⌈")
+ ("rceil" "\\rceil" t "&rceil;" "[right ceiling]" "[right ceiling]" "⌉")
+ ("lfloor" "\\lfloor" t "&lfloor;" "[left floor]" "[left floor]" "⌊")
+ ("rfloor" "\\rfloor" t "&rfloor;" "[right floor]" "[right floor]" "⌋")
+ ("lang" "\\langle" t "&lang;" "<" "<" "⟨")
+ ("rang" "\\rangle" t "&rang;" ">" ">" "⟩")
+
+ "** Arrows"
+ ("larr" "\\leftarrow" t "&larr;" "<-" "<-" "←")
+ ("leftarrow" "\\leftarrow" t "&larr;" "<-" "<-" "←")
+ ("gets" "\\gets" t "&larr;" "<-" "<-" "←")
+ ("lArr" "\\Leftarrow" t "&lArr;" "<=" "<=" "⇐")
+ ("Leftarrow" "\\Leftarrow" t "&lArr;" "<=" "<=" "⇐")
+ ("uarr" "\\uparrow" t "&uarr;" "[uparrow]" "[uparrow]" "↑")
+ ("uparrow" "\\uparrow" t "&uarr;" "[uparrow]" "[uparrow]" "↑")
+ ("uArr" "\\Uparrow" t "&uArr;" "[dbluparrow]" "[dbluparrow]" "⇑")
+ ("Uparrow" "\\Uparrow" t "&uArr;" "[dbluparrow]" "[dbluparrow]" "⇑")
+ ("rarr" "\\rightarrow" t "&rarr;" "->" "->" "→")
+ ("to" "\\to" t "&rarr;" "->" "->" "→")
+ ("rightarrow" "\\rightarrow" t "&rarr;" "->" "->" "→")
+ ("rArr" "\\Rightarrow" t "&rArr;" "=>" "=>" "⇒")
+ ("Rightarrow" "\\Rightarrow" t "&rArr;" "=>" "=>" "⇒")
+ ("darr" "\\downarrow" t "&darr;" "[downarrow]" "[downarrow]" "↓")
+ ("downarrow" "\\downarrow" t "&darr;" "[downarrow]" "[downarrow]" "↓")
+ ("dArr" "\\Downarrow" t "&dArr;" "[dbldownarrow]" "[dbldownarrow]" "⇓")
+ ("Downarrow" "\\Downarrow" t "&dArr;" "[dbldownarrow]" "[dbldownarrow]" "⇓")
+ ("harr" "\\leftrightarrow" t "&harr;" "<->" "<->" "↔")
+ ("leftrightarrow" "\\leftrightarrow" t "&harr;" "<->" "<->" "↔")
+ ("hArr" "\\Leftrightarrow" t "&hArr;" "<=>" "<=>" "⇔")
+ ("Leftrightarrow" "\\Leftrightarrow" t "&hArr;" "<=>" "<=>" "⇔")
+ ("crarr" "\\hookleftarrow" t "&crarr;" "<-'" "<-'" "↵")
+ ("hookleftarrow" "\\hookleftarrow" t "&crarr;" "<-'" "<-'" "↵")
+
+ "** Function names"
+ ("arccos" "\\arccos" t "arccos" "arccos" "arccos" "arccos")
+ ("arcsin" "\\arcsin" t "arcsin" "arcsin" "arcsin" "arcsin")
+ ("arctan" "\\arctan" t "arctan" "arctan" "arctan" "arctan")
+ ("arg" "\\arg" t "arg" "arg" "arg" "arg")
+ ("cos" "\\cos" t "cos" "cos" "cos" "cos")
+ ("cosh" "\\cosh" t "cosh" "cosh" "cosh" "cosh")
+ ("cot" "\\cot" t "cot" "cot" "cot" "cot")
+ ("coth" "\\coth" t "coth" "coth" "coth" "coth")
+ ("csc" "\\csc" t "csc" "csc" "csc" "csc")
+ ("deg" "\\deg" t "&deg;" "deg" "deg" "deg")
+ ("det" "\\det" t "det" "det" "det" "det")
+ ("dim" "\\dim" t "dim" "dim" "dim" "dim")
+ ("exp" "\\exp" t "exp" "exp" "exp" "exp")
+ ("gcd" "\\gcd" t "gcd" "gcd" "gcd" "gcd")
+ ("hom" "\\hom" t "hom" "hom" "hom" "hom")
+ ("inf" "\\inf" t "inf" "inf" "inf" "inf")
+ ("ker" "\\ker" t "ker" "ker" "ker" "ker")
+ ("lg" "\\lg" t "lg" "lg" "lg" "lg")
+ ("lim" "\\lim" t "lim" "lim" "lim" "lim")
+ ("liminf" "\\liminf" t "liminf" "liminf" "liminf" "liminf")
+ ("limsup" "\\limsup" t "limsup" "limsup" "limsup" "limsup")
+ ("ln" "\\ln" t "ln" "ln" "ln" "ln")
+ ("log" "\\log" t "log" "log" "log" "log")
+ ("max" "\\max" t "max" "max" "max" "max")
+ ("min" "\\min" t "min" "min" "min" "min")
+ ("Pr" "\\Pr" t "Pr" "Pr" "Pr" "Pr")
+ ("sec" "\\sec" t "sec" "sec" "sec" "sec")
+ ("sin" "\\sin" t "sin" "sin" "sin" "sin")
+ ("sinh" "\\sinh" t "sinh" "sinh" "sinh" "sinh")
+ ("sup" "\\sup" t "&sup;" "sup" "sup" "sup")
+ ("tan" "\\tan" t "tan" "tan" "tan" "tan")
+ ("tanh" "\\tanh" t "tanh" "tanh" "tanh" "tanh")
+
+ "** Signs & Symbols"
+ ("bull" "\\textbullet{}" nil "&bull;" "*" "*" "•")
+ ("bullet" "\\textbullet{}" nil "&bull;" "*" "*" "•")
+ ("star" "\\star" t "*" "*" "*" "⋆")
+ ("lowast" "\\ast" t "&lowast;" "*" "*" "∗")
+ ("ast" "\\ast" t "&lowast;" "*" "*" "*")
+ ("odot" "\\odot" t "o" "[circled dot]" "[circled dot]" "ʘ")
+ ("oplus" "\\oplus" t "&oplus;" "[circled plus]" "[circled plus]" "⊕")
+ ("otimes" "\\otimes" t "&otimes;" "[circled times]" "[circled times]" "⊗")
+ ("checkmark" "\\checkmark" t "&#10003;" "[checkmark]" "[checkmark]" "✓")
+
+ "** Miscellaneous (seldom used)"
+ ("para" "\\P{}" nil "&para;" "[pilcrow]" "¶" "¶")
+ ("ordf" "\\textordfeminine{}" nil "&ordf;" "_a_" "ª" "ª")
+ ("ordm" "\\textordmasculine{}" nil "&ordm;" "_o_" "º" "º")
+ ("cedil" "\\c{}" nil "&cedil;" "[cedilla]" "¸" "¸")
+ ("oline" "\\overline{~}" t "&oline;" "[overline]" "¯" "‾")
+ ("uml" "\\textasciidieresis{}" nil "&uml;" "[diaeresis]" "¨" "¨")
+ ("zwnj" "\\/{}" nil "&zwnj;" "" "" "‌")
+ ("zwj" "" nil "&zwj;" "" "" "‍")
+ ("lrm" "" nil "&lrm;" "" "" "‎")
+ ("rlm" "" nil "&rlm;" "" "" "‏")
+
+ "** Smilies"
+ ("smile" "\\smile" t "&#9786;" ":-)" ":-)" "⌣")
+ ("smiley" "\\smiley{}" nil "&#9786;" ":-)" ":-)" "☺")
+ ("blacksmile" "\\blacksmiley{}" nil "&#9787;" ":-)" ":-)" "☻")
+ ("sad" "\\frownie{}" nil "&#9785;" ":-(" ":-(" "☹")
+
+ "** Suits"
+ ("clubs" "\\clubsuit" t "&clubs;" "[clubs]" "[clubs]" "♣")
+ ("clubsuit" "\\clubsuit" t "&clubs;" "[clubs]" "[clubs]" "♣")
+ ("spades" "\\spadesuit" t "&spades;" "[spades]" "[spades]" "♠")
+ ("spadesuit" "\\spadesuit" t "&spades;" "[spades]" "[spades]" "♠")
+ ("hearts" "\\heartsuit" t "&hearts;" "[hearts]" "[hearts]" "♥")
+ ("heartsuit" "\\heartsuit" t "&heartsuit;" "[hearts]" "[hearts]" "♥")
+ ("diams" "\\diamondsuit" t "&diams;" "[diamonds]" "[diamonds]" "♦")
+ ("diamondsuit" "\\diamondsuit" t "&diams;" "[diamonds]" "[diamonds]" "♦")
+ ("Diamond" "\\diamond" t "&diamond;" "[diamond]" "[diamond]" "⋄")
+ ("loz" "\\diamond" t "&loz;" "[lozenge]" "[lozenge]" "◊")
+ )
+ "Default entities used in Org-mode to produce special characters.
+For details see `org-entities-user'.")
+
+(defsubst org-entity-get (name)
+ "Get the proper association for NAME from the entity lists.
+This first checks the user list, then the built-in list."
+ (or (assoc name org-entities-user)
+ (assoc name org-entities)))
+
+(defun org-entity-get-representation (name kind)
+ "Get the correct representation of entity NAME for export type KIND.
+Kind can be any of `latex', `html', `ascii', `latin1', or `utf8'."
+ (let* ((e (org-entity-get name))
+ (n (cdr (assq kind '((latex . 1) (html . 3) (ascii . 4)
+ (latin1 . 5) (utf8 . 6)))))
+ (r (and e n (nth n e))))
+ (if (and e r
+ (not org-entities-ascii-explanatory)
+ (memq kind '(ascii latin1 utf8))
+ (= (string-to-char r) ?\[))
+ (concat "\\" name)
+ r)))
+
+(defsubst org-entity-latex-math-p (name)
+ "Does entity NAME require math mode in LaTeX?"
+ (nth 2 (org-entity-get name)))
+
+;; Helpfunctions to create a table for orgmode.org/worg/org-symbols.org
+
+(defun org-entities-create-table ()
+ "Create an org-mode table with all entities."
+ (interactive)
+ (let ((ll org-entities)
+ (pos (point))
+ e latex mathp html latin utf8 name ascii)
+ (insert "|Name|LaTeX code|LaTeX|HTML code |HTML|ASCII|Latin1|UTF-8\n|-\n")
+ (while ll
+ (when (listp e)
+ (setq e (pop ll))
+ (setq name (car e)
+ latex (nth 1 e)
+ mathp (nth 2 e)
+ html (nth 3 e)
+ ascii (nth 4 e)
+ latin (nth 5 e)
+ utf8 (nth 6 e))
+ (if (equal ascii "|") (setq ascii "\\vert"))
+ (if (equal latin "|") (setq latin "\\vert"))
+ (if (equal utf8 "|") (setq utf8 "\\vert"))
+ (if (equal ascii "=>") (setq ascii "= >"))
+ (if (equal latin "=>") (setq latin "= >"))
+ (insert "|" name
+ "|" (format "=%s=" latex)
+ "|" (format (if mathp "$%s$" "$\\mbox{%s}$")
+ latex)
+ "|" (format "=%s=" html) "|" html
+ "|" ascii "|" latin "|" utf8
+ "|\n")))
+ (goto-char pos)
+ (org-table-align)))
+
+(defun org-entities-help ()
+ "Create a Help buffer with all available entities."
+ (interactive)
+ (with-output-to-temp-buffer "*Org Entity Help*"
+ (princ "Org-mode entities\n=================\n\n")
+ (let ((ll (append '("* User-defined additions (variable org-entities-user)")
+ org-entities-user
+ org-entities))
+ e latex mathp html latin utf8 name ascii
+ (lastwasstring t)
+ (head (concat
+ "\n"
+ " Symbol Org entity LaTeX code HTML code\n"
+ " -----------------------------------------------------------\n")))
+ (while ll
+ (setq e (pop ll))
+ (if (stringp e)
+ (progn
+ (princ e)
+ (princ "\n")
+ (setq lastwasstring t))
+ (if lastwasstring (princ head))
+ (setq lastwasstring nil)
+ (setq name (car e)
+ latex (nth 1 e)
+ html (nth 3 e)
+ utf8 (nth 6 e))
+ (princ (format " %-8s \\%-16s %-22s %-13s\n"
+ utf8 name latex html))))))
+ (with-current-buffer "*Org Entity Help*"
+ (org-mode))
+ (select-window (get-buffer-window "*Org Entity Help*")))
+
+
+(defun replace-amp ()
+ "Postprocess HTML file to unescape the ampersand."
+ (interactive)
+ (while (re-search-forward "<td>&amp;\\([^<;]+;\\)" nil t)
+ (replace-match (concat "<td>&" (match-string 1)) t t)))
+
+(provide 'org-entities)
+
+;; Local variables:
+;; coding: utf-8
+;; End:
+
+;; arch-tag: e6bd163f-7419-4009-9c93-a74623016424
+
+;;; org-entities.el ends here
diff --git a/lisp/org/org-exp-blocks.el b/lisp/org/org-exp-blocks.el
index fd0dbca4e2d..3751e68e057 100644
--- a/lisp/org/org-exp-blocks.el
+++ b/lisp/org/org-exp-blocks.el
@@ -4,6 +4,7 @@
;; Free Software Foundation, Inc.
;; Author: Eric Schulte
+;; Version: 7.3
;; This file is part of GNU Emacs.
;;
@@ -67,6 +68,8 @@
;; `org-export-blocks-add-block' to add your block type to
;; `org-export-blocks'.
+;;; Code:
+
(eval-when-compile
(require 'cl))
(require 'org)
@@ -92,10 +95,10 @@
'((comment org-export-blocks-format-comment t)
(ditaa org-export-blocks-format-ditaa nil)
(dot org-export-blocks-format-dot nil))
- "Use this a-list to associate block types with block exporting
-functions. The type of a block is determined by the text
-immediately following the '#+BEGIN_' portion of the block header.
-Each block export function should accept three argumets..."
+ "Use this alist to associate block types with block exporting functions.
+The type of a block is determined by the text immediately
+following the '#+BEGIN_' portion of the block header. Each block
+export function should accept three arguments."
:group 'org-export-general
:type '(repeat
(list
@@ -105,14 +108,14 @@ Each block export function should accept three argumets..."
:set 'org-export-blocks-set)
(defun org-export-blocks-add-block (block-spec)
- "Add a new block type to `org-export-blocks'. BLOCK-SPEC
-should be a three element list the first element of which should
-indicate the name of the block, the second element should be the
-formatting function called by `org-export-blocks-preprocess' and
-the third element a flag indicating whether these types of blocks
-should be fontified in org-mode buffers (see
-`org-protecting-blocks'). For example the BLOCK-SPEC for ditaa
-blocks is as follows...
+ "Add a new block type to `org-export-blocks'.
+BLOCK-SPEC should be a three element list the first element of
+which should indicate the name of the block, the second element
+should be the formatting function called by
+`org-export-blocks-preprocess' and the third element a flag
+indicating whether these types of blocks should be fontified in
+org-mode buffers (see `org-protecting-blocks'). For example the
+BLOCK-SPEC for ditaa blocks is as follows.
(ditaa org-export-blocks-format-ditaa nil)"
(unless (member block-spec org-export-blocks)
@@ -121,25 +124,28 @@ blocks is as follows...
(defcustom org-export-interblocks
'()
- "Use this a-list to associate block types with block exporting
-functions. The type of a block is determined by the text
-immediately following the '#+BEGIN_' portion of the block header.
-Each block export function should accept three argumets..."
+ "Use this a-list to associate block types with block exporting functions.
+The type of a block is determined by the text immediately
+following the '#+BEGIN_' portion of the block header. Each block
+export function should accept three arguments."
:group 'org-export-general
:type 'alist)
(defcustom org-export-blocks-witheld
'(hidden)
- "List of block types (see `org-export-blocks') which should not
-be exported."
+ "List of block types (see `org-export-blocks') which should not be exported."
:group 'org-export-general
:type 'list)
-(defvar org-export-blocks-postblock-hooks nil "")
+(defcustom org-export-blocks-postblock-hook nil
+ "Run after blocks have been processed with `org-export-blocks-preprocess'."
+ :group 'org-export-general
+ :type 'hook)
(defun org-export-blocks-html-quote (body &optional open close)
- "Protext BODY from org html export. The optional OPEN and
-CLOSE tags will be inserted around BODY."
+ "Protect BODY from org html export.
+The optional OPEN and CLOSE tags will be inserted around BODY."
+
(concat
"\n#+BEGIN_HTML\n"
(or open "")
@@ -148,8 +154,8 @@ CLOSE tags will be inserted around BODY."
"#+END_HTML\n"))
(defun org-export-blocks-latex-quote (body &optional open close)
- "Protext BODY from org latex export. The optional OPEN and
-CLOSE tags will be inserted around BODY."
+ "Protect BODY from org latex export.
+The optional OPEN and CLOSE tags will be inserted around BODY."
(concat
"\n#+BEGIN_LaTeX\n"
(or open "")
@@ -158,22 +164,21 @@ CLOSE tags will be inserted around BODY."
"#+END_LaTeX\n"))
(defun org-export-blocks-preprocess ()
- "Export all blocks according to the `org-export-blocks' block
-exportation alist. Does not export block types specified in
-specified in BLOCKS which default to the value of
-`org-export-blocks-witheld'."
+ "Export all blocks according to the `org-export-blocks' block export alist.
+Does not export block types specified in specified in BLOCKS
+which defaults to the value of `org-export-blocks-witheld'."
(interactive)
(save-window-excursion
(let ((case-fold-search t)
(types '())
- indentation type func start body headers preserve-indent)
+ indentation type func start body headers preserve-indent progress-marker)
(flet ((interblock (start end)
(mapcar (lambda (pair) (funcall (second pair) start end))
org-export-interblocks)))
(goto-char (point-min))
(setq start (point))
(while (re-search-forward
- "^\\([ \t]*\\)#\\+begin_\\(\\S-+\\)[ \t]*\\(.*\\)?[\r\n]\\([^\000]*?\\)[\r\n][ \t]*#\\+end_\\S-+.*" nil t)
+ "^\\([ \t]*\\)#\\+begin_\\(\\S-+\\)[ \t]*\\(.*\\)?[\r\n]\\([^\000]*?\\)[\r\n][ \t]*#\\+end_\\S-+.*[\r\n]?" nil t)
(setq indentation (length (match-string 1)))
(setq type (intern (downcase (match-string 2))))
(setq headers (save-match-data (org-split-string (match-string 3) "[ \t]+")))
@@ -183,17 +188,21 @@ specified in BLOCKS which default to the value of
(setq body (save-match-data (org-remove-indentation body))))
(unless (memq type types) (setq types (cons type types)))
(save-match-data (interblock start (match-beginning 0)))
- (if (setq func (cadr (assoc type org-export-blocks)))
- (progn
- (replace-match (save-match-data
+ (when (setq func (cadr (assoc type org-export-blocks)))
+ (let ((replacement (save-match-data
(if (memq type org-export-blocks-witheld) ""
- (apply func body headers))) t t)
+ (apply func body headers)))))
+ (when replacement
+ (replace-match replacement t t)
(unless preserve-indent
- (indent-code-rigidly (match-beginning 0) (match-end 0) indentation))))
+ (indent-code-rigidly
+ (match-beginning 0) (match-end 0) indentation)))))
(setq start (match-end 0)))
- (interblock start (point-max))))))
+ (interblock start (point-max))
+ (run-hooks 'org-export-blocks-postblock-hook)))))
-(add-hook 'org-export-preprocess-hook 'org-export-blocks-preprocess)
+(add-hook 'org-export-preprocess-after-include-files-hook
+ 'org-export-blocks-preprocess)
;;================================================================================
;; type specific functions
@@ -209,7 +218,7 @@ specified in BLOCKS which default to the value of
(expand-file-name
"../contrib"
(file-name-directory (or load-file-name buffer-file-name)))))))
- "Path to the ditaa jar executable")
+ "Path to the ditaa jar executable.")
(defun org-export-blocks-format-ditaa (body &rest headers)
"Pass block BODY to the ditaa utility creating an image.
@@ -219,13 +228,15 @@ passed to the ditaa utility as command line arguments."
(message "ditaa-formatting...")
(let* ((args (if (cdr headers) (mapconcat 'identity (cdr headers) " ")))
(data-file (make-temp-file "org-ditaa"))
- (hash (sha1 (prin1-to-string (list body args))))
- (raw-out-file (if headers (car headers)))
- (out-file-parts (if (string-match "\\(.+\\)\\.\\([^\\.]+\\)$" raw-out-file)
- (cons (match-string 1 raw-out-file)
- (match-string 2 raw-out-file))
- (cons raw-out-file "png")))
- (out-file (concat (car out-file-parts) "_" hash "." (cdr out-file-parts))))
+ (hash (progn
+ (set-text-properties 0 (length body) nil body)
+ (sha1 (prin1-to-string (list body args)))))
+ (raw-out-file (if headers (car headers)))
+ (out-file-parts (if (string-match "\\(.+\\)\\.\\([^\\.]+\\)$" raw-out-file)
+ (cons (match-string 1 raw-out-file)
+ (match-string 2 raw-out-file))
+ (cons raw-out-file "png")))
+ (out-file (concat (car out-file-parts) "_" hash "." (cdr out-file-parts))))
(unless (file-exists-p org-ditaa-jar-path)
(error (format "Could not find ditaa.jar at %s" org-ditaa-jar-path)))
(setq body (if (string-match "^\\([^:\\|:[^ ]\\)" body)
@@ -279,13 +290,15 @@ digraph data_relationships {
(message "dot-formatting...")
(let* ((args (if (cdr headers) (mapconcat 'identity (cdr headers) " ")))
(data-file (make-temp-file "org-ditaa"))
- (hash (sha1 (prin1-to-string (list body args))))
- (raw-out-file (if headers (car headers)))
- (out-file-parts (if (string-match "\\(.+\\)\\.\\([^\\.]+\\)$" raw-out-file)
- (cons (match-string 1 raw-out-file)
- (match-string 2 raw-out-file))
- (cons raw-out-file "png")))
- (out-file (concat (car out-file-parts) "_" hash "." (cdr out-file-parts))))
+ (hash (progn
+ (set-text-properties 0 (length body) nil body)
+ (sha1 (prin1-to-string (list body args)))))
+ (raw-out-file (if headers (car headers)))
+ (out-file-parts (if (string-match "\\(.+\\)\\.\\([^\\.]+\\)$" raw-out-file)
+ (cons (match-string 1 raw-out-file)
+ (match-string 2 raw-out-file))
+ (cons raw-out-file "png")))
+ (out-file (concat (car out-file-parts) "_" hash "." (cdr out-file-parts))))
(cond
((or htmlp latexp docbookp)
(unless (file-exists-p out-file)
diff --git a/lisp/org/org-exp.el b/lisp/org/org-exp.el
index cf1b5a49da4..73e0951334d 100644
--- a/lisp/org/org-exp.el
+++ b/lisp/org/org-exp.el
@@ -6,7 +6,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -26,11 +26,15 @@
;;
;;; Commentary:
+;;; Code:
+
(require 'org)
(require 'org-macs)
(require 'org-agenda)
(require 'org-exp-blocks)
+(require 'ob-exp)
(require 'org-src)
+
(eval-when-compile
(require 'cl))
@@ -42,6 +46,8 @@
(declare-function org-export-htmlize-region-for-paste "org-html" (beg end))
(declare-function htmlize-buffer "ext:htmlize" (&optional buffer))
(declare-function org-inlinetask-remove-END-maybe "org-inlinetask" ())
+(declare-function org-table-cookie-line-p "org-table" (line))
+(declare-function org-table-colgroup-line-p "org-table" (line))
(autoload 'org-export-generic "org-export-generic" "Export using the generic exporter" t)
(defgroup org-export nil
"Options for exporting org-listings."
@@ -54,7 +60,7 @@
:group 'org-export)
(defcustom org-export-allow-BIND 'confirm
- "Non-nil means, allow #+BIND to define local variable values for export.
+ "Non-nil means allow #+BIND to define local variable values for export.
This is a potential security risk, which is why the user must confirm the
use of these lines."
:group 'org-export-general
@@ -67,7 +73,7 @@ use of these lines."
(defvar org-export-publishing-directory nil)
(defcustom org-export-show-temporary-export-buffer t
- "Non-nil means, show buffer after exporting to temp buffer.
+ "Non-nil means show buffer after exporting to temp buffer.
When Org exports to a file, the buffer visiting that file is ever
shown, but remains buried. However, when exporting to a temporary
buffer, that buffer is popped up in a second window. When this variable
@@ -76,7 +82,14 @@ is nil, the buffer remains buried also in these cases."
:type 'boolean)
(defcustom org-export-copy-to-kill-ring t
- "Non-nil means, exported stuff will also be pushed onto the kill ring."
+ "Non-nil means exported stuff will also be pushed onto the kill ring."
+ :group 'org-export-general
+ :type 'boolean)
+
+(defcustom org-export-kill-product-buffer-when-displayed nil
+ "Non-nil means kill the product buffer if it is displayed immediately.
+This applied to the commands `org-export-html-and-open' and
+`org-export-as-pdf-and-open'."
:group 'org-export-general
:type 'boolean)
@@ -86,9 +99,10 @@ This works by starting up a separate Emacs process visiting the same file
and doing the export from there.
Not all export commands are affected by this - only the ones which
actually write to a file, and that do not depend on the buffer state.
-
+\\<org-mode-map>
If this option is nil, you can still get background export by calling
-`org-export' with a double prefix arg: `C-u C-u C-c C-e'.
+`org-export' with a double prefix arg: \
+\\[universal-argument] \\[universal-argument] \\[org-export].
If this option is t, the double prefix can be used to exceptionally
force an export command into the current process."
@@ -114,7 +128,7 @@ This is without condition, so even subtrees inside that carry one of the
;; FIXME: rename, this is a general variable
(defcustom org-export-html-expand t
- "Non-nil means, for HTML export, treat @<...> as HTML tag.
+ "Non-nil means for HTML export, treat @<...> as HTML tag.
When nil, these tags will be exported as plain text and therefore
not be interpreted by a browser.
@@ -124,7 +138,7 @@ This option can also be set with the +OPTIONS line, e.g. \"@:nil\"."
:type 'boolean)
(defcustom org-export-with-special-strings t
- "Non-nil means, interpret \"\-\", \"--\" and \"---\" for export.
+ "Non-nil means interpret \"\-\", \"--\" and \"---\" for export.
When this option is turned on, these strings will be exported as:
Org HTML LaTeX
@@ -167,7 +181,7 @@ This option can also be set with the +OPTIONS line, e.g. \"-:nil\"."
("no" "Forfatter" "Dato" "Innhold" "Fotnoter")
("nb" "Forfatter" "Dato" "Innhold" "Fotnoter") ;; nb = Norsk (bokm.l)
("nn" "Forfattar" "Dato" "Innhald" "Fotnotar") ;; nn = Norsk (nynorsk)
- ("pl" "Autor" "Data" "Spis tre&sacute;ci" "Przypis")
+ ("pl" "Autor" "Data" "Spis tre&#x015b;ci" "Przypis")
("sv" "F&ouml;rfattare" "Datum" "Inneh&aring;ll" "Fotnoter"))
"Terms used in export text, translated to different languages.
Use the variable `org-export-default-language' to set the language,
@@ -198,7 +212,7 @@ This is best set with the #+KEYWORDS line in a file, it does not make
sense to set this globally.")
(defcustom org-export-skip-text-before-1st-heading nil
- "Non-nil means, skip all text before the first headline when exporting.
+ "Non-nil means skip all text before the first headline when exporting.
When nil, that text is exported as well."
:group 'org-export-general
:type 'boolean)
@@ -214,7 +228,7 @@ This option can also be set with the +OPTIONS line, e.g. \"H:2\"."
:type 'integer)
(defcustom org-export-with-section-numbers t
- "Non-nil means, add section numbers to headlines when exporting.
+ "Non-nil means add section numbers to headlines when exporting.
This option can also be set with the +OPTIONS line, e.g. \"num:t\"."
:group 'org-export-general
@@ -224,7 +238,7 @@ This option can also be set with the +OPTIONS line, e.g. \"num:t\"."
"Format of section numbers for export.
The variable has two components.
1. A list of lists, each indicating a counter type and a separator.
- The counter type can be any of \"1\", \"A\", \"a\", \"I\", or \"a\".
+ The counter type can be any of \"1\", \"A\", \"a\", \"I\", or \"i\".
It causes causes numeric, alphabetic, or roman counters, respectively.
The separator is only used if another counter for a subsection is being
added.
@@ -241,7 +255,7 @@ The variable has two components.
(string :tag "Terminator")))
(defcustom org-export-with-toc t
- "Non-nil means, create a table of contents in exported files.
+ "Non-nil means create a table of contents in exported files.
The TOC contains headlines with levels up to`org-export-headline-levels'.
When an integer, include levels up to N in the toc, this may then be
different from `org-export-headline-levels', but it will not be allowed
@@ -263,24 +277,24 @@ or \"toc:3\"."
(integer :tag "TOC to level")))
(defcustom org-export-mark-todo-in-toc nil
- "Non-nil means, mark TOC lines that contain any open TODO items."
+ "Non-nil means mark TOC lines that contain any open TODO items."
:group 'org-export-general
:type 'boolean)
(defcustom org-export-with-todo-keywords t
- "Non-nil means, include TODO keywords in export.
+ "Non-nil means include TODO keywords in export.
When nil, remove all these keywords from the export."
:group 'org-export-general
:type 'boolean)
(defcustom org-export-with-priority nil
- "Non-nil means, include priority cookies in export.
+ "Non-nil means include priority cookies in export.
When nil, remove priority cookies for export."
:group 'org-export-general
:type 'boolean)
(defcustom org-export-preserve-breaks nil
- "Non-nil means, preserve all line breaks when exporting.
+ "Non-nil means preserve all line breaks when exporting.
Normally, in HTML output paragraphs will be reformatted. In ASCII
export, line breaks will always be preserved, regardless of this variable.
@@ -302,21 +316,29 @@ headline Only export the headline, but skip the tree below it."
(const :tag "entirely" t)))
(defcustom org-export-author-info t
- "Non-nil means, insert author name and email into the exported file.
+ "Non-nil means insert author name and email into the exported file.
+
+This option can also be set with the +OPTIONS line,
+e.g. \"author:nil\"."
+ :group 'org-export-general
+ :type 'boolean)
+
+(defcustom org-export-email-info nil
+ "Non-nil means insert author name and email into the exported file.
This option can also be set with the +OPTIONS line,
-e.g. \"author-info:nil\"."
+e.g. \"email:t\"."
:group 'org-export-general
:type 'boolean)
(defcustom org-export-creator-info t
- "Non-nil means, the postamble should contain a creator sentence.
+ "Non-nil means the postamble should contain a creator sentence.
This sentence is \"HTML generated by org-mode XX in emacs XXX\"."
:group 'org-export-general
:type 'boolean)
(defcustom org-export-time-stamp-file t
- "Non-nil means, insert a time stamp into the exported file.
+ "Non-nil means insert a time stamp into the exported file.
The time stamp shows when the file was created.
This option can also be set with the +OPTIONS line,
@@ -347,7 +369,7 @@ This option can also be set with the +OPTIONS line, e.g. \"tags:nil\"."
(const :tag "On" t)))
(defcustom org-export-with-drawers nil
- "Non-nil means, export with drawers like the property drawer.
+ "Non-nil means export with drawers like the property drawer.
When t, all drawers are exported. This may also be a list of
drawer names to export."
:group 'org-export-general
@@ -357,9 +379,19 @@ drawer names to export."
(repeat :tag "Selected drawers"
(string :tag "Drawer name"))))
+(defvar org-export-first-hook nil
+ "Hook called as the first thing in each exporter.
+Point will be still in the original buffer.
+Good for general initialization")
+
(defvar org-export-preprocess-hook nil
"Hook for preprocessing an export buffer.
-Pretty much the first thing when exporting is running this hook.")
+Pretty much the first thing when exporting is running this hook.
+Point will be in a temporary buffer that contains a copy of
+the original buffer, or of the section that is being export.
+All the other hooks in the org-export-preprocess... category
+also work in that temporary buffer, already modified by various
+stages of the processing.")
(defvar org-export-preprocess-after-include-files-hook nil
"Hook for preprocessing an export buffer.
@@ -371,11 +403,28 @@ This is run after selection of trees to be exported has happened.
This selection includes tags-based selection, as well as removal
of commented and archived trees.")
+(defvar org-export-preprocess-after-headline-targets-hook nil
+ "Hook for preprocessing export buffer.
+This is run just after the headline targets have been defined and
+the target-alist has been set up.")
+
+(defvar org-export-preprocess-before-selecting-backend-code-hook nil
+ "Hook for preprocessing an export buffer.
+This is run just before backend-specific blocks get selected.")
+
(defvar org-export-preprocess-after-blockquote-hook nil
"Hook for preprocessing an export buffer.
This is run after blockquote/quote/verse/center have been marked
with cookies.")
+(defvar org-export-preprocess-after-radio-targets-hook nil
+ "Hook for preprocessing an export buffer.
+This is run after radio target processing.")
+
+(defvar org-export-preprocess-before-normalizing-links-hook nil
+ "Hook for preprocessing an export buffer.
+This hook is run before links are normalized.")
+
(defvar org-export-preprocess-before-backend-specifics-hook nil
"Hook run before backend-specific functions are called during preprocessing.")
@@ -390,7 +439,7 @@ returning the buffer string to the backend.")
:group 'org-export)
(defcustom org-export-with-emphasize t
- "Non-nil means, interpret *word*, /word/, and _word_ as emphasized text.
+ "Non-nil means interpret *word*, /word/, and _word_ as emphasized text.
If the export target supports emphasizing text, the word will be
typeset in bold, italic, or underlined, respectively. Works only for
single words, but you can say: I *really* *mean* *this*.
@@ -408,41 +457,13 @@ This option can also be set with the +OPTIONS line, e.g. \"f:nil\"."
:group 'org-export-translation
:type 'boolean)
-(defcustom org-export-with-sub-superscripts t
- "Non-nil means, interpret \"_\" and \"^\" for export.
-When this option is turned on, you can use TeX-like syntax for sub- and
-superscripts. Several characters after \"_\" or \"^\" will be
-considered as a single item - so grouping with {} is normally not
-needed. For example, the following things will be parsed as single
-sub- or superscripts.
-
- 10^24 or 10^tau several digits will be considered 1 item.
- 10^-12 or 10^-tau a leading sign with digits or a word
- x^2-y^3 will be read as x^2 - y^3, because items are
- terminated by almost any nonword/nondigit char.
- x_{i^2} or x^(2-i) braces or parenthesis do grouping.
-
-Still, ambiguity is possible - so when in doubt use {} to enclose the
-sub/superscript. If you set this variable to the symbol `{}',
-the braces are *required* in order to trigger interpretations as
-sub/superscript. This can be helpful in documents that need \"_\"
-frequently in plain text.
-
-Not all export backends support this, but HTML does.
-
-This option can also be set with the +OPTIONS line, e.g. \"^:nil\"."
- :group 'org-export-translation
- :type '(choice
- (const :tag "Always interpret" t)
- (const :tag "Only with braces" {})
- (const :tag "Never interpret" nil)))
-
(defcustom org-export-with-TeX-macros t
- "Non-nil means, interpret simple TeX-like macros when exporting.
+ "Non-nil means interpret simple TeX-like macros when exporting.
For example, HTML export converts \\alpha to &alpha; and \\AA to &Aring;.
Not only real TeX macros will work here, but the standard HTML entities
for math can be used as macro names as well. For a list of supported
-names in HTML export, see the constant `org-html-entities'.
+names in HTML export, see the constant `org-entities' and the user option
+`org-entities-user'.
Not all export backends support this.
This option can also be set with the +OPTIONS line, e.g. \"TeX:nil\"."
@@ -450,23 +471,37 @@ This option can also be set with the +OPTIONS line, e.g. \"TeX:nil\"."
:group 'org-export-latex
:type 'boolean)
-(defcustom org-export-with-LaTeX-fragments nil
- "Non-nil means, convert LaTeX fragments to images when exporting to HTML.
-When set, the exporter will find LaTeX environments if the \\begin line is
-the first non-white thing on a line. It will also find the math delimiters
-like $a=b$ and \\( a=b \\) for inline math, $$a=b$$ and \\[ a=b \\] for
-display math.
+(defcustom org-export-with-LaTeX-fragments t
+ "Non-nil means process LaTeX math fragments for HTML display.
+When set, the exporter will find and process LaTeX environments if the
+\\begin line is the first non-white thing on a line. It will also find
+and process the math delimiters like $a=b$ and \\( a=b \\) for inline math,
+$$a=b$$ and \\[ a=b \\] for display math.
-This option can also be set with the +OPTIONS line, e.g. \"LaTeX:t\".
+This option can also be set with the +OPTIONS line, e.g. \"LaTeX:mathjax\".
+
+Allowed values are:
+
+nil Don't do anything.
+verbatim Keep eveything in verbatim
+dvipng Process the LaTeX fragments to images.
+ This will also include processing of non-math environments.
+t Do MathJax preprocessing if there is at least on math snippet,
+ and arrange for MathJax.js to be loaded.
The default is nil, because this option needs the `dvipng' program which
is not available on all systems."
:group 'org-export-translation
:group 'org-export-latex
- :type 'boolean)
+ :type '(choice
+ (const :tag "Do not process math in any way" nil)
+ (const :tag "Obsolete, use dvipng setting" t)
+ (const :tag "Use dvipng to make images" dvipng)
+ (const :tag "Use MathJax to display math" mathjax)
+ (const :tag "Leave math verbatim" verbatim)))
(defcustom org-export-with-fixed-width t
- "Non-nil means, lines starting with \":\" will be in fixed width font.
+ "Non-nil means lines starting with \":\" will be in fixed width font.
This can be used to have pre-formatted text, fragments of code etc. For
example:
: ;; Some Lisp examples
@@ -479,12 +514,6 @@ This option can also be set with the +OPTIONS line, e.g. \"::nil\"."
:group 'org-export-translation
:type 'boolean)
-(defcustom org-match-sexp-depth 3
- "Number of stacked braces for sub/superscript matching.
-This has to be set before loading org.el to be effective."
- :group 'org-export-translation
- :type 'integer)
-
(defgroup org-export-tables nil
"Options for exporting tables in Org-mode."
:tag "Org Export Tables"
@@ -505,7 +534,7 @@ This option can also be set with the +OPTIONS line, e.g. \"|:nil\"."
:type 'boolean)
(defcustom org-export-highlight-first-table-line t
- "Non-nil means, highlight the first table line.
+ "Non-nil means highlight the first table line.
In HTML export, this means use <th> instead of <td>.
In tables created with table.el, this applies to the first table line.
In Org-mode tables, all lines before the first horizontal separator
@@ -523,13 +552,14 @@ the values of constants may be useful to have."
:type 'boolean)
(defcustom org-export-prefer-native-exporter-for-tables nil
- "Non-nil means, always export tables created with table.el natively.
-Natively means, use the HTML code generator in table.el.
+ "Non-nil means always export tables created with table.el natively.
+Natively means use the HTML code generator in table.el.
When nil, Org-mode's own HTML generator is used when possible (i.e. if
the table does not use row- or column-spanning). This has the
advantage, that the automatic HTML conversions for math symbols and
sub/superscripts can be applied. Org-mode's HTML generator is also
-much faster."
+much faster. The LaTeX exporter always use the native exporter for
+table.el tables."
:group 'org-export-tables
:type 'boolean)
@@ -581,6 +611,7 @@ much faster."
(:fixed-width ":" org-export-with-fixed-width)
(:timestamps "<" org-export-with-timestamps)
(:author-info "author" org-export-author-info)
+ (:email-info "email" org-export-email-info)
(:creator-info "creator" org-export-creator-info)
(:time-stamp-file "timestamp" org-export-time-stamp-file)
(:tables "|" org-export-with-tables)
@@ -658,12 +689,14 @@ modified) list.")
(let ((re (org-make-options-regexp
(append
'("TITLE" "AUTHOR" "DATE" "EMAIL" "TEXT" "OPTIONS" "LANGUAGE"
+ "MATHJAX"
"LINK_UP" "LINK_HOME" "SETUPFILE" "STYLE"
"LATEX_HEADER" "LATEX_CLASS"
"EXPORT_SELECT_TAGS" "EXPORT_EXCLUDE_TAGS"
- "KEYWORDS" "DESCRIPTION" "MACRO" "BIND")
+ "KEYWORDS" "DESCRIPTION" "MACRO" "BIND" "XSLT")
(mapcar 'car org-export-inbuffer-options-extra))))
- p key val text options a pr style
+ (case-fold-search t)
+ p key val text options mathjax a pr style
latex-header latex-class macros letbind
ext-setup-or-nil setup-contents (start 0))
(while (or (and ext-setup-or-nil
@@ -695,8 +728,12 @@ modified) list.")
(setq text (if text (concat text "\n" val) val)))
((string-equal key "OPTIONS")
(setq options (concat val " " options)))
+ ((string-equal key "MATHJAX")
+ (setq mathjax (concat val " " mathjax)))
((string-equal key "BIND")
(push (read (concat "(" val ")")) letbind))
+ ((string-equal key "XSLT")
+ (setq p (plist-put p :xslt val)))
((string-equal key "LINK_UP")
(setq p (plist-put p :link-up val)))
((string-equal key "LINK_HOME")
@@ -729,9 +766,12 @@ modified) list.")
(setq p (plist-put p :latex-class latex-class)))
(when options
(setq p (org-export-add-options-to-plist p options)))
+ (when mathjax
+ (setq p (plist-put p :mathjax mathjax)))
;; Add macro definitions
(setq p (plist-put p :macro-date "(eval (format-time-string \"$1\"))"))
(setq p (plist-put p :macro-time "(eval (format-time-string \"$1\"))"))
+ (setq p (plist-put p :macro-property "(eval (org-entry-get nil \"$1\" 'selective))"))
(setq p (plist-put
p :macro-modification-time
(and (buffer-file-name)
@@ -772,9 +812,10 @@ security risks."
(defun org-install-letbind ()
"Install the values from #+BIND lines as local variables."
- (let ((letbind (plist-get org-export-opt-plist :let-bind)))
- (while letbind
- (org-set-local (caar letbind) (nth 1 (pop letbind))))))
+ (let ((letbind (plist-get org-export-opt-plist :let-bind))
+ pair)
+ (while (setq pair (pop letbind))
+ (org-set-local (car pair) (nth 1 pair)))))
(defun org-export-add-options-to-plist (p options)
"Parse an OPTIONS line and set values in the property list P."
@@ -831,33 +872,35 @@ in the background. This will be done only for commands that write
to a file. For details see the docstring of `org-export-run-in-background'.
The prefix argument ARG will be passed to the exporter. However, if
-ARG is a double universal prefix `C-u C-u', that means to inverse the
+ARG is a double universal prefix \\[universal-argument] \\[universal-argument], \
+that means to inverse the
value of `org-export-run-in-background'."
(interactive "P")
(let* ((bg (org-xor (equal arg '(16)) org-export-run-in-background))
+ subtree-p
(help "[t] insert the export option template
\[v] limit export to visible part of outline tree
+\[1] only export the current subtree
+\[SPC] publish enclosing subtree (with LaTeX_CLASS or EXPORT_FILE_NAME prop)
-\[a] export as ASCII [A] to temporary buffer
+\[a/n/u] export as ASCII/Latin-1/UTF-8 [A/N/U] to temporary buffer
-\[h] export as HTML [H] to temporary buffer [R] export region
+\[h] export as HTML [H] to temporary buffer [R] export region
\[b] export as HTML and open in browser
-\[l] export as LaTeX [L] to temporary buffer
-\[p] export as LaTeX and process to PDF
-\[d] export as LaTeX, process to PDF, and open the resulting PDF document
+\[l] export as LaTeX [L] to temporary buffer
+\[p] export as LaTeX and process to PDF [d] ... and open PDF file
-\[D] export as DocBook
-\[V] export as DocBook, process to PDF, and open the resulting PDF document
+\[D] export as DocBook [V] export as DocBook, process to PDF, and open
-\[m] export as Freemind mind map
+\[j] export as TaskJuggler [J] ... and open
+\[m] export as Freemind mind map
\[x] export as XOXO
\[g] export using Wes Hardaker's generic exporter
\[i] export current file as iCalendar file
-\[I] export all agenda files as iCalendar files
-\[c] export agenda files into combined iCalendar file
+\[I] export all agenda files as iCalendar files [c] ...as one combined file
\[F] publish current file [P] publish current project
\[X] publish a project... [E] publish every projects")
@@ -866,6 +909,10 @@ value of `org-export-run-in-background'."
(?v org-export-visible nil)
(?a org-export-as-ascii t)
(?A org-export-as-ascii-to-buffer t)
+ (?n org-export-as-latin1 t)
+ (?N org-export-as-latin1-to-buffer t)
+ (?u org-export-as-utf8 t)
+ (?U org-export-as-utf8-to-buffer t)
(?h org-export-as-html t)
(?b org-export-as-html-and-open t)
(?H org-export-as-html-to-buffer nil)
@@ -874,6 +921,8 @@ value of `org-export-run-in-background'."
(?g org-export-generic t)
(?D org-export-as-docbook t)
(?V org-export-as-docbook-pdf-and-open t)
+ (?j org-export-as-taskjuggler t)
+ (?J org-export-as-taskjuggler-and-open t)
(?m org-export-as-freemind t)
(?l org-export-as-latex t)
(?p org-export-as-pdf t)
@@ -886,7 +935,8 @@ value of `org-export-run-in-background'."
(?P org-publish-current-project t)
(?X org-publish t)
(?E org-publish-all t)))
- r1 r2 ass)
+ r1 r2 ass
+ (cpos (point)) (cbuf (current-buffer)) bpos)
(save-excursion
(save-window-excursion
(delete-other-windows)
@@ -895,7 +945,25 @@ value of `org-export-run-in-background'."
(org-fit-window-to-buffer (get-buffer-window
"*Org Export/Publishing Help*"))
(message "Select command: ")
- (setq r1 (read-char-exclusive))))
+ (setq r1 (read-char-exclusive))
+ (when (eq r1 ?1)
+ (setq subtree-p t)
+ (message "Select command (for subtree): ")
+ (setq r1 (read-char-exclusive)))
+ (when (eq r1 ?\ )
+ (let ((case-fold-search t))
+ (if (re-search-backward
+ "^[ \t]+\\(:latex_class:\\|:export_title:\\)[ \t]+\\S-"
+ nil t)
+ (progn
+ (org-back-to-heading t)
+ (setq subtree-p t)
+ (setq bpos (point))
+ (message "Select command (for subtree): ")
+ (setq r1 (read-char-exclusive)))
+ (error "No enclosing node with LaTeX_CLASS or EXPORT_FILE_NAME")
+ )))))
+ (and bpos (goto-char bpos))
(setq r2 (if (< r1 27) (+ r1 96) r1))
(unless (setq ass (assq r2 cmds))
(error "No command associated with key %c" r1))
@@ -916,322 +984,30 @@ value of `org-export-run-in-background'."
(set-process-sentinel p 'org-export-process-sentinel)
(message "Background process \"%s\": started" p))
;; background processing not requested, or not possible
- (call-interactively (nth 1 ass)))))
+ (if subtree-p (progn (outline-mark-subtree) (activate-mark)))
+ (call-interactively (nth 1 ass))
+ (when (and bpos (get-buffer-window cbuf))
+ (let ((cw (selected-window)))
+ (select-window (get-buffer-window cbuf))
+ (goto-char cpos)
+ (deactivate-mark)
+ (select-window cw))))))
(defun org-export-process-sentinel (process status)
(if (string-match "\n+\\'" status)
(setq status (substring status 0 -1)))
(message "Background process \"%s\": %s" process status))
-(defconst org-html-entities
- '(("nbsp")
- ("iexcl")
- ("cent")
- ("pound")
- ("curren")
- ("yen")
- ("brvbar")
- ("vert" . "&#124;")
- ("sect")
- ("uml")
- ("copy")
- ("ordf")
- ("laquo")
- ("not")
- ("shy")
- ("reg")
- ("macr")
- ("deg")
- ("pm" . "&plusmn;")
- ("plusmn")
- ("sup2")
- ("sup3")
- ("acute")
- ("micro")
- ("para")
- ("middot")
- ("odot"."o")
- ("star"."*")
- ("cedil")
- ("sup1")
- ("ordm")
- ("raquo")
- ("frac14")
- ("frac12")
- ("frac34")
- ("iquest")
- ("Agrave")
- ("Aacute")
- ("Acirc")
- ("Atilde")
- ("Auml")
- ("Aring") ("AA"."&Aring;")
- ("AElig")
- ("Ccedil")
- ("Egrave")
- ("Eacute")
- ("Ecirc")
- ("Euml")
- ("Igrave")
- ("Iacute")
- ("Icirc")
- ("Iuml")
- ("ETH")
- ("Ntilde")
- ("Ograve")
- ("Oacute")
- ("Ocirc")
- ("Otilde")
- ("Ouml")
- ("times")
- ("Oslash")
- ("Ugrave")
- ("Uacute")
- ("Ucirc")
- ("Uuml")
- ("Yacute")
- ("THORN")
- ("szlig")
- ("agrave")
- ("aacute")
- ("acirc")
- ("atilde")
- ("auml")
- ("aring")
- ("aelig")
- ("ccedil")
- ("egrave")
- ("eacute")
- ("ecirc")
- ("euml")
- ("igrave")
- ("iacute")
- ("icirc")
- ("iuml")
- ("eth")
- ("ntilde")
- ("ograve")
- ("oacute")
- ("ocirc")
- ("otilde")
- ("ouml")
- ("divide")
- ("oslash")
- ("ugrave")
- ("uacute")
- ("ucirc")
- ("uuml")
- ("yacute")
- ("thorn")
- ("yuml")
- ("fnof")
- ("Alpha")
- ("Beta")
- ("Gamma")
- ("Delta")
- ("Epsilon")
- ("Zeta")
- ("Eta")
- ("Theta")
- ("Iota")
- ("Kappa")
- ("Lambda")
- ("Mu")
- ("Nu")
- ("Xi")
- ("Omicron")
- ("Pi")
- ("Rho")
- ("Sigma")
- ("Tau")
- ("Upsilon")
- ("Phi")
- ("Chi")
- ("Psi")
- ("Omega")
- ("alpha")
- ("beta")
- ("gamma")
- ("delta")
- ("epsilon")
- ("varepsilon"."&epsilon;")
- ("zeta")
- ("eta")
- ("theta")
- ("iota")
- ("kappa")
- ("lambda")
- ("mu")
- ("nu")
- ("xi")
- ("omicron")
- ("pi")
- ("rho")
- ("sigmaf") ("varsigma"."&sigmaf;")
- ("sigma")
- ("tau")
- ("upsilon")
- ("phi")
- ("chi")
- ("psi")
- ("omega")
- ("thetasym") ("vartheta"."&thetasym;")
- ("upsih")
- ("piv")
- ("bull") ("bullet"."&bull;")
- ("hellip") ("dots"."&hellip;")
- ("prime")
- ("Prime")
- ("oline")
- ("frasl")
- ("weierp")
- ("image")
- ("real")
- ("trade")
- ("alefsym")
- ("larr") ("leftarrow"."&larr;") ("gets"."&larr;")
- ("uarr") ("uparrow"."&uarr;")
- ("rarr") ("to"."&rarr;") ("rightarrow"."&rarr;")
- ("darr")("downarrow"."&darr;")
- ("harr") ("leftrightarrow"."&harr;")
- ("crarr") ("hookleftarrow"."&crarr;") ; has round hook, not quite CR
- ("lArr") ("Leftarrow"."&lArr;")
- ("uArr") ("Uparrow"."&uArr;")
- ("rArr") ("Rightarrow"."&rArr;")
- ("dArr") ("Downarrow"."&dArr;")
- ("hArr") ("Leftrightarrow"."&hArr;")
- ("forall")
- ("part") ("partial"."&part;")
- ("exist") ("exists"."&exist;")
- ("empty") ("emptyset"."&empty;")
- ("nabla")
- ("isin") ("in"."&isin;")
- ("notin")
- ("ni")
- ("prod")
- ("sum")
- ("minus")
- ("lowast") ("ast"."&lowast;")
- ("radic")
- ("prop") ("proptp"."&prop;")
- ("infin") ("infty"."&infin;")
- ("ang") ("angle"."&ang;")
- ("and") ("wedge"."&and;")
- ("or") ("vee"."&or;")
- ("cap")
- ("cup")
- ("int")
- ("there4")
- ("sim")
- ("cong") ("simeq"."&cong;")
- ("asymp")("approx"."&asymp;")
- ("ne") ("neq"."&ne;")
- ("equiv")
- ("le")
- ("ge")
- ("sub") ("subset"."&sub;")
- ("sup") ("supset"."&sup;")
- ("nsub")
- ("sube")
- ("supe")
- ("oplus")
- ("otimes")
- ("perp")
- ("sdot") ("cdot"."&sdot;")
- ("lceil")
- ("rceil")
- ("lfloor")
- ("rfloor")
- ("lang")
- ("rang")
- ("loz") ("Diamond"."&loz;")
- ("spades") ("spadesuit"."&spades;")
- ("clubs") ("clubsuit"."&clubs;")
- ("hearts") ("diamondsuit"."&hearts;")
- ("diams") ("diamondsuit"."&diams;")
- ("smile"."&#9786;") ("blacksmile"."&#9787;") ("sad"."&#9785;")
- ("quot")
- ("amp")
- ("lt")
- ("gt")
- ("OElig")
- ("oelig")
- ("Scaron")
- ("scaron")
- ("Yuml")
- ("circ")
- ("tilde")
- ("ensp")
- ("emsp")
- ("thinsp")
- ("zwnj")
- ("zwj")
- ("lrm")
- ("rlm")
- ("ndash")
- ("mdash")
- ("lsquo")
- ("rsquo")
- ("sbquo")
- ("ldquo")
- ("rdquo")
- ("bdquo")
- ("dagger")
- ("Dagger")
- ("permil")
- ("lsaquo")
- ("rsaquo")
- ("euro")
-
- ("arccos"."arccos")
- ("arcsin"."arcsin")
- ("arctan"."arctan")
- ("arg"."arg")
- ("cos"."cos")
- ("cosh"."cosh")
- ("cot"."cot")
- ("coth"."coth")
- ("csc"."csc")
- ("deg"."deg")
- ("det"."det")
- ("dim"."dim")
- ("exp"."exp")
- ("gcd"."gcd")
- ("hom"."hom")
- ("inf"."inf")
- ("ker"."ker")
- ("lg"."lg")
- ("lim"."lim")
- ("liminf"."liminf")
- ("limsup"."limsup")
- ("ln"."ln")
- ("log"."log")
- ("max"."max")
- ("min"."min")
- ("Pr"."Pr")
- ("sec"."sec")
- ("sin"."sin")
- ("sinh"."sinh")
- ("sup"."sup")
- ("tan"."tan")
- ("tanh"."tanh")
- )
- "Entities for TeX->HTML translation.
-Entries can be like (\"ent\"), in which case \"\\ent\" will be translated to
-\"&ent;\". An entry can also be a dotted pair like (\"ent\".\"&other;\").
-In that case, \"\\ent\" will be translated to \"&other;\".
-The list contains HTML entities for Latin-1, Greek and other symbols.
-It is supplemented by a number of commonly used TeX macros with appropriate
-translations. There is currently no way for users to extend this.")
-
;;; General functions for all backends
(defvar org-export-target-aliases nil
"Alist of targets with invisible aliases.")
(defvar org-export-preferred-target-alist nil
"Alist of section id's with preferred aliases.")
+(defvar org-export-id-target-alist nil
+ "Alist of section id's with preferred aliases.")
(defvar org-export-code-refs nil
- "Alist of code references and line numbers")
+ "Alist of code references and line numbers.")
(defun org-export-preprocess-string (string &rest parameters)
"Cleanup STRING so that that the true exported has a more consistent source.
@@ -1254,15 +1030,20 @@ on this string to produce the exported version."
(outline-regexp "\\*+ ")
target-alist rtn)
- (setq org-export-target-aliases nil)
- (setq org-export-preferred-target-alist nil)
- (setq org-export-code-refs nil)
+ (setq org-export-target-aliases nil
+ org-export-preferred-target-alist nil
+ org-export-id-target-alist nil
+ org-export-code-refs nil)
(with-current-buffer (get-buffer-create " org-mode-tmp")
(erase-buffer)
(insert string)
(setq case-fold-search t)
+ (let ((inhibit-read-only t))
+ (remove-text-properties (point-min) (point-max)
+ '(read-only t)))
+
;; Remove license-to-kill stuff
;; The caller marks some stuff for killing, stuff that has been
;; used to create the page title, for example.
@@ -1282,7 +1063,7 @@ on this string to produce the exported version."
(untabify (point-min) (point-max))
;; Handle include files, and call a hook
- (org-export-handle-include-files)
+ (org-export-handle-include-files-recurse)
(run-hooks 'org-export-preprocess-after-include-files-hook)
;; Get rid of archived trees
@@ -1296,6 +1077,9 @@ on this string to produce the exported version."
(plist-get parameters :exclude-tags))
(run-hooks 'org-export-preprocess-after-tree-selection-hook)
+ ;; Mark end of lists
+ (org-export-mark-list-ending backend)
+
;; Handle source code snippets
(org-export-replace-src-segments-and-examples backend)
@@ -1309,6 +1093,11 @@ on this string to produce the exported version."
;; Find all headings and compute the targets for them
(setq target-alist (org-export-define-heading-targets target-alist))
+ (run-hooks 'org-export-preprocess-after-headline-targets-hook)
+
+ ;; Find HTML special classes for headlines
+ (org-export-remember-html-container-classes)
+
;; Get rid of drawers
(org-export-remove-or-extract-drawers
drawers (plist-get parameters :drawers) backend)
@@ -1333,6 +1122,7 @@ on this string to produce the exported version."
;; Select and protect backend specific stuff, throw away stuff
;; that is specific for other backends
+ (run-hooks 'org-export-preprocess-before-selecting-backend-code-hook)
(org-export-select-backend-specific-text backend)
;; Protect quoted subtrees
@@ -1358,12 +1148,14 @@ on this string to produce the exported version."
;; Find matches for radio targets and turn them into internal links
(org-export-mark-radio-links)
+ (run-hooks 'org-export-preprocess-after-radio-targets-hook)
;; Find all links that contain a newline and put them into a single line
(org-export-concatenate-multiline-links)
;; Normalize links: Convert angle and plain links into bracket links
;; and expand link abbreviations
+ (run-hooks 'org-export-preprocess-before-normalizing-links-hook)
(org-export-normalize-links)
;; Find all internal links. If they have a fuzzy match (i.e. not
@@ -1375,7 +1167,8 @@ on this string to produce the exported version."
(when (plist-get parameters :emph-multiline)
(org-export-concatenate-multiline-emphasis))
- ;; Remove special table lines
+ ;; Remove special table lines, and store alignment information
+ (org-store-forced-table-alignment)
(when org-export-table-remove-special-lines
(org-export-remove-special-table-lines))
@@ -1403,6 +1196,9 @@ on this string to produce the exported version."
;; Remove or replace comments
(org-export-handle-comments (plist-get parameters :comments))
+ ;; Remove #+TBLFM and #+TBLNAME lines
+ (org-export-handle-table-metalines)
+
;; Run the final hook
(run-hooks 'org-export-preprocess-final-hook)
@@ -1419,40 +1215,55 @@ on this string to produce the exported version."
p (or (next-single-property-change p :org-license-to-kill)
(point-max))))))
+(defvar org-export-define-heading-targets-headline-hook nil
+ "Hook that is run when a headline was matched during target search.
+This is part of the preprocessing for export.")
+
(defun org-export-define-heading-targets (target-alist)
"Find all headings and define the targets for them.
-The new targets are added to TARGET-ALIST, which is also returned."
+The new targets are added to TARGET-ALIST, which is also returned.
+Also find all ID and CUSTOM_ID properties and store them."
(goto-char (point-min))
(org-init-section-numbers)
(let ((re (concat "^" org-outline-regexp
- "\\| [ \t]*:\\(ID\\|CUSTOM_ID\\):[ \t]*\\([^ \t\r\n]+\\)"))
+ "\\|"
+ "^[ \t]*:\\(ID\\|CUSTOM_ID\\):[ \t]*\\([^ \t\r\n]+\\)"))
level target last-section-target a id)
(while (re-search-forward re nil t)
- (if (match-end 2)
- (progn
- (setq id (org-match-string-no-properties 2))
- (push (cons id target) target-alist)
- (setq a (or (assoc last-section-target org-export-target-aliases)
- (progn
- (push (list last-section-target)
- org-export-target-aliases)
- (car org-export-target-aliases))))
- (push (caar target-alist) (cdr a))
- (when (equal (match-string 1) "CUSTOM_ID")
- (if (not (assoc last-section-target
- org-export-preferred-target-alist))
- (push (cons last-section-target id)
- org-export-preferred-target-alist))))
- (setq level (org-reduced-level
- (save-excursion (goto-char (point-at-bol))
- (org-outline-level))))
- (setq target (org-solidify-link-text
- (format "sec-%s" (org-section-number level))))
- (setq last-section-target target)
- (push (cons target target) target-alist)
- (add-text-properties
- (point-at-bol) (point-at-eol)
- (list 'target target)))))
+ (org-if-unprotected-at (match-beginning 0)
+ (if (match-end 2)
+ (progn
+ (setq id (org-match-string-no-properties 2))
+ (push (cons id target) target-alist)
+ (setq a (or (assoc last-section-target org-export-target-aliases)
+ (progn
+ (push (list last-section-target)
+ org-export-target-aliases)
+ (car org-export-target-aliases))))
+ (push (caar target-alist) (cdr a))
+ (when (equal (match-string 1) "CUSTOM_ID")
+ (if (not (assoc last-section-target
+ org-export-preferred-target-alist))
+ (push (cons last-section-target id)
+ org-export-preferred-target-alist)))
+ (when (equal (match-string 1) "ID")
+ (if (not (assoc last-section-target
+ org-export-id-target-alist))
+ (push (cons last-section-target (concat "ID-" id))
+ org-export-id-target-alist))))
+ (setq level (org-reduced-level
+ (save-excursion (goto-char (point-at-bol))
+ (org-outline-level))))
+ (setq target (org-solidify-link-text
+ (format "sec-%s" (replace-regexp-in-string
+ "\\." "_"
+ (org-section-number level)))))
+ (setq last-section-target target)
+ (push (cons target target) target-alist)
+ (add-text-properties
+ (point-at-bol) (point-at-eol)
+ (list 'target target))
+ (run-hooks 'org-export-define-heading-targets-headline-hook)))))
target-alist)
(defun org-export-handle-invisible-targets (target-alist)
@@ -1488,7 +1299,7 @@ This function also handles the id links, if they have a match in
the current file."
(goto-char (point-min))
(while (re-search-forward org-bracket-link-regexp nil t)
- (org-if-unprotected
+ (org-if-unprotected-at (1+ (match-beginning 0))
(let* ((md (match-data))
(desc (match-end 2))
(link (org-link-unescape (match-string 1)))
@@ -1513,18 +1324,19 @@ the current file."
(string-match "^\\." link))
nil)
(t
- (save-excursion
- (setq found (condition-case nil (org-link-search link)
- (error nil)))
- (when (and found
- (or (org-on-heading-p)
- (not (eq found 'dedicated))))
- (or (get-text-property (point) 'target)
- (get-text-property
- (max (point-min)
- (1- (or (previous-single-property-change
- (point) 'target) 0)))
- 'target))))))))
+ (let ((org-link-search-inhibit-query t))
+ (save-excursion
+ (setq found (condition-case nil (org-link-search link)
+ (error nil)))
+ (when (and found
+ (or (org-on-heading-p)
+ (not (eq found 'dedicated))))
+ (or (get-text-property (point) 'target)
+ (get-text-property
+ (max (point-min)
+ (1- (or (previous-single-property-change
+ (point) 'target) 0)))
+ 'target)))))))))
(when target
(set-match-data md)
(goto-char (match-beginning 1))
@@ -1535,12 +1347,23 @@ the current file."
(unless desc (insert "][" link))
(add-text-properties pos (point) props))))))
+(defun org-export-remember-html-container-classes ()
+ "Store the HTML_CONTAINER_CLASS properties in a text property."
+ (goto-char (point-min))
+ (let (class)
+ (while (re-search-forward
+ "^[ \t]*:HTML_CONTAINER_CLASS:[ \t]+\\(.+\\)$" nil t)
+ (setq class (match-string 1))
+ (save-excursion
+ (org-back-to-heading t)
+ (put-text-property (point-at-bol) (point-at-eol) 'html-container-class class)))))
+
(defvar org-export-format-drawer-function nil
"Function to be called to format the contents of a drawer.
The function must accept three parameters:
- BACKEND one of the symbols html, docbook, latex, ascii, xoxo
NAME the drawer name, like \"PROPERTIES\"
CONTENT the content of the drawer.
+ BACKEND one of the symbols html, docbook, latex, ascii, xoxo
The function should return the text to be inserted into the buffer.
If this is nil, `org-export-format-drawer' is used as a default.")
@@ -1659,7 +1482,7 @@ from the buffer."
(goto-char (point-min))
(while (re-search-forward re-archive nil t)
(if (not (org-on-heading-p t))
- (org-end-of-subtree t)
+ (goto-char (point-at-eol))
(beginning-of-line 1)
(setq a (if export-archived-trees
(1+ (point-at-eol)) (point))
@@ -1739,6 +1562,7 @@ from the buffer."
(let ((formatters
'((docbook "DOCBOOK" "BEGIN_DOCBOOK" "END_DOCBOOK")
(html "HTML" "BEGIN_HTML" "END_HTML")
+ (beamer "BEAMER" "BEGIN_BEAMER" "END_BEAMER")
(ascii "ASCII" "BEGIN_ASCII" "END_ASCII")
(latex "LaTeX" "BEGIN_LaTeX" "END_LaTeX")))
(case-fold-search t)
@@ -1746,15 +1570,25 @@ from the buffer."
(while formatters
(setq fmt (pop formatters))
- (when (eq (car fmt) backend)
- ;; This is selected code, put it into the file for real
- (goto-char (point-min))
- (while (re-search-forward (concat "^\\([ \t]*\\)#\\+" (cadr fmt)
- ":[ \t]*\\(.*\\)") nil t)
+ ;; Handle #+Backend: stuff
+ (goto-char (point-min))
+ (while (re-search-forward (concat "^\\([ \t]*\\)#\\+" (cadr fmt)
+ ":[ \t]*\\(.*\\)") nil t)
+ (if (not (eq (car fmt) backend))
+ (delete-region (point-at-bol) (min (1+ (point-at-eol)) (point-max)))
(replace-match "\\1\\2" t)
(add-text-properties
(point-at-bol) (min (1+ (point-at-eol)) (point-max))
'(org-protected t))))
+ ;; Delete #+attr_Backend: stuff of another backend. Those
+ ;; matching the current backend will be taken care of by
+ ;; `org-export-attach-captions-and-attributes'
+ (goto-char (point-min))
+ (while (re-search-forward (concat "^\\([ \t]*\\)#\\+attr_" (cadr fmt)
+ ":[ \t]*\\(.*\\)") nil t)
+ (when (not (eq (car fmt) backend))
+ (delete-region (point-at-bol) (min (1+ (point-at-eol)) (point-max)))))
+ ;; Handle #+begin_Backend and #+end_Backend stuff
(goto-char (point-min))
(while (re-search-forward (concat "^[ \t]*#\\+" (caddr fmt) "\\>.*\n?")
nil t)
@@ -1788,8 +1622,8 @@ These special cookies will later be interpreted by the backend."
(setq beg (match-beginning 0)
beg1 (1+ (match-end 0)))
(when (re-search-forward (concat "^[ \t]*#\\+end_" type "\\>.*") nil t)
- (setq end (1+ (point-at-eol))
- end1 (1- (match-beginning 0)))
+ (setq end1 (1- (match-beginning 0))
+ end (+ (point-at-eol) (if (looking-at "\n$") 1 0)))
(setq content (org-remove-indentation (buffer-substring beg1 end1)))
(setq content (concat "ORG-" (upcase t1) "-START\n"
content "\n"
@@ -1797,6 +1631,31 @@ These special cookies will later be interpreted by the backend."
(delete-region beg end)
(insert (org-add-props content nil 'original-indentation ind))))))
+(defun org-export-mark-list-ending (backend)
+ "Mark list endings with special cookies.
+These special cookies will later be interpreted by the backend.
+`org-list-end-re' is replaced by a blank line in the process."
+ (let ((process-buffer
+ (lambda (end-list-marker)
+ (goto-char (point-min))
+ (while (org-search-forward-unenclosed org-item-beginning-re nil t)
+ (goto-char (org-list-bottom-point))
+ (when (and (not (eq org-list-ending-method 'indent))
+ (looking-at (org-list-end-re)))
+ (replace-match "\n"))
+ (insert end-list-marker)))))
+ ;; We need to divide backends into 3 categories.
+ (cond
+ ;; 1. Backends using `org-list-parse-list' do not need markers.
+ ((memq backend '(latex))
+ nil)
+ ;; 2. Line-processing backends need to be told where lists end.
+ ((memq backend '(html docbook))
+ (funcall process-buffer "ORG-LIST-END\n"))
+ ;; 3. Others backends do not need to know this: clean list enders.
+ (t
+ (funcall process-buffer "")))))
+
(defun org-export-attach-captions-and-attributes (backend target-alist)
"Move #+CAPTION, #+ATTR_BACKEND, and #+LABEL text into text properties.
If the next thing following is a table, add the text properties to the first
@@ -1811,38 +1670,55 @@ table line. If it is a link, add it to the line containing the link."
"\\|"
"^[ \t]*#\\+label:[ \t]+\\(.*\\)"
"\\|"
- "^[ \t]*|[^-]"
+ "^[ \t]*\\(|[^-]\\)"
"\\|"
"^[ \t]*\\[\\[.*\\]\\][ \t]*$"))
- cap attr label)
+ cap shortn attr label end)
(while (re-search-forward re nil t)
(cond
((match-end 1)
- (setq cap (concat cap (if cap " " "") (org-trim (match-string 1)))))
+ (progn
+ (setq cap (concat cap (if cap " " "") (org-trim (match-string 1))))
+ (when (string-match "\\[\\(.*\\)\\]{\\(.*\\)}" cap)
+ (setq shortn (match-string 1 cap)
+ cap (match-string 2 cap)))
+ (delete-region (point-at-bol) (min (1+ (point-at-eol)) (point-max)))))
((match-end 2)
- (setq attr (concat attr (if attr " " "") (org-trim (match-string 2)))))
+ (progn
+ (setq attr (concat attr (if attr " " "") (org-trim (match-string 2))))
+ (delete-region (point-at-bol) (min (1+ (point-at-eol)) (point-max)))))
((match-end 3)
- (setq label (org-trim (match-string 3))))
+ (progn
+ (setq label (org-trim (match-string 3)))
+ (delete-region (point-at-bol) (min (1+ (point-at-eol)) (point-max)))))
(t
- (add-text-properties (point-at-bol) (point-at-eol)
+ (setq end (if (match-end 4)
+ (let ((ee (org-table-end)))
+ (prog1 (1- (marker-position ee)) (move-marker ee nil)))
+ (point-at-eol)))
+ (add-text-properties (point-at-bol) end
(list 'org-caption cap
+ 'org-caption-shortn shortn
'org-attributes attr
'org-label label))
(if label (push (cons label label) target-alist))
+ (goto-char end)
(setq cap nil attr nil label nil)))))
target-alist)
(defun org-export-remove-comment-blocks-and-subtrees ()
"Remove the comment environment, and also commented subtrees."
(let ((re-commented (concat "^\\*+[ \t]+" org-comment-string "\\>"))
- (case-fold-search nil))
+ case-fold-search)
;; Remove comment environment
(goto-char (point-min))
+ (setq case-fold-search t)
(while (re-search-forward
- "^#\\+BEGIN_COMMENT[ \t]*\n[^\000]*?^#\\+END_COMMENT\\>.*" nil t)
+ "^#\\+begin_comment[ \t]*\n[^\000]*?^#\\+end_comment\\>.*" nil t)
(replace-match "" t t))
;; Remove subtrees that are commented
(goto-char (point-min))
+ (setq case-fold-search nil)
(while (re-search-forward re-commented nil t)
(goto-char (match-beginning 0))
(delete-region (point) (org-end-of-subtree t)))))
@@ -1851,21 +1727,36 @@ table line. If it is a link, add it to the line containing the link."
"Remove comments, or convert to backend-specific format.
COMMENTSP can be a format string for publishing comments.
When it is nil, all comments will be removed."
- (let ((re "^\\(#\\|[ \t]*#\\+\\)\\(.*\n?\\)")
+ (let ((re "^\\(#\\|[ \t]*#\\+ \\)\\(.*\n?\\)")
pos)
(goto-char (point-min))
(while (or (looking-at re)
(re-search-forward re nil t))
(setq pos (match-beginning 0))
- (if (and commentsp
- (not (equal (char-before (match-end 1)) ?+)))
- (progn (add-text-properties
- (match-beginning 0) (match-end 0) '(org-protected t))
- (replace-match (format commentsp (match-string 2)) t t))
+ (if (get-text-property pos 'org-protected)
+ (goto-char (1+ pos))
+ (if (and commentsp
+ (not (equal (char-before (match-end 1)) ?+)))
+ (progn (add-text-properties
+ (match-beginning 0) (match-end 0) '(org-protected t))
+ (replace-match (format commentsp (match-string 2)) t t))
+ (goto-char (1+ pos))
+ (replace-match "")
+ (goto-char (max (point-min) (1- pos))))))))
+
+(defun org-export-handle-table-metalines ()
+ "Remove table specific metalines #+TBLNAME: and #+TBLFM:."
+ (let ((re "^[ \t]*#\\+TBL\\(NAME\\|FM\\):\\(.*\n?\\)")
+ pos)
+ (goto-char (point-min))
+ (while (or (looking-at re)
+ (re-search-forward re nil t))
+ (setq pos (match-beginning 0))
+ (if (get-text-property (match-beginning 1) 'org-protected)
+ (goto-char (1+ pos))
(goto-char (1+ pos))
- (org-if-unprotected
- (replace-match "")
- (goto-char (max (point-min) (1- pos))))))))
+ (replace-match "")
+ (goto-char (max (point-min) (1- pos)))))))
(defun org-export-mark-radio-links ()
"Find all matches for radio targets and turn them into internal links."
@@ -1877,30 +1768,54 @@ When it is nil, all comments will be removed."
(unless
(save-match-data
(or (org-in-regexp org-bracket-link-regexp)
- (org-in-regexp org-plain-link-re)))
+ (org-in-regexp org-plain-link-re)
+ (org-in-regexp "<<[^<>]+>>")))
(org-if-unprotected
(replace-match "\\1[[\\2]]")))))))
+(defun org-store-forced-table-alignment ()
+ "Find table lines which force alignment, store the results in properties."
+ (let (line cnt aligns)
+ (goto-char (point-min))
+ (while (re-search-forward "|[ \t]*<[lrc][0-9]*>[ \t]*|" nil t)
+ ;; OK, this looks like a table line with an alignment cookie
+ (org-if-unprotected
+ (setq line (buffer-substring (point-at-bol) (point-at-eol)))
+ (when (and (org-at-table-p)
+ (org-table-cookie-line-p line))
+ (setq cnt 0 aligns nil)
+ (mapc
+ (lambda (x)
+ (setq cnt (1+ cnt))
+ (if (string-match "\\`<\\([lrc]\\)" x)
+ (push (cons cnt (downcase (match-string 1 x))) aligns)))
+ (org-split-string line "[ \t]*|[ \t]*"))
+ (add-text-properties (org-table-begin) (org-table-end)
+ (list 'org-forced-aligns aligns))))
+ (goto-char (point-at-eol)))))
+
(defun org-export-remove-special-table-lines ()
- "Remove tables lines that are used for internal purposes."
+ "Remove tables lines that are used for internal purposes.
+Also, store forcedalignment information found in such lines."
(goto-char (point-min))
(while (re-search-forward "^[ \t]*|" nil t)
- (beginning-of-line 1)
- (if (or (looking-at "[ \t]*| *[!_^] *|")
- (not
- (memq
- nil
- (mapcar
- (lambda (f)
- (or (= (length f) 0)
- (string-match
- "\\`<\\([0-9]\\|[rl]\\|[rl][0-9]+\\)>\\'" f)))
- (org-split-string ;; FIXME, can't we do this without splitting???
- (buffer-substring (point-at-bol) (point-at-eol))
- "[ \t]*|[ \t]*")))))
- (delete-region (max (point-min) (1- (point-at-bol)))
- (point-at-eol))
- (end-of-line 1))))
+ (org-if-unprotected-at (1- (point))
+ (beginning-of-line 1)
+ (if (or (looking-at "[ \t]*| *[!_^] *|")
+ (not
+ (memq
+ nil
+ (mapcar
+ (lambda (f)
+ (or (= (length f) 0)
+ (string-match
+ "\\`<\\([0-9]\\|[lrc]\\|[lrc][0-9]+\\)>\\'" f)))
+ (org-split-string ;; FIXME, can't we do without splitting???
+ (buffer-substring (point-at-bol) (point-at-eol))
+ "[ \t]*|[ \t]*")))))
+ (delete-region (max (point-min) (1- (point-at-bol)))
+ (point-at-eol))
+ (end-of-line 1)))))
(defun org-export-protect-sub-super (s)
(save-match-data
@@ -1915,16 +1830,19 @@ When it is nil, all comments will be removed."
nodesc)
(goto-char (point-min))
(while (re-search-forward re-plain-link nil t)
- (goto-char (1- (match-end 0)))
- (org-if-unprotected-at (1+ (match-beginning 0))
- (let* ((s (concat (match-string 1)
- "[[" (match-string 2) ":" (match-string 3)
- "][" (match-string 2) ":" (org-export-protect-sub-super
- (match-string 3))
- "]]")))
- ;; added 'org-link face to links
- (put-text-property 0 (length s) 'face 'org-link s)
- (replace-match s t t))))
+ (unless (org-string-match-p
+ "\\[\\[\\S+:\\S-*?\\<"
+ (buffer-substring (point-at-bol) (match-beginning 0)))
+ (goto-char (1- (match-end 0)))
+ (org-if-unprotected-at (1+ (match-beginning 0))
+ (let* ((s (concat (match-string 1)
+ "[[" (match-string 2) ":" (match-string 3)
+ "][" (match-string 2) ":" (org-export-protect-sub-super
+ (match-string 3))
+ "]]")))
+ ;; added 'org-link face to links
+ (put-text-property 0 (length s) 'face 'org-link s)
+ (replace-match s t t)))))
(goto-char (point-min))
(while (re-search-forward re-angle-link nil t)
(goto-char (1- (match-end 0)))
@@ -1962,7 +1880,7 @@ This is to make sure that the line-processing export backends
can work correctly."
(goto-char (point-min))
(while (re-search-forward "\\(\\(\\[\\|\\]\\)\\[[^]]*?\\)[ \t]*\n[ \t]*\\([^]]*\\]\\(\\[\\|\\]\\)\\)" nil t)
- (org-if-unprotected
+ (org-if-unprotected-at (match-beginning 1)
(replace-match "\\1 \\3")
(goto-char (match-beginning 0)))))
@@ -1975,7 +1893,9 @@ can work correctly."
(if (and (not (= (char-after (match-beginning 3))
(char-after (match-beginning 4))))
(save-excursion (goto-char (match-beginning 0))
- (save-match-data (not (org-at-table-p)))))
+ (save-match-data
+ (and (not (org-at-table-p))
+ (not (org-at-heading-p))))))
(org-if-unprotected
(subst-char-in-region (match-beginning 0) (match-end 0)
?\n ?\ t)
@@ -2144,16 +2064,15 @@ TYPE must be a string, any of:
(intern (concat ":" key)))))
(save-match-data
(when args
- (setq args (org-split-string args ",[ \t\n]*") args2 nil)
- (setq args (mapcar 'org-trim args))
+ (setq args (org-split-string args ",") args2 nil)
(while args
(while (string-match "\\\\\\'" (car args))
;; repair bad splits
(setcar (cdr args) (concat (substring (car args) 0 -1)
- ";" (nth 1 args)))
+ "," (nth 1 args)))
(pop args))
(push (pop args) args2))
- (setq args (nreverse args2))
+ (setq args (mapcar 'org-trim (nreverse args2)))
(setq s 0)
(while (string-match "\\$\\([0-9]+\\)" val s)
(setq s (1+ (match-beginning 0))
@@ -2181,7 +2100,7 @@ TYPE must be a string, any of:
(defun org-export-handle-include-files ()
"Include the contents of include files, with proper formatting."
(let ((case-fold-search t)
- params file markup lang start end prefix prefix1 switches)
+ params file markup lang start end prefix prefix1 switches all)
(goto-char (point-min))
(while (re-search-forward "^#\\+INCLUDE:?[ \t]+\\(.*\\)" nil t)
(setq params (read (concat "(" (match-string 1) ")"))
@@ -2198,6 +2117,7 @@ TYPE must be a string, any of:
(not (file-exists-p file))
(not (file-readable-p file)))
(insert (format "CANNOT INCLUDE FILE %s" file))
+ (setq all (cons file all))
(when markup
(if (equal (downcase markup) "src")
(setq start (format "#+begin_src %s %s\n"
@@ -2210,7 +2130,20 @@ TYPE must be a string, any of:
(insert (org-get-file-contents (expand-file-name file)
prefix prefix1 markup))
(or (bolp) (newline))
- (insert (or end ""))))))
+ (insert (or end ""))))
+ all))
+
+(defun org-export-handle-include-files-recurse ()
+ "Recursively include files aborting on circular inclusion."
+ (let ((now (list org-current-export-file)) all)
+ (while now
+ (setq all (append now all))
+ (setq now (org-export-handle-include-files))
+ (let ((intersection
+ (delq nil
+ (mapcar (lambda (el) (when (member el all) el)) now))))
+ (when intersection
+ (error "Recursive #+INCLUDE: %S" intersection))))))
(defun org-get-file-contents (file &optional prefix prefix1 markup)
"Get the contents of FILE and return them as a string.
@@ -2225,7 +2158,7 @@ take care of the block they are in."
(goto-char (point-min))
(while (not (eobp))
(insert (or prefix1 prefix))
- (setq prefix1 nil)
+ (setq prefix1 "")
(beginning-of-line 2)))
(buffer-string)
(when (member markup '("src" "example"))
@@ -2263,24 +2196,36 @@ in the list) and remove property and value from the list in LISTVAR."
"Replace source code segments with special code for export."
(setq org-export-last-code-line-counter-value 0)
(let ((case-fold-search t)
- lang code trans opts indent)
+ lang code trans opts indent caption)
(goto-char (point-min))
(while (re-search-forward
- "\\(^\\([ \t]*\\)#\\+BEGIN_SRC:?[ \t]+\\([^ \t\n]+\\)\\(.*\\)\n\\([^\000]+?\n\\)[ \t]*#\\+END_SRC.*\\)\\|\\(^\\([ \t]*\\)#\\+BEGIN_EXAMPLE:?\\(?:[ \t]+\\(.*\\)\\)?\n\\([^\000]+?\n\\)[ \t]*#\\+END_EXAMPLE.*\\)"
+ "\\(^\\([ \t]*\\)#\\+BEGIN_SRC:?\\([ \t]+\\([^ \t\n]+\\)\\)?\\(.*\\)\n\\([^\000]+?\n\\)[ \t]*#\\+END_SRC.*\n?\\)\\|\\(^\\([ \t]*\\)#\\+BEGIN_EXAMPLE:?\\(?:[ \t]+\\(.*\\)\\)?\n\\([^\000]+?\n\\)[ \t]*#\\+END_EXAMPLE.*\n?\\)"
nil t)
(if (match-end 1)
- ;; src segments
- (setq lang (match-string 3)
- opts (match-string 4)
- code (match-string 5)
- indent (length (match-string 2)))
+ (if (not (match-string 4))
+ (error "Source block missing language specification: %s"
+ (let* ((body (match-string 6))
+ (nothing (message "body:%s" body))
+ (preview (or (and (string-match
+ "^[ \t]*\\([^\n\r]*\\)" body)
+ (match-string 1 body)) body)))
+ (if (> (length preview) 35)
+ (concat (substring preview 0 32) "...")
+ preview)))
+ ;; src segments
+ (setq lang (match-string 4)
+ opts (match-string 5)
+ code (match-string 6)
+ indent (length (match-string 2))
+ caption (get-text-property 0 'org-caption (match-string 0))))
(setq lang nil
- opts (match-string 8)
- code (match-string 9)
- indent (length (match-string 7))))
+ opts (match-string 9)
+ code (match-string 10)
+ indent (length (match-string 8))
+ caption (get-text-property 0 'org-caption (match-string 0))))
(setq trans (org-export-format-source-code-or-example
- backend lang code opts indent))
+ backend lang code opts indent caption))
(replace-match trans t t))))
(defvar htmlp) ;; dynamically scoped
@@ -2288,9 +2233,12 @@ in the list) and remove property and value from the list in LISTVAR."
(defvar org-export-latex-verbatim-wrap) ;; defined in org-latex.el
(defvar org-export-latex-listings) ;; defined in org-latex.el
(defvar org-export-latex-listings-langs) ;; defined in org-latex.el
+(defvar org-export-latex-listings-w-names) ;; defined in org-latex.el
+(defvar org-export-latex-minted-langs) ;; defined in org-latex.el
+(defvar org-export-latex-minted-with-line-numbers) ;; defined in org-latex.el
(defun org-export-format-source-code-or-example
- (backend lang code &optional opts indent)
+ (backend lang code &optional opts indent caption)
"Format CODE from language LANG and return it formatted for export.
If LANG is nil, do not add any fontification.
OPTS contains formatting options, like `-n' for triggering numbering lines,
@@ -2341,13 +2289,15 @@ INDENT was the original indentation of the block."
(concat "\n#+BEGIN_DOCBOOK\n"
(org-add-props (concat "<programlisting><![CDATA["
rtn
- "]]>\n</programlisting>\n")
- '(org-protected t))
+ "]]></programlisting>\n")
+ '(org-protected t org-example t))
"#+END_DOCBOOK\n"))
((eq backend 'html)
;; We are exporting to HTML
(when lang
- (require 'htmlize nil t)
+ (if (featurep 'xemacs)
+ (require 'htmlize)
+ (require 'htmlize nil t))
(when (not (fboundp 'htmlize-region-for-paste))
;; we do not have htmlize.el, or an old version of it
(setq lang nil)
@@ -2378,12 +2328,22 @@ INDENT was the original indentation of the block."
(org-export-htmlize-region-for-paste
(point-min) (point-max))))
(if (string-match "<pre\\([^>]*\\)>\n*" rtn)
- (setq rtn (replace-match
- (format "<pre class=\"src src-%s\">\n" lang)
- t t rtn))))
+ (setq rtn
+ (concat
+ (if caption
+ (concat
+ "<div class=\"org-src-container\">"
+ (format
+ "<label class=\"org-src-name\">%s</label>"
+ caption))
+ "")
+ (replace-match
+ (format "<pre class=\"src src-%s\">\n" lang)
+ t t rtn)
+ (if caption "</div>" "")))))
(if textareap
(setq rtn (concat
- (format "<p>\n<textarea cols=\"%d\" rows=\"%d\" overflow-x:scroll >\n"
+ (format "<p>\n<textarea cols=\"%d\" rows=\"%d\">"
cols rows)
rtn "</textarea>\n</p>\n"))
(with-temp-buffer
@@ -2400,34 +2360,61 @@ INDENT was the original indentation of the block."
cont rpllbl fmt)))
(if (string-match "\\(\\`<[^>]*>\\)\n" rtn)
(setq rtn (replace-match "\\1" t nil rtn)))
- (concat "\n#+BEGIN_HTML\n" (org-add-props rtn '(org-protected t)) "\n#+END_HTML\n\n"))
+ (concat "\n#+BEGIN_HTML\n" (org-add-props rtn '(org-protected t org-example t)) "\n#+END_HTML\n\n"))
((eq backend 'latex)
(setq rtn (org-export-number-lines rtn 'latex 0 0 num cont rpllbl fmt))
- (concat "\n#+BEGIN_LaTeX\n"
+ (concat "#+BEGIN_LaTeX\n"
(org-add-props
- (if org-export-latex-listings
- (concat
- (if lang
- (let*
- ((lang-sym (intern lang))
- (lstlang
- (or (cadr
- (assq
- lang-sym
- org-export-latex-listings-langs))
- lang)))
- (format "\\lstset{language=%s}\n" lstlang))
- "")
- "\\begin{lstlisting}\n"
- rtn "\\end{lstlisting}\n")
- (concat (car org-export-latex-verbatim-wrap)
- rtn (cdr org-export-latex-verbatim-wrap)))
- '(org-protected t))
- "#+END_LaTeX\n\n"))
- ((eq backend 'ascii)
- ;; This is not HTML or LaTeX, so just make it an example.
- (setq rtn (org-export-number-lines rtn 'ascii 0 0 num cont rpllbl fmt))
- (concat "#+BEGIN_ASCII\n"
+ (cond
+ ((and org-export-latex-listings
+ (not (eq org-export-latex-listings 'minted)))
+ (concat
+ (if lang
+ (let*
+ ((lang-sym (intern lang))
+ (lstlang
+ (or (cadr
+ (assq
+ lang-sym
+ org-export-latex-listings-langs))
+ lang)))
+ (format "\\lstset{language=%s}\n" lstlang))
+ "\n")
+ (when (and caption
+ org-export-latex-listings-w-names)
+ (format "\n%s $\\equiv$ \n"
+ (replace-regexp-in-string
+ "_" "\\\\_" caption)))
+ "\\begin{lstlisting}\n"
+ rtn "\\end{lstlisting}\n"))
+ ((eq org-export-latex-listings 'minted)
+ (if lang
+ (let*
+ ((lang-sym (intern lang))
+ (minted-lang
+ (or (cadr
+ (assq
+ lang-sym
+ org-export-latex-minted-langs))
+ (downcase lang))))
+ (concat
+ (when (and caption
+ org-export-latex-listings-w-names)
+ (format "\n%s $\\equiv$ \n"
+ (replace-regexp-in-string
+ "_" "\\\\_" caption)))
+ (format
+ "\\begin{minted}[mathescape,%s\nnumbersep=5pt,\nframe=lines,\nframesep=2mm]{%s}\n" (if org-export-latex-minted-with-line-numbers "\nlinenos," "") minted-lang)
+ rtn "\\end{minted}\n"))))
+ (t (concat (car org-export-latex-verbatim-wrap)
+ rtn (cdr org-export-latex-verbatim-wrap))))
+ '(org-protected t org-example t))
+ "#+END_LaTeX\n"))
+ ((eq backend 'ascii)
+ ;; This is not HTML or LaTeX, so just make it an example.
+ (setq rtn (org-export-number-lines rtn 'ascii 0 0 num cont rpllbl fmt))
+ (concat caption "\n"
+ "#+BEGIN_ASCII\n"
(org-add-props
(concat
(mapconcat
@@ -2435,7 +2422,7 @@ INDENT was the original indentation of the block."
(org-split-string rtn "\n")
"\n")
"\n")
- '(org-protected t))
+ '(org-protected t org-example t))
"#+END_ASCII\n"))))
(org-add-props rtn nil 'original-indentation indent))))
@@ -2538,22 +2525,27 @@ INDENT was the original indentation of the block."
(defun org-export-visible (type arg)
"Create a copy of the visible part of the current buffer, and export it.
The copy is created in a temporary buffer and removed after use.
-TYPE is the final key (as a string) that also select the export command in
-the `C-c C-e' export dispatcher.
-
-As a special case, if you type SPC at the prompt, the temporary org-mode
-file will not be removed but presented to you so that you can continue to
-use it. The prefix arg ARG is passed through to the exporting command."
+TYPE is the final key (as a string) that also selects the export command in
+the \\<org-mode-map>\\[org-export] export dispatcher.
+As a special case, if the you type SPC at the prompt, the temporary
+org-mode file will not be removed but presented to you so that you can
+continue to use it. The prefix arg ARG is passed through to the exporting
+command."
(interactive
(list (progn
- (message "Export visible: [a]SCII [h]tml [b]rowse HTML [H/R]uffer with HTML [D]ocBook [x]OXO [ ]keep buffer")
+ (message "Export visible: [a]SCII [h]tml [b]rowse HTML [H/R]buffer with HTML [D]ocBook [l]atex [p]df [d]view pdf [L]atex buffer [x]OXO [ ]keep buffer")
(read-char-exclusive))
current-prefix-arg))
- (if (not (member type '(?a ?\C-a ?b ?\C-b ?h ?D ?x ?\ )))
+ (if (not (member type '(?a ?n ?u ?\C-a ?b ?\C-b ?h ?D ?x ?\ ?l ?p ?d ?L)))
(error "Invalid export key"))
(let* ((binding (cdr (assoc type
- '((?a . org-export-as-ascii)
+ '(
+ (?a . org-export-as-ascii)
(?A . org-export-as-ascii-to-buffer)
+ (?n . org-export-as-latin1)
+ (?N . org-export-as-latin1-to-buffer)
+ (?u . org-export-as-utf8)
+ (?U . org-export-as-utf8-to-buffer)
(?\C-a . org-export-as-ascii)
(?b . org-export-as-html-and-open)
(?\C-b . org-export-as-html-and-open)
@@ -2561,6 +2553,12 @@ use it. The prefix arg ARG is passed through to the exporting command."
(?H . org-export-as-html-to-buffer)
(?R . org-export-region-as-html)
(?D . org-export-as-docbook)
+
+ (?l . org-export-as-latex)
+ (?p . org-export-as-pdf)
+ (?d . org-export-as-pdf-and-open)
+ (?L . org-export-as-latex-to-buffer)
+
(?x . org-export-as-xoxo)))))
(keepp (equal type ?\ ))
(file buffer-file-name)
@@ -2614,6 +2612,28 @@ use it. The prefix arg ARG is passed through to the exporting command."
(defvar org-export-htmlized-org-css-url) ;; defined in org-html.el
+(defun org-export-string (string fmt &optional dir)
+ "Export STRING to FMT using existing export facilities.
+During export STRING is saved to a temporary file whose location
+could vary. Optional argument DIR can be used to force the
+directory in which the temporary file is created during export
+which can be useful for resolving relative paths. Dir defaults
+to the value of `temporary-file-directory'."
+ (let ((temporary-file-directory (or dir temporary-file-directory))
+ (tmp-file (make-temp-file "org-")))
+ (unwind-protect
+ (with-temp-buffer
+ (insert string)
+ (write-file tmp-file)
+ (org-load-modules-maybe)
+ (unless org-local-vars
+ (setq org-local-vars (org-get-local-variables)))
+ (eval ;; convert to fmt -- mimicing `org-run-like-in-org-mode'
+ (list 'let org-local-vars
+ (list (intern (concat "org-export-as-" fmt))
+ nil nil nil ''string t))))
+ (delete-file tmp-file))))
+
;;;###autoload
(defun org-export-as-org (arg &optional hidden ext-plist
to-buffer body-only pub-dir)
@@ -2655,7 +2675,8 @@ directory."
filename)))
(backup-inhibited t)
(buffer (find-file-noselect filename))
- (region (buffer-string)))
+ (region (buffer-string))
+ str-ret)
(save-excursion
(switch-to-buffer buffer)
(erase-buffer)
@@ -2701,7 +2722,11 @@ directory."
(write-file (concat filename ".html")))
(kill-buffer newbuf)))
(set-buffer-modified-p nil)
- (kill-buffer (current-buffer)))))
+ (if (equal to-buffer 'string)
+ (progn (setq str-ret (buffer-string))
+ (kill-buffer (current-buffer))
+ str-ret)
+ (kill-buffer (current-buffer))))))
(defvar org-archive-location) ;; gets loaded with the org-archive require.
(defun org-get-current-options ()
@@ -2723,6 +2748,7 @@ Does include HTML export options as well as TODO and CATEGORY stuff."
#+EXPORT_EXCLUDE_TAGS: %s
#+LINK_UP: %s
#+LINK_HOME: %s
+#+XSLT:
#+CATEGORY: %s
#+SEQ_TODO: %s
#+TYP_TODO: %s
@@ -2815,13 +2841,16 @@ If yes remove the column and the special lines."
"^[ \t]*| *\\([\#!$*_^ /]\\) *|")
x)))
lines))
+ ;; No special marking column
(progn
(setq org-table-clean-did-remove-column nil)
(delq nil
(mapcar
(lambda (x)
(cond
- ((string-match "^[ \t]*| */ *|" x)
+ ((org-table-colgroup-line-p x)
+ ;; This line contains colgroup info, extract it
+ ;; and then discard the line
(setq org-table-colgroup-info
(mapcar (lambda (x)
(cond ((member x '("<" "&lt;")) :start)
@@ -2830,14 +2859,20 @@ If yes remove the column and the special lines."
(t nil)))
(org-split-string x "[ \t]*|[ \t]*")))
nil)
+ ((org-table-cookie-line-p x)
+ ;; This line contains formatting cookies, discard it
+ nil)
(t x)))
lines)))
+ ;; there is a special marking column
(setq org-table-clean-did-remove-column t)
(delq nil
(mapcar
(lambda (x)
(cond
- ((string-match "^[ \t]*| */ *|" x)
+ ((org-table-colgroup-line-p x)
+ ;; This line contains colgroup info, extract it
+ ;; and then discard the line
(setq org-table-colgroup-info
(mapcar (lambda (x)
(cond ((member x '("<" "&lt;")) :start)
@@ -2846,8 +2881,12 @@ If yes remove the column and the special lines."
(t nil)))
(cdr (org-split-string x "[ \t]*|[ \t]*"))))
nil)
+ ((org-table-cookie-line-p x)
+ ;; This line contains formatting cookies, discard it
+ nil)
((string-match "^[ \t]*| *[!_^/] *|" x)
- nil) ; ignore this line
+ ;; ignore this line
+ nil)
((or (string-match "^\\([ \t]*\\)|-+\\+" x)
(string-match "^\\([ \t]*\\)|[^|]*|" x))
;; remove the first column
@@ -2857,7 +2896,7 @@ If yes remove the column and the special lines."
(defun org-export-cleanup-toc-line (s)
"Remove tags and timestamps from lines going into the toc."
(when (memq org-export-with-tags '(not-in-toc nil))
- (if (string-match (org-re " +:[[:alnum:]_@:]+: *$") s)
+ (if (string-match (org-re " +:[[:alnum:]_@#%:]+: *$") s)
(setq s (replace-match "" t t s))))
(when org-export-remove-timestamps-from-toc
(while (string-match org-maybe-keyword-time-regexp s)
@@ -2869,41 +2908,6 @@ If yes remove the column and the special lines."
(setq s (replace-match "" t t s)))
s)
-(defun org-create-multibrace-regexp (left right n)
- "Create a regular expression which will match a balanced sexp.
-Opening delimiter is LEFT, and closing delimiter is RIGHT, both given
-as single character strings.
-The regexp returned will match the entire expression including the
-delimiters. It will also define a single group which contains the
-match except for the outermost delimiters. The maximum depth of
-stacked delimiters is N. Escaping delimiters is not possible."
- (let* ((nothing (concat "[^" left right "]*?"))
- (or "\\|")
- (re nothing)
- (next (concat "\\(?:" nothing left nothing right "\\)+" nothing)))
- (while (> n 1)
- (setq n (1- n)
- re (concat re or next)
- next (concat "\\(?:" nothing left next right "\\)+" nothing)))
- (concat left "\\(" re "\\)" right)))
-
-(defvar org-match-substring-regexp
- (concat
- "\\([^\\]\\)\\([_^]\\)\\("
- "\\(" (org-create-multibrace-regexp "{" "}" org-match-sexp-depth) "\\)"
- "\\|"
- "\\(" (org-create-multibrace-regexp "(" ")" org-match-sexp-depth) "\\)"
- "\\|"
- "\\(\\(?:\\*\\|[-+]?[^-+*!@#$%^_ \t\r\n,:\"?<>~;./{}=()]+\\)\\)\\)")
- "The regular expression matching a sub- or superscript.")
-
-(defvar org-match-substring-with-braces-regexp
- (concat
- "\\([^\\]\\)\\([_^]\\)\\("
- "\\(" (org-create-multibrace-regexp "{" "}" org-match-sexp-depth) "\\)"
- "\\)")
- "The regular expression matching a sub- or superscript, forcing braces.")
-
(defun org-get-text-property-any (pos prop &optional object)
(or (get-text-property pos prop object)
diff --git a/lisp/org/org-faces.el b/lisp/org/org-faces.el
index 2e5e63199a0..e4e17f15c5d 100644
--- a/lisp/org/org-faces.el
+++ b/lisp/org/org-faces.el
@@ -6,7 +6,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -49,7 +49,7 @@
(defgroup org-faces nil
"Faces in Org-mode."
:tag "Org Faces"
- :group 'org-font-lock)
+ :group 'org-appearance)
(defface org-hide
'((((background light)) (:foreground "white"))
@@ -338,29 +338,53 @@ This face is only used if `org-fontify-done-headline' is set. If applies
to the part of the headline after the DONE keyword."
:group 'org-faces)
+(defcustom org-faces-easy-properties
+ '((todo . :foreground) (tag . :foreground) (priority . :foreground))
+ "The property changes by easy faces.
+This is an alist, the keys show the area of application, the values
+can be `:foreground' or `:background'. A color string for special
+keywords will then be interpreted as either foreground or background
+color."
+ :group 'org-faces
+ :group 'org-todo
+ :type '(repeat
+ (cons (choice (const todo) (const tag) (const priority))
+ (choice (const :foreground) (const :background)))))
+
(defcustom org-todo-keyword-faces nil
"Faces for specific TODO keywords.
This is a list of cons cells, with TODO keywords in the car
-and faces in the cdr. The face can be a symbol, or a property
-list of attributes, like (:foreground \"blue\" :weight bold :underline t)."
+and faces in the cdr. The face can be a symbol, a color
+as a string (in which case the rest is inherited from the `org-todo' face),
+or a property list of attributes, like
+ (:foreground \"blue\" :weight bold :underline t).
+If it is a color string, the variable `org-faces-easy-properties'
+determines if it is a foreground or a background color."
:group 'org-faces
:group 'org-todo
:type '(repeat
(cons
- (string :tag "keyword")
- (sexp :tag "face"))))
+ (string :tag "Keyword")
+ (choice :tag "Face "
+ (string :tag "Color")
+ (sexp :tag "Face")))))
(defcustom org-priority-faces nil
"Faces for specific Priorities.
This is a list of cons cells, with priority character in the car
-and faces in the cdr. The face can be a symbol, or a property
-list of attributes, like (:foreground \"blue\" :weight bold :underline t)."
+and faces in the cdr. The face can be a symbol, a color as
+as a string, or a property list of attributes, like
+ (:foreground \"blue\" :weight bold :underline t).
+If it is a color string, the variable `org-faces-easy-properties'
+determines if it is a foreground or a background color."
:group 'org-faces
:group 'org-todo
:type '(repeat
(cons
(character :tag "Priority")
- (sexp :tag "face"))))
+ (choice :tag "Face "
+ (string :tag "Color")
+ (sexp :tag "Face")))))
(defvar org-tags-special-faces-re nil)
(defun org-set-tag-faces (var value)
@@ -378,15 +402,16 @@ list of attributes, like (:foreground \"blue\" :weight bold :underline t)."
(org-copy-face 'org-todo 'org-checkbox-statistics-todo
- "Face used for unfinished checkbox statistics.")
+ "Face used for unfinished checkbox statistics.")
(org-copy-face 'org-done 'org-checkbox-statistics-done
- "Face used for finished checkbox statistics.")
+ "Face used for finished checkbox statistics.")
(defcustom org-tag-faces nil
"Faces for specific tags.
This is a list of cons cells, with tags in the car and faces in the cdr.
-The face can be a symbol, or a property list of attributes,
+The face can be a symbol, a foreground color (in which case the rest is
+inherited from the `org-tag' face) or a property list of attributes,
like (:foreground \"blue\" :weight bold :underline t).
If you set this variable through customize, it will immediately be effective
in new buffers and in modified lines.
@@ -397,8 +422,10 @@ changes."
:set 'org-set-tag-faces
:type '(repeat
(cons
- (string :tag "Tag")
- (sexp :tag "Face"))))
+ (string :tag "Tag ")
+ (choice :tag "Face"
+ (string :tag "Foreground color")
+ (sexp :tag "Face")))))
(defface org-table ;; originally copied from font-lock-function-name-face
(org-compatible-face nil
@@ -431,7 +458,7 @@ changes."
(:foreground "green"))
(((class color) (min-colors 8) (background dark))
(:foreground "yellow"))))
- "Face for fixed-with text like code snippets."
+ "Face for fixed-width text like code snippets."
:group 'org-faces
:version "22.1")
@@ -441,6 +468,34 @@ changes."
:group 'org-faces
:version "22.1")
+(defface org-document-title
+ '((((class color) (background light)) (:foreground "midnight blue" :weight bold :height 1.44))
+ (((class color) (background dark)) (:foreground "pale turquoise" :weight bold :height 1.44))
+ (t (:weight bold :height 1.44)))
+ "Face for document title, i.e. that which follows the #+TITLE: keyword."
+ :group 'org-faces)
+
+(defface org-document-info
+ '((((class color) (background light)) (:foreground "midnight blue"))
+ (((class color) (background dark)) (:foreground "pale turquoise"))
+ (t nil))
+ "Face for document date, author and email; i.e. that which
+follows a #+DATE:, #+AUTHOR: or #+EMAIL: keyword."
+ :group 'org-faces)
+
+(defface org-document-info-keyword
+ (org-compatible-face 'shadow
+ '((((class color grayscale) (min-colors 88) (background light))
+ (:foreground "grey50"))
+ (((class color grayscale) (min-colors 88) (background dark))
+ (:foreground "grey70"))
+ (((class color) (min-colors 8) (background light))
+ (:foreground "green"))
+ (((class color) (min-colors 8) (background dark))
+ (:foreground "yellow"))))
+ "Face for #+TITLE:, #+AUTHOR:, #+EMAIL: and #+DATE: keywords."
+ :group 'org-faces)
+
(defface org-block
(org-compatible-face 'shadow
'((((class color grayscale) (min-colors 88) (background light))
@@ -474,6 +529,13 @@ changes."
(org-copy-face 'org-block 'org-verse
"Face for #+BEGIN_VERSE ... #+END_VERSE blocks.")
+(defcustom org-fontify-quote-and-verse-blocks nil
+ "Non-nil means, add a special face to #+begin_quote and #+begin_verse block.
+When nil, format these as normal Org. This is the default, because the
+content of these blocks will still be treated as Org syntax."
+ :group 'org-faces
+ :type 'boolean)
+
(defface org-clock-overlay ;; copied from secondary-selection
(org-compatible-face nil
'((((class color) (min-colors 88) (background light))
@@ -502,17 +564,17 @@ changes."
:group 'org-faces)
(org-copy-face 'org-agenda-structure 'org-agenda-date
- "Face used in agenda for normal days.")
+ "Face used in agenda for normal days.")
(org-copy-face 'org-agenda-date 'org-agenda-date-today
- "Face used in agenda for today."
- :weight 'bold :italic 't)
+ "Face used in agenda for today."
+ :weight 'bold :italic 't)
(org-copy-face 'secondary-selection 'org-agenda-clocking
- "Face marking the current clock item in the agenda.")
+ "Face marking the current clock item in the agenda.")
(org-copy-face 'org-agenda-date 'org-agenda-date-weekend
- "Face used in agenda for weekend days.
+ "Face used in agenda for weekend days.
See the variable `org-agenda-weekend-days' for a definition of which days
belong to the weekend."
:weight 'bold)
@@ -538,7 +600,7 @@ belong to the weekend."
(defface org-agenda-dimmed-todo-face
'((((background light)) (:foreground "grey50"))
(((background dark)) (:foreground "grey50")))
- "Face used to dimm blocked tasks in the agenda."
+ "Face used to dim blocked tasks in the agenda."
:group 'org-faces)
(defface org-scheduled-previously
@@ -605,6 +667,12 @@ month and 365.24 days for a year)."
"Face used for time grids."
:group 'org-faces)
+(defface org-agenda-diary
+ (org-compatible-face 'default
+ nil)
+ "Face used for agenda entries that come from the Emacs diary."
+ :group 'org-faces)
+
(defconst org-level-faces
'(org-level-1 org-level-2 org-level-3 org-level-4
org-level-5 org-level-6 org-level-7 org-level-8
@@ -634,7 +702,10 @@ If it is less than 8, the level-1 face gets re-used for level N+1 etc."
:group 'org-faces)
(org-copy-face 'modeline 'org-mode-line-clock
- "Face used for clock display in mode line.")
+ "Face used for clock display in mode line.")
+(org-copy-face 'modeline 'org-mode-line-clock-overrun
+ "Face used for clock display for overrun tasks in mode line."
+ :background "red")
(provide 'org-faces)
diff --git a/lisp/org/org-feed.el b/lisp/org/org-feed.el
index df1e187e40d..8bda3098e0a 100644
--- a/lisp/org/org-feed.el
+++ b/lisp/org/org-feed.el
@@ -5,7 +5,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -45,7 +45,7 @@
;; With this setup, the command `M-x org-feed-update-all' will
;; collect new entries in the feed at the given URL and create
;; entries as subheadings under the "ReQall Entries" heading in the
-;; file "~/org-feeds.org". Each feed should normally have its own
+;; file "~/org/feeds.org". Each feed should normally have its own
;; heading - however see the `:drawer' parameter.
;;
;; Besides these standard elements that need to be specified for each
@@ -83,8 +83,8 @@
;;
;; #+DRAWERS: PROPERTIES LOGBOOK FEEDSTATUS
;;
-;; Acknowledgements
-;; ----------------
+;; Acknowledgments
+;; ---------------
;;
;; org-feed.el is based on ideas by Brad Bozarth who implemented a
;; similar mechanism using shell and awk scripts.
@@ -99,10 +99,11 @@
(declare-function xml-get-children "xml" (node child-name))
(declare-function xml-get-attribute "xml" (node attribute))
(declare-function xml-get-attribute-or-nil "xml" (node attribute))
+(declare-function xml-substitute-special "xml" (string))
(defgroup org-feed nil
"Options concerning RSS feeds as inputs for Org files."
- :tag "Org ID"
+ :tag "Org Feed"
:group 'org)
(defcustom org-feed-alist nil
@@ -165,10 +166,11 @@ Here are the keyword-value pair allows in `org-feed-alist'.
When the handler is called, point will be at the feed headline.
:parse-feed function
- This function gets passed a buffer, and should return a list of entries,
- each being a property list containing the `:guid' and `:item-full-text'
- keys. The default is `org-feed-parse-rss-feed'; `org-feed-parse-atom-feed'
- is an alternative.
+ This function gets passed a buffer, and should return a list
+ of entries, each being a property list containing the
+ `:guid' and `:item-full-text' keys. The default is
+ `org-feed-parse-rss-feed'; `org-feed-parse-atom-feed' is an
+ alternative.
:parse-entry function
This function gets passed an entry as returned by the parse-feed
@@ -199,12 +201,12 @@ Here are the keyword-value pair allows in `org-feed-alist'.
(list :inline t :tag "Changed items"
(const :changed-handler)
(symbol :tag "Handler Function"))
- (list :inline t :tag "Parse Feed"
- (const :parse-feed)
- (symbol :tag "Parse Feed Function"))
- (list :inline t :tag "Parse Entry"
- (const :parse-entry)
- (symbol :tag "Parse Entry Function"))
+ (list :inline t :tag "Parse Feed"
+ (const :parse-feed)
+ (symbol :tag "Parse Feed Function"))
+ (list :inline t :tag "Parse Entry"
+ (const :parse-entry)
+ (symbol :tag "Parse Entry Function"))
)))))
(defcustom org-feed-drawer "FEEDSTATUS"
@@ -234,7 +236,7 @@ following special escapes are valid as well:
:type '(string :tag "Template"))
(defcustom org-feed-save-after-adding t
- "Non-nil means, save buffer after adding new feed items."
+ "Non-nil means save buffer after adding new feed items."
:group 'org-feed
:type 'boolean)
@@ -302,10 +304,10 @@ it can be a list structured like an entry in `org-feed-alist'."
org-feed-default-template))
(drawer (or (nth 1 (memq :drawer feed))
org-feed-drawer))
- (parse-feed (or (nth 1 (memq :parse-feed feed))
- 'org-feed-parse-rss-feed))
- (parse-entry (or (nth 1 (memq :parse-entry feed))
- 'org-feed-parse-rss-entry))
+ (parse-feed (or (nth 1 (memq :parse-feed feed))
+ 'org-feed-parse-rss-feed))
+ (parse-entry (or (nth 1 (memq :parse-entry feed))
+ 'org-feed-parse-rss-entry))
feed-buffer inbox-pos new-formatted
entries old-status status new changed guid-alist e guid olds)
(setq feed-buffer (org-feed-get-feed url))
@@ -321,10 +323,11 @@ it can be a list structured like an entry in `org-feed-alist'."
(setq old-status (org-feed-read-previous-status inbox-pos drawer))
;; Add the "handled" status to the appropriate entries
(setq entries (mapcar (lambda (e)
- (setq e (plist-put e :handled
- (nth 1 (assoc
- (plist-get e :guid)
- old-status)))))
+ (setq e
+ (plist-put e :handled
+ (nth 1 (assoc
+ (plist-get e :guid)
+ old-status)))))
entries))
;; Find out which entries are new and which are changed
(dolist (e entries)
@@ -539,7 +542,8 @@ If that property is already present, nothing changes."
(setq tmp (org-feed-make-indented-block
tmp (org-get-indentation))))))
(replace-match tmp t t))))
- (buffer-string)))))
+ (decode-coding-string
+ (buffer-string) (detect-coding-region (point-min) (point-max) t))))))
(defun org-feed-make-indented-block (s n)
"Add indentation of N spaces to a multiline string S."
@@ -579,11 +583,12 @@ Assumes headers are indeed present!"
"Parse BUFFER for RSS feed entries.
Returns a list of entries, with each entry a property list,
containing the properties `:guid' and `:item-full-text'."
- (let (entries beg end item guid entry)
+ (let ((case-fold-search t)
+ entries beg end item guid entry)
(with-current-buffer buffer
(widen)
(goto-char (point-min))
- (while (re-search-forward "<item>" nil t)
+ (while (re-search-forward "<item\\>.*?>" nil t)
(setq beg (point)
end (and (re-search-forward "</item>" nil t)
(match-beginning 0)))
@@ -598,6 +603,7 @@ containing the properties `:guid' and `:item-full-text'."
(defun org-feed-parse-rss-entry (entry)
"Parse the `:item-full-text' field for xml tags and create new properties."
+ (require 'xml)
(with-temp-buffer
(insert (plist-get entry :item-full-text))
(goto-char (point-min))
@@ -605,7 +611,7 @@ containing the properties `:guid' and `:item-full-text'."
nil t)
(setq entry (plist-put entry
(intern (concat ":" (match-string 1)))
- (match-string 2))))
+ (xml-substitute-special (match-string 2)))))
(goto-char (point-min))
(unless (re-search-forward "isPermaLink[ \t]*=[ \t]*\"false\"" nil t)
(setq entry (plist-put entry :guid-permalink t))))
@@ -618,14 +624,15 @@ containing the properties `:guid' and `:item-full-text'.
The `:item-full-text' property actually contains the sexp
formatted as a string, not the original XML data."
+ (require 'xml)
(with-current-buffer buffer
(widen)
(let ((feed (car (xml-parse-region (point-min) (point-max)))))
(mapcar
(lambda (entry)
- (list
- :guid (car (xml-node-children (car (xml-get-children entry 'id))))
- :item-full-text (prin1-to-string entry)))
+ (list
+ :guid (car (xml-node-children (car (xml-get-children entry 'id))))
+ :item-full-text (prin1-to-string entry)))
(xml-get-children feed 'entry)))))
(defun org-feed-parse-atom-entry (entry)
@@ -633,28 +640,36 @@ formatted as a string, not the original XML data."
(let ((xml (car (read-from-string (plist-get entry :item-full-text)))))
;; Get first <link href='foo'/>.
(setq entry (plist-put entry :link
- (xml-get-attribute
- (car (xml-get-children xml 'link))
- 'href)))
+ (xml-get-attribute
+ (car (xml-get-children xml 'link))
+ 'href)))
;; Add <title/> as :title.
(setq entry (plist-put entry :title
- (car (xml-node-children
- (car (xml-get-children xml 'title))))))
+ (xml-substitute-special
+ (car (xml-node-children
+ (car (xml-get-children xml 'title)))))))
(let* ((content (car (xml-get-children xml 'content)))
- (type (xml-get-attribute-or-nil content 'type)))
+ (type (xml-get-attribute-or-nil content 'type)))
(when content
- (cond
- ((string= type "text")
- ;; We like plain text.
- (setq entry (plist-put entry :description (car (xml-node-children content)))))
- ((string= type "html")
- ;; TODO: convert HTML to Org markup.
- (setq entry (plist-put entry :description (car (xml-node-children content)))))
- ((string= type "xhtml")
- ;; TODO: convert XHTML to Org markup.
- (setq entry (plist-put entry :description (prin1-to-string (xml-node-children content)))))
- (t
- (setq entry (plist-put entry :description (format "Unknown '%s' content." type)))))))
+ (cond
+ ((string= type "text")
+ ;; We like plain text.
+ (setq entry (plist-put entry :description
+ (xml-substitute-special
+ (car (xml-node-children content))))))
+ ((string= type "html")
+ ;; TODO: convert HTML to Org markup.
+ (setq entry (plist-put entry :description
+ (xml-substitute-special
+ (car (xml-node-children content))))))
+ ((string= type "xhtml")
+ ;; TODO: convert XHTML to Org markup.
+ (setq entry (plist-put entry :description
+ (prin1-to-string
+ (xml-node-children content)))))
+ (t
+ (setq entry (plist-put entry :description
+ (format "Unknown '%s' content." type)))))))
entry))
(provide 'org-feed)
diff --git a/lisp/org/org-footnote.el b/lisp/org/org-footnote.el
index 5731daa066e..2a97b54db6f 100644
--- a/lisp/org/org-footnote.el
+++ b/lisp/org/org-footnote.el
@@ -5,7 +5,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -47,7 +47,9 @@
(declare-function org-back-to-heading "org" (&optional invisible-ok))
(declare-function org-end-of-subtree "org" (&optional invisible-ok to-heading))
(declare-function org-in-verbatim-emphasis "org" ())
+(declare-function org-inside-latex-macro-p "org" ())
(defvar org-odd-levels-only) ;; defined in org.el
+(defvar message-signature-separator) ;; defined in message.el
(defconst org-footnote-re
(concat "[^][\n]" ; to make sure it is not at the beginning of a line
@@ -64,6 +66,11 @@
(org-re "^\\(\\[\\([0-9]+\\|fn:[-_[:word:]]+\\)\\]\\)")
"Regular expression matching the definition of a footnote.")
+(defgroup org-footnote nil
+ "Footnotes in Org-mode."
+ :tag "Org Footnote"
+ :group 'org)
+
(defcustom org-footnote-section "Footnotes"
"Outline heading containing footnote definitions before export.
This can be nil, to place footnotes locally at the end of the current
@@ -74,7 +81,7 @@ automatically, i.e. when creating the footnote, and when sorting the notes.
However, by hand you may place definitions *anywhere*.
If this is a string, during export, all subtrees starting with this
heading will be removed after extracting footnote definitions."
- :group 'org-footnotes
+ :group 'org-footnote
:type '(choice
(string :tag "Collect footnotes under heading")
(const :tag "Define footnotes locally" nil)))
@@ -86,11 +93,11 @@ as in Org-mode. Outside Org-mode, new footnotes are always placed at
the end of the file. When you normalize the notes, any line containing
only this tag will be removed, a new one will be inserted at the end
of the file, followed by the collected and normalized footnotes."
- :group 'org-footnotes
+ :group 'org-footnote
:type 'string)
(defcustom org-footnote-define-inline nil
- "Non-nil means, define footnotes inline, at reference location.
+ "Non-nil means define footnotes inline, at reference location.
When nil, footnotes will be defined in a special section near
the end of the document. When t, the [fn:label:definition] notation
will be used to define the footnote at the reference position."
@@ -98,7 +105,7 @@ will be used to define the footnote at the reference position."
:type 'boolean)
(defcustom org-footnote-auto-label t
- "Non-nil means, define automatically new labels for footnotes.
+ "Non-nil means define automatically new labels for footnotes.
Possible values are:
nil prompt the user for each label
@@ -115,7 +122,7 @@ plain Automatically create plain number labels like [1]"
(const :tag "Create automatic [N]" plain)))
(defcustom org-footnote-auto-adjust nil
- "Non-nil means, automatically adjust footnotes after insert/delete.
+ "Non-nil means automatically adjust footnotes after insert/delete.
When this is t, after each insertion or deletion of a footnote,
simple fn:N footnotes will be renumbered, and all footnotes will be sorted.
If you want to have just sorting or just renumbering, set this variable
@@ -132,7 +139,7 @@ The main values of this variable can be set with in-buffer options:
(const :tag "Renumber and Sort" t)))
(defcustom org-footnote-fill-after-inline-note-extraction nil
- "Non-nil means, fill paragraphs after extracting footnotes.
+ "Non-nil means fill paragraphs after extracting footnotes.
When extracting inline footnotes, the lengths of lines can change a lot.
When this option is set, paragraphs from which an inline footnote has been
extracted will be filled again."
@@ -181,25 +188,25 @@ with start and label of the footnote if there is a definition at point."
(org-show-context 'link-search)
(message "Edit definition and go back with `C-c &' or, if unique, with `C-c C-c'."))))
-(defun org-footnote-goto-next-reference (label)
- "Find the definition of the footnote with label LABEL."
+(defun org-footnote-goto-previous-reference (label)
+ "Find the first closest (to point) reference of footnote with label LABEL."
(interactive "sLabel: ")
(org-mark-ring-push)
(setq label (org-footnote-normalize-label label))
(let ((re (format ".\\[%s[]:]" label))
(p0 (point)) pos)
(save-excursion
- (setq pos (or (re-search-forward re nil t)
- (and (goto-char (point-min))
- (re-search-forward re nil t))
+ (setq pos (or (re-search-backward re nil t)
+ (and (goto-char (point-max))
+ (re-search-backward re nil t))
(and (progn (widen) t)
(goto-char p0)
- (re-search-forward re nil t))
- (and (goto-char (point-min))
+ (re-search-backward re nil t))
+ (and (goto-char (point-max))
(re-search-forward re nil t)))))
(if pos
(progn
- (goto-char pos)
+ (goto-char (match-end 0))
(org-show-context 'link-search))
(error "Cannot find reference of footnote %s" label))))
@@ -296,15 +303,19 @@ or new, let the user edit the definition of the footnote."
(t
(setq re (concat "^" org-footnote-tag-for-non-org-mode-files "[ \t]*$"))
(unless (re-search-forward re nil t)
- (goto-char (point-max))
- (skip-chars-backward " \t\r\n")
- (insert "\n\n")
- (delete-region (point) (point-max))
- (insert org-footnote-tag-for-non-org-mode-files "\n"))
- (goto-char (point-max))
- (skip-chars-backward " \t\r\n")))
- (insert "\n\n")
- (insert "[" label "] ")
+ (let ((max (if (and (eq major-mode 'message-mode)
+ (re-search-forward message-signature-separator nil t))
+ (progn (beginning-of-line) (point))
+ (goto-char (point-max)))))
+ (skip-chars-backward " \t\r\n")
+ (delete-region (point) max)
+ (insert "\n\n")
+ (insert org-footnote-tag-for-non-org-mode-files "\n")))))
+ ;; Skip existing footnotes
+ (while (re-search-forward "^[[:space:]]*\\[[^]]+\\] " nil t)
+ (forward-line))
+ (insert "[" label "] \n")
+ (goto-char (1- (point)))
(message "Edit definition and go back with `C-c &' or, if unique, with `C-c C-c'.")))
;;;###autoload
@@ -338,7 +349,7 @@ With prefix arg SPECIAL, offer additional commands in a menu."
(org-footnote-goto-definition (nth 1 tmp))
(goto-char (match-beginning 4))))
((setq tmp (org-footnote-at-definition-p))
- (org-footnote-goto-next-reference (nth 1 tmp)))
+ (org-footnote-goto-previous-reference (nth 1 tmp)))
(t (org-footnote-new)))))
;;;###autoload
@@ -366,7 +377,8 @@ referenced sequence."
;; Now find footnote references, and extract the definitions
(goto-char (point-min))
(while (re-search-forward org-footnote-re nil t)
- (unless (or (org-in-commented-line) (org-in-verbatim-emphasis))
+ (unless (or (org-in-commented-line) (org-in-verbatim-emphasis)
+ (org-inside-latex-macro-p))
(org-if-unprotected
(setq def (match-string 4)
idef def
@@ -397,13 +409,13 @@ referenced sequence."
(skip-chars-backward " \t\n\t")
(delete-region (1+ (point)) (match-beginning 0))))))
(unless sort-only
- (replace-match (concat before "[" marker "]"))
+ (replace-match (concat before "[" marker "]") t t)
(and idef
org-footnote-fill-after-inline-note-extraction
(fill-paragraph)))
(if (not a) (push (list ref marker def (if idef t nil))
ref-table)))))
-
+
;; First find and remove the footnote section
(goto-char (point-min))
(cond
@@ -499,7 +511,8 @@ ENTRY is (fn-label num-mark definition)."
(beginning-of-line 0))
(if (looking-at "[ \t]*#\\+TBLFM:") (beginning-of-line 2))
(end-of-line 1)
- (skip-chars-backward "\n\r\t "))
+ (skip-chars-backward "\n\r\t ")
+ (forward-line))
(defun org-footnote-delete (&optional label)
"Delete the footnote at point.
diff --git a/lisp/org/org-freemind.el b/lisp/org/org-freemind.el
index ce923502ae9..736cc577ce7 100644
--- a/lisp/org/org-freemind.el
+++ b/lisp/org/org-freemind.el
@@ -5,7 +5,7 @@
;; Author: Lennart Borgman (lennart O borgman A gmail O com)
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -81,30 +81,35 @@
(require 'xml)
(require 'org)
+;(require 'rx)
(require 'org-exp)
(eval-when-compile (require 'cl))
+(defgroup org-freemind nil
+ "Customization group for org-freemind export/import."
+ :group 'org)
+
;; Fix-me: I am not sure these are useful:
;;
;; (defcustom org-freemind-main-fgcolor "black"
;; "Color of main node's text."
;; :type 'color
-;; :group 'freemind)
+;; :group 'org-freemind)
;; (defcustom org-freemind-main-color "black"
;; "Background color of main node."
;; :type 'color
-;; :group 'freemind)
+;; :group 'org-freemind)
;; (defcustom org-freemind-child-fgcolor "black"
;; "Color of child nodes' text."
;; :type 'color
-;; :group 'freemind)
+;; :group 'org-freemind)
;; (defcustom org-freemind-child-color "black"
;; "Background color of child nodes."
;; :type 'color
-;; :group 'freemind)
+;; :group 'org-freemind)
(defvar org-freemind-node-style nil "Internal use.")
@@ -151,11 +156,25 @@ NOT READY YET."
(string :tag "Font name" :value "SansSerif"))
(list :format "%v" (const :format "" font-size)
(integer :tag "Font size" :value 12)))))))
- :group 'freemind)
+ :group 'org-freemind)
;;;###autoload
-(defun org-export-as-freemind (arg &optional hidden ext-plist
+(defun org-export-as-freemind (&optional hidden ext-plist
to-buffer body-only pub-dir)
+ "Export the current buffer as a Freemind file.
+If there is an active region, export only the region. HIDDEN is
+obsolete and does nothing. EXT-PLIST is a property list with
+external parameters overriding org-mode's default settings, but
+still inferior to file-local settings. When TO-BUFFER is
+non-nil, create a buffer with that name and export to that
+buffer. If TO-BUFFER is the symbol `string', don't leave any
+buffer behind but just return the resulting HTML as a string.
+When BODY-ONLY is set, don't produce the file header and footer,
+simply return the content of the document (all top level
+sections). When PUB-DIR is set, use this as the publishing
+directory.
+
+See `org-freemind-from-org-mode' for more information."
(interactive "P")
(let* ((opt-plist (org-combine-plists (org-default-export-plist)
ext-plist
@@ -202,7 +221,20 @@ NOT READY YET."
(let ((name (read-file-name "FreeMind file: "
nil nil nil
(if (buffer-file-name)
- (file-name-nondirectory (buffer-file-name))
+ (let* ((name-ext (file-name-nondirectory (buffer-file-name)))
+ (name (file-name-sans-extension name-ext))
+ (ext (file-name-extension name-ext)))
+ (cond
+ ((string= "mm" ext)
+ name-ext)
+ ((string= "org" ext)
+ (let ((name-mm (concat name ".mm")))
+ (if (file-exists-p name-mm)
+ name-mm
+ (message "Not exported to Freemind format yet")
+ "")))
+ (t
+ "")))
"")
;; Fix-me: Is this an Emacs bug?
;; This predicate function is never
@@ -226,7 +258,7 @@ The characters \"&<> will be escaped."
(dolist (cc chars)
(setq fm-str
(concat fm-str
- (if (< cc 256)
+ (if (< cc 160)
(cond
((= cc ?\") "&quot;")
((= cc ?\&) "&amp;")
@@ -240,7 +272,7 @@ The characters \"&<> will be escaped."
;; file is utf-8:
;;
;; (format "&#x%x;" (- cc ;; ?\x800))
- (format "&#x%x" (encode-char cc 'ucs))
+ (format "&#x%x;" (encode-char cc 'ucs))
))))
fm-str))
@@ -264,52 +296,84 @@ will also unescape &#nn;."
)))
org-str))))
-;; (org-freemind-test-escape)
-(defun org-freemind-test-escape ()
- (let* ((str1 "a quote: \", an amp: &, lt: <; over 256: ")
- (str2 (org-freemind-escape-str-from-org str1))
- (str3 (org-freemind-unescape-str-to-org str2))
+;; (let* ((str1 "a quote: \", an amp: &, lt: <; over 256: ")
+;; (str2 (org-freemind-escape-str-from-org str1))
+;; (str3 (org-freemind-unescape-str-to-org str2)))
+;; (unless (string= str1 str3)
+;; (error "Error str3=%s" str3)))
+
+(defun org-freemind-convert-links-helper (matched)
+ "Helper for `org-freemind-convert-links-from-org'.
+MATCHED is the link just matched."
+ (let* ((link (match-string 1 matched))
+ (text (match-string 2 matched))
+ (ext (file-name-extension link))
+ (col-pos (string-match-p ":" link))
+ (is-img (and (image-type-from-file-name link)
+ (let ((url-type (substring link 0 col-pos)))
+ (member url-type '("file" "http" "https")))))
)
- (unless (string= str1 str3)
- (error "str3=%s" str3))
- ))
+ (if is-img
+ ;; Fix-me: I can't find a way to get the border to "shrink
+ ;; wrap" around the image using <div>.
+ ;;
+ ;; (concat "<div style=\"border: solid 1px #ddd; width:auto;\">"
+ ;; "<img src=\"" link "\" alt=\"" text "\" />"
+ ;; "<br />"
+ ;; "<i>" text "</i>"
+ ;; "</div>")
+ (concat "<table border=\"0\" style=\"border: solid 1px #ddd;\"><tr><td>"
+ "<img src=\"" link "\" alt=\"" text "\" />"
+ "<br />"
+ "<i>" text "</i>"
+ "</td></tr></table>")
+ (concat "<a href=\"" link "\">" text "</a>"))))
(defun org-freemind-convert-links-from-org (org-str)
"Convert org links in ORG-STR to freemind links and return the result."
(let ((fm-str (replace-regexp-in-string
- (rx (not (any "[\""))
- (submatch
- "http"
- (opt ?\s)
- "://"
- (1+
- (any "-%.?@a-zA-Z0-9()_/:~=&#"))))
+ ;;(rx (not (any "[\""))
+ ;; (submatch
+ ;; "http"
+ ;; (opt ?\s)
+ ;; "://"
+ ;; (1+
+ ;; (any "-%.?@a-zA-Z0-9()_/:~=&#"))))
+ "[^\"[]\\(http ?://[--:#%&()=?-Z_a-z~]+\\)"
"[[\\1][\\1]]"
- org-str)))
- (replace-regexp-in-string (rx "[["
- (submatch (*? nonl))
- "]["
- (submatch (*? nonl))
- "]]")
- "<a href=\"\\1\">\\2</a>"
- fm-str)))
+ org-str
+ nil ;; fixedcase
+ nil ;; literal
+ 1 ;; subexp
+ )))
+ (replace-regexp-in-string
+ ;;(rx "[["
+ ;; (submatch (*? nonl))
+ ;; "]["
+ ;; (submatch (*? nonl))
+ ;; "]]")
+ "\\[\\[\\(.*?\\)]\\[\\(.*?\\)]]"
+ ;;"<a href=\"\\1\">\\2</a>"
+ 'org-freemind-convert-links-helper
+ fm-str)))
;;(org-freemind-convert-links-to-org "<a href=\"http://www.somewhere/\">link-text</a>")
(defun org-freemind-convert-links-to-org (fm-str)
"Convert freemind links in FM-STR to org links and return the result."
(let ((org-str (replace-regexp-in-string
- (rx "<a"
- space
- (0+
- (0+ (not (any ">")))
- space)
- "href=\""
- (submatch (0+ (not (any "\""))))
- "\""
- (0+ (not (any ">")))
- ">"
- (submatch (0+ (not (any "<"))))
- "</a>")
+ ;;(rx "<a"
+ ;; space
+ ;; (0+
+ ;; (0+ (not (any ">")))
+ ;; space)
+ ;; "href=\""
+ ;; (submatch (0+ (not (any "\""))))
+ ;; "\""
+ ;; (0+ (not (any ">")))
+ ;; ">"
+ ;; (submatch (0+ (not (any "<"))))
+ ;; "</a>")
+ "<a[[:space:]]\\(?:[^>]*[[:space:]]\\)*href=\"\\([^\"]*\\)\"[^>]*>\\([^<]*\\)</a>"
"[[\\1][\\2]]"
fm-str)))
org-str))
@@ -318,29 +382,60 @@ will also unescape &#nn;."
;;(defun org-freemind-convert-drawers-from-org (text)
;; )
-;; (org-freemind-test-links)
-;; (defun org-freemind-test-links ()
;; (let* ((str1 "[[http://www.somewhere/][link-text]")
;; (str2 (org-freemind-convert-links-from-org str1))
-;; (str3 (org-freemind-convert-links-to-org str2))
-;; )
+;; (str3 (org-freemind-convert-links-to-org str2)))
;; (unless (string= str1 str3)
-;; (error "str3=%s" str3))
-;; ))
+;; (error "Error str3=%s" str3)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Org => FreeMind
+(defvar org-freemind-bol-helper-base-indent nil)
+
+(defun org-freemind-bol-helper (matched)
+ "Helper for `org-freemind-convert-text-p'.
+MATCHED is the link just matched."
+ (let ((res "")
+ (bi org-freemind-bol-helper-base-indent))
+ (dolist (cc (append matched nil))
+ (if (= 32 cc)
+ ;;(setq res (concat res "&nbsp;"))
+ ;; We need to use the numerical version. Otherwise Freemind
+ ;; ver 0.9.0 RC9 can not export to html/javascript.
+ (progn
+ (if (< 0 bi)
+ (setq bi (1- bi))
+ (setq res (concat res "&#160;"))))
+ (setq res (concat res (char-to-string cc)))))
+ res))
+;; (setq x (replace-regexp-in-string "\n +" 'org-freemind-bol-nbsp-helper "\n "))
+
(defun org-freemind-convert-text-p (text)
"Convert TEXT to html with <p> paragraphs."
+ ;; (string-match-p "[^ ]" " a")
+ (setq org-freemind-bol-helper-base-indent (string-match-p "[^ ]" text))
(setq text (org-freemind-escape-str-from-org text))
- (setq text (replace-regexp-in-string (rx "\n" (0+ blank) "\n") "</p><p>\n" text))
- ;;(setq text (replace-regexp-in-string (rx bol (1+ blank) eol) "" text))
- ;;(setq text (replace-regexp-in-string (rx bol (1+ blank)) "<br />" text))
+
+ (setq text (replace-regexp-in-string "\\([[:space:]]\\)\\(/\\)\\([^/]+\\)\\(/\\)\\([[:space:]]\\)" "\\1<i>\\3</i>\\5" text))
+ (setq text (replace-regexp-in-string "\\([[:space:]]\\)\\(\*\\)\\([^*]+\\)\\(\*\\)\\([[:space:]]\\)" "\\1<b>\\3</b>\\5" text))
+
+ (setq text (concat "<p>" text))
+ (setq text (replace-regexp-in-string "\n[[:blank:]]*\n" "</p><p>" text))
+ (setq text (replace-regexp-in-string "\\(?:<p>\\|\n\\) +" 'org-freemind-bol-helper text))
(setq text (replace-regexp-in-string "\n" "<br />" text))
- (concat "<p>"
- (org-freemind-convert-links-from-org text)
- "</p>\n"))
+ (setq text (concat text "</p>"))
+
+ (org-freemind-convert-links-from-org text))
+
+(defcustom org-freemind-node-css-style
+ "p { margin-top: 3px; margin-bottom: 3px; }"
+ "CSS style for Freemind nodes."
+ ;; Fix-me: I do not understand this. It worked to export from Freemind
+ ;; with this setting now, but not before??? Was this perhaps a java
+ ;; bug or is it a windows xp bug (some resource gets exhausted if you
+ ;; use sticky keys which I do).
+ :group 'org-freemind)
(defun org-freemind-org-text-to-freemind-subnode/note (node-name start end drawers-regexp)
"Convert text part of org node to freemind subnode or note.
@@ -389,11 +484,14 @@ DRAWERS-REGEXP are converted to freemind notes."
"<node style=\"bubble\" background_color=\"#eeee00\">\n"
"<richcontent TYPE=\"NODE\"><html>\n"
"<head>\n"
+ (if (= 0 (length org-freemind-node-css-style))
+ ""
+ (concat
"<style type=\"text/css\">\n"
"<!--\n"
- "p { margin-top: 0 }\n"
+ org-freemind-node-css-style
"-->\n"
- "</style>\n"
+ "</style>\n"))
"</head>\n"
"<body>\n"))
(let ((begin-html-mark (regexp-quote "#+BEGIN_HTML"))
@@ -426,21 +524,28 @@ DRAWERS-REGEXP are converted to freemind notes."
"</html>\n"
"</richcontent>\n"
;; Put a note that this is for the parent node
- "<richcontent TYPE=\"NOTE\"><html>"
- "<head>"
- "</head>"
- "<body>"
- "<p>"
- "-- This is more about \"" node-name "\" --"
- "</p>"
- "</body>"
- "</html>"
- "</richcontent>\n"
+ ;; "<richcontent TYPE=\"NOTE\"><html>"
+ ;; "<head>"
+ ;; "</head>"
+ ;; "<body>"
+ ;; "<p>"
+ ;; "-- This is more about \"" node-name "\" --"
+ ;; "</p>"
+ ;; "</body>"
+ ;; "</html>"
+ ;; "</richcontent>\n"
+ note-res
"</node>\n" ;; ok
)))
(list node-res note-res))))
-(defun org-freemind-write-node (mm-buffer drawers-regexp num-left-nodes base-level current-level next-level this-m2 this-node-end this-children-visible next-node-start next-has-some-visible-child)
+(defun org-freemind-write-node (mm-buffer drawers-regexp
+ num-left-nodes base-level
+ current-level next-level this-m2
+ this-node-end
+ this-children-visible
+ next-node-start
+ next-has-some-visible-child)
(let* (this-icons
this-bg-color
this-m2-escaped
@@ -502,7 +607,7 @@ DRAWERS-REGEXP are converted to freemind notes."
(insert "<icon builtin=\"" icon "\"/>\n")))
)
(with-current-buffer mm-buffer
- (when this-rich-note (insert this-rich-note))
+ ;;(when this-rich-note (insert this-rich-note))
(when this-rich-node (insert this-rich-node))))
num-left-nodes)
@@ -520,11 +625,13 @@ Otherwise give an error say the file exists."
(error "File %s already exists" file))
t))
-(defvar org-freemind-node-pattern (rx bol
- (submatch (1+ "*"))
- (1+ space)
- (submatch (*? nonl))
- eol))
+(defvar org-freemind-node-pattern
+ ;;(rx bol
+ ;; (submatch (1+ "*"))
+ ;; (1+ space)
+ ;; (submatch (*? nonl))
+ ;; eol)
+ "^\\(\\*+\\)[[:space:]]+\\(.*?\\)$")
(defun org-freemind-look-for-visible-child (node-level)
(save-excursion
@@ -561,11 +668,10 @@ Otherwise give an error say the file exists."
(num-top2-nodes 0)
num-left-nodes
(unclosed-nodes 0)
+ (odd-only org-odd-levels-only)
(first-time t)
(current-level 1)
base-level
- skipping-odd
- (skipped-odd 0)
prev-node-end
rich-text
unfinished-tag
@@ -573,27 +679,31 @@ Otherwise give an error say the file exists."
node-at-line-last)
(with-current-buffer mm-buffer
(erase-buffer)
- (insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n")
+ (setq buffer-file-coding-system 'utf-8)
+ ;; Fix-me: Currentl Freemind (ver 0.9.0 RC9) does not support this:
+ ;;(insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n")
(insert "<map version=\"0.9.0\">\n")
(insert "<!-- To view this file, download free mind mapping software FreeMind from http://freemind.sourceforge.net -->\n"))
(save-excursion
;; Get special buffer vars:
(goto-char (point-min))
- (while (re-search-forward (rx bol "#+DRAWERS:") nil t)
+ (message "Writing Freemind file...")
+ (while (re-search-forward "^#\\+DRAWERS:" nil t)
(let ((dr-txt (buffer-substring-no-properties (match-end 0) (line-end-position))))
(setq drawers (append drawers (split-string dr-txt) nil))))
(setq drawers-regexp
- (concat (rx bol (0+ blank) ":")
+ (concat "^[[:blank:]]*:"
(regexp-opt drawers)
- (rx ":" (0+ blank)
- "\n"
- (*? anything)
- "\n"
- (0+ blank)
- ":END:"
- (0+ blank)
- eol)
- ))
+ ;;(rx ":" (0+ blank)
+ ;; "\n"
+ ;; (*? anything)
+ ;; "\n"
+ ;; (0+ blank)
+ ;; ":END:"
+ ;; (0+ blank)
+ ;; eol)
+ ":[[:blank:]]*\n\\(?:.\\|\n\\)*?\n[[:blank:]]*:END:[[:blank:]]*$"
+ ))
(if node-at-line
;; Get number of top nodes and last line for this node
@@ -671,21 +781,6 @@ Otherwise give an error say the file exists."
(setq next-node-start (match-beginning 0))
(setq next-m2 (match-string-no-properties 2))
(setq next-level (length next-m1))
- (when (> next-level current-level)
- (if (not (and org-odd-levels-only
- (/= (mod current-level 2) 0)
- (= next-level (+ 2 current-level))))
- (setq skipping-odd nil)
- (setq skipping-odd t)
- (setq skipped-odd (1+ skipped-odd)))
- (unless (or (= next-level (1+ current-level))
- skipping-odd)
- (if (or org-odd-levels-only
- (/= next-level (+ 2 current-level)))
- (error "Next level step > +1 for node ending at line %s" (line-number-at-pos))
- (error "Next level step = +2 for node ending at line %s, forgot org-odd-levels-only?"
- (line-number-at-pos)))
- ))
(setq next-children-visible
(not (eq 'outline
(get-char-property (line-end-position) 'invisible))))
@@ -698,11 +793,8 @@ Otherwise give an error say the file exists."
(while (>= current-level next-level)
(with-current-buffer mm-buffer
(insert "</node>\n")
- (setq current-level (1- current-level))
- (when (< 0 skipped-odd)
- (setq skipped-odd (1- skipped-odd))
- (setq current-level (1- current-level)))
- )))
+ (setq current-level
+ (- current-level (if odd-only 2 1))))))
(setq this-node-end (1+ next-node-end))
(setq this-m2 next-m2)
(setq current-level next-level)
@@ -725,7 +817,8 @@ Otherwise give an error say the file exists."
(with-current-buffer mm-buffer
(while (> current-level base-level)
(insert "</node>\n")
- (setq current-level (1- current-level))
+ (setq current-level
+ (- current-level (if odd-only 2 1)))
))
(with-current-buffer mm-buffer
(insert "</map>")
@@ -812,7 +905,8 @@ Otherwise give an error say the file exists."
;;;###autoload
(defun org-freemind-from-org-mode-node (node-line mm-file)
- "Convert node at line NODE-LINE to the FreeMind file MM-FILE."
+ "Convert node at line NODE-LINE to the FreeMind file MM-FILE.
+See `org-freemind-from-org-mode' for more information."
(interactive
(progn
(unless (org-back-to-heading nil)
@@ -825,20 +919,29 @@ Otherwise give an error say the file exists."
".mm"))
(mm-file (read-file-name "Output FreeMind file: " nil nil nil default-mm-file)))
(list line mm-file))))
- (when (org-freemind-check-overwrite mm-file (called-interactively-p 'any))
+ (when (org-freemind-check-overwrite mm-file (org-called-interactively-p 'any))
(let ((org-buffer (current-buffer))
(mm-buffer (find-file-noselect mm-file)))
(org-freemind-write-mm-buffer org-buffer mm-buffer node-line)
(with-current-buffer mm-buffer
(basic-save-buffer)
- (when (called-interactively-p 'any)
+ (when (org-called-interactively-p 'any)
(switch-to-buffer-other-window mm-buffer)
(when (y-or-n-p "Show in FreeMind? ")
(org-freemind-show buffer-file-name)))))))
;;;###autoload
(defun org-freemind-from-org-mode (org-file mm-file)
- "Convert the `org-mode' file ORG-FILE to the FreeMind file MM-FILE."
+ "Convert the `org-mode' file ORG-FILE to the FreeMind file MM-FILE.
+All the nodes will be opened or closed in Freemind just as you
+have them in `org-mode'.
+
+Note that exporting to Freemind also gives you an alternative way
+to export from `org-mode' to html. You can create a dynamic html
+version of the your org file, by first exporting to Freemind and
+then exporting from Freemind to html. The 'As
+XHTML (JavaScript)' version in Freemind works very well \(and you
+can use a CSS stylesheet to style it)."
;; Fix-me: better doc, include recommendations etc.
(interactive
(let* ((org-file buffer-file-name)
@@ -849,13 +952,13 @@ Otherwise give an error say the file exists."
".mm"))
(mm-file (read-file-name "Output FreeMind file: " nil nil nil default-mm-file)))
(list org-file mm-file)))
- (when (org-freemind-check-overwrite mm-file (called-interactively-p 'any))
+ (when (org-freemind-check-overwrite mm-file (org-called-interactively-p 'any))
(let ((org-buffer (if org-file (find-file-noselect org-file) (current-buffer)))
(mm-buffer (find-file-noselect mm-file)))
(org-freemind-write-mm-buffer org-buffer mm-buffer nil)
(with-current-buffer mm-buffer
(basic-save-buffer)
- (when (called-interactively-p 'any)
+ (when (org-called-interactively-p 'any)
(switch-to-buffer-other-window mm-buffer)
(when (y-or-n-p "Show in FreeMind? ")
(org-freemind-show buffer-file-name)))))))
@@ -872,7 +975,7 @@ Otherwise give an error say the file exists."
"-sparse.mm"))
(mm-file (read-file-name "Output FreeMind file: " nil nil nil default-mm-file)))
(list (current-buffer) mm-file)))
- (when (org-freemind-check-overwrite mm-file (called-interactively-p 'any))
+ (when (org-freemind-check-overwrite mm-file (org-called-interactively-p 'any))
(let (org-buffer
(mm-buffer (find-file-noselect mm-file)))
(save-window-excursion
@@ -881,7 +984,7 @@ Otherwise give an error say the file exists."
(org-freemind-write-mm-buffer org-buffer mm-buffer nil)
(with-current-buffer mm-buffer
(basic-save-buffer)
- (when (called-interactively-p 'any)
+ (when (org-called-interactively-p 'any)
(switch-to-buffer-other-window mm-buffer)
(when (y-or-n-p "Show in FreeMind? ")
(org-freemind-show buffer-file-name)))))))
@@ -1036,7 +1139,7 @@ PATH should be a list of steps, where each step has the form
(save-match-data
(let* ((rc (org-freemind-get-richcontent-node node))
(txt (org-freemind-get-tree-text rc)))
- ;;(when txt (setq txt (replace-regexp-in-string (rx (1+ whitespace)) " " txt)))
+ ;;(when txt (setq txt (replace-regexp-in-string "[[:space:]]+" " " txt)))
txt
)))
@@ -1045,7 +1148,7 @@ PATH should be a list of steps, where each step has the form
(save-match-data
(let* ((rc (org-freemind-get-richcontent-note node))
(txt (when rc (org-freemind-get-tree-text rc))))
- ;;(when txt (setq txt (replace-regexp-in-string (rx (1+ whitespace)) " " txt)))
+ ;;(when txt (setq txt (replace-regexp-in-string "[[:space:]]+" " " txt)))
txt
)))
@@ -1061,6 +1164,7 @@ PATH should be a list of steps, where each step has the form
(let ((qname (car node))
(attributes (cadr node))
text
+ ;; Fix-me: note is never inserted
(note (org-freemind-get-richcontent-note-text node))
(mark "-- This is more about ")
(icons (org-freemind-get-icon-names node))
@@ -1091,6 +1195,8 @@ PATH should be a list of steps, where each step has the form
(case qname
('node
(insert (make-string (- level skip-levels) ?*) " " text "\n")
+ (when note
+ (insert ":COMMENT:\n" note "\n:END:\n"))
))))
(dolist (child children)
(unless (or (null child)
@@ -1108,7 +1214,7 @@ PATH should be a list of steps, where each step has the form
(default-org-file (concat (file-name-nondirectory mm-file) ".org"))
(org-file (read-file-name "Output org-mode file: " nil nil nil default-org-file)))
(list mm-file org-file))))
- (when (org-freemind-check-overwrite org-file (called-interactively-p 'any))
+ (when (org-freemind-check-overwrite org-file (org-called-interactively-p 'any))
(let ((mm-buffer (find-file-noselect mm-file))
(org-buffer (find-file-noselect org-file)))
(with-current-buffer mm-buffer
@@ -1117,7 +1223,7 @@ PATH should be a list of steps, where each step has the form
(note (org-freemind-get-richcontent-note-text top-node))
(skip-levels
(if (and note
- (string-match (rx bol "--org-mode: WHOLE FILE" eol) note))
+ (string-match "^--org-mode: WHOLE FILE$" note))
1
0)))
(with-current-buffer org-buffer
diff --git a/lisp/org/org-gnus.el b/lisp/org/org-gnus.el
index 0fc61963f77..6d782759a75 100644
--- a/lisp/org/org-gnus.el
+++ b/lisp/org/org-gnus.el
@@ -7,7 +7,7 @@
;; Tassilo Horn <tassilo at member dot fsf dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -39,22 +39,33 @@
;; Declare external functions and variables
(declare-function message-fetch-field "message" (header &optional not-all))
(declare-function message-narrow-to-head-1 "message" nil)
+(declare-function nnimap-group-overview-filename "nnimap" (group server))
;; The following line suppresses a compiler warning stemming from gnus-sum.el
(declare-function gnus-summary-last-subject "gnus-sum" nil)
-
;; Customization variables
(when (fboundp 'defvaralias)
(defvaralias 'org-usenet-links-prefer-google 'org-gnus-prefer-web-links))
(defcustom org-gnus-prefer-web-links nil
- "Non-nil means, `org-store-link' will create web links to Google groups.
+ "If non-nil, `org-store-link' creates web links to Google groups or Gmane.
When nil, Gnus will be used for such links.
Using a prefix arg to the command \\[org-store-link] (`org-store-link')
negates this setting for the duration of the command."
:group 'org-link-store
:type 'boolean)
+(defcustom org-gnus-nnimap-query-article-no-from-file nil
+ "If non-nil, `org-gnus-follow-link' will try to translate
+Message-Ids to article numbers by querying the .overview file.
+Normally, this translation is done by querying the IMAP server,
+which is usually very fast. Unfortunately, some (maybe badly
+configured) IMAP servers don't support this operation quickly.
+So if following a link to a Gnus article takes ages, try setting
+this variable to `t'."
+ :group 'org-link-store
+ :type 'boolean)
+
;; Install the link type
(org-add-link-type "gnus" 'org-gnus-open)
@@ -62,6 +73,22 @@ negates this setting for the duration of the command."
;; Implementation
+(defun org-gnus-nnimap-cached-article-number (group server message-id)
+ "Return cached article number (uid) of message in GROUP on SERVER.
+MESSAGE-ID is the message-id header field that identifies the
+message. If the uid is not cached, return nil."
+ (with-temp-buffer
+ (let ((nov (nnimap-group-overview-filename group server)))
+ (when (file-exists-p nov)
+ (mm-insert-file-contents nov)
+ (set-buffer-modified-p nil)
+ (goto-char (point-min))
+ (catch 'found
+ (while (search-forward message-id nil t)
+ (let ((hdr (split-string (thing-at-point 'line) "\t")))
+ (if (string= (nth 4 hdr) message-id)
+ (throw 'found (nth 0 hdr))))))))))
+
(defun org-gnus-group-link (group)
"Create a link to the Gnus group GROUP.
If GROUP is a newsgroup and `org-gnus-prefer-web-links' is
@@ -120,30 +147,52 @@ If `org-store-link' was called with a prefix arg the meaning of
((memq major-mode '(gnus-summary-mode gnus-article-mode))
(let* ((group gnus-newsgroup-name)
- (header (with-current-buffer gnus-summary-buffer
+ (header (with-current-buffer gnus-summary-buffer
(gnus-summary-article-header)))
(from (mail-header-from header))
(message-id (org-remove-angle-brackets (mail-header-id header)))
(date (mail-header-date header))
- (subject (mail-header-subject header))
- (to (cdr (assq 'To (mail-header-extra header))))
- newsgroups x-no-archive desc link)
+ (date-ts (and date (format-time-string
+ (org-time-stamp-format t) (date-to-time date))))
+ (date-ts-ia (and date (format-time-string
+ (org-time-stamp-format t t)
+ (date-to-time date))))
+ (subject (copy-sequence (mail-header-subject header)))
+ (to (cdr (assq 'To (mail-header-extra header))))
+ newsgroups x-no-archive desc link)
+ ;; Remove text properties of subject string to avoid Emacs bug
+ ;; #3506
+ (set-text-properties 0 (length subject) nil subject)
+
;; Fetching an article is an expensive operation; newsgroup and
;; x-no-archive are only needed for web links.
(when (org-xor current-prefix-arg org-gnus-prefer-web-links)
- ;; Make sure the original article buffer is up-to-date
- (save-window-excursion (gnus-summary-select-article))
- (setq to (or to (gnus-fetch-original-field "To"))
- newsgroups (gnus-fetch-original-field "Newsgroups")
- x-no-archive (gnus-fetch-original-field "x-no-archive")))
- (org-store-link-props :type "gnus" :from from :subject subject
+ ;; Make sure the original article buffer is up-to-date
+ (save-window-excursion (gnus-summary-select-article))
+ (setq to (or to (gnus-fetch-original-field "To"))
+ newsgroups (gnus-fetch-original-field "Newsgroups")
+ x-no-archive (gnus-fetch-original-field "x-no-archive")))
+ (org-store-link-props :type "gnus" :from from :subject subject
:message-id message-id :group group :to to)
+ (when date
+ (org-add-link-props :date date :date-timestamp date-ts
+ :date-timestamp-inactive date-ts-ia))
(setq desc (org-email-link-description)
link (org-gnus-article-link
group newsgroups message-id x-no-archive))
(org-add-link-props :link link :description desc)
link))))
+(defun org-gnus-open-nntp (path)
+ "Follow the nntp: link specified by PATH."
+ (let* ((spec (split-string path "/"))
+ (server (split-string (nth 2 spec) "@"))
+ (group (nth 3 spec))
+ (article (nth 4 spec)))
+ (org-gnus-follow-link
+ (format "nntp+%s:%s" (or (cdr server) (car server)) group)
+ article)))
+
(defun org-gnus-open (path)
"Follow the Gnus message or folder link specified by PATH."
(let (group article)
@@ -169,19 +218,36 @@ If `org-store-link' was called with a prefix arg the meaning of
(cond ((and group article)
(gnus-activate-group group t)
(condition-case nil
- (let ((articles 1)
- group-opened)
- (while (and (not group-opened)
- ;; stop on integer overflows
- (> articles 0))
- (setq group-opened (gnus-group-read-group articles nil group)
- articles (if (< articles 16)
- (1+ articles)
- (* articles 2))))
- (if group-opened
- (gnus-summary-goto-article article nil t)
- (message "Couldn't follow gnus link. %s"
- "The summary couldn't be opened.")))
+ (let* ((method (gnus-find-method-for-group group))
+ (backend (car method))
+ (server (cadr method)))
+ (cond
+ ((eq backend 'nndoc)
+ (if (gnus-group-read-group t nil group)
+ (gnus-summary-goto-article article nil t)
+ (message "Couldn't follow gnus link. %s"
+ "The summary couldn't be opened.")))
+ (t
+ (let ((articles 1)
+ group-opened)
+ (when (and (eq backend 'nnimap)
+ org-gnus-nnimap-query-article-no-from-file)
+ (setq article
+ (or (org-gnus-nnimap-cached-article-number
+ (nth 1 (split-string group ":"))
+ server (concat "<" article ">")) article)))
+ (while (and (not group-opened)
+ ;; stop on integer overflows
+ (> articles 0))
+ (setq group-opened (gnus-group-read-group
+ articles nil group)
+ articles (if (< articles 16)
+ (1+ articles)
+ (* articles 2))))
+ (if group-opened
+ (gnus-summary-goto-article article nil t)
+ (message "Couldn't follow gnus link. %s"
+ "The summary couldn't be opened."))))))
(quit (message "Couldn't follow gnus link. %s"
"The linked group is empty."))))
(group (gnus-group-jump-to-group group))))
diff --git a/lisp/org/org-habit.el b/lisp/org/org-habit.el
index 47b0647893f..394b4fb05db 100644
--- a/lisp/org/org-habit.el
+++ b/lisp/org/org-habit.el
@@ -5,7 +5,7 @@
;; Author: John Wiegley <johnw at gnu dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -27,11 +27,13 @@
;; This file contains the habit tracking code for Org-mode
+;;; Code:
+
(require 'org)
(require 'org-agenda)
+
(eval-when-compile
- (require 'cl)
- (require 'calendar))
+ (require 'cl))
(defgroup org-habit nil
"Options concerning habit tracking in Org-mode."
@@ -67,52 +69,52 @@ relative to the current effective date."
:type 'boolean)
(defface org-habit-clear-face
- '((((background light)) (:background "slateblue"))
+ '((((background light)) (:background "#8270f9"))
(((background dark)) (:background "blue")))
"Face for days on which a task shouldn't be done yet."
:group 'org-habit
:group 'org-faces)
(defface org-habit-clear-future-face
- '((((background light)) (:background "powderblue"))
+ '((((background light)) (:background "#d6e4fc"))
(((background dark)) (:background "midnightblue")))
"Face for future days on which a task shouldn't be done yet."
:group 'org-habit
:group 'org-faces)
(defface org-habit-ready-face
- '((((background light)) (:background "green"))
+ '((((background light)) (:background "#4df946"))
(((background dark)) (:background "forestgreen")))
"Face for days on which a task should start to be done."
:group 'org-habit
:group 'org-faces)
(defface org-habit-ready-future-face
- '((((background light)) (:background "palegreen"))
+ '((((background light)) (:background "#acfca9"))
(((background dark)) (:background "darkgreen")))
"Face for days on which a task should start to be done."
:group 'org-habit
:group 'org-faces)
(defface org-habit-alert-face
- '((((background light)) (:background "yellow"))
+ '((((background light)) (:background "#f5f946"))
(((background dark)) (:background "gold")))
"Face for days on which a task is due."
:group 'org-habit
:group 'org-faces)
(defface org-habit-alert-future-face
- '((((background light)) (:background "palegoldenrod"))
+ '((((background light)) (:background "#fafca9"))
(((background dark)) (:background "darkgoldenrod")))
"Face for days on which a task is due."
:group 'org-habit
:group 'org-faces)
(defface org-habit-overdue-face
- '((((background light)) (:background "red"))
+ '((((background light)) (:background "#f9372d"))
(((background dark)) (:background "firebrick")))
"Face for days on which a task is overdue."
:group 'org-habit
:group 'org-faces)
(defface org-habit-overdue-future-face
- '((((background light)) (:background "mistyrose"))
+ '((((background light)) (:background "#fc9590"))
(((background dark)) (:background "darkred")))
"Face for days on which a task is overdue."
:group 'org-habit
@@ -147,15 +149,17 @@ This list represents a \"habit\" for the rest of this module."
(assert (org-is-habit-p (point)))
(let* ((scheduled (org-get-scheduled-time (point)))
(scheduled-repeat (org-get-repeat org-scheduled-string))
- (sr-days (org-habit-duration-to-days scheduled-repeat))
(end (org-entry-end-position))
- (habit-entry (org-no-properties (nth 5 (org-heading-components))))
- closed-dates deadline dr-days)
+ (habit-entry (org-no-properties (nth 4 (org-heading-components))))
+ closed-dates deadline dr-days sr-days)
(if scheduled
(setq scheduled (time-to-days scheduled))
(error "Habit %s has no scheduled date" habit-entry))
(unless scheduled-repeat
- (error "Habit %s has no scheduled repeat period" habit-entry))
+ (error
+ "Habit '%s' has no scheduled repeat period or has an incorrect one"
+ habit-entry))
+ (setq sr-days (org-habit-duration-to-days scheduled-repeat))
(unless (> sr-days 0)
(error "Habit %s scheduled repeat period is less than 1d" habit-entry))
(when (string-match "/\\([0-9]+[dwmy]\\)" scheduled-repeat)
@@ -179,8 +183,10 @@ This list represents a \"habit\" for the rest of this module."
(defsubst org-habit-deadline (habit)
(let ((deadline (nth 2 habit)))
(or deadline
- (+ (org-habit-scheduled habit)
- (1- (org-habit-scheduled-repeat habit))))))
+ (if (nth 3 habit)
+ (+ (org-habit-scheduled habit)
+ (1- (org-habit-scheduled-repeat habit)))
+ (org-habit-scheduled habit)))))
(defsubst org-habit-deadline-repeat (habit)
(or (nth 3 habit)
(org-habit-scheduled-repeat habit)))
@@ -281,9 +287,16 @@ current time."
donep)))
markedp face)
(if donep
- (progn
+ (let ((done-time (time-add
+ starting
+ (days-to-time
+ (- start (time-to-days starting))))))
+
(aset graph index ?*)
(setq markedp t)
+ (put-text-property
+ index (1+ index) 'help-echo
+ (format-time-string (org-time-stamp-format) done-time) graph)
(while (and done-dates
(= start (car done-dates)))
(setq last-done-date (car done-dates)
@@ -305,6 +318,7 @@ current time."
(defun org-habit-insert-consistency-graphs (&optional line)
"Insert consistency graph for any habitual tasks."
(let ((inhibit-read-only t) l c
+ (buffer-invisibility-spec '(org-link))
(moment (time-subtract (current-time)
(list 0 (* 3600 org-extend-today-until) 0))))
(save-excursion
diff --git a/lisp/org/org-html.el b/lisp/org/org-html.el
index 2682d239898..68fee5b8df5 100644
--- a/lisp/org/org-html.el
+++ b/lisp/org/org-html.el
@@ -6,7 +6,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -26,7 +26,10 @@
;;
;;; Commentary:
+;;; Code:
+
(require 'org-exp)
+
(eval-when-compile (require 'cl))
(declare-function org-id-find-id-file "org-id" (id))
@@ -57,7 +60,7 @@ by the footnotes themselves."
:type 'string)
(defcustom org-export-html-coding-system nil
- "Coding system for HTML export, defaults to buffer-file-coding-system."
+ "Coding system for HTML export, defaults to `buffer-file-coding-system'."
:group 'org-export-html
:type 'coding-system)
@@ -81,7 +84,7 @@ and corresponding declarations."
(string :tag "Declaration")))))
(defcustom org-export-html-style-include-scripts t
- "Non-nil means, include the javascript snippets in exported HTML files.
+ "Non-nil means include the JavaScript snippets in exported HTML files.
The actual script is defined in `org-export-html-scripts' and should
not be modified."
:group 'org-export-html
@@ -110,7 +113,7 @@ not be modified."
}
/*]]>*///-->
</script>"
-"Basic javascript that is needed by HTML files produced by Org-mode.")
+"Basic JavaScript that is needed by HTML files produced by Org-mode.")
(defconst org-export-html-style-default
"<style type=\"text/css\">
@@ -123,6 +126,9 @@ not be modified."
.target { }
.timestamp { color: #bebebe; }
.timestamp-kwd { color: #5f9ea0; }
+ .right {margin-left:auto; margin-right:0px; text-align:right;}
+ .left {margin-left:0px; margin-right:auto; text-align:left;}
+ .center {margin-left:auto; margin-right:auto; text-align:center;}
p.verse { margin-left: 3% }
pre {
border: 1pt solid #AEBDCC;
@@ -133,10 +139,17 @@ not be modified."
overflow:auto;
}
table { border-collapse: collapse; }
- td, th { vertical-align: top; }
+ td, th { vertical-align: top; }
+ th.right { text-align:center; }
+ th.left { text-align:center; }
+ th.center { text-align:center; }
+ td.right { text-align:right; }
+ td.left { text-align:left; }
+ td.center { text-align:center; }
dt { font-weight: bold; }
div.figure { padding: 0.5em; }
div.figure p { text-align: center; }
+ textarea { overflow-x: auto; }
.linenr { font-size:smaller }
.code-highlighted {background-color:#ffff00;}
.org-info-js_info-navigation { border-style:none; }
@@ -153,7 +166,7 @@ have the default style included, customize the variable
`org-export-html-style-include-default'.")
(defcustom org-export-html-style-include-default t
- "Non-nil means, include the default style in exported HTML files.
+ "Non-nil means include the default style in exported HTML files.
The actual style is defined in `org-export-html-style-default' and should
not be modified. Use the variables `org-export-html-style' to add
your own style information."
@@ -205,21 +218,127 @@ settings with <style>...</style> tags."
;;;###autoload
(put 'org-export-html-style-extra 'safe-local-variable 'stringp)
+(defcustom org-export-html-mathjax-options
+ '((path "http://orgmode.org/mathjax/MathJax.js")
+ (scale "100")
+ (align "center")
+ (indent "2em")
+ (mathml nil))
+ "Options for MathJax setup.
+
+path The path where to find MathJax
+scale Scaling for the HTML-CSS backend, usually between 100 and 133
+align How to align display math: left, center, or right
+indent If align is not center, how far from the left/right side?
+mathml Should a MathML player be used if available?
+ This is faster and reduces bandwidth use, but currently
+ sometimes has lower spacing quality. Therefore, the default is
+ nil. When browsers get better, this switch can be flipped.
+
+You can also customize this for each buffer, using something like
+
+#+MATHJAX: scale:\"133\" align:\"right\" mathml:t path:\"/MathJax/\""
+ :group 'org-export-html
+ :type '(list :greedy t
+ (list :tag "path (the path from where to load MathJax.js)"
+ (const :format " " path) (string))
+ (list :tag "scale (scaling for the displayed math)"
+ (const :format " " scale) (string))
+ (list :tag "align (alignment of displayed equations)"
+ (const :format " " align) (string))
+ (list :tag "indent (indentation with left or right alignment)"
+ (const :format " " indent) (string))
+ (list :tag "mathml (should MathML display be used is possible)"
+ (const :format " " mathml) (boolean))))
+
+(defun org-export-html-mathjax-config (template options in-buffer)
+ "Insert the user setup into the matchjax template."
+ (let (name val (yes " ") (no "// ") x)
+ (mapc
+ (lambda (e)
+ (setq name (car e) val (nth 1 e))
+ (if (string-match (concat "\\<" (symbol-name name) ":") in-buffer)
+ (setq val (car (read-from-string
+ (substring in-buffer (match-end 0))))))
+ (if (not (stringp val)) (setq val (format "%s" val)))
+ (if (string-match (concat "%" (upcase (symbol-name name))) template)
+ (setq template (replace-match val t t template))))
+ options)
+ (setq val (nth 1 (assq 'mathml options)))
+ (if (string-match (concat "\\<mathml:") in-buffer)
+ (setq val (car (read-from-string
+ (substring in-buffer (match-end 0))))))
+ ;; Exchange prefixes depending on mathml setting
+ (if (not val) (setq x yes yes no no x))
+ ;; Replace cookies to turn on or off the config/jax lines
+ (if (string-match ":MMLYES:" template)
+ (setq template (replace-match yes t t template)))
+ (if (string-match ":MMLNO:" template)
+ (setq template (replace-match no t t template)))
+ ;; Return the modified template
+ template))
+
+(defcustom org-export-html-mathjax-template
+ "<script type=\"text/javascript\" src=\"%PATH\">
+<!--/*--><![CDATA[/*><!--*/
+ MathJax.Hub.Config({
+ // Only one of the two following lines, depending on user settings
+ // First allows browser-native MathML display, second forces HTML/CSS
+ :MMLYES: config: [\"MMLorHTML.js\"], jax: [\"input/TeX\"],
+ :MMLNO: jax: [\"input/TeX\", \"output/HTML-CSS\"],
+ extensions: [\"tex2jax.js\",\"TeX/AMSmath.js\",\"TeX/AMSsymbols.js\",
+ \"TeX/noUndefined.js\"],
+ tex2jax: {
+ inlineMath: [ [\"\\\\(\",\"\\\\)\"] ],
+ displayMath: [ ['$$','$$'], [\"\\\\[\",\"\\\\]\"] ],
+ skipTags: [\"script\",\"noscript\",\"style\",\"textarea\",\"pre\",\"code\"],
+ ignoreClass: \"tex2jax_ignore\",
+ processEscapes: false,
+ processEnvironments: true,
+ preview: \"TeX\"
+ },
+ showProcessingMessages: true,
+ displayAlign: \"%ALIGN\",
+ displayIndent: \"%INDENT\",
+
+ \"HTML-CSS\": {
+ scale: %SCALE,
+ availableFonts: [\"STIX\",\"TeX\"],
+ preferredFont: \"TeX\",
+ webFont: \"TeX\",
+ imageFont: \"TeX\",
+ showMathMenu: true,
+ },
+ MMLorHTML: {
+ prefer: {
+ MSIE: \"MML\",
+ Firefox: \"MML\",
+ Opera: \"HTML\",
+ other: \"HTML\"
+ }
+ }
+ });
+/*]]>*///-->
+</script>"
+ "The MathJax setup for XHTML files."
+ :group 'org-export-html
+ :type 'string)
+
(defcustom org-export-html-tag-class-prefix ""
- "Prefix to clas names for TODO keywords.
+ "Prefix to class names for TODO keywords.
Each tag gets a class given by the tag itself, with this prefix.
The default prefix is empty because it is nice to just use the keyword
as a class name. But if you get into conflicts with other, existing
-CSS classes, then this prefic can be very useful."
+CSS classes, then this prefix can be very useful."
:group 'org-export-html
:type 'string)
(defcustom org-export-html-todo-kwd-class-prefix ""
- "Prefix to clas names for TODO keywords.
+ "Prefix to class names for TODO keywords.
Each TODO keyword gets a class given by the keyword itself, with this prefix.
The default prefix is empty because it is nice to just use the keyword
as a class name. But if you get into conflicts with other, existing
-CSS classes, then this prefic can be very useful."
+CSS classes, then this prefix can be very useful."
:group 'org-export-html
:type 'string)
@@ -234,10 +353,11 @@ CSS classes, then this prefic can be very useful."
|
<a accesskey=\"H\" href=\"%s\"> HOME </a>
</div>"
- "Snippet used to insert the HOME and UP links. This is a format,
-the first %s will receive the UP link, the second the HOME link.
-If both `org-export-html-link-up' and `org-export-html-link-home' are
-empty, the entire snippet will be ignored."
+ "Snippet used to insert the HOME and UP links.
+This is a format string, the first %s will receive the UP link,
+the second the HOME link. If both `org-export-html-link-up' and
+`org-export-html-link-home' are empty, the entire snippet will be
+ignored."
:group 'org-export-html
:type 'string)
@@ -253,7 +373,7 @@ document title."
:type 'string)
(defcustom org-export-html-link-org-files-as-html t
- "Non-nil means, make file links to `file.org' point to `file.html'.
+ "Non-nil means make file links to `file.org' point to `file.html'.
When org-mode is exporting an org-mode file to HTML, links to
non-html files are directly put into a href tag in HTML.
However, links to other Org-mode files (recognized by the
@@ -265,7 +385,7 @@ When nil, the links still point to the plain `.org' file."
:type 'boolean)
(defcustom org-export-html-inline-images 'maybe
- "Non-nil means, inline images into exported HTML pages.
+ "Non-nil means inline images into exported HTML pages.
This is done using an <img> tag. When nil, an anchor with href is used to
link to the image. If this option is `maybe', then images in links with
an empty description will be inlined, while images with a description will
@@ -276,7 +396,7 @@ be linked only."
(const :tag "When there is no description" maybe)))
(defcustom org-export-html-inline-image-extensions
- '("png" "jpeg" "jpg" "gif")
+ '("png" "jpeg" "jpg" "gif" "svg")
"Extensions of image files that can be inlined into HTML."
:group 'org-export-html
:type '(repeat (string :tag "Extension")))
@@ -289,17 +409,22 @@ borders and spacing."
:group 'org-export-html
:type 'string)
-(defcustom org-export-table-header-tags '("<th scope=\"%s\">" . "</th>")
+(defcustom org-export-table-header-tags '("<th scope=\"%s\"%s>" . "</th>")
"The opening tag for table header fields.
This is customizable so that alignment options can be specified.
-%s will be filled with the scope of the field, either row or col.
-See also the variable `org-export-html-table-use-header-tags-for-first-column'."
+The first %s will be filled with the scope of the field, either row or col.
+The second %s will be replaced by a style entry to align the field.
+See also the variable `org-export-html-table-use-header-tags-for-first-column'.
+See also the variable `org-export-html-table-align-individual-fields'."
:group 'org-export-tables
:type '(cons (string :tag "Opening tag") (string :tag "Closing tag")))
-(defcustom org-export-table-data-tags '("<td>" . "</td>")
+(defcustom org-export-table-data-tags '("<td%s>" . "</td>")
"The opening tag for table data fields.
-This is customizable so that alignment options can be specified."
+This is customizable so that alignment options can be specified.
+The first %s will be filled with the scope of the field, either row or col.
+The second %s will be replaced by a style entry to align the field.
+See also the variable `org-export-html-table-align-individual-fields'."
:group 'org-export-tables
:type '(cons (string :tag "Opening tag") (string :tag "Closing tag")))
@@ -330,16 +455,22 @@ will give even lines the class \"tr-even\" and odd lines the class \"tr-odd\"."
(string :tag "Specify")
(sexp))))
-
+(defcustom org-export-html-table-align-individual-fields t
+ "Non-nil means attach style attributes for alignment to each table field.
+When nil, alignment will only be specified in the column tags, but this
+is ignored by some browsers (like Firefox, Safari). Opera does it right
+though."
+ :group 'org-export-tables
+ :type 'boolean)
(defcustom org-export-html-table-use-header-tags-for-first-column nil
- "Non-nil means, format column one in tables with header tags.
+ "Non-nil means format column one in tables with header tags.
When nil, also column one will use data tags."
:group 'org-export-tables
:type 'boolean)
(defcustom org-export-html-validation-link nil
- "Non-nil means, add validationlink to postamble of HTML exported files."
+ "Non-nil means add validation link to postamble of HTML exported files."
:group 'org-export-html
:type '(choice
(const :tag "Nothing" nil)
@@ -348,9 +479,10 @@ When nil, also column one will use data tags."
(defcustom org-export-html-with-timestamp nil
- "If non-nil, write `org-export-html-html-helper-timestamp'
-into the exported HTML text. Otherwise, the buffer will just be saved
-to a file."
+ "If non-nil, write timestamp into the exported HTML text.
+If non-nil Write `org-export-html-html-helper-timestamp' into the
+exported HTML text. Otherwise, the buffer will just be saved to
+a file."
:group 'org-export-html
:type 'boolean)
@@ -404,10 +536,10 @@ with a link to this URL."
;;; Variables, constants, and parameter plists
(defvar org-export-html-preamble nil
- "Preamble, to be inserted just before <body>. Set by publishing functions.
+ "Preamble, to be inserted just after <body>. Set by publishing functions.
This may also be a function, building and inserting the preamble.")
(defvar org-export-html-postamble nil
- "Preamble, to be inserted just after </body>. Set by publishing functions.
+ "Postamble, to be inserted just before </body>. Set by publishing functions.
This may also be a function, building and inserting the postamble.")
(defvar org-export-html-auto-preamble t
"Should default preamble be inserted? Set by publishing functions.")
@@ -420,20 +552,36 @@ This may also be a function, building and inserting the postamble.")
"Hook run during HTML export, after blockquote, verse, center are done.")
(defvar org-export-html-final-hook nil
- "Hook run during HTML export, after blockquote, verse, center are done.")
+ "Hook run at the end of HTML export, in the new buffer.")
;;; HTML export
(defun org-export-html-preprocess (parameters)
- ;; Convert LaTeX fragments to images
+ "Convert LaTeX fragments to images."
(when (and org-current-export-file
(plist-get parameters :LaTeX-fragments))
(org-format-latex
(concat "ltxpng/" (file-name-sans-extension
(file-name-nondirectory
org-current-export-file)))
- org-current-export-dir nil "Creating LaTeX image %s"))
- (message "Exporting..."))
+ org-current-export-dir nil "Creating LaTeX image %s"
+ nil nil
+ (cond
+ ((eq (plist-get parameters :LaTeX-fragments) 'verbatim) 'verbatim)
+ ((eq (plist-get parameters :LaTeX-fragments) 'mathjax ) 'mathjax)
+ ((eq (plist-get parameters :LaTeX-fragments) t ) 'mathjax)
+ ((eq (plist-get parameters :LaTeX-fragments) 'dvipng ) 'dvipng)
+ (t nil))))
+ (goto-char (point-min))
+ (let (label l1)
+ (while (re-search-forward "\\\\ref{\\([^{}\n]+\\)}" nil t)
+ (org-if-unprotected-at (match-beginning 1)
+ (setq label (match-string 1))
+ (save-match-data
+ (if (string-match "\\`[a-z]\\{1,10\\}:\\(.+\\)" label)
+ (setq l1 (substring label (match-beginning 1)))
+ (setq l1 label)))
+ (replace-match (format "[[#%s][%s]]" label l1) t t)))))
;;;###autoload
(defun org-export-as-html-and-open (arg)
@@ -443,11 +591,14 @@ The prefix ARG specifies how many levels of the outline should become
headlines. The default is 3. Lower levels will become bulleted lists."
(interactive "P")
(org-export-as-html arg 'hidden)
- (org-open-file buffer-file-name))
+ (org-open-file buffer-file-name)
+ (when org-export-kill-product-buffer-when-displayed
+ (kill-buffer (current-buffer))))
;;;###autoload
(defun org-export-as-html-batch ()
- "Call `org-export-as-html', may be used in batch processing as
+ "Call the function `org-export-as-html'.
+This function can be used in batch processing as:
emacs --batch
--load=$HOME/lib/emacs/org.el
--eval \"(setq org-export-headline-levels 2)\"
@@ -521,6 +672,128 @@ in a window. A non-interactive call will only return the buffer."
(defvar html-table-tag nil) ; dynamically scoped into this.
(defvar org-par-open nil)
+
+;;; org-html-cvt-link-fn
+(defconst org-html-cvt-link-fn
+ nil
+ "Function to convert link URLs to exportable URLs.
+Takes two arguments, TYPE and PATH.
+Returns exportable url as (TYPE PATH), or nil to signal that it
+didn't handle this case.
+Intended to be locally bound around a call to `org-export-as-html'." )
+
+(defun org-html-cvt-org-as-html (opt-plist type path)
+ "Convert an org filename to an equivalent html filename.
+If TYPE is not file, just return `nil'.
+See variable `org-export-html-link-org-files-as-html'"
+
+ (save-match-data
+ (and
+ org-export-html-link-org-files-as-html
+ (string= type "file")
+ (string-match "\\.org$" path)
+ (progn
+ (list
+ "file"
+ (concat
+ (substring path 0 (match-beginning 0))
+ "."
+ (plist-get opt-plist :html-extension)))))))
+
+
+;;; org-html-should-inline-p
+(defun org-html-should-inline-p (filename descp)
+ "Return non-nil if link FILENAME should be inlined.
+The decision to inline the FILENAME link is based on the current
+settings. DESCP is the boolean of whether there was a link
+description. See variables `org-export-html-inline-images' and
+`org-export-html-inline-image-extensions'."
+ (declare (special
+ org-export-html-inline-images
+ org-export-html-inline-image-extensions))
+ (and (or (eq t org-export-html-inline-images)
+ (and org-export-html-inline-images (not descp)))
+ (org-file-image-p
+ filename org-export-html-inline-image-extensions)))
+
+;;; org-html-make-link
+(defun org-html-make-link (opt-plist type path fragment desc attr
+ may-inline-p)
+ "Make an HTML link.
+OPT-PLIST is an options list.
+TYPE is the device-type of the link (THIS://foo.html)
+PATH is the path of the link (http://THIS#locationx)
+FRAGMENT is the fragment part of the link, if any (foo.html#THIS)
+DESC is the link description, if any.
+ATTR is a string of other attributes of the a element.
+MAY-INLINE-P allows inlining it as an image."
+
+ (declare (special org-par-open))
+ (save-match-data
+ (let* ((filename path)
+ ;;First pass. Just sanity stuff.
+ (components-1
+ (cond
+ ((string= type "file")
+ (list
+ type
+ ;;Substitute just if original path was absolute.
+ ;;(Otherwise path must remain relative)
+ (if (file-name-absolute-p path)
+ (concat "file://" (expand-file-name path))
+ path)))
+ ((string= type "")
+ (list nil path))
+ (t (list type path))))
+
+ ;;Second pass. Components converted so they can refer
+ ;;to a remote site.
+ (components-2
+ (or
+ (and org-html-cvt-link-fn
+ (apply org-html-cvt-link-fn
+ opt-plist components-1))
+ (apply #'org-html-cvt-org-as-html
+ opt-plist components-1)
+ components-1))
+ (type (first components-2))
+ (thefile (second components-2)))
+
+
+ ;;Third pass. Build final link except for leading type
+ ;;spec.
+ (cond
+ ((or
+ (not type)
+ (string= type "http")
+ (string= type "https")
+ (string= type "file"))
+ (if fragment
+ (setq thefile (concat thefile "#" fragment))))
+
+ (t))
+
+ ;;Final URL-build, for all types.
+ (setq thefile
+ (let
+ ((str (org-export-html-format-href thefile)))
+ (if (and type (not (string= "file" type)))
+ (concat type ":" str)
+ str)))
+
+ (if (and
+ may-inline-p
+ ;;Can't inline a URL with a fragment.
+ (not fragment))
+ (progn
+ (message "image %s %s" thefile org-par-open)
+ (org-export-html-format-image thefile org-par-open))
+ (concat
+ "<a href=\"" thefile "\"" attr ">"
+ (org-export-html-format-desc desc)
+ "</a>")))))
+
+;;; org-export-as-html
;;;###autoload
(defun org-export-as-html (arg &optional hidden ext-plist
to-buffer body-only pub-dir)
@@ -539,6 +812,7 @@ the file header and footer, simply return the content of
<body>...</body>, without even the body tags themselves. When
PUB-DIR is set, use this as the publishing directory."
(interactive "P")
+ (run-hooks 'org-export-first-hook)
;; Make sure we have a file name when we need it.
(when (and (not (or to-buffer body-only))
@@ -624,7 +898,8 @@ PUB-DIR is set, use this as the publishing directory."
(author (plist-get opt-plist :author))
(title (or (and subtree-p (org-export-get-title-from-subtree))
(plist-get opt-plist :title)
- (and (not
+ (and (not body-only)
+ (not
(plist-get opt-plist :skip-before-1st-heading))
(org-export-grab-title-from-buffer))
(and buffer-file-name
@@ -635,8 +910,8 @@ PUB-DIR is set, use this as the publishing directory."
(string-match "\\S-" (plist-get opt-plist :link-up))
(plist-get opt-plist :link-up)))
(link-home (and (plist-get opt-plist :link-home)
- (string-match "\\S-" (plist-get opt-plist :link-home))
- (plist-get opt-plist :link-home)))
+ (string-match "\\S-" (plist-get opt-plist :link-home))
+ (plist-get opt-plist :link-home)))
(dummy (setq opt-plist (plist-put opt-plist :title title)))
(html-table-tag (plist-get opt-plist :html-table-tag))
(quote-re0 (concat "^[ \t]*" org-quote-string "\\>"))
@@ -669,6 +944,7 @@ PUB-DIR is set, use this as the publishing directory."
(buffer-substring
(if region-p (region-beginning) (point-min))
(if region-p (region-end) (point-max))))
+ (org-export-have-math nil)
(lines
(org-split-string
(org-export-preprocess-string
@@ -692,11 +968,21 @@ PUB-DIR is set, use this as the publishing directory."
:LaTeX-fragments
(plist-get opt-plist :LaTeX-fragments))
"[\r\n]"))
+ (mathjax
+ (if (or (eq (plist-get opt-plist :LaTeX-fragments) 'mathjax)
+ (and org-export-have-math
+ (eq (plist-get opt-plist :LaTeX-fragments) t)))
+
+ (org-export-html-mathjax-config
+ org-export-html-mathjax-template
+ org-export-html-mathjax-options
+ (or (plist-get opt-plist :mathjax) ""))
+ ""))
table-open type
table-buffer table-orig-buffer
- ind item-type starter didclose
+ ind item-type starter
rpl path attr desc descp desc1 desc2 link
- snumber fnc item-tag
+ snumber fnc item-tag item-number
footnotes footref-seen
id-file href
)
@@ -761,6 +1047,7 @@ lang=\"%s\" xml:lang=\"%s\">
<meta name=\"description\" content=\"%s\"/>
<meta name=\"keywords\" content=\"%s\"/>
%s
+%s
</head>
<body>
<div id=\"content\">
@@ -775,10 +1062,11 @@ lang=\"%s\" xml:lang=\"%s\">
"")
(or charset "iso-8859-1"))
language language
- (org-html-expand title)
+ title
(or charset "iso-8859-1")
date author description keywords
style
+ mathjax
(if (or link-up link-home)
(concat
(format org-export-html-home/up-format
@@ -804,70 +1092,73 @@ lang=\"%s\" xml:lang=\"%s\">
(push "<ul>\n<li>" thetoc)
(setq lines
(mapcar '(lambda (line)
- (if (string-match org-todo-line-regexp line)
- ;; This is a headline
- (progn
- (setq have-headings t)
- (setq level (- (match-end 1) (match-beginning 1)
- level-offset)
- level (org-tr-level level)
- txt (save-match-data
- (org-html-expand
- (org-export-cleanup-toc-line
- (match-string 3 line))))
- todo
- (or (and org-export-mark-todo-in-toc
- (match-beginning 2)
- (not (member (match-string 2 line)
- org-done-keywords)))
+ (if (and (string-match org-todo-line-regexp line)
+ (not (get-text-property 0 'org-protected line)))
+ ;; This is a headline
+ (progn
+ (setq have-headings t)
+ (setq level (- (match-end 1) (match-beginning 1)
+ level-offset)
+ level (org-tr-level level)
+ txt (save-match-data
+ (org-html-expand
+ (org-export-cleanup-toc-line
+ (match-string 3 line))))
+ todo
+ (or (and org-export-mark-todo-in-toc
+ (match-beginning 2)
+ (not (member (match-string 2 line)
+ org-done-keywords)))
; TODO, not DONE
- (and org-export-mark-todo-in-toc
- (= level umax-toc)
- (org-search-todo-below
- line lines level))))
- (if (string-match
- (org-re "[ \t]+:\\([[:alnum:]_@:]+\\):[ \t]*$") txt)
- (setq txt (replace-match "&nbsp;&nbsp;&nbsp;<span class=\"tag\"> \\1</span>" t nil txt)))
- (if (string-match quote-re0 txt)
- (setq txt (replace-match "" t t txt)))
- (setq snumber (org-section-number level))
- (if org-export-with-section-numbers
- (setq txt (concat snumber " " txt)))
- (if (<= level (max umax umax-toc))
- (setq head-count (+ head-count 1)))
- (if (<= level umax-toc)
- (progn
- (if (> level org-last-level)
- (progn
- (setq cnt (- level org-last-level))
- (while (>= (setq cnt (1- cnt)) 0)
- (push "\n<ul>\n<li>" thetoc))
- (push "\n" thetoc)))
- (if (< level org-last-level)
- (progn
- (setq cnt (- org-last-level level))
- (while (>= (setq cnt (1- cnt)) 0)
- (push "</li>\n</ul>" thetoc))
- (push "\n" thetoc)))
- ;; Check for targets
- (while (string-match org-any-target-regexp line)
- (setq line (replace-match
- (concat "@<span class=\"target\">" (match-string 1 line) "@</span> ")
- t t line)))
- (while (string-match "&lt;\\(&lt;\\)+\\|&gt;\\(&gt;\\)+" txt)
- (setq txt (replace-match "" t t txt)))
- (setq href (format "sec-%s" snumber))
- (setq href (or (cdr (assoc href org-export-preferred-target-alist)) href))
- (push
- (format
- (if todo
- "</li>\n<li><a href=\"#%s\"><span class=\"todo\">%s</span></a>"
- "</li>\n<li><a href=\"#%s\">%s</a>")
- href txt) thetoc)
-
- (setq org-last-level level))
- )))
- line)
+ (and org-export-mark-todo-in-toc
+ (= level umax-toc)
+ (org-search-todo-below
+ line lines level))))
+ (if (string-match
+ (org-re "[ \t]+:\\([[:alnum:]_@:]+\\):[ \t]*$") txt)
+ (setq txt (replace-match "&nbsp;&nbsp;&nbsp;<span class=\"tag\"> \\1</span>" t nil txt)))
+ (if (string-match quote-re0 txt)
+ (setq txt (replace-match "" t t txt)))
+ (setq snumber (org-section-number level))
+ (if org-export-with-section-numbers
+ (setq txt (concat snumber " " txt)))
+ (if (<= level (max umax umax-toc))
+ (setq head-count (+ head-count 1)))
+ (if (<= level umax-toc)
+ (progn
+ (if (> level org-last-level)
+ (progn
+ (setq cnt (- level org-last-level))
+ (while (>= (setq cnt (1- cnt)) 0)
+ (push "\n<ul>\n<li>" thetoc))
+ (push "\n" thetoc)))
+ (if (< level org-last-level)
+ (progn
+ (setq cnt (- org-last-level level))
+ (while (>= (setq cnt (1- cnt)) 0)
+ (push "</li>\n</ul>" thetoc))
+ (push "\n" thetoc)))
+ ;; Check for targets
+ (while (string-match org-any-target-regexp line)
+ (setq line (replace-match
+ (concat "@<span class=\"target\">" (match-string 1 line) "@</span> ")
+ t t line)))
+ (while (string-match "&lt;\\(&lt;\\)+\\|&gt;\\(&gt;\\)+" txt)
+ (setq txt (replace-match "" t t txt)))
+ (setq href
+ (replace-regexp-in-string
+ "\\." "_" (format "sec-%s" snumber)))
+ (setq href (or (cdr (assoc href org-export-preferred-target-alist)) href))
+ (push
+ (format
+ (if todo
+ "</li>\n<li><a href=\"#%s\"><span class=\"todo\">%s</span></a>"
+ "</li>\n<li><a href=\"#%s\">%s</a>")
+ href txt) thetoc)
+
+ (setq org-last-level level))
+ )))
+ line)
lines))
(while (> org-last-level (1- org-min-level))
(setq org-last-level (1- org-last-level))
@@ -910,7 +1201,16 @@ lang=\"%s\" xml:lang=\"%s\">
(org-open-par))
(throw 'nextline nil))
- (org-export-html-close-lists-maybe line)
+ ;; Explicit list closure
+ (when (equal "ORG-LIST-END" line)
+ (while local-list-indent
+ (org-close-li (car local-list-type))
+ (insert (format "</%sl>\n" (car local-list-type)))
+ (pop local-list-type)
+ (pop local-list-indent))
+ (setq in-local-list nil)
+ (org-open-par)
+ (throw 'nextline nil))
;; Protected HTML
(when (get-text-property 0 'org-protected line)
@@ -944,10 +1244,12 @@ lang=\"%s\" xml:lang=\"%s\">
(when (equal "ORG-VERSE-START" line)
(org-close-par-maybe)
(insert "\n<p class=\"verse\">\n")
+ (setq org-par-open t)
(setq inverse t)
(throw 'nextline nil))
(when (equal "ORG-VERSE-END" line)
(insert "</p>\n")
+ (setq org-par-open nil)
(org-open-par)
(setq inverse nil)
(throw 'nextline nil))
@@ -999,7 +1301,7 @@ lang=\"%s\" xml:lang=\"%s\">
"\" class=\"target\">" (match-string 1 line)
"@</a> ")
t t line)))))
-
+
(setq line (org-html-handle-time-stamps line))
;; replace "&" by "&amp;", "<" and ">" by "&lt;" and "&gt;"
@@ -1036,61 +1338,70 @@ lang=\"%s\" xml:lang=\"%s\">
(setq desc (org-add-props
(concat "<img src=\"" desc "\"/>")
'(org-protected t))))
- ;; FIXME: do we need to unescape here somewhere?
(cond
((equal type "internal")
- (setq rpl
- (concat
- "<a href=\""
- (if (= (string-to-char path) ?#) "" "#")
- (org-solidify-link-text
- (save-match-data (org-link-unescape path)) nil)
- "\"" attr ">"
- (org-export-html-format-desc desc)
- "</a>")))
+ (let
+ ((frag-0
+ (if (= (string-to-char path) ?#)
+ (substring path 1)
+ path)))
+ (setq rpl
+ (org-html-make-link
+ opt-plist
+ ""
+ ""
+ (org-solidify-link-text
+ (save-match-data (org-link-unescape frag-0))
+ nil)
+ desc attr nil))))
((and (equal type "id")
(setq id-file (org-id-find-id-file path)))
;; This is an id: link to another file (if it was the same file,
;; it would have become an internal link...)
(save-match-data
(setq id-file (file-relative-name
- id-file (file-name-directory org-current-export-file)))
- (setq id-file (concat (file-name-sans-extension id-file)
- "." html-extension))
- (setq rpl (concat "<a href=\"" id-file "#"
- (if (org-uuidgen-p path) "ID-")
- path "\""
- attr ">"
- (org-export-html-format-desc desc)
- "</a>"))))
+ id-file
+ (file-name-directory org-current-export-file)))
+ (setq rpl
+ (org-html-make-link opt-plist
+ "file" id-file
+ (concat (if (org-uuidgen-p path) "ID-") path)
+ desc
+ attr
+ nil))))
((member type '("http" "https"))
- ;; standard URL, just check if we need to inline an image
- (if (and (or (eq t org-export-html-inline-images)
- (and org-export-html-inline-images (not descp)))
- (org-file-image-p
- path org-export-html-inline-image-extensions))
- (setq rpl (org-export-html-format-image
- (concat type ":" path) org-par-open))
- (setq link (concat type ":" path))
- (setq rpl (concat "<a href=\""
- (org-export-html-format-href link)
- "\"" attr ">"
- (org-export-html-format-desc desc)
- "</a>"))))
+ ;; standard URL, can inline as image
+ (setq rpl
+ (org-html-make-link opt-plist
+ type path nil
+ desc
+ attr
+ (org-html-should-inline-p path descp))))
((member type '("ftp" "mailto" "news"))
- ;; standard URL
- (setq link (concat type ":" path))
- (setq rpl (concat "<a href=\""
- (org-export-html-format-href link)
- "\"" attr ">"
- (org-export-html-format-desc desc)
- "</a>")))
+ ;; standard URL, can't inline as image
+ (setq rpl
+ (org-html-make-link opt-plist
+ type path nil
+ desc
+ attr
+ nil)))
((string= type "coderef")
- (setq rpl (format "<a href=\"#coderef-%s\" class=\"coderef\" onmouseover=\"CodeHighlightOn(this, 'coderef-%s');\" onmouseout=\"CodeHighlightOff(this, 'coderef-%s');\">%s</a>"
- path path path
- (format (org-export-get-coderef-format path (and descp desc))
- (cdr (assoc path org-export-code-refs))))))
+ (let*
+ ((coderef-str (format "coderef-%s" path))
+ (attr-1
+ (format "class=\"coderef\" onmouseover=\"CodeHighlightOn(this, '%s');\" onmouseout=\"CodeHighlightOff(this, '%s');\""
+ coderef-str coderef-str)))
+ (setq rpl
+ (org-html-make-link opt-plist
+ type "" coderef-str
+ (format
+ (org-export-get-coderef-format
+ path
+ (and descp desc))
+ (cdr (assoc path org-export-code-refs)))
+ attr-1
+ nil))))
((functionp (setq fnc (nth 2 (assoc type org-link-protocols))))
;; The link protocol has a function for format the link
@@ -1100,49 +1411,54 @@ lang=\"%s\" xml:lang=\"%s\">
((string= type "file")
;; FILE link
- (let* ((filename path)
- (abs-p (file-name-absolute-p filename))
- thefile file-is-image-p search)
- (save-match-data
- (if (string-match "::\\(.*\\)" filename)
- (setq search (match-string 1 filename)
- filename (replace-match "" t nil filename)))
- (setq valid
- (if (functionp link-validate)
- (funcall link-validate filename current-dir)
- t))
- (setq file-is-image-p
- (org-file-image-p
- filename org-export-html-inline-image-extensions))
- (setq thefile (if abs-p (expand-file-name filename) filename))
- (when (and org-export-html-link-org-files-as-html
- (string-match "\\.org$" thefile))
- (setq thefile (concat (substring thefile 0
- (match-beginning 0))
- "." html-extension))
- (if (and search
- ;; make sure this is can be used as target search
- (not (string-match "^[0-9]*$" search))
- (not (string-match "^\\*" search))
- (not (string-match "^/.*/$" search)))
- (setq thefile (concat thefile "#"
- (org-solidify-link-text
- (org-link-unescape search)))))
- (when (string-match "^file:" desc)
- (setq desc (replace-match "" t t desc))
- (if (string-match "\\.org$" desc)
- (setq desc (replace-match "" t t desc))))))
- (setq rpl (if (and file-is-image-p
- (or (eq t org-export-html-inline-images)
- (and org-export-html-inline-images
- (not descp))))
- (progn
- (message "image %s %s" thefile org-par-open)
- (org-export-html-format-image thefile org-par-open))
- (concat "<a href=\"" thefile "\"" attr ">"
- (org-export-html-format-desc desc)
- "</a>")))
- (if (not valid) (setq rpl desc))))
+ (save-match-data
+ (let*
+ ((components
+ (if
+ (string-match "::\\(.*\\)" path)
+ (list
+ (replace-match "" t nil path)
+ (match-string 1 path))
+ (list path nil)))
+
+ ;;The proper path, without a fragment
+ (path-1
+ (first components))
+
+ ;;The raw fragment
+ (fragment-0
+ (second components))
+
+ ;;Check the fragment. If it can't be used as
+ ;;target fragment we'll pass nil instead.
+ (fragment-1
+ (if
+ (and fragment-0
+ (not (string-match "^[0-9]*$" fragment-0))
+ (not (string-match "^\\*" fragment-0))
+ (not (string-match "^/.*/$" fragment-0)))
+ (org-solidify-link-text
+ (org-link-unescape fragment-0))
+ nil))
+ (desc-2
+ ;;Description minus "file:" and ".org"
+ (if (string-match "^file:" desc)
+ (let
+ ((desc-1 (replace-match "" t t desc)))
+ (if (string-match "\\.org$" desc-1)
+ (replace-match "" t t desc-1)
+ desc-1))
+ desc)))
+
+ (setq rpl
+ (if
+ (and
+ (functionp link-validate)
+ (not (funcall link-validate path-1 current-dir)))
+ desc
+ (org-html-make-link opt-plist
+ "file" path-1 fragment-1 desc-2 attr
+ (org-html-should-inline-p path-1 descp)))))))
(t
;; just publish the path, as default
@@ -1199,14 +1515,6 @@ lang=\"%s\" xml:lang=\"%s\">
(setq txt (replace-match "" t t txt)))
(if (<= level (max umax umax-toc))
(setq head-count (+ head-count 1)))
- (when in-local-list
- ;; Close any local lists before inserting a new header line
- (while local-list-type
- (org-close-li (car local-list-type))
- (insert (format "</%sl>\n" (car local-list-type)))
- (pop local-list-type))
- (setq local-list-indent nil
- in-local-list nil))
(setq first-heading-pos (or first-heading-pos (point)))
(org-html-level-start level txt umax
(and org-export-with-toc (<= level umax))
@@ -1218,19 +1526,6 @@ lang=\"%s\" xml:lang=\"%s\">
(insert "<pre>")
(setq inquote t)))
- ((string-match "^[ \t]*- __+[ \t]*$" line)
- ;; Explicit list closure
- (when local-list-type
- (let ((ind (org-get-indentation line)))
- (while (and local-list-indent
- (<= ind (car local-list-indent)))
- (org-close-li (car local-list-type))
- (insert (format "</%sl>\n" (car local-list-type)))
- (pop local-list-type)
- (pop local-list-indent))
- (or local-list-indent (setq in-local-list nil))))
- (throw 'nextline nil))
-
((and org-export-with-tables
(string-match "^\\([ \t]*\\)\\(|\\|\\+-+\\+\\)" line))
(when (not table-open)
@@ -1263,27 +1558,15 @@ lang=\"%s\" xml:lang=\"%s\">
starter (if (match-beginning 2)
(substring (match-string 2 line) 0 -1))
line (substring line (match-beginning 5))
+ item-number nil
item-tag nil)
+ (if (string-match "\\[@\\(?:start:\\)?\\([0-9]+\\)\\][ \t]?" line)
+ (setq item-number (match-string 1 line)
+ line (replace-match "" t t line)))
(if (and starter (string-match "\\(.*?\\) ::[ \t]*" line))
(setq item-type "d"
item-tag (match-string 1 line)
line (substring line (match-end 0))))
- (when (and (not (equal item-type "d"))
- (not (string-match "[^ \t]" line)))
- ;; empty line. Pretend indentation is large.
- (setq ind (if org-empty-line-terminates-plain-lists
- 0
- (1+ (or (car local-list-indent) 1)))))
- (setq didclose nil)
- (while (and in-local-list
- (or (and (= ind (car local-list-indent))
- (not starter))
- (< ind (car local-list-indent))))
- (setq didclose t)
- (org-close-li (car local-list-type))
- (insert (format "</%sl>\n" (car local-list-type)))
- (pop local-list-type) (pop local-list-indent)
- (setq in-local-list local-list-indent))
(cond
((and starter
(or (not in-local-list)
@@ -1292,29 +1575,40 @@ lang=\"%s\" xml:lang=\"%s\">
(org-close-par-maybe)
(insert (cond
((equal item-type "u") "<ul>\n<li>\n")
+ ((and (equal item-type "o") item-number)
+ (format "<ol>\n<li value=\"%s\">\n" item-number))
((equal item-type "o") "<ol>\n<li>\n")
((equal item-type "d")
(format "<dl>\n<dt>%s</dt><dd>\n" item-tag))))
(push item-type local-list-type)
(push ind local-list-indent)
(setq in-local-list t))
+ ;; Continue list
(starter
- ;; continue current list
+ ;; terminate any previous sublist but first ensure
+ ;; list is not ill-formed.
+ (let ((min-ind (apply 'min local-list-indent)))
+ (when (< ind min-ind) (setq ind min-ind)))
+ (while (< ind (car local-list-indent))
+ (org-close-li (car local-list-type))
+ (insert (format "</%sl>\n" (car local-list-type)))
+ (pop local-list-type) (pop local-list-indent)
+ (setq in-local-list local-list-indent))
+ ;; insert new item
(org-close-li (car local-list-type))
(insert (cond
((equal (car local-list-type) "d")
(format "<dt>%s</dt><dd>\n" (or item-tag "???")))
- (t "<li>\n"))))
- (didclose
- ;; we did close a list, normal text follows: need <p>
- (org-open-par)))
+ ((and (equal item-type "o") item-number)
+ (format "<li value=\"%s\">\n" item-number))
+ (t "<li>\n")))))
(if (string-match "^[ \t]*\\[\\([X ]\\)\\]" line)
(setq line
(replace-match
(if (equal (match-string 1 line) "X")
"<b>[X]</b>"
"<b>[<span style=\"visibility:hidden;\">X</span>]</b>")
- t t line))))
+ t t line))))
;; Horizontal line
(when (string-match "^[ \t]*-\\{5,\\}[ \t]*$" line)
@@ -1369,14 +1663,7 @@ lang=\"%s\" xml:lang=\"%s\">
(when inquote
(insert "</pre>\n")
(org-open-par))
- (when in-local-list
- ;; Close any local lists before inserting a new header line
- (while local-list-type
- (org-close-li (car local-list-type))
- (insert (format "</%sl>\n" (car local-list-type)))
- (pop local-list-type))
- (setq local-list-indent nil
- in-local-list nil))
+
(org-html-level-start 1 nil umax
(and org-export-with-toc (<= level umax))
head-count)
@@ -1402,7 +1689,7 @@ lang=\"%s\" xml:lang=\"%s\">
(when (and org-export-author-info author)
(insert "<p class=\"author\"> "
(nth 1 lang-words) ": " author "\n")
- (when email
+ (when (and org-export-email-info email (string-match "\\S-" email))
(if (listp (split-string email ",+ *"))
(mapc (lambda(e)
(insert "<a href=\"mailto:" e "\">&lt;"
@@ -1457,8 +1744,6 @@ lang=\"%s\" xml:lang=\"%s\">
(while (re-search-forward "<li>[ \r\n\t]*</li>\n?" nil t)
(replace-match ""))
(goto-char (point-min))
- (while (re-search-forward "</ul>\\s-*<ul>\n?" nil t)
- (replace-match ""))
;; Convert whitespace place holders
(goto-char (point-min))
(let (beg end n)
@@ -1469,6 +1754,12 @@ lang=\"%s\" xml:lang=\"%s\">
(delete-region beg end)
(insert (format "<span style=\"visibility:hidden;\">%s</span>"
(make-string n ?x)))))
+ ;; Remove empty lines at the beginning of the file.
+ (goto-char (point-min))
+ (when (looking-at "\\s-+\n") (replace-match ""))
+ ;; Remove display properties
+ (remove-text-properties (point-min) (point-max) '(display t))
+ ;; Run the hook
(run-hooks 'org-export-html-final-hook)
(or to-buffer (save-buffer))
(goto-char (point-min))
@@ -1506,10 +1797,12 @@ lang=\"%s\" xml:lang=\"%s\">
"Create image tag with source and attributes."
(save-match-data
(if (string-match "^ltxpng/" src)
- (format "<img src=\"%s\"/>" src)
+ (format "<img src=\"%s\" alt=\"%s\"/>"
+ src (org-find-text-property-in-string 'org-latex-src src))
(let* ((caption (org-find-text-property-in-string 'org-caption src))
(attr (org-find-text-property-in-string 'org-attributes src))
(label (org-find-text-property-in-string 'org-label src)))
+ (setq caption (and caption (org-html-do-expand caption)))
(concat
(if caption
(format "%s<div %sclass=\"figure\">
@@ -1545,13 +1838,14 @@ lang=\"%s\" xml:lang=\"%s\">
nil))))
(defvar org-table-number-regexp) ; defined in org-table.el
-(defun org-format-table-html (lines olines)
- "Find out which HTML converter to use and return the HTML code."
+(defun org-format-table-html (lines olines &optional no-css)
+ "Find out which HTML converter to use and return the HTML code.
+NO-CSS is passed to the exporter."
(if (stringp lines)
(setq lines (org-split-string lines "\n")))
(if (string-match "^[ \t]*|" (car lines))
;; A normal org table
- (org-format-org-table-html lines)
+ (org-format-org-table-html lines nil no-css)
;; Table made by table.el - test for spanning
(let* ((hlines (delq nil (mapcar
(lambda (x)
@@ -1572,8 +1866,12 @@ lang=\"%s\" xml:lang=\"%s\">
(org-format-table-table-html-using-table-generate-source olines)))))
(defvar org-table-number-fraction) ; defined in org-table.el
-(defun org-format-org-table-html (lines &optional splice)
- "Format a table into HTML."
+(defun org-format-org-table-html (lines &optional splice no-css)
+ "Format a table into HTML.
+LINES is a list of lines. Optional argument SPLICE means, do not
+insert header and surrounding <table> tags, just format the lines.
+Optional argument NO-CSS means use XHTML attributes instead of CSS
+for formatting. This is required for the DocBook exporter."
(require 'org-table)
;; Get rid of hlines at beginning and end
(if (string-match "^[ \t]*|-" (car lines)) (setq lines (cdr lines)))
@@ -1585,25 +1883,25 @@ lang=\"%s\" xml:lang=\"%s\">
;; column and the special lines
(setq lines (org-table-clean-before-export lines)))
- (let* ((caption (or (get-text-property 0 'org-caption (car lines))
- (get-text-property (or (next-single-property-change
- 0 'org-caption (car lines))
- 0)
- 'org-caption (car lines))))
- (attributes (or (get-text-property 0 'org-attributes (car lines))
- (get-text-property (or (next-single-property-change
- 0 'org-attributes (car lines))
- 0)
- 'org-attributes (car lines))))
+ (let* ((caption (org-find-text-property-in-string 'org-caption (car lines)))
+ (label (org-find-text-property-in-string 'org-label (car lines)))
+ (forced-aligns (org-find-text-property-in-string 'org-forced-aligns
+ (car lines)))
+ (attributes (org-find-text-property-in-string 'org-attributes
+ (car lines)))
(html-table-tag (org-export-splice-attributes
html-table-tag attributes))
(head (and org-export-highlight-first-table-line
(delq nil (mapcar
(lambda (x) (string-match "^[ \t]*|-" x))
(cdr lines)))))
-
- (nline 0) fnum i
- tbopen line fields html gr colgropen rowstart rowend)
+ (nline 0) fnum nfields i (cnt 0)
+ tbopen line fields html gr colgropen rowstart rowend
+ ali align aligns n)
+ (setq caption (and caption (org-html-do-expand caption)))
+ (when (and forced-aligns org-table-clean-did-remove-column)
+ (setq forced-aligns
+ (mapcar (lambda (x) (cons (1- (car x)) (cdr x))) forced-aligns)))
(if splice (setq head nil))
(unless splice (push (if head "<thead>" "<tbody>") html))
(setq tbopen t)
@@ -1619,30 +1917,34 @@ lang=\"%s\" xml:lang=\"%s\">
(throw 'next-line t)))
;; Break the line into fields
(setq fields (org-split-string line "[ \t]*|[ \t]*"))
- (unless fnum (setq fnum (make-vector (length fields) 0)))
+ (unless fnum (setq fnum (make-vector (length fields) 0)
+ nfields (length fnum)))
(setq nline (1+ nline) i -1
rowstart (eval (car org-export-table-row-tags))
rowend (eval (cdr org-export-table-row-tags)))
(push (concat rowstart
(mapconcat
(lambda (x)
- (setq i (1+ i))
- (if (and (< i nline)
+ (setq i (1+ i) ali (format "@@class%03d@@" i))
+ (if (and (< i nfields) ; make sure no rogue line causes an error here
(string-match org-table-number-regexp x))
(incf (aref fnum i)))
(cond
(head
(concat
- (format (car org-export-table-header-tags) "col")
+ (format (car org-export-table-header-tags)
+ "col" ali)
x
(cdr org-export-table-header-tags)))
((and (= i 0) org-export-html-table-use-header-tags-for-first-column)
(concat
- (format (car org-export-table-header-tags) "row")
+ (format (car org-export-table-header-tags)
+ "row" ali)
x
(cdr org-export-table-header-tags)))
(t
- (concat (car org-export-table-data-tags) x
+ (concat (format (car org-export-table-data-tags) ali)
+ x
(cdr org-export-table-data-tags)))))
fields "")
rowend)
@@ -1655,28 +1957,57 @@ lang=\"%s\" xml:lang=\"%s\">
(unless (car org-table-colgroup-info)
(setq org-table-colgroup-info
(cons :start (cdr org-table-colgroup-info))))
+ (setq i 0)
(push (mapconcat
(lambda (x)
- (setq gr (pop org-table-colgroup-info))
- (format "%s<col align=\"%s\" />%s"
+ (setq gr (pop org-table-colgroup-info)
+ i (1+ i)
+ align (if (assoc i forced-aligns)
+ (cdr (assoc (cdr (assoc i forced-aligns))
+ '(("l" . "left") ("r" . "right")
+ ("c" . "center"))))
+ (if (> (/ (float x) nline)
+ org-table-number-fraction)
+ "right" "left")))
+ (push align aligns)
+ (format (if no-css
+ "%s<col align=\"%s\" />%s"
+ "%s<col class=\"%s\" />%s")
(if (memq gr '(:start :startend))
(prog1
- (if colgropen "</colgroup>\n<colgroup>" "<colgroup>")
+ (if colgropen
+ "</colgroup>\n<colgroup>"
+ "<colgroup>")
(setq colgropen t))
"")
- (if (> (/ (float x) nline) org-table-number-fraction)
- "right" "left")
+ align
(if (memq gr '(:end :startend))
(progn (setq colgropen nil) "</colgroup>")
"")))
fnum "")
html)
- (if colgropen (setq html (cons (car html) (cons "</colgroup>" (cdr html)))))
+ (setq aligns (nreverse aligns))
+ (if colgropen (setq html (cons (car html)
+ (cons "</colgroup>" (cdr html)))))
;; Since the output of HTML table formatter can also be used in
;; DocBook document, we want to always include the caption to make
;; DocBook XML file valid.
(push (format "<caption>%s</caption>" (or caption "")) html)
+ (when label (push (format "<a name=\"%s\" id=\"%s\"></a>" label label)
+ html))
(push html-table-tag html))
+ (setq html (mapcar
+ (lambda (x)
+ (replace-regexp-in-string
+ "@@class\\([0-9]+\\)@@"
+ (lambda (txt)
+ (if (not org-export-html-table-align-individual-fields)
+ ""
+ (setq n (string-to-number (match-string 1 txt)))
+ (format (if no-css " align=\"%s\"" " class=\"%s\"")
+ (or (nth n aligns) "left"))))
+ x))
+ html))
(concat (mapconcat 'identity html "\n") "\n")))
(defun org-export-splice-attributes (tag attributes)
@@ -1721,10 +2052,10 @@ But it has the disadvantage, that no cell- or row-spanning is allowed."
(if (equal x "") (setq x empty))
(if head
(concat
- (format (car org-export-table-header-tags) "col")
+ (format (car org-export-table-header-tags) "col" "")
x
(cdr org-export-table-header-tags))
- (concat (car org-export-table-data-tags) x
+ (concat (format (car org-export-table-data-tags) "") x
(cdr org-export-table-data-tags))))
field-buffer "\n")
"</tr>\n"))
@@ -1845,7 +2176,7 @@ that uses these same face definitions."
(goto-char (point-min)))
(defun org-html-protect (s)
- ;; convert & to &amp;, < to &lt; and > to &gt;
+ "convert & to &amp;, < to &lt; and > to &gt;"
(let ((start 0))
(while (string-match "&" s start)
(setq s (replace-match "&amp;" t t s)
@@ -1860,19 +2191,21 @@ that uses these same face definitions."
s)
(defun org-html-expand (string)
- "Prepare STRING for HTML export. Applies all active conversions.
+ "Prepare STRING for HTML export. Apply all active conversions.
If there are links in the string, don't modify these."
(let* ((re (concat org-bracket-link-regexp "\\|"
- (org-re "[ \t]+\\(:[[:alnum:]_@:]+:\\)[ \t]*$")))
+ (org-re "[ \t]+\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$")))
m s l res)
- (while (setq m (string-match re string))
- (setq s (substring string 0 m)
- l (match-string 0 string)
- string (substring string (match-end 0)))
- (push (org-html-do-expand s) res)
- (push l res))
- (push (org-html-do-expand string) res)
- (apply 'concat (nreverse res))))
+ (if (string-match "^[ \t]*\\+-[-+]*\\+[ \t]*$" string)
+ string
+ (while (setq m (string-match re string))
+ (setq s (substring string 0 m)
+ l (match-string 0 string)
+ string (substring string (match-end 0)))
+ (push (org-html-do-expand s) res)
+ (push l res))
+ (push (org-html-do-expand string) res)
+ (apply 'concat (nreverse res)))))
(defun org-html-do-expand (s)
"Apply all active conversions to translate special ASCII to HTML."
@@ -1887,16 +2220,14 @@ If there are links in the string, don't modify these."
(if org-export-with-sub-superscripts
(setq s (org-export-html-convert-sub-super s)))
(if org-export-with-TeX-macros
- (let ((start 0) wd ass)
- (while (setq start (string-match "\\\\\\([a-zA-Z]+\\)\\({}\\)?"
+ (let ((start 0) wd rep)
+ (while (setq start (string-match "\\\\\\([a-zA-Z]+[0-9]*\\)\\({}\\)?"
s start))
(if (get-text-property (match-beginning 0) 'org-protected s)
(setq start (match-end 0))
(setq wd (match-string 1 s))
- (if (setq ass (assoc wd org-html-entities))
- (setq s (replace-match (or (cdr ass)
- (concat "&" (car ass) ";"))
- t t s))
+ (if (setq rep (org-entity-get-representation wd 'html))
+ (setq s (replace-match rep t t s))
(setq start (+ start (length wd))))))))
s)
@@ -1973,20 +2304,6 @@ If there are links in the string, don't modify these."
(defvar in-local-list)
(defvar local-list-indent)
(defvar local-list-type)
-(defun org-export-html-close-lists-maybe (line)
- (let ((ind (or (get-text-property 0 'original-indentation line)))
-; (and (string-match "\\S-" line)
-; (org-get-indentation line))))
- didclose)
- (when ind
- (while (and in-local-list
- (<= ind (car local-list-indent)))
- (setq didclose t)
- (org-close-li (car local-list-type))
- (insert (format "</%sl>\n" (car local-list-type)))
- (pop local-list-type) (pop local-list-indent)
- (setq in-local-list local-list-indent))
- (and didclose (org-open-par)))))
(defvar body-only) ; dynamically scoped into this.
(defun org-html-level-start (level title umax with-toc head-count)
@@ -1994,11 +2311,14 @@ If there are links in the string, don't modify these."
When TITLE is nil, just close all open levels."
(org-close-par-maybe)
(let* ((target (and title (org-get-text-property-any 0 'target title)))
- (extra-targets (assoc target org-export-target-aliases))
- (preferred (cdr (assoc target org-export-preferred-target-alist)))
+ (extra-targets (and target
+ (assoc target org-export-target-aliases)))
+ (extra-class (and title (org-get-text-property-any 0 'html-container-class title)))
+ (preferred (and target
+ (cdr (assoc target org-export-preferred-target-alist))))
(remove (or preferred target))
(l org-level-max)
- snumber href suffix)
+ snumber snu href suffix)
(setq extra-targets (remove remove extra-targets))
(setq extra-targets
(mapconcat (lambda (x)
@@ -2016,7 +2336,7 @@ When TITLE is nil, just close all open levels."
(when title
;; If title is nil, this means this function is called to close
;; all levels, so the rest is done only if title is given
- (when (string-match (org-re "\\(:[[:alnum:]_@:]+:\\)[ \t]*$") title)
+ (when (string-match (org-re "\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$") title)
(setq title (replace-match
(if org-export-with-tags
(save-match-data
@@ -2047,7 +2367,8 @@ When TITLE is nil, just close all open levels."
extra-targets title "<br/>\n")
(insert "<ul>\n<li>" title "<br/>\n"))))
(aset org-levels-open (1- level) t)
- (setq snumber (org-section-number level))
+ (setq snumber (org-section-number level)
+ snu (replace-regexp-in-string "\\." "_" snumber))
(setq level (+ level org-export-html-toplevel-hlevel -1))
(if (and org-export-with-section-numbers (not body-only))
(setq title (concat
@@ -2055,11 +2376,12 @@ When TITLE is nil, just close all open levels."
level snumber)
" " title)))
(unless (= head-count 1) (insert "\n</div>\n"))
- (setq href (cdr (assoc (concat "sec-" snumber) org-export-preferred-target-alist)))
- (setq suffix (or href snumber))
- (setq href (or href (concat "sec-" snumber)))
- (insert (format "\n<div id=\"outline-container-%s\" class=\"outline-%d\">\n<h%d id=\"%s\">%s%s</h%d>\n<div class=\"outline-text-%d\" id=\"text-%s\">\n"
- suffix level level href
+ (setq href (cdr (assoc (concat "sec-" snu) org-export-preferred-target-alist)))
+ (setq suffix (or href snu))
+ (setq href (or href (concat "sec-" snu)))
+ (insert (format "\n<div id=\"outline-container-%s\" class=\"outline-%d%s\">\n<h%d id=\"%s\">%s%s</h%d>\n<div class=\"outline-text-%d\" id=\"text-%s\">\n"
+ suffix level (if extra-class (concat " " extra-class) "")
+ level href
extra-targets
title level level suffix))
(org-open-par)))))
diff --git a/lisp/org/org-icalendar.el b/lisp/org/org-icalendar.el
index 29f358712fe..fe6e97c72dd 100644
--- a/lisp/org/org-icalendar.el
+++ b/lisp/org/org-icalendar.el
@@ -6,7 +6,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -26,8 +26,13 @@
;;
;;; Commentary:
+;;; Code:
+
(require 'org-exp)
+(eval-when-compile
+ (require 'cl))
+
(declare-function org-bbdb-anniv-export-ical "org-bbdb" nil)
(defgroup org-export-icalendar nil
@@ -42,13 +47,29 @@ The file name should be absolute, the file will be overwritten without warning."
:group 'org-export-icalendar
:type 'file)
+(defcustom org-icalendar-alarm-time 0
+ "Number of minutes for triggering an alarm for exported timed events.
+A zero value (the default) turns off the definition of an alarm trigger
+for timed events. If non-zero, alarms are created.
+
+- a single alarm per entry is defined
+- The alarm will go off N minutes before the event
+- only a DISPLAY action is defined."
+ :group 'org-export-icalendar
+ :type 'integer)
+
(defcustom org-icalendar-combined-name "OrgMode"
"Calendar name for the combined iCalendar representing all agenda files."
:group 'org-export-icalendar
:type 'string)
+(defcustom org-icalendar-combined-description nil
+ "Calendar description for the combined iCalendar (all agenda files)."
+ :group 'org-export-icalendar
+ :type 'string)
+
(defcustom org-icalendar-use-plain-timestamp t
- "Non-nil means, make an event from every plain time stamp."
+ "Non-nil means make an event from every plain time stamp."
:group 'org-export-icalendar
:type 'boolean)
@@ -104,7 +125,7 @@ all-tags All tags, including inherited ones."
(const :tag "All tags, including inherited ones" all-tags))))
(defcustom org-icalendar-include-todo nil
- "Non-nil means, export to iCalendar files should also cover TODO items.
+ "Non-nil means export to iCalendar files should also cover TODO items.
Valid values are:
nil don't include any TODO items
t include all TODO items that are not in a DONE state
@@ -129,13 +150,13 @@ up in the ics file. But for normal iCalendar export, you can use this
for whatever you need.")
(defcustom org-icalendar-include-bbdb-anniversaries nil
- "Non-nil means, a combined iCalendar files should include anniversaries.
+ "Non-nil means a combined iCalendar files should include anniversaries.
The anniversaries are define in the BBDB database."
:group 'org-export-icalendar
:type 'boolean)
(defcustom org-icalendar-include-sexps t
- "Non-nil means, export to iCalendar files should also cover sexp entries.
+ "Non-nil means export to iCalendar files should also cover sexp entries.
These are entries like in the diary, but directly in an Org-mode file."
:group 'org-export-icalendar
:type 'boolean)
@@ -152,12 +173,12 @@ The text will be inserted into the DESCRIPTION field."
(integer :tag "Max characters")))
(defcustom org-icalendar-store-UID nil
- "Non-nil means, store any created UIDs in properties.
+ "Non-nil means store any created UIDs in properties.
The iCalendar standard requires that all entries have a unique identifier.
Org will create these identifiers as needed. When this variable is non-nil,
the created UIDs will be stored in the ID property of the entry. Then the
next time this entry is exported, it will be exported with the same UID,
-superceding the previous form of it. This is essential for
+superseding the previous form of it. This is essential for
synchronization services.
This variable is not turned on by default because we want to avoid creating
a property drawer in every entry if people are only playing with this feature,
@@ -173,6 +194,13 @@ When nil of the empty string, use the abbreviation retrieved from Emacs."
(const :tag "Unspecified" nil)
(string :tag "Time zone")))
+(defcustom org-icalendar-use-UTC-date-time ()
+ "Non-nil force the use of the universal time for iCalendar DATE-TIME.
+The iCalendar DATE-TIME can be expressed with local time or universal Time,
+universal time could be more compatible with some external tools."
+ :group 'org-export-icalendar
+ :type 'boolean)
+
;;; iCalendar export
;;;###autoload
@@ -185,7 +213,7 @@ file, but with extension `.ics'."
;;;###autoload
(defun org-export-icalendar-all-agenda-files ()
- "Export all files in `org-agenda-files' to iCalendar .ics files.
+ "Export all files in the variable `org-agenda-files' to iCalendar .ics files.
Each iCalendar file will be located in the same directory as the Org-mode
file, but with extension `.ics'."
(interactive)
@@ -272,7 +300,7 @@ When COMBINE is non nil, add the category to each line."
"DTSTART"))
hd ts ts2 state status (inc t) pos b sexp rrule
scheduledp deadlinep todo prefix due start
- tmp pri categories location summary desc uid
+ tmp pri categories location summary desc uid alarm
(sexp-buffer (get-buffer-create "*ical-tmp*")))
(org-refresh-category-properties)
(save-excursion
@@ -290,7 +318,7 @@ When COMBINE is non nil, add the category to each line."
inc t
hd (condition-case nil
(org-icalendar-cleanup-string
- (org-get-heading))
+ (org-get-heading t))
(error (throw :skip nil)))
summary (org-icalendar-cleanup-string
(org-entry-get nil "SUMMARY"))
@@ -304,6 +332,7 @@ When COMBINE is non nil, add the category to each line."
(org-id-get-create)
(or (org-id-get) (org-id-new)))
categories (org-export-get-categories)
+ alarm ""
deadlinep nil scheduledp nil)
(if (looking-at re2)
(progn
@@ -352,6 +381,17 @@ When COMBINE is non nil, add the category to each line."
";INTERVAL=" (match-string 1 ts)))
(setq rrule ""))
(setq summary (or summary hd))
+ ;; create an alarm entry if the entry is timed. this is not very general in that:
+ ;; (a) only one alarm per entry is defined,
+ ;; (b) only minutes are allowed for the trigger period ahead of the start time, and
+ ;; (c) only a DISPLAY action is defined.
+ ;; [ESF]
+ (let ((t1 (ignore-errors (org-parse-time-string ts 'nodefault))))
+ (if (and (> org-icalendar-alarm-time 0)
+ (car t1) (nth 1 t1) (nth 2 t1))
+ (setq alarm (format "\nBEGIN:VALARM\nACTION:DISPLAY\nDESCRIPTION:%s\nTRIGGER:-P0D0H%dM0S\nEND:VALARM" summary org-icalendar-alarm-time))
+ (setq alarm ""))
+ )
(if (string-match org-bracket-link-regexp summary)
(setq summary
(replace-match (if (match-end 3)
@@ -368,7 +408,7 @@ UID: %s
%s
%s%s
SUMMARY:%s%s%s
-CATEGORIES:%s
+CATEGORIES:%s%s
END:VEVENT\n"
(concat prefix uid)
(org-ical-ts-to-string ts "DTSTART")
@@ -378,7 +418,8 @@ END:VEVENT\n"
(concat "\nDESCRIPTION: " desc) "")
(if (and location (string-match "\\S-" location))
(concat "\nLOCATION: " location) "")
- categories)))))
+ categories
+ alarm)))))
(when (and org-icalendar-include-sexps
(condition-case nil (require 'icalendar) (error nil))
(fboundp 'icalendar-export-region))
@@ -405,7 +446,7 @@ END:VEVENT\n"
(when org-icalendar-include-todo
(setq prefix "TODO-")
(goto-char (point-min))
- (while (re-search-forward org-todo-line-regexp nil t)
+ (while (re-search-forward org-complex-heading-regexp nil t)
(catch :skip
(org-agenda-skip)
(when org-icalendar-verify-function
@@ -437,7 +478,7 @@ END:VEVENT\n"
((eq org-icalendar-include-todo t)
;; include everything that is not done
(member state org-not-done-keywords))))
- (setq hd (match-string 3)
+ (setq hd (match-string 4)
summary (org-icalendar-cleanup-string
(org-entry-get nil "SUMMARY"))
desc (org-icalendar-cleanup-string
@@ -511,11 +552,12 @@ whitespace, newlines, drawers, and timestamps, and cut it down to MAXLENGTH
characters."
(if (not s)
nil
- (when is-body
+ (if is-body
(let ((re (concat "\\(" org-drawer-regexp "\\)[^\000]*?:END:.*\n?"))
(re2 (concat "^[ \t]*" org-keyword-time-regexp ".*\n?")))
(while (string-match re s) (setq s (replace-match "" t t s)))
- (while (string-match re2 s) (setq s (replace-match "" t t s)))))
+ (while (string-match re2 s) (setq s (replace-match "" t t s))))
+ (setq s (replace-regexp-in-string "[[:space:]]+" " " s)))
(let ((start 0))
(while (string-match "\\([,;]\\)" s start)
(setq start (+ (match-beginning 0) 2)
@@ -563,14 +605,16 @@ not used right now."
(name (or name "unknown"))
(timezone (if (> (length org-icalendar-timezone) 0)
org-icalendar-timezone
- (cadr (current-time-zone)))))
+ (cadr (current-time-zone))))
+ (description org-icalendar-combined-description))
(princ
(format "BEGIN:VCALENDAR
VERSION:2.0
X-WR-CALNAME:%s
PRODID:-//%s//Emacs with Org-mode//EN
X-WR-TIMEZONE:%s
-CALSCALE:GREGORIAN\n" name user timezone))))
+X-WR-CALDESC:%s
+CALSCALE:GREGORIAN\n" name user timezone description))))
(defun org-finish-icalendar-file ()
"Finish an iCalendar file by inserting the END statement."
@@ -581,22 +625,29 @@ CALSCALE:GREGORIAN\n" name user timezone))))
KEYWORD is added in front, to make a complete line like DTSTART....
When INC is non-nil, increase the hour by two (if time string contains
a time), or the day by one (if it does not contain a time)."
- (let ((t1 (org-parse-time-string s 'nodefault))
+ (let ((t1 (ignore-errors (org-parse-time-string s 'nodefault)))
t2 fmt have-time time)
- (if (and (car t1) (nth 1 t1) (nth 2 t1))
- (setq t2 t1 have-time t)
- (setq t2 (org-parse-time-string s)))
- (let ((s (car t2)) (mi (nth 1 t2)) (h (nth 2 t2))
- (d (nth 3 t2)) (m (nth 4 t2)) (y (nth 5 t2)))
- (when inc
- (if have-time
- (if org-agenda-default-appointment-duration
- (setq mi (+ org-agenda-default-appointment-duration mi))
- (setq h (+ 2 h)))
- (setq d (1+ d))))
- (setq time (encode-time s mi h d m y)))
- (setq fmt (if have-time ":%Y%m%dT%H%M%S" ";VALUE=DATE:%Y%m%d"))
- (concat keyword (format-time-string fmt time))))
+ (if (not t1)
+ ""
+ (if (and (car t1) (nth 1 t1) (nth 2 t1))
+ (setq t2 t1 have-time t)
+ (setq t2 (org-parse-time-string s)))
+ (let ((s (car t2)) (mi (nth 1 t2)) (h (nth 2 t2))
+ (d (nth 3 t2)) (m (nth 4 t2)) (y (nth 5 t2)))
+ (when inc
+ (if have-time
+ (if org-agenda-default-appointment-duration
+ (setq mi (+ org-agenda-default-appointment-duration mi))
+ (setq h (+ 2 h)))
+ (setq d (1+ d))))
+ (setq time (encode-time s mi h d m y)))
+ (setq fmt (if have-time (if org-icalendar-use-UTC-date-time
+ ":%Y%m%dT%H%M%SZ"
+ ":%Y%m%dT%H%M%S")
+ ";VALUE=DATE:%Y%m%d"))
+ (concat keyword (format-time-string fmt time
+ (and org-icalendar-use-UTC-date-time
+ have-time))))))
(provide 'org-icalendar)
diff --git a/lisp/org/org-id.el b/lisp/org/org-id.el
index 512c9a898db..fcca58831d1 100644
--- a/lisp/org/org-id.el
+++ b/lisp/org/org-id.el
@@ -5,7 +5,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -37,8 +37,9 @@
;; time of the ID, with microsecond accuracy. This virtually
;; guarantees globally unique identifiers, even if several people are
;; creating IDs at the same time in files that will eventually be used
-;; together. As an external method `uuidgen' is supported, if installed
-;; on the system.
+;; together.
+;;
+;; By default Org uses UUIDs as global unique identifiers.
;;
;; This file defines the following API:
;;
@@ -68,6 +69,8 @@
;; Find the location of an entry with specific id.
;;
+;;; Code:
+
(require 'org)
(declare-function message-make-fqdn "message" ())
@@ -84,18 +87,9 @@
:group 'org-id
:type 'string)
-(defcustom org-id-method
- (condition-case nil
- (if (string-match "\\`[-0-9a-fA-F]\\{36\\}\\'"
- (org-trim (shell-command-to-string
- org-id-uuid-program)))
- 'uuidgen
- 'org)
- (error 'org))
+(defcustom org-id-method 'uuid
"The method that should be used to create new IDs.
-If `uuidgen' is available on the system, it will be used as the default method.
-if not, the method `org' is used.
An ID will consist of the optional prefix specified in `org-id-prefix',
and a unique part created by the method this variable specifies.
@@ -105,11 +99,13 @@ org Org's own internal method, using an encoding of the current time to
microsecond accuracy, and optionally the current domain of the
computer. See the variable `org-id-include-domain'.
-uuidgen Call the external command uuidgen."
+uuid Create random (version 4) UUIDs. If the program defined in
+ `org-id-uuid-program' is available it is used to create the ID.
+ Otherwise an internal functions is used."
:group 'org-id
:type '(choice
(const :tag "Org's internal method" org)
- (const :tag "external: uuidgen" uuidgen)))
+ (const :tag "external: uuidgen" uuid)))
(defcustom org-id-prefix nil
"The prefix for IDs.
@@ -123,7 +119,7 @@ to have no space characters in them."
(string :tag "Prefix")))
(defcustom org-id-include-domain nil
- "Non-nil means, add the domain name to new IDs.
+ "Non-nil means add the domain name to new IDs.
This ensures global uniqueness of IDs, and is also suggested by
RFC 2445 in combination with RFC 822. This is only relevant if
`org-id-method' is `org'. When uuidgen is used, the domain will never
@@ -135,7 +131,7 @@ people to make this necessary."
:type 'boolean)
(defcustom org-id-track-globally t
- "Non-nil means, track IDs through files, so that links work globally.
+ "Non-nil means track IDs through files, so that links work globally.
This work by maintaining a hash table for IDs and writing this table
to disk when exiting Emacs. Because of this, it works best if you use
a single Emacs process, not many.
@@ -178,7 +174,7 @@ This variable is only relevant when `org-id-track-globally' is set."
(file))))
(defcustom org-id-search-archives t
- "Non-nil means, search also the archive files of agenda files for entries.
+ "Non-nil means search also the archive files of agenda files for entries.
This is a possibility to reduce overhead, but it means that entries moved
to the archives can no longer be found by ID.
This variable is only relevant when `org-id-track-globally' is set."
@@ -306,8 +302,10 @@ So a typical ID could look like \"Org:4nd91V40HI\"."
unique)
(if (equal prefix ":") (setq prefix ""))
(cond
- ((eq org-id-method 'uuidgen)
- (setq unique (org-trim (shell-command-to-string org-id-uuid-program))))
+ ((memq org-id-method '(uuidgen uuid))
+ (setq unique (org-trim (shell-command-to-string org-id-uuid-program)))
+ (unless (org-uuidgen-p unique)
+ (setq unique (org-id-uuid))))
((eq org-id-method 'org)
(let* ((etime (org-id-reverse-string (org-id-time-to-b36)))
(postfix (if org-id-include-domain
@@ -318,6 +316,30 @@ So a typical ID could look like \"Org:4nd91V40HI\"."
(t (error "Invalid `org-id-method'")))
(concat prefix unique)))
+(defun org-id-uuid ()
+ "Return string with random (version 4) UUID."
+ (let ((rnd (md5 (format "%s%s%s%s%s%s%s"
+ (random t)
+ (current-time)
+ (user-uid)
+ (emacs-pid)
+ (user-full-name)
+ user-mail-address
+ (recent-keys)))))
+ (format "%s-%s-4%s-%s%s-%s"
+ (substring rnd 0 8)
+ (substring rnd 8 12)
+ (substring rnd 13 16)
+ (format "%x"
+ (logior
+ #b10000000
+ (logand
+ #b10111111
+ (string-to-number
+ (substring rnd 16 18) 16))))
+ (substring rnd 18 20)
+ (substring rnd 20 32))))
+
(defun org-id-reverse-string (s)
(mapconcat 'char-to-string (nreverse (string-to-list s)) ""))
@@ -466,7 +488,7 @@ When CHECK is given, prepare detailed information about duplicate IDs."
(defun org-id-locations-save ()
"Save `org-id-locations' in `org-id-locations-file'."
- (when org-id-track-globally
+ (when (and org-id-track-globally org-id-locations)
(let ((out (if (hash-table-p org-id-locations)
(org-id-hash-to-alist org-id-locations)
org-id-locations)))
@@ -545,7 +567,9 @@ When CHECK is given, prepare detailed information about duplicate IDs."
(defun org-id-find-id-file (id)
"Query the id database for the file in which this ID is located."
(unless org-id-locations (org-id-locations-load))
- (or (gethash id org-id-locations)
+ (or (and org-id-locations
+ (hash-table-p org-id-locations)
+ (gethash id org-id-locations))
;; ball back on current buffer
(buffer-file-name (or (buffer-base-buffer (current-buffer))
(current-buffer)))))
@@ -572,10 +596,12 @@ optional argument MARKERP, return the position as a new marker."
;; Calling the following function is hard-coded into `org-store-link',
;; so we do have to add it to `org-store-link-functions'.
+;;;###autoload
(defun org-id-store-link ()
"Store a link to the current entry, using its ID."
(interactive)
(let* ((link (org-make-link "id:" (org-id-get-create)))
+ (case-fold-search nil)
(desc (save-excursion
(org-back-to-heading t)
(or (and (looking-at org-complex-heading-regexp)
diff --git a/lisp/org/org-indent.el b/lisp/org/org-indent.el
index d3fcec4c26f..39ba445eb93 100644
--- a/lisp/org/org-indent.el
+++ b/lisp/org/org-indent.el
@@ -4,7 +4,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -29,22 +29,24 @@
;; by adding text properties to a buffer to make sure lines are
;; indented according to outline structure.
+;;; Code:
+
(require 'org-macs)
(require 'org-compat)
(require 'org)
+
(eval-when-compile
(require 'cl))
-
(defgroup org-indent nil
"Options concerning dynamic virtual outline indentation."
- :tag "Org Structure"
+ :tag "Org Indent"
:group 'org)
(defconst org-indent-max 40
- "Maximum indentation in characters")
+ "Maximum indentation in characters.")
(defconst org-indent-max-levels 40
- "Maximum indentation in characters")
+ "Maximum indentation in characters.")
(defvar org-indent-strings nil
"Vector with all indentation strings.
@@ -53,7 +55,7 @@ It will be set in `org-indent-initialize'.")
"Vector with all indentation star strings.
It will be set in `org-indent-initialize'.")
(defvar org-hide-leading-stars-before-indent-mode nil
- "Used locally")
+ "Used locally.")
(defcustom org-indent-boundary-char ?\ ; comment to protect space char
"The end of the virtual indentation strings, a single-character string.
@@ -67,13 +69,15 @@ it may be prettier to customize the org-indent face."
:type 'character)
(defcustom org-indent-mode-turns-off-org-adapt-indentation t
- "Non-nil means, turning on org-indent-mode turns off indentation adaptation.
+ "Non-nil means setting the variable `org-indent-mode' will \
+turn off indentation adaptation.
For details see the variable `org-adapt-indentation'."
:group 'org-indent
:type 'boolean)
(defcustom org-indent-mode-turns-on-hiding-stars t
- "Non-nil means, turning on org-indent-mode turns on `org-hide-leading-stars'."
+ "Non-nil means setting the variable `org-indent-mode' will \
+turn on `org-hide-leading-stars'."
:group 'org-indent
:type 'boolean)
@@ -127,44 +131,57 @@ Internally this works by adding `line-prefix' properties to all non-headlines.
These properties are updated locally in idle time.
FIXME: How to update when broken?"
nil " Ind" nil
- (if (org-bound-and-true-p org-inhibit-startup)
- (setq org-indent-mode nil)
- (if org-indent-mode
- (progn
- (or org-indent-strings (org-indent-initialize))
- (when org-indent-mode-turns-off-org-adapt-indentation
- (org-set-local 'org-adapt-indentation nil))
- (when org-indent-mode-turns-on-hiding-stars
- (org-set-local 'org-hide-leading-stars-before-indent-mode
- org-hide-leading-stars)
- (org-set-local 'org-hide-leading-stars t))
- (make-local-variable 'buffer-substring-filters)
- (add-to-list 'buffer-substring-filters
- 'org-indent-remove-properties-from-string)
- (org-add-hook 'org-after-demote-entry-hook
- 'org-indent-refresh-section nil 'local)
- (org-add-hook 'org-after-promote-entry-hook
- 'org-indent-refresh-section nil 'local)
- (org-add-hook 'org-font-lock-hook
- 'org-indent-refresh-to nil 'local)
- (and font-lock-mode (org-restart-font-lock))
- )
- (save-excursion
- (save-restriction
- (org-indent-remove-properties (point-min) (point-max))
- (kill-local-variable 'org-adapt-indentation)
- (when (boundp 'org-hide-leading-stars-before-indent-mode)
- (org-set-local 'org-hide-leading-stars
- org-hide-leading-stars-before-indent-mode))
- (setq buffer-substring-filters
- (delq 'org-indent-remove-properties-from-string
- buffer-substring-filters))
- (remove-hook 'org-after-promote-entry-hook
- 'org-indent-refresh-section 'local)
- (remove-hook 'org-after-demote-entry-hook
- 'org-indent-refresh-section 'local)
- (and font-lock-mode (org-restart-font-lock))
- (redraw-display))))))
+ (cond
+ ((org-bound-and-true-p org-inhibit-startup)
+ (setq org-indent-mode nil))
+ ((and org-indent-mode (featurep 'xemacs))
+ (message "org-indent-mode does not work in XEmacs - refusing to turn it on")
+ (setq org-indent-mode nil))
+ ((and org-indent-mode
+ (not (org-version-check "23.1.50" "Org Indent mode" :predicate)))
+ (message "org-indent-mode can crash Emacs 23.1 - refusing to turn it on!")
+ (ding)
+ (sit-for 1)
+ (setq org-indent-mode nil))
+ (org-indent-mode
+ ;; mode was turned on.
+ (org-set-local 'indent-tabs-mode nil)
+ (or org-indent-strings (org-indent-initialize))
+ (when org-indent-mode-turns-off-org-adapt-indentation
+ (org-set-local 'org-adapt-indentation nil))
+ (when org-indent-mode-turns-on-hiding-stars
+ (org-set-local 'org-hide-leading-stars-before-indent-mode
+ org-hide-leading-stars)
+ (org-set-local 'org-hide-leading-stars t))
+ (make-local-variable 'buffer-substring-filters)
+ (add-to-list 'buffer-substring-filters
+ 'org-indent-remove-properties-from-string)
+ (org-add-hook 'org-after-demote-entry-hook
+ 'org-indent-refresh-section nil 'local)
+ (org-add-hook 'org-after-promote-entry-hook
+ 'org-indent-refresh-section nil 'local)
+ (org-add-hook 'org-font-lock-hook
+ 'org-indent-refresh-to nil 'local)
+ (and font-lock-mode (org-restart-font-lock))
+ )
+ (t
+ ;; mode was turned off (or we refused to turn it on)
+ (save-excursion
+ (save-restriction
+ (org-indent-remove-properties (point-min) (point-max))
+ (kill-local-variable 'org-adapt-indentation)
+ (when (boundp 'org-hide-leading-stars-before-indent-mode)
+ (org-set-local 'org-hide-leading-stars
+ org-hide-leading-stars-before-indent-mode))
+ (setq buffer-substring-filters
+ (delq 'org-indent-remove-properties-from-string
+ buffer-substring-filters))
+ (remove-hook 'org-after-promote-entry-hook
+ 'org-indent-refresh-section 'local)
+ (remove-hook 'org-after-demote-entry-hook
+ 'org-indent-refresh-section 'local)
+ (and font-lock-mode (org-restart-font-lock))
+ (redraw-display))))))
(defface org-indent
@@ -186,8 +203,9 @@ useful to make it ever so slightly different."
(defun org-indent-remove-properties (beg end)
"Remove indentations between BEG and END."
- (org-unmodified
- (remove-text-properties beg end '(line-prefix nil wrap-prefix nil))))
+ (let ((inhibit-modification-hooks t))
+ (with-silent-modifications
+ (remove-text-properties beg end '(line-prefix nil wrap-prefix nil)))))
(defun org-indent-remove-properties-from-string (string)
"Remove indentations between BEG and END."
@@ -202,8 +220,9 @@ useful to make it ever so slightly different."
"Add indentation properties between BEG and END.
Assumes that BEG is at the beginning of a line."
(when (or t org-indent-mode)
- (let (ov b e n level exit nstars)
- (org-unmodified
+ (let ((inhibit-modification-hooks t)
+ ov b e n level exit nstars)
+ (with-silent-modifications
(save-excursion
(goto-char beg)
(while (not exit)
@@ -227,7 +246,7 @@ Assumes that BEG is at the beginning of a line."
b e (list 'line-prefix (aref org-indent-strings n)
'wrap-prefix (aref org-indent-strings n))))
(setq b (1+ (point-at-eol))
- n (* level org-indent-indentation-per-level))))))))
+ n (* (or level 0) org-indent-indentation-per-level))))))))
(defun org-indent-refresh-section ()
"Refresh indentation properties in the current outline section.
diff --git a/lisp/org/org-info.el b/lisp/org/org-info.el
index 1b620714abd..6ea192b1765 100644
--- a/lisp/org/org-info.el
+++ b/lisp/org/org-info.el
@@ -6,7 +6,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
diff --git a/lisp/org/org-inlinetask.el b/lisp/org/org-inlinetask.el
index 8334057a0b5..29d8c40eed2 100644
--- a/lisp/org/org-inlinetask.el
+++ b/lisp/org/org-inlinetask.el
@@ -5,7 +5,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;; This file is part of GNU Emacs.
@@ -33,7 +33,7 @@
;; and properties. However, these nodes are treated specially by the
;; visibility cycling and export commands.
;;
-;; Visibility cycling exempts these nodes from cycling. So whenever their
+;; Visibility cycling exempts these nodes from cycling. So whenever their
;; parent is opened, so are these tasks. This will only work with
;; `org-cycle', so if you are also using other commands to show/hide
;; entries, you will occasionally find these tasks to behave like
@@ -74,8 +74,7 @@
;;
;; C-c C-x t Insert a new inline task with END line
-
-;;; Code
+;;; Code:
(require 'org)
@@ -91,10 +90,12 @@ or to a number smaller than this one. In fact, when `org-cycle-max-level' is
not set, it will be assumed to be one less than the value of smaller than
the value of this variable."
:group 'org-inlinetask
- :type 'boolean)
+ :type '(choice
+ (const :tag "Off" nil)
+ (integer)))
(defcustom org-inlinetask-export t
- "Non-nil means, export inline tasks.
+ "Non-nil means export inline tasks.
When nil, they will not be exported."
:group 'org-inlinetask
:type 'boolean)
@@ -105,15 +106,47 @@ When nil, they will not be exported."
(defvar org-complex-heading-regexp)
(defvar org-property-end-re)
-(defun org-inlinetask-insert-task ()
- "Insert an inline task."
- (interactive)
+(defcustom org-inlinetask-default-state nil
+ "Non-nil means make inline tasks have a TODO keyword initially.
+This should be the state `org-inlinetask-insert-task' should use by
+default, or nil of no state should be assigned."
+ :group 'org-inlinetask
+ :type '(choice
+ (const :tag "No state" nil)
+ (string :tag "Specific state")))
+
+(defun org-inlinetask-insert-task (&optional no-state)
+ "Insert an inline task.
+If prefix arg NO-STATE is set, ignore `org-inlinetask-default-state'."
+ (interactive "P")
(or (bolp) (newline))
- (insert (make-string org-inlinetask-min-level ?*) " \n"
- (make-string org-inlinetask-min-level ?*) " END\n")
+ (let ((indent org-inlinetask-min-level))
+ (if org-odd-levels-only
+ (setq indent (- (* 2 indent) 1)))
+ (insert (make-string indent ?*)
+ (if (or no-state (not org-inlinetask-default-state))
+ " \n"
+ (concat " " org-inlinetask-default-state " \n"))
+ (make-string indent ?*) " END\n"))
(end-of-line -1))
(define-key org-mode-map "\C-c\C-xt" 'org-inlinetask-insert-task)
+(defun org-inlinetask-in-task-p ()
+ "Return true if point is inside an inline task."
+ (save-excursion
+ (let* ((nstars (if org-odd-levels-only
+ (1- (* 2 (or org-inlinetask-min-level 200)))
+ (or org-inlinetask-min-level 200)))
+ (stars-re (concat "^\\(?:\\*\\{"
+ (format "%d" (- nstars 1))
+ ",\\}\\)[ \t]+"))
+ (task-beg-re (concat stars-re "\\(?:.*\\)"))
+ (task-end-re (concat stars-re "\\(?:END\\|end\\)")))
+ (beginning-of-line)
+ (or (looking-at task-beg-re)
+ (and (re-search-forward "^\\*+[ \t]+" nil t)
+ (progn (beginning-of-line) (looking-at task-end-re)))))))
+
(defvar htmlp) ; dynamically scoped into the next function
(defvar latexp) ; dynamically scoped into the next function
(defun org-inlinetask-export-handler ()
@@ -149,7 +182,17 @@ Either remove headline and meta data, or do special formatting."
(when (string-match org-complex-heading-regexp headline)
(setq headline (concat
(if (match-end 2)
- (concat (match-string 2 headline) " ") "")
+ (concat
+ (org-add-props
+ (format
+ "@<span class=\"%s %s\"> %s@</span>"
+ (if (member (match-string 2 headline)
+ org-done-keywords)
+ "done" "todo")
+ (match-string 2 headline)
+ (match-string 2 headline))
+ nil 'org-protected t)
+ " ") "")
(match-string 4 headline)))
(when content
(if (not (string-match "\\S-" content))
@@ -232,5 +275,4 @@ Either remove headline and meta data, or do special formatting."
(provide 'org-inlinetask)
-;; arch-tag: 59fdac51-8bcc-469e-a21e-6897dd6697bb
;;; org-inlinetask.el ends here
diff --git a/lisp/org/org-irc.el b/lisp/org/org-irc.el
index d1822d05c05..3dd9680c8ff 100644
--- a/lisp/org/org-irc.el
+++ b/lisp/org/org-irc.el
@@ -4,7 +4,7 @@
;;
;; Author: Philip Jackson <emacs@shellarchive.co.uk>
;; Keywords: erc, irc, link, org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
diff --git a/lisp/org/org-jsinfo.el b/lisp/org/org-jsinfo.el
index a3158adec3f..d435d814679 100644
--- a/lisp/org/org-jsinfo.el
+++ b/lisp/org/org-jsinfo.el
@@ -6,7 +6,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -26,12 +26,12 @@
;;
;;; Commentary:
-;; This file implements the support for Sebastian Rose's Javascript
+;; This file implements the support for Sebastian Rose's JavaScript
;; org-info.js to display an org-mode file exported to HTML in an
;; Info-like way, or using folding similar to the outline structure
;; org org-mode itself.
-;; Documentation for using this module is in the Org manual. The script
+;; Documentation for using this module is in the Org manual. The script
;; itself is documented by Sebastian Rose in a file distributed with
;; the script. FIXME: Accurate pointers!
@@ -87,7 +87,7 @@ line in the buffer. See also the variable `org-infojs-options'."
(defcustom org-infojs-options
(mapcar (lambda (x) (cons (car x) (nth 2 x)))
org-infojs-opts-table)
- "Options settings for the INFOJS Javascript.
+ "Options settings for the INFOJS JavaScript.
Each of the options must have an entry in `org-export-html/infojs-opts-table'.
The value can either be a string that will be passed to the script, or
a property. This property is then assumed to be a property that is defined
diff --git a/lisp/org/org-latex.el b/lisp/org/org-latex.el
index ffec1be7a56..2cf947312d8 100644
--- a/lisp/org/org-latex.el
+++ b/lisp/org/org-latex.el
@@ -4,7 +4,7 @@
;;
;; Emacs Lisp Archive Entry
;; Filename: org-latex.el
-;; Version: 6.33x
+;; Version: 7.3
;; Author: Bastien Guerry <bzg AT altern DOT org>
;; Maintainer: Carsten Dominik <carsten.dominik AT gmail DOT com>
;; Keywords: org, wp, tex
@@ -50,9 +50,11 @@
(require 'org)
(require 'org-exp)
(require 'org-macs)
+(require 'org-beamer)
;;; Variables:
(defvar org-export-latex-class nil)
+(defvar org-export-latex-class-options nil)
(defvar org-export-latex-header nil)
(defvar org-export-latex-append-header nil)
(defvar org-export-latex-options-plist nil)
@@ -89,53 +91,30 @@
(defcustom org-export-latex-classes
'(("article"
- "\\documentclass[11pt]{article}
-\\usepackage[utf8]{inputenc}
-\\usepackage[T1]{fontenc}
-\\usepackage{graphicx}
-\\usepackage{longtable}
-\\usepackage{float}
-\\usepackage{wrapfig}
-\\usepackage{soul}
-\\usepackage{amssymb}
-\\usepackage{hyperref}"
+ "\\documentclass[11pt]{article}"
("\\section{%s}" . "\\section*{%s}")
("\\subsection{%s}" . "\\subsection*{%s}")
("\\subsubsection{%s}" . "\\subsubsection*{%s}")
("\\paragraph{%s}" . "\\paragraph*{%s}")
("\\subparagraph{%s}" . "\\subparagraph*{%s}"))
("report"
- "\\documentclass[11pt]{report}
-\\usepackage[utf8]{inputenc}
-\\usepackage[T1]{fontenc}
-\\usepackage{graphicx}
-\\usepackage{longtable}
-\\usepackage{float}
-\\usepackage{wrapfig}
-\\usepackage{soul}
-\\usepackage{amssymb}
-\\usepackage{hyperref}"
+ "\\documentclass[11pt]{report}"
("\\part{%s}" . "\\part*{%s}")
("\\chapter{%s}" . "\\chapter*{%s}")
("\\section{%s}" . "\\section*{%s}")
("\\subsection{%s}" . "\\subsection*{%s}")
("\\subsubsection{%s}" . "\\subsubsection*{%s}"))
("book"
- "\\documentclass[11pt]{book}
-\\usepackage[utf8]{inputenc}
-\\usepackage[T1]{fontenc}
-\\usepackage{graphicx}
-\\usepackage{longtable}
-\\usepackage{float}
-\\usepackage{wrapfig}
-\\usepackage{soul}
-\\usepackage{amssymb}
-\\usepackage{hyperref}"
+ "\\documentclass[11pt]{book}"
("\\part{%s}" . "\\part*{%s}")
("\\chapter{%s}" . "\\chapter*{%s}")
("\\section{%s}" . "\\section*{%s}")
("\\subsection{%s}" . "\\subsection*{%s}")
- ("\\subsubsection{%s}" . "\\subsubsection*{%s}")))
+ ("\\subsubsection{%s}" . "\\subsubsection*{%s}"))
+ ("beamer"
+ "\\documentclass{beamer}"
+ org-beamer-sectioning
+ ))
"Alist of LaTeX classes and associated header and structure.
If #+LaTeX_CLASS is set in the buffer, use its value and the
associated information. Here is the structure of each cell:
@@ -145,11 +124,60 @@ associated information. Here is the structure of each cell:
(numbered-section . unnumbered-section\)
...\)
-A %s formatter is mandatory in each section string and will be
-replaced by the title of the section.
+The header string
+-----------------
+
+The HEADER-STRING is the header that will be inserted into the LaTeX file.
+It should contain the \\documentclass macro, and anything else that is needed
+for this setup. To this header, the following commands will be added:
+
+- Calls to \\usepackage for all packages mentioned in the variables
+ `org-export-latex-default-packages-alist' and
+ `org-export-latex-packages-alist'. Thus, your header definitions should
+ avoid to also request these packages.
+
+- Lines specified via \"#+LaTeX_HEADER:\"
+
+If you need more control about the sequence in which the header is built
+up, or if you want to exclude one of these building blocks for a particular
+class, you can use the following macro-like placeholders.
+
+ [DEFAULT-PACKAGES] \\usepackage statements for default packages
+ [NO-DEFAULT-PACKAGES] do not include any of the default packages
+ [PACKAGES] \\usepackage statements for packages
+ [NO-PACKAGES] do not include the packages
+ [EXTRA] the stuff from #+LaTeX_HEADER
+ [NO-EXTRA] do not include #+LaTeX_HEADER stuff
+ [BEAMER-HEADER-EXTRA] the beamer extra headers
+
+So a header like
+
+ \\documentclass{article}
+ [NO-DEFAULT-PACKAGES]
+ [EXTRA]
+ \\providecommand{\\alert}[1]{\\textbf{#1}}
+ [PACKAGES]
+
+will omit the default packages, and will include the #+LaTeX_HEADER lines,
+then have a call to \\providecommand, and then place \\usepackage commands
+based on the content of `org-export-latex-packages-alist'.
+
+If your header or `org-export-latex-default-packages-alist' inserts
+\"\\usepackage[AUTO]{inputenc}\", AUTO will automatically be replaced with
+a coding system derived from `buffer-file-coding-system'. See also the
+variable `org-export-latex-inputenc-alist' for a way to influence this
+mechanism.
+
+The sectioning structure
+------------------------
+
+The sectioning structure of the class is given by the elements following
+the header string. For each sectioning level, a number of strings is
+specified. A %s formatter is mandatory in each section string and will
+be replaced by the title of the section.
Instead of a cons cell (numbered . unnumbered), you can also provide a list
-of 2-4 elements,
+of 2 or 4 elements,
(numbered-open numbered-close)
@@ -157,9 +185,15 @@ or
(numbered-open numbered-close unnumbered-open unnumbered-close)
-providing opening and closing strings for an environment that should
+providing opening and closing strings for a LaTeX environment that should
represent the document section. The opening clause should have a %s
-to represent the section title."
+to represent the section title.
+
+Instead of a list of sectioning commands, you can also specify a
+function name. That function will be called with two parameters,
+the (reduced) level of the headline, and the headline text. The function
+must return a cons cell with the (possibly modified) headline text, and the
+sectioning list in the cdr."
:group 'org-export-latex
:type '(repeat
(list (string :tag "LaTeX class")
@@ -167,13 +201,29 @@ to represent the section title."
(repeat :tag "Levels" :inline t
(choice
(cons :tag "Heading"
- (string :tag "numbered")
- (string :tag "unnumbered)"))
+ (string :tag " numbered")
+ (string :tag "unnumbered"))
(list :tag "Environment"
- (string :tag "Opening (numbered) ")
- (string :tag "Closing (numbered) ")
+ (string :tag "Opening (numbered)")
+ (string :tag "Closing (numbered)")
(string :tag "Opening (unnumbered)")
- (string :tag "Closing (unnumbered)")))))))
+ (string :tag "Closing (unnumbered)"))
+ (function :tag "Hook computing sectioning"))))))
+
+(defcustom org-export-latex-inputenc-alist nil
+ "Alist of inputenc coding system names, and what should really be used.
+For example, adding an entry
+
+ (\"utf8\" . \"utf8x\")
+
+will cause \\usepackage[utf8x]{inputenc} to be used for buffers that
+are written as utf8 files."
+ :group 'org-export-latex
+ :type '(repeat
+ (cons
+ (string :tag "Derived from buffer")
+ (string :tag "Use this instead"))))
+
(defcustom org-export-latex-emphasis-alist
'(("*" "\\textbf{%s}" nil)
@@ -230,6 +280,11 @@ markup defined, the first one in the association list will be used."
(string :tag "Keyword")
(string :tag "Markup")))))
+(defcustom org-export-latex-tag-markup "\\textbf{%s}"
+ "Markup for tags, as a printf format."
+ :group 'org-export-latex
+ :type 'string)
+
(defcustom org-export-latex-timestamp-markup "\\textit{%s}"
"A printf format string to be applied to time stamps."
:group 'org-export-latex
@@ -240,6 +295,13 @@ markup defined, the first one in the association list will be used."
:group 'org-export-latex
:type 'string)
+(defcustom org-export-latex-hyperref-format "\\href{%s}{%s}"
+ "A printf format string to be applied to hyperref links.
+The format must contain two %s instances. The first will be filled with
+the link, the second with the link description."
+ :group 'org-export-latex
+ :type 'string)
+
(defcustom org-export-latex-tables-verbatim nil
"When non-nil, tables are exported verbatim."
:group 'org-export-latex
@@ -305,7 +367,7 @@ Defaults to \\begin{verbatim} and \\end{verbatim}."
(string :tag "Close")))
(defcustom org-export-latex-listings nil
- "Non-nil means, export source code using the listings package.
+ "Non-nil means export source code using the listings package.
This package will fontify source code, possibly even with color.
If you want to use this, you also need to make LaTeX use the
listings package, and if you want to have color, the color
@@ -314,12 +376,30 @@ for example using customize, or with something like
(require 'org-latex)
(add-to-list 'org-export-latex-packages-alist '(\"\" \"listings\"))
- (add-to-list 'org-export-latex-packages-alist '(\"\" \"color\"))"
+ (add-to-list 'org-export-latex-packages-alist '(\"\" \"color\"))
+
+Alternatively,
+
+ (setq org-export-latex-listings 'minted)
+
+causes source code to be exported using the minted package as
+opposed to listings. If you want to use minted, you need to add
+the minted package to `org-export-latex-packages-alist', for
+example using customize, or with
+
+ (require 'org-latex)
+ (add-to-list 'org-export-latex-packages-alist '(\"\" \"minted\"))
+
+In addition, it is neccessary to install
+pygments (http://pygments.org), and to configure
+`org-latex-to-pdf-process' so that the -shell-escape option is
+passed to pdflatex.
+"
:group 'org-export-latex
:type 'boolean)
(defcustom org-export-latex-listings-langs
- '((emacs-lisp "Lisp") (lisp "Lisp")
+ '((emacs-lisp "Lisp") (lisp "Lisp") (clojure "Lisp")
(c "C") (cc "C++")
(fortran "fortran")
(perl "Perl") (cperl "Perl") (python "Python") (ruby "Ruby")
@@ -328,7 +408,7 @@ for example using customize, or with something like
(shell-script "bash")
(gnuplot "Gnuplot")
(ocaml "Caml") (caml "Caml")
- (sql "SQL"))
+ (sql "SQL") (sqlite "sql"))
"Alist mapping languages to their listing language counterpart.
The key is a symbol, the major mode symbol without the \"-mode\".
The value is the string that should be inserted as the language parameter
@@ -341,9 +421,47 @@ hurt if it is present."
(symbol :tag "Major mode ")
(string :tag "Listings language"))))
+(defcustom org-export-latex-listings-w-names t
+ "Non-nil means export names of named code blocks.
+Code blocks exported with the listings package (controlled by the
+`org-export-latex-listings' variable) can be named in the style
+of noweb."
+ :group 'org-export-latex
+ :type 'boolean)
+
+(defcustom org-export-latex-minted-langs
+ '((emacs-lisp "common-lisp")
+ (cc "c++")
+ (cperl "perl")
+ (shell-script "bash")
+ (caml "ocaml"))
+ "Alist mapping languages to their minted language counterpart.
+The key is a symbol, the major mode symbol without the \"-mode\".
+The value is the string that should be inserted as the language parameter
+for the minted package. If the mode name and the listings name are
+the same, the language does not need an entry in this list - but it does not
+hurt if it is present.
+
+Note that minted uses all lower case for language identifiers,
+and that the full list of language identifiers can be obtained
+with:
+pygmentize -L lexers
+"
+ :group 'org-export-latex
+ :type '(repeat
+ (list
+ (symbol :tag "Major mode ")
+ (string :tag "Listings language"))))
+
+(defcustom org-export-latex-minted-with-line-numbers nil
+ "Should source code line numbers be included when exporting
+with the latex minted package?"
+ :group 'org-export-latex
+ :type 'boolean)
+
(defcustom org-export-latex-remove-from-headlines
'(:todo nil :priority nil :tags nil)
- "A plist of keywords to remove from headlines. OBSOLETE.
+ "A plist of keywords to remove from headlines. OBSOLETE.
Non-nil means remove this keyword type from the headline.
Don't remove the keys, just change their values.
@@ -359,6 +477,11 @@ and `org-export-with-tags' instead."
:group 'org-export-latex
:type 'string)
+(defcustom org-export-latex-tabular-environment "tabular"
+ "Default environment used to build tables."
+ :group 'org-export-latex
+ :type 'string)
+
(defcustom org-export-latex-inline-image-extensions
'("pdf" "jpeg" "jpg" "png" "ps" "eps")
"Extensions of image files that can be inlined into LaTeX.
@@ -370,50 +493,93 @@ allowed. The default we use here encompasses both."
:type '(repeat (string :tag "Extension")))
(defcustom org-export-latex-coding-system nil
- "Coding system for the exported LaTex file."
+ "Coding system for the exported LaTeX file."
:group 'org-export-latex
:type 'coding-system)
(defgroup org-export-pdf nil
"Options for exporting Org-mode files to PDF, via LaTeX."
- :tag "Org Export LaTeX"
+ :tag "Org Export PDF"
:group 'org-export-latex
:group 'org-export)
(defcustom org-latex-to-pdf-process
- '("pdflatex -interaction nonstopmode %s"
- "pdflatex -interaction nonstopmode %s")
+ '("pdflatex -interaction nonstopmode -output-directory %o %f"
+ "pdflatex -interaction nonstopmode -output-directory %o %f"
+ "pdflatex -interaction nonstopmode -output-directory %o %f")
"Commands to process a LaTeX file to a PDF file.
This is a list of strings, each of them will be given to the shell
-as a command. %s in the command will be replaced by the full file name, %b
-by the file base name (i.e. without extension).
+as a command. %f in the command will be replaced by the full file name, %b
+by the file base name (i.e. without extension) and %o by the base directory
+of the file.
+
The reason why this is a list is that it usually takes several runs of
-pdflatex, maybe mixed with a call to bibtex. Org does not have a clever
+`pdflatex', maybe mixed with a call to `bibtex'. Org does not have a clever
mechanism to detect which of these commands have to be run to get to a stable
result, and it also does not do any error checking.
+By default, Org uses 3 runs of `pdflatex' to do the processing. If you
+have texi2dvi on your system and if that does not cause the infamous
+egrep/locale bug:
+
+ http://lists.gnu.org/archive/html/bug-texinfo/2010-03/msg00031.html
+
+then `texi2dvi' is the superior choice. Org does offer it as one
+of the customize options.
+
Alternatively, this may be a Lisp function that does the processing, so you
could use this to apply the machinery of AUCTeX or the Emacs LaTeX mode.
This function should accept the file name as its single argument."
- :group 'org-export-latex
- :type '(choice (repeat :tag "Shell command sequence"
+ :group 'org-export-pdf
+ :type '(choice
+ (repeat :tag "Shell command sequence"
(string :tag "Shell command"))
- (function)))
+ (const :tag "2 runs of pdflatex"
+ ("pdflatex -interaction nonstopmode -output-directory %o %f"
+ "pdflatex -interaction nonstopmode -output-directory %o %f"))
+ (const :tag "3 runs of pdflatex"
+ ("pdflatex -interaction nonstopmode -output-directory %o %f"
+ "pdflatex -interaction nonstopmode -output-directory %o %f"
+ "pdflatex -interaction nonstopmode -output-directory %o %f"))
+ (const :tag "pdflatex,bibtex,pdflatex,pdflatex"
+ ("pdflatex -interaction nonstopmode -output-directory %o %f"
+ "bibtex %b"
+ "pdflatex -interaction nonstopmode -output-directory %o %f"
+ "pdflatex -interaction nonstopmode -output-directory %o %f"))
+ (const :tag "texi2dvi"
+ ("texi2dvi -p -b -c -V %f"))
+ (const :tag "rubber"
+ ("rubber -d --into %o %f"))
+ (function)))
+
+(defcustom org-export-pdf-logfiles
+ '("aux" "idx" "log" "out" "toc" "nav" "snm" "vrb")
+ "The list of file extensions to consider as LaTeX logfiles."
+ :group 'org-export-pdf
+ :type '(repeat (string :tag "Extension")))
(defcustom org-export-pdf-remove-logfiles t
- "Non-nil means, remove the logfiles produced by PDF production.
+ "Non-nil means remove the logfiles produced by PDF production.
These are the .aux, .log, .out, and .toc files."
:group 'org-export-pdf
:type 'boolean)
;;; Hooks
+(defvar org-export-latex-after-initial-vars-hook nil
+ "Hook run before LaTeX export.
+The exact moment is after the initial variables like org-export-latex-class
+have been determined from the environment.")
+
(defvar org-export-latex-after-blockquotes-hook nil
"Hook run during LaTeX export, after blockquote, verse, center are done.")
(defvar org-export-latex-final-hook nil
"Hook run in the finalized LaTeX buffer.")
+(defvar org-export-latex-after-save-hook nil
+ "Hook run in the finalized LaTeX buffer, after it has been saved.")
+
;;; Autoload functions:
;;;###autoload
@@ -510,10 +676,13 @@ non-nil, create a buffer with that name and export to that
buffer. If TO-BUFFER is the symbol `string', don't leave any
buffer behind but just return the resulting LaTeX as a string.
When BODY-ONLY is set, don't produce the file header and footer,
-simply return the content of \begin{document}...\end{document},
-without even the \begin{document} and \end{document} commands.
+simply return the content of \\begin{document}...\\end{document},
+without even the \\begin{document} and \\end{document} commands.
when PUB-DIR is set, use this as the publishing directory."
(interactive "P")
+ (when (and (not body-only) arg (listp arg)) (setq body-only t))
+ (run-hooks 'org-export-first-hook)
+
;; Make sure we have a file name when we need it.
(when (and (not (or to-buffer body-only))
(not buffer-file-name))
@@ -525,10 +694,14 @@ when PUB-DIR is set, use this as the publishing directory."
(message "Exporting to LaTeX...")
(org-unmodified
- (remove-text-properties (point-min) (point-max)
- '(:org-license-to-kill nil)))
+ (let ((inhibit-read-only t))
+ (remove-text-properties (point-min) (point-max)
+ '(:org-license-to-kill nil))))
(org-update-radio-target-regexp)
(org-export-latex-set-initial-vars ext-plist arg)
+ (setq org-export-opt-plist org-export-latex-options-plist)
+ (org-install-letbind)
+ (run-hooks 'org-export-latex-after-initial-vars-hook)
(let* ((wcf (current-window-configuration))
(opt-plist org-export-latex-options-plist)
(region-p (org-region-active-p))
@@ -547,27 +720,40 @@ when PUB-DIR is set, use this as the publishing directory."
(org-export-add-subtree-options opt-plist rbeg)
opt-plist)))
;; Make sure the variable contains the updated values.
- (org-export-latex-options-plist opt-plist)
+ (org-export-latex-options-plist (setq org-export-opt-plist opt-plist))
+ ;; The following two are dynamically scoped into other
+ ;; routines below.
+ (org-current-export-dir
+ (or pub-dir (org-export-directory :html opt-plist)))
+ (org-current-export-file buffer-file-name)
(title (or (and subtree-p (org-export-get-title-from-subtree))
(plist-get opt-plist :title)
(and (not
(plist-get opt-plist :skip-before-1st-heading))
(org-export-grab-title-from-buffer))
- (file-name-sans-extension
- (file-name-nondirectory buffer-file-name))))
- (filename (concat (file-name-as-directory
- (or pub-dir
- (org-export-directory :LaTeX ext-plist)))
- (file-name-sans-extension
- (or (and subtree-p
- (org-entry-get rbeg "EXPORT_FILE_NAME" t))
- (file-name-nondirectory ;sans-extension
- buffer-file-name)))
- ".tex"))
- (filename (if (equal (file-truename filename)
- (file-truename buffer-file-name))
- (concat filename ".tex")
- filename))
+ (and buffer-file-name
+ (file-name-sans-extension
+ (file-name-nondirectory buffer-file-name)))
+ "No Title"))
+ (filename
+ (and (not to-buffer)
+ (concat
+ (file-name-as-directory
+ (or pub-dir
+ (org-export-directory :LaTeX ext-plist)))
+ (file-name-sans-extension
+ (or (and subtree-p
+ (org-entry-get rbeg "EXPORT_FILE_NAME" t))
+ (file-name-nondirectory ;sans-extension
+ (or buffer-file-name
+ (error "Don't know which export file to use")))))
+ ".tex")))
+ (filename
+ (and filename
+ (if (equal (file-truename filename)
+ (file-truename (or buffer-file-name "dummy.org")))
+ (concat filename ".tex")
+ filename)))
(buffer (if to-buffer
(cond
((eq to-buffer 'string) (get-buffer-create
@@ -602,6 +788,24 @@ when PUB-DIR is set, use this as the publishing directory."
(region (buffer-substring
(if region-p (region-beginning) (point-min))
(if region-p (region-end) (point-max))))
+ (text
+ (and text (string-match "\\S-" text)
+ (org-export-preprocess-string
+ text
+ :emph-multiline t
+ :for-LaTeX t
+ :comments nil
+ :tags (plist-get opt-plist :tags)
+ :priority (plist-get opt-plist :priority)
+ :footnotes (plist-get opt-plist :footnotes)
+ :drawers (plist-get opt-plist :drawers)
+ :timestamps (plist-get opt-plist :timestamps)
+ :todo-keywords (plist-get opt-plist :todo-keywords)
+ :add-text nil
+ :skip-before-1st-heading skip
+ :select-tags nil
+ :exclude-tags nil
+ :LaTeX-fragments nil)))
(string-for-export
(org-export-preprocess-string
region
@@ -656,6 +860,11 @@ when PUB-DIR is set, use this as the publishing directory."
;; finalization
(unless body-only (insert "\n\\end{document}"))
+ ;; Attach description terms to the \item macro
+ (goto-char (point-min))
+ (while (re-search-forward "^[ \t]*\\\\item\\([ \t]+\\)\\[" nil t)
+ (delete-region (match-beginning 1) (match-end 1)))
+
;; Relocate the table of contents
(goto-char (point-min))
(when (re-search-forward "\\[TABLE-OF-CONTENTS\\]" nil t)
@@ -666,8 +875,25 @@ when PUB-DIR is set, use this as the publishing directory."
(and (re-search-forward "\\[TABLE-OF-CONTENTS\\]" nil t)
(replace-match "\\tableofcontents" t t)))
+ ;; Cleanup forced line ends in items where they are not needed
+ (goto-char (point-min))
+ (while (re-search-forward
+ "^[ \t]*\\\\item\\>.*\\(\\\\\\\\\\)[ \t]*\\(\n\\\\label.*\\)*\n\\\\begin"
+ nil t)
+ (delete-region (match-beginning 1) (match-end 1)))
+ (goto-char (point-min))
+ (while (re-search-forward
+ "^[ \t]*\\\\item\\>.*\\(\\\\\\\\\\)[ \t]*\\(\n\\\\label.*\\)*"
+ nil t)
+ (if (looking-at "[\n \t]+")
+ (replace-match "\n")))
+
(run-hooks 'org-export-latex-final-hook)
- (or to-buffer (save-buffer))
+ (if to-buffer
+ (unless (eq major-mode 'latex-mode) (latex-mode))
+ (save-buffer))
+ (org-export-latex-fix-inputenc)
+ (run-hooks 'org-export-latex-after-save-hook)
(goto-char (point-min))
(or (org-export-push-to-kill-ring "LaTeX")
(message "Exporting to LaTeX...done"))
@@ -696,12 +922,12 @@ when PUB-DIR is set, use this as the publishing directory."
(save-excursion
(goto-char (point-min))
(re-search-forward "\\\\bibliography{" nil t))))
- cmd)
+ cmd output-dir errors)
(with-current-buffer outbuf (erase-buffer))
- (and (file-exists-p pdffile) (delete-file pdffile))
- (message "Processing LaTeX file...")
+ (message (concat "Processing LaTeX file " file "..."))
+ (setq output-dir (file-name-directory file))
(if (and cmds (symbolp cmds))
- (funcall cmds file)
+ (funcall cmds (shell-quote-argument file))
(while cmds
(setq cmd (pop cmds))
(while (string-match "%b" cmd)
@@ -709,30 +935,64 @@ when PUB-DIR is set, use this as the publishing directory."
(save-match-data
(shell-quote-argument base))
t t cmd)))
- (while (string-match "%s" cmd)
+ (while (string-match "%f" cmd)
(setq cmd (replace-match
(save-match-data
(shell-quote-argument file))
t t cmd)))
- (shell-command cmd outbuf outbuf)))
- (message "Processing LaTeX file...done")
+ (while (string-match "%o" cmd)
+ (setq cmd (replace-match
+ (save-match-data
+ (shell-quote-argument output-dir))
+ t t cmd)))
+ (shell-command cmd outbuf)))
+ (message (concat "Processing LaTeX file " file "...done"))
+ (setq errors (org-export-latex-get-error outbuf))
(if (not (file-exists-p pdffile))
- (error "PDF file was not produced")
+ (error (concat "PDF file " pdffile " was not produced"
+ (if errors (concat ":" errors "") "")))
(set-window-configuration wconfig)
(when org-export-pdf-remove-logfiles
- (dolist (ext '("aux" "log" "out" "toc"))
+ (dolist (ext org-export-pdf-logfiles)
(setq file (concat base "." ext))
(and (file-exists-p file) (delete-file file))))
- (message "Exporting to PDF...done")
+ (message (concat
+ "Exporting to PDF...done"
+ (if errors
+ (concat ", with some errors:" errors)
+ "")))
pdffile)))
+(defun org-export-latex-get-error (buf)
+ "Collect the kinds of errors that remain in pdflatex processing."
+ (with-current-buffer buf
+ (save-excursion
+ (goto-char (point-max))
+ (when (re-search-backward "^[ \t]*This is pdf.*?TeX.*?Version" nil t)
+ ;; OK, we are at the location of the final run
+ (let ((pos (point)) (errors "") (case-fold-search t))
+ (if (re-search-forward "Reference.*?undefined" nil t)
+ (setq errors (concat errors " [undefined reference]")))
+ (goto-char pos)
+ (if (re-search-forward "Citation.*?undefined" nil t)
+ (setq errors (concat errors " [undefined citation]")))
+ (goto-char pos)
+ (if (re-search-forward "Undefined control sequence" nil t)
+ (setq errors (concat errors " [undefined control sequence]")))
+ (and (org-string-nw-p errors) errors))))))
+
;;;###autoload
(defun org-export-as-pdf-and-open (arg)
"Export as LaTeX, then process through to PDF, and open."
(interactive "P")
(let ((pdffile (org-export-as-pdf arg)))
(if pdffile
- (org-open-file pdffile)
+ (progn
+ (org-open-file pdffile)
+ (when org-export-kill-product-buffer-when-displayed
+ (kill-buffer (find-buffer-visiting
+ (concat (file-name-sans-extension (buffer-file-name))
+ ".tex")))))
(error "PDF file was not produced"))))
;;; Parsing functions:
@@ -745,7 +1005,7 @@ Return a list reflecting the document structure."
(goto-char (point-min))
(let* ((cnt 0) output
(depth org-export-latex-sectioning-depth))
- (while (re-search-forward
+ (while (org-re-search-forward-unprotected
(concat "^\\(\\(?:\\*\\)\\{"
(number-to-string (+ (if odd 2 1) level))
"\\}\\) \\(.*\\)$")
@@ -753,7 +1013,7 @@ Return a list reflecting the document structure."
(when (> level 0)
(save-excursion
(save-match-data
- (re-search-forward
+ (org-re-search-forward-unprotected
(concat "^\\(\\(?:\\*\\)\\{"
(number-to-string level)
"\\}\\) \\(.*\\)$") nil t)))) t)
@@ -765,7 +1025,7 @@ Return a list reflecting the document structure."
(narrow-to-region
(point)
(save-match-data
- (if (re-search-forward
+ (if (org-re-search-forward-unprotected
(concat "^\\(\\(?:\\*\\)\\{"
(number-to-string (+ (if odd 2 1) level))
"\\}\\) \\(.*\\)$") nil t)
@@ -789,7 +1049,7 @@ Return a list reflecting the document structure."
(defun org-export-latex-parse-content ()
"Extract the content of a section."
(let ((beg (point))
- (end (if (re-search-forward "^\\(\\*\\)+ .*$" nil t)
+ (end (if (org-re-search-forward-unprotected "^\\(\\*\\)+ .*$" nil t)
(progn (beginning-of-line) (point))
(point-max))))
(buffer-substring beg end)))
@@ -797,7 +1057,7 @@ Return a list reflecting the document structure."
(defun org-export-latex-parse-subcontent (level odd)
"Extract the subcontent of a section at LEVEL.
If ODD Is non-nil, assume subcontent only contains odd sections."
- (if (not (re-search-forward
+ (if (not (org-re-search-forward-unprotected
(concat "^\\(\\(?:\\*\\)\\{"
(number-to-string (+ (if odd 4 2) level))
"\\}\\) \\(.*\\)$")
@@ -824,8 +1084,7 @@ and its content."
(defun org-export-latex-subcontent (subcontent num)
"Export each cell of SUBCONTENT to LaTeX.
If NUM, export sections as numerical sections."
- (let* ((heading (org-export-latex-fontify-headline
- (cdr (assoc 'heading subcontent))))
+ (let* ((heading (cdr (assoc 'heading subcontent)))
(level (- (cdr (assoc 'level subcontent))
org-export-latex-add-level))
(occur (number-to-string (cdr (assoc 'occur subcontent))))
@@ -833,32 +1092,61 @@ If NUM, export sections as numerical sections."
(subcontent (cadr (assoc 'subcontent subcontent)))
(label (org-get-text-property-any 0 'target heading))
(label-list (cons label (cdr (assoc label
- org-export-target-aliases)))))
+ org-export-target-aliases))))
+ (sectioning org-export-latex-sectioning)
+ (depth org-export-latex-sectioning-depth)
+ main-heading sub-heading)
+ (when (symbolp (car sectioning))
+ (setq sectioning (funcall (car sectioning) level heading))
+ (when sectioning
+ (setq heading (car sectioning)
+ sectioning (cdr sectioning)
+ ;; target property migh have changed...
+ label (org-get-text-property-any 0 'target heading)
+ label-list (cons label (cdr (assoc label
+ org-export-target-aliases)))))
+ (if sectioning (setq sectioning (make-list 10 sectioning)))
+ (setq depth (if sectioning 10000 0)))
+ (if (string-match "[ \t]*\\\\\\\\[ \t]*" heading)
+ (setq main-heading (substring heading 0 (match-beginning 0))
+ sub-heading (substring heading (match-end 0))))
+ (setq heading (org-export-latex-fontify-headline heading)
+ sub-heading (and sub-heading
+ (org-export-latex-fontify-headline sub-heading))
+ main-heading (and main-heading
+ (org-export-latex-fontify-headline main-heading)))
(cond
;; Normal conversion
- ((<= level org-export-latex-sectioning-depth)
- (let* ((sec (nth (1- level) org-export-latex-sectioning))
+ ((<= level depth)
+ (let* ((sec (nth (1- level) sectioning))
start end)
(if (consp (cdr sec))
(setq start (nth (if num 0 2) sec)
end (nth (if num 1 3) sec))
(setq start (if num (car sec) (cdr sec))))
- (insert (format start heading) "\n")
+ (insert (format start (if main-heading main-heading heading)
+ (or sub-heading "")))
+ (insert "\n")
(when label
(insert (mapconcat (lambda (l) (format "\\label{%s}" l))
label-list "\n") "\n"))
(insert (org-export-latex-content content))
(cond ((stringp subcontent) (insert subcontent))
- ((listp subcontent) (org-export-latex-sub subcontent)))
- (if end (insert end "\n"))))
+ ((listp subcontent)
+ (while (org-looking-back "\n\n") (backward-delete-char 1))
+ (org-export-latex-sub subcontent)))
+ (when (and end (string-match "[^ \t]" end))
+ (let ((hook (org-get-text-property-any 0 'org-insert-hook end)))
+ (and (functionp hook) (funcall hook)))
+ (insert end "\n"))))
;; At a level under the hl option: we can drop this subsection
- ((> level org-export-latex-sectioning-depth)
+ ((> level depth)
(cond ((eq org-export-latex-low-levels 'description)
(if (string-match "% ends low level$"
(buffer-substring (point-at-bol 0) (point)))
(delete-region (point-at-bol 0) (point))
(insert "\\begin{description}\n"))
- (insert (format "\n\\item[%s]%s~\n\n"
+ (insert (format "\n\\item[%s]%s~\n"
heading
(if label (format "\\label{%s}" label) "")))
(insert (org-export-latex-content content))
@@ -871,7 +1159,7 @@ If NUM, export sections as numerical sections."
(delete-region (point-at-bol 0) (point))
(insert (format "\\begin{%s}\n"
(symbol-name org-export-latex-low-levels))))
- (insert (format "\n\\item %s\\\\\n%s\n"
+ (insert (format "\n\\item %s\\\\\n%s%%"
heading
(if label (format "\\label{%s}" label) "")))
(insert (org-export-latex-content content))
@@ -926,10 +1214,23 @@ LEVEL indicates the default depth for export."
(save-restriction
(widen)
(goto-char (point-min))
- (and (re-search-forward "^#\\+LaTeX_CLASS:[ \t]*\\([a-zA-Z]+\\)" nil t)
+ (and (re-search-forward "^#\\+LaTeX_CLASS:[ \t]*\\(-[a-zA-Z]+\\)" nil t)
(match-string 1))))
(plist-get org-export-latex-options-plist :latex-class)
org-export-latex-default-class)
+ org-export-latex-class-options
+ (or (and (org-region-active-p)
+ (save-excursion
+ (goto-char (region-beginning))
+ (and (looking-at org-complex-heading-regexp)
+ (org-entry-get nil "LaTeX_CLASS_OPTIONS" 'selective))))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (and (re-search-forward "^#\\+LaTeX_CLASS_OPTIONS:[ \t]*\\(.*?\\)[ \t]*$" nil t)
+ (match-string 1))))
+ (plist-get org-export-latex-options-plist :latex-class-options))
org-export-latex-class
(or (car (assoc org-export-latex-class org-export-latex-classes))
(error "No definition for class `%s' in `org-export-latex-classes'"
@@ -943,32 +1244,42 @@ LEVEL indicates the default depth for export."
(let ((hl-levels
(plist-get org-export-latex-options-plist :headline-levels))
(sec-depth (length org-export-latex-sectioning)))
- (if (> hl-levels sec-depth) sec-depth hl-levels)))))
+ (if (> hl-levels sec-depth) sec-depth hl-levels))))
+ (when (and org-export-latex-class-options
+ (string-match "\\S-" org-export-latex-class-options)
+ (string-match "^[ \t]*\\(\\\\documentclass\\)\\(\\[.*?\\]\\)?"
+ org-export-latex-header))
+ (setq org-export-latex-header
+ (concat (substring org-export-latex-header 0 (match-end 1))
+ org-export-latex-class-options
+ (substring org-export-latex-header (match-end 0))))))
+
+(defvar org-export-latex-format-toc-function
+ 'org-export-latex-format-toc-default
+ "The function formatting returning the string to create the table of contents.
+The function mus take one parameter, the depth of the table of contents.")
(defun org-export-latex-make-header (title opt-plist)
"Make the LaTeX header and return it as a string.
TITLE is the current title from the buffer or region.
OPT-PLIST is the options plist for current buffer."
(let ((toc (plist-get opt-plist :table-of-contents))
- (author (plist-get opt-plist :author)))
+ (author (org-export-apply-macros-in-string
+ (plist-get opt-plist :author))))
(concat
(if (plist-get opt-plist :time-stamp-file)
(format-time-string "%% Created %Y-%m-%d %a %H:%M\n"))
- ;; insert LaTeX custom header
- (org-export-apply-macros-in-string org-export-latex-header)
- "\n"
- ;; insert information on LaTeX packages
- (when org-export-latex-packages-alist
- (mapconcat (lambda(p)
- (if (equal "" (car p))
- (format "\\usepackage{%s}" (cadr p))
- (format "\\usepackage[%s]{%s}"
- (car p) (cadr p))))
- org-export-latex-packages-alist "\n"))
- ;; insert additional commands in the header
- (org-export-apply-macros-in-string
- (plist-get opt-plist :latex-header-extra))
+ ;; insert LaTeX custom header and packages from the list
+ (org-splice-latex-header
+ (org-export-apply-macros-in-string org-export-latex-header)
+ org-export-latex-default-packages-alist
+ org-export-latex-packages-alist nil
+ (org-export-apply-macros-in-string
+ (plist-get opt-plist :latex-header-extra)))
+ ;; append another special variable
(org-export-apply-macros-in-string org-export-latex-append-header)
+ ;; define alert if not yet defined
+ "\n\\providecommand{\\alert}[1]{\\textbf{#1}}"
;; insert the title
(format
"\n\n\\title{%s}\n"
@@ -980,7 +1291,7 @@ OPT-PLIST is the options plist for current buffer."
(format "\\author{%s}\n"
(org-export-latex-fontify-headline (or author user-full-name)))
(format "%%\\author{%s}\n"
- (or author user-full-name)))
+ (org-export-latex-fontify-headline (or author user-full-name))))
;; insert the date
(format "\\date{%s}\n"
(format-time-string
@@ -997,13 +1308,15 @@ OPT-PLIST is the options plist for current buffer."
;; table of contents
(when (and org-export-with-toc
(plist-get opt-plist :section-numbers))
- (cond ((numberp toc)
- (format "\\setcounter{tocdepth}{%s}\n\\tableofcontents\n\\vspace*{1cm}\n"
- (min toc (plist-get opt-plist :headline-levels))))
- (toc (format "\\setcounter{tocdepth}{%s}\n\\tableofcontents\n\\vspace*{1cm}\n"
- (plist-get opt-plist :headline-levels)))))
- (when (plist-get opt-plist :preserve-breaks)
- "\\obeylines\n"))))
+ (funcall org-export-latex-format-toc-function
+ (cond ((numberp toc)
+ (min toc (plist-get opt-plist :headline-levels)))
+ (toc (plist-get opt-plist :headline-levels))))))))
+
+(defun org-export-latex-format-toc-default (depth)
+ (when depth
+ (format "\\setcounter{tocdepth}{%s}\n\\tableofcontents\n\\vspace*{1cm}\n"
+ depth)))
(defun org-export-latex-first-lines (opt-plist &optional beg end)
"Export the first lines before first headline.
@@ -1028,8 +1341,20 @@ If END is non-nil, it is the end of the region."
:timestamps (plist-get opt-plist :timestamps)
:footnotes (plist-get opt-plist :footnotes)))
(org-unmodified
- (add-text-properties pt (max pt (1- end))
- '(:org-license-to-kill t)))))))
+ (let ((inhibit-read-only t)
+ (limit (max pt (1- end))))
+ (add-text-properties pt limit
+ '(:org-license-to-kill t))
+ (save-excursion
+ (goto-char pt)
+ (while (re-search-forward "^[ \t]*#\\+.*\n?" limit t)
+ (let ((case-fold-search t))
+ (unless (org-string-match-p
+ "^[ \t]*#\\+\\(attr_\\|caption\\>\\|label\\>\\)"
+ (match-string 0))
+ (remove-text-properties (match-beginning 0) (match-end 0)
+ '(:org-license-to-kill t))))))))))))
+
(defvar org-export-latex-header-defs nil
"The header definitions that might be used in the LaTeX body.")
@@ -1101,20 +1426,21 @@ links, keywords, lists, tables, fixed-width"
(cdr todo-markup) (car todo-markup)))
(t (cdr (or (assoc (match-string 1) todo-markup)
(car todo-markup))))))
- (replace-match (format fmt (match-string 1)) t t)))
+ (replace-match (org-export-latex-protect-string
+ (format fmt (match-string 1))) t t)))
;; convert priority string
(when (re-search-forward "\\[\\\\#.\\]" nil t)
(if (plist-get remove-list :priority)
(replace-match "")
(replace-match (format "\\textbf{%s}" (match-string 0)) t t)))
;; convert tags
- (when (re-search-forward "\\(:[a-zA-Z0-9_@]+\\)+:" nil t)
+ (when (re-search-forward "\\(:[a-zA-Z0-9_@#%]+\\)+:" nil t)
(if (or (not org-export-with-tags)
(plist-get remove-list :tags))
(replace-match "")
(replace-match
(org-export-latex-protect-string
- (format "\\textbf{%s}"
+ (format org-export-latex-tag-markup
(save-match-data
(replace-regexp-in-string
"_" "\\\\_" (match-string 0)))))
@@ -1127,13 +1453,20 @@ links, keywords, lists, tables, fixed-width"
;; the beginning of the buffer - inserting "\n" is safe here though.
(insert "\n" string)
(goto-char (point-min))
- (let ((re (concat "\\\\[a-zA-Z]+\\(?:"
- "\\[.*\\]"
- "\\)?"
- (org-create-multibrace-regexp "{" "}" 3))))
+ (let ((re (concat "\\\\\\([a-zA-Z]+\\)"
+ "\\(?:<[^<>\n]*>\\)*"
+ "\\(?:\\[[^][\n]*?\\]\\)*"
+ "\\(?:<[^<>\n]*>\\)*"
+ "\\("
+ (org-create-multibrace-regexp "{" "}" 3)
+ "\\)\\{1,3\\}")))
(while (re-search-forward re nil t)
- (unless (save-excursion (goto-char (match-beginning 0))
- (equal (char-after (point-at-bol)) ?#))
+ (unless (or
+ ;; check for comment line
+ (save-excursion (goto-char (match-beginning 0))
+ (org-in-indented-comment-line))
+ ;; Check if this is a defined entity, so that is may need conversion
+ (org-entity-get (match-string 1)))
(add-text-properties (match-beginning 0) (match-end 0)
'(org-protected t)))))
(when (plist-get org-export-latex-options-plist :emphasize)
@@ -1192,7 +1525,8 @@ See the `org-export-latex.el' code for a complete conversion table."
(if (equal (match-string 1) "\\")
(replace-match (match-string 2) t t)
(replace-match (concat (match-string 1) "\\"
- (match-string 2)) t t)))
+ (match-string 2)) t t)
+ (backward-char 1)))
((equal (match-string 2) "...")
(replace-match
(concat (match-string 1)
@@ -1216,7 +1550,19 @@ See the `org-export-latex.el' code for a complete conversion table."
(org-export-latex-treat-backslash-char
(match-string 1)
(or (match-string 3) "")))
- "") t t))
+ "") t t)
+ (when (and (get-text-property (1- (point)) 'org-entity)
+ (looking-at "{}"))
+ ;; OK, this was an entity replacement, and the user
+ ;; had terminated the entity with {}. Make sure
+ ;; {} is protected as well, and remove the extra {}
+ ;; inserted by the conversion.
+ (put-text-property (point) (+ 2 (point)) 'org-protected t)
+ (if (save-excursion (goto-char (max (- (point) 2) (point-min)))
+ (looking-at "{}"))
+ (replace-match ""))
+ (forward-char 2))
+ (backward-char 1))
((member (match-string 2) '("_" "^"))
(replace-match (or (save-match-data
(org-export-latex-treat-sub-super-char
@@ -1227,8 +1573,8 @@ See the `org-export-latex.el' code for a complete conversion table."
(backward-char 1)))))))
'(;"^\\([^\n$]*?\\|^\\)\\(\\\\?\\$\\)\\([^\n$]*\\)$"
"\\(\\(\\\\?\\$\\)\\)"
- "\\([a-za-z0-9]+\\|[ \t\n]\\|\\b\\|\\\\\\)\\(_\\|\\^\\)\\({[^{}]+}\\|[a-za-z0-9]+\\|[ \t\n]\\|[:punct:]\\|)\\|{[a-za-z0-9]+}\\|([a-za-z0-9]+)\\)"
- "\\(.\\|^\\)\\(\\\\\\)\\([ \t\n]\\|[a-zA-Z&#%{}\"]+\\)"
+ "\\([a-zA-Z0-9()]+\\|[ \t\n]\\|\\b\\|\\\\\\)\\(_\\|\\^\\)\\({[^{}]+}\\|[a-zA-Z0-9]+\\|[ \t\n]\\|[:punct:]\\|)\\|{[a-zA-Z0-9]+}\\|([a-zA-Z0-9]+)\\)"
+ "\\(.\\|^\\)\\(\\\\\\)\\([ \t\n]\\|\\([&#%{}\"]\\|[a-zA-Z][a-zA-Z0-9]*\\)\\)"
"\\(.\\|^\\)\\(&\\)"
"\\(.\\|^\\)\\(#\\)"
"\\(.\\|^\\)\\(%\\)"
@@ -1264,7 +1610,9 @@ Convert CHAR depending on STRING-BEFORE and STRING-AFTER."
((and (> (length string-after) 1)
(or (eq subsup t)
(and (equal subsup '{}) (eq (string-to-char string-after) ?\{)))
- (string-match "[({]?\\([^)}]+\\)[)}]?" string-after))
+ (or (string-match "[{]?\\([^}]+\\)[}]?" string-after)
+ (string-match "[(]?\\([^)]+\\)[)]?" string-after)))
+
(org-export-latex-protect-string
(format "%s$%s{%s}$" string-before char
(if (and (> (match-end 1) (1+ (match-beginning 1)))
@@ -1280,29 +1628,35 @@ Convert CHAR depending on STRING-BEFORE and STRING-AFTER."
(defun org-export-latex-treat-backslash-char (string-before string-after)
"Convert the \"$\" special character to LaTeX.
The conversion is made depending of STRING-BEFORE and STRING-AFTER."
- (cond ((member (list string-after) org-html-entities)
- ;; backslash is part of a special entity (like "\alpha")
- (concat string-before "$\\"
- (or (cdar (member (list string-after) org-html-entities))
- string-after) "$"))
- ((and (not (string-match "^[ \n\t]" string-after))
- (not (string-match "[ \t]\\'\\|^" string-before)))
- ;; backslash is inside a word
- (org-export-latex-protect-string
- (concat string-before "\\textbackslash{}" string-after)))
- ((not (or (equal string-after "")
- (string-match "^[ \t\n]" string-after)))
- ;; backslash might escape a character (like \#) or a user TeX
- ;; macro (like \setcounter)
- (org-export-latex-protect-string
- (concat string-before "\\" string-after)))
- ((and (string-match "^[ \t\n]" string-after)
- (string-match "[ \t\n]\\'" string-before))
- ;; backslash is alone, convert it to $\backslash$
- (org-export-latex-protect-string
- (concat string-before "\\textbackslash{}" string-after)))
- (t (org-export-latex-protect-string
- (concat string-before "\\textbackslash{}" string-after)))))
+ (let ((ass (org-entity-get string-after)))
+ (cond
+ (ass (org-add-props
+ (if (nth 2 ass)
+ (concat string-before
+ (org-export-latex-protect-string
+ (concat "$" (nth 1 ass) "$")))
+ (concat string-before (org-export-latex-protect-string
+ (nth 1 ass))))
+ nil 'org-entity t))
+ ((and (not (string-match "^[ \n\t]" string-after))
+ (not (string-match "[ \t]\\'\\|^" string-before)))
+ ;; backslash is inside a word
+ (concat string-before
+ (org-export-latex-protect-string
+ (concat "\\textbackslash{}" string-after))))
+ ((not (or (equal string-after "")
+ (string-match "^[ \t\n]" string-after)))
+ ;; backslash might escape a character (like \#) or a user TeX
+ ;; macro (like \setcounter)
+ (concat string-before
+ (org-export-latex-protect-string (concat "\\" string-after))))
+ ((and (string-match "^[ \t\n]" string-after)
+ (string-match "[ \t\n]\\'" string-before))
+ ;; backslash is alone, convert it to $\backslash$
+ (org-export-latex-protect-string
+ (concat string-before "\\textbackslash{}" string-after)))
+ (t (org-export-latex-protect-string
+ (concat string-before "\\textbackslash{}" string-after))))))
(defun org-export-latex-keywords ()
"Convert special keywords to LaTeX."
@@ -1312,34 +1666,42 @@ The conversion is made depending of STRING-BEFORE and STRING-AFTER."
(match-string 0)) t t)
(save-excursion
(beginning-of-line 1)
- (unless (looking-at ".*\\\\newline[ \t]*$")
+ (unless (looking-at ".*\n[ \t]*\n")
(end-of-line 1)
- (insert "\\newline")))))
+ (insert "\n")))))
(defun org-export-latex-fixed-width (opt)
"When OPT is non-nil convert fixed-width sections to LaTeX."
(goto-char (point-min))
(while (re-search-forward "^[ \t]*:\\([ \t]\\|$\\)" nil t)
- (if opt
- (progn (goto-char (match-beginning 0))
- (insert "\\begin{verbatim}\n")
- (while (looking-at "^\\([ \t]*\\):\\(\\([ \t]\\|$\\).*\\)$")
- (replace-match (concat (match-string 1)
- (match-string 2)) t t)
- (forward-line))
- (insert "\\end{verbatim}\n\n"))
- (progn (goto-char (match-beginning 0))
- (while (looking-at "^\\([ \t]*\\):\\(\\([ \t]\\|$\\).*\\)$")
- (replace-match (concat "%" (match-string 1)
- (match-string 2)) t t)
- (forward-line))))))
-
+ (unless (get-text-property (point) 'org-example)
+ (if opt
+ (progn (goto-char (match-beginning 0))
+ (insert "\\begin{verbatim}\n")
+ (while (looking-at "^\\([ \t]*\\):\\(\\([ \t]\\|$\\).*\\)$")
+ (replace-match (concat (match-string 1)
+ (match-string 2)) t t)
+ (forward-line))
+ (insert "\\end{verbatim}\n\n"))
+ (progn (goto-char (match-beginning 0))
+ (while (looking-at "^\\([ \t]*\\):\\(\\([ \t]\\|$\\).*\\)$")
+ (replace-match (concat "%" (match-string 1)
+ (match-string 2)) t t)
+ (forward-line)))))))
(defvar org-table-last-alignment) ; defined in org-table.el
(defvar org-table-last-column-widths) ; defined in org-table.el
(declare-function orgtbl-to-latex "org-table" (table params) t)
(defun org-export-latex-tables (insert)
"Convert tables to LaTeX and INSERT it."
+ ;; First, get the table.el tables
+ (goto-char (point-min))
+ (while (re-search-forward "^[ \t]*\\(\\+-[-+]*\\+\\)[ \t]*\n[ \t]*|" nil t)
+ (org-if-unprotected
+ (require 'table)
+ (org-export-latex-convert-table.el-table)))
+
+ ;; And now the Org-mode tables
(goto-char (point-min))
(while (re-search-forward "^\\([ \t]*\\)|" nil t)
(org-if-unprotected-at (1- (point))
@@ -1351,7 +1713,7 @@ The conversion is made depending of STRING-BEFORE and STRING-AFTER."
(org-table-last-column-widths (copy-sequence
org-table-last-column-widths))
fnum fields line lines olines gr colgropen line-fmt align
- caption label attr floatp longtblp)
+ caption shortn label attr floatp placement longtblp)
(if org-export-latex-tables-verbatim
(let* ((tbl (concat "\\begin{verbatim}\n" raw-table
"\\end{verbatim}\n")))
@@ -1360,6 +1722,8 @@ The conversion is made depending of STRING-BEFORE and STRING-AFTER."
(progn
(setq caption (org-find-text-property-in-string
'org-caption raw-table)
+ shortn (org-find-text-property-in-string
+ 'org-caption-shortn raw-table)
attr (org-find-text-property-in-string
'org-attributes raw-table)
label (org-find-text-property-in-string
@@ -1367,9 +1731,15 @@ The conversion is made depending of STRING-BEFORE and STRING-AFTER."
longtblp (and attr (stringp attr)
(string-match "\\<longtable\\>" attr))
align (and attr (stringp attr)
- (string-match "\\<align=\\([^ \t\n\r,]+\\)" attr)
+ (string-match "\\<align=\\([^ \t\n\r]+\\)" attr)
(match-string 1 attr))
- floatp (or caption label))
+ floatp (or caption label)
+ placement (if (and attr
+ (stringp attr)
+ (string-match "[ \t]*\\<placement=\\(\\S-+\\)" attr))
+ (match-string 1 attr)
+ "[htb]"))
+ (setq caption (and caption (org-export-latex-fontify-headline caption)))
(setq lines (org-split-string raw-table "\n"))
(apply 'delete-region (list beg end))
(when org-export-table-remove-special-lines
@@ -1423,16 +1793,19 @@ The conversion is made depending of STRING-BEFORE and STRING-AFTER."
(concat
(if longtblp
(concat "\\begin{longtable}{" align "}\n")
- (if floatp "\\begin{table}[htb]\n"))
- (if (or floatp longtblp)
+ (if floatp (format "\\begin{table}%s\n" placement)))
+ (if floatp
(format
- "\\caption{%s%s}"
- (if label (concat "\\\label{" label "}") "")
- (or caption "")))
- (if longtblp "\\\\\n" "\n")
+ "\\caption%s{%s} %s"
+ (if shortn (concat "[" shortn "]") "")
+ (or caption "")
+ (if label (format "\\label{%s}" label) "")))
+ (if (and longtblp caption) "\\\\\n" "\n")
(if (and org-export-latex-tables-centered (not longtblp))
"\\begin{center}\n")
- (if (not longtblp) (concat "\\begin{tabular}{" align "}\n"))
+ (if (not longtblp)
+ (format "\\begin{%s}{%s}\n"
+ org-export-latex-tabular-environment align))
(orgtbl-to-latex
lines
`(:tstart nil :tend nil
@@ -1444,7 +1817,9 @@ The conversion is made depending of STRING-BEFORE and STRING-AFTER."
\\endfoot
\\endlastfoot" (length org-table-last-alignment))
nil)))
- (if (not longtblp) (concat "\n\\end{tabular}"))
+ (if (not longtblp)
+ (format "\n\\end{%s}"
+ org-export-latex-tabular-environment))
(if longtblp "\n" (if org-export-latex-tables-centered
"\n\\end{center}\n" "\n"))
(if longtblp
@@ -1452,6 +1827,58 @@ The conversion is made depending of STRING-BEFORE and STRING-AFTER."
(if floatp "\\end{table}"))))
"\n\n"))))))))
+(defun org-export-latex-convert-table.el-table ()
+ "Replace table.el table at point with LaTeX code."
+ (let (tbl caption shortn label line floatp attr align rmlines)
+ (setq line (buffer-substring (point-at-bol) (point-at-eol))
+ label (org-get-text-property-any 0 'org-label line)
+ caption (org-get-text-property-any 0 'org-caption line)
+ shortn (org-get-text-property-any 0 'org-caption-shortn line)
+ attr (org-get-text-property-any 0 'org-attributes line)
+ align (and attr (stringp attr)
+ (string-match "\\<align=\\([^ \t\n\r,]+\\)" attr)
+ (match-string 1 attr))
+ rmlines (and attr (stringp attr)
+ (string-match "\\<rmlines\\>" attr))
+ floatp (or label caption))
+ (and (get-buffer "*org-export-table*")
+ (kill-buffer (get-buffer "*org-export-table*")))
+ (table-generate-source 'latex "*org-export-table*" "caption")
+ (setq tbl (with-current-buffer "*org-export-table*"
+ (buffer-string)))
+ (while (string-match "^%.*\n" tbl)
+ (setq tbl (replace-match "" t t tbl)))
+ ;; fix the hlines
+ (when rmlines
+ (let ((n 0) lines)
+ (setq lines (mapcar (lambda (x)
+ (if (string-match "^\\\\hline$" x)
+ (progn
+ (setq n (1+ n))
+ (if (= n 2) x nil))
+ x))
+ (org-split-string tbl "\n")))
+ (setq tbl (mapconcat 'identity (delq nil lines) "\n"))))
+ (when (and align (string-match "\\\\begin{tabular}{.*}" tbl))
+ (setq tbl (replace-match (concat "\\begin{tabular}{" align "}")
+ t t tbl)))
+ (and (get-buffer "*org-export-table*")
+ (kill-buffer (get-buffer "*org-export-table*")))
+ (beginning-of-line 0)
+ (while (looking-at "[ \t]*\\(|\\|\\+-\\)")
+ (delete-region (point) (1+ (point-at-eol))))
+ (when org-export-latex-tables-centered
+ (setq tbl (concat "\\begin{center}\n" tbl "\\end{center}")))
+ (when floatp
+ (setq tbl (concat "\\begin{table}\n"
+ (format "\\caption%s{%s}%s\n"
+ (if shortn (format "[%s]" shortn) "")
+ (if label (format "\\label{%s}" label) "")
+ (or caption ""))
+ tbl
+ "\n\\end{table}\n")))
+ (insert (org-export-latex-protect-string tbl))))
+
(defun org-export-latex-fontify ()
"Convert fontification to LaTeX."
(goto-char (point-min))
@@ -1468,12 +1895,17 @@ The conversion is made depending of STRING-BEFORE and STRING-AFTER."
(unless (or (and (get-text-property (- (point) 2) 'org-protected)
(not (get-text-property
(- (point) 2) 'org-verbatim-emph)))
+ (equal (char-after (match-beginning 3))
+ (char-after (1+ (match-beginning 3))))
(save-excursion
(goto-char (match-beginning 1))
(save-match-data
(and (org-at-table-p)
(string-match
- "[|\n]" (buffer-substring beg end))))))
+ "[|\n]" (buffer-substring beg end)))))
+ (and (equal (match-string 3) "+")
+ (save-match-data
+ (string-match "\\`-+\\'" (match-string 4)))))
(setq s (match-string 4))
(setq rpl (concat (match-string 1)
(org-export-latex-emph-format (cadr emph)
@@ -1482,7 +1914,7 @@ The conversion is made depending of STRING-BEFORE and STRING-AFTER."
(if (caddr emph)
(setq rpl (org-export-latex-protect-string rpl))
(save-match-data
- (if (string-match "\\`.\\(\\\\[a-z]+{\\)\\(.*\\)\\(}\\).?\\'" rpl)
+ (if (string-match "\\`.?\\(\\\\[a-z]+{\\)\\(.*\\)\\(}\\).?\\'" rpl)
(progn
(add-text-properties (match-beginning 1) (match-end 1)
'(org-protected t) rpl)
@@ -1541,10 +1973,11 @@ The conversion is made depending of STRING-BEFORE and STRING-AFTER."
"file")))
(coderefp (equal type "coderef"))
(caption (org-find-text-property-in-string 'org-caption raw-path))
+ (shortn (org-find-text-property-in-string 'org-caption-shortn raw-path))
(attr (or (org-find-text-property-in-string 'org-attributes raw-path)
(plist-get org-export-latex-options-plist :latex-image-options)))
(label (org-find-text-property-in-string 'org-label raw-path))
- imgp radiop
+ imgp radiop fnc
;; define the path of the link
(path (cond
((member type '("coderef"))
@@ -1573,11 +2006,12 @@ The conversion is made depending of STRING-BEFORE and STRING-AFTER."
raw-path))))))))
;; process with link inserting
(apply 'delete-region remove)
+ (setq caption (and caption (org-export-latex-fontify-headline caption)))
(cond ((and imgp
(plist-get org-export-latex-options-plist :inline-images))
;; OK, we need to inline an image
(insert
- (org-export-latex-format-image raw-path caption label attr)))
+ (org-export-latex-format-image raw-path caption label attr shortn)))
(coderefp
(insert (format
(org-export-get-coderef-format path desc)
@@ -1589,27 +2023,37 @@ The conversion is made depending of STRING-BEFORE and STRING-AFTER."
(org-remove-initial-hash
(org-solidify-link-text raw-path))
desc)))
- (path
+ (path
(when (org-at-table-p)
;; There is a strange problem when we have a link in a table,
;; ampersands then cause a problem. I think this must be
;; a LaTeX issue, but we here implement a work-around anyway.
(setq path (org-export-latex-protect-amp path)
desc (org-export-latex-protect-amp desc)))
- (insert (format "\\href{%s}{%s}" path desc)))
+ (insert (format org-export-latex-hyperref-format path desc)))
+
+ ((functionp (setq fnc (nth 2 (assoc type org-link-protocols))))
+ ;; The link protocol has a function for formatting the link
+ (insert
+ (save-match-data
+ (funcall fnc (org-link-unescape raw-path) desc 'latex))))
+
(t (insert "\\texttt{" desc "}")))))))
-(defun org-export-latex-format-image (path caption label attr)
+(defun org-export-latex-format-image (path caption label attr &optional shortn)
"Format the image element, depending on user settings."
- (let (floatp wrapp placement figenv)
+ (let (ind floatp wrapp multicolumnp placement figenv)
(setq floatp (or caption label))
+ (setq ind (org-get-text-property-any 0 'original-indentation path))
(when (and attr (stringp attr))
(if (string-match "[ \t]*\\<wrap\\>" attr)
(setq wrapp t floatp nil attr (replace-match "" t t attr)))
(if (string-match "[ \t]*\\<float\\>" attr)
- (setq wrapp nil floatp t attr (replace-match "" t t attr))))
-
+ (setq wrapp nil floatp t attr (replace-match "" t t attr)))
+ (if (string-match "[ \t]*\\<multicolumn\\>" attr)
+ (setq multicolumnp t attr (replace-match "" t t attr))))
+
(setq placement
(cond
(wrapp "{l}{0.5\\textwidth}")
@@ -1630,8 +2074,13 @@ The conversion is made depending of STRING-BEFORE and STRING-AFTER."
(wrapp "\\begin{wrapfigure}%placement
\\centering
\\includegraphics[%attr]{%path}
-\\caption{%labelcmd%caption}
+\\caption%shortn{%labelcmd%caption}
\\end{wrapfigure}")
+ (multicolumnp "\\begin{figure*}%placement
+\\centering
+\\includegraphics[%attr]{%path}
+\\caption{%labelcmd%caption}
+\\end{figure*}")
(floatp "\\begin{figure}%placement
\\centering
\\includegraphics[%attr]{%path}
@@ -1639,20 +2088,29 @@ The conversion is made depending of STRING-BEFORE and STRING-AFTER."
\\end{figure}")
(t "\\includegraphics[%attr]{%path}")))
+
+ (setq figenv (mapconcat 'identity (split-string figenv "\n")
+ (save-excursion (beginning-of-line 1)
+ (looking-at "[ \t]*")
+ (concat "\n" (match-string 0)))))
+
(if (and (not label) (not caption)
(string-match "^\\\\caption{.*\n" figenv))
(setq figenv (replace-match "" t t figenv)))
- (org-fill-template
- figenv
- (list (cons "path"
- (if (file-name-absolute-p path)
- (expand-file-name path)
- path))
- (cons "attr" attr)
- (cons "labelcmd" (if label (format "\\label{%s}"
- label)""))
- (cons "caption" (or caption ""))
- (cons "placement" (or placement ""))))))
+ (org-add-props
+ (org-fill-template
+ figenv
+ (list (cons "path"
+ (if (file-name-absolute-p path)
+ (expand-file-name path)
+ path))
+ (cons "attr" attr)
+ (cons "shortn" (if shortn (format "[%s]" shortn) ""))
+ (cons "labelcmd" (if label (format "\\label{%s}"
+ label)""))
+ (cons "caption" (or caption ""))
+ (cons "placement" (or placement ""))))
+ nil 'original-indentation ind)))
(defun org-export-latex-protect-amp (s)
(while (string-match "\\([^\\\\]\\)\\(&\\)" s)
@@ -1666,7 +2124,6 @@ The conversion is made depending of STRING-BEFORE and STRING-AFTER."
s))
(defvar org-latex-entities) ; defined below
(defvar org-latex-entities-regexp) ; defined below
-(defvar org-latex-entities-exceptions) ; defined below
(defun org-export-latex-preprocess (parameters)
"Clean stuff in the LaTeX export."
@@ -1679,7 +2136,8 @@ The conversion is made depending of STRING-BEFORE and STRING-AFTER."
;; Preserve latex environments
(goto-char (point-min))
(while (re-search-forward "^[ \t]*\\\\begin{\\([a-zA-Z]+\\*?\\)}" nil t)
- (let* ((start (progn (beginning-of-line) (point)))
+ (org-if-unprotected
+ (let* ((start (progn (beginning-of-line) (point)))
(end (and (re-search-forward
(concat "^[ \t]*\\\\end{"
(regexp-quote (match-string 1))
@@ -1687,7 +2145,7 @@ The conversion is made depending of STRING-BEFORE and STRING-AFTER."
(point-at-eol))))
(if end
(add-text-properties start end '(org-protected t))
- (goto-char (point-at-eol)))))
+ (goto-char (point-at-eol))))))
;; Preserve math snippets
@@ -1705,13 +2163,15 @@ The conversion is made depending of STRING-BEFORE and STRING-AFTER."
(setq beg (+ (match-beginning 0) off) end (- (match-end 0) 0))
(add-text-properties beg end '(org-protected t org-latex-math t))))))
- ;; Convert LaTeX to \LaTeX{}
+ ;; Convert LaTeX to \LaTeX{} and TeX to \TeX{}
(goto-char (point-min))
(let ((case-fold-search nil))
- (while (re-search-forward "\\([^+_]\\)LaTeX" nil t)
- (org-if-unprotected
- (replace-match (org-export-latex-protect-string
- (concat (match-string 1) "\\LaTeX{}")) t t))))
+ (while (re-search-forward "\\<\\(\\(La\\)?TeX\\)\\>" nil t)
+ (unless (eq (char-before (match-beginning 1)) ?\\)
+ (org-if-unprotected-1
+ (replace-match (org-export-latex-protect-string
+ (concat "\\" (match-string 1)
+ "{}")) t t)))))
;; Convert blockquotes
(goto-char (point-min))
@@ -1759,25 +2219,36 @@ The conversion is made depending of STRING-BEFORE and STRING-AFTER."
(replace-match (org-export-latex-protect-string "\\hrule") t t)))
;; Protect LaTeX commands like \command[...]{...} or \command{...}
- (let ((re (concat "\\\\[a-zA-Z]+\\(?:"
- "\\[.*\\]"
- "\\)?"
- (org-create-multibrace-regexp "{" "}" 3))))
+ (goto-char (point-min))
+ (let ((re (concat
+ "\\\\\\([a-zA-Z]+\\)"
+ "\\(?:<[^<>\n]*>\\)*"
+ "\\(?:\\[[^][\n]*?\\]\\)*"
+ "\\(?:<[^<>\n]*>\\)*"
+ "\\(" (org-create-multibrace-regexp "{" "}" 3) "\\)\\{1,3\\}")))
(while (re-search-forward re nil t)
- (unless (save-excursion (goto-char (match-beginning 0))
- (equal (char-after (point-at-bol)) ?#))
+ (unless (or
+ ;; check for comment line
+ (save-excursion (goto-char (match-beginning 0))
+ (org-in-indented-comment-line))
+ ;; Check if this is a defined entity, so that is may need conversion
+ (org-entity-get (match-string 1))
+ )
(add-text-properties (match-beginning 0) (match-end 0)
'(org-protected t)))))
+ ;; Special case for \nbsp
+ (goto-char (point-min))
+ (while (re-search-forward "\\\\nbsp\\({}\\|\\>\\)" nil t)
+ (org-if-unprotected
+ (replace-match (org-export-latex-protect-string "~"))))
+
;; Protect LaTeX entities
(goto-char (point-min))
- (let (a)
- (while (re-search-forward org-latex-entities-regexp nil t)
- (if (setq a (assoc (match-string 0) org-latex-entities-exceptions))
- (replace-match (org-add-props (nth 1 a) nil 'org-protected t)
- t t)
- (add-text-properties (match-beginning 0) (match-end 0)
- '(org-protected t)))))
+ (while (re-search-forward org-latex-entities-regexp nil t)
+ (org-if-unprotected
+ (add-text-properties (match-beginning 0) (match-end 0)
+ '(org-protected t))))
;; Replace radio links
(goto-char (point-min))
@@ -1786,10 +2257,12 @@ The conversion is made depending of STRING-BEFORE and STRING-AFTER."
">>>?\\((INVISIBLE)\\)?") nil t)
(org-if-unprotected-at (+ (match-beginning 0) 2)
(replace-match
- (org-export-latex-protect-string
- (format "\\label{%s}%s" (save-match-data (org-solidify-link-text
- (match-string 1)))
- (if (match-string 2) "" (match-string 1)))) t t)))
+ (concat
+ (org-export-latex-protect-string
+ (format "\\label{%s}" (save-match-data (org-solidify-link-text
+ (match-string 1)))))
+ (if (match-string 2) "" (match-string 1)))
+ t t)))
;; Delete @<...> constructs
;; Thanks to Daniel Clemente for this regexp
@@ -1832,6 +2305,10 @@ The conversion is made depending of STRING-BEFORE and STRING-AFTER."
(add-text-properties (1- (length footnote-rpl))
(length footnote-rpl)
'(org-protected t) footnote-rpl)
+ (if (org-on-heading-p)
+ (setq footnote-rpl
+ (concat (org-export-latex-protect-string "\\protect")
+ footnote-rpl)))
(insert footnote-rpl)))
)))))
@@ -1842,17 +2319,44 @@ The conversion is made depending of STRING-BEFORE and STRING-AFTER."
(org-if-unprotected
(replace-match "")))))
+(defun org-export-latex-fix-inputenc ()
+ "Set the coding system in inputenc to what the buffer is."
+ (let* ((cs buffer-file-coding-system)
+ (opt (or (ignore-errors (latexenc-coding-system-to-inputenc cs))
+ "utf8")))
+ (when opt
+ ;; Translate if that is requested
+ (setq opt (or (cdr (assoc opt org-export-latex-inputenc-alist)) opt))
+ ;; find the \usepackage statement and replace the option
+ (goto-char (point-min))
+ (while (re-search-forward "\\\\usepackage\\[\\(AUTO\\)\\]{inputenc}"
+ nil t)
+ (goto-char (match-beginning 1))
+ (delete-region (match-beginning 1) (match-end 1))
+ (insert opt))
+ (and buffer-file-name
+ (save-buffer)))))
+
;;; List handling:
(defun org-export-latex-lists ()
"Convert plain text lists in current buffer into LaTeX lists."
- (goto-char (point-min))
- (while (re-search-forward org-list-beginning-re nil t)
- (org-if-unprotected
- (beginning-of-line)
- (insert (org-list-to-latex (org-list-parse-list t)
- org-export-latex-list-parameters))
- "\n")))
+ (let (res)
+ (goto-char (point-min))
+ (while (org-search-forward-unenclosed org-item-beginning-re nil t)
+ (beginning-of-line)
+ (setq res (org-list-to-latex (org-list-parse-list t)
+ org-export-latex-list-parameters))
+ (while (string-match "^\\(\\\\item[ \t]+\\)\\[@\\(?:start:\\)?\\([0-9]+\\)\\]"
+ res)
+ (setq res (replace-match
+ (concat (format "\\setcounter{enumi}{%d}"
+ (1- (string-to-number
+ (match-string 2 res))))
+ "\n"
+ (match-string 1 res))
+ t t res)))
+ (insert res "\n"))))
(defconst org-latex-entities
'("\\!"
@@ -1959,7 +2463,6 @@ The conversion is made depending of STRING-BEFORE and STRING-AFTER."
"\\medskip"
"\\multicolumn"
"\\multiput"
- ("\\nbsp" "~")
"\\newcommand"
"\\newcounter"
"\\newenvironment"
@@ -2031,14 +2534,9 @@ The conversion is made depending of STRING-BEFORE and STRING-AFTER."
"\\vspace")
"A list of LaTeX commands to be protected when performing conversion.")
-(defvar org-latex-entities-exceptions nil)
-
(defconst org-latex-entities-regexp
(let (names rest)
(dolist (x org-latex-entities)
- (when (consp x)
- (add-to-list 'org-latex-entities-exceptions x)
- (setq x (car x)))
(if (string-match "[a-zA-Z]$" x)
(push x names)
(push x rest)))
diff --git a/lisp/org/org-list.el b/lisp/org/org-list.el
index 5d1da8a861c..4ea466f379d 100644
--- a/lisp/org/org-list.el
+++ b/lisp/org/org-list.el
@@ -7,7 +7,7 @@
;; Bastien Guerry <bzg AT altern DOT org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -31,6 +31,8 @@
;;; Code:
+(eval-when-compile
+ (require 'cl))
(require 'org-macs)
(require 'org-compat)
@@ -38,20 +40,31 @@
(defvar org-M-RET-may-split-line)
(defvar org-complex-heading-regexp)
(defvar org-odd-levels-only)
+(defvar org-outline-regexp)
+(defvar org-ts-regexp)
+(defvar org-ts-regexp-both)
(declare-function org-invisible-p "org" ())
(declare-function org-on-heading-p "org" (&optional invisible-ok))
(declare-function outline-next-heading "outline" ())
(declare-function org-back-to-heading "org" (&optional invisible-ok))
(declare-function org-back-over-empty-lines "org" ())
-(declare-function org-skip-whitespace "org" ())
(declare-function org-trim "org" (s))
(declare-function org-get-indentation "org" (&optional line))
(declare-function org-timer-item "org-timer" (&optional arg))
+(declare-function org-timer-hms-to-secs "org-timer" (hms))
(declare-function org-combine-plists "org" (&rest plists))
-(declare-function org-entry-get "org" (pom property &optional inherit))
+(declare-function org-entry-get "org"
+ (pom property &optional inherit literal-nil))
(declare-function org-narrow-to-subtree "org" ())
(declare-function org-show-subtree "org" ())
+(declare-function org-in-regexps-block-p "org"
+ (start-re end-re &optional bound))
+(declare-function org-level-increment "org" ())
+(declare-function org-at-heading-p "org" (&optional ignored))
+(declare-function outline-previous-heading "outline" ())
+(declare-function org-icompleting-read "org" (&rest args))
+(declare-function org-time-string-to-seconds "org" (s))
(defgroup org-plain-lists nil
"Options concerning plain lists in Org-mode."
@@ -60,7 +73,6 @@
(defcustom org-cycle-include-plain-lists t
"When t, make TAB cycle visibility on plain list items.
-
Cycling plain lists works only when the cursor is on a plain list
item. When the cursor is on an outline heading, plain lists are
treated as text. This is the most stable way of handling this,
@@ -84,7 +96,29 @@ heading will be exposed in a children' view."
(defcustom org-list-demote-modify-bullet nil
"Default bullet type installed when demoting an item.
This is an association list, for each bullet type, this alist will point
-to the bulled that should be used when this item is demoted."
+to the bullet that should be used when this item is demoted.
+For example,
+
+ (setq org-list-demote-modify-bullet
+ '((\"+\" . \"-\") (\"-\" . \"+\") (\"*\" . \"+\")))
+
+will make
+
+ + Movies
+ + Silence of the Lambs
+ + My Cousin Vinny
+ + Books
+ + The Hunt for Red October
+ + The Road to Omaha
+
+into
+
+ + Movies
+ - Silence of the Lambs
+ - My Cousin Vinny
+ + Books
+ - The Hunt for Red October
+ - The Road to Omaha"
:group 'org-plain-lists
:type '(repeat
(cons
@@ -115,39 +149,91 @@ the safe choice."
(defcustom org-list-two-spaces-after-bullet-regexp nil
"A regular expression matching bullets that should have 2 spaces after them.
When nil, no bullet will have two spaces after them.
-When a string, it will be used as a regular expression. When the bullet
-type of a list is changed, the new bullet type will be matched against this
-regexp. If it matches, there will be two spaces instead of one after
-the bullet in each item of he list."
- :group 'org-plain-list
+When a string, it will be used as a regular expression. When the
+bullet type of a list is changed, the new bullet type will be
+matched against this regexp. If it matches, there will be two
+spaces instead of one after the bullet in each item of the list."
+ :group 'org-plain-lists
:type '(choice
(const :tag "never" nil)
(regexp)))
-(defcustom org-empty-line-terminates-plain-lists nil
- "Non-nil means, an empty line ends all plain list levels.
-When nil, empty lines are part of the preceding item."
+(defcustom org-list-ending-method 'both
+ "Determine where plain lists should end.
+Valid values are: `regexp', `indent' or `both'.
+
+When set to `regexp', Org will look into two variables,
+`org-empty-line-terminates-plain-lists' and the more general
+`org-list-end-regexp', to determine what will end lists. This is
+the fastest method.
+
+When set to `indent', a list will end whenever a line following
+an item, but not starting one, is less or equally indented than
+it.
+
+When set to `both', each of the preceding methods is applied to
+determine lists endings. This is the default method."
:group 'org-plain-lists
- :type 'boolean)
+ :type '(choice
+ (const :tag "With a regexp defining ending" regexp)
+ (const :tag "With indentation of regular (no bullet) text" indent)
+ (const :tag "With both methods" both)))
-(defcustom org-auto-renumber-ordered-lists t
- "Non-nil means, automatically renumber ordered plain lists.
-Renumbering happens when the sequence have been changed with
-\\[org-shiftmetaup] or \\[org-shiftmetadown]. After other editing commands,
-use \\[org-ctrl-c-ctrl-c] to trigger renumbering."
+(defcustom org-empty-line-terminates-plain-lists nil
+ "Non-nil means an empty line ends all plain list levels.
+This variable only makes sense if `org-list-ending-method' is set
+to `regexp' or `both'. This is then equivalent to set
+`org-list-end-regexp' to \"^[ \\t]*$\"."
:group 'org-plain-lists
:type 'boolean)
-(defcustom org-provide-checkbox-statistics t
- "Non-nil means, update checkbox statistics after insert and toggle.
-When this is set, checkbox statistics is updated each time you
-either insert a new checkbox with \\[org-insert-todo-heading] or
-toggle a checkbox with \\[org-ctrl-c-ctrl-c]."
+(defcustom org-list-end-regexp "^[ \t]*\n[ \t]*\n"
+ "Regexp matching the end of all plain list levels.
+It must start with \"^\" and end with \"\\n\". It defaults to 2
+blank lines. `org-empty-line-terminates-plain-lists' has
+precedence over it."
:group 'org-plain-lists
- :type 'boolean)
+ :type 'string)
+
+(defcustom org-list-automatic-rules '((bullet . t)
+ (checkbox . t)
+ (indent . t)
+ (insert . t))
+ "Non-nil means apply set of rules when acting on lists.
+By default, automatic actions are taken when using
+ \\[org-meta-return], \\[org-metaright], \\[org-metaleft],
+ \\[org-shiftmetaright], \\[org-shiftmetaleft],
+ \\[org-ctrl-c-minus], \\[org-toggle-checkbox] or
+ \\[org-insert-todo-heading]. You can disable individually these
+ rules by setting them to nil. Valid rules are:
+
+bullet when non-nil, cycling bullet do not allow lists at
+ column 0 to have * as a bullet and descriptions lists
+ to be numbered.
+checkbox when non-nil, checkbox statistics is updated each time
+ you either insert a new checkbox or toggle a checkbox.
+ It also prevents from inserting a checkbox in a
+ description item.
+indent when non-nil, indenting or outdenting list top-item
+ with its subtree will move the whole list and
+ outdenting a list whose bullet is * to column 0 will
+ change that bullet to -
+insert when non-nil, trying to insert an item inside a block
+ will insert it right before the block instead of
+ throwing an error."
+ :group 'org-plain-lists
+ :type '(alist :tag "Sets of rules"
+ :key-type
+ (choice
+ (const :tag "Bullet" bullet)
+ (const :tag "Checkbox" checkbox)
+ (const :tag "Indent" indent)
+ (const :tag "Insert" insert))
+ :value-type
+ (boolean :tag "Activate" :value t)))
(defcustom org-hierarchical-checkbox-statistics t
- "Non-nil means, checkbox statistics counts only the state of direct children.
+ "Non-nil means checkbox statistics counts only the state of direct children.
When nil, all boxes below the cookie are counted.
This can be set to nil on a per-node basis using a COOKIE_DATA property
with the word \"recursive\" in the value."
@@ -161,27 +247,24 @@ When the indentation would be larger than this, it will become
:group 'org-plain-lists
:type 'integer)
-(defvar org-list-beginning-re
- "^\\([ \t]*\\)\\([-+]\\|[0-9]+[.)]\\) +\\(.*\\)$")
-
(defcustom org-list-radio-list-templates
'((latex-mode "% BEGIN RECEIVE ORGLST %n
% END RECEIVE ORGLST %n
\\begin{comment}
#+ORGLST: SEND %n org-list-to-latex
-| | |
+-
\\end{comment}\n")
(texinfo-mode "@c BEGIN RECEIVE ORGLST %n
@c END RECEIVE ORGLST %n
@ignore
#+ORGLST: SEND %n org-list-to-texinfo
-| | |
+-
@end ignore\n")
(html-mode "<!-- BEGIN RECEIVE ORGLST %n -->
<!-- END RECEIVE ORGLST %n -->
<!--
#+ORGLST: SEND %n org-list-to-html
-| | |
+-
-->\n"))
"Templates for radio lists in different major modes.
All occurrences of %n in a template will be replaced with the name of the
@@ -191,21 +274,541 @@ list, obtained by prompting the user."
(list (symbol :tag "Major mode")
(string :tag "Format"))))
-;;;; Plain list items, including checkboxes
+;;; Internal functions
+
+(defun org-list-end-re ()
+ "Return the regex corresponding to the end of a list.
+It depends on `org-empty-line-terminates-plain-lists'."
+ (if org-empty-line-terminates-plain-lists
+ "^[ \t]*\n"
+ org-list-end-regexp))
+
+(defun org-item-re (&optional general)
+ "Return the correct regular expression for plain lists.
+If GENERAL is non-nil, return the general regexp independent of the value
+of `org-plain-list-ordered-item-terminator'."
+ (cond
+ ((or general (eq org-plain-list-ordered-item-terminator t))
+ "\\([ \t]*\\([-+]\\|\\([0-9]+[.)]\\)\\)\\|[ \t]+\\*\\)\\([ \t]+\\|$\\)")
+ ((= org-plain-list-ordered-item-terminator ?.)
+ "\\([ \t]*\\([-+]\\|\\([0-9]+\\.\\)\\)\\|[ \t]+\\*\\)\\([ \t]+\\|$\\)")
+ ((= org-plain-list-ordered-item-terminator ?\))
+ "\\([ \t]*\\([-+]\\|\\([0-9]+)\\)\\)\\|[ \t]+\\*\\)\\([ \t]+\\|$\\)")
+ (t (error "Invalid value of `org-plain-list-ordered-item-terminator'"))))
+
+(defconst org-item-beginning-re (concat "^" (org-item-re))
+ "Regexp matching the beginning of a plain list item.")
+
+(defun org-list-ending-between (min max &optional firstp)
+ "Find the position of a list ending between MIN and MAX, or nil.
+This function looks for `org-list-end-re' outside a block.
+
+If FIRSTP in non-nil, return the point at the beginning of the
+nearest valid terminator from MIN. Otherwise, return the point at
+the end of the nearest terminator from MAX."
+ (save-excursion
+ (let* ((start (if firstp min max))
+ (end (if firstp max min))
+ (search-fun (if firstp
+ #'org-search-forward-unenclosed
+ #'org-search-backward-unenclosed))
+ (list-end-p (progn
+ (goto-char start)
+ (funcall search-fun (org-list-end-re) end t))))
+ ;; Is there a valid list ending somewhere ?
+ (and list-end-p
+ ;; we want to be on the first line of the list ender
+ (match-beginning 0)))))
+
+(defun org-list-maybe-skip-block (search limit)
+ "Return non-nil value if point is in a block, skipping it on the way.
+It looks for the boundary of the block in SEARCH direction,
+stopping at LIMIT."
+ (save-match-data
+ (let ((case-fold-search t)
+ (boundary (if (eq search 're-search-forward) 3 5)))
+ (when (save-excursion
+ (and (funcall search "^[ \t]*#\\+\\(begin\\|end\\)_" limit t)
+ (= (length (match-string 1)) boundary)))
+ ;; We're in a block: get out of it
+ (goto-char (match-beginning 0))))))
+
+(defun org-list-search-unenclosed-generic (search re bound noerr)
+ "Search a string outside blocks and protected places.
+Arguments SEARCH, RE, BOUND and NOERR are similar to those in
+`search-forward', `search-backward', `re-search-forward' and
+`re-search-backward'."
+ (catch 'exit
+ (let ((origin (point)))
+ (while t
+ ;; 1. No match: return to origin or bound, depending on NOERR.
+ (unless (funcall search re bound noerr)
+ (throw 'exit (and (goto-char (if (memq noerr '(t nil)) origin bound))
+ nil)))
+ ;; 2. Match not in block or protected: return point. Else
+ ;; skip the block and carry on.
+ (unless (or (get-text-property (match-beginning 0) 'org-protected)
+ (org-list-maybe-skip-block search bound))
+ (throw 'exit (point)))))))
+
+(defun org-search-backward-unenclosed (regexp &optional bound noerror)
+ "Like `re-search-backward' but don't stop inside blocks or protected places.
+Arguments REGEXP, BOUND and NOERROR are similar to those used in
+`re-search-backward'."
+ (org-list-search-unenclosed-generic
+ #'re-search-backward regexp (or bound (point-min)) noerror))
+
+(defun org-search-forward-unenclosed (regexp &optional bound noerror)
+ "Like `re-search-forward' but don't stop inside blocks or protected places.
+Arguments REGEXP, BOUND and NOERROR are similar to those used in
+`re-search-forward'."
+ (org-list-search-unenclosed-generic
+ #'re-search-forward regexp (or bound (point-max)) noerror))
+
+(defun org-list-in-item-p-with-indent (limit)
+ "Is the cursor inside a plain list?
+Plain lists are considered ending when a non-blank line is less
+indented than the previous item within LIMIT."
+ (save-excursion
+ (beginning-of-line)
+ (cond
+ ;; do not start searching inside a block...
+ ((org-list-maybe-skip-block #'re-search-backward limit))
+ ;; ... or at a blank line
+ ((looking-at "^[ \t]*$")
+ (skip-chars-backward " \r\t\n")
+ (beginning-of-line)))
+ (beginning-of-line)
+ (or (org-at-item-p)
+ (let* ((case-fold-search t)
+ (ind-ref (org-get-indentation))
+ ;; Ensure there is at least an item above
+ (up-item-p (save-excursion
+ (org-search-backward-unenclosed
+ org-item-beginning-re limit t))))
+ (and up-item-p
+ (catch 'exit
+ (while t
+ (cond
+ ((org-at-item-p)
+ (throw 'exit (< (org-get-indentation) ind-ref)))
+ ((looking-at "^[ \t]*$")
+ (skip-chars-backward " \r\t\n")
+ (beginning-of-line))
+ ((looking-at "^[ \t]*#\\+end_")
+ (re-search-backward "^[ \t]*#\\+begin_"))
+ (t
+ (setq ind-ref (min (org-get-indentation) ind-ref))
+ (forward-line -1))))))))))
+
+(defun org-list-in-item-p-with-regexp (limit)
+ "Is the cursor inside a plain list?
+Plain lists end when `org-list-end-regexp' is matched, or at a
+blank line if `org-empty-line-terminates-plain-lists' is true.
+
+Argument LIMIT specifies the upper-bound of the search."
+ (save-excursion
+ (let* ((actual-pos (goto-char (point-at-eol)))
+ ;; Moved to eol so current line can be matched by
+ ;; `org-item-re'.
+ (last-item-start (save-excursion
+ (org-search-backward-unenclosed
+ org-item-beginning-re limit t)))
+ (list-ender (org-list-ending-between
+ last-item-start actual-pos)))
+ ;; We are in a list when we are on an item line or when we can
+ ;; find an item before point and there is no valid list ender
+ ;; between it and the point.
+ (and last-item-start (not list-ender)))))
+
+(defun org-list-top-point-with-regexp (limit)
+ "Return point at the top level item in a list.
+Argument LIMIT specifies the upper-bound of the search.
+
+List ending is determined by regexp. See
+`org-list-ending-method'. for more information."
+ (save-excursion
+ (let ((pos (point-at-eol)))
+ ;; Is there some list above this one ? If so, go to its ending.
+ ;; Otherwise, go back to the heading above or bob.
+ (goto-char (or (org-list-ending-between limit pos) limit))
+ ;; From there, search down our list.
+ (org-search-forward-unenclosed org-item-beginning-re pos t)
+ (point-at-bol))))
+
+(defun org-list-bottom-point-with-regexp (limit)
+ "Return point just before list ending.
+Argument LIMIT specifies the lower-bound of the search.
+
+List ending is determined by regexp. See
+`org-list-ending-method'. for more information."
+ (save-excursion
+ (let ((pos (org-get-item-beginning)))
+ ;; The list ending is either first point matching
+ ;; `org-list-end-re', point at first white-line before next
+ ;; heading, or eob.
+ (or (org-list-ending-between (min pos limit) limit t) limit))))
+
+(defun org-list-top-point-with-indent (limit)
+ "Return point at the top level in a list.
+Argument LIMIT specifies the upper-bound of the search.
+
+List ending is determined by indentation of text. See
+`org-list-ending-method'. for more information."
+ (save-excursion
+ (let ((case-fold-search t))
+ (let ((item-ref (goto-char (org-get-item-beginning)))
+ (ind-ref 10000))
+ (forward-line -1)
+ (catch 'exit
+ (while t
+ (let ((ind (org-get-indentation)))
+ (cond
+ ((looking-at "^[ \t]*:END:")
+ (throw 'exit item-ref))
+ ((<= (point) limit)
+ (throw 'exit
+ (if (and (org-at-item-p) (< ind ind-ref))
+ (point-at-bol)
+ item-ref)))
+ ((looking-at "^[ \t]*$")
+ (skip-chars-backward " \r\t\n")
+ (beginning-of-line))
+ ((looking-at "^[ \t]*#\\+end_")
+ (re-search-backward "^[ \t]*#\\+begin_"))
+ ((not (org-at-item-p))
+ (setq ind-ref (min ind ind-ref))
+ (forward-line -1))
+ ((>= ind ind-ref)
+ (throw 'exit item-ref))
+ (t
+ (setq item-ref (point-at-bol) ind-ref 10000)
+ (forward-line -1))))))))))
+
+(defun org-list-bottom-point-with-indent (limit)
+ "Return point just before list ending or nil if not in a list.
+Argument LIMIT specifies the lower-bound of the search.
+
+List ending is determined by the indentation of text. See
+`org-list-ending-method' for more information."
+ (save-excursion
+ (let ((ind-ref (progn
+ (goto-char (org-get-item-beginning))
+ (org-get-indentation)))
+ (case-fold-search t))
+ ;; do not start inside a block
+ (org-list-maybe-skip-block #'re-search-forward limit)
+ (beginning-of-line)
+ (catch 'exit
+ (while t
+ (skip-chars-forward " \t")
+ (let ((ind (org-get-indentation)))
+ (cond
+ ((or (>= (point) limit)
+ (looking-at ":END:"))
+ (throw 'exit (progn
+ ;; Ensure bottom is just after a
+ ;; non-blank line.
+ (skip-chars-backward " \r\t\n")
+ (min (point-max) (1+ (point-at-eol))))))
+ ((= (point) (point-at-eol))
+ (skip-chars-forward " \r\t\n")
+ (beginning-of-line))
+ ((org-at-item-p)
+ (setq ind-ref ind)
+ (forward-line 1))
+ ((<= ind ind-ref)
+ (throw 'exit (point-at-bol)))
+ ((looking-at "#\\+begin_")
+ (re-search-forward "[ \t]*#\\+end_")
+ (forward-line 1))
+ (t (forward-line 1)))))))))
+
+(defun org-list-at-regexp-after-bullet-p (regexp)
+ "Is point at a list item with REGEXP after bullet?"
+ (and (org-at-item-p)
+ (save-excursion
+ (goto-char (match-end 0))
+ ;; Ignore counter if any
+ (when (looking-at "\\(?:\\[@\\(?:start:\\)?[0-9]+\\][ \t]*\\)?")
+ (goto-char (match-end 0)))
+ (looking-at regexp))))
+
+(defun org-list-get-item-same-level (search-fun pos limit pre-move)
+ "Return point at the beginning of next item at the same level.
+Search items using function SEARCH-FUN, from POS to LIMIT. It
+uses PRE-MOVE before search. Return nil if no item was found."
+ (save-excursion
+ (goto-char pos)
+ (let* ((start (org-get-item-beginning))
+ (ind (progn (goto-char start) (org-get-indentation))))
+ ;; We don't want to match the current line.
+ (funcall pre-move)
+ ;; Skip any sublist on the way
+ (while (and (funcall search-fun org-item-beginning-re limit t)
+ (> (org-get-indentation) ind)))
+ (when (and (/= (point-at-bol) start) ; Have we moved ?
+ (= (org-get-indentation) ind))
+ (point-at-bol)))))
+
+(defun org-list-separating-blank-lines-number (pos top bottom)
+ "Return number of blank lines that should separate items in list.
+POS is the position of point to be considered.
+
+TOP and BOTTOM are respectively position of list beginning and
+list ending.
+
+Assume point is at item's beginning. If the item is alone, apply
+some heuristics to guess the result."
+ (save-excursion
+ (let ((insert-blank-p
+ (cdr (assq 'plain-list-item org-blank-before-new-entry)))
+ usr-blank)
+ (cond
+ ;; Trivial cases where there should be none.
+ ((or (and (not (eq org-list-ending-method 'indent))
+ org-empty-line-terminates-plain-lists)
+ (not insert-blank-p)) 0)
+ ;; When `org-blank-before-new-entry' says so, it is 1.
+ ((eq insert-blank-p t) 1)
+ ;; plain-list-item is 'auto. Count blank lines separating
+ ;; neighbours items in list.
+ (t (let ((next-p (org-get-next-item (point) bottom)))
+ (cond
+ ;; Is there a next item?
+ (next-p (goto-char next-p)
+ (org-back-over-empty-lines))
+ ;; Is there a previous item?
+ ((org-get-previous-item (point) top)
+ (org-back-over-empty-lines))
+ ;; User inserted blank lines, trust him
+ ((and (> pos (org-end-of-item-before-blank bottom))
+ (> (save-excursion
+ (goto-char pos)
+ (skip-chars-backward " \t")
+ (setq usr-blank (org-back-over-empty-lines))) 0))
+ usr-blank)
+ ;; Are there blank lines inside the item ?
+ ((save-excursion
+ (org-search-forward-unenclosed
+ "^[ \t]*$" (org-end-of-item-before-blank bottom) t)) 1)
+ ;; No parent: no blank line.
+ (t 0))))))))
+
+(defun org-list-insert-item-generic (pos &optional checkbox after-bullet)
+ "Insert a new list item at POS.
+If POS is before first character after bullet of the item, the
+new item will be created before the current one.
+
+Insert a checkbox if CHECKBOX is non-nil, and string AFTER-BULLET
+after the bullet. Cursor will be after this text once the
+function ends."
+ (goto-char pos)
+ ;; Is point in a special block?
+ (when (org-in-regexps-block-p
+ "^[ \t]*#\\+\\(begin\\|BEGIN\\)_\\([a-zA-Z0-9_]+\\)"
+ '(concat "^[ \t]*#\\+\\(end\\|END\\)_" (match-string 2)))
+ (if (not (cdr (assq 'insert org-list-automatic-rules)))
+ ;; Rule in `org-list-automatic-rules' forbids insertion.
+ (error "Cannot insert item inside a block")
+ ;; Else, move before it prior to add a new item.
+ (end-of-line)
+ (re-search-backward "^[ \t]*#\\+\\(begin\\|BEGIN\\)_" nil t)
+ (end-of-line 0)))
+ (let* ((true-pos (point))
+ (top (org-list-top-point))
+ (bottom (copy-marker (org-list-bottom-point)))
+ (bullet (and (goto-char (org-get-item-beginning))
+ (org-list-bullet-string (org-get-bullet))))
+ (ind (org-get-indentation))
+ (before-p (progn
+ ;; Description item: text starts after colons.
+ (or (org-at-item-description-p)
+ ;; At a checkbox: text starts after it.
+ (org-at-item-checkbox-p)
+ ;; Otherwise, text starts after bullet.
+ (org-at-item-p))
+ (<= true-pos (match-end 0))))
+ (blank-lines-nb (org-list-separating-blank-lines-number
+ true-pos top bottom))
+ (insert-fun
+ (lambda (text)
+ ;; insert bullet above item in order to avoid bothering
+ ;; with possible blank lines ending last item.
+ (goto-char (org-get-item-beginning))
+ (indent-to-column ind)
+ (insert (concat bullet (when checkbox "[ ] ") after-bullet))
+ ;; Stay between after-bullet and before text.
+ (save-excursion
+ (insert (concat text (make-string (1+ blank-lines-nb) ?\n))))
+ (unless before-p
+ ;; store bottom: exchanging items doesn't change list
+ ;; bottom point but will modify marker anyway
+ (setq bottom (marker-position bottom))
+ (let ((col (current-column)))
+ (org-list-exchange-items
+ (org-get-item-beginning) (org-get-next-item (point) bottom)
+ bottom)
+ ;; recompute next-item: last sexp modified list
+ (goto-char (org-get-next-item (point) bottom))
+ (org-move-to-column col)))
+ ;; checkbox update might modify bottom point, so use a
+ ;; marker here
+ (setq bottom (copy-marker bottom))
+ (when checkbox (org-update-checkbox-count-maybe))
+ (org-list-repair nil top bottom))))
+ (goto-char true-pos)
+ (cond
+ (before-p (funcall insert-fun nil) t)
+ ;; Can't split item: insert bullet at the end of item.
+ ((not (org-get-alist-option org-M-RET-may-split-line 'item))
+ (funcall insert-fun nil) t)
+ ;; else, insert a new bullet along with everything from point
+ ;; down to last non-blank line of item.
+ (t
+ (delete-horizontal-space)
+ ;; Get pos again in case previous command modified line.
+ (let* ((pos (point))
+ (end-before-blank (org-end-of-item-before-blank bottom))
+ (after-text
+ (when (< pos end-before-blank)
+ (prog1
+ (delete-and-extract-region pos end-before-blank)
+ ;; delete any blank line at and before point.
+ (beginning-of-line)
+ (while (looking-at "^[ \t]*$")
+ (delete-region (point-at-bol) (1+ (point-at-eol)))
+ (beginning-of-line 0))))))
+ (funcall insert-fun after-text) t)))))
+
+(defvar org-last-indent-begin-marker (make-marker))
+(defvar org-last-indent-end-marker (make-marker))
+
+(defun org-list-indent-item-generic (arg no-subtree top bottom)
+ "Indent a local list item including its children.
+When number ARG is a negative, item will be outdented, otherwise
+it will be indented.
-;;; Plain list items
+If a region is active, all items inside will be moved.
+
+If NO-SUBTREE is non-nil, only indent the item itself, not its
+children.
+
+TOP and BOTTOM are respectively position at item beginning and at
+item ending.
+
+Return t if successful."
+ (let* ((regionp (org-region-active-p))
+ (rbeg (and regionp (region-beginning)))
+ (rend (and regionp (region-end))))
+ (cond
+ ((and regionp
+ (goto-char rbeg)
+ (not (org-search-forward-unenclosed org-item-beginning-re rend t)))
+ (error "No item in region"))
+ ((not (org-at-item-p))
+ (error "Not on an item"))
+ (t
+ ;; Are we going to move the whole list?
+ (let* ((specialp (and (cdr (assq 'indent org-list-automatic-rules))
+ (not no-subtree)
+ (= top (point-at-bol)))))
+ ;; Determine begin and end points of zone to indent. If moving
+ ;; more than one item, ensure we keep them on subsequent moves.
+ (unless (and (memq last-command '(org-shiftmetaright org-shiftmetaleft))
+ (memq this-command '(org-shiftmetaright org-shiftmetaleft)))
+ (if regionp
+ (progn
+ (set-marker org-last-indent-begin-marker rbeg)
+ (set-marker org-last-indent-end-marker rend))
+ (set-marker org-last-indent-begin-marker (point-at-bol))
+ (set-marker org-last-indent-end-marker
+ (save-excursion
+ (cond
+ (specialp bottom)
+ (no-subtree (org-end-of-item-or-at-child bottom))
+ (t (org-get-end-of-item bottom)))))))
+ ;; Get everything ready
+ (let* ((beg (marker-position org-last-indent-begin-marker))
+ (end (marker-position org-last-indent-end-marker))
+ (struct (org-list-struct
+ beg end top (if specialp end bottom) (< arg 0)))
+ (origins (org-list-struct-origins struct))
+ (beg-item (assq beg struct)))
+ (cond
+ ;; Special case: moving top-item with indent rule
+ (specialp
+ (let* ((level-skip (org-level-increment))
+ (offset (if (< arg 0) (- level-skip) level-skip))
+ (top-ind (nth 1 beg-item)))
+ (if (< (+ top-ind offset) 0)
+ (error "Cannot outdent beyond margin")
+ ;; Change bullet if necessary
+ (when (and (= (+ top-ind offset) 0)
+ (string-match "*" (nth 2 beg-item)))
+ (setcdr beg-item (list (nth 1 beg-item)
+ (org-list-bullet-string "-"))))
+ ;; Shift ancestor
+ (let ((anc (car struct)))
+ (setcdr anc (list (+ (nth 1 anc) offset) "" nil)))
+ (org-list-struct-fix-struct struct origins)
+ (org-list-struct-apply-struct struct end))))
+ ;; Forbidden move
+ ((and (< arg 0)
+ (or (and no-subtree
+ (not regionp)
+ (org-list-struct-get-child beg-item struct))
+ (let ((last-item (save-excursion
+ (goto-char end)
+ (skip-chars-backward " \r\t\n")
+ (goto-char (org-get-item-beginning))
+ (org-list-struct-assoc-at-point))))
+ (org-list-struct-get-child last-item struct))))
+ (error "Cannot outdent an item without its children"))
+ ;; Normal shifting
+ (t
+ (let* ((shifted-ori (if (< arg 0)
+ (org-list-struct-outdent beg end origins)
+ (org-list-struct-indent beg end origins struct))))
+ (org-list-struct-fix-struct struct shifted-ori)
+ (org-list-struct-apply-struct struct bottom))))))))))
+
+;;; Predicates
+
+(defun org-in-item-p ()
+ "Is the cursor inside a plain list?
+This checks `org-list-ending-method'."
+ (unless (let ((outline-regexp org-outline-regexp)) (org-at-heading-p))
+ (let* ((prev-head (save-excursion (outline-previous-heading)))
+ (bound (if prev-head
+ (or (save-excursion
+ (let ((case-fold-search t))
+ (re-search-backward "^[ \t]*:END:" prev-head t)))
+ prev-head)
+ (point-min))))
+ (cond
+ ((eq org-list-ending-method 'regexp)
+ (org-list-in-item-p-with-regexp bound))
+ ((eq org-list-ending-method 'indent)
+ (org-list-in-item-p-with-indent bound))
+ (t (and (org-list-in-item-p-with-regexp bound)
+ (org-list-in-item-p-with-indent bound)))))))
+
+(defun org-list-first-item-p (top)
+ "Is this item the first item in a plain list?
+Assume point is at an item.
+
+TOP is the position of list's top-item."
+ (save-excursion
+ (beginning-of-line)
+ (let ((ind (org-get-indentation)))
+ (or (not (org-search-backward-unenclosed org-item-beginning-re top t))
+ (< (org-get-indentation) ind)))))
(defun org-at-item-p ()
"Is point in a line starting a hand-formatted item?"
- (let ((llt org-plain-list-ordered-item-terminator))
- (save-excursion
- (goto-char (point-at-bol))
- (looking-at
- (cond
- ((eq llt t) "\\([ \t]*\\([-+]\\|\\([0-9]+[.)]\\)\\)\\|[ \t]+\\*\\)\\( \\|$\\)")
- ((= llt ?.) "\\([ \t]*\\([-+]\\|\\([0-9]+\\.\\)\\)\\|[ \t]+\\*\\)\\( \\|$\\)")
- ((= llt ?\)) "\\([ \t]*\\([-+]\\|\\([0-9]+)\\)\\)\\|[ \t]+\\*\\)\\( \\|$\\)")
- (t (error "Invalid value of `org-plain-list-ordered-item-terminator'")))))))
+ (save-excursion
+ (beginning-of-line) (looking-at org-item-beginning-re)))
(defun org-at-item-bullet-p ()
"Is point at the bullet of a plain list item?"
@@ -213,170 +816,18 @@ list, obtained by prompting the user."
(not (member (char-after) '(?\ ?\t)))
(< (point) (match-end 0))))
-(defun org-in-item-p ()
- "It the cursor inside a plain list item.
-Does not have to be the first line."
- (save-excursion
- (condition-case nil
- (progn
- (org-beginning-of-item)
- (org-at-item-p)
- t)
- (error nil))))
-
-(defun org-insert-item (&optional checkbox)
- "Insert a new item at the current level.
-Return t when things worked, nil when we are not in an item."
- (when (save-excursion
- (condition-case nil
- (progn
- (org-beginning-of-item)
- (org-at-item-p)
- (if (org-invisible-p) (error "Invisible item"))
- t)
- (error nil)))
- (let* ((bul (match-string 0))
- (descp (save-excursion (goto-char (match-beginning 0))
- (beginning-of-line 1)
- (save-match-data
- (and (looking-at "[ \t]*\\(.*?\\) ::")
- (match-string 1)))))
- (empty-line-p (save-excursion
- (goto-char (match-beginning 0))
- (and (not (bobp))
- (or (beginning-of-line 0) t)
- (save-match-data
- (looking-at "[ \t]*$")))))
- (timerp (and descp
- (save-match-data
- (string-match "^[-+*][ \t]+[0-9]+:[0-9]+:[0-9]+$"
- descp))))
- (eow (save-excursion (beginning-of-line 1) (looking-at "[ \t]*")
- (match-end 0)))
- (blank-a (if org-empty-line-terminates-plain-lists
- nil
- (cdr (assq 'plain-list-item org-blank-before-new-entry))))
- (blank (if (eq blank-a 'auto) empty-line-p blank-a))
- pos)
- (if descp (setq checkbox nil))
- (if timerp
- (progn (org-timer-item) t)
- (cond
- ((and (org-at-item-p) (<= (point) eow))
- ;; before the bullet
- (beginning-of-line 1)
- (open-line (if blank 2 1)))
- ((<= (point) eow)
- (beginning-of-line 1))
- (t
- (unless (org-get-alist-option org-M-RET-may-split-line 'item)
- (end-of-line 1)
- (delete-horizontal-space))
- (newline (if blank 2 1))))
- (insert bul
- (if checkbox "[ ]" "")
- (if descp (concat (if checkbox " " "")
- (read-string "Term: ") " :: ") ""))
- (just-one-space)
- (setq pos (point))
- (end-of-line 1)
- (unless (= (point) pos) (just-one-space) (backward-delete-char 1)))
- (org-maybe-renumber-ordered-list)
- (and checkbox (org-update-checkbox-count-maybe))
- t)))
+(defun org-at-item-timer-p ()
+ "Is point at a line starting a plain list item with a timer?"
+ (org-list-at-regexp-after-bullet-p
+ "\\([0-9]+:[0-9]+:[0-9]+\\)[ \t]+::[ \t]+"))
-;;; Checkboxes
+(defun org-at-item-description-p ()
+ "Is point at a description list item?"
+ (org-list-at-regexp-after-bullet-p "\\(\\S-.+\\)[ \t]+::[ \t]+"))
(defun org-at-item-checkbox-p ()
"Is point at a line starting a plain-list item with a checklet?"
- (and (org-at-item-p)
- (save-excursion
- (goto-char (match-end 0))
- (skip-chars-forward " \t")
- (looking-at "\\[[- X]\\]"))))
-
-(defun org-toggle-checkbox (&optional toggle-presence)
- "Toggle the checkbox in the current line.
-With prefix arg TOGGLE-PRESENCE, add or remove checkboxes.
-With double prefix, set checkbox to [-].
-When there is an active region, toggle status or presence of the checkbox
-in the first line, and make every item in the region have the same
-status or presence, respectively.
-If the cursor is in a headline, apply this to all checkbox items in the
-text below the heading."
- (interactive "P")
- (catch 'exit
- (let (beg end status first-present first-status blocked)
- (cond
- ((org-region-active-p)
- (setq beg (region-beginning) end (region-end)))
- ((org-on-heading-p)
- (setq beg (point) end (save-excursion (outline-next-heading) (point))))
- ((org-at-item-checkbox-p)
- (save-excursion
- (if (equal toggle-presence '(4))
- (progn
- (replace-match "")
- (goto-char (match-beginning 0))
- (just-one-space))
- (when (setq blocked (org-checkbox-blocked-p))
- (error "Checkbox blocked because of unchecked box in line %d"
- blocked))
- (replace-match
- (cond ((equal toggle-presence '(16)) "[-]")
- ((member (match-string 0) '("[ ]" "[-]")) "[X]")
- (t "[ ]"))
- t t)))
- (throw 'exit t))
- ((org-at-item-p)
- ;; add a checkbox
- (save-excursion
- (goto-char (match-end 0))
- (insert "[ ] "))
- (throw 'exit t))
- (t (error "Not at a checkbox or heading, and no active region")))
- (setq end (move-marker (make-marker) end))
- (save-excursion
- (goto-char beg)
- (setq first-present (org-at-item-checkbox-p)
- first-status
- (save-excursion
- (and (re-search-forward "[ \t]\\(\\[[ X]\\]\\)" end t)
- (equal (match-string 1) "[X]"))))
- (while (< (point) end)
- (if toggle-presence
- (cond
- ((and first-present (org-at-item-checkbox-p))
- (save-excursion
- (replace-match "")
- (goto-char (match-beginning 0))
- (just-one-space)))
- ((and (not first-present) (not (org-at-item-checkbox-p))
- (org-at-item-p))
- (save-excursion
- (goto-char (match-end 0))
- (insert "[ ] "))))
- (when (org-at-item-checkbox-p)
- (setq status (equal (match-string 0) "[X]"))
- (replace-match
- (if first-status "[ ]" "[X]") t t)))
- (beginning-of-line 2)))))
- (org-update-checkbox-count-maybe))
-
-(defun org-reset-checkbox-state-subtree ()
- "Reset all checkboxes in an entry subtree."
- (interactive "*")
- (save-restriction
- (save-excursion
- (org-narrow-to-subtree)
- (org-show-subtree)
- (goto-char (point-min))
- (let ((end (point-max)))
- (while (< (point) end)
- (when (org-at-item-checkbox-p)
- (replace-match "[ ]" t t))
- (beginning-of-line 2))))
- (org-update-checkbox-count-maybe)))
+ (org-list-at-regexp-after-bullet-p "\\(\\[[- X]\\]\\)[ \t]+"))
(defun org-checkbox-blocked-p ()
"Is the current checkbox blocked from for being checked now?
@@ -389,403 +840,621 @@ A checkbox is blocked if all of the following conditions are fulfilled:
(save-match-data
(save-excursion
(unless (org-at-item-checkbox-p) (throw 'exit nil))
- (when (equal (match-string 0) "[X]")
+ (when (equal (match-string 1) "[X]")
;; the box is already checked!
(throw 'exit nil))
(let ((end (point-at-bol)))
(condition-case nil (org-back-to-heading t)
(error (throw 'exit nil)))
(unless (org-entry-get nil "ORDERED") (throw 'exit nil))
- (if (re-search-forward "^[ \t]*[-+*0-9.)] \\[[- ]\\]" end t)
- (org-current-line)
- nil))))))
+ (when (org-search-forward-unenclosed
+ "^[ \t]*[-+*0-9.)]+[ \t]+\\(\\[@\\(?:start:\\)?[0-9]+\\][ \t]*\\)?\\[[- ]\\]" end t)
+ (org-current-line)))))))
+
+;;; Navigate
+
+;; Every interactive navigation function is derived from a
+;; non-interactive one, which doesn't move point, assumes point is
+;; already in a list and doesn't compute list boundaries.
+
+;; If you plan to use more than one org-list function is some code,
+;; you should therefore first check if point is in a list with
+;; `org-in-item-p' or `org-at-item-p', then compute list boundaries
+;; with `org-list-top-point' and `org-list-bottom-point', and make use
+;; of non-interactive forms.
+
+(defun org-list-top-point ()
+ "Return point at the top level in a list.
+Assume point is in a list."
+ (let* ((prev-head (save-excursion (outline-previous-heading)))
+ (bound (if prev-head
+ (or (save-excursion
+ (let ((case-fold-search t))
+ (re-search-backward "^[ \t]*:END:" prev-head t)))
+ prev-head)
+ (point-min))))
+ (cond
+ ((eq org-list-ending-method 'regexp)
+ (org-list-top-point-with-regexp bound))
+ ((eq org-list-ending-method 'indent)
+ (org-list-top-point-with-indent bound))
+ (t (let ((top-re (org-list-top-point-with-regexp bound)))
+ (org-list-top-point-with-indent (or top-re bound)))))))
+
+(defun org-list-bottom-point ()
+ "Return point just before list ending.
+Assume point is in a list."
+ (let* ((next-head (save-excursion
+ (and (let ((outline-regexp org-outline-regexp))
+ ;; Use default regexp because folding
+ ;; changes OUTLINE-REGEXP.
+ (outline-next-heading)))))
+ (limit (or (save-excursion
+ (and (re-search-forward "^[ \t]*:END:" next-head t)
+ (point-at-bol)))
+ next-head
+ (point-max))))
+ (cond
+ ((eq org-list-ending-method 'regexp)
+ (org-list-bottom-point-with-regexp limit))
+ ((eq org-list-ending-method 'indent)
+ (org-list-bottom-point-with-indent limit))
+ (t (let ((bottom-re (org-list-bottom-point-with-regexp limit)))
+ (org-list-bottom-point-with-indent (or bottom-re limit)))))))
+
+(defun org-get-item-beginning ()
+ "Return position of current item beginning."
+ (save-excursion
+ ;; possibly match current line
+ (end-of-line)
+ (org-search-backward-unenclosed org-item-beginning-re nil t)
+ (point-at-bol)))
-(defvar org-checkbox-statistics-hook nil
- "Hook that is run whenever Org thinks checkbox statistics should be updated.
-This hook runs even if `org-provide-checkbox-statistics' is nil, to it can
-be used to implement alternative ways of collecting statistics information.")
+(defun org-beginning-of-item ()
+ "Go to the beginning of the current hand-formatted item.
+If the cursor is not in an item, throw an error."
+ (interactive)
+ (if (org-in-item-p)
+ (goto-char (org-get-item-beginning))
+ (error "Not in an item")))
-(defun org-update-checkbox-count-maybe ()
- "Update checkbox statistics unless turned off by user."
- (when org-provide-checkbox-statistics
- (org-update-checkbox-count))
- (run-hooks 'org-checkbox-statistics-hook))
+(defun org-get-beginning-of-list (top)
+ "Return position of the first item of the current list or sublist.
+TOP is the position at list beginning."
+ (save-excursion
+ (let (prev-p)
+ (while (setq prev-p (org-get-previous-item (point) top))
+ (goto-char prev-p))
+ (point-at-bol))))
-(defun org-update-checkbox-count (&optional all)
- "Update the checkbox statistics in the current section.
-This will find all statistic cookies like [57%] and [6/12] and update them
-with the current numbers. With optional prefix argument ALL, do this for
-the whole buffer."
- (interactive "P")
- (save-excursion
- (let* ((buffer-invisibility-spec (org-inhibit-invisibility)) ; Emacs 21
- (beg (condition-case nil
- (progn (org-back-to-heading) (point))
- (error (point-min))))
- (end (move-marker (make-marker)
- (progn (outline-next-heading) (point))))
- (re "\\(\\(\\[[0-9]*%\\]\\)\\|\\(\\[[0-9]*/[0-9]*\\]\\)\\)")
- (re-box "^[ \t]*\\([-+*]\\|[0-9]+[.)]\\) +\\(\\[[- X]\\]\\)")
- (re-find (concat re "\\|" re-box))
- beg-cookie end-cookie is-percent c-on c-off lim new
- eline curr-ind next-ind continue-from startsearch
- (recursive
- (or (not org-hierarchical-checkbox-statistics)
- (string-match "\\<recursive\\>"
- (or (org-entry-get nil "COOKIE_DATA") ""))))
- (cstat 0)
- )
- (when all
- (goto-char (point-min))
- (outline-next-heading)
- (setq beg (point) end (point-max)))
- (goto-char end)
- ;; find each statistics cookie
- (while (and (re-search-backward re-find beg t)
- (not (save-match-data
- (and (org-on-heading-p)
- (string-match "\\<todo\\>"
- (downcase
- (or (org-entry-get
- nil "COOKIE_DATA")
- "")))))))
- (setq beg-cookie (match-beginning 1)
- end-cookie (match-end 1)
- cstat (+ cstat (if end-cookie 1 0))
- startsearch (point-at-eol)
- continue-from (match-beginning 0)
- is-percent (match-beginning 2)
- lim (cond
- ((org-on-heading-p) (outline-next-heading) (point))
- ((org-at-item-p) (org-end-of-item) (point))
- (t nil))
- c-on 0
- c-off 0)
- (when lim
- ;; find first checkbox for this cookie and gather
- ;; statistics from all that are at this indentation level
- (goto-char startsearch)
- (if (re-search-forward re-box lim t)
- (progn
- (org-beginning-of-item)
- (setq curr-ind (org-get-indentation))
- (setq next-ind curr-ind)
- (while (and (bolp) (org-at-item-p)
- (if recursive
- (<= curr-ind next-ind)
- (= curr-ind next-ind)))
- (save-excursion (end-of-line) (setq eline (point)))
- (if (re-search-forward re-box eline t)
- (if (member (match-string 2) '("[ ]" "[-]"))
- (setq c-off (1+ c-off))
- (setq c-on (1+ c-on))))
- (if (not recursive)
- (org-end-of-item)
- (end-of-line)
- (when (re-search-forward org-list-beginning-re lim t)
- (beginning-of-line)))
- (setq next-ind (org-get-indentation)))))
- (goto-char continue-from)
- ;; update cookie
- (when end-cookie
- (setq new (if is-percent
- (format "[%d%%]" (/ (* 100 c-on) (max 1 (+ c-on c-off))))
- (format "[%d/%d]" c-on (+ c-on c-off))))
- (goto-char beg-cookie)
- (insert new)
- (delete-region (point) (+ (point) (- end-cookie beg-cookie))))
- ;; update items checkbox if it has one
- (when (org-at-item-p)
- (org-beginning-of-item)
- (when (and (> (+ c-on c-off) 0)
- (re-search-forward re-box (point-at-eol) t))
- (setq beg-cookie (match-beginning 2)
- end-cookie (match-end 2))
- (delete-region beg-cookie end-cookie)
- (goto-char beg-cookie)
- (cond ((= c-off 0) (insert "[X]"))
- ((= c-on 0) (insert "[ ]"))
- (t (insert "[-]")))
- )))
- (goto-char continue-from))
- (when (interactive-p)
- (message "Checkbox statistics updated %s (%d places)"
- (if all "in entire file" "in current outline entry") cstat)))))
+(defun org-beginning-of-item-list ()
+ "Go to the beginning item of the current list or sublist.
+Return an error if not in a list."
+ (interactive)
+ (if (org-in-item-p)
+ (goto-char (org-get-beginning-of-list (org-list-top-point)))
+ (error "Not in an item")))
-(defun org-get-checkbox-statistics-face ()
- "Select the face for checkbox statistics.
-The face will be `org-done' when all relevant boxes are checked. Otherwise
-it will be `org-todo'."
- (if (match-end 1)
- (if (equal (match-string 1) "100%")
- 'org-checkbox-statistics-done
- 'org-checkbox-statistics-todo)
- (if (and (> (match-end 2) (match-beginning 2))
- (equal (match-string 2) (match-string 3)))
- 'org-checkbox-statistics-done
- 'org-checkbox-statistics-todo)))
+(defun org-get-end-of-list (bottom)
+ "Return position at the end of the current list or sublist.
+BOTTOM is the position at list ending."
+ (save-excursion
+ (goto-char (org-get-item-beginning))
+ (let ((ind (org-get-indentation)))
+ (while (and (/= (point) bottom)
+ (>= (org-get-indentation) ind))
+ (org-search-forward-unenclosed org-item-beginning-re bottom 'move))
+ (if (= (point) bottom) bottom (point-at-bol)))))
-(defun org-beginning-of-item ()
- "Go to the beginning of the current hand-formatted item.
-If the cursor is not in an item, throw an error."
+(defun org-end-of-item-list ()
+ "Go to the end of the current list or sublist.
+If the cursor in not in an item, throw an error."
(interactive)
- (let ((pos (point))
- (limit (save-excursion
- (condition-case nil
- (progn
- (org-back-to-heading)
- (beginning-of-line 2) (point))
- (error (point-min)))))
- (ind-empty (if org-empty-line-terminates-plain-lists 0 10000))
- ind ind1)
- (if (org-at-item-p)
- (beginning-of-line 1)
- (beginning-of-line 1)
- (skip-chars-forward " \t")
- (setq ind (current-column))
- (if (catch 'exit
- (while t
- (beginning-of-line 0)
- (if (or (bobp) (< (point) limit)) (throw 'exit nil))
-
- (if (looking-at "[ \t]*$")
- (setq ind1 ind-empty)
- (skip-chars-forward " \t")
- (setq ind1 (current-column)))
- (if (< ind1 ind)
- (progn (beginning-of-line 1) (throw 'exit (org-at-item-p))))))
- nil
- (goto-char pos)
- (error "Not in an item")))))
+ (if (org-in-item-p)
+ (goto-char (org-get-end-of-list (org-list-bottom-point)))
+ (error "Not in an item")))
+
+(defun org-get-end-of-item (bottom)
+ "Return position at the end of the current item.
+BOTTOM is the position at list ending."
+ (or (org-get-next-item (point) bottom)
+ (org-get-end-of-list bottom)))
(defun org-end-of-item ()
"Go to the end of the current hand-formatted item.
If the cursor is not in an item, throw an error."
(interactive)
- (let* ((pos (point))
- ind1
- (ind-empty (if org-empty-line-terminates-plain-lists 0 10000))
- (limit (save-excursion (outline-next-heading) (point)))
- (ind (save-excursion
- (org-beginning-of-item)
- (skip-chars-forward " \t")
- (current-column)))
- (end (catch 'exit
- (while t
- (beginning-of-line 2)
- (if (eobp) (throw 'exit (point)))
- (if (>= (point) limit) (throw 'exit (point-at-bol)))
- (if (looking-at "[ \t]*$")
- (setq ind1 ind-empty)
- (skip-chars-forward " \t")
- (setq ind1 (current-column)))
- (if (<= ind1 ind)
- (throw 'exit (point-at-bol)))))))
- (if end
- (goto-char end)
- (goto-char pos)
- (error "Not in an item"))))
+ (if (org-in-item-p)
+ (goto-char (org-get-end-of-item (org-list-bottom-point)))
+ (error "Not in an item")))
+
+(defun org-end-of-item-or-at-child (bottom)
+ "Move to the end of the item, stops before the first child if any.
+BOTTOM is the position at list ending."
+ (end-of-line)
+ (goto-char
+ (if (org-search-forward-unenclosed org-item-beginning-re bottom t)
+ (point-at-bol)
+ (org-get-end-of-item bottom))))
+
+(defun org-end-of-item-before-blank (bottom)
+ "Return point at end of item, before any blank line.
+Point returned is at eol.
+
+BOTTOM is the position at list ending."
+ (save-excursion
+ (goto-char (org-get-end-of-item bottom))
+ (skip-chars-backward " \r\t\n")
+ (point-at-eol)))
-(defun org-next-item ()
- "Move to the beginning of the next item in the current plain list.
-Error if not at a plain list, or if this is the last item in the list."
- (interactive)
- (let (ind ind1 (pos (point)))
- (org-beginning-of-item)
- (setq ind (org-get-indentation))
- (org-end-of-item)
- (setq ind1 (org-get-indentation))
- (unless (and (org-at-item-p) (= ind ind1))
- (goto-char pos)
- (error "On last item"))))
+(defun org-get-previous-item (pos limit)
+ "Return point of the previous item at the same level as POS.
+Stop searching at LIMIT. Return nil if no item is found."
+ (org-list-get-item-same-level
+ #'org-search-backward-unenclosed pos limit #'beginning-of-line))
(defun org-previous-item ()
- "Move to the beginning of the previous item in the current plain list.
-Error if not at a plain list, or if this is the first item in the list."
+ "Move to the beginning of the previous item.
+Item is at the same level in the current plain list. Error if not
+in a plain list, or if this is the first item in the list."
(interactive)
- (let (beg ind ind1 (pos (point)))
- (org-beginning-of-item)
- (setq beg (point))
- (setq ind (org-get-indentation))
- (goto-char beg)
- (catch 'exit
- (while t
- (beginning-of-line 0)
- (if (looking-at "[ \t]*$")
- nil
- (if (<= (setq ind1 (org-get-indentation)) ind)
- (throw 'exit t)))))
- (condition-case nil
- (if (or (not (org-at-item-p))
- (< ind1 (1- ind)))
- (error "")
- (org-beginning-of-item))
- (error (goto-char pos)
- (error "On first item")))))
-
-(defun org-first-list-item-p ()
- "Is this heading the first item in a plain list?"
- (unless (org-at-item-p)
- (error "Not at a plain list item"))
+ (if (not (org-in-item-p))
+ (error "Not in an item")
+ (let ((prev-p (org-get-previous-item (point) (org-list-top-point))))
+ (if prev-p (goto-char prev-p) (error "On first item")))))
+
+(defun org-get-next-item (pos limit)
+ "Return point of the next item at the same level as POS.
+Stop searching at LIMIT. Return nil if no item is found."
+ (org-list-get-item-same-level
+ #'org-search-forward-unenclosed pos limit #'end-of-line))
+
+(defun org-next-item ()
+ "Move to the beginning of the next item.
+Item is at the same level in the current plain list. Error if not
+in a plain list, or if this is the last item in the list."
+ (interactive)
+ (if (not (org-in-item-p))
+ (error "Not in an item")
+ (let ((next-p (org-get-next-item (point) (org-list-bottom-point))))
+ (if next-p (goto-char next-p) (error "On last item")))))
+
+;;; Manipulate
+
+(defun org-list-exchange-items (beg-A beg-B bottom)
+ "Swap item starting at BEG-A with item starting at BEG-B.
+Blank lines at the end of items are left in place. Assume BEG-A
+is lesser than BEG-B.
+
+BOTTOM is the position at list ending."
(save-excursion
- (org-beginning-of-item)
- (= (point) (save-excursion (org-beginning-of-item-list)))))
+ (let* ((end-of-item-no-blank
+ (lambda (pos)
+ (goto-char pos)
+ (goto-char (org-end-of-item-before-blank bottom))))
+ (end-A-no-blank (funcall end-of-item-no-blank beg-A))
+ (end-B-no-blank (funcall end-of-item-no-blank beg-B))
+ (body-A (buffer-substring beg-A end-A-no-blank))
+ (body-B (buffer-substring beg-B end-B-no-blank))
+ (between-A-no-blank-and-B (buffer-substring end-A-no-blank beg-B)))
+ (goto-char beg-A)
+ (delete-region beg-A end-B-no-blank)
+ (insert (concat body-B between-A-no-blank-and-B body-A)))))
(defun org-move-item-down ()
"Move the plain list item at point down, i.e. swap with following item.
Subitems (items with larger indentation) are considered part of the item,
so this really moves item trees."
(interactive)
- (let ((col (current-column))
- (pos (point))
- beg beg0 end end0 ind ind1 txt ne-end ne-beg)
- (org-beginning-of-item)
- (setq beg0 (point))
- (save-excursion
- (setq ne-beg (org-back-over-empty-lines))
- (setq beg (point)))
- (goto-char beg0)
- (setq ind (org-get-indentation))
- (org-end-of-item)
- (setq end0 (point))
- (setq ind1 (org-get-indentation))
- (setq ne-end (org-back-over-empty-lines))
- (setq end (point))
- (goto-char beg0)
- (when (and (org-first-list-item-p) (< ne-end ne-beg))
- ;; include less whitespace
- (save-excursion
- (goto-char beg)
- (forward-line (- ne-beg ne-end))
- (setq beg (point))))
- (goto-char end0)
- (if (and (org-at-item-p) (= ind ind1))
- (progn
- (org-end-of-item)
- (org-back-over-empty-lines)
- (setq txt (buffer-substring beg end))
- (save-excursion
- (delete-region beg end))
- (setq pos (point))
- (insert txt)
- (goto-char pos) (org-skip-whitespace)
- (org-maybe-renumber-ordered-list)
- (move-to-column col))
- (goto-char pos)
- (move-to-column col)
- (error "Cannot move this item further down"))))
-
-(defun org-move-item-up (arg)
+ (if (not (org-at-item-p))
+ (error "Not at an item")
+ (let* ((pos (point))
+ (col (current-column))
+ (bottom (org-list-bottom-point))
+ (actual-item (goto-char (org-get-item-beginning)))
+ (next-item (org-get-next-item (point) bottom)))
+ (if (not next-item)
+ (progn
+ (goto-char pos)
+ (error "Cannot move this item further down"))
+ (org-list-exchange-items actual-item next-item bottom)
+ (org-list-repair nil nil bottom)
+ (goto-char (org-get-next-item (point) bottom))
+ (move-to-column col)))))
+
+(defun org-move-item-up ()
"Move the plain list item at point up, i.e. swap with previous item.
Subitems (items with larger indentation) are considered part of the item,
so this really moves item trees."
- (interactive "p")
- (let ((col (current-column)) (pos (point))
- beg beg0 end ind ind1 txt
- ne-beg ne-ins ins-end)
- (org-beginning-of-item)
- (setq beg0 (point))
- (setq ind (org-get-indentation))
- (save-excursion
- (setq ne-beg (org-back-over-empty-lines))
- (setq beg (point)))
- (goto-char beg0)
- (org-end-of-item)
- (org-back-over-empty-lines)
- (setq end (point))
- (goto-char beg0)
- (catch 'exit
- (while t
- (beginning-of-line 0)
- (if (looking-at "[ \t]*$")
- (if org-empty-line-terminates-plain-lists
- (progn
- (goto-char pos)
- (error "Cannot move this item further up"))
- nil)
- (if (<= (setq ind1 (org-get-indentation)) ind)
- (throw 'exit t)))))
- (condition-case nil
- (org-beginning-of-item)
- (error (goto-char beg0)
- (move-to-column col)
- (error "Cannot move this item further up")))
- (setq ind1 (org-get-indentation))
- (if (and (org-at-item-p) (= ind ind1))
- (progn
- (setq ne-ins (org-back-over-empty-lines))
- (setq txt (buffer-substring beg end))
- (save-excursion
- (delete-region beg end))
- (setq pos (point))
- (insert txt)
- (setq ins-end (point))
- (goto-char pos) (org-skip-whitespace)
-
- (when (and (org-first-list-item-p) (> ne-ins ne-beg))
- ;; Move whitespace back to beginning
- (save-excursion
- (goto-char ins-end)
- (let ((kill-whole-line t))
- (kill-line (- ne-ins ne-beg)) (point)))
- (insert (make-string (- ne-ins ne-beg) ?\n)))
-
- (org-maybe-renumber-ordered-list)
- (move-to-column col))
- (goto-char pos)
- (move-to-column col)
- (error "Cannot move this item further up"))))
-
-(defun org-maybe-renumber-ordered-list ()
- "Renumber the ordered list at point if setup allows it.
-This tests the user option `org-auto-renumber-ordered-lists' before
-doing the renumbering."
(interactive)
- (when (and org-auto-renumber-ordered-lists
- (org-at-item-p))
- (if (match-beginning 3)
- (org-renumber-ordered-list 1)
- (org-fix-bullet-type))))
-
-(defun org-maybe-renumber-ordered-list-safe ()
- (condition-case nil
- (save-excursion
- (org-maybe-renumber-ordered-list))
- (error nil)))
+ (if (not (org-at-item-p))
+ (error "Not at an item")
+ (let* ((pos (point))
+ (col (current-column))
+ (top (org-list-top-point))
+ (bottom (org-list-bottom-point))
+ (actual-item (goto-char (org-get-item-beginning)))
+ (prev-item (org-get-previous-item (point) top)))
+ (if (not prev-item)
+ (progn
+ (goto-char pos)
+ (error "Cannot move this item further up"))
+ (org-list-exchange-items prev-item actual-item bottom)
+ (org-list-repair nil top bottom)
+ (move-to-column col)))))
-(defun org-cycle-list-bullet (&optional which)
- "Cycle through the different itemize/enumerate bullets.
-This cycle the entire list level through the sequence:
+(defun org-insert-item (&optional checkbox)
+ "Insert a new item at the current level.
+If cursor is before first character after bullet of the item, the
+new item will be created before the current one.
- `-' -> `+' -> `*' -> `1.' -> `1)'
+If CHECKBOX is non-nil, add a checkbox next to the bullet.
-If WHICH is a string, use that as the new bullet. If WHICH is an integer,
-0 means `-', 1 means `+' etc."
- (interactive "P")
- (org-preserve-lc
- (org-beginning-of-item-list)
- (org-at-item-p)
- (beginning-of-line 1)
- (let ((current (match-string 0))
- (prevp (eq which 'previous))
- new old)
- (setq new (cond
- ((and (numberp which)
- (nth (1- which) '("-" "+" "*" "1." "1)"))))
- ((string-match "-" current) (if prevp "1)" "+"))
- ((string-match "\\+" current)
- (if prevp "-" (if (looking-at "\\S-") "1." "*")))
- ((string-match "\\*" current) (if prevp "+" "1."))
- ((string-match "\\." current)
- (if prevp (if (looking-at "\\S-") "+" "*") "1)"))
- ((string-match ")" current) (if prevp "1." "-"))
- (t (error "This should not happen"))))
- (and (looking-at "\\([ \t]*\\)\\(\\S-+\\)")
- (setq old (match-string 2))
- (replace-match (concat "\\1" new)))
- (org-shift-item-indentation (- (length new) (length old)))
- (org-fix-bullet-type)
- (org-maybe-renumber-ordered-list))))
+Return t when things worked, nil when we are not in an item, or
+item is invisible."
+ (unless (or (not (org-in-item-p))
+ (save-excursion
+ (goto-char (org-get-item-beginning))
+ (org-invisible-p)))
+ (if (save-excursion
+ (goto-char (org-get-item-beginning))
+ (org-at-item-timer-p))
+ ;; Timer list: delegate to `org-timer-item'.
+ (progn (org-timer-item) t)
+ ;; if we're in a description list, ask for the new term.
+ (let ((desc-text (when (save-excursion
+ (and (goto-char (org-get-item-beginning))
+ (org-at-item-description-p)))
+ (concat (read-string "Term: ") " :: "))))
+ ;; Don't insert a checkbox if checkbox rule is applied and it
+ ;; is a description item.
+ (org-list-insert-item-generic
+ (point) (and checkbox
+ (or (not desc-text)
+ (not (cdr (assq 'checkbox org-list-automatic-rules)))))
+ desc-text)))))
+
+;;; Structures
+
+;; The idea behind structures is to avoid moving back and forth in the
+;; buffer on costly operations like indenting or fixing bullets.
+
+;; It achieves this by taking a snapshot of an interesting part of the
+;; list, in the shape of an alist, using `org-list-struct'.
+
+;; It then proceeds to changes directly on the alist, with the help of
+;; and `org-list-struct-origins'. When those are done,
+;; `org-list-struct-apply-struct' applies the changes to the buffer.
+
+(defun org-list-struct-assoc-at-point ()
+ "Return the structure association at point.
+It is a cons-cell whose key is point and values are indentation,
+bullet string and bullet counter, if any."
+ (save-excursion
+ (beginning-of-line)
+ (list (point-at-bol)
+ (org-get-indentation)
+ (progn
+ (looking-at "^[ \t]*\\([-+*0-9.)]+[ \t]+\\)")
+ (match-string 1))
+ (progn
+ (goto-char (match-end 0))
+ (and (looking-at "\\[@\\(?:start:\\)?\\([0-9]+\\)\\]")
+ (match-string 1))))))
+
+(defun org-list-struct (begin end top bottom &optional outdent)
+ "Return the structure containing the list between BEGIN and END.
+A structure is an alist where key is point of item and values
+are, in that order, indentation, bullet string and value of
+counter, if any. A structure contains every list and sublist that
+has items between BEGIN and END along with their common ancestor.
+If no such ancestor can be found, the function will add a virtual
+ancestor at position 0.
+
+TOP and BOTTOM are respectively the position of list beginning
+and list ending.
+
+If OUTDENT is non-nil, it will also grab all of the parent list
+and the grand-parent. Setting OUTDENT to t is mandatory when next
+change is an outdent."
+ (save-excursion
+ (let* (struct
+ (extend
+ (lambda (struct)
+ (let* ((ind-min (apply 'min (mapcar 'cadr struct)))
+ (begin (caar struct))
+ (end (caar (last struct)))
+ pre-list post-list)
+ (goto-char begin)
+ ;; Find beginning of most outdented list (min list)
+ (while (and (org-search-backward-unenclosed
+ org-item-beginning-re top t)
+ (>= (org-get-indentation) ind-min))
+ (setq pre-list (cons (org-list-struct-assoc-at-point)
+ pre-list)))
+ ;; Now get the parent. If none, add a virtual ancestor
+ (if (< (org-get-indentation) ind-min)
+ (setq pre-list (cons (org-list-struct-assoc-at-point)
+ pre-list))
+ (setq pre-list (cons (list 0 (org-get-indentation) "" nil)
+ pre-list)))
+ ;; Find end of min list
+ (goto-char end)
+ (end-of-line)
+ (while (and (org-search-forward-unenclosed
+ org-item-beginning-re bottom 'move)
+ (>= (org-get-indentation) ind-min))
+ (setq post-list (cons (org-list-struct-assoc-at-point)
+ post-list)))
+ ;; Is list is malformed? If some items are less
+ ;; indented that top-item, add them anyhow.
+ (when (and (= (caar pre-list) 0) (< (point) bottom))
+ (beginning-of-line)
+ (while (org-search-forward-unenclosed
+ org-item-beginning-re bottom t)
+ (setq post-list (cons (org-list-struct-assoc-at-point)
+ post-list))))
+ (append pre-list struct (reverse post-list))))))
+ ;; Here we start: first get the core zone...
+ (goto-char end)
+ (while (org-search-backward-unenclosed org-item-beginning-re begin t)
+ (setq struct (cons (org-list-struct-assoc-at-point) struct)))
+ ;; ... then, extend it to make it a structure...
+ (let ((extended (funcall extend struct)))
+ ;; ... twice when OUTDENT is non-nil and struct still can be
+ ;; extended
+ (if (and outdent (> (caar extended) 0))
+ (funcall extend extended)
+ extended)))))
+
+(defun org-list-struct-origins (struct)
+ "Return an alist where key is item's position and value parent's.
+STRUCT is the list's structure looked up."
+ (let* ((struct-rev (reverse struct))
+ (acc (list (cons (nth 1 (car struct)) 0)))
+ (prev-item (lambda (item)
+ (car (nth 1 (member (assq item struct) struct-rev)))))
+ (get-origins
+ (lambda (item)
+ (let* ((item-pos (car item))
+ (ind (nth 1 item))
+ (prev-ind (caar acc)))
+ (cond
+ ;; List closing.
+ ((> prev-ind ind)
+ (let ((current-origin (or (member (assq ind acc) acc)
+ ;; needed if top-point is
+ ;; not the most outdented
+ (last acc))))
+ (setq acc current-origin)
+ (cons item-pos (cdar acc))))
+ ;; New list
+ ((< prev-ind ind)
+ (let ((origin (funcall prev-item item-pos)))
+ (setq acc (cons (cons ind origin) acc))
+ (cons item-pos origin)))
+ ;; Current list going on
+ (t (cons item-pos (cdar acc))))))))
+ (cons '(0 . 0) (mapcar get-origins (cdr struct)))))
+
+(defun org-list-struct-get-parent (item struct origins)
+ "Return parent association of ITEM in STRUCT or nil.
+ORIGINS is the alist of parents. See `org-list-struct-origins'."
+ (let* ((parent-pos (cdr (assq (car item) origins))))
+ (when (> parent-pos 0) (assq parent-pos struct))))
+
+(defun org-list-struct-get-child (item struct)
+ "Return child association of ITEM in STRUCT or nil."
+ (let ((ind (nth 1 item))
+ (next-item (cadr (member item struct))))
+ (when (and next-item (> (nth 1 next-item) ind)) next-item)))
+
+(defun org-list-struct-fix-bul (struct origins)
+ "Verify and correct bullets for every association in STRUCT.
+ORIGINS is the alist of parents. See `org-list-struct-origins'.
+
+This function modifies STRUCT."
+ (let* (acc
+ (init-bul (lambda (item)
+ (let ((counter (nth 3 item))
+ (bullet (org-list-bullet-string (nth 2 item))))
+ (cond
+ ((and (string-match "[0-9]+" bullet) counter)
+ (replace-match counter nil nil bullet))
+ ((string-match "[0-9]+" bullet)
+ (replace-match "1" nil nil bullet))
+ (t bullet)))))
+ (set-bul (lambda (item bullet)
+ (setcdr item (list (nth 1 item) bullet (nth 3 item)))))
+ (get-bul (lambda (item bullet)
+ (let* ((counter (nth 3 item)))
+ (if (and counter (string-match "[0-9]+" bullet))
+ (replace-match counter nil nil bullet)
+ bullet))))
+ (fix-bul
+ (lambda (item) struct
+ (let* ((parent (cdr (assq (car item) origins)))
+ (orig-ref (assq parent acc)))
+ (if orig-ref
+ ;; Continuing previous list
+ (let* ((prev-bul (cdr orig-ref))
+ (new-bul (funcall get-bul item prev-bul)))
+ (setcdr orig-ref (org-list-inc-bullet-maybe new-bul))
+ (funcall set-bul item new-bul))
+ ;; A new list is starting
+ (let ((new-bul (funcall init-bul item)))
+ (funcall set-bul item new-bul)
+ (setq acc (cons (cons parent
+ (org-list-inc-bullet-maybe new-bul))
+ acc))))))))
+ (mapc fix-bul (cdr struct))))
+
+(defun org-list-struct-fix-ind (struct origins)
+ "Verify and correct indentation for every association in STRUCT.
+ORIGINS is the alist of parents. See `org-list-struct-origins'.
+
+This function modifies STRUCT."
+ (let* ((headless (cdr struct))
+ (ancestor (car struct))
+ (top-ind (+ (nth 1 ancestor) (length (nth 2 ancestor))))
+ (new-ind
+ (lambda (item)
+ (let* ((parent (org-list-struct-get-parent item headless origins)))
+ (if parent
+ ;; Indent like parent + length of parent's bullet
+ (setcdr item (cons (+ (length (nth 2 parent)) (nth 1 parent))
+ (cddr item)))
+ ;; If no parent, indent like top-point
+ (setcdr item (cons top-ind (cddr item))))))))
+ (mapc new-ind headless)))
+
+(defun org-list-struct-fix-struct (struct origins)
+ "Return STRUCT with correct bullets and indentation.
+ORIGINS is the alist of parents. See `org-list-struct-origins'.
+
+Only elements of STRUCT that have changed are returned."
+ (let ((old (copy-alist struct)))
+ (org-list-struct-fix-bul struct origins)
+ (org-list-struct-fix-ind struct origins)
+ (delq nil (mapcar (lambda (e) (when (not (equal (pop old) e)) e)) struct))))
+
+(defun org-list-struct-outdent (start end origins)
+ "Outdent items in a structure.
+Items are indented when their key is between START, included, and
+END, excluded.
+
+ORIGINS is the alist of parents. See `org-list-struct-origins'.
+
+STRUCT is the concerned structure."
+ (let* (acc
+ (out (lambda (cell)
+ (let* ((item (car cell))
+ (parent (cdr cell)))
+ (cond
+ ;; Item not yet in zone: keep association
+ ((< item start) cell)
+ ;; Item out of zone: follow associations in acc
+ ((>= item end)
+ (let ((convert (assq parent acc)))
+ (if convert (cons item (cdr convert)) cell)))
+ ;; Item has no parent: error
+ ((<= parent 0)
+ (error "Cannot outdent top-level items"))
+ ;; Parent is outdented: keep association
+ ((>= parent start)
+ (setq acc (cons (cons parent item) acc)) cell)
+ (t
+ ;; Parent isn't outdented: reparent to grand-parent
+ (let ((grand-parent (cdr (assq parent origins))))
+ (setq acc (cons (cons parent item) acc))
+ (cons item grand-parent))))))))
+ (mapcar out origins)))
+
+(defun org-list-struct-indent (start end origins struct)
+ "Indent items in a structure.
+Items are indented when their key is between START, included, and
+END, excluded.
+
+ORIGINS is the alist of parents. See `org-list-struct-origins'.
+
+STRUCT is the concerned structure. It may be modified if
+`org-list-demote-modify-bullet' matches bullets between START and
+END."
+ (let* (acc
+ (orig-rev (reverse origins))
+ (get-prev-item
+ (lambda (cell parent)
+ (car (rassq parent (cdr (memq cell orig-rev))))))
+ (set-assoc
+ (lambda (cell)
+ (setq acc (cons cell acc)) cell))
+ (change-bullet-maybe
+ (lambda (item)
+ (let* ((full-item (assq item struct))
+ (item-bul (org-trim (nth 2 full-item)))
+ (new-bul-p (cdr (assoc item-bul org-list-demote-modify-bullet))))
+ (when new-bul-p
+ ;; new bullet is stored without space to ensure item
+ ;; will be modified
+ (setcdr full-item
+ (list (nth 1 full-item)
+ new-bul-p
+ (nth 3 full-item)))))))
+ (ind
+ (lambda (cell)
+ (let* ((item (car cell))
+ (parent (cdr cell)))
+ (cond
+ ;; Item not yet in zone: keep association
+ ((< item start) cell)
+ ((>= item end)
+ ;; Item out of zone: follow associations in acc
+ (let ((convert (assq parent acc)))
+ (if convert (cons item (cdr convert)) cell)))
+ (t
+ ;; Item is in zone...
+ (let ((prev (funcall get-prev-item cell parent)))
+ ;; Check if bullet needs to be changed
+ (funcall change-bullet-maybe item)
+ (cond
+ ;; First item indented but not parent: error
+ ((and (or (not prev) (= prev 0)) (< parent start))
+ (error "Cannot indent the first item of a list"))
+ ;; First item and parent indented: keep same parent
+ ((or (not prev) (= prev 0))
+ (funcall set-assoc cell))
+ ;; Previous item not indented: reparent to it
+ ((< prev start)
+ (funcall set-assoc (cons item prev)))
+ ;; Previous item indented: reparent like it
+ (t
+ (funcall set-assoc (cons item
+ (cdr (assq prev acc)))))))))))))
+ (mapcar ind origins)))
+
+(defun org-list-struct-apply-struct (struct bottom)
+ "Apply modifications to list so it mirrors STRUCT.
+BOTTOM is position at list ending.
+
+Initial position is restored after the changes."
+ (let* ((pos (copy-marker (point)))
+ (ancestor (caar struct))
+ (modify
+ (lambda (item)
+ (goto-char (car item))
+ (let* ((new-ind (nth 1 item))
+ (new-bul (org-list-bullet-string (nth 2 item)))
+ (old-ind (org-get-indentation))
+ (old-bul (progn
+ (looking-at "[ \t]*\\(\\S-+[ \t]*\\)")
+ (match-string 1)))
+ (old-body-ind (+ (length old-bul) old-ind))
+ (new-body-ind (+ (length new-bul) new-ind)))
+ ;; 1. Shift item's body
+ (unless (= old-body-ind new-body-ind)
+ (org-shift-item-indentation
+ (- new-body-ind old-body-ind) bottom))
+ ;; 2. Replace bullet
+ (unless (equal new-bul old-bul)
+ (save-excursion
+ (looking-at "[ \t]*\\(\\S-+[ \t]*\\)")
+ (replace-match new-bul nil nil nil 1)))
+ ;; 3. Indent item to appropriate column
+ (unless (= new-ind old-ind)
+ (delete-region (point-at-bol)
+ (progn
+ (skip-chars-forward " \t")
+ (point)))
+ (indent-to new-ind)))))
+ ;; Remove ancestor if it is left.
+ (struct-to-apply (if (or (not ancestor) (= 0 ancestor))
+ (cdr struct)
+ struct)))
+ ;; Apply changes from bottom to top
+ (mapc modify (nreverse struct-to-apply))
+ (goto-char pos)))
+
+;;; Indentation
(defun org-get-string-indentation (s)
"What indentation has S due to SPACE and TAB at the beginning of the string?"
@@ -798,280 +1467,555 @@ If WHICH is a string, use that as the new bullet. If WHICH is an integer,
(t (throw 'exit t)))))
i))
-(defun org-renumber-ordered-list (arg)
- "Renumber an ordered plain list.
-Cursor needs to be in the first line of an item, the line that starts
-with something like \"1.\" or \"2)\"."
- (interactive "p")
- (unless (and (org-at-item-p)
- (match-beginning 3))
- (error "This is not an ordered list"))
- (let ((line (org-current-line))
- (col (current-column))
- (ind (org-get-string-indentation
- (buffer-substring (point-at-bol) (match-beginning 3))))
- ;; (term (substring (match-string 3) -1))
- ind1 (n (1- arg))
- fmt bobp old new delta)
- ;; find where this list begins
- (org-beginning-of-item-list)
- (setq bobp (bobp))
- (looking-at "[ \t]*[0-9]+\\([.)]\\)")
- (setq fmt (concat "%d" (or (match-string 1) ".")))
- (beginning-of-line 0)
- ;; walk forward and replace these numbers
- (catch 'exit
- (while t
- (catch 'next
- (if bobp (setq bobp nil) (beginning-of-line 2))
- (if (eobp) (throw 'exit nil))
- (if (looking-at "[ \t]*$") (throw 'next nil))
- (skip-chars-forward " \t") (setq ind1 (current-column))
- (if (> ind1 ind) (throw 'next t))
- (if (< ind1 ind) (throw 'exit t))
- (if (not (org-at-item-p)) (throw 'exit nil))
- (setq old (match-string 2))
- (delete-region (match-beginning 2) (match-end 2))
- (goto-char (match-beginning 2))
- (insert (setq new (format fmt (setq n (1+ n)))))
- (setq delta (- (length new) (length old)))
- (org-shift-item-indentation delta)
- (if (= (org-current-line) line) (setq col (+ col delta))))))
- (org-goto-line line)
- (org-move-to-column col)))
-
-(defvar org-suppress-item-indentation) ; dynamically scoped parameter
-(defun org-fix-bullet-type (&optional force-bullet)
- "Make sure all items in this list have the same bullet as the first item.
-Also, fix the indentation."
+(defun org-shift-item-indentation (delta bottom)
+ "Shift the indentation in current item by DELTA.
+Sub-items are not moved.
+
+BOTTOM is position at list ending."
+ (save-excursion
+ (let ((beg (point-at-bol))
+ (end (org-end-of-item-or-at-child bottom)))
+ (beginning-of-line (unless (eolp) 0))
+ (while (> (point) beg)
+ (when (looking-at "[ \t]*\\S-")
+ ;; this is not an empty line
+ (let ((i (org-get-indentation)))
+ (when (and (> i 0) (> (+ i delta) 0))
+ (indent-line-to (+ i delta)))))
+ (beginning-of-line 0)))))
+
+(defun org-outdent-item ()
+ "Outdent a local list item, but not its children.
+If a region is active, all items inside will be moved."
(interactive)
- (unless (org-at-item-p) (error "This is not a list"))
- (let ((line (org-current-line))
- (col (current-column))
- (ind (current-indentation))
- ind1 bullet oldbullet)
- ;; find where this list begins
- (org-beginning-of-item-list)
- (beginning-of-line 1)
- ;; find out what the bullet type is
- (looking-at "[ \t]*\\(\\S-+\\)")
- (setq bullet (concat (or force-bullet (match-string 1)) " "))
- (if (and org-list-two-spaces-after-bullet-regexp
- (string-match org-list-two-spaces-after-bullet-regexp bullet))
- (setq bullet (concat bullet " ")))
- ;; walk forward and replace these numbers
- (beginning-of-line 0)
- (catch 'exit
- (while t
- (catch 'next
- (beginning-of-line 2)
- (if (eobp) (throw 'exit nil))
- (if (looking-at "[ \t]*$") (throw 'next nil))
- (skip-chars-forward " \t") (setq ind1 (current-column))
- (if (> ind1 ind) (throw 'next t))
- (if (< ind1 ind) (throw 'exit t))
- (if (not (org-at-item-p)) (throw 'exit nil))
- (skip-chars-forward " \t")
- (looking-at "\\S-+ *")
- (setq oldbullet (match-string 0))
- (unless (equal bullet oldbullet) (replace-match bullet))
- (org-shift-item-indentation (- (length bullet)
- (length oldbullet))))))
- (org-goto-line line)
- (org-move-to-column col)
- (if (string-match "[0-9]" bullet)
- (org-renumber-ordered-list 1))))
-
-(defun org-shift-item-indentation (delta)
- "Shift the indentation in current item by DELTA."
- (unless (org-bound-and-true-p org-suppress-item-indentation)
- (save-excursion
- (let ((beg (point-at-bol))
- (end (progn (org-end-of-item) (point)))
- i)
- (goto-char end)
- (beginning-of-line 0)
- (while (> (point) beg)
- (when (looking-at "[ \t]*\\S-")
- ;; this is not an empty line
- (setq i (org-get-indentation))
- (if (and (> i 0) (> (setq i (+ i delta)) 0))
- (indent-line-to i)))
- (beginning-of-line 0))))))
+ (org-list-indent-item-generic
+ -1 t (org-list-top-point) (org-list-bottom-point)))
-(defun org-beginning-of-item-list ()
- "Go to the beginning of the current item list.
-I.e. to the first item in this list."
+(defun org-indent-item ()
+ "Indent a local list item, but not its children.
+If a region is active, all items inside will be moved."
(interactive)
- (org-beginning-of-item)
- (let ((pos (point-at-bol))
- (ind (org-get-indentation))
- ind1)
- ;; find where this list begins
- (catch 'exit
- (while t
- (catch 'next
- (beginning-of-line 0)
- (if (looking-at "[ \t]*$")
- (throw (if (bobp) 'exit 'next) t))
- (skip-chars-forward " \t") (setq ind1 (current-column))
- (if (or (< ind1 ind)
- (and (= ind1 ind)
- (not (org-at-item-p)))
- (and (= (point-at-bol) (point-min))
- (setq pos (point-min))))
- (throw 'exit t)
- (when (org-at-item-p) (setq pos (point-at-bol)))))))
- (goto-char pos)))
+ (org-list-indent-item-generic
+ 1 t (org-list-top-point) (org-list-bottom-point)))
-(defun org-end-of-item-list ()
- "Go to the end of the current item list.
-I.e. to the text after the last item."
+(defun org-outdent-item-tree ()
+ "Outdent a local list item including its children.
+If a region is active, all items inside will be moved."
(interactive)
- (org-beginning-of-item)
- (let ((pos (point-at-bol))
+ (org-list-indent-item-generic
+ -1 nil (org-list-top-point) (org-list-bottom-point)))
+
+(defun org-indent-item-tree ()
+ "Indent a local list item including its children.
+If a region is active, all items inside will be moved."
+ (interactive)
+ (org-list-indent-item-generic
+ 1 nil (org-list-top-point) (org-list-bottom-point)))
+
+(defvar org-tab-ind-state)
+(defun org-cycle-item-indentation ()
+ "Cycle levels of indentation of an empty item.
+The first run indent the item, if applicable. Subsequents runs
+outdent it at meaningful levels in the list. When done, item is
+put back at its original position with its original bullet.
+
+Return t at each successful move."
+ (let ((org-adapt-indentation nil)
(ind (org-get-indentation))
- ind1)
- ;; find where this list begins
- (catch 'exit
- (while t
- (catch 'next
- (beginning-of-line 2)
- (if (looking-at "[ \t]*$")
- (if (eobp)
- (progn (setq pos (point)) (throw 'exit t))
- (throw 'next t)))
- (skip-chars-forward " \t") (setq ind1 (current-column))
- (if (or (< ind1 ind)
- (and (= ind1 ind)
- (not (org-at-item-p)))
- (eobp))
- (progn
- (setq pos (point-at-bol))
- (throw 'exit t))))))
- (goto-char pos)))
+ (bottom (and (org-at-item-p) (org-list-bottom-point))))
+ (when (and (or (org-at-item-description-p)
+ (org-at-item-checkbox-p)
+ (org-at-item-p))
+ ;; Check that item is really empty
+ (>= (match-end 0) (save-excursion
+ (org-end-of-item-or-at-child bottom)
+ (skip-chars-backward " \r\t\n")
+ (point))))
+ (setq this-command 'org-cycle-item-indentation)
+ (let ((top (org-list-top-point)))
+ ;; When in the middle of the cycle, try to outdent first. If it
+ ;; fails, and point is still at initial position, indent. Else,
+ ;; go back to original position.
+ (if (eq last-command 'org-cycle-item-indentation)
+ (cond
+ ((ignore-errors (org-list-indent-item-generic -1 t top bottom)))
+ ((and (= (org-get-indentation) (car org-tab-ind-state))
+ (ignore-errors
+ (org-list-indent-item-generic 1 t top bottom))))
+ (t (back-to-indentation)
+ (indent-to-column (car org-tab-ind-state))
+ (end-of-line)
+ (org-list-repair (cdr org-tab-ind-state))
+ ;; Break cycle
+ (setq this-command 'identity)))
+ ;; If a cycle is starting, remember indentation and bullet,
+ ;; then try to indent. If it fails, try to outdent.
+ (setq org-tab-ind-state (cons ind (org-get-bullet)))
+ (cond
+ ((ignore-errors (org-list-indent-item-generic 1 t top bottom)))
+ ((ignore-errors (org-list-indent-item-generic -1 t top bottom)))
+ (t (error "Cannot move item")))))
+ t)))
+;;; Bullets
-(defvar org-last-indent-begin-marker (make-marker))
-(defvar org-last-indent-end-marker (make-marker))
+(defun org-get-bullet ()
+ "Return the bullet of the item at point.
+Assume cursor is at an item."
+ (save-excursion
+ (beginning-of-line)
+ (and (looking-at "[ \t]*\\(\\S-+\\)") (match-string 1))))
+
+(defun org-list-bullet-string (bullet)
+ "Return BULLET with the correct number of whitespaces.
+It determines the number of whitespaces to append by looking at
+`org-list-two-spaces-after-bullet-regexp'."
+ (save-match-data
+ (string-match "\\S-+\\([ \t]*\\)" bullet)
+ (replace-match
+ (save-match-data
+ (concat
+ " "
+ ;; Do we need to concat another white space ?
+ (when (and org-list-two-spaces-after-bullet-regexp
+ (string-match org-list-two-spaces-after-bullet-regexp bullet))
+ " ")))
+ nil nil bullet 1)))
+
+(defun org-list-inc-bullet-maybe (bullet)
+ "Increment BULLET if applicable."
+ (if (string-match "[0-9]+" bullet)
+ (replace-match
+ (number-to-string (1+ (string-to-number (match-string 0 bullet))))
+ nil nil bullet)
+ bullet))
+
+(defun org-list-repair (&optional force-bullet top bottom)
+ "Make sure all items are correctly indented, with the right bullet.
+This function scans the list at point, along with any sublist.
+
+If FORCE-BULLET is a string, ensure all items in list share this
+bullet, or a logical successor in the case of an ordered list.
+
+When non-nil, TOP and BOTTOM specify respectively position of
+list beginning and list ending.
+
+Item's body is not indented, only shifted with the bullet."
+ (interactive)
+ (unless (org-at-item-p) (error "This is not a list"))
+ (let* ((bottom (or bottom (org-list-bottom-point)))
+ (struct (org-list-struct
+ (point-at-bol) (point-at-eol)
+ (or top (org-list-top-point)) bottom))
+ (origins (org-list-struct-origins struct))
+ fixed-struct)
+ (if (stringp force-bullet)
+ (let ((begin (nth 1 struct)))
+ (setcdr begin (list (nth 1 begin)
+ (org-list-bullet-string force-bullet)
+ (nth 3 begin)))
+ (setq fixed-struct
+ (cons begin (org-list-struct-fix-struct struct origins))))
+ (setq fixed-struct (org-list-struct-fix-struct struct origins)))
+ (org-list-struct-apply-struct fixed-struct bottom)))
+
+(defun org-cycle-list-bullet (&optional which)
+ "Cycle through the different itemize/enumerate bullets.
+This cycle the entire list level through the sequence:
+
+ `-' -> `+' -> `*' -> `1.' -> `1)'
+
+If WHICH is a valid string, use that as the new bullet. If WHICH
+is an integer, 0 means `-', 1 means `+' etc. If WHICH is
+'previous, cycle backwards."
+ (interactive "P")
+ (let* ((top (org-list-top-point))
+ (bullet (save-excursion
+ (goto-char (org-get-beginning-of-list top))
+ (org-get-bullet)))
+ (current (cond
+ ((string-match "\\." bullet) "1.")
+ ((string-match ")" bullet) "1)")
+ (t bullet)))
+ (bullet-rule-p (cdr (assq 'bullet org-list-automatic-rules)))
+ (bullet-list (append '("-" "+" )
+ ;; *-bullets are not allowed at column 0
+ (unless (and bullet-rule-p
+ (looking-at "\\S-")) '("*"))
+ ;; Description items cannot be numbered
+ (unless (and bullet-rule-p
+ (or (eq org-plain-list-ordered-item-terminator ?\))
+ (org-at-item-description-p))) '("1."))
+ (unless (and bullet-rule-p
+ (or (eq org-plain-list-ordered-item-terminator ?.)
+ (org-at-item-description-p))) '("1)"))))
+ (len (length bullet-list))
+ (item-index (- len (length (member current bullet-list))))
+ (get-value (lambda (index) (nth (mod index len) bullet-list)))
+ (new (cond
+ ((member which bullet-list) which)
+ ((numberp which) (funcall get-value which))
+ ((eq 'previous which) (funcall get-value (1- item-index)))
+ (t (funcall get-value (1+ item-index))))))
+ (org-list-repair new top)))
+
+;;; Checkboxes
+
+(defun org-toggle-checkbox (&optional toggle-presence)
+ "Toggle the checkbox in the current line.
+With prefix arg TOGGLE-PRESENCE, add or remove checkboxes. With
+double prefix, set checkbox to [-].
+
+When there is an active region, toggle status or presence of the
+first checkbox there, and make every item inside have the
+same status or presence, respectively.
-(defun org-outdent-item (arg)
- "Outdent a local list item."
- (interactive "p")
- (org-indent-item (- arg)))
-
-(defun org-indent-item (arg)
- "Indent a local list item."
- (interactive "p")
- (and (org-region-active-p) (org-cursor-to-region-beginning))
- (unless (org-at-item-p)
- (error "Not on an item"))
- (let (beg end ind ind1 ind-bul delta ind-down ind-up firstp)
- (setq firstp (org-first-list-item-p))
+If the cursor is in a headline, apply this to all checkbox items
+in the text below the heading, taking as reference the first item
+in subtree, ignoring drawers."
+ (interactive "P")
+ ;; Bounds is a list of type (beg end single-p) where single-p is t
+ ;; when `org-toggle-checkbox' is applied to a single item. Only
+ ;; toggles on single items will return errors.
+ (let* ((bounds
+ (cond
+ ((org-region-active-p)
+ (let ((rbeg (region-beginning))
+ (rend (region-end)))
+ (save-excursion
+ (goto-char rbeg)
+ (if (org-search-forward-unenclosed org-item-beginning-re rend 'move)
+ (list (point-at-bol) rend nil)
+ (error "No item in region")))))
+ ((org-on-heading-p)
+ ;; In this case, reference line is the first item in
+ ;; subtree outside drawers
+ (let ((pos (point))
+ (limit (save-excursion (outline-next-heading) (point))))
+ (save-excursion
+ (goto-char limit)
+ (org-search-backward-unenclosed ":END:" pos 'move)
+ (org-search-forward-unenclosed
+ org-item-beginning-re limit 'move)
+ (list (point) limit nil))))
+ ((org-at-item-p)
+ (list (point-at-bol) (1+ (point-at-eol)) t))
+ (t (error "Not at an item or heading, and no active region"))))
+ (beg (car bounds))
+ ;; marker is needed because deleting or inserting checkboxes
+ ;; will change bottom point
+ (end (copy-marker (nth 1 bounds)))
+ (single-p (nth 2 bounds))
+ (ref-presence (save-excursion
+ (goto-char beg)
+ (org-at-item-checkbox-p)))
+ (ref-status (equal (match-string 1) "[X]"))
+ (act-on-item
+ (lambda (ref-pres ref-stat)
+ (if (equal toggle-presence '(4))
+ (cond
+ ((and ref-pres (org-at-item-checkbox-p))
+ (replace-match ""))
+ ((and (not ref-pres)
+ (not (org-at-item-checkbox-p))
+ (org-at-item-p))
+ (goto-char (match-end 0))
+ ;; Ignore counter, if any
+ (when (looking-at "\\(?:\\[@\\(?:start:\\)?[0-9]+\\][ \t]*\\)?")
+ (goto-char (match-end 0)))
+ (let ((desc-p (and (org-at-item-description-p)
+ (cdr (assq 'checkbox org-list-automatic-rules)))))
+ (cond
+ ((and single-p desc-p)
+ (error "Cannot add a checkbox in a description list"))
+ ((not desc-p) (insert "[ ] "))))))
+ (let ((blocked (org-checkbox-blocked-p)))
+ (cond
+ ((and blocked single-p)
+ (error "Checkbox blocked because of unchecked box in line %d" blocked))
+ (blocked nil)
+ ((org-at-item-checkbox-p)
+ (replace-match
+ (cond ((equal toggle-presence '(16)) "[-]")
+ (ref-stat "[ ]")
+ (t "[X]"))
+ t t nil 1))))))))
(save-excursion
- (setq end (and (org-region-active-p) (region-end)))
- (if (memq last-command '(org-shiftmetaright org-shiftmetaleft))
- (setq beg org-last-indent-begin-marker
- end org-last-indent-end-marker)
- (org-beginning-of-item)
- (setq beg (move-marker org-last-indent-begin-marker (point)))
- (org-end-of-item)
- (setq end (move-marker org-last-indent-end-marker (or end (point)))))
(goto-char beg)
- (setq ind-bul (org-item-indent-positions)
- ind (caar ind-bul)
- ind-down (car (nth 2 ind-bul))
- ind-up (car (nth 1 ind-bul))
- delta (if (> arg 0)
- (if ind-down (- ind-down ind) 2)
- (if ind-up (- ind-up ind) -2)))
- (if (< (+ delta ind) 0) (error "Cannot outdent beyond margin"))
(while (< (point) end)
- (beginning-of-line 1)
- (skip-chars-forward " \t") (setq ind1 (current-column))
- (delete-region (point-at-bol) (point))
- (or (eolp) (org-indent-to-column (+ ind1 delta)))
- (beginning-of-line 2)))
- (org-fix-bullet-type
- (and (> arg 0)
- (not firstp)
- (cdr (assoc (cdr (nth 0 ind-bul)) org-list-demote-modify-bullet))))
- (org-maybe-renumber-ordered-list-safe)
- (save-excursion
- (beginning-of-line 0)
- (condition-case nil (org-beginning-of-item) (error nil))
- (org-maybe-renumber-ordered-list-safe))))
-
-(defun org-item-indent-positions ()
- "Return indentation for plain list items.
-This returns a list with three values: The current indentation, the
-parent indentation and the indentation a child should have.
-Assumes cursor in item line."
- (let* ((bolpos (point-at-bol))
- (ind (org-get-indentation))
- (bullet (org-get-bullet))
- ind-down ind-up bullet-up bullet-down pos)
- (save-excursion
- (org-beginning-of-item-list)
- (skip-chars-backward "\n\r \t")
- (when (org-in-item-p)
- (org-beginning-of-item)
- (setq ind-up (org-get-indentation))
- (setq bullet-up (org-get-bullet))))
- (setq pos (point))
+ (funcall act-on-item ref-presence ref-status)
+ (org-search-forward-unenclosed org-item-beginning-re end 'move)))
+ (org-update-checkbox-count-maybe)))
+
+(defun org-reset-checkbox-state-subtree ()
+ "Reset all checkboxes in an entry subtree."
+ (interactive "*")
+ (save-restriction
(save-excursion
- (cond
- ((and (condition-case nil (progn (org-previous-item) t)
- (error nil))
- (or (forward-char 1) t)
- (re-search-forward "^\\([ \t]*\\([-+]\\|\\([0-9]+[.)]\\)\\)\\|[ \t]+\\*\\)\\( \\|$\\)" bolpos t))
- (setq ind-down (org-get-indentation)
- bullet-down (org-get-bullet)))
- ((and (goto-char pos)
- (org-at-item-p))
- (goto-char (match-end 0))
- (skip-chars-forward " \t")
- (setq ind-down (current-column)
- bullet-down (org-get-bullet)))))
- (if (and bullet-down (string-match "\\`[0-9]+\\(\\.\\|)\\)\\'" bullet-down))
- (setq bullet-down (concat "1" (match-string 1 bullet-down))))
- (if (and bullet-up (string-match "\\`[0-9]+\\(\\.\\|)\\)\\'" bullet-up))
- (setq bullet-up (concat "1" (match-string 1 bullet-up))))
- (if (and bullet (string-match "\\`[0-9]+\\(\\.\\|)\\)\\'" bullet))
- (setq bullet (concat "1" (match-string 1 bullet))))
- (list (cons ind bullet)
- (cons ind-up bullet-up)
- (cons ind-down bullet-down))))
-
-(defvar org-tab-ind-state) ; defined in org.el
-(defun org-cycle-item-indentation ()
- (let ((org-suppress-item-indentation t)
- (org-adapt-indentation nil))
- (cond
- ((and (looking-at "[ \t]*$")
- (looking-back "^\\([ \t]*\\)\\([-+*]\\|[0-9]+[).]\\)[ \t]+"))
- (setq this-command 'org-cycle-item-indentation)
- (if (eq last-command 'org-cycle-item-indentation)
- (condition-case nil
- (progn (org-outdent-item 1)
- (if (equal org-tab-ind-state (org-get-indentation))
- (org-outdent-item 1))
- (end-of-line 1))
- (error
- (progn
- (while (< (org-get-indentation) org-tab-ind-state)
- (progn (org-indent-item 1) (end-of-line 1)))
- (setq this-command 'org-cycle))))
- (setq org-tab-ind-state (org-get-indentation))
- (org-indent-item 1))
- t))))
+ (org-narrow-to-subtree)
+ (org-show-subtree)
+ (goto-char (point-min))
+ (let ((end (point-max)))
+ (while (< (point) end)
+ (when (org-at-item-checkbox-p)
+ (replace-match "[ ]" t t nil 1))
+ (beginning-of-line 2))))
+ (org-update-checkbox-count-maybe)))
-(defun org-get-bullet ()
+(defvar org-checkbox-statistics-hook nil
+ "Hook that is run whenever Org thinks checkbox statistics should be updated.
+This hook runs even if checkbox rule in
+`org-list-automatic-rules' does not apply, so it can be used to
+implement alternative ways of collecting statistics
+information.")
+
+(defun org-update-checkbox-count-maybe ()
+ "Update checkbox statistics unless turned off by user."
+ (when (cdr (assq 'checkbox org-list-automatic-rules))
+ (org-update-checkbox-count))
+ (run-hooks 'org-checkbox-statistics-hook))
+
+(defun org-update-checkbox-count (&optional all)
+ "Update the checkbox statistics in the current section.
+This will find all statistic cookies like [57%] and [6/12] and update them
+with the current numbers. With optional prefix argument ALL, do this for
+the whole buffer."
+ (interactive "P")
(save-excursion
- (goto-char (point-at-bol))
- (and (looking-at
- "^\\([ \t]*\\([-+]\\|\\([0-9]+[.)]\\)\\)\\|[ \t]+\\(\\*\\)\\)\\( \\|$\\)")
- (or (match-string 2) (match-string 4)))))
+ (let ((cstat 0))
+ (catch 'exit
+ (while t
+ (let* ((buffer-invisibility-spec (org-inhibit-invisibility)) ; Emacs 21
+ (beg (condition-case nil
+ (progn (org-back-to-heading) (point))
+ (error (point-min))))
+ (end (copy-marker (save-excursion
+ (outline-next-heading) (point))))
+ (re-cookie "\\(\\(\\[[0-9]*%\\]\\)\\|\\(\\[[0-9]*/[0-9]*\\]\\)\\)")
+ (re-box "^[ \t]*\\([-+*]\\|[0-9]+[.)]\\)[ \t]+\\(?:\\[@\\(?:start:\\)?[0-9]+\\][ \t]*\\)?\\(\\[[- X]\\]\\)")
+ beg-cookie end-cookie is-percent c-on c-off lim new
+ curr-ind next-ind continue-from startsearch list-beg list-end
+ (recursive
+ (or (not org-hierarchical-checkbox-statistics)
+ (string-match "\\<recursive\\>"
+ (or (ignore-errors
+ (org-entry-get nil "COOKIE_DATA"))
+ "")))))
+ (goto-char end)
+ ;; find each statistics cookie
+ (while (and (org-search-backward-unenclosed re-cookie beg 'move)
+ (not (save-match-data
+ (and (org-on-heading-p)
+ (string-match "\\<todo\\>"
+ (downcase
+ (or (org-entry-get
+ nil "COOKIE_DATA")
+ "")))))))
+ (setq beg-cookie (match-beginning 1)
+ end-cookie (match-end 1)
+ cstat (+ cstat (if end-cookie 1 0))
+ startsearch (point-at-eol)
+ continue-from (match-beginning 0)
+ is-percent (match-beginning 2)
+ lim (cond
+ ((org-on-heading-p) (outline-next-heading) (point))
+ ;; Ensure many cookies in the same list won't imply
+ ;; computing list boundaries as many times.
+ ((org-at-item-p)
+ (unless (and list-beg (>= (point) list-beg))
+ (setq list-beg (org-list-top-point)
+ list-end (copy-marker
+ (org-list-bottom-point))))
+ (org-get-end-of-item list-end))
+ (t nil))
+ c-on 0
+ c-off 0)
+ (when lim
+ ;; find first checkbox for this cookie and gather
+ ;; statistics from all that are at this indentation level
+ (goto-char startsearch)
+ (if (org-search-forward-unenclosed re-box lim t)
+ (progn
+ (beginning-of-line)
+ (setq curr-ind (org-get-indentation))
+ (setq next-ind curr-ind)
+ (while (and (bolp) (org-at-item-p)
+ (if recursive
+ (<= curr-ind next-ind)
+ (= curr-ind next-ind)))
+ (when (org-at-item-checkbox-p)
+ (if (member (match-string 1) '("[ ]" "[-]"))
+ (setq c-off (1+ c-off))
+ (setq c-on (1+ c-on))))
+ (if (not recursive)
+ ;; org-get-next-item goes through list-enders
+ ;; with proper limit.
+ (goto-char (or (org-get-next-item (point) lim) lim))
+ (end-of-line)
+ (when (org-search-forward-unenclosed
+ org-item-beginning-re lim t)
+ (beginning-of-line)))
+ (setq next-ind (org-get-indentation)))))
+ (goto-char continue-from)
+ ;; update cookie
+ (when end-cookie
+ (setq new (if is-percent
+ (format "[%d%%]" (/ (* 100 c-on)
+ (max 1 (+ c-on c-off))))
+ (format "[%d/%d]" c-on (+ c-on c-off))))
+ (goto-char beg-cookie)
+ (insert new)
+ (delete-region (point) (+ (point) (- end-cookie beg-cookie))))
+ ;; update items checkbox if it has one
+ (when (and (org-at-item-checkbox-p)
+ (> (+ c-on c-off) 0))
+ (setq beg-cookie (match-beginning 1)
+ end-cookie (match-end 1))
+ (delete-region beg-cookie end-cookie)
+ (goto-char beg-cookie)
+ (cond ((= c-off 0) (insert "[X]"))
+ ((= c-on 0) (insert "[ ]"))
+ (t (insert "[-]")))))
+ (goto-char continue-from)))
+ (unless (and all (outline-next-heading)) (throw 'exit nil))))
+ (when (interactive-p)
+ (message "Checkbox statistics updated %s (%d places)"
+ (if all "in entire file" "in current outline entry") cstat)))))
+
+(defun org-get-checkbox-statistics-face ()
+ "Select the face for checkbox statistics.
+The face will be `org-done' when all relevant boxes are checked.
+Otherwise it will be `org-todo'."
+ (if (match-end 1)
+ (if (equal (match-string 1) "100%")
+ 'org-checkbox-statistics-done
+ 'org-checkbox-statistics-todo)
+ (if (and (> (match-end 2) (match-beginning 2))
+ (equal (match-string 2) (match-string 3)))
+ 'org-checkbox-statistics-done
+ 'org-checkbox-statistics-todo)))
+
+;;; Misc Tools
+
+(defun org-apply-on-list (function init-value &rest args)
+ "Call FUNCTION on each item of the list at point.
+FUNCTION must be called with at least one argument: INIT-VALUE,
+that will contain the value returned by the function at the
+previous item, plus ARGS extra arguments.
+
+As an example, (org-apply-on-list (lambda (result) (1+ result)) 0)
+will return the number of items in the current list.
+
+Sublists of the list are skipped. Cursor is always at the
+beginning of the item."
+ (let* ((pos (copy-marker (point)))
+ (end (copy-marker (org-list-bottom-point)))
+ (next-p (copy-marker (org-get-beginning-of-list (org-list-top-point))))
+ (value init-value))
+ (while (< next-p end)
+ (goto-char next-p)
+ (set-marker next-p (or (org-get-next-item (point) end) end))
+ (setq value (apply function value args)))
+ (goto-char pos)
+ value))
+
+(defun org-sort-list (&optional with-case sorting-type getkey-func compare-func)
+ "Sort plain list items.
+The cursor may be at any item of the list that should be sorted.
+Sublists are not sorted. Checkboxes, if any, are ignored.
+
+Sorting can be alphabetically, numerically, by date/time as given by
+a time stamp, by a property or by priority.
+
+Comparing entries ignores case by default. However, with an
+optional argument WITH-CASE, the sorting considers case as well.
+
+The command prompts for the sorting type unless it has been given
+to the function through the SORTING-TYPE argument, which needs to
+be a character, \(?n ?N ?a ?A ?t ?T ?f ?F). Here is the precise
+meaning of each character:
+
+n Numerically, by converting the beginning of the item to a number.
+a Alphabetically. Only the first line of item is checked.
+t By date/time, either the first active time stamp in the entry, if
+ any, or by the first inactive one. In a timer list, sort the timers.
+
+Capital letters will reverse the sort order.
+
+If the SORTING-TYPE is ?f or ?F, then GETKEY-FUNC specifies a
+function to be called with point at the beginning of the record.
+It must return either a string or a number that should serve as
+the sorting key for that record. It will then use COMPARE-FUNC to
+compare entries."
+ (interactive "P")
+ (let* ((case-func (if with-case 'identity 'downcase))
+ (top (org-list-top-point))
+ (bottom (org-list-bottom-point))
+ (start (org-get-beginning-of-list top))
+ (end (org-get-end-of-list bottom))
+ (sorting-type
+ (progn
+ (message
+ "Sort plain list: [a]lpha [n]umeric [t]ime [f]unc A/N/T/F means reversed:")
+ (read-char-exclusive)))
+ (getkey-func (and (= (downcase sorting-type) ?f)
+ (org-icompleting-read "Sort using function: "
+ obarray 'fboundp t nil nil)
+ (intern getkey-func))))
+ (message "Sorting items...")
+ (save-restriction
+ (narrow-to-region start end)
+ (goto-char (point-min))
+ (let* ((dcst (downcase sorting-type))
+ (case-fold-search nil)
+ (now (current-time))
+ (sort-func (cond
+ ((= dcst ?a) 'string<)
+ ((= dcst ?f) compare-func)
+ ((= dcst ?t) '<)
+ (t nil)))
+ (begin-record (lambda ()
+ (skip-chars-forward " \r\t\n")
+ (beginning-of-line)))
+ (end-record (lambda ()
+ (goto-char (org-end-of-item-before-blank end))))
+ (value-to-sort
+ (lambda ()
+ (when (looking-at "[ \t]*[-+*0-9.)]+\\([ \t]+\\[[- X]\\]\\)?[ \t]+")
+ (cond
+ ((= dcst ?n)
+ (string-to-number (buffer-substring (match-end 0)
+ (point-at-eol))))
+ ((= dcst ?a)
+ (buffer-substring (match-end 0) (point-at-eol)))
+ ((= dcst ?t)
+ (cond
+ ;; If it is a timer list, convert timer to seconds
+ ((org-at-item-timer-p)
+ (org-timer-hms-to-secs (match-string 1)))
+ ((or (org-search-forward-unenclosed org-ts-regexp
+ (point-at-eol) t)
+ (org-search-forward-unenclosed org-ts-regexp-both
+ (point-at-eol) t))
+ (org-time-string-to-seconds (match-string 0)))
+ (t (org-float-time now))))
+ ((= dcst ?f)
+ (if getkey-func
+ (let ((value (funcall getkey-func)))
+ (if (stringp value)
+ (funcall case-func value)
+ value))
+ (error "Invalid key function `%s'" getkey-func)))
+ (t (error "Invalid sorting type `%c'" sorting-type)))))))
+ (sort-subr (/= dcst sorting-type)
+ begin-record
+ end-record
+ value-to-sort
+ nil
+ sort-func)
+ (org-list-repair nil top bottom)
+ (run-hooks 'org-after-sorting-entries-or-items-hook)
+ (message "Sorting items...done")))))
;;; Send and receive lists
@@ -1079,82 +2023,55 @@ Assumes cursor in item line."
"Parse the list at point and maybe DELETE it.
Return a list containing first level items as strings and
sublevels as a list of strings."
- (let* ((item-beginning (org-list-item-beginning))
- (start (car item-beginning))
- (end (org-list-end (cdr item-beginning)))
+ (let* ((start (goto-char (org-list-top-point)))
+ (end (org-list-bottom-point))
output itemsep ltype)
- (while (re-search-forward org-list-beginning-re end t)
- (goto-char (match-beginning 3))
- (save-match-data
- (cond ((string-match "[0-9]" (match-string 2))
- (setq itemsep "[0-9]+\\(?:\\.\\|)\\)"
- ltype 'ordered))
- ((string-match "^.*::" (match-string 0))
- (setq itemsep "[-+]" ltype 'descriptive))
- (t (setq itemsep "[-+]" ltype 'unordered))))
- (let* ((indent1 (match-string 1))
- (nextitem (save-excursion
- (save-match-data
- (or (and (re-search-forward
- (concat "^" indent1 itemsep " *?") end t)
- (match-beginning 0)) end))))
- (item (buffer-substring
- (point)
- (or (and (re-search-forward
- org-list-beginning-re end t)
- (goto-char (match-beginning 0)))
- (goto-char end))))
- (nextindent (match-string 1))
- (item (org-trim item))
- (item (if (string-match "^\\[\\([xX ]\\)\\]" item)
+ (while (org-search-forward-unenclosed org-item-beginning-re end t)
+ (save-excursion
+ (beginning-of-line)
+ (setq ltype (cond ((looking-at-p "^[ \t]*[0-9]") 'ordered)
+ ((org-at-item-description-p) 'descriptive)
+ (t 'unordered))))
+ (let* ((indent1 (org-get-indentation))
+ (nextitem (or (org-get-next-item (point) end) end))
+ (item (org-trim (buffer-substring (point)
+ (org-end-of-item-or-at-child end))))
+ (nextindent (if (= (point) end) 0 (org-get-indentation)))
+ (item (if (string-match
+ "^\\(?:\\[@\\(?:start:\\)?[0-9]+\\][ \t]*\\)?\\[\\([xX ]\\)\\]"
+ item)
(replace-match (if (equal (match-string 1 item) " ")
- "[CBOFF]"
- "[CBON]")
- t nil item)
+ "CBOFF"
+ "CBON")
+ t nil item 1)
item)))
(push item output)
- (when (> (length nextindent)
- (length indent1))
- (narrow-to-region (point) nextitem)
- (push (org-list-parse-list) output)
- (widen))))
- (when delete (delete-region start end))
+ (when (> nextindent indent1)
+ (save-restriction
+ (narrow-to-region (point) nextitem)
+ (push (org-list-parse-list) output)))))
+ (when delete
+ (delete-region start end)
+ (save-match-data
+ (when (and (not (eq org-list-ending-method 'indent))
+ (looking-at (org-list-end-re)))
+ (replace-match "\n"))))
(setq output (nreverse output))
(push ltype output)))
-(defun org-list-item-beginning ()
- "Find the beginning of the list item.
-Return a cons which car is the beginning position of the item and
-cdr is the indentation string."
- (save-excursion
- (if (not (or (looking-at org-list-beginning-re)
- (re-search-backward
- org-list-beginning-re nil t)))
- (progn (goto-char (point-min)) (point))
- (cons (match-beginning 0) (match-string 1)))))
-
-(defun org-list-goto-true-beginning ()
- "Go to the beginning of the list at point."
- (beginning-of-line 1)
- (while (looking-at org-list-beginning-re)
- (beginning-of-line 0))
- (progn
- (re-search-forward org-list-beginning-re nil t)
- (goto-char (match-beginning 0))))
-
(defun org-list-make-subtree ()
"Convert the plain list at point into a subtree."
(interactive)
- (org-list-goto-true-beginning)
- (let ((list (org-list-parse-list t)) nstars)
- (save-excursion
- (if (condition-case nil
- (org-back-to-heading)
- (error nil))
- (progn (re-search-forward org-complex-heading-regexp nil t)
- (setq nstars (length (match-string 1))))
- (setq nstars 0)))
- (org-list-make-subtrees list (1+ nstars))))
+ (if (not (org-in-item-p))
+ (error "Not in a list")
+ (let ((list (org-list-parse-list t)) nstars)
+ (save-excursion
+ (if (ignore-errors
+ (org-back-to-heading))
+ (progn (looking-at org-complex-heading-regexp)
+ (setq nstars (length (match-string 1))))
+ (setq nstars 0)))
+ (org-list-make-subtrees list (1+ nstars)))))
(defun org-list-make-subtrees (list level)
"Convert LIST into subtrees starting at LEVEL."
@@ -1168,20 +2085,6 @@ cdr is the indentation string."
(org-list-make-subtrees item (1+ level))))
list)))
-(defun org-list-end (indent)
- "Return the position of the end of the list.
-INDENT is the indentation of the list, as a string."
- (save-excursion
- (catch 'exit
- (while (or (looking-at org-list-beginning-re)
- (looking-at (concat "^" indent "[ \t]+\\|^$"))
- (> (or (get-text-property (point) 'original-indentation) -1)
- (length indent)))
- (if (eq (point) (point-max))
- (throw 'exit (point-max)))
- (forward-line 1)))
- (point)))
-
(defun org-list-insert-radio-list ()
"Insert a radio list template appropriate for this major mode."
(interactive)
@@ -1203,45 +2106,52 @@ With argument MAYBE, fail quietly if no transformation is defined for
this list."
(interactive)
(catch 'exit
- (unless (org-at-item-p) (error "Not at a list"))
+ (unless (org-at-item-p) (error "Not at a list item"))
(save-excursion
- (org-list-goto-true-beginning)
- (beginning-of-line 0)
- (unless (looking-at "#\\+ORGLST: *SEND +\\([a-zA-Z0-9_]+\\) +\\([^ \t\r\n]+\\)\\( +.*\\)?")
+ (re-search-backward "#\\+ORGLST" nil t)
+ (unless (looking-at "[ \t]*#\\+ORGLST[: \t][ \t]*SEND[ \t]+\\([^ \t\r\n]+\\)[ \t]+\\([^ \t\r\n]+\\)\\([ \t]+.*\\)?")
(if maybe
(throw 'exit nil)
(error "Don't know how to transform this list"))))
(let* ((name (match-string 1))
(transform (intern (match-string 2)))
- (item-beginning (org-list-item-beginning))
- (txt (buffer-substring-no-properties
- (car item-beginning)
- (org-list-end (cdr item-beginning))))
- (list (org-list-parse-list))
- beg)
+ (bottom-point
+ (save-excursion
+ (re-search-forward
+ "\\(\\\\end{comment}\\|@end ignore\\|-->\\)" nil t)
+ (match-beginning 0)))
+ (top-point
+ (progn
+ (re-search-backward "#\\+ORGLST" nil t)
+ (re-search-forward org-item-beginning-re bottom-point t)
+ (match-beginning 0)))
+ (list (save-restriction
+ (narrow-to-region top-point bottom-point)
+ (org-list-parse-list)))
+ beg txt)
(unless (fboundp transform)
(error "No such transformation function %s" transform))
- (setq txt (funcall transform list))
- ;; Find the insertion place
- (save-excursion
- (goto-char (point-min))
- (unless (re-search-forward
- (concat "BEGIN RECEIVE ORGLST +" name "\\([ \t]\\|$\\)") nil t)
- (error "Don't know where to insert translated list"))
- (goto-char (match-beginning 0))
- (beginning-of-line 2)
- (setq beg (point))
- (unless (re-search-forward (concat "END RECEIVE ORGLST +" name) nil t)
- (error "Cannot find end of insertion region"))
- (beginning-of-line 1)
- (delete-region beg (point))
- (goto-char beg)
- (insert txt "\n"))
+ (let ((txt (funcall transform list)))
+ ;; Find the insertion place
+ (save-excursion
+ (goto-char (point-min))
+ (unless (re-search-forward
+ (concat "BEGIN RECEIVE ORGLST +"
+ name
+ "\\([ \t]\\|$\\)") nil t)
+ (error "Don't know where to insert translated list"))
+ (goto-char (match-beginning 0))
+ (beginning-of-line 2)
+ (setq beg (point))
+ (unless (re-search-forward (concat "END RECEIVE ORGLST +" name) nil t)
+ (error "Cannot find end of insertion region"))
+ (delete-region beg (point-at-bol))
+ (goto-char beg)
+ (insert txt "\n")))
(message "List converted and installed at receiver location"))))
(defun org-list-to-generic (list params)
"Convert a LIST parsed through `org-list-parse-list' to other formats.
-
Valid parameters PARAMS are
:ustart String to start an unordered list
@@ -1270,21 +2180,21 @@ Valid parameters PARAMS are
(interactive)
(let* ((p params) sublist
(splicep (plist-get p :splice))
- (ostart (plist-get p :ostart))
- (oend (plist-get p :oend))
- (ustart (plist-get p :ustart))
- (uend (plist-get p :uend))
- (dstart (plist-get p :dstart))
- (dend (plist-get p :dend))
- (dtstart (plist-get p :dtstart))
- (dtend (plist-get p :dtend))
- (ddstart (plist-get p :ddstart))
- (ddend (plist-get p :ddend))
- (istart (plist-get p :istart))
- (iend (plist-get p :iend))
- (isep (plist-get p :isep))
- (lsep (plist-get p :lsep))
- (cbon (plist-get p :cbon))
+ (ostart (plist-get p :ostart))
+ (oend (plist-get p :oend))
+ (ustart (plist-get p :ustart))
+ (uend (plist-get p :uend))
+ (dstart (plist-get p :dstart))
+ (dend (plist-get p :dend))
+ (dtstart (plist-get p :dtstart))
+ (dtend (plist-get p :dtend))
+ (ddstart (plist-get p :ddstart))
+ (ddend (plist-get p :ddend))
+ (istart (plist-get p :istart))
+ (iend (plist-get p :iend))
+ (isep (plist-get p :isep))
+ (lsep (plist-get p :lsep))
+ (cbon (plist-get p :cbon))
(cboff (plist-get p :cboff)))
(let ((wrapper
(cond ((eq (car list) 'ordered)
@@ -1297,28 +2207,30 @@ Valid parameters PARAMS are
(while (setq sublist (pop list))
(cond ((symbolp sublist) nil)
((stringp sublist)
- (when (string-match "^\\(.*\\) ::" sublist)
+ (when (string-match "^\\(.*\\)[ \t]+::" sublist)
(setq term (org-trim (format (concat dtstart "%s" dtend)
(match-string 1 sublist))))
- (setq sublist (substring sublist (1+ (length term)))))
+ (setq sublist (concat ddstart
+ (org-trim (substring sublist
+ (match-end 0)))
+ ddend)))
(if (string-match "\\[CBON\\]" sublist)
(setq sublist (replace-match cbon t t sublist)))
(if (string-match "\\[CBOFF\\]" sublist)
(setq sublist (replace-match cboff t t sublist)))
(if (string-match "\\[-\\]" sublist)
(setq sublist (replace-match "$\\boxminus$" t t sublist)))
- (setq rtn (concat rtn istart term ddstart
- sublist ddend iend isep)))
- (t (setq rtn (concat rtn ;; previous list
- lsep ;; list separator
+ (setq rtn (concat rtn istart term sublist iend isep)))
+ (t (setq rtn (concat rtn ;; previous list
+ lsep ;; list separator
(org-list-to-generic sublist p)
- lsep ;; list separator
+ lsep ;; list separator
)))))
(format wrapper rtn))))
(defun org-list-to-latex (list &optional params)
"Convert LIST into a LaTeX list.
-LIST is as returnd by `org-list-parse-list'. PARAMS is a property list
+LIST is as returned by `org-list-parse-list'. PARAMS is a property list
with overruling parameters for `org-list-to-generic'."
(org-list-to-generic
list
@@ -1335,7 +2247,7 @@ with overruling parameters for `org-list-to-generic'."
(defun org-list-to-html (list &optional params)
"Convert LIST into a HTML list.
-LIST is as returnd by `org-list-parse-list'. PARAMS is a property list
+LIST is as returned by `org-list-parse-list'. PARAMS is a property list
with overruling parameters for `org-list-to-generic'."
(org-list-to-generic
list
@@ -1352,7 +2264,7 @@ with overruling parameters for `org-list-to-generic'."
(defun org-list-to-texinfo (list &optional params)
"Convert LIST into a Texinfo list.
-LIST is as returnd by `org-list-parse-list'. PARAMS is a property list
+LIST is as returned by `org-list-parse-list'. PARAMS is a property list
with overruling parameters for `org-list-to-generic'."
(org-list-to-generic
list
diff --git a/lisp/org/org-mac-message.el b/lisp/org/org-mac-message.el
index ff0098ee114..afac5ca71b1 100644
--- a/lisp/org/org-mac-message.el
+++ b/lisp/org/org-mac-message.el
@@ -5,7 +5,7 @@
;; Author: John Wiegley <johnw@gnu.org>
;; Christopher Suckling <suckling at gmail dot com>
-;; Version: 6.33x
+;; Version: 7.3
;; Keywords: outlines, hypermedia, calendar, wp
;; This file is part of GNU Emacs.
@@ -39,7 +39,7 @@
;; messages selected in Mail.app.
;; (org-mac-message-insert-flagged) searches within an org-mode buffer
-;; for a specific heading, creating it if it doesn't exist. Any
+;; for a specific heading, creating it if it doesn't exist. Any
;; message:// links within the first level of the heading are deleted
;; and replaced with links to flagged messages.
@@ -53,7 +53,7 @@
:group 'org-link)
(defcustom org-mac-mail-account "customize"
- "The Mail.app account in which to search for flagged messages"
+ "The Mail.app account in which to search for flagged messages."
:group 'org-mac-flagged-mail
:type 'string)
@@ -81,7 +81,7 @@ This will use the command `open' with the message URL."
"open" (concat "message://<" (substring message-id 2) ">")))
(defun as-get-selected-mail ()
- "AppleScript to create links to selected messages in Mail.app"
+ "AppleScript to create links to selected messages in Mail.app."
(do-applescript
(concat
"tell application \"Mail\"\n"
@@ -97,7 +97,7 @@ This will use the command `open' with the message URL."
"end tell")))
(defun as-get-flagged-mail ()
- "AppleScript to create links to flagged messages in Mail.app"
+ "AppleScript to create links to flagged messages in Mail.app."
(do-applescript
(concat
;; Is Growl installed?
@@ -179,7 +179,7 @@ The Org-syntax text will be pushed to the kill ring, and also returned."
(defun org-mac-message-insert-selected ()
"Insert a link to the messages currently selected in Mail.app.
-This will use applescript to get the message-id and the subject of the
+This will use AppleScript to get the message-id and the subject of the
active mail in Mail.app and make a link out of it."
(interactive)
(insert (org-mac-message-get-links "s")))
@@ -209,7 +209,7 @@ list of message:// links to flagged mail after heading."
(insert "\n" (org-mac-message-get-links "f")))
(goto-char (point-max))
(insert "\n")
- (org-insert-heading)
+ (org-insert-heading nil t)
(insert org-heading "\n" (org-mac-message-get-links "f"))))))
(provide 'org-mac-message)
diff --git a/lisp/org/org-macs.el b/lisp/org/org-macs.el
index 1bfc2aed307..5a5612387fd 100644
--- a/lisp/org/org-macs.el
+++ b/lisp/org/org-macs.el
@@ -6,7 +6,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -38,11 +38,32 @@
(defmacro declare-function (fn file &optional arglist fileonly))))
(declare-function org-add-props "org-compat" (string plist &rest props))
+(declare-function org-string-match-p "org-compat" (&rest args))
+
+(defmacro org-called-interactively-p (&optional kind)
+ `(if (featurep 'xemacs)
+ (interactive-p)
+ (if (or (> emacs-major-version 23)
+ (and (>= emacs-major-version 23)
+ (>= emacs-minor-version 2)))
+ (called-interactively-p ,kind)
+ (interactive-p))))
(defmacro org-bound-and-true-p (var)
"Return the value of symbol VAR if it is bound, else nil."
`(and (boundp (quote ,var)) ,var))
+(defun org-string-nw-p (s)
+ "Is S a string with a non-white character?"
+ (and (stringp s)
+ (org-string-match-p "\\S-" s)
+ s))
+
+(defun org-not-nil (v)
+ "If V not nil, and also not the string \"nil\", then return V.
+Otherwise return nil."
+ (and v (not (equal v "nil")) v))
+
(defmacro org-unmodified (&rest body)
"Execute body without changing `buffer-modified-p'.
Also, do not record undo information."
@@ -63,6 +84,8 @@ Also, do not record undo information."
(setq ss (replace-match "a-zA-Z0-9" t t ss)))
(while (string-match "\\[:alpha:\\]" ss)
(setq ss (replace-match "a-zA-Z" t t ss)))
+ (while (string-match "\\[:punct:\\]" ss)
+ (setq ss (replace-match "\001-@[-`{-~" t t ss)))
ss))
s))
@@ -85,7 +108,7 @@ Also, do not record undo information."
(defmacro org-maybe-intangible (props)
"Add '(intangible t) to PROPS if Emacs version is earlier than Emacs 22.
-In emacs 21, invisible text is not avoided by the command loop, so the
+In Emacs 21, invisible text is not avoided by the command loop, so the
intangible property is needed to make sure point skips this text.
In Emacs 22, this is not necessary. The intangible text property has
led to problems with flyspell. These problems are fixed in flyspell.el,
@@ -123,6 +146,14 @@ We use a macro so that the test can happen at compilation time."
,@body))
(put 'org-if-unprotected-at 'lisp-indent-function 1)
+(defun org-re-search-forward-unprotected (&rest args)
+ "Like re-search-forward, but stop only in unprotected places."
+ (catch 'exit
+ (while t
+ (unless (apply 're-search-forward args)
+ (throw 'exit nil))
+ (unless (get-text-property (match-beginning 0) 'org-protected)
+ (throw 'exit (point))))))
(defmacro org-with-remote-undo (_buffer &rest _body)
"Execute BODY while recording undo information in two buffers."
@@ -152,7 +183,8 @@ We use a macro so that the test can happen at compilation time."
`(let ((inhibit-read-only t)) ,@body))
(defconst org-rm-props '(invisible t face t keymap t intangible t mouse-face t
- rear-nonsticky t mouse-map t fontified t)
+ rear-nonsticky t mouse-map t fontified t
+ org-emphasis t)
"Properties to remove when a string without properties is wanted.")
(defsubst org-match-string-no-properties (num &optional string)
@@ -260,7 +292,6 @@ This is in contrast to merely setting it to 0."
(setq plist (cddr plist)))
p))
-
(defun org-replace-match-keep-properties (newtext &optional fixedcase
literal string)
"Like `replace-match', but add the text properties found original text."
@@ -268,6 +299,25 @@ This is in contrast to merely setting it to 0."
(match-beginning 0) string)))
(replace-match newtext fixedcase literal string))
+(defmacro org-save-outline-visibility (use-markers &rest body)
+ "Save and restore outline visibility around BODY.
+If USE-MARKERS is non-nil, use markers for the positions.
+This means that the buffer may change while running BODY,
+but it also means that the buffer should stay alive
+during the operation, because otherwise all these markers will
+point nowhere."
+ (declare (indent 1))
+ `(let ((data (org-outline-overlay-data ,use-markers)))
+ (unwind-protect
+ (progn
+ ,@body
+ (org-set-outline-overlay-data data))
+ (when ,use-markers
+ (mapc (lambda (c)
+ (and (markerp (car c)) (move-marker (car c) nil))
+ (and (markerp (cdr c)) (move-marker (cdr c) nil)))
+ data)))))
+
(defmacro org-with-limited-levels (&rest body)
"Execute BODY with limited number of outline levels."
`(let* ((outline-regexp (org-get-limited-outline-regexp)))
@@ -277,7 +327,7 @@ This is in contrast to merely setting it to 0."
(defvar org-inlinetask-min-level) ; defined in org-inlinetask.el
(defun org-get-limited-outline-regexp ()
"Return outline-regexp with limited number of levels.
-The number of levels is controlled by "
+The number of levels is controlled by `org-inlinetask-min-level'"
(if (or (not (org-mode-p)) (not (featurep 'org-inlinetask)))
outline-regexp
diff --git a/lisp/org/org-mew.el b/lisp/org/org-mew.el
index ba8de96f9c6..efedef8ec5c 100644
--- a/lisp/org/org-mew.el
+++ b/lisp/org/org-mew.el
@@ -5,7 +5,7 @@
;; Author: Tokuya Kameshima <kames at fa2 dot so-net dot ne dot jp>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;; This file is part of GNU Emacs.
@@ -81,7 +81,7 @@
(mew-case-folder (mew-sinfo-get-case)
(nth 1 (mew-refile-get msgnum)))
(mew-summary-folder-name)))
- message-id from to subject desc link)
+ message-id from to subject desc link date date-ts date-ts-ia)
(save-window-excursion
(if (fboundp 'mew-summary-set-message-buffer)
(mew-summary-set-message-buffer folder-name msgnum)
@@ -89,9 +89,19 @@
(setq message-id (mew-header-get-value "Message-Id:"))
(setq from (mew-header-get-value "From:"))
(setq to (mew-header-get-value "To:"))
+ (setq date (mew-header-get-value "Date:"))
+ (setq date-ts (and date (format-time-string
+ (org-time-stamp-format t)
+ (date-to-time date))))
+ (setq date-ts-ia (and date (format-time-string
+ (org-time-stamp-format t t)
+ (date-to-time date))))
(setq subject (mew-header-get-value "Subject:")))
(org-store-link-props :type "mew" :from from :to to
:subject subject :message-id message-id)
+ (when date
+ (org-add-link-props :date date :date-timestamp date-ts
+ :date-timestamp-inactive date-ts-ia))
(setq message-id (org-remove-angle-brackets message-id))
(setq desc (org-email-link-description))
(setq link (org-make-link "mew:" folder-name
diff --git a/lisp/org/org-mhe.el b/lisp/org/org-mhe.el
index 0af426d39fd..b1024a000e2 100644
--- a/lisp/org/org-mhe.el
+++ b/lisp/org/org-mhe.el
@@ -6,7 +6,7 @@
;; Author: Thomas Baumann <thomas dot baumann at ch dot tum dot de>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -83,13 +83,22 @@ supported by MH-E."
"Store a link to an MH-E folder or message."
(when (or (equal major-mode 'mh-folder-mode)
(equal major-mode 'mh-show-mode))
- (let ((from (org-mhe-get-header "From:"))
- (to (org-mhe-get-header "To:"))
- (message-id (org-mhe-get-header "Message-Id:"))
- (subject (org-mhe-get-header "Subject:"))
- link desc)
+ (let* ((from (org-mhe-get-header "From:"))
+ (to (org-mhe-get-header "To:"))
+ (message-id (org-mhe-get-header "Message-Id:"))
+ (subject (org-mhe-get-header "Subject:"))
+ (date (org-mhe-get-header "Date:"))
+ (date-ts (and date (format-time-string
+ (org-time-stamp-format t) (date-to-time date))))
+ (date-ts-ia (and date (format-time-string
+ (org-time-stamp-format t t)
+ (date-to-time date))))
+ link desc)
(org-store-link-props :type "mh" :from from :to to
:subject subject :message-id message-id)
+ (when date
+ (org-add-link-props :date date :date-timestamp date-ts
+ :date-timestamp-inactive date-ts-ia))
(setq desc (org-email-link-description))
(setq link (org-make-link "mhe:" (org-mhe-get-message-real-folder) "#"
(org-remove-angle-brackets message-id)))
@@ -181,7 +190,7 @@ you have a better idea of how to do this then please let us know."
(if (equal major-mode 'mh-folder-mode)
(mh-show)
(mh-show-show))
- header-field)))
+ (org-trim header-field))))
(defun org-mhe-follow-link (folder article)
"Follow an MH-E link to FOLDER and ARTICLE.
diff --git a/lisp/org/org-mks.el b/lisp/org/org-mks.el
new file mode 100644
index 00000000000..2d429a79152
--- /dev/null
+++ b/lisp/org/org-mks.el
@@ -0,0 +1,137 @@
+;;; org-mks.el --- Multi-key-selection for Org-mode
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Carsten Dominik <carsten at orgmode dot org>
+;; Keywords: outlines, hypermedia, calendar, wp
+;; Homepage: http://orgmode.org
+;; Version: 7.3
+;;
+;; This file is part of GNU Emacs.
+;;
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;;; Commentary:
+;;
+
+;;; Code:
+
+(require 'org)
+(eval-when-compile
+ (require 'cl))
+
+(defun org-mks (table title &optional prompt specials)
+ "Select a member of an alist with multiple keys.
+TABLE is the alist which should contain entries where the car is a string.
+There should be two types of entries.
+
+1. prefix descriptions like (\"a\" \"Description\")
+ This indicates that `a' is a prefix key for multi-letter selection, and
+ that there are entries following with keys like \"ab\", \"ax\"...
+
+2. Selectable members must have more than two elements, with the first
+ being the string of keys that lead to selecting it, and the second a
+ short description string of the item.
+
+The command will then make a temporary buffer listing all entries
+that can be selected with a single key, and all the single key
+prefixes. When you press the key for a single-letter entry, it is selected.
+When you press a prefix key, the commands (and maybe further prefixes)
+under this key will be shown and offered for selection.
+
+TITLE will be placed over the selection in the temporary buffer,
+PROMPT will be used when prompting for a key. SPECIAL is an alist with
+also (\"key\" \"description\") entries. When one of these is selection,
+only the bare key is returned."
+ (setq prompt (or prompt "Select: "))
+ (let (tbl orig-table dkey ddesc des-keys allowed-keys
+ current prefix rtn re pressed buffer (inhibit-quit t))
+ (save-window-excursion
+ (setq buffer (org-switch-to-buffer-other-window "*Org Select*"))
+ (setq orig-table table)
+ (catch 'exit
+ (while t
+ (erase-buffer)
+ (insert title "\n\n")
+ (setq tbl table
+ des-keys nil
+ allowed-keys nil)
+ (setq prefix (if current (concat current " ") ""))
+ (while tbl
+ (cond
+ ((and (= 2 (length (car tbl))) (= (length (caar tbl)) 1))
+ ;; This is a description on this level
+ (setq dkey (caar tbl) ddesc (cadar tbl))
+ (pop tbl)
+ (push dkey des-keys)
+ (push dkey allowed-keys)
+ (insert prefix "[" dkey "]" "..." " " ddesc "..." "\n")
+ ;; Skip keys which are below this prefix
+ (setq re (concat "\\`" (regexp-quote dkey)))
+ (while (and tbl (string-match re (caar tbl))) (pop tbl)))
+ ((= 2 (length (car tbl)))
+ ;; Not yet a usable description, skip it
+ )
+ (t
+ ;; usable entry on this level
+ (insert prefix "[" (caar tbl) "]" " " (nth 1 (car tbl)) "\n")
+ (push (caar tbl) allowed-keys)
+ (pop tbl))))
+ (when specials
+ (insert "-------------------------------------------------------------------------------\n")
+ (let ((sp specials))
+ (while sp
+ (insert (format "[%s] %s\n"
+ (caar sp) (nth 1 (car sp))))
+ (push (caar sp) allowed-keys)
+ (pop sp))))
+ (push "\C-g" allowed-keys)
+ (goto-char (point-min))
+ (if (not (pos-visible-in-window-p (point-max)))
+ (org-fit-window-to-buffer))
+ (message prompt)
+ (setq pressed (char-to-string (read-char-exclusive)))
+ (while (not (member pressed allowed-keys))
+ (message "Invalid key `%s'" pressed) (sit-for 1)
+ (message prompt)
+ (setq pressed (char-to-string (read-char-exclusive))))
+ (when (equal pressed "\C-g")
+ (kill-buffer buffer)
+ (error "Abort"))
+ (when (and (not (assoc pressed table))
+ (not (member pressed des-keys))
+ (assoc pressed specials))
+ (throw 'exit (setq rtn pressed)))
+ (unless (member pressed des-keys)
+ (throw 'exit (setq rtn (rassoc (cdr (assoc pressed table))
+ orig-table))))
+ (setq current (concat current pressed))
+ (setq table (mapcar
+ (lambda (x)
+ (if (and (> (length (car x)) 1)
+ (equal (substring (car x) 0 1) pressed))
+ (cons (substring (car x) 1) (cdr x))
+ nil))
+ table))
+ (setq table (remove nil table)))))
+ (when buffer (kill-buffer buffer))
+ rtn))
+
+(provide 'org-mks)
+
+;; arch-tag: 4ea90d0e-c6e4-4684-bd61-baf878712f9f
+
+;;; org-mks.el ends here
diff --git a/lisp/org/org-mobile.el b/lisp/org/org-mobile.el
index 121c2fd0308..a278fb16d0a 100644
--- a/lisp/org/org-mobile.el
+++ b/lisp/org/org-mobile.el
@@ -4,7 +4,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -26,13 +26,16 @@
;;; Commentary:
;;
;; This file contains the code to interact with Richard Moreland's iPhone
-;; application MobileOrg. This code is documented in Appendix B of the
-;; Org-mode manual. The code is not specific for the iPhone, however.
-;; Any external viewer/flagging/editing application that uses the same
-;; conventions could be used.
+;; application MobileOrg, as well as with the Android version by Matthew Jones.
+;; This code is documented in Appendix B of the Org-mode manual. The code is
+;; not specific for the iPhone and Android - any external
+;; viewer/flagging/editing application that uses the same conventions could
+;; be used.
(require 'org)
(require 'org-agenda)
+;;; Code:
+
(eval-when-compile (require 'cl))
(defgroup org-mobile nil
@@ -47,7 +50,7 @@ directly. Directories will be search for files with the extension `.org'.
In addition to this, the list may also contain the following symbols:
org-agenda-files
- This means, include the complete, unrestricted list of files given in
+ This means include the complete, unrestricted list of files given in
the variable `org-agenda-files'.
org-agenda-text-search-extra-files
Include the files given in the variable
@@ -65,6 +68,52 @@ org-agenda-text-search-extra-files
:group 'org-mobile
:type 'directory)
+(defcustom org-mobile-use-encryption nil
+ "Non-nil means keep only encrypted files on the WebDAV server.
+Encryption uses AES-256, with a password given in
+`org-mobile-encryption-password'.
+When nil, plain files are kept on the server.
+Turning on encryption requires to set the same password in the MobileOrg
+application. Before turning this on, check of MobileOrg does already
+support it - at the time of this writing it did not yet."
+ :group 'org-mobile
+ :type 'boolean)
+
+(defcustom org-mobile-encryption-tempfile "~/orgtmpcrypt"
+ "File that is being used as a temporary file for encryption.
+This must be local file on your local machine (not on the WebDAV server).
+You might want to put this file into a directory where only you have access."
+ :group 'org-mobile
+ :type 'directory)
+
+(defcustom org-mobile-encryption-password ""
+ "Password for encrypting files uploaded to the server.
+This is a single password which is used for AES-256 encryption. The same
+password must also be set in the MobileOrg application. All Org files,
+including mobileorg.org will be encrypted using this password.
+
+SECURITY CONSIDERATIONS:
+
+Note that, when Org runs the encryption commands, the password could
+be visible briefly on your system with the `ps' command. So this method is
+only intended to keep the files secure on the server, not on your own machine.
+
+Also, if you set this variable in an init file (.emacs or .emacs.d/init.el
+or custom.el...) and if that file is stored in a way so that other can read
+it, this also limits the security of this approach. You can also leave
+this variable empty - Org will then ask for the password once per Emacs
+session."
+ :group 'org-mobile
+ :type '(string :tag "Password"))
+
+(defvar org-mobile-encryption-password-session nil)
+
+(defun org-mobile-encryption-password ()
+ (or (org-string-nw-p org-mobile-encryption-password)
+ (org-string-nw-p org-mobile-encryption-password-session)
+ (setq org-mobile-encryption-password-session
+ (read-passwd "Password for MobileOrg: " t))))
+
(defcustom org-mobile-inbox-for-pull "~/org/from-mobile.org"
"The file where captured notes and flags will be appended to.
During the execution of `org-mobile-pull', the file
@@ -85,13 +134,29 @@ should point to this file."
:group 'org-mobile
:type 'file)
+(defcustom org-mobile-agendas 'all
+ "The agendas that should be pushed to MobileOrg.
+Allowed values:
+
+default the weekly agenda and the global TODO list
+custom all custom agendas defined by the user
+all the custom agendas and the default ones
+list a list of selection key(s) as string."
+ :group 'org-mobile
+ :type '(choice
+ (const :tag "Default Agendas" default)
+ (const :tag "Custom Agendas" custom)
+ (const :tag "Default and Custom Agendas" all)
+ (repeat :tag "Selected"
+ (string :tag "Selection Keys"))))
+
(defcustom org-mobile-force-id-on-agenda-items t
- "Non-nil means make all agenda items carry and ID."
+ "Non-nil means make all agenda items carry an ID."
:group 'org-mobile
:type 'boolean)
(defcustom org-mobile-force-mobile-change nil
- "Non-nil means, force the change made on the mobile device.
+ "Non-nil means force the change made on the mobile device.
So even if there have been changes to the computer version of the entry,
force the new value set on the mobile.
When nil, mark the entry from the mobile with an error message.
@@ -247,15 +312,14 @@ create all custom agenda views, for upload to the mobile phone."
(kill-buffer a-buffer)
(let ((cw (selected-window)))
(select-window (get-buffer-window a-buffer))
-
(org-agenda-redo)
(select-window cw)))))
(message "Files for mobile viewer staged"))
-
+
(defvar org-mobile-before-process-capture-hook nil
"Hook that is run after content was moved to `org-mobile-inbox-for-pull'.
-The inbox file is in the current buffer, and the buffer is arrowed to the
-new captured data.")
+The inbox file is visited by the current buffer, and the buffer is
+narrowed to the newly captured data.")
;;;###autoload
(defun org-mobile-pull ()
@@ -285,6 +349,7 @@ agenda view showing the flagged items."
(defun org-mobile-check-setup ()
"Check if org-mobile-directory has been set up."
+ (org-mobile-cleanup-encryption-tempfile)
(unless (and org-directory
(stringp org-directory)
(string-match "\\S-" org-directory)
@@ -305,7 +370,19 @@ agenda view showing the flagged items."
(file-exists-p
(file-name-directory org-mobile-inbox-for-pull)))
(error
- "Variable `org-mobile-inbox-for-pull' must point to a file in an existing directory")))
+ "Variable `org-mobile-inbox-for-pull' must point to a file in an existing directory"))
+ (unless (and org-mobile-checksum-binary
+ (string-match "\\S-" org-mobile-checksum-binary))
+ (error "No executable found to compute checksums"))
+ (when org-mobile-use-encryption
+ (unless (string-match "\\S-" (org-mobile-encryption-password))
+ (error
+ "To use encryption, you must set `org-mobile-encryption-password'"))
+ (unless (file-writable-p org-mobile-encryption-tempfile)
+ (error "Cannot write to encryption tempfile %s"
+ org-mobile-encryption-tempfile))
+ (unless (executable-find "openssl")
+ (error "openssl is needed to encrypt files"))))
(defun org-mobile-create-index-file ()
"Write the index file in the WebDAV directory."
@@ -313,8 +390,10 @@ agenda view showing the flagged items."
(lambda (a b) (string< (cdr a) (cdr b)))))
(def-todo (default-value 'org-todo-keywords))
(def-tags (default-value 'org-tag-alist))
+ (target-file (expand-file-name org-mobile-index-file
+ org-mobile-directory))
file link-name todo-kwds done-kwds tags drawers entry kwds dwds twds)
-
+
(org-prepare-agenda-buffers (mapcar 'car files-alist))
(setq done-kwds (org-uniquify org-done-keywords-for-agenda))
(setq todo-kwds (org-delete-all
@@ -331,7 +410,9 @@ agenda view showing the flagged items."
(t nil)))
org-tag-alist-for-agenda))))
(with-temp-file
- (expand-file-name org-mobile-index-file org-mobile-directory)
+ (if org-mobile-use-encryption
+ org-mobile-encryption-tempfile
+ target-file)
(while (setq entry (pop def-todo))
(insert "#+READONLY\n")
(setq kwds (mapcar (lambda (x) (if (string-match "(" x)
@@ -372,7 +453,11 @@ agenda view showing the flagged items."
(insert (format "* [[file:%s][%s]]\n"
link-name link-name)))
(push (cons org-mobile-index-file (md5 (buffer-string)))
- org-mobile-checksum-files))))
+ org-mobile-checksum-files))
+ (when org-mobile-use-encryption
+ (org-mobile-encrypt-and-move org-mobile-encryption-tempfile
+ target-file)
+ (org-mobile-cleanup-encryption-tempfile))))
(defun org-mobile-copy-agenda-files ()
"Copy all agenda files to the stage or WebDAV directory."
@@ -385,21 +470,29 @@ agenda view showing the flagged items."
target-dir (file-name-directory target-path))
(unless (file-directory-p target-dir)
(make-directory target-dir 'parents))
- (copy-file file target-path 'ok-if-exists)
+ (if org-mobile-use-encryption
+ (org-mobile-encrypt-and-move file target-path)
+ (copy-file file target-path 'ok-if-exists))
(setq check (shell-command-to-string
(concat org-mobile-checksum-binary " "
(shell-quote-argument (expand-file-name file)))))
(when (string-match "[a-fA-F0-9]\\{30,40\\}" check)
(push (cons link-name (match-string 0 check))
org-mobile-checksum-files))))
+
(setq file (expand-file-name org-mobile-capture-file
org-mobile-directory))
(save-excursion
(setq buf (find-file file))
- (and (= (point-min) (point-max)) (insert "\n"))
- (save-buffer)
+ (when (and (= (point-min) (point-max)))
+ (insert "\n")
+ (save-buffer)
+ (when org-mobile-use-encryption
+ (write-file org-mobile-encryption-tempfile)
+ (org-mobile-encrypt-and-move org-mobile-encryption-tempfile file)))
(push (cons org-mobile-capture-file (md5 (buffer-string)))
org-mobile-checksum-files))
+ (org-mobile-cleanup-encryption-tempfile)
(kill-buffer buf)))
(defun org-mobile-write-checksums ()
@@ -426,8 +519,22 @@ The table of checksums is written to the file mobile-checksums."
((not (nth 1 x)) (cons (car x) (cons "" (cddr x))))
(t (cons (car x) (cons "" (cdr x))))))
org-agenda-custom-commands)))
- new e key desc type match settings cmds gkey gdesc gsettings cnt)
- (while (setq e (pop custom-list))
+ (default-list '(("a" "Agenda" agenda) ("t" "All TODO" alltodo)))
+ thelist new e key desc type match settings cmds gkey gdesc gsettings cnt)
+ (cond
+ ((eq org-mobile-agendas 'custom)
+ (setq thelist custom-list))
+ ((eq org-mobile-agendas 'default)
+ (setq thelist default-list))
+ ((eq org-mobile-agendas 'all)
+ (setq thelist custom-list)
+ (unless (assoc "t" thelist) (push '("t" "ALL TODO" alltodo) thelist))
+ (unless (assoc "a" thelist) (push '("a" "Agenda" agenda) thelist)))
+ ((listp org-mobile-agendas)
+ (setq thelist (append custom-list default-list))
+ (setq thelist (delq nil (mapcar (lambda (k) (assoc k thelist))
+ org-mobile-agendas)))))
+ (while (setq e (pop thelist))
(cond
((stringp (cdr e))
;; this is a description entry - skip it
@@ -438,7 +545,12 @@ The table of checksums is written to the file mobile-checksums."
((memq (nth 2 e) '(todo-tree tags-tree occur-tree))
;; These are trees, not really agenda commands
)
- ((memq (nth 2 e) '(agenda todo tags))
+ ((and (memq (nth 2 e) '(todo tags tags-todo))
+ (or (null (nth 3 e))
+ (not (string-match "\\S-" (nth 3 e)))))
+ ;; These would be interactive because the match string is empty
+ )
+ ((memq (nth 2 e) '(agenda alltodo todo tags tags-todo))
;; a normal command
(setq key (car e) desc (nth 1 e) type (nth 2 e) match (nth 3 e)
settings (nth 4 e))
@@ -527,40 +639,105 @@ The table of checksums is written to the file mobile-checksums."
(if (org-bound-and-true-p
org-mobile-force-id-on-agenda-items)
(org-id-get m 'create)
- (org-entry-get m "ID")))
+ (or (org-entry-get m "ID")
+ (org-mobile-get-outline-path-link m))))
(insert " :PROPERTIES:\n :ORIGINAL_ID: " id
"\n :END:\n")))))
(beginning-of-line 2))
- (push (cons (file-name-nondirectory file) (md5 (buffer-string)))
+ (push (cons "agendas.org" (md5 (buffer-string)))
org-mobile-checksum-files))
(message "Agenda written to Org file %s" file)))
+(defun org-mobile-get-outline-path-link (pom)
+ (org-with-point-at pom
+ (concat "olp:"
+ (org-mobile-escape-olp (file-name-nondirectory buffer-file-name))
+ "/"
+ (mapconcat 'org-mobile-escape-olp
+ (org-get-outline-path)
+ "/")
+ "/"
+ (org-mobile-escape-olp (nth 4 (org-heading-components))))))
+
+(defun org-mobile-escape-olp (s)
+ (let ((table '((?: . "%3a") (?\[ . "%5b") (?\] . "%5d") (?/ . "%2f"))))
+ (org-link-escape s table)))
+
;;;###autoload
(defun org-mobile-create-sumo-agenda ()
"Create a file that contains all custom agenda views."
(interactive)
(let* ((file (expand-file-name "agendas.org"
org-mobile-directory))
+ (file1 (if org-mobile-use-encryption
+ org-mobile-encryption-tempfile
+ file))
(sumo (org-mobile-sumo-agenda-command))
(org-agenda-custom-commands
- (list (append sumo (list (list file)))))
+ (list (append sumo (list (list file1)))))
(org-mobile-creating-agendas t))
- (unless (file-writable-p file)
- (error "Cannot write to file %s" file))
+ (unless (file-writable-p file1)
+ (error "Cannot write to file %s" file1))
(when sumo
- (org-store-agenda-views))))
+ (org-store-agenda-views))
+ (when org-mobile-use-encryption
+ (org-mobile-encrypt-and-move file1 file)
+ (delete-file file1)
+ (org-mobile-cleanup-encryption-tempfile))))
+
+(defun org-mobile-encrypt-and-move (infile outfile)
+ "Encrypt INFILE locally to INFILE_enc, then move it to OUTFILE.
+We do this in two steps so that remote paths will work, even if the
+encryption program does not understand them."
+ (let ((encfile (concat infile "_enc")))
+ (org-mobile-encrypt-file infile encfile)
+ (when outfile
+ (copy-file encfile outfile 'ok-if-exists)
+ (delete-file encfile))))
+
+(defun org-mobile-encrypt-file (infile outfile)
+ "Encrypt INFILE to OUTFILE, using `org-mobile-encryption-password'."
+ (shell-command
+ (format "openssl enc -aes-256-cbc -salt -pass %s -in %s -out %s"
+ (shell-quote-argument (concat "pass:"
+ (org-mobile-encryption-password)))
+ (shell-quote-argument (expand-file-name infile))
+ (shell-quote-argument (expand-file-name outfile)))))
+
+(defun org-mobile-decrypt-file (infile outfile)
+ "Decrypt INFILE to OUTFILE, using `org-mobile-encryption-password'."
+ (shell-command
+ (format "openssl enc -d -aes-256-cbc -salt -pass %s -in %s -out %s"
+ (shell-quote-argument (concat "pass:"
+ (org-mobile-encryption-password)))
+ (shell-quote-argument (expand-file-name infile))
+ (shell-quote-argument (expand-file-name outfile)))))
+
+(defun org-mobile-cleanup-encryption-tempfile ()
+ "Remove the encryption tempfile if it exists."
+ (and (stringp org-mobile-encryption-tempfile)
+ (file-exists-p org-mobile-encryption-tempfile)
+ (delete-file org-mobile-encryption-tempfile)))
(defun org-mobile-move-capture ()
"Move the contents of the capture file to the inbox file.
Return a marker to the location where the new content has been added.
If nothing new has been added, return nil."
(interactive)
- (let ((inbox-buffer (find-file-noselect org-mobile-inbox-for-pull))
- (capture-buffer (find-file-noselect
- (expand-file-name org-mobile-capture-file
- org-mobile-directory)))
- (insertion-point (make-marker))
- not-empty content)
+ (let* ((encfile nil)
+ (capture-file (expand-file-name org-mobile-capture-file
+ org-mobile-directory))
+ (inbox-buffer (find-file-noselect org-mobile-inbox-for-pull))
+ (capture-buffer
+ (if (not org-mobile-use-encryption)
+ (find-file-noselect capture-file)
+ (org-mobile-cleanup-encryption-tempfile)
+ (setq encfile (concat org-mobile-encryption-tempfile "_enc"))
+ (copy-file capture-file encfile)
+ (org-mobile-decrypt-file encfile org-mobile-encryption-tempfile)
+ (find-file-noselect org-mobile-encryption-tempfile)))
+ (insertion-point (make-marker))
+ not-empty content)
(with-current-buffer capture-buffer
(setq content (buffer-string))
(setq not-empty (string-match "\\S-" content))
@@ -577,9 +754,14 @@ If nothing new has been added, return nil."
(save-buffer)
(org-mobile-update-checksum-for-capture-file (buffer-string))))
(kill-buffer capture-buffer)
+ (when org-mobile-use-encryption
+ (org-mobile-encrypt-and-move org-mobile-encryption-tempfile
+ capture-file)
+ (org-mobile-cleanup-encryption-tempfile))
(if not-empty insertion-point)))
(defun org-mobile-update-checksum-for-capture-file (buffer-string)
+ "Find the checksum line and modify it to match BUFFER-STRING."
(let* ((file (expand-file-name "checksums.dat" org-mobile-directory))
(buffer (find-file-noselect file)))
(when buffer
@@ -781,42 +963,6 @@ FIXME: Hmmm, not sure if we can make his work against the
auto-correction feature. Needs a bit more thinking. So this function
is currently a noop.")
-
-(defun org-find-olp (path)
- "Return a marker pointing to the entry at outline path OLP.
-If anything goes wrong, the return value will instead an error message,
-as a string."
- (let* ((file (pop path))
- (buffer (find-file-noselect file))
- (level 1)
- (lmin 1)
- (lmax 1)
- limit re end found pos heading cnt)
- (unless buffer (error "File not found :%s" file))
- (with-current-buffer buffer
- (save-excursion
- (save-restriction
- (widen)
- (setq limit (point-max))
- (goto-char (point-min))
- (while (setq heading (pop path))
- (setq re (format org-complex-heading-regexp-format
- (regexp-quote heading)))
- (setq cnt 0 pos (point))
- (while (re-search-forward re end t)
- (setq level (- (match-end 1) (match-beginning 1)))
- (if (and (>= level lmin) (<= level lmax))
- (setq found (match-beginning 0) cnt (1+ cnt))))
- (when (= cnt 0) (error "Heading not found on level %d: %s"
- lmax heading))
- (when (> cnt 1) (error "Heading not unique on level %d: %s"
- lmax heading))
- (goto-char found)
- (setq lmin (1+ level) lmax (+ lmin (if org-odd-levels-only 1 0)))
- (setq end (save-excursion (org-end-of-subtree t t))))
- (when (org-on-heading-p)
- (move-marker (make-marker) (point))))))))
-
(defun org-mobile-locate-entry (link)
(if (string-match "\\`id:\\(.*\\)$" link)
(org-id-find (match-string 1 link) 'marker)
@@ -856,7 +1002,7 @@ be returned that indicates what went wrong."
(org-todo (or new 'none)) t)
(t (error "State before change was expected as \"%s\", but is \"%s\""
old current))))
-
+
((eq what 'tags)
(setq current (org-get-tags)
new1 (and new (org-split-string new ":+"))
@@ -869,7 +1015,7 @@ be returned that indicates what went wrong."
(org-set-tags-to new1) t)
(t (error "Tags before change were expected as \"%s\", but are \"%s\""
(or old "") (or current "")))))
-
+
((eq what 'priority)
(when (looking-at org-complex-heading-regexp)
(setq current (and (match-end 3) (substring (match-string 3) 2 3)))
@@ -895,7 +1041,7 @@ be returned that indicates what went wrong."
(delete-region (point) (+ (point) (length current)))
(org-set-tags nil 'align))
(t (error "Heading changed in MobileOrg and on the computer")))))
-
+
((eq what 'body)
(setq current (buffer-substring (min (1+ (point-at-eol)) (point-max))
(save-excursion (outline-next-heading)
@@ -915,7 +1061,6 @@ be returned that indicates what went wrong."
(point))))
t)
(t (error "Body was changed in MobileOrg and on the computer")))))))
-
(defun org-mobile-tags-same-p (list1 list2)
"Are the two tag lists the same?"
diff --git a/lisp/org/org-mouse.el b/lisp/org/org-mouse.el
index c7457a64fda..4a341d4272d 100644
--- a/lisp/org/org-mouse.el
+++ b/lisp/org/org-mouse.el
@@ -1,10 +1,11 @@
;;; org-mouse.el --- Better mouse support for org-mode
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation
+;; Copyright (C) 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;;
;; Author: Piotr Zielinski <piotr dot zielinski at gmail dot com>
;; Maintainer: Carsten Dominik <carsten at orgmode dot org>
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -137,6 +138,8 @@
;;
;; Versions 0.01 -- 0.07: (I don't remember)
+;;; Code:
+
(eval-when-compile (require 'cl))
(require 'org)
@@ -146,6 +149,7 @@
(declare-function org-agenda-change-all-lines "org-agenda"
(newhead hdmarker &optional fixface just-this))
(declare-function org-verify-change-for-undo "org-agenda" (l1 l2))
+(declare-function org-apply-on-list "org-list" (function init-value &rest args))
(defvar org-mouse-plain-list-regexp "\\([ \t]*\\)\\([-+*]\\|[0-9]+[.)]\\) "
"Regular expression that matches a plain list.")
@@ -189,7 +193,7 @@ Changing this variable requires a restart of Emacs to get activated."
(interactive)
(end-of-line)
(skip-chars-backward "\t ")
- (when (looking-back ":[A-Za-z]+:")
+ (when (org-looking-back ":[A-Za-z]+:")
(skip-chars-backward ":A-Za-z")
(skip-chars-backward "\t ")))
@@ -225,7 +229,7 @@ this function is called. Otherwise, the current major mode menu is used."
(mouse-save-then-kill event)))
(defun org-mouse-line-position ()
- "Returns `:beginning' or `:middle' or `:end', depending on the point position.
+ "Return `:beginning' or `:middle' or `:end', depending on the point position.
If the point is at the end of the line, return `:end'.
If the point is separated from the beginning of the line only by white
@@ -290,7 +294,7 @@ ITEMFORMAT governs formatting of the elements of KEYWORDS. If it
is a function, it is invoked with the keyword as the only
argument. If it is a string, it is interpreted as the format
string to (format ITEMFORMAT keyword). If it is neither a string
-nor a function, elements of KEYWORDS are used directly. "
+nor a function, elements of KEYWORDS are used directly."
(mapcar
`(lambda (keyword)
(vector (cond
@@ -342,8 +346,7 @@ ITEMFORMAT governs formatting of the elements of KEYWORDS. If it
is a function, it is invoked with the keyword as the only
argument. If it is a string, it is interpreted as the format
string to (format ITEMFORMAT keyword). If it is neither a string
-nor a function, elements of KEYWORDS are used directly.
-"
+nor a function, elements of KEYWORDS are used directly."
(setq group (or group 0))
(let ((replace (org-mouse-match-closure
(if nosurround 'replace-match
@@ -432,7 +435,7 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:"
(lambda (kwd) (equal state kwd))))))
(defun org-mouse-tag-menu () ;todo
- "Create the tags menu"
+ "Create the tags menu."
(append
(let ((tags (org-get-tags)))
(org-mouse-keyword-menu
@@ -575,17 +578,15 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:"
(goto-char (second contextdata))
(re-search-forward ".*" (third contextdata))))))
-(defun org-mouse-for-each-item (function)
- (save-excursion
- (ignore-errors
- (while t (org-previous-item)))
- (ignore-errors
- (while t
- (funcall function)
- (org-next-item)))))
+(defun org-mouse-for-each-item (funct)
+ ;; Functions called by `org-apply-on-list' need an argument
+ (let ((wrap-fun (lambda (c) (funcall funct))))
+ (when (org-in-item-p)
+ (org-apply-on-list wrap-fun nil))))
(defun org-mouse-bolp ()
- "Returns true if there only spaces, tabs, and '*', between the beginning of line and the point"
+ "Return true if there only spaces, tabs, and '*' before point.
+This means, between the beginning of line and the point."
(save-excursion
(skip-chars-backward " \t*") (bolp)))
@@ -607,7 +608,7 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:"
(:end ; insert text here
(skip-chars-backward " \t")
(kill-region (point) (point-at-eol))
- (unless (looking-back org-mouse-punctuation)
+ (unless (org-looking-back org-mouse-punctuation)
(insert (concat org-mouse-punctuation " ")))))
(insert text)
@@ -674,7 +675,7 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:"
'org-mode-restart))))
((or (eolp)
(and (looking-at "\\( \\|\t\\)\\(+:[0-9a-zA-Z_:]+\\)?\\( \\|\t\\)+$")
- (looking-back " \\|\t")))
+ (org-looking-back " \\|\t")))
(org-mouse-popup-global-menu))
((get-context :checkbox)
(popup-menu
@@ -909,18 +910,18 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:"
(setq org-mouse-context-menu-function 'org-mouse-context-menu)
(when (memq 'context-menu org-mouse-features)
- (define-key org-mouse-map (if (featurep 'xemacs) [button3] [mouse-3]) nil)
- (define-key org-mode-map [mouse-3] 'org-mouse-show-context-menu))
- (define-key org-mode-map [down-mouse-1] 'org-mouse-down-mouse)
+ (org-defkey org-mouse-map [mouse-3] nil)
+ (org-defkey org-mode-map [mouse-3] 'org-mouse-show-context-menu))
+ (org-defkey org-mode-map [down-mouse-1] 'org-mouse-down-mouse)
(when (memq 'context-menu org-mouse-features)
- (define-key org-mouse-map [C-drag-mouse-1] 'org-mouse-move-tree)
- (define-key org-mouse-map [C-down-mouse-1] 'org-mouse-move-tree-start))
+ (org-defkey org-mouse-map [C-drag-mouse-1] 'org-mouse-move-tree)
+ (org-defkey org-mouse-map [C-down-mouse-1] 'org-mouse-move-tree-start))
(when (memq 'yank-link org-mouse-features)
- (define-key org-mode-map [S-mouse-2] 'org-mouse-yank-link)
- (define-key org-mode-map [drag-mouse-3] 'org-mouse-yank-link))
+ (org-defkey org-mode-map [S-mouse-2] 'org-mouse-yank-link)
+ (org-defkey org-mode-map [drag-mouse-3] 'org-mouse-yank-link))
(when (memq 'move-tree org-mouse-features)
- (define-key org-mouse-map [drag-mouse-3] 'org-mouse-move-tree)
- (define-key org-mouse-map [down-mouse-3] 'org-mouse-move-tree-start))
+ (org-defkey org-mouse-map [drag-mouse-3] 'org-mouse-move-tree)
+ (org-defkey org-mouse-map [down-mouse-3] 'org-mouse-move-tree-start))
(when (memq 'activate-stars org-mouse-features)
(font-lock-add-keywords
@@ -1131,13 +1132,11 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:"
(add-hook 'org-agenda-mode-hook
'(lambda ()
(setq org-mouse-context-menu-function 'org-mouse-agenda-context-menu)
- (define-key org-agenda-mode-map
- (if (featurep 'xemacs) [button3] [mouse-3])
- 'org-mouse-show-context-menu)
- (define-key org-agenda-mode-map [down-mouse-3] 'org-mouse-move-tree-start)
- (define-key org-agenda-mode-map (if (featurep 'xemacs) [(control mouse-4)] [C-mouse-4]) 'org-agenda-earlier)
- (define-key org-agenda-mode-map (if (featurep 'xemacs) [(control mouse-5)] [C-mouse-5]) 'org-agenda-later)
- (define-key org-agenda-mode-map [drag-mouse-3]
+ (org-defkey org-agenda-mode-map [mouse-3] 'org-mouse-show-context-menu)
+ (org-defkey org-agenda-mode-map [down-mouse-3] 'org-mouse-move-tree-start)
+ (org-defkey org-agenda-mode-map [C-mouse-4] 'org-agenda-earlier)
+ (org-defkey org-agenda-mode-map [C-mouse-5] 'org-agenda-later)
+ (org-defkey org-agenda-mode-map [drag-mouse-3]
'(lambda (event) (interactive "e")
(case (org-mouse-get-gesture event)
(:left (org-agenda-earlier 1))
@@ -1147,4 +1146,4 @@ SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:"
;; arch-tag: ff1ae557-3529-41a3-95c6-baaebdcc280f
-;;; org-mouse.el ends-here
+;;; org-mouse.el ends here
diff --git a/lisp/org/org-plot.el b/lisp/org/org-plot.el
index 2e1f6c8f6cc..274d3f94c8a 100644
--- a/lisp/org/org-plot.el
+++ b/lisp/org/org-plot.el
@@ -5,7 +5,7 @@
;; Author: Eric Schulte <schulte dot eric at gmail dot com>
;; Keywords: tables, plotting
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -44,7 +44,7 @@
'((:plot-type . 2d)
(:with . lines)
(:ind . 0))
- "Default options to gnuplot used by `org-plot/gnuplot'")
+ "Default options to gnuplot used by `org-plot/gnuplot'.")
(defvar org-plot-timestamp-fmt nil)
@@ -134,7 +134,7 @@ Pass PARAMS through to `orgtbl-to-generic' when exporting TABLE."
(defun org-plot/gnuplot-to-grid-data (table data-file params)
"Export the data in TABLE to DATA-FILE for gnuplot.
-This means, in a format appropriate for grid plotting by gnuplot.
+This means in a format appropriate for grid plotting by gnuplot.
PARAMS specifies which columns of TABLE should be plotted as independent
and dependant variables."
(interactive)
@@ -250,8 +250,9 @@ manner suitable for prepending to a user-specified script."
(setf plot-lines
(cons
(format plot-str data-file
- (or (and (not text-ind) ind
- (> ind 0) (format "%d:" ind)) "")
+ (or (and ind (> ind 0)
+ (not text-ind)
+ (format "%d:" ind)) "")
(+ 1 col)
(if text-ind (format ":xticlabel(%d)" ind) "")
with
@@ -271,7 +272,7 @@ manner suitable for prepending to a user-specified script."
;; facade functions
;;;###autoload
(defun org-plot/gnuplot (&optional params)
- "Plot table using gnuplot. Gnuplot options can be specified with PARAMS.
+ "Plot table using gnuplot. Gnuplot options can be specified with PARAMS.
If not given options will be taken from the +PLOT
line directly before or after the table."
(interactive)
@@ -300,7 +301,7 @@ line directly before or after the table."
(setf table (delq 'hline (cdr table)))) ;; clean non-data from table
;; collect options
(save-excursion (while (and (equal 0 (forward-line -1))
- (looking-at "#\\+"))
+ (looking-at "[[:space:]]*#\\+"))
(setf params (org-plot/collect-options params))))
;; dump table to datafile (very different for grid)
(case (plist-get params :plot-type)
@@ -320,7 +321,6 @@ line directly before or after the table."
(mapcar (lambda (row) (nth ind row)) table)))) 0)
(plist-put params :timeind t)
;; check for text ind column
-
(if (or (string= (plist-get params :with) "hist")
(> (length
(delq 0 (mapcar
diff --git a/lisp/org/org-protocol.el b/lisp/org/org-protocol.el
index 59f08f1dfa2..3a20c5f729c 100644
--- a/lisp/org/org-protocol.el
+++ b/lisp/org/org-protocol.el
@@ -9,7 +9,7 @@
;; Author: Ross Patterson <me AT rpatterson DOT net>
;; Maintainer: Sebastian Rose <sebastian_rose AT gmx DOT de>
;; Keywords: org, emacsclient, wp
-;; Version: 6.33x
+;; Version: 7.3
;; This file is part of GNU Emacs.
;;
@@ -31,8 +31,8 @@
;;
;; Intercept calls from emacsclient to trigger custom actions.
;;
-;; This is done by advising `server-visit-files' to scann the list of filenames
-;; for `org-protocol-the-protocol' and sub-procols defined in
+;; This is done by advising `server-visit-files' to scan the list of filenames
+;; for `org-protocol-the-protocol' and sub-protocols defined in
;; `org-protocol-protocol-alist' and `org-protocol-protocol-alist-default'.
;;
;; Any application that supports calling external programs with an URL
@@ -58,7 +58,7 @@
;; (setq org-protocol-protocol-alist
;; '(("my-protocol"
;; :protocol "my-protocol"
-;; :function my-protocol-handler-fuction)))
+;; :function my-protocol-handler-function)))
;;
;; A "sub-protocol" will be found in URLs like this:
;;
@@ -84,15 +84,20 @@
;; URLs to local filenames defined in `org-protocol-project-alist'.
;;
;; * `org-protocol-store-link' stores an Org-link (if Org-mode is present) and
-;; pushes the browsers URL to the `kill-ring' for yanking. This handler is
+;; pushes the browsers URL to the `kill-ring' for yanking. This handler is
;; triggered through the sub-protocol \"store-link\".
;;
-;; * Call `org-protocol-remember' by using the sub-protocol \"remember\". If
-;; Org-mode is loaded, emacs will pop-up a remember buffer and fill the
-;; template with the data provided. I.e. the browser's URL is inserted as an
-;; Org-link of which the page title will be the description part. If text
+;; * Call `org-protocol-capture' by using the sub-protocol \"capture\". If
+;; Org-mode is loaded, Emacs will pop-up a capture buffer and fill the
+;; template with the data provided. I.e. the browser's URL is inserted as an
+;; Org-link of which the page title will be the description part. If text
;; was select in the browser, that text will be the body of the entry.
;;
+;; * Call `org-protocol-remember' by using the sub-protocol \"remember\".
+;; This is provided for backward compatibility.
+;; You may read `org-capture' as `org-remember' throughout this file if
+;; you still use `org-remember'.
+;;
;; You may use the same bookmark URL for all those standard handlers and just
;; adjust the sub-protocol used:
;;
@@ -101,7 +106,7 @@
;; encodeURIComponent(document.title)+'/'+
;; encodeURIComponent(window.getSelection())
;;
-;; The handler for the sub-protocol \"remember\" detects an optional template
+;; The handler for the sub-protocol \"capture\" detects an optional template
;; char that, if present, triggers the use of a special template.
;; Example:
;;
@@ -121,8 +126,6 @@
(eval-when-compile
(require 'cl))
-(declare-function org-publish-initialize-files-alist "org-publish"
- (&optional refresh))
(declare-function org-publish-get-project-from-filename "org-publish"
(filename &optional up))
(declare-function server-edit "server" (&optional arg))
@@ -143,6 +146,7 @@ for `org-protocol-the-protocol' and sub-procols defined in
(defconst org-protocol-protocol-alist-default
'(("org-remember" :protocol "remember" :function org-protocol-remember :kill-client t)
+ ("org-capture" :protocol "capture" :function org-protocol-capture :kill-client t)
("org-store-link" :protocol "store-link" :function org-protocol-store-link)
("org-open-source" :protocol "open-source" :function org-protocol-open-source))
"Default protocols to use.
@@ -151,18 +155,19 @@ See `org-protocol-protocol-alist' for a description of this variable.")
(defconst org-protocol-the-protocol "org-protocol"
"This is the protocol to detect if org-protocol.el is loaded.
-`org-protocol-protocol-alist-default' and `org-protocol-protocol-alist' hold the
-sub-protocols that trigger the required action. You will have to define just one
-protocol handler OS-wide (MS-Windows) or per application (Linux). That protocol
-handler should call emacsclient.")
+`org-protocol-protocol-alist-default' and `org-protocol-protocol-alist' hold
+the sub-protocols that trigger the required action. You will have to define
+just one protocol handler OS-wide (MS-Windows) or per application (Linux).
+That protocol handler should call emacsclient.")
;;; User variables:
(defcustom org-protocol-reverse-list-of-files t
- "* The filenames passed on the commandline are passed to the emacs-server in
-reversed order. Set to `t' (default) to re-reverse the list, i.e. use the
-sequence on the command line. If nil, the sequence of the filenames is
+ "* Non-nil means re-reverse the list of filenames passed on the command line.
+The filenames passed on the command line are passed to the emacs-server in
+reverse order. Set to t (default) to re-reverse the list, i.e. use the
+sequence on the command line. If nil, the sequence of the filenames is
unchanged."
:group 'org-protocol
:type 'boolean)
@@ -225,7 +230,7 @@ protocol - protocol to detect in a filename without trailing colon and slashes.
If you define a protocol \"my-protocol\", `org-protocol-check-filename-for-protocol'
will search filenames for \"org-protocol:/my-protocol:/\"
and trigger your action for every match. `org-protocol' is defined in
- `org-protocol-the-protocol'. Double and tripple slashes are compressed
+ `org-protocol-the-protocol'. Double and triple slashes are compressed
to one by emacsclient.
function - function that handles requests with protocol and takes exactly one
@@ -239,7 +244,7 @@ function - function that handles requests with protocol and takes exactly one
kill-client - If t, kill the client immediately, once the sub-protocol is
detected. This is necessary for actions that can be interrupted by
- `C-g' to avoid dangeling emacsclients. Note, that all other command
+ `C-g' to avoid dangling emacsclients. Note, that all other command
line arguments but the this one will be discarded, greedy handlers
still receive the whole list of arguments though.
@@ -248,23 +253,22 @@ Here is an example:
(setq org-protocol-protocol-alist
'((\"my-protocol\"
:protocol \"my-protocol\"
- :function my-protocol-handler-fuction)
+ :function my-protocol-handler-function)
(\"your-protocol\"
:protocol \"your-protocol\"
- :function your-protocol-handler-fuction)))"
+ :function your-protocol-handler-function)))"
:group 'org-protocol
:type '(alist))
-(defcustom org-protocol-default-template-key "w"
+(defcustom org-protocol-default-template-key nil
"The default org-remember-templates key to use."
:group 'org-protocol
:type 'string)
-
;;; Helper functions:
(defun org-protocol-sanitize-uri (uri)
- "emacsclient compresses double and tripple slashes.
+ "emacsclient compresses double and triple slashes.
Slashes are sanitized to double slashes here."
(when (string-match "^\\([a-z]+\\):/" uri)
(let* ((splitparts (split-string uri "/+")))
@@ -273,12 +277,13 @@ Slashes are sanitized to double slashes here."
(defun org-protocol-split-data(data &optional unhexify separator)
- "Split, what a org-protocol handler function gets as only argument.
-data is that one argument. Data is splitted at each occurrence of separator
- (regexp). If no separator is specified or separator is nil, assume \"/+\".
-The results of that splitting are return as a list. If unhexify is non-nil,
-hex-decode each split part. If unhexify is a function, use that function to
-decode each split part."
+ "Split, what an org-protocol handler function gets as only argument.
+DATA is that one argument. DATA is split at each occurrence of
+SEPARATOR (regexp). If no SEPARATOR is specified or SEPARATOR is
+nil, assume \"/+\". The results of that splitting are returned
+as a list. If UNHEXIFY is non-nil, hex-decode each split part. If
+UNHEXIFY is a function, use that function to decode each split
+part."
(let* ((sep (or separator "/+"))
(split-parts (split-string data sep)))
(if unhexify
@@ -316,7 +321,7 @@ encodeURIComponent. E.g. `%C3%B6' is the german Umlaut `ü'."
(defun org-protocol-unhex-compound (hex)
- "Unhexify unicode hex-chars. E.g. `%C3%B6' is the german Umlaut `ü'."
+ "Unhexify unicode hex-chars. E.g. `%C3%B6' is the German Umlaut `ü'."
(let* ((bytes (remove "" (split-string hex "%")))
(ret "")
(eat 0)
@@ -412,9 +417,9 @@ This function transforms it into a flat list."
;;; Standard protocol handlers:
(defun org-protocol-store-link (fname)
- "Process an org-protocol://store-link:// style url
-and store a browser URL as an org link. Also pushes the links URL to the
-`kill-ring'.
+ "Process an org-protocol://store-link:// style url.
+Additionally store a browser URL as an org link. Also pushes the
+link's URL to the `kill-ring'.
The location for a browser's bookmark has to look like this:
@@ -443,50 +448,75 @@ The sub-protocol used to reach this function is set in
(defun org-protocol-remember (info)
"Process an org-protocol://remember:// style url.
+The location for a browser's bookmark has to look like this:
+
+ javascript:location.href='org-protocol://remember://'+ \\
+ encodeURIComponent(location.href)+'/' \\
+ encodeURIComponent(document.title)+'/'+ \\
+ encodeURIComponent(window.getSelection())
+
+See the docs for `org-protocol-capture' for more information."
+
+ (if (and (boundp 'org-stored-links)
+ (or (fboundp 'org-capture))
+ (org-protocol-do-capture info 'org-remember))
+ (message "Org-mode not loaded."))
+ nil)
+
+(defun org-protocol-capture (info)
+ "Process an org-protocol://capture:// style url.
+
The sub-protocol used to reach this function is set in
`org-protocol-protocol-alist'.
This function detects an URL, title and optional text, separated by '/'
The location for a browser's bookmark has to look like this:
- javascript:location.href='org-protocol://remember://'+ \\
+ javascript:location.href='org-protocol://capture://'+ \\
encodeURIComponent(location.href)+'/' \\
encodeURIComponent(document.title)+'/'+ \\
encodeURIComponent(window.getSelection())
By default, it uses the character `org-protocol-default-template-key',
-which should be associated with a template in `org-remember-templates'.
+which should be associated with a template in `org-capture-templates'.
But you may prepend the encoded URL with a character and a slash like so:
- javascript:location.href='org-protocol://org-store-link://b/'+ ...
+ javascript:location.href='org-protocol://capture://b/'+ ...
Now template ?b will be used."
-
(if (and (boundp 'org-stored-links)
- (fboundp 'org-remember))
- (let* ((parts (org-protocol-split-data info t))
- (template (or (and (= 1 (length (car parts))) (pop parts))
- org-protocol-default-template-key))
- (url (org-protocol-sanitize-uri (car parts)))
- (type (if (string-match "^\\([a-z]+\\):" url)
- (match-string 1 url)))
- (title (cadr parts))
- (region (caddr parts))
- (orglink (org-make-link-string url title))
- remember-annotation-functions)
- (setq org-stored-links
- (cons (list url title) org-stored-links))
- (kill-new orglink)
- (org-store-link-props :type type
- :link url
- :description title
- :initial region)
- (raise-frame)
- (org-remember nil (string-to-char template)))
-
- (message "Org-mode not loaded."))
+ (or (fboundp 'org-capture))
+ (org-protocol-do-capture info 'org-capture))
+ (message "Org-mode not loaded."))
nil)
+(defun org-protocol-do-capture (info capture-func)
+ "Support `org-capture' and `org-remember' alike.
+CAPTURE-FUNC is either the symbol `org-remember' or `org-capture'."
+ (let* ((parts (org-protocol-split-data info t))
+ (template (or (and (= 1 (length (car parts))) (pop parts))
+ org-protocol-default-template-key))
+ (url (org-protocol-sanitize-uri (car parts)))
+ (type (if (string-match "^\\([a-z]+\\):" url)
+ (match-string 1 url)))
+ (title(or (cadr parts) ""))
+ (region (or (caddr parts) ""))
+ (orglink (org-make-link-string
+ url (if (string-match "[^[:space:]]" title) title url)))
+ (org-capture-link-is-already-stored t) ;; avoid call to org-store-link
+ remember-annotation-functions)
+ (setq org-stored-links
+ (cons (list url title) org-stored-links))
+ (kill-new orglink)
+ (org-store-link-props :type type
+ :link url
+ :description title
+ :annotation orglink
+ :initial region)
+ (raise-frame)
+ (funcall capture-func nil template)))
+
+
(defun org-protocol-open-source (fname)
"Process an org-protocol://open-source:// style url.
@@ -560,7 +590,7 @@ This is, how the matching is done:
protocol and sub-protocol are regexp-quoted.
-If a matching protcol is found, the protcol is stripped from fname and the
+If a matching protocol is found, the protocol is stripped from fname and the
result is passed to the protocols function as the only parameter. If the
function returns nil, the filename is removed from the list of filenames
passed from emacsclient to the server.
@@ -613,11 +643,10 @@ as filename."
(defun org-protocol-create-for-org ()
"Create a org-protocol project for the current file's Org-mode project.
This works, if the file visited is part of a publishing project in
-`org-publish-project-alist'. This functions calls `org-protocol-create' to do
+`org-publish-project-alist'. This function calls `org-protocol-create' to do
most of the work."
(interactive)
(require 'org-publish)
- (org-publish-initialize-files-alist)
(let ((all (or (org-publish-get-project-from-filename buffer-file-name))))
(if all (org-protocol-create (cdr all))
(message "Not in an org-project. Did mean %s?"
diff --git a/lisp/org/org-publish.el b/lisp/org/org-publish.el
index b13fda9d27b..51db9f652d1 100644
--- a/lisp/org/org-publish.el
+++ b/lisp/org/org-publish.el
@@ -1,10 +1,11 @@
;;; org-publish.el --- publish related org-mode files as a website
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: David O'Toole <dto@gnu.org>
;; Maintainer: Carsten Dominik <carsten DOT dominik AT gmail DOT com>
;; Keywords: hypermedia, outlines, wp
-;; Version: 6.33x
+;; Version: 7.3
;; This file is part of GNU Emacs.
;;
@@ -31,7 +32,7 @@
;; + Publish all one's org-files to HTML or PDF
;; + Upload HTML, images, attachments and other files to a web server
;; + Exclude selected private pages from publishing
-;; + Publish a clickable index of pages
+;; + Publish a clickable sitemap of pages
;; + Manage local timestamps for publishing only changed files
;; + Accept plugin functions to extend range of publishable content
;;
@@ -39,6 +40,17 @@
;;; Code:
+
+(defun org-publish-sanitize-plist (plist)
+ (mapcar (lambda (x)
+ (or (cdr (assq x '((:index-filename . :sitemap-filename)
+ (:index-title . :sitemap-title)
+ (:index-function . :sitemap-function)
+ (:index-style . :sitemap-style)
+ (:auto-index . :auto-sitemap))))
+ x))
+ plist))
+
(eval-when-compile
(require 'cl))
(require 'org)
@@ -59,11 +71,14 @@ Each element of the alist is a publishing 'project.' The CAR of
each element is a string, uniquely identifying the project. The
CDR of each element is in one of the following forms:
- (:property value :property value ... )
+1. A well-formed property list with an even number of elements, alternating
+ keys and values, specifying parameters for the publishing process.
-OR,
+ (:property value :property value ... )
- (:components (\"project-1\" \"project-2\" ...))
+2. A meta-project definition, specifying of a list of sub-projects:
+
+ (:components (\"project-1\" \"project-2\" ...))
When the CDR of an element of org-publish-project-alist is in
this second form, the elements of the list after :components are
@@ -80,7 +95,8 @@ Most properties are optional, but some should always be set:
:base-directory Directory containing publishing source files
:base-extension Extension (without the dot!) of source files.
- This can be a regular expression.
+ This can be a regular expression. If not given,
+ \"org\" will be used as default extension.
:publishing-directory Directory (possibly remote) where output
files will be published
@@ -112,9 +128,11 @@ project for publishing. For example, you could call GNU Make on a
certain makefile, to ensure published files are built up to date.
:preparation-function Function to be called before publishing
- this project.
+ this project. This may also be a list
+ of functions.
:completion-function Function to be called after publishing
- this project.
+ this project. This may also be a list
+ of functions.
Some properties control details of the Org publishing process,
and are equivalent to the corresponding user variables listed in
@@ -144,28 +162,49 @@ learn more about their use and default values.
:author `user-full-name'
:email `user-mail-address'
-The following properties may be used to control publishing of an
-index of files or summary page for a given project.
+The following properties may be used to control publishing of a
+sitemap of files or summary page for a given project.
- :auto-index Whether to publish an index during
+ :auto-sitemap Whether to publish a sitemap during
`org-publish-current-project' or `org-publish-all'.
- :index-filename Filename for output of index. Defaults
+ :sitemap-filename Filename for output of sitemap. Defaults
to 'sitemap.org' (which becomes 'sitemap.html').
- :index-title Title of index page. Defaults to name of file.
- :index-function Plugin function to use for generation of index.
- Defaults to `org-publish-org-index', which
+ :sitemap-title Title of sitemap page. Defaults to name of file.
+ :sitemap-function Plugin function to use for generation of sitemap.
+ Defaults to `org-publish-org-sitemap', which
generates a plain list of links to all files
in the project.
- :index-style Can be `list' (index is just an itemized list
+ :sitemap-style Can be `list' (sitemap is just an itemized list
of the titles of the files involved) or
`tree' (the directory structure of the source
- files is reflected in the index). Defaults to
- `tree'."
+ files is reflected in the sitemap). Defaults to
+ `tree'.
+
+ If you create a sitemap file, adjust the sorting like this:
+
+ :sitemap-sort-folders Where folders should appear in the sitemap.
+ Set this to `first' (default) or `last' to
+ display folders first or last, respectively.
+ Any other value will mix files and folders.
+ :sitemap-alphabetically The site map is normally sorted alphabetically.
+ Set this explicitly to nil to turn off sorting.
+ :sitemap-ignore-case Should sorting be case-sensitive? Default nil.
+
+The following properties control the creation of a concept index.
+
+ :makeindex Create a concept index.
+
+Other properties affecting publication.
+
+ :body-only Set this to 't' to publish only the body of the
+ documents, excluding everything outside and
+ including the <body> tags in HTML, or
+ \begin{document}..\end{document} in LaTeX."
:group 'org-publish
:type 'alist)
(defcustom org-publish-use-timestamps-flag t
- "When non-nil, use timestamp checking to publish only changed files.
+ "Non-nil means use timestamp checking to publish only changed files.
When nil, do no timestamp checking and always publish all files."
:group 'org-publish
:type 'boolean)
@@ -177,7 +216,7 @@ When nil, do no timestamp checking and always publish all files."
:type 'directory)
(defcustom org-publish-list-skipped-files t
- "Non-nil means, show message about files *not* published."
+ "Non-nil means show message about files *not* published."
:group 'org-publish
:type 'boolean)
@@ -194,6 +233,34 @@ Any changes made by this hook will be saved."
:group 'org-publish
:type 'hook)
+(defcustom org-publish-sitemap-sort-alphabetically t
+ "Should sitemaps be sorted alphabetically by default?
+
+You can overwrite this default per project in your
+`org-publish-project-alist', using `:sitemap-alphabetically'."
+ :group 'org-publish
+ :type 'boolean)
+
+(defcustom org-publish-sitemap-sort-folders 'first
+ "A symbol, denoting if folders are sorted first in sitemaps.
+Possible values are `first', `last', and nil.
+If `first', folders will be sorted before files.
+If `last', folders are sorted to the end after the files.
+Any other value will not mix files and folders.
+
+You can overwrite this default per project in your
+`org-publish-project-alist', using `:sitemap-sort-folders'."
+ :group 'org-publish
+ :type 'symbol)
+
+(defcustom org-publish-sitemap-sort-ignore-case nil
+ "Sort sitemaps case insensitively by default?
+
+You can overwrite this default per project in your
+`org-publish-project-alist', using `:sitemap-ignore-case'."
+ :group 'org-publish
+ :type 'boolean)
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Timestamp-related functions
@@ -201,29 +268,19 @@ Any changes made by this hook will be saved."
"Return path to timestamp file for filename FILENAME."
(setq filename (concat filename "::" (or pub-dir "") "::"
(format "%s" (or pub-func ""))))
- (concat (file-name-as-directory org-publish-timestamp-directory)
- "X" (if (fboundp 'sha1) (sha1 filename) (md5 filename))))
+ (concat "X" (if (fboundp 'sha1) (sha1 filename) (md5 filename))))
(defun org-publish-needed-p (filename &optional pub-dir pub-func true-pub-dir)
- "Return `t' if FILENAME should be published in PUB-DIR using PUB-FUNC.
-TRUE-PUB-DIR is there the file will truely end up. Currently we are not using
+ "Return t if FILENAME should be published in PUB-DIR using PUB-FUNC.
+TRUE-PUB-DIR is where the file will truly end up. Currently we are not using
this - maybe it can eventually be used to check if the file is present at
the target location, and how old it is. Right ow we cannot do this, because
we do not know under what file name the file will be stored - the publishing
function can still decide about that independently."
(let ((rtn
(if org-publish-use-timestamps-flag
- (if (file-exists-p org-publish-timestamp-directory)
- ;; first handle possible wrong timestamp directory
- (if (not (file-directory-p org-publish-timestamp-directory))
- (error "Org publish timestamp: %s is not a directory"
- org-publish-timestamp-directory)
- ;; there is a timestamp, check if FILENAME is newer
- (file-newer-than-file-p
- filename (org-publish-timestamp-filename
- filename pub-dir pub-func)))
- (make-directory org-publish-timestamp-directory)
- t)
+ (org-publish-cache-file-needs-publishing
+ filename pub-dir pub-func)
;; don't use timestamps, always return t
t)))
(if rtn
@@ -235,55 +292,33 @@ function can still decide about that independently."
(defun org-publish-update-timestamp (filename &optional pub-dir pub-func)
"Update publishing timestamp for file FILENAME.
If there is no timestamp, create one."
- (let ((timestamp-file (org-publish-timestamp-filename
- filename pub-dir pub-func))
- newly-created-timestamp)
- (if (not (file-exists-p timestamp-file))
- ;; create timestamp file if needed
- (with-temp-buffer
- (make-directory (file-name-directory timestamp-file) t)
- (write-file timestamp-file)
- (setq newly-created-timestamp t)))
- ;; Emacs 21 doesn't have `set-file-times'
- (if (and (fboundp 'set-file-times)
- (not newly-created-timestamp))
- (set-file-times timestamp-file)
- (call-process "touch" nil 0 nil (expand-file-name timestamp-file)))))
+ (let ((key (org-publish-timestamp-filename filename pub-dir pub-func))
+ (stamp (org-publish-cache-ctime-of-src filename)))
+ (org-publish-cache-set key stamp)))
(defun org-publish-remove-all-timestamps ()
- "Remove all files in the timstamp directory."
+ "Remove all files in the timestamp directory."
(let ((dir org-publish-timestamp-directory)
files)
(when (and (file-exists-p dir)
(file-directory-p dir))
- (mapc 'delete-file (directory-files dir 'full "[^.]\\'")))))
+ (mapc 'delete-file (directory-files dir 'full "[^.]\\'"))
+ (org-publish-reset-cache))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Mapping files to project names
-
-(defvar org-publish-files-alist nil
- "Alist of files and their parent projects.
-Each element of this alist is of the form:
-
- (file-name . project-name)")
+;;;
(defvar org-publish-initial-buffer nil
"The buffer `org-publish' has been called from.")
(defvar org-publish-temp-files nil
"Temporary list of files to be published.")
-(defun org-publish-initialize-files-alist (&optional refresh)
- "Set `org-publish-files-alist' if it is not set.
-Also set it if the optional argument REFRESH is non-nil."
- (interactive "P")
- (when (or refresh (not org-publish-files-alist))
- (setq org-publish-files-alist
- (org-publish-get-files org-publish-project-alist))))
+;; Here, so you find the variable right before it's used the first time:
+(defvar org-publish-cache nil
+ "This will cache timestamps and titles for files in publishing projects.
+Blocks could hash sha1 values here.")
-(defun org-publish-validate-link (link &optional directory)
- "Check if LINK points to a file in the current project."
- (assoc (expand-file-name link directory) org-publish-files-alist))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compatibility aliases
@@ -306,27 +341,11 @@ This is a compatibility function for Emacsen without `delete-dups'."
list))
(declare-function org-publish-delete-dups "org-publish" (list))
+(declare-function find-lisp-find-files "find-lisp" (directory regexp))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Getting project information out of org-publish-project-alist
-(defun org-publish-get-files (projects-alist &optional no-exclusion)
- "Return the list of all publishable files for PROJECTS-ALIST.
-If NO-EXCLUSION is non-nil, don't exclude files."
- (let (all-files)
- ;; add all projects
- (mapc
- (lambda(p)
- (let* ((exclude (plist-get (cdr p) :exclude))
- (files (and p (org-publish-get-base-files p exclude))))
- ;; add all files from this project
- (mapc (lambda(f)
- (add-to-list 'all-files
- (cons (expand-file-name f) (car p))))
- files)))
- (org-publish-expand-projects projects-alist))
- all-files))
-
(defun org-publish-expand-projects (projects-alist)
"Expand projects in PROJECTS-ALIST.
This splices all the components into the list."
@@ -340,6 +359,42 @@ This splices all the components into the list."
(push p rtn)))
(nreverse (org-publish-delete-dups (delq nil rtn)))))
+
+(defvar sitemap-alphabetically)
+(defvar sitemap-sort-folders)
+(defvar sitemap-ignore-case)
+(defvar sitemap-requested)
+(defun org-publish-compare-directory-files (a b)
+ "Predicate for `sort', that sorts folders-first/last and alphabetically."
+ (let ((retval t))
+ (when (or sitemap-alphabetically sitemap-sort-folders)
+ ;; First we sort alphabetically:
+ (when sitemap-alphabetically
+ (let* ((adir (file-directory-p a))
+ (aorg (and (string-match "\\.org$" a) (not adir)))
+ (bdir (file-directory-p b))
+ (borg (and (string-match "\\.org$" b) (not bdir)))
+ (A (if aorg
+ (concat (file-name-directory a)
+ (org-publish-find-title a)) a))
+ (B (if borg
+ (concat (file-name-directory b)
+ (org-publish-find-title b)) b)))
+ (setq retval (if sitemap-ignore-case
+ (not (string-lessp (upcase B) (upcase A)))
+ (not (string-lessp B A))))))
+
+ ;; Directory-wise wins:
+ (when sitemap-sort-folders
+ ;; a is directory, b not:
+ (cond
+ ((and (file-directory-p a) (not (file-directory-p b)))
+ (setq retval (equal sitemap-sort-folders 'first)))
+ ;; a is not a directory, but b is:
+ ((and (not (file-directory-p a)) (file-directory-p b))
+ (setq retval (equal sitemap-sort-folders 'last))))))
+ retval))
+
(defun org-publish-get-base-files-1 (base-dir &optional recurse match skip-file skip-dir)
"Set `org-publish-temp-files' with files from BASE-DIR directory.
If RECURSE is non-nil, check BASE-DIR recursively. If MATCH is
@@ -358,8 +413,12 @@ matching the regexp SKIP-DIR when recursing through BASE-DIR."
(and skip-file (string-match skip-file fnd))
(not (file-exists-p (file-truename f)))
(not (string-match match fnd)))
+
(pushnew f org-publish-temp-files)))))
- (directory-files base-dir t (unless recurse match))))
+ (if sitemap-requested
+ (sort (directory-files base-dir t (unless recurse match))
+ 'org-publish-compare-directory-files)
+ (directory-files base-dir t (unless recurse match)))))
(defun org-publish-get-base-files (project &optional exclude-regexp)
"Return a list of all files in PROJECT.
@@ -371,9 +430,29 @@ matching filenames."
(include-list (plist-get project-plist :include))
(recurse (plist-get project-plist :recursive))
(extension (or (plist-get project-plist :base-extension) "org"))
+ ;; sitemap-... variables are dynamically scoped for
+ ;; org-publish-compare-directory-files:
+ (sitemap-requested
+ (plist-get project-plist :auto-sitemap))
+ (sitemap-sort-folders
+ (if (plist-member project-plist :sitemap-sort-folders)
+ (plist-get project-plist :sitemap-sort-folders)
+ org-publish-sitemap-sort-folders))
+ (sitemap-alphabetically
+ (if (plist-member project-plist :sitemap-alphabetically)
+ (plist-get project-plist :sitemap-alphabetically)
+ org-publish-sitemap-sort-alphabetically))
+ (sitemap-ignore-case
+ (if (plist-member project-plist :sitemap-ignore-case)
+ (plist-get project-plist :sitemap-ignore-case)
+ org-publish-sitemap-sort-ignore-case))
(match (if (eq extension 'any)
"^[^\\.]"
(concat "^[^\\.].*\\.\\(" extension "\\)$"))))
+ ;; Make sure sitemap-sort-folders' has an accepted value
+ (unless (memq sitemap-sort-folders '(first last))
+ (setq sitemap-sort-folders nil))
+
(setq org-publish-temp-files nil)
(org-publish-get-base-files-1 base-dir recurse match
;; FIXME distinguish exclude regexp
@@ -387,9 +466,33 @@ matching filenames."
org-publish-temp-files))
(defun org-publish-get-project-from-filename (filename &optional up)
- "Return the project FILENAME belongs."
- (let* ((project-name (cdr (assoc (expand-file-name filename)
- org-publish-files-alist))))
+ "Return the project that FILENAME belongs to."
+ (let* ((filename (expand-file-name filename))
+ project-name)
+
+ (catch 'p-found
+ (dolist (prj org-publish-project-alist)
+ (unless (plist-get (cdr prj) :components)
+ ;; [[info:org:Selecting%20files]] shows how this is supposed to work:
+ (let* ((r (plist-get (cdr prj) :recursive))
+ (b (expand-file-name (file-name-as-directory
+ (plist-get (cdr prj) :base-directory))))
+ (x (or (plist-get (cdr prj) :base-extension) "org"))
+ (e (plist-get (cdr prj) :exclude))
+ (i (plist-get (cdr prj) :include))
+ (xm (concat "^" b (if r ".+" "[^/]+") "\\.\\(" x "\\)$")))
+ (when (or
+ (and
+ i
+ (member filename
+ (mapcar
+ (lambda (file) (expand-file-name file b))
+ i)))
+ (and
+ (not (and e (string-match e filename)))
+ (string-match xm filename)))
+ (setq project-name (car prj))
+ (throw 'p-found project-name))))))
(when up
(dolist (prj org-publish-project-alist)
(if (member project-name (plist-get (cdr prj) :components))
@@ -421,13 +524,15 @@ PUB-DIR is the publishing directory."
(setq export-buf-or-file
(funcall (intern (concat "org-export-as-" format))
(plist-get plist :headline-levels)
- nil plist nil nil pub-dir))
+ nil plist nil
+ (plist-get plist :body-only)
+ pub-dir))
(when (and (bufferp export-buf-or-file)
(buffer-live-p export-buf-or-file))
(set-buffer export-buf-or-file)
;; run hooks after export and save export
- (and (run-hooks 'org-publish-after-export-hook)
- (if (buffer-modified-p) (save-buffer)))
+ (progn (run-hooks 'org-publish-after-export-hook)
+ (if (buffer-modified-p) (save-buffer)))
(kill-buffer export-buf-or-file))
;; maybe restore buffer's content
(set-buffer init-buf)
@@ -439,34 +544,65 @@ PUB-DIR is the publishing directory."
(unless visiting
(kill-buffer init-buf))))))
+(defmacro org-publish-with-aux-preprocess-maybe (&rest body)
+ "Execute BODY with a modified hook to preprocess for index."
+ `(let ((org-export-preprocess-after-headline-targets-hook
+ (if (plist-get project-plist :makeindex)
+ (cons 'org-publish-aux-preprocess
+ org-export-preprocess-after-headline-targets-hook)
+ org-export-preprocess-after-headline-targets-hook)))
+ ,@body))
+
+(defvar project-plist)
(defun org-publish-org-to-latex (plist filename pub-dir)
"Publish an org file to LaTeX.
See `org-publish-org-to' to the list of arguments."
- (org-publish-org-to "latex" plist filename pub-dir))
+ (org-publish-with-aux-preprocess-maybe
+ (org-publish-org-to "latex" plist filename pub-dir)))
(defun org-publish-org-to-pdf (plist filename pub-dir)
"Publish an org file to PDF (via LaTeX).
See `org-publish-org-to' to the list of arguments."
- (org-publish-org-to "pdf" plist filename pub-dir))
+ (org-publish-with-aux-preprocess-maybe
+ (org-publish-org-to "pdf" plist filename pub-dir)))
(defun org-publish-org-to-html (plist filename pub-dir)
"Publish an org file to HTML.
See `org-publish-org-to' to the list of arguments."
- (org-publish-org-to "html" plist filename pub-dir))
+ (org-publish-with-aux-preprocess-maybe
+ (org-publish-org-to "html" plist filename pub-dir)))
(defun org-publish-org-to-org (plist filename pub-dir)
"Publish an org file to HTML.
See `org-publish-org-to' to the list of arguments."
(org-publish-org-to "org" plist filename pub-dir))
+(defun org-publish-org-to-ascii (plist filename pub-dir)
+ "Publish an org file to ASCII.
+See `org-publish-org-to' to the list of arguments."
+ (org-publish-with-aux-preprocess-maybe
+ (org-publish-org-to "ascii" plist filename pub-dir)))
+
+(defun org-publish-org-to-latin1 (plist filename pub-dir)
+ "Publish an org file to Latin-1.
+See `org-publish-org-to' to the list of arguments."
+ (org-publish-with-aux-preprocess-maybe
+ (org-publish-org-to "latin1" plist filename pub-dir)))
+
+(defun org-publish-org-to-utf8 (plist filename pub-dir)
+ "Publish an org file to UTF-8.
+See `org-publish-org-to' to the list of arguments."
+ (org-publish-with-aux-preprocess-maybe
+ (org-publish-org-to "utf8" plist filename pub-dir)))
+
(defun org-publish-attachment (plist filename pub-dir)
"Publish a file with no transformation of any kind.
See `org-publish-org-to' to the list of arguments."
;; make sure eshell/cp code is loaded
- (unless (file-directory-p pub-dir)
- (make-directory pub-dir t))
- (or (equal (expand-file-name (file-name-directory filename))
- (file-name-as-directory (expand-file-name pub-dir)))
+ (unless (file-directory-p pub-dir)
+ (make-directory pub-dir t))
+ (or (equal (expand-file-name (file-name-directory filename))
+ (file-name-as-directory (expand-file-name pub-dir)))
(copy-file filename
(expand-file-name (file-name-nondirectory filename) pub-dir)
t)))
@@ -474,30 +610,39 @@ See `org-publish-org-to' to the list of arguments."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Publishing files, sets of files, and indices
-(defun org-publish-file (filename &optional project)
- "Publish file FILENAME from PROJECT."
+(defun org-publish-file (filename &optional project no-cache)
+ "Publish file FILENAME from PROJECT.
+If NO-CACHE is not nil, do not initialize org-publish-cache and
+write it to disk. This is needed, since this function is used to
+publish single files, when entire projects are published.
+See `org-publish-projects'."
(let* ((project
(or project
(or (org-publish-get-project-from-filename filename)
- (if (y-or-n-p
- (format "%s is not in a project. Re-read the list of projects files? "
- (abbreviate-file-name filename)))
- ;; If requested, re-initialize the list of projects files
- (progn (org-publish-initialize-files-alist t)
- (or (org-publish-get-project-from-filename filename)
- (error "File %s not part of any known project"
- (abbreviate-file-name filename))))
- (error "Can't publish file outside of a project")))))
+ (error "File %s not part of any known project"
+ (abbreviate-file-name filename)))))
(project-plist (cdr project))
- (ftname (file-truename filename))
+ (ftname (expand-file-name filename))
(publishing-function
(or (plist-get project-plist :publishing-function)
'org-publish-org-to-html))
- (base-dir (file-name-as-directory
- (file-truename (plist-get project-plist :base-directory))))
- (pub-dir (file-name-as-directory
- (file-truename (plist-get project-plist :publishing-directory))))
+ (base-dir
+ (file-name-as-directory
+ (expand-file-name
+ (or (plist-get project-plist :base-directory)
+ (error "Project %s does not have :base-directory defined"
+ (car project))))))
+ (pub-dir
+ (file-name-as-directory
+ (file-truename
+ (or (plist-get project-plist :publishing-directory)
+ (error "Project %s does not have :publishing-directory defined"
+ (car project))))))
tmp-pub-dir)
+
+ (unless no-cache
+ (org-publish-initialize-cache (car project)))
+
(setq tmp-pub-dir
(file-name-directory
(concat pub-dir
@@ -514,35 +659,47 @@ See `org-publish-org-to' to the list of arguments."
tmp-pub-dir)
(funcall publishing-function project-plist filename tmp-pub-dir)
(org-publish-update-timestamp
- filename pub-dir publishing-function)))))
+ filename pub-dir publishing-function)))
+ (unless no-cache (org-publish-write-cache-file))))
(defun org-publish-projects (projects)
"Publish all files belonging to the PROJECTS alist.
-If :auto-index is set, publish the index too."
+If :auto-sitemap is set, publish the sitemap too.
+If :makeindex is set, also produce a file theindex.org."
(mapc
(lambda (project)
+ ;; Each project uses it's own cache file:
+ (org-publish-initialize-cache (car project))
(let*
((project-plist (cdr project))
(exclude-regexp (plist-get project-plist :exclude))
- (index-p (plist-get project-plist :auto-index))
- (index-filename (or (plist-get project-plist :index-filename)
- "sitemap.org"))
- (index-function (or (plist-get project-plist :index-function)
- 'org-publish-org-index))
+ (sitemap-p (plist-get project-plist :auto-sitemap))
+ (sitemap-filename (or (plist-get project-plist :sitemap-filename)
+ "sitemap.org"))
+ (sitemap-function (or (plist-get project-plist :sitemap-function)
+ 'org-publish-org-sitemap))
(preparation-function (plist-get project-plist :preparation-function))
(completion-function (plist-get project-plist :completion-function))
(files (org-publish-get-base-files project exclude-regexp)) file)
- (when preparation-function (funcall preparation-function))
- (if index-p (funcall index-function project index-filename))
+ (when preparation-function (run-hooks 'preparation-function))
+ (if sitemap-p (funcall sitemap-function project sitemap-filename))
(while (setq file (pop files))
- (org-publish-file file project))
- (when completion-function (funcall completion-function))))
+ (org-publish-file file project t))
+ (when (plist-get project-plist :makeindex)
+ (org-publish-index-generate-theindex.inc
+ (plist-get project-plist :base-directory))
+ (org-publish-file (expand-file-name
+ "theindex.org"
+ (plist-get project-plist :base-directory))
+ project t))
+ (when completion-function (run-hooks 'completion-function))
+ (org-publish-write-cache-file)))
(org-publish-expand-projects projects)))
-(defun org-publish-org-index (project &optional index-filename)
- "Create an index of pages in set defined by PROJECT.
-Optionally set the filename of the index with INDEX-FILENAME.
-Default for INDEX-FILENAME is 'sitemap.org'."
+(defun org-publish-org-sitemap (project &optional sitemap-filename)
+ "Create a sitemap of pages in set defined by PROJECT.
+Optionally set the filename of the sitemap with SITEMAP-FILENAME.
+Default for SITEMAP-FILENAME is 'sitemap.org'."
(let* ((project-plist (cdr project))
(dir (file-name-as-directory
(plist-get project-plist :base-directory)))
@@ -550,28 +707,28 @@ Default for INDEX-FILENAME is 'sitemap.org'."
(indent-str (make-string 2 ?\ ))
(exclude-regexp (plist-get project-plist :exclude))
(files (nreverse (org-publish-get-base-files project exclude-regexp)))
- (index-filename (concat dir (or index-filename "sitemap.org")))
- (index-title (or (plist-get project-plist :index-title)
- (concat "Index for project " (car project))))
- (index-style (or (plist-get project-plist :index-style)
+ (sitemap-filename (concat dir (or sitemap-filename "sitemap.org")))
+ (sitemap-title (or (plist-get project-plist :sitemap-title)
+ (concat "Sitemap for project " (car project))))
+ (sitemap-style (or (plist-get project-plist :sitemap-style)
'tree))
- (visiting (find-buffer-visiting index-filename))
- (ifn (file-name-nondirectory index-filename))
- file index-buffer)
- (with-current-buffer (setq index-buffer
- (or visiting (find-file index-filename)))
+ (visiting (find-buffer-visiting sitemap-filename))
+ (ifn (file-name-nondirectory sitemap-filename))
+ file sitemap-buffer)
+ (with-current-buffer (setq sitemap-buffer
+ (or visiting (find-file sitemap-filename)))
(erase-buffer)
- (insert (concat "#+TITLE: " index-title "\n\n"))
+ (insert (concat "#+TITLE: " sitemap-title "\n\n"))
(while (setq file (pop files))
(let ((fn (file-name-nondirectory file))
(link (file-relative-name file dir))
(oldlocal localdir))
- ;; index shouldn't index itself
- (unless (equal (file-truename index-filename)
+ ;; sitemap shouldn't list itself
+ (unless (equal (file-truename sitemap-filename)
(file-truename file))
- (if (eq index-style 'list)
- (message "Generating list-style index for %s" index-title)
- (message "Generating tree-style index for %s" index-title)
+ (if (eq sitemap-style 'list)
+ (message "Generating list-style sitemap for %s" sitemap-title)
+ (message "Generating tree-style sitemap for %s" sitemap-title)
(setq localdir (concat (file-name-as-directory dir)
(file-name-directory link)))
(unless (string= localdir oldlocal)
@@ -600,11 +757,13 @@ Default for INDEX-FILENAME is 'sitemap.org'."
(org-publish-find-title file)
"]]\n")))))
(save-buffer))
- (or visiting (kill-buffer index-buffer))))
+ (or visiting (kill-buffer sitemap-buffer))))
(defun org-publish-find-title (file)
- "Find the title of file in project."
- (let* ((visiting (find-buffer-visiting file))
+ "Find the title of FILE in project."
+ (or
+ (org-publish-cache-get-file-property file :title nil t)
+ (let* ((visiting (find-buffer-visiting file))
(buffer (or visiting (find-file-noselect file)))
title)
(with-current-buffer buffer
@@ -618,7 +777,8 @@ Default for INDEX-FILENAME is 'sitemap.org'."
(file-name-nondirectory (file-name-sans-extension file))))))
(unless visiting
(kill-buffer buffer))
- title))
+ (org-publish-cache-set-file-property file :title title)
+ title)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Interactive publishing functions
@@ -640,7 +800,12 @@ Default for INDEX-FILENAME is 'sitemap.org'."
(save-window-excursion
(let* ((org-publish-use-timestamps-flag
(if force nil org-publish-use-timestamps-flag)))
- (org-publish-projects (list project)))))
+ (org-publish-projects
+ (if (stringp project)
+ ;; If this function is called in batch mode,
+ ;; project is still a string here.
+ (list (assoc project org-publish-project-alist))
+ (list project))))))
;;;###autoload
(defun org-publish-all (&optional force)
@@ -650,18 +815,17 @@ directory and force publishing all files."
(interactive "P")
(when force
(org-publish-remove-all-timestamps))
- (org-publish-initialize-files-alist)
(save-window-excursion
(let ((org-publish-use-timestamps-flag
(if force nil org-publish-use-timestamps-flag)))
(org-publish-projects org-publish-project-alist))))
+
;;;###autoload
(defun org-publish-current-file (&optional force)
"Publish the current file.
With prefix argument, force publish the file."
(interactive "P")
- (org-publish-initialize-files-alist)
(save-window-excursion
(let ((org-publish-use-timestamps-flag
(if force nil org-publish-use-timestamps-flag)))
@@ -673,17 +837,245 @@ With prefix argument, force publish the file."
With a prefix argument, force publishing of all files in
the project."
(interactive "P")
- (org-publish-initialize-files-alist)
(save-window-excursion
(let ((project (org-publish-get-project-from-filename (buffer-file-name) 'up))
(org-publish-use-timestamps-flag
(if force nil org-publish-use-timestamps-flag)))
(if (not project)
(error "File %s is not part of any known project" (buffer-file-name)))
+ ;; FIXME: force is not used here?
(org-publish project))))
-(provide 'org-publish)
+;;; Index generation
+
+(defvar backend) ; dynamically scoped
+(defun org-publish-aux-preprocess ()
+ "Find index entries and write them to an .orgx file."
+ (let ((case-fold-search t)
+ entry index target)
+ (goto-char (point-min))
+ (while
+ (and
+ (re-search-forward "^[ \t]*#\\+index:[ \t]*\\(.*?\\)[ \t]*$" nil t)
+ (> (match-end 1) (match-beginning 1)))
+ (setq entry (match-string 1))
+ (when (eq backend 'latex)
+ (replace-match (format "\\index{%s}" entry) t t))
+ (save-excursion
+ (ignore-errors (org-back-to-heading t))
+ (setq target (get-text-property (point) 'target))
+ (setq target (or (cdr (assoc target org-export-preferred-target-alist))
+ (cdr (assoc target org-export-id-target-alist))
+ target ""))
+ (push (cons entry target) index)))
+ (with-temp-file
+ (concat (file-name-sans-extension org-current-export-file) ".orgx")
+ (dolist (entry (nreverse index))
+ (insert (format "INDEX: (%s) %s\n" (cdr entry) (car entry)))))))
+
+(defun org-publish-index-generate-theindex.inc (directory)
+ "Generate the index from all .orgx files in the current directory and below."
+ (require 'find-lisp)
+ (let* ((fulldir (file-name-as-directory
+ (expand-file-name directory)))
+ (full-files (find-lisp-find-files directory "\\.orgx\\'"))
+ (re (concat "\\`" fulldir))
+ (files (mapcar (lambda (f) (if (string-match re f)
+ (substring f (match-end 0))
+ f))
+ full-files))
+ (default-directory directory)
+ index origfile buf target entry ibuffer
+ main last-main letter last-letter file sub link tgext)
+ ;; `files' contains the list of relative file names
+ (dolist (file files)
+ (setq origfile (substring file 0 -1))
+ (setq buf (find-file-noselect file))
+ (with-current-buffer buf
+ (goto-char (point-min))
+ (while (re-search-forward "^INDEX: (\\(.*?\\)) \\(.*\\)" nil t)
+ (setq target (match-string 1)
+ entry (match-string 2))
+ (push (list entry origfile target) index)))
+ (kill-buffer buf))
+ (setq index (sort index (lambda (a b) (string< (downcase (car a))
+ (downcase (car b))))))
+ (setq ibuffer (find-file-noselect (expand-file-name "theindex.inc" directory)))
+ (with-current-buffer ibuffer
+ (erase-buffer)
+ (insert "* Index\n")
+ (setq last-letter nil)
+ (dolist (idx index)
+ (setq entry (car idx) file (nth 1 idx) target (nth 2 idx))
+ (if (and (stringp target) (string-match "\\S-" target))
+ (setq tgext (concat "::#" target))
+ (setq tgext ""))
+ (setq letter (upcase (substring entry 0 1)))
+ (when (not (equal letter last-letter))
+ (insert "** " letter "\n")
+ (setq last-letter letter))
+ (if (string-match "!" entry)
+ (setq main (substring entry 0 (match-beginning 0))
+ sub (substring entry (match-end 0)))
+ (setq main nil sub nil last-main nil))
+ (when (and main (not (equal main last-main)))
+ (insert " - " main "\n")
+ (setq last-main main))
+ (setq link (concat "[[file:" file tgext "]"
+ "[" (or sub entry) "]]"))
+ (if (and main sub)
+ (insert " - " link "\n")
+ (insert " - " link "\n")))
+ (save-buffer))
+ (kill-buffer ibuffer)
+
+ (let ((index-file (expand-file-name "theindex.org" directory)))
+ (unless (file-exists-p index-file)
+ (setq ibuffer (find-file-noselect index-file))
+ (with-current-buffer ibuffer
+ (erase-buffer)
+ (insert "\n\n#+include: \"theindex.inc\"\n\n")
+ (save-buffer))
+ (kill-buffer ibuffer)))))
+
+
+;; Caching functions:
+
+(defun org-publish-write-cache-file (&optional free-cache)
+ "Write `org-publish-cache' to file.
+If FREE-CACHE, empty the cache."
+ (unless org-publish-cache
+ (error "%s" "`org-publish-write-cache-file' called, but no cache present"))
+
+ (let ((cache-file (org-publish-cache-get ":cache-file:")))
+ (unless cache-file
+ (error
+ "%s" "Cannot find cache-file name in `org-publish-write-cache-file'"))
+ (with-temp-file cache-file
+ (let ((print-level nil)
+ (print-length nil))
+ (insert "(setq org-publish-cache (make-hash-table :test 'equal :weakness nil :size 100))\n")
+ (maphash (lambda (k v)
+ (insert
+ (format (concat "(puthash %S "
+ (if (or (listp v) (symbolp v))
+ "'" "")
+ "%S org-publish-cache)\n") k v)))
+ org-publish-cache)))
+ (when free-cache (org-publish-reset-cache))))
+
+(defun org-publish-initialize-cache (project-name)
+ "Initialize the projects cache if not initialized yet and return it."
+
+ (unless project-name
+ (error "%s%s" "Cannot initialize `org-publish-cache' without projects name"
+ " in `org-publish-initialize-cache'"))
+
+ (unless (file-exists-p org-publish-timestamp-directory)
+ (make-directory org-publish-timestamp-directory t))
+ (if (not (file-directory-p org-publish-timestamp-directory))
+ (error "Org publish timestamp: %s is not a directory"
+ org-publish-timestamp-directory))
+
+ (unless (and org-publish-cache
+ (string= (org-publish-cache-get ":project:") project-name))
+ (let* ((cache-file (concat
+ (expand-file-name org-publish-timestamp-directory)
+ project-name
+ ".cache"))
+ (cexists (file-exists-p cache-file)))
+
+ (when org-publish-cache
+ (org-publish-reset-cache))
+
+ (if cexists
+ (load-file cache-file)
+ (setq org-publish-cache
+ (make-hash-table :test 'equal :weakness nil :size 100))
+ (org-publish-cache-set ":project:" project-name)
+ (org-publish-cache-set ":cache-file:" cache-file))
+ (unless cexists (org-publish-write-cache-file nil))))
+ org-publish-cache)
+
+(defun org-publish-reset-cache ()
+ "Empty org-publish-cache and reset it nil."
+ (message "%s" "Resetting org-publish-cache")
+ (if (hash-table-p org-publish-cache)
+ (clrhash org-publish-cache))
+ (setq org-publish-cache nil))
+
+(defun org-publish-cache-file-needs-publishing (filename &optional pub-dir pub-func)
+ "Check the timestamp of the last publishing of FILENAME.
+Return `t', if the file needs publishing"
+ (unless org-publish-cache
+ (error "%s" "`org-publish-cache-file-needs-publishing' called, but no cache present"))
+ (let* ((key (org-publish-timestamp-filename filename pub-dir pub-func))
+ (pstamp (org-publish-cache-get key)))
+ (if (null pstamp)
+ t
+ (let ((ctime (org-publish-cache-ctime-of-src filename)))
+ (< pstamp ctime)))))
+
+(defun org-publish-cache-set-file-property (filename property value &optional project-name)
+ "Set the VALUE for a PROPERTY of file FILENAME in publishing cache to VALUE.
+Use cache file of PROJECT-NAME. If the entry does not exist, it will be
+created. Return VALUE."
+ ;; Evtl. load the requested cache file:
+ (if project-name (org-publish-initialize-cache project-name))
+ (let ((pl (org-publish-cache-get filename)))
+ (if pl
+ (progn
+ (plist-put pl property value)
+ value)
+ (org-publish-cache-get-file-property
+ filename property value nil project-name))))
+
+(defun org-publish-cache-get-file-property
+ (filename property &optional default no-create project-name)
+ "Return the value for a PROPERTY of file FILENAME in publishing cache.
+Use cache file of PROJECT-NAME. Return the value of that PROPERTY or
+DEFAULT, if the value does not yet exist.
+If the entry will be created, unless NO-CREATE is not nil."
+ ;; Evtl. load the requested cache file:
+ (if project-name (org-publish-initialize-cache project-name))
+ (let ((pl (org-publish-cache-get filename))
+ (retval nil))
+ (if pl
+ (if (plist-member pl property)
+ (setq retval (plist-get pl property))
+ (setq retval default))
+ ;; no pl yet:
+ (unless no-create
+ (org-publish-cache-set filename (list property default)))
+ (setq retval default))
+ retval))
+
+(defun org-publish-cache-get (key)
+ "Return the value stored in `org-publish-cache' for key KEY.
+Returns nil, if no value or nil is found, or the cache does not
+exist."
+ (unless org-publish-cache
+ (error "%s" "`org-publish-cache-get' called, but no cache present"))
+ (gethash key org-publish-cache))
+
+(defun org-publish-cache-set (key value)
+ "Store KEY VALUE pair in `org-publish-cache'.
+Returns value on success, else nil."
+ (unless org-publish-cache
+ (error "%s" "`org-publish-cache-set' called, but no cache present"))
+ (puthash key value org-publish-cache))
+
+(defun org-publish-cache-ctime-of-src (filename)
+ "Get the files ctime as integer."
+ (let ((src-attr (file-attributes filename)))
+ (+
+ (lsh (car (nth 5 src-attr)) 16)
+ (cadr (nth 5 src-attr)))))
+
+
+
+(provide 'org-publish)
;; arch-tag: 72807f3c-8af0-4a6b-8dca-c3376eb25adb
diff --git a/lisp/org/org-remember.el b/lisp/org/org-remember.el
index 7df860cccbc..a15825a51ec 100644
--- a/lisp/org/org-remember.el
+++ b/lisp/org/org-remember.el
@@ -6,7 +6,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -54,14 +54,15 @@
:group 'org)
(defcustom org-remember-store-without-prompt t
- "Non-nil means, `C-c C-c' stores remember note without further prompts.
+ "Non-nil means \\<org-remember-mode-map>\\[org-remember-finalize] \
+stores the remember note without further prompts.
It then uses the file and headline specified by the template or (if the
template does not specify them) by the variables `org-default-notes-file'
and `org-remember-default-headline'. To force prompting anyway, use
-`C-u C-c C-c' to file the note.
+\\[universal-argument] \\[org-remember-finalize] to file the note.
-When this variable is nil, `C-c C-c' gives you the prompts, and
-`C-u C-c C-c' triggers the fasttrack."
+When this variable is nil, \\[org-remember-finalize] gives you the prompts, and
+\\[universal-argument] \\[org-remember-finalize] triggers the fasttrack."
:group 'org-remember
:type 'boolean)
@@ -94,10 +95,10 @@ You can set this on a per-template basis with the variable
(defcustom org-remember-templates nil
"Templates for the creation of remember buffers.
When nil, just let remember make the buffer.
-When non-nil, this is a list of 5-element lists. In each entry, the first
-element is the name of the template, which should be a single short word.
-The second element is a character, a unique key to select this template.
-The third element is the template.
+When non-nil, this is a list of (up to) 6-element lists. In each entry,
+the first element is the name of the template, which should be a single
+short word. The second element is a character, a unique key to select
+this template. The third element is the template.
The fourth element is optional and can specify a destination file for
remember items created with this template. The default file is given
@@ -114,46 +115,49 @@ An optional sixth element specifies the contexts in which the template
will be offered to the user. This element can be a list of major modes
or a function, and the template will only be offered if `org-remember'
is called from a mode in the list, or if the function returns t.
-Templates that specify t or nil for the context will be always be added
+Templates that specify t or nil for the context will always be added
to the list of selectable templates.
The template specifies the structure of the remember buffer. It should have
a first line starting with a star, to act as the org-mode headline.
Furthermore, the following %-escapes will be replaced with content:
- %^{prompt} Prompt the user for a string and replace this sequence with it.
- A default value and a completion table ca be specified like this:
+ %^{PROMPT} prompt the user for a string and replace this sequence with it.
+ A default value and a completion table can be specified like this:
%^{prompt|default|completion2|completion3|...}
+ The arrow keys access a prompt-specific history.
+ %a annotation, normally the link created with `org-store-link'
+ %A like %a, but prompt for the description part
+ %i initial content, copied from the active region. If %i is
+ indented, the entire inserted text will be indented as well.
%t time stamp, date only
%T time stamp with date and time
%u, %U like the above, but inactive time stamps
%^t like %t, but prompt for date. Similarly %^T, %^u, %^U.
- You may define a prompt like %^{Please specify birthday
+ You may define a prompt like %^{Please specify birthday}t
%n user name (taken from `user-full-name')
- %a annotation, normally the link created with org-store-link
- %i initial content, copied from the active region. If %i is
- indented, the entire inserted text will be indented as well.
%c current kill ring head
%x content of the X clipboard
- %^C Interactive selection of which kill or clip to use
- %^L Like %^C, but insert as link
- %k title of currently clocked task
- %K link to currently clocked task
- %^g prompt for tags, with completion on tags in target file
- %^G prompt for tags, with completion all tags in all agenda files
- %^{prop}p Prompt the user for a value for property `prop'
%:keyword specific information for certain link types, see below
- %[pathname] insert the contents of the file given by `pathname'
- %(sexp) evaluate elisp `(sexp)' and replace with the result
- %! Store this note immediately after filling the template
- %& Visit note immediately after storing it
-
- %? After completing the template, position cursor here.
+ %^C interactive selection of which kill or clip to use
+ %^L like %^C, but insert as link
+ %k title of the currently clocked task
+ %K link to the currently clocked task
+ %^g prompt for tags, completing tags in the target file
+ %^G prompt for tags, completing all tags in all agenda files
+ %^{PROP}p Prompt the user for a value for property PROP
+ %[PATHNAME] insert the contents of the file given by PATHNAME
+ %(SEXP) evaluate elisp `(SEXP)' and replace with the result
+ %! store this note immediately after completing the template\
+ \\<org-remember-mode-map>
+ (skipping the \\[org-remember-finalize] that normally triggers storing)
+ %& jump to target location immediately after storing note
+ %? after completing the template, position cursor here.
Apart from these general escapes, you can access information specific to the
link type that is created. For example, calling `remember' in emails or gnus
will record the author and the subject of the message, which you can access
-with %:author and %:subject, respectively. Here is a complete list of what
+with %:fromname and %:subject, respectively. Here is a complete list of what
is recorded for each link type.
Link type | Available information
@@ -163,7 +167,8 @@ vm, wl, mh, rmail | %:type %:subject %:message-id
| %:from %:fromname %:fromaddress
| %:to %:toname %:toaddress
| %:fromto (either \"to NAME\" or \"from NAME\")
-gnus | %:group, for messages also all email fields
+gnus | %:group, for messages also all email fields and
+ | %:org-date (the Date: header in Org format)
w3, w3m | %:type %:url
info | %:type %:file %:node
calendar | %:type %:date"
@@ -211,7 +216,7 @@ The remember buffer is still current when this hook runs."
:type 'hook)
(defvar org-remember-mode-map (make-sparse-keymap)
- "Keymap for org-remember-mode, a minor mode.
+ "Keymap for `org-remember-mode', a minor mode.
Use this map to set additional keybindings for when Org-mode is used
for a Remember buffer.")
(defvar org-remember-mode-hook nil
@@ -225,11 +230,11 @@ for a Remember buffer.")
(define-key org-remember-mode-map "\C-c\C-k" 'org-remember-kill)
(defcustom org-remember-clock-out-on-exit 'query
- "Non-nil means, stop the clock when exiting a clocking remember buffer.
+ "Non-nil means stop the clock when exiting a clocking remember buffer.
This only applies if the clock is running in the remember buffer. If the
clock is not stopped, it continues to run in the storage location.
Instead of nil or t, this may also be the symbol `query' to prompt the
-user each time a remember buffer with a running clock is filed away. "
+user each time a remember buffer with a running clock is filed away."
:group 'org-remember
:type '(choice
(const :tag "Never" nil)
@@ -248,7 +253,7 @@ See also `org-remember-auto-remove-backup-files'."
(directory :tag "Directory")))
(defcustom org-remember-auto-remove-backup-files t
- "Non-nil means, remove remember backup files after successfully storage.
+ "Non-nil means remove remember backup files after successfully storage.
When remember is finished successfully, with storing the note at the
desired target, remove the backup files related to this remember process
and show a message about remaining backup files, from previous, unfinished
@@ -265,7 +270,7 @@ Set this to nil if you find that you don't need the warning.
If you cancel remember calls frequently and know when they
contain useful information (because you know that you made an
-error or emacs crashed, for example) nil is more useful. In the
+error or Emacs crashed, for example) nil is more useful. In the
opposite case, the default, t, is more useful."
:group 'org-remember
:type 'boolean)
@@ -351,7 +356,7 @@ RET at beg-of-buf -> Append to file as level 2 headline
org-force-remember-template-char))
(t
(setq msg (format
- "Select template: %s"
+ "Select template: %s%s"
(mapconcat
(lambda (x)
(cond
@@ -362,13 +367,17 @@ RET at beg-of-buf -> Append to file as level 2 headline
(format "[%c]%s" (car x)
(substring (nth 1 x) 1)))
(t (format "[%c]%s" (car x) (nth 1 x)))))
- templates " ")))
+ templates " ")
+ (if (assoc ?C templates)
+ ""
+ " [C]customize templates")))
(let ((inhibit-quit t) char0)
(while (not char0)
(message msg)
(setq char0 (read-char-exclusive))
(when (and (not (assoc char0 templates))
- (not (equal char0 ?\C-g)))
+ (not (equal char0 ?\C-g))
+ (not (equal char0 ?C)))
(message "No such template \"%c\"" char0)
(ding) (sit-for 1)
(setq char0 nil)))
@@ -376,15 +385,14 @@ RET at beg-of-buf -> Append to file as level 2 headline
(jump-to-register remember-register)
(kill-buffer remember-buffer)
(error "Abort"))
+ (when (not (assoc char0 templates))
+ (jump-to-register remember-register)
+ (kill-buffer remember-buffer)
+ (customize-variable 'org-remember-templates)
+ (error "Customize templates"))
char0))))))
(cddr (assoc char templates)))))
-(defun org-get-x-clipboard (value)
- "Get the value of the x clipboard, compatible with XEmacs, and GNU Emacs 21."
- (if (eq window-system 'x)
- (let ((x (org-get-x-clipboard-compat value)))
- (if x (org-no-properties x)))))
-
;;;###autoload
(defun org-remember-apply-template (&optional use-char skip-interactive)
"Initialize *remember* buffer with template, invoke `org-mode'.
@@ -470,7 +478,7 @@ to be run from that hook to function properly."
## C-u C-c C-c like C-c C-c, and immediately visit note at target location
## C-0 C-c C-c \"%s\" -> \"* %s\"
## %s to select file and header location interactively.
-## C-2 C-c C-c as child of the currently clocked item
+## C-2 C-c C-c as child (C-3: as sibling) of the currently clocked item
## To switch templates, use `\\[org-remember]'. To abort use `C-c C-k'.\n\n"
(if org-remember-store-without-prompt " C-c C-c" " C-1 C-c C-c")
(abbreviate-file-name (or file org-default-notes-file))
@@ -479,9 +487,22 @@ to be run from that hook to function properly."
(or (cdr org-remember-previous-location) "???")
(if org-remember-store-without-prompt "C-1 C-c C-c" " C-c C-c"))))
(insert tpl)
- (goto-char (point-min))
+ ;; %[] Insert contents of a file.
+ (goto-char (point-min))
+ (while (re-search-forward "%\\[\\(.+\\)\\]" nil t)
+ (unless (org-remember-escaped-%)
+ (let ((start (match-beginning 0))
+ (end (match-end 0))
+ (filename (expand-file-name (match-string 1))))
+ (goto-char start)
+ (delete-region start end)
+ (condition-case error
+ (insert-file-contents filename)
+ (error (insert (format "%%![Couldn't insert %s: %s]"
+ filename error)))))))
;; Simple %-escapes
+ (goto-char (point-min))
(while (re-search-forward "%\\([tTuUaiAcxkKI]\\)" nil t)
(unless (org-remember-escaped-%)
(when (and initial (equal (match-string 0) "%i"))
@@ -495,19 +516,6 @@ to be run from that hook to function properly."
(or (eval (intern (concat "v-" (match-string 1)))) "")
t t)))
- ;; %[] Insert contents of a file.
- (goto-char (point-min))
- (while (re-search-forward "%\\[\\(.+\\)\\]" nil t)
- (unless (org-remember-escaped-%)
- (let ((start (match-beginning 0))
- (end (match-end 0))
- (filename (expand-file-name (match-string 1))))
- (goto-char start)
- (delete-region start end)
- (condition-case error
- (insert-file-contents filename)
- (error (insert (format "%%![Couldn't insert %s: %s]"
- filename error)))))))
;; %() embedded elisp
(goto-char (point-min))
(while (re-search-forward "%\\((.+)\\)" nil t)
@@ -567,7 +575,7 @@ to be run from that hook to function properly."
'org-tags-completion-function nil nil nil
'org-tags-history)))
(setq ins (mapconcat 'identity
- (org-split-string ins (org-re "[^[:alnum:]_@]+"))
+ (org-split-string ins (org-re "[^[:alnum:]_@#%]+"))
":"))
(when (string-match "\\S-" ins)
(or (equal (char-before) ?:) (insert ":"))
@@ -718,9 +726,11 @@ from that hook."
If there is an active region, make sure remember uses it as initial content
of the remember buffer.
-When called interactively with a `C-u' prefix argument GOTO, don't remember
+When called interactively with a \\[universal-argument] \
+prefix argument GOTO, don't remember
anything, just go to the file/headline where the selected template usually
-stores its notes. With a double prefix arg `C-u C-u', go to the last
+stores its notes. With a double prefix argument \
+\\[universal-argument] \\[universal-argument], go to the last
note stored by remember.
Lisp programs can set ORG-FORCE-REMEMBER-TEMPLATE-CHAR to a character
@@ -792,21 +802,24 @@ The user is queried for the template."
When the template has specified a file and a headline, the entry is filed
there, or in the location defined by `org-default-notes-file' and
`org-remember-default-headline'.
-
+\\<org-remember-mode-map>
If no defaults have been defined, or if the current prefix argument
-is 1 (so you must use `C-1 C-c C-c' to exit remember), an interactive
+is 1 (using C-1 \\[org-remember-finalize] to exit remember), an interactive
process is used to select the target location.
-When the prefix is 0 (i.e. when remember is exited with `C-0 C-c C-c'),
+When the prefix is 0 (i.e. when remember is exited with \
+C-0 \\[org-remember-finalize]),
the entry is filed to the same location as the previous note.
-When the prefix is 2 (i.e. when remember is exited with `C-2 C-c C-c'),
+When the prefix is 2 (i.e. when remember is exited with \
+C-2 \\[org-remember-finalize]),
the entry is filed as a subentry of the entry where the clock is
currently running.
-When `C-u' has been used as prefix argument, the note is stored and emacs
-moves point to the new location of the note, so that editing can be
-continued there (similar to inserting \"%&\" into the template).
+When \\[universal-argument] has been used as prefix argument, the
+note is stored and Emacs moves point to the new location of the
+note, so that editing can be continued there (similar to
+inserting \"%&\" into the template).
Before storing the note, the function ensures that the text has an
org-mode-style headline, i.e. a first line that starts with
@@ -860,6 +873,7 @@ See also the variable `org-reverse-note-order'."
(previousp (and (member current-prefix-arg '((16) 0))
org-remember-previous-location))
(clockp (equal current-prefix-arg 2))
+ (clocksp (equal current-prefix-arg 3))
(fastp (org-xor (equal current-prefix-arg 1)
org-remember-store-without-prompt))
(file (cond
@@ -882,7 +896,7 @@ See also the variable `org-reverse-note-order'."
visiting (and file (org-find-base-buffer-visiting file))
heading (cdr org-remember-previous-location)
fastp t))
- (when clockp
+ (when (or clockp clocksp)
(setq file (buffer-file-name (marker-buffer org-clock-marker))
visiting (and file (org-find-base-buffer-visiting file))
heading org-clock-heading-for-remember
@@ -1015,7 +1029,9 @@ See also the variable `org-reverse-note-order'."
(beginning-of-line 2)
(end-of-line 1)
(insert "\n"))))
- (org-paste-subtree (org-get-valid-level level 1) txt)
+ (org-paste-subtree (if clocksp
+ level
+ (org-get-valid-level level 1)) txt)
(and org-auto-align-tags (org-set-tags nil t))
(bookmark-set "org-remember-last-stored")
(move-marker org-remember-last-stored-marker (point)))
diff --git a/lisp/org/org-rmail.el b/lisp/org/org-rmail.el
index 98cdcde1d20..5574bf77ac4 100644
--- a/lisp/org/org-rmail.el
+++ b/lisp/org/org-rmail.el
@@ -6,7 +6,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -59,10 +59,20 @@
(from (mail-fetch-field "from"))
(to (mail-fetch-field "to"))
(subject (mail-fetch-field "subject"))
+ (date (mail-fetch-field "date"))
+ (date-ts (and date (format-time-string
+ (org-time-stamp-format t)
+ (date-to-time date))))
+ (date-ts-ia (and date (format-time-string
+ (org-time-stamp-format t t)
+ (date-to-time date))))
desc link)
(org-store-link-props
:type "rmail" :from from :to to
:subject subject :message-id message-id)
+ (when date
+ (org-add-link-props :date date :date-timestamp date-ts
+ :date-timestamp-inactive date-ts-ia))
(setq message-id (org-remove-angle-brackets message-id))
(setq desc (org-email-link-description))
(setq link (org-make-link "rmail:" folder "#" message-id))
diff --git a/lisp/org/org-src.el b/lisp/org/org-src.el
index 25e7f9dcd12..c4f0065ec34 100644
--- a/lisp/org/org-src.el
+++ b/lisp/org/org-src.el
@@ -8,7 +8,7 @@
;; Dan Davison <davison at stats dot ox dot ac dot uk>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -34,10 +34,13 @@
(require 'org-macs)
(require 'org-compat)
+(require 'ob-keys)
+(require 'ob-comint)
(eval-when-compile
(require 'cl))
(declare-function org-do-remove-indentation "org" (&optional n))
+(declare-function org-at-table.el-p "org" ())
(declare-function org-get-indentation "org" (&optional line))
(declare-function org-switch-to-buffer-other-window "org" (&rest args))
@@ -62,7 +65,7 @@ there are kept outside the narrowed region."
"The default coderef format.
This format string will be used to search for coderef labels in literal
examples (EXAMPLE and SRC blocks). The format can be overwritten in
-an individual literal example with the -f option, like
+an individual literal example with the -l option, like
#+BEGIN_SRC pascal +n -r -l \"((%s))\"
...
@@ -86,10 +89,11 @@ These are the regions where each line starts with a colon."
(function :tag "Other (specify)")))
(defcustom org-src-preserve-indentation nil
- "If non-nil, leading whitespace characters in source code
-blocks are preserved on export, and when switching between the
-org buffer and the language mode edit buffer. If this variable
-is nil then, after editing with \\[org-edit-src-code], the
+ "If non-nil preserve leading whitespace characters on export.
+If non-nil leading whitespace characters in source code blocks
+are preserved on export, and when switching between the org
+buffer and the language mode edit buffer. If this variable is nil
+then, after editing with \\[org-edit-src-code], the
minimum (across-lines) number of leading whitespace characters
are removed from all lines, and the code block is uniformly
indented according to the value of `org-edit-src-content-indentation'."
@@ -100,11 +104,15 @@ indented according to the value of `org-edit-src-content-indentation'."
"Indentation for the content of a source code block.
This should be the number of spaces added to the indentation of the #+begin
line in order to compute the indentation of the block content after
-editing it with \\[org-edit-src-code]. Has no effect if
+editing it with \\[org-edit-src-code]. Has no effect if
`org-src-preserve-indentation' is non-nil."
:group 'org-edit-structure
:type 'integer)
+(defvar org-src-strip-leading-and-trailing-blank-lines nil
+ "If non-nil, blank lines are removed when exiting the code edit
+buffer.")
+
(defcustom org-edit-src-persistent-message t
"Non-nil means show persistent exit help message while editing src examples.
The message is shown in the header-line, which will be created in the
@@ -113,7 +121,6 @@ When nil, the message will only be shown intermittently in the echo area."
:group 'org-edit-structure
:type 'boolean)
-
(defcustom org-src-window-setup 'reorganize-frame
"How the source code edit buffer should be displayed.
Possible values for this option are:
@@ -146,7 +153,8 @@ but which mess up the display of a snippet in Org exported files.")
(defcustom org-src-lang-modes
'(("ocaml" . tuareg) ("elisp" . emacs-lisp) ("ditaa" . artist)
- ("asymptote" . asy) ("dot" . fundamental))
+ ("asymptote" . asy) ("dot" . fundamental) ("sqlite" . sql)
+ ("calc" . fundamental))
"Alist mapping languages to their major mode.
The key is the language name, the value is the string that should
be inserted as the name of the major mode. For many languages this is
@@ -164,8 +172,10 @@ For example, there is no ocaml-mode in Emacs, but the mode to use is
(defvar org-src-mode-map (make-sparse-keymap))
(define-key org-src-mode-map "\C-c'" 'org-edit-src-exit)
+
(defvar org-edit-src-force-single-line nil)
(defvar org-edit-src-from-org-mode nil)
+(defvar org-edit-src-allow-write-back-p t)
(defvar org-edit-src-picture nil)
(defvar org-edit-src-beg-marker nil)
(defvar org-edit-src-end-marker nil)
@@ -179,6 +189,8 @@ For example, there is no ocaml-mode in Emacs, but the mode to use is
immediately; otherwise it will ask whether you want to return
to the existing edit buffer.")
+(defvar org-src-babel-info nil)
+
(define-minor-mode org-src-mode
"Minor mode for language major mode buffers generated by org.
This minor mode is turned on in two situations:
@@ -187,32 +199,39 @@ This minor mode is turned on in two situations:
There is a mode hook, and keybindings for `org-edit-src-exit' and
`org-edit-src-save'")
-(defun org-edit-src-code (&optional context)
+(defun org-edit-src-code (&optional context code edit-buffer-name quietp)
"Edit the source code example at point.
-The example is copied to a separate buffer, and that buffer is switched
-to the correct language mode. When done, exit with \\[org-edit-src-exit].
-This will remove the original code in the Org buffer, and replace it with
-the edited version. Optional argument CONTEXT is used by
-\\[org-edit-src-save] when calling this function."
+The example is copied to a separate buffer, and that buffer is
+switched to the correct language mode. When done, exit with
+\\[org-edit-src-exit]. This will remove the original code in the
+Org buffer, and replace it with the edited version. Optional
+argument CONTEXT is used by \\[org-edit-src-save] when calling
+this function. See \\[org-src-window-setup] to configure the
+display of windows containing the Org buffer and the code
+buffer."
(interactive)
(unless (eq context 'save)
(setq org-edit-src-saved-temp-window-config (current-window-configuration)))
- (let ((line (org-current-line))
- (col (current-column))
+ (let ((mark (and (org-region-active-p) (mark)))
(case-fold-search t)
- (msg (substitute-command-keys
- "Edit, then exit with C-c ' (C-c and single quote)"))
(info (org-edit-src-find-region-and-lang))
+ (babel-info (org-babel-get-src-block-info 'light))
(org-mode-p (eq major-mode 'org-mode))
(beg (make-marker))
(end (make-marker))
(preserve-indentation org-src-preserve-indentation)
- block-nindent total-nindent ovl lang lang-f single lfmt code begline buffer)
+ (allow-write-back-p (null code))
+ block-nindent total-nindent ovl lang lang-f single lfmt buffer msg
+ begline markline markcol line col)
(if (not info)
nil
(setq beg (move-marker beg (nth 0 info))
end (move-marker end (nth 1 info))
- code (buffer-substring-no-properties beg end)
+ msg (if allow-write-back-p
+ (substitute-command-keys
+ "Edit, then exit with C-c ' (C-c and single quote)")
+ "Exit with C-c ' (C-c and single quote)")
+ code (or code (buffer-substring-no-properties beg end))
lang (or (cdr (assoc (nth 2 info) org-src-lang-modes))
(nth 2 info))
lang (if (symbolp lang) (symbol-name lang) lang)
@@ -221,9 +240,23 @@ the edited version. Optional argument CONTEXT is used by
block-nindent (nth 5 info)
lang-f (intern (concat lang "-mode"))
begline (save-excursion (goto-char beg) (org-current-line)))
+ (if (and mark (>= mark beg) (<= mark end))
+ (save-excursion (goto-char mark)
+ (setq markline (org-current-line)
+ markcol (current-column))))
+ (if (equal lang-f 'table.el-mode)
+ (setq lang-f (lambda ()
+ (text-mode)
+ (if (org-bound-and-true-p flyspell-mode)
+ (flyspell-mode -1))
+ (table-recognize)
+ (org-set-local 'org-edit-src-content-indentation 0))))
(unless (functionp lang-f)
(error "No such language mode: %s" lang-f))
- (org-goto-line line)
+ (save-excursion
+ (if (> (point) end) (goto-char end))
+ (setq line (org-current-line)
+ col (current-column)))
(if (and (setq buffer (org-edit-src-find-buffer beg end))
(if org-src-ask-before-returning-to-edit-buffer
(y-or-n-p "Return to existing edit buffer? [n] will revert changes: ") t))
@@ -231,20 +264,21 @@ the edited version. Optional argument CONTEXT is used by
(when buffer
(with-current-buffer buffer
(if (boundp 'org-edit-src-overlay)
- (org-delete-overlay org-edit-src-overlay)))
+ (delete-overlay org-edit-src-overlay)))
(kill-buffer buffer))
(setq buffer (generate-new-buffer
- (org-src-construct-edit-buffer-name (buffer-name) lang)))
- (setq ovl (org-make-overlay beg end))
- (org-overlay-put ovl 'edit-buffer buffer)
- (org-overlay-put ovl 'help-echo "Click with mouse-1 to switch to buffer editing this segment")
- (org-overlay-put ovl 'face 'secondary-selection)
- (org-overlay-put ovl
- 'keymap
- (let ((map (make-sparse-keymap)))
- (define-key map [mouse-1] 'org-edit-src-continue)
- map))
- (org-overlay-put ovl :read-only "Leave me alone")
+ (or edit-buffer-name
+ (org-src-construct-edit-buffer-name (buffer-name) lang))))
+ (setq ovl (make-overlay beg end))
+ (overlay-put ovl 'edit-buffer buffer)
+ (overlay-put ovl 'help-echo "Click with mouse-1 to switch to buffer editing this segment")
+ (overlay-put ovl 'face 'secondary-selection)
+ (overlay-put ovl
+ 'keymap
+ (let ((map (make-sparse-keymap)))
+ (define-key map [mouse-1] 'org-edit-src-continue)
+ map))
+ (overlay-put ovl :read-only "Leave me alone")
(org-src-switch-to-buffer buffer 'edit)
(if (eq single 'macro-definition)
(setq code (replace-regexp-in-string "\\\\n" "\n" code t t)))
@@ -254,10 +288,16 @@ the edited version. Optional argument CONTEXT is used by
(unless preserve-indentation
(setq total-nindent (or (org-do-remove-indentation) 0)))
(let ((org-inhibit-startup t))
- (funcall lang-f))
+ (condition-case e
+ (funcall lang-f)
+ (error
+ (error "Language mode `%s' fails with: %S" lang-f (nth 1 e)))))
(set (make-local-variable 'org-edit-src-force-single-line) single)
(set (make-local-variable 'org-edit-src-from-org-mode) org-mode-p)
+ (set (make-local-variable 'org-edit-src-allow-write-back-p) allow-write-back-p)
(set (make-local-variable 'org-src-preserve-indentation) preserve-indentation)
+ (when babel-info
+ (set (make-local-variable 'org-src-babel-info) babel-info))
(when lfmt
(set (make-local-variable 'org-coderef-label-format) lfmt))
(when org-mode-p
@@ -265,6 +305,12 @@ the edited version. Optional argument CONTEXT is used by
(while (re-search-forward "^," nil t)
(if (eq (org-current-line) line) (setq total-nindent (1+ total-nindent)))
(replace-match "")))
+ (when markline
+ (org-goto-line (1+ (- markline begline)))
+ (org-move-to-column
+ (if preserve-indentation markcol (max 0 (- markcol total-nindent))))
+ (push-mark (point) 'no-message t)
+ (setq deactivate-mark nil))
(org-goto-line (1+ (- line begline)))
(org-move-to-column
(if preserve-indentation col (max 0 (- col total-nindent))))
@@ -276,7 +322,7 @@ the edited version. Optional argument CONTEXT is used by
(set-buffer-modified-p nil)
(and org-edit-src-persistent-message
(org-set-local 'header-line-format msg)))
- (message "%s" msg)
+ (unless quietp (message "%s" msg))
t)))
(defun org-edit-src-continue (e)
@@ -307,13 +353,15 @@ the edited version. Optional argument CONTEXT is used by
(if (eq context 'edit) (delete-other-windows))
(org-switch-to-buffer-other-window buffer)
(if (eq context 'exit) (delete-other-windows)))
+ ('switch-invisibly
+ (set-buffer buffer))
(t
(message "Invalid value %s for org-src-window-setup"
(symbol-name org-src-window-setup))
(switch-to-buffer buffer))))
(defun org-src-construct-edit-buffer-name (org-buffer-name lang)
- "Construct the buffer name for a source editing buffer"
+ "Construct the buffer name for a source editing buffer."
(concat "*Org Src " org-buffer-name "[ " lang " ]*"))
(defun org-edit-src-find-buffer (beg end)
@@ -374,22 +422,22 @@ the fragment in the Org-mode buffer."
(when buffer
(with-current-buffer buffer
(if (boundp 'org-edit-src-overlay)
- (org-delete-overlay org-edit-src-overlay)))
+ (delete-overlay org-edit-src-overlay)))
(kill-buffer buffer))
(setq buffer (generate-new-buffer
(org-src-construct-edit-buffer-name
(buffer-name) "Fixed Width")))
- (setq ovl (org-make-overlay beg end))
- (org-overlay-put ovl 'face 'secondary-selection)
- (org-overlay-put ovl 'edit-buffer buffer)
- (org-overlay-put ovl 'help-echo "Click with mouse-1 to switch to buffer editing this segment")
- (org-overlay-put ovl 'face 'secondary-selection)
- (org-overlay-put ovl
+ (setq ovl (make-overlay beg end))
+ (overlay-put ovl 'face 'secondary-selection)
+ (overlay-put ovl 'edit-buffer buffer)
+ (overlay-put ovl 'help-echo "Click with mouse-1 to switch to buffer editing this segment")
+ (overlay-put ovl 'face 'secondary-selection)
+ (overlay-put ovl
'keymap
(let ((map (make-sparse-keymap)))
(define-key map [mouse-1] 'org-edit-src-continue)
map))
- (org-overlay-put ovl :read-only "Leave me alone")
+ (overlay-put ovl :read-only "Leave me alone")
(switch-to-buffer buffer)
(insert code)
(remove-text-properties (point-min) (point-max)
@@ -399,7 +447,7 @@ the fragment in the Org-mode buffer."
((eq org-edit-fixed-width-region-mode 'artist-mode)
(fundamental-mode)
(artist-mode 1))
- (t (funcall org-edit-fixed-width-region-mode)))
+ (t (funcall org-edit-fixed-width-region-mode)))
(set (make-local-variable 'org-edit-src-force-single-line) nil)
(set (make-local-variable 'org-edit-src-from-org-mode) org-mode-p)
(set (make-local-variable 'org-edit-src-picture) t)
@@ -482,7 +530,16 @@ the language, a switch telling if the content should be in a single line."
(throw 'exit
(list (match-end 0) end
(org-edit-src-get-lang lang)
- single lfmt ind))))))))))))
+ single lfmt ind)))))))))
+ (when (org-at-table.el-p)
+ (re-search-backward "^[\t]*[^ \t|\\+]" nil t)
+ (setq beg (1+ (point-at-eol)))
+ (goto-char beg)
+ (or (re-search-forward "^[\t]*[^ \t|\\+]" nil t)
+ (progn (goto-char (point-max)) (newline)))
+ (setq end (point-at-bol))
+ (setq ind (org-edit-src-get-indentation beg))
+ (throw 'exit (list beg end 'table.el nil nil ind))))))
(defun org-edit-src-get-lang (lang)
"Extract the src language."
@@ -505,7 +562,7 @@ the language, a switch telling if the content should be in a single line."
(match-string 1 s))))
(defun org-edit-src-get-indentation (pos)
- "Count leading whitespace characters on line"
+ "Count leading whitespace characters on line."
(save-match-data
(goto-char pos)
(org-get-indentation)))
@@ -513,8 +570,9 @@ the language, a switch telling if the content should be in a single line."
(defun org-edit-src-exit (&optional context)
"Exit special edit and protect problematic lines."
(interactive)
- (unless org-edit-src-from-org-mode
- (error "This is not a sub-editing buffer, something is wrong..."))
+ (unless (org-bound-and-true-p org-edit-src-from-org-mode)
+ (error "This is not a sub-editing buffer, something is wrong"))
+ (widen)
(let* ((beg org-edit-src-beg-marker)
(end org-edit-src-end-marker)
(ovl org-edit-src-overlay)
@@ -524,59 +582,71 @@ the language, a switch telling if the content should be in a single line."
(total-nindent (+ (or org-edit-src-block-indentation 0)
org-edit-src-content-indentation))
(preserve-indentation org-src-preserve-indentation)
+ (allow-write-back-p (org-bound-and-true-p org-edit-src-allow-write-back-p))
(delta 0) code line col indent)
- (untabify (point-min) (point-max))
- (save-excursion
- (goto-char (point-min))
- (if (looking-at "[ \t\n]*\n") (replace-match ""))
- (unless macro
- (if (re-search-forward "\n[ \t\n]*\\'" nil t) (replace-match ""))))
+ (when allow-write-back-p
+ (unless preserve-indentation (untabify (point-min) (point-max)))
+ (if org-src-strip-leading-and-trailing-blank-lines
+ (save-excursion
+ (goto-char (point-min))
+ (if (looking-at "[ \t\n]*\n") (replace-match ""))
+ (unless macro
+ (if (re-search-forward "\n[ \t\n]*\\'" nil t) (replace-match ""))))))
(setq line (if (org-bound-and-true-p org-edit-src-force-single-line)
1
(org-current-line))
col (current-column))
- (when single
- (goto-char (point-min))
- (if (re-search-forward "\\s-+\\'" nil t) (replace-match ""))
- (goto-char (point-min))
- (let ((cnt 0))
- (while (re-search-forward "\n" nil t)
- (setq cnt (1+ cnt))
- (replace-match (if macro "\\n" " ") t t))
- (when (and macro (> cnt 0))
- (goto-char (point-max)) (insert "\\n")))
- (goto-char (point-min))
- (if (looking-at "\\s-*") (replace-match " ")))
- (when (org-bound-and-true-p org-edit-src-from-org-mode)
- (goto-char (point-min))
- (while (re-search-forward
- (if (org-mode-p) "^\\(.\\)" "^\\([*]\\|[ \t]*#\\+\\)") nil t)
- (if (eq (org-current-line) line) (setq delta (1+ delta)))
- (replace-match ",\\1")))
- (when (org-bound-and-true-p org-edit-src-picture)
- (setq preserve-indentation nil)
- (untabify (point-min) (point-max))
- (goto-char (point-min))
- (while (re-search-forward "^" nil t)
- (replace-match ": ")))
- (unless (or single preserve-indentation (= total-nindent 0))
- (setq indent (make-string total-nindent ?\ ))
- (goto-char (point-min))
- (while (re-search-forward "^" nil t)
- (replace-match indent)))
- (if (org-bound-and-true-p org-edit-src-picture)
- (setq total-nindent (+ total-nindent 2)))
- (setq code (buffer-string))
- (set-buffer-modified-p nil)
+ (when allow-write-back-p
+ (when single
+ (goto-char (point-min))
+ (if (re-search-forward "\\s-+\\'" nil t) (replace-match ""))
+ (goto-char (point-min))
+ (let ((cnt 0))
+ (while (re-search-forward "\n" nil t)
+ (setq cnt (1+ cnt))
+ (replace-match (if macro "\\n" " ") t t))
+ (when (and macro (> cnt 0))
+ (goto-char (point-max)) (insert "\\n")))
+ (goto-char (point-min))
+ (if (looking-at "\\s-*") (replace-match " ")))
+ (when (org-bound-and-true-p org-edit-src-from-org-mode)
+ (goto-char (point-min))
+ (while (re-search-forward
+ (if (org-mode-p) "^\\(.\\)" "^\\([*]\\|[ \t]*#\\+\\)") nil t)
+ (if (eq (org-current-line) line) (setq delta (1+ delta)))
+ (replace-match ",\\1")))
+ (when (org-bound-and-true-p org-edit-src-picture)
+ (setq preserve-indentation nil)
+ (untabify (point-min) (point-max))
+ (goto-char (point-min))
+ (while (re-search-forward "^" nil t)
+ (replace-match ": ")))
+ (unless (or single preserve-indentation (= total-nindent 0))
+ (setq indent (make-string total-nindent ?\ ))
+ (goto-char (point-min))
+ (while (re-search-forward "^" nil t)
+ (replace-match indent)))
+ (if (org-bound-and-true-p org-edit-src-picture)
+ (setq total-nindent (+ total-nindent 2)))
+ (setq code (buffer-string))
+ (set-buffer-modified-p nil))
(org-src-switch-to-buffer (marker-buffer beg) (or context 'exit))
(kill-buffer buffer)
(goto-char beg)
- (delete-region beg end)
- (insert code)
- (goto-char beg)
- (if single (just-one-space))
- (org-goto-line (1- (+ (org-current-line) line)))
- (org-move-to-column (if preserve-indentation col (+ col total-nindent delta)))
+ (when allow-write-back-p
+ (delete-region beg end)
+ (insert code)
+ (goto-char beg)
+ (if single (just-one-space)))
+ (if (memq t (mapcar (lambda (overlay)
+ (eq (overlay-get overlay 'invisible)
+ 'org-hide-block))
+ (overlays-at (point))))
+ ;; Block is hidden; put point at start of block
+ (beginning-of-line 0)
+ ;; Block is visible, put point where it was in the code buffer
+ (org-goto-line (1- (+ (org-current-line) line)))
+ (org-move-to-column (if preserve-indentation col (+ col total-nindent delta))))
(move-marker beg nil)
(move-marker end nil))
(unless (eq context 'save)
@@ -601,18 +671,140 @@ the language, a switch telling if the content should be in a single line."
(message (or msg ""))))
(defun org-src-mode-configure-edit-buffer ()
- (when org-edit-src-from-org-mode
- (setq buffer-offer-save t)
- (setq buffer-file-name
- (concat (buffer-file-name (marker-buffer org-edit-src-beg-marker))
- "[" (buffer-name) "]"))
- (set (if (featurep 'xemacs) 'write-contents-hooks 'write-contents-functions)
- '(org-edit-src-save))
+ (when (org-bound-and-true-p org-edit-src-from-org-mode)
(org-add-hook 'kill-buffer-hook
- '(lambda () (org-delete-overlay org-edit-src-overlay)) nil 'local)))
+ '(lambda () (delete-overlay org-edit-src-overlay)) nil 'local)
+ (if (org-bound-and-true-p org-edit-src-allow-write-back-p)
+ (progn
+ (setq buffer-offer-save t)
+ (setq buffer-file-name
+ (concat (buffer-file-name (marker-buffer org-edit-src-beg-marker))
+ "[" (buffer-name) "]"))
+ (if (featurep 'xemacs)
+ (progn
+ (make-variable-buffer-local 'write-contents-hooks) ; needed only for 21.4
+ (setq write-contents-hooks '(org-edit-src-save)))
+ (setq write-contents-functions '(org-edit-src-save))))
+ (setq buffer-read-only t))))
(org-add-hook 'org-src-mode-hook 'org-src-mode-configure-edit-buffer)
+
+(defun org-src-associate-babel-session (info)
+ "Associate edit buffer with comint session."
+ (interactive)
+ (let ((session (cdr (assoc :session (nth 2 info)))))
+ (and session (not (string= session "none"))
+ (org-babel-comint-buffer-livep session)
+ ((lambda (f) (and (fboundp f) (funcall f session)))
+ (intern (format "org-babel-%s-associate-session" (nth 0 info)))))))
+
+(defun org-src-babel-configure-edit-buffer ()
+ (when org-src-babel-info
+ (org-src-associate-babel-session org-src-babel-info)))
+
+(org-add-hook 'org-src-mode-hook 'org-src-babel-configure-edit-buffer)
+(defmacro org-src-do-at-code-block (&rest body)
+ "Execute a command from an edit buffer in the Org-mode buffer."
+ `(let ((beg-marker org-edit-src-beg-marker))
+ (if beg-marker
+ (with-current-buffer (marker-buffer beg-marker)
+ (goto-char (marker-position beg-marker))
+ ,@body))))
+
+(defun org-src-do-key-sequence-at-code-block (&optional key)
+ "Execute key sequence at code block in the source Org buffer.
+The command bound to KEY in the Org-babel key map is executed
+remotely with point temporarily at the start of the code block in
+the Org buffer.
+
+This command is not bound to a key by default, to avoid conflicts
+with language major mode bindings. To bind it to C-c @ in all
+language major modes, you could use
+
+ (add-hook 'org-src-mode-hook
+ (lambda () (define-key org-src-mode-map \"\\C-c@\"
+ 'org-src-do-key-sequence-at-code-block)))
+
+In that case, for example, C-c @ t issued in code edit buffers
+would tangle the current Org code block, C-c @ e would execute
+the block and C-c @ h would display the other available
+Org-babel commands."
+ (interactive "kOrg-babel key: ")
+ (if (equal key (kbd "C-g")) (keyboard-quit)
+ (org-edit-src-save)
+ (org-src-do-at-code-block
+ (call-interactively
+ (lookup-key org-babel-map key)))))
+
+(defcustom org-src-tab-acts-natively nil
+ "If non-nil, the effect of TAB in a code block is as if it were
+issued in the language major mode buffer."
+ :type 'boolean
+ :group 'org-babel)
+
+(defun org-src-native-tab-command-maybe ()
+ "Perform language-specific TAB action.
+Alter code block according to effect of TAB in the language major
+mode."
+ (and org-src-tab-acts-natively
+ (let ((org-src-strip-leading-and-trailing-blank-lines nil))
+ (org-babel-do-key-sequence-in-edit-buffer (kbd "TAB")))))
+
+(add-hook 'org-tab-first-hook 'org-src-native-tab-command-maybe)
+
+(defun org-src-font-lock-fontify-block (lang start end)
+ "Fontify code block.
+This function is called by emacs automatic fontification, as long
+as `org-src-fontify-natively' is non-nil. For manual
+fontification of code blocks see `org-src-fontify-block' and
+`org-src-fontify-buffer'"
+ (let* ((lang-mode (org-src-get-lang-mode lang))
+ (string (buffer-substring-no-properties start end))
+ (modified (buffer-modified-p))
+ (org-buffer (current-buffer)) pos next)
+ (remove-text-properties start end '(face nil))
+ (with-current-buffer
+ (get-buffer-create
+ (concat " org-src-fontification:" (symbol-name lang-mode)))
+ (delete-region (point-min) (point-max))
+ (insert string)
+ (unless (eq major-mode lang-mode) (funcall lang-mode))
+ (font-lock-fontify-buffer)
+ (setq pos (point-min))
+ (while (setq next (next-single-property-change pos 'face))
+ (put-text-property
+ (+ start (1- pos)) (+ start next) 'face
+ (get-text-property pos 'face) org-buffer)
+ (setq pos next)))
+ (add-text-properties
+ start end
+ '(font-lock-fontified t fontified t font-lock-multiline t))
+ (set-buffer-modified-p modified))
+ t) ;; Tell `org-fontify-meta-lines-and-blocks' that we fontified
+
+(defun org-src-fontify-block ()
+ "Fontify code block at point."
+ (interactive)
+ (save-excursion
+ (let ((org-src-fontify-natively t)
+ (info (org-edit-src-find-region-and-lang)))
+ (font-lock-fontify-region (nth 0 info) (nth 1 info)))))
+
+(defun org-src-fontify-buffer ()
+ "Fontify all code blocks in the current buffer"
+ (interactive)
+ (org-babel-map-src-blocks nil
+ (org-src-fontify-block)))
+
+(defun org-src-get-lang-mode (lang)
+ "Return major mode that should be used for LANG.
+LANG is a string, and the returned major mode is a symbol."
+ (intern
+ (concat
+ ((lambda (l) (if (symbolp l) (symbol-name l) l))
+ (or (cdr (assoc lang org-src-lang-modes)) lang)) "-mode")))
+
(provide 'org-src)
;; arch-tag: 6a1fc84f-dec7-47be-a416-64be56bea5d8
diff --git a/lisp/org/org-table.el b/lisp/org/org-table.el
index bedcc9a5074..0d61a782270 100644
--- a/lisp/org/org-table.el
+++ b/lisp/org/org-table.el
@@ -6,7 +6,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -49,7 +49,7 @@
(defvar constants-unit-system)
(defcustom orgtbl-optimized (eq org-enable-table-editor 'optimized)
- "Non-nil means, use the optimized table editor version for `orgtbl-mode'.
+ "Non-nil means use the optimized table editor version for `orgtbl-mode'.
In the optimized version, the table editor takes over all simple keys that
normally just insert a character. In tables, the characters are inserted
in a way to minimize disturbing the table structure (i.e. in overwrite mode
@@ -142,14 +142,14 @@ alignment to the right border applies."
:group 'org-table)
(defcustom org-table-automatic-realign t
- "Non-nil means, automatically re-align table when pressing TAB or RETURN.
+ "Non-nil means automatically re-align table when pressing TAB or RETURN.
When nil, aligning is only done with \\[org-table-align], or after column
removal/insertion."
:group 'org-table-editing
:type 'boolean)
(defcustom org-table-auto-blank-field t
- "Non-nil means, automatically blank table field when starting to type into it.
+ "Non-nil means automatically blank table field when starting to type into it.
This only happens when typing immediately after a field motion
command (TAB, S-TAB or RET).
Only relevant when `org-enable-table-editor' is equal to `optimized'."
@@ -157,7 +157,7 @@ Only relevant when `org-enable-table-editor' is equal to `optimized'."
:type 'boolean)
(defcustom org-table-tab-jumps-over-hlines t
- "Non-nil means, tab in the last column of a table with jump over a hline.
+ "Non-nil means tab in the last column of a table with jump over a hline.
If a horizontal separator line is following the current line,
`org-table-next-field' can either create a new row before that line, or jump
over the line. When this option is nil, a new line will be created before
@@ -183,7 +183,7 @@ t: accept as input and present for editing"
(const :tag "Convert user input, don't offer during editing" 'from)))
(defcustom org-table-copy-increment t
- "Non-nil means, increment when copying current field with \\[org-table-copy-down]."
+ "Non-nil means increment when copying current field with \\[org-table-copy-down]."
:group 'org-table-calculation
:type 'boolean)
@@ -196,7 +196,7 @@ t: accept as input and present for editing"
calc-date-format (YYYY "-" MM "-" DD " " Www (" " hh ":" mm))
calc-display-working-message t
)
- "List with Calc mode settings for use in calc-eval for table formulas.
+ "List with Calc mode settings for use in `calc-eval' for table formulas.
The list must contain alternating symbols (Calc modes variables and values).
Don't remove any of the default settings, just change the values. Org-mode
relies on the variables to be present in the list."
@@ -204,7 +204,7 @@ relies on the variables to be present in the list."
:type 'plist)
(defcustom org-table-formula-evaluate-inline t
- "Non-nil means, TAB and RET evaluate a formula in current table field.
+ "Non-nil means TAB and RET evaluate a formula in current table field.
If the current field starts with an equal sign, it is assumed to be a formula
which should be evaluated as described in the manual and in the documentation
string of the command `org-table-eval-formula'. This feature requires the
@@ -215,7 +215,7 @@ the command \\[org-table-eval-formula]."
:type 'boolean)
(defcustom org-table-formula-use-constants t
- "Non-nil means, interpret constants in formulas in tables.
+ "Non-nil means interpret constants in formulas in tables.
A constant looks like `$c' or `$Grav' and will be replaced before evaluation
by the value given in `org-table-formula-constants', or by a value obtained
from the `constants.el' package."
@@ -241,8 +241,8 @@ Constants can also be defined on a per-file basis using a line like
(string :tag "value"))))
(defcustom org-table-allow-automatic-line-recalculation t
- "Non-nil means, lines marked with |#| or |*| will be recomputed automatically.
-Automatically means, when TAB or RET or C-c C-c are pressed in the line."
+ "Non-nil means lines marked with |#| or |*| will be recomputed automatically.
+Automatically means when TAB or RET or C-c C-c are pressed in the line."
:group 'org-table-calculation
:type 'boolean)
@@ -252,7 +252,7 @@ Automatically means, when TAB or RET or C-c C-c are pressed in the line."
:type 'boolean)
(defcustom org-table-relative-ref-may-cross-hline t
- "Non-nil means, relative formula references may cross hlines.
+ "Non-nil means relative formula references may cross hlines.
Here are the allowed values:
nil Relative references may not cross hlines. They will reference the
@@ -276,10 +276,11 @@ portability of tables."
:group 'org-table)
(defcustom org-table-export-default-format "orgtbl-to-tsv"
- "Default export parameters for org-table-export. These can be
-overridden on for a specific table by setting the TABLE_EXPORT_FORMAT
-property. See the manual section on orgtbl radio tables for the different
-export transformations and available parameters."
+ "Default export parameters for `org-table-export'.
+These can be overridden for a specific table by setting the
+TABLE_EXPORT_FORMAT property. See the manual section on orgtbl
+radio tables for the different export transformations and
+available parameters."
:group 'org-table-import-export
:type 'string)
@@ -290,8 +291,7 @@ export transformations and available parameters."
(defconst org-table-calculate-mark-regexp "^[ \t]*| *[!$^_#*] *\\(|\\|$\\)"
"Detects a table line marked for automatic recalculation.")
(defconst org-table-border-regexp "^[ \t]*[^| \t]"
- "Searching from within a table (any type) this finds the first line
-outside the table.")
+ "Searching from within a table (any type) this finds the first line outside the table.")
(defvar org-table-last-highlighted-reference nil)
(defvar org-table-formula-history nil)
@@ -305,11 +305,11 @@ outside the table.")
"Alist with locations of named fields.")
(defvar org-table-current-line-types nil
- "Table row types, non-nil only for the duration of a comand.")
+ "Table row types, non-nil only for the duration of a command.")
(defvar org-table-current-begin-line nil
- "Table begin line, non-nil only for the duration of a comand.")
+ "Table begin line, non-nil only for the duration of a command.")
(defvar org-table-current-begin-pos nil
- "Table begin position, non-nil only for the duration of a comand.")
+ "Table begin position, non-nil only for the duration of a command.")
(defvar org-table-dlines nil
"Vector of data line line numbers in the current table.")
(defvar org-table-hlines nil
@@ -327,6 +327,37 @@ outside the table.")
"\\(" "@?[-0-9I$&]+" "\\|" "[a-zA-Z]\\{1,2\\}\\([0-9]+\\|&\\)" "\\|" "\\$[a-zA-Z0-9]+" "\\)")
"Match a range for reference display.")
+(defun org-table-colgroup-line-p (line)
+ "Is this a table line colgroup information?"
+ (save-match-data
+ (and (string-match "[<>]\\|&[lg]t;" line)
+ (string-match "\\`[ \t]*|[ \t]*/[ \t]*\\(|[ \t<>0-9|lgt&;]+\\)\\'"
+ line)
+ (not (delq
+ nil
+ (mapcar
+ (lambda (s)
+ (not (member s '("" "<" ">" "<>" "&lt;" "&gt;" "&lt;&gt;"))))
+ (org-split-string (match-string 1 line) "[ \t]*|[ \t]*")))))))
+
+(defun org-table-cookie-line-p (line)
+ "Is this a table line with only alignment/width cookies?"
+ (save-match-data
+ (and (string-match "[<>]\\|&[lg]t;" line)
+ (or (string-match
+ "\\`[ \t]*|[ \t]*/[ \t]*\\(|[ \t<>0-9|lrcgt&;]+\\)\\'" line)
+ (string-match "\\(\\`[ \t<>lrc0-9|gt&;]+\\'\\)" line))
+ (not (delq nil (mapcar
+ (lambda (s)
+ (not (or (equal s "")
+ (string-match
+ "\\`<\\([lrc]?[0-9]+\\|[lrc]\\)>\\'" s)
+ (string-match
+ "\\`&lt;\\([lrc]?[0-9]+\\|[lrc]\\)&gt;\\'"
+ s))))
+ (org-split-string (match-string 1 line)
+ "[ \t]*|[ \t]*")))))))
+
(defconst org-table-translate-regexp
(concat "\\(" "@[-0-9I$]+" "\\|" "[a-zA-Z]\\{1,2\\}\\([0-9]+\\|&\\)" "\\)")
"Match a reference that needs translation, for reference display.")
@@ -342,8 +373,9 @@ and table.el tables."
(if (y-or-n-p "Convert table to Org-mode table? ")
(org-table-convert)))
((org-at-table-p)
- (if (y-or-n-p "Convert table to table.el table? ")
- (org-table-convert)))
+ (when (y-or-n-p "Convert table to table.el table? ")
+ (org-table-align)
+ (org-table-convert)))
(t (call-interactively 'table-insert))))
(defun org-table-create-or-convert-from-region (arg)
@@ -426,7 +458,7 @@ nil When nil, the command tries to be smart and figure out the
(t 1))))
(goto-char beg)
(if (equal separator '(4))
- (while (<= (point) end)
+ (while (< (point) end)
;; parse the csv stuff
(cond
((looking-at "^") (insert "| "))
@@ -470,7 +502,7 @@ FILE can be the output file name. If not given, it will be taken from
a TABLE_EXPORT_FILE property in the current entry or higher up in the
hierarchy, or the user will be prompted for a file name.
FORMAT can be an export format, of the same kind as it used when
-orgtbl-mode sends a table in a different format. The default format can
+`orgtbl-mode' sends a table in a different format. The default format can
be found in the variable `org-table-export-default-format', but the function
first checks if there is an export format specified in a TABLE_EXPORT_FORMAT
property, locally or anywhere up in the hierarchy."
@@ -567,7 +599,7 @@ This is being used to correctly align a single field after TAB or RET.")
"List of max width of fields in each column.
This is being used to correctly align a single field after TAB or RET.")
(defvar org-table-formula-debug nil
- "Non-nil means, debug table formulas.
+ "Non-nil means debug table formulas.
When nil, simply write \"#ERROR\" in corrupted fields.")
(make-variable-buffer-local 'org-table-formula-debug)
(defvar org-table-overlay-coordinates nil
@@ -575,6 +607,7 @@ When nil, simply write \"#ERROR\" in corrupted fields.")
(make-variable-buffer-local 'org-table-overlay-coordinates)
(defvar org-last-recalc-line nil)
+(defvar org-table-do-narrow t) ; for dynamic scoping
(defconst org-narrow-column-arrow "=>"
"Used as display property in narrowed table columns.")
@@ -601,7 +634,8 @@ When nil, simply write \"#ERROR\" in corrupted fields.")
(make-string sp2 ?\ ) "%%%s%ds" (make-string sp1 ?\ ) "|"))
(hfmt1 (concat
(make-string sp2 ?-) "%s" (make-string sp1 ?-) "+"))
- emptystrings links dates emph narrow falign falign1 fmax f1 len c e)
+ emptystrings links dates emph raise narrow
+ falign falign1 fmax f1 len c e space)
(untabify beg end)
(remove-text-properties beg end '(org-cwidth t org-dwidth t display t))
;; Check if we have links or dates
@@ -611,6 +645,9 @@ When nil, simply write \"#ERROR\" in corrupted fields.")
(setq emph (and org-hide-emphasis-markers
(re-search-forward org-emph-re end t)))
(goto-char beg)
+ (setq raise (and org-use-sub-superscripts
+ (re-search-forward org-match-substring-regexp end t)))
+ (goto-char beg)
(setq dates (and org-display-custom-times
(re-search-forward org-ts-regexp-both end t)))
;; Make sure the link properties are right
@@ -618,13 +655,15 @@ When nil, simply write \"#ERROR\" in corrupted fields.")
;; Make sure the date properties are right
(when dates (goto-char beg) (while (org-activate-dates end)))
(when emph (goto-char beg) (while (org-do-emphasis-faces end)))
+ (when raise (goto-char beg) (while (org-raise-scripts end)))
;; Check if we are narrowing any columns
(goto-char beg)
- (setq narrow (and org-format-transports-properties-p
- (re-search-forward "<[rl]?[0-9]+>" end t)))
+ (setq narrow (and org-table-do-narrow
+ org-format-transports-properties-p
+ (re-search-forward "<[lrc]?[0-9]+>" end t)))
(goto-char beg)
- (setq falign (re-search-forward "<[rl][0-9]*>" end t))
+ (setq falign (re-search-forward "<[lrc][0-9]*>" end t))
(goto-char beg)
;; Get the rows
(setq lines (org-split-string
@@ -660,13 +699,14 @@ When nil, simply write \"#ERROR\" in corrupted fields.")
(while (< (setq i (1+ i)) maxfields) ;; Loop over all columns
(setq column (mapcar (lambda (x) (or (nth i x) "")) fields))
;; Check if there is an explicit width specified
+ (setq fmax nil)
(when (or narrow falign)
(setq c column fmax nil falign1 nil)
(while c
(setq e (pop c))
- (when (and (stringp e) (string-match "^<\\([rl]\\)?\\([0-9]+\\)?>$" e))
+ (when (and (stringp e) (string-match "^<\\([lrc]\\)?\\([0-9]+\\)?>$" e))
(if (match-end 1) (setq falign1 (match-string 1 e)))
- (if (match-end 2)
+ (if (and org-table-do-narrow (match-end 2))
(setq fmax (string-to-number (match-string 2 e)) c nil))))
;; Find fields that are wider than fmax, and shorten them
(when fmax
@@ -685,7 +725,8 @@ When nil, simply write \"#ERROR\" in corrupted fields.")
(list 'display org-narrow-column-arrow)
xx)))))
;; Get the maximum width for each column
- (push (apply 'max 1 (mapcar 'org-string-width column)) lengths)
+ (push (apply 'max (or fmax 1) 1 (mapcar 'org-string-width column))
+ lengths)
;; Get the fraction of numbers, to decide about alignment of the column
(if falign1
(push (equal (downcase falign1) "r") typenums)
@@ -705,16 +746,22 @@ When nil, simply write \"#ERROR\" in corrupted fields.")
;; With invisible characters, `format' does not get the field width right
;; So we need to make these fields wide by hand.
- (when (or links emph)
+ (when (or links emph raise)
(loop for i from 0 upto (1- maxfields) do
(setq len (nth i lengths))
(loop for j from 0 upto (1- (length fields)) do
(setq c (nthcdr i (car (nthcdr j fields))))
(if (and (stringp (car c))
- (text-property-any 0 (length (car c)) 'invisible 'org-link (car c))
-; (string-match org-bracket-link-regexp (car c))
+ (or (text-property-any 0 (length (car c))
+ 'invisible 'org-link (car c))
+ (text-property-any 0 (length (car c))
+ 'org-dwidth t (car c)))
(< (org-string-width (car c)) len))
- (setcar c (concat (car c) (make-string (- len (org-string-width (car c))) ?\ )))))))
+ (progn
+ (setq space (make-string (- len (org-string-width (car c))) ?\ ))
+ (setcar c (if (nth i typenums)
+ (concat space (car c))
+ (concat (car c) space))))))))
;; Compute the formats needed for output of the table
(setq rfmt (concat indent "|") hfmt (concat indent "|"))
@@ -760,14 +807,6 @@ When nil, simply write \"#ERROR\" in corrupted fields.")
(setq org-table-may-need-update nil)
))
-
-
-
-
-
-
-
-
(defun org-table-begin (&optional table-type)
"Find the beginning of the table and return its position.
With argument TABLE-TYPE, go to the beginning of a table.el-type table."
@@ -826,6 +865,7 @@ Optional argument NEW may specify text to replace the current field content."
(if (<= (length new) l) ;; FIXME: length -> str-width?
(setq n (format f new))
(setq n (concat new "|") org-table-may-need-update t)))
+ (if (equal (string-to-char n) ?-) (setq n (concat " " n)))
(or (equal n o)
(let (org-table-may-need-update)
(replace-match n t t))))
@@ -1003,6 +1043,47 @@ This actually throws an error, so it aborts the current command."
(defvar org-table-clip nil
"Clipboard for table regions.")
+(defun org-table-get (line column)
+ "Get the field in table line LINE, column COLUMN.
+If LINE is larger than the number of data lines in the table, the function
+returns nil. However, if COLUMN is too large, we will simply return an
+empty string.
+If LINE is nil, use the current line.
+If column is nil, use the current column."
+ (setq column (or column (org-table-current-column)))
+ (save-excursion
+ (and (or (not line) (org-table-goto-line line))
+ (org-trim (org-table-get-field column)))))
+
+(defun org-table-put (line column value &optional align)
+ "Put VALUE into line LINE, column COLUMN.
+When ALIGN is set, also realign the table."
+ (setq column (or column (org-table-current-column)))
+ (prog1 (save-excursion
+ (and (or (not line) (org-table-goto-line line))
+ (progn (org-table-goto-column column nil 'force) t)
+ (org-table-get-field column value)))
+ (and align (org-table-align))))
+
+(defun org-table-current-line ()
+ "Return the index of the current data line."
+ (let ((pos (point)) (end (org-table-end)) (cnt 0))
+ (save-excursion
+ (goto-char (org-table-begin))
+ (while (and (re-search-forward org-table-dataline-regexp end t)
+ (setq cnt (1+ cnt))
+ (< (point-at-eol) pos))))
+ cnt))
+
+(defun org-table-goto-line (N)
+ "Go to the Nth data line in the current table.
+Return t when the line exists, nil if it does not exist."
+ (goto-char (org-table-begin))
+ (let ((end (org-table-end)) (cnt 0))
+ (while (and (re-search-forward org-table-dataline-regexp end t)
+ (< (setq cnt (1+ cnt)) N)))
+ (= cnt N)))
+
(defun org-table-blank-field ()
"Blank the current table field or active region."
(interactive)
@@ -1074,16 +1155,19 @@ is always the old value."
(defun org-table-current-column ()
"Find out which column we are in."
+ (interactive)
+ (if (interactive-p) (org-table-check-inside-data-field))
(save-excursion
(let ((cnt 0) (pos (point)))
(beginning-of-line 1)
(while (search-forward "|" pos t)
(setq cnt (1+ cnt)))
+ (if (interactive-p) (message "In table column %d" cnt))
cnt)))
(defun org-table-current-dline ()
"Find out what table data line we are in.
-Only datalines count for this."
+Only data lines count for this."
(interactive)
(if (interactive-p) (org-table-check-inside-data-field))
(save-excursion
@@ -1102,22 +1186,20 @@ of the field.
If there are less than N fields, just go to after the last delimiter.
However, when FORCE is non-nil, create new columns if necessary."
(interactive "p")
- (let ((pos (point-at-eol)))
- (beginning-of-line 1)
- (when (> n 0)
- (while (and (> (setq n (1- n)) -1)
- (or (search-forward "|" pos t)
- (and force
- (progn (end-of-line 1)
- (skip-chars-backward "^|")
- (insert " | "))))))
-; (backward-char 2) t)))))
- (when (and force (not (looking-at ".*|")))
- (save-excursion (end-of-line 1) (insert " | ")))
- (if on-delim
- (backward-char 1)
- (if (looking-at " ") (forward-char 1))))))
-
+ (beginning-of-line 1)
+ (when (> n 0)
+ (while (and (> (setq n (1- n)) -1)
+ (or (search-forward "|" (point-at-eol) t)
+ (and force
+ (progn (end-of-line 1)
+ (skip-chars-backward "^|")
+ (insert " | ")
+ t)))))
+ (when (and force (not (looking-at ".*|")))
+ (save-excursion (end-of-line 1) (insert " | ")))
+ (if on-delim
+ (backward-char 1)
+ (if (looking-at " ") (forward-char 1)))))
(defun org-table-insert-column ()
"Insert a new column into the table."
@@ -1146,7 +1228,7 @@ However, when FORCE is non-nil, create new columns if necessary."
(org-table-fix-formulas "$LR" nil (1- col) 1)))
(defun org-table-find-dataline ()
- "Find a dataline in the current table, which is needed for column commands."
+ "Find a data line in the current table, which is needed for column commands."
(if (and (org-at-table-p)
(not (org-at-table-hline-p)))
t
@@ -1686,23 +1768,6 @@ the table and kill the editing buffer."
(org-table-align)
(message "New field value inserted")))
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
(defvar org-timecnt) ; dynamically scoped parameter
(defun org-table-sum (&optional beg end nlast)
@@ -1787,7 +1852,7 @@ If NLAST is a number, only the NLAST fields will actually be summed."
"Return the formula active for the current field.
Assumes that specials are in place.
If KEY is given, return the key to this formula.
-Otherwise return the formula preceeded with \"=\" or \":=\"."
+Otherwise return the formula preceded with \"=\" or \":=\"."
(let* ((name (car (rassoc (list (org-current-line)
(org-table-current-column))
org-table-named-field-locations)))
@@ -2243,6 +2308,20 @@ not overwrite the stored one."
(setq form (copy-sequence formula)
lispp (and (> (length form) 2)(equal (substring form 0 2) "'(")))
(if (and lispp literal) (setq lispp 'literal))
+
+ ;; Insert row and column number of formula result field
+ (while (string-match "[@$]#" form)
+ (setq form
+ (replace-match
+ (format "%d"
+ (save-match-data
+ (if (equal (substring form (match-beginning 0)
+ (1+ (match-beginning 0)))
+ "@")
+ (org-table-current-dline)
+ (org-table-current-column))))
+ t t form)))
+
;; Check for old vertical references
(setq form (org-table-rewrite-old-row-references form))
;; Insert remote references
@@ -2315,7 +2394,7 @@ $1-> %s\n" orig formula form0 form))
(org-fit-window-to-buffer bw)
(unless (and (interactive-p) (not ndown))
(unless (let (inhibit-redisplay)
- (y-or-n-p "Debugging Formula. Continue to next? "))
+ (y-or-n-p "Debugging Formula. Continue to next? "))
(org-table-align)
(error "Abort"))
(delete-window bw)
@@ -2340,7 +2419,7 @@ $1-> %s\n" orig formula form0 form))
"Get a calc vector from a column, according to descriptor DESC.
Optional arguments TBEG and COL can give the beginning of the table and
the current column, to avoid unnecessary parsing.
-HIGHLIGHT means, just highlight the range."
+HIGHLIGHT means just highlight the range."
(if (not (equal (string-to-char desc) ?@))
(setq desc (concat "@" desc)))
(save-excursion
@@ -2412,7 +2491,7 @@ and TABLE is a vector with line types."
;; 1 2 3 4 5 6
(and (not (match-end 3)) (not (match-end 6)))
(and (match-end 3) (match-end 6) (not (match-end 5))))
- (error "invalid row descriptor `%s'" desc))
+ (error "Invalid row descriptor `%s'" desc))
(let* ((hdir (and (match-end 2) (match-string 2 desc)))
(hn (if (match-end 3) (- (match-end 3) (match-beginning 3)) nil))
(odir (and (match-end 5) (match-string 5 desc)))
@@ -2426,7 +2505,7 @@ and TABLE is a vector with line types."
(setq i 0 hdir "+")
(if (eq (aref table 0) 'hline) (setq hn (1- hn)))))
(if (and (not hn) on (not odir))
- (error "should never happen");;(aref org-table-dlines on)
+ (error "Should never happen");;(aref org-table-dlines on)
(if (and hn (> hn 0))
(setq i (org-table-find-row-type table i 'hline (equal hdir "-")
nil hn cline desc)))
@@ -2497,7 +2576,8 @@ LISPP means to return something appropriate for a Lisp list."
(defun org-table-recalculate (&optional all noalign)
"Recalculate the current table line by applying all stored formulas.
With prefix arg ALL, do this for all lines in the table.
-With the prefix argument ALL is `(16)' (a double `C-c C-u' prefix), or if
+With the prefix argument ALL is `(16)' \
+\(a double \\[universal-prefix] \\[universal-prefix] prefix), or if
it is the symbol `iterate', recompute the table until it no longer changes.
If NOALIGN is not nil, do not re-align the table after the computations
are done. This is typically used internally to save time, if it is
@@ -2625,6 +2705,36 @@ known that the table will be realigned a little later anyway."
(throw 'exit t)))
(error "No convergence after %d iterations" i))))
+(defun org-table-recalculate-buffer-tables ()
+ "Recalculate all tables in the current buffer."
+ (interactive)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (org-table-map-tables (lambda () (org-table-recalculate t)) t))))
+
+(defun org-table-iterate-buffer-tables ()
+ "Iterate all tables in the buffer, to converge inter-table dependencies."
+ (interactive)
+ (let* ((imax 10)
+ (checksum (md5 (buffer-string)))
+
+ c1
+ (i imax))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (catch 'exit
+ (while (> i 0)
+ (setq i (1- i))
+ (org-table-map-tables (lambda () (org-table-recalculate t)) t)
+ (if (equal checksum (setq c1 (md5 (buffer-string))))
+ (progn
+ (message "Convergence after %d iterations" (- imax i))
+ (throw 'exit t))
+ (setq checksum c1)))
+ (error "No convergence after %d iterations" imax))))))
+
(defun org-table-formula-substitute-names (f)
"Replace $const with values in string F."
(let ((start 0) a (f1 f) (pp (/= (string-to-char f) ?')))
@@ -2663,6 +2773,7 @@ Parameters get priority."
(org-defkey map "\C-x\C-s" 'org-table-fedit-finish)
(org-defkey map "\C-c\C-s" 'org-table-fedit-finish)
(org-defkey map "\C-c\C-c" 'org-table-fedit-finish)
+ (org-defkey map "\C-c'" 'org-table-fedit-finish)
(org-defkey map "\C-c\C-q" 'org-table-fedit-abort)
(org-defkey map "\C-c?" 'org-table-show-reference)
(org-defkey map [(meta shift up)] 'org-table-fedit-line-up)
@@ -2759,7 +2870,7 @@ Parameters get priority."
(if (eq org-table-use-standard-references t)
(org-table-fedit-toggle-ref-type))
(org-goto-line startline)
- (message "Edit formulas and finish with `C-c C-c'. See menu for more commands.")))
+ (message "Edit formulas, finish with `C-c C-c' or `C-c ' '. See menu for more commands.")))
(defun org-table-fedit-post-command ()
(when (not (memq this-command '(lisp-complete-symbol)))
@@ -2797,6 +2908,12 @@ full TBLFM line."
(not (equal ?. (aref s (max (- (match-beginning 0) 2) 0)))))
;; 3.e5 or something like this.
(setq start (match-end 0)))
+ ((or (> (- (match-end 1) (match-beginning 1)) 2)
+ ;; (member (match-string 1 s)
+ ;; '("arctan" "exp" "expm" "lnp" "log" "stir"))
+ )
+ ;; function name, just advance
+ (setq start (match-end 0)))
(t
(setq start (match-beginning 0)
s (replace-match
@@ -2901,7 +3018,7 @@ For example: 28 -> AB."
(org-rematch-and-replace 5 (eq dir 'left))))))
(defun org-rematch-and-replace (n &optional decr hline)
- "Re-match the group N, and replace it with the shifted refrence."
+ "Re-match the group N, and replace it with the shifted reference."
(or (match-end n) (error "Cannot shift reference in this direction"))
(goto-char (match-beginning n))
(and (looking-at (regexp-quote (match-string n)))
@@ -2909,7 +3026,7 @@ For example: 28 -> AB."
t t)))
(defun org-table-shift-refpart (ref &optional decr hline)
- "Shift a refrence part REF.
+ "Shift a reference part REF.
If DECR is set, decrease the references row/column, else increase.
If HLINE is set, this may be a hline reference, it certainly is not
a translation reference."
@@ -2977,7 +3094,7 @@ With prefix ARG, apply the new formulas to the table."
(select-window sel-win)
(goto-char pos)
(unless (org-at-table-p)
- (error "Lost table position - cannot install formulae"))
+ (error "Lost table position - cannot install formulas"))
(org-table-store-formulas eql)
(move-marker pos nil)
(kill-buffer "*Edit Formulas*")
@@ -3219,8 +3336,8 @@ Use COMMAND to do the motion, repeat if necessary to end up in a data line."
(defun org-table-add-rectangle-overlay (beg end &optional face)
"Add a new overlay."
- (let ((ov (org-make-overlay beg end)))
- (org-overlay-put ov 'face (or face 'secondary-selection))
+ (let ((ov (make-overlay beg end)))
+ (overlay-put ov 'face (or face 'secondary-selection))
(push ov org-table-rectangle-overlays)))
(defun org-table-highlight-rectangle (&optional beg end face)
@@ -3255,7 +3372,7 @@ Use COMMAND to do the motion, repeat if necessary to end up in a data line."
"Remove the rectangle overlays."
(unless org-inhibit-highlight-removal
(remove-hook 'before-change-functions 'org-table-remove-rectangle-highlight)
- (mapc 'org-delete-overlay org-table-rectangle-overlays)
+ (mapc 'delete-overlay org-table-rectangle-overlays)
(setq org-table-rectangle-overlays nil)))
(defvar org-table-coordinate-overlays nil
@@ -3265,14 +3382,14 @@ Use COMMAND to do the motion, repeat if necessary to end up in a data line."
(defun org-table-overlay-coordinates ()
"Add overlays to the table at point, to show row/column coordinates."
(interactive)
- (mapc 'org-delete-overlay org-table-coordinate-overlays)
+ (mapc 'delete-overlay org-table-coordinate-overlays)
(setq org-table-coordinate-overlays nil)
(save-excursion
(let ((id 0) (ih 0) hline eol s1 s2 str ic ov beg)
(goto-char (org-table-begin))
(while (org-at-table-p)
(setq eol (point-at-eol))
- (setq ov (org-make-overlay (point-at-bol) (1+ (point-at-bol))))
+ (setq ov (make-overlay (point-at-bol) (1+ (point-at-bol))))
(push ov org-table-coordinate-overlays)
(setq hline (looking-at org-table-hline-regexp))
(setq str (if hline (format "I*%-2d" (setq ih (1+ ih)))
@@ -3286,7 +3403,7 @@ Use COMMAND to do the motion, repeat if necessary to end up in a data line."
s1 (concat "$" (int-to-string ic))
s2 (org-number-to-letters ic)
str (if (eq org-table-use-standard-references t) s2 s1))
- (setq ov (org-make-overlay beg (+ beg (length str))))
+ (setq ov (make-overlay beg (+ beg (length str))))
(push ov org-table-coordinate-overlays)
(org-overlay-display ov str 'org-special-keyword 'evaporate)))
(beginning-of-line 2)))))
@@ -3300,7 +3417,7 @@ Use COMMAND to do the motion, repeat if necessary to end up in a data line."
(if (and (org-at-table-p) org-table-overlay-coordinates)
(org-table-align))
(unless org-table-overlay-coordinates
- (mapc 'org-delete-overlay org-table-coordinate-overlays)
+ (mapc 'delete-overlay org-table-coordinate-overlays)
(setq org-table-coordinate-overlays nil)))
(defun org-table-toggle-formula-debugger ()
@@ -3338,10 +3455,6 @@ Use COMMAND to do the motion, repeat if necessary to end up in a data line."
;; active, this binding is ignored inside tables and replaced with a
;; modified self-insert.
-(defvar orgtbl-mode nil
- "Variable controlling `orgtbl-mode', a minor mode enabling the `org-mode'
-table editor in arbitrary modes.")
-(make-variable-buffer-local 'orgtbl-mode)
(defvar orgtbl-mode-map (make-keymap)
"Keymap for `orgtbl-mode'.")
@@ -3352,7 +3465,7 @@ table editor in arbitrary modes.")
(orgtbl-mode 1))
(defvar org-old-auto-fill-inhibit-regexp nil
- "Local variable used by `orgtbl-mode'")
+ "Local variable used by `orgtbl-mode'.")
(defconst orgtbl-line-start-regexp
"[ \t]*\\(|\\|#\\+\\(TBLFM\\|ORGTBL\\|TBLNAME\\):\\)"
@@ -3361,51 +3474,54 @@ table editor in arbitrary modes.")
(defconst orgtbl-extra-font-lock-keywords
(list (list (concat "^" orgtbl-line-start-regexp ".*")
0 (quote 'org-table) 'prepend))
- "Extra font-lock-keywords to be added when orgtbl-mode is active.")
+ "Extra `font-lock-keywords' to be added when `orgtbl-mode' is active.")
+
+;; Install it as a minor mode.
+(put 'orgtbl-mode :included t)
+(put 'orgtbl-mode :menu-tag "Org Table Mode")
;;;###autoload
-(defun orgtbl-mode (&optional arg)
+(define-minor-mode orgtbl-mode
"The `org-mode' table editor as a minor mode for use in other modes."
- (interactive)
+ :lighter " OrgTbl" :keymap orgtbl-mode-map
(org-load-modules-maybe)
- (if (org-mode-p)
- ;; Exit without error, in case some hook functions calls this
- ;; by accident in org-mode.
- (message "Orgtbl-mode is not useful in org-mode, command ignored")
- (setq orgtbl-mode
- (if arg (> (prefix-numeric-value arg) 0) (not orgtbl-mode)))
- (if orgtbl-mode
- (progn
- (and (orgtbl-setup) (defun orgtbl-setup () nil))
- ;; Make sure we are first in minor-mode-map-alist
- (let ((c (assq 'orgtbl-mode minor-mode-map-alist)))
- (and c (setq minor-mode-map-alist
- (cons c (delq c minor-mode-map-alist)))))
- (org-set-local (quote org-table-may-need-update) t)
- (org-add-hook 'before-change-functions 'org-before-change-function
- nil 'local)
- (org-set-local 'org-old-auto-fill-inhibit-regexp
- auto-fill-inhibit-regexp)
- (org-set-local 'auto-fill-inhibit-regexp
- (if auto-fill-inhibit-regexp
- (concat orgtbl-line-start-regexp "\\|"
- auto-fill-inhibit-regexp)
- orgtbl-line-start-regexp))
- (org-add-to-invisibility-spec '(org-cwidth))
- (when (fboundp 'font-lock-add-keywords)
- (font-lock-add-keywords nil orgtbl-extra-font-lock-keywords)
- (org-restart-font-lock))
- (easy-menu-add orgtbl-mode-menu)
- (run-hooks 'orgtbl-mode-hook))
- (setq auto-fill-inhibit-regexp org-old-auto-fill-inhibit-regexp)
- (org-table-cleanup-narrow-column-properties)
- (org-remove-from-invisibility-spec '(org-cwidth))
- (remove-hook 'before-change-functions 'org-before-change-function t)
- (when (fboundp 'font-lock-remove-keywords)
- (font-lock-remove-keywords nil orgtbl-extra-font-lock-keywords)
- (org-restart-font-lock))
- (easy-menu-remove orgtbl-mode-menu)
- (force-mode-line-update 'all))))
+ (cond
+ ((org-mode-p)
+ ;; Exit without error, in case some hook functions calls this
+ ;; by accident in org-mode.
+ (message "Orgtbl-mode is not useful in org-mode, command ignored"))
+ (orgtbl-mode
+ (and (orgtbl-setup) (defun orgtbl-setup () nil)) ;; FIXME: Yuck!?!
+ ;; Make sure we are first in minor-mode-map-alist
+ (let ((c (assq 'orgtbl-mode minor-mode-map-alist)))
+ ;; FIXME: maybe it should use emulation-mode-map-alists?
+ (and c (setq minor-mode-map-alist
+ (cons c (delq c minor-mode-map-alist)))))
+ (org-set-local (quote org-table-may-need-update) t)
+ (org-add-hook 'before-change-functions 'org-before-change-function
+ nil 'local)
+ (org-set-local 'org-old-auto-fill-inhibit-regexp
+ auto-fill-inhibit-regexp)
+ (org-set-local 'auto-fill-inhibit-regexp
+ (if auto-fill-inhibit-regexp
+ (concat orgtbl-line-start-regexp "\\|"
+ auto-fill-inhibit-regexp)
+ orgtbl-line-start-regexp))
+ (add-to-invisibility-spec '(org-cwidth))
+ (when (fboundp 'font-lock-add-keywords)
+ (font-lock-add-keywords nil orgtbl-extra-font-lock-keywords)
+ (org-restart-font-lock))
+ (easy-menu-add orgtbl-mode-menu))
+ (t
+ (setq auto-fill-inhibit-regexp org-old-auto-fill-inhibit-regexp)
+ (org-table-cleanup-narrow-column-properties)
+ (org-remove-from-invisibility-spec '(org-cwidth))
+ (remove-hook 'before-change-functions 'org-before-change-function t)
+ (when (fboundp 'font-lock-remove-keywords)
+ (font-lock-remove-keywords nil orgtbl-extra-font-lock-keywords)
+ (org-restart-font-lock))
+ (easy-menu-remove orgtbl-mode-menu)
+ (force-mode-line-update 'all))))
(defun org-table-cleanup-narrow-column-properties ()
"Remove all properties related to narrow-column invisibility."
@@ -3420,11 +3536,6 @@ table editor in arbitrary modes.")
(while (setq s (text-property-any s (point-max) 'invisible 'org-cwidth))
(remove-text-properties s (1+ s) '(invisible t)))))
-;; Install it as a minor mode.
-(put 'orgtbl-mode :included t)
-(put 'orgtbl-mode :menu-tag "Org Table Mode")
-(add-minor-mode 'orgtbl-mode " OrgTbl" orgtbl-mode-map)
-
(defun orgtbl-make-binding (fun n &rest keys)
"Create a function for binding in the table minor mode.
FUN is the command to call inside a table. N is used to create a unique
@@ -3459,34 +3570,33 @@ to execute outside of tables."
"Setup orgtbl keymaps."
(let ((nfunc 0)
(bindings
- (list
- '([(meta shift left)] org-table-delete-column)
- '([(meta left)] org-table-move-column-left)
- '([(meta right)] org-table-move-column-right)
- '([(meta shift right)] org-table-insert-column)
- '([(meta shift up)] org-table-kill-row)
- '([(meta shift down)] org-table-insert-row)
- '([(meta up)] org-table-move-row-up)
- '([(meta down)] org-table-move-row-down)
- '("\C-c\C-w" org-table-cut-region)
- '("\C-c\M-w" org-table-copy-region)
- '("\C-c\C-y" org-table-paste-rectangle)
- '("\C-c-" org-table-insert-hline)
- '("\C-c}" org-table-toggle-coordinate-overlays)
- '("\C-c{" org-table-toggle-formula-debugger)
- '("\C-m" org-table-next-row)
- '([(shift return)] org-table-copy-down)
- '("\C-c?" org-table-field-info)
- '("\C-c " org-table-blank-field)
- '("\C-c+" org-table-sum)
- '("\C-c=" org-table-eval-formula)
- '("\C-c'" org-table-edit-formulas)
- '("\C-c`" org-table-edit-field)
- '("\C-c*" org-table-recalculate)
- '("\C-c^" org-table-sort-lines)
- '("\M-a" org-table-beginning-of-field)
- '("\M-e" org-table-end-of-field)
- '([(control ?#)] org-table-rotate-recalc-marks)))
+ '(([(meta shift left)] org-table-delete-column)
+ ([(meta left)] org-table-move-column-left)
+ ([(meta right)] org-table-move-column-right)
+ ([(meta shift right)] org-table-insert-column)
+ ([(meta shift up)] org-table-kill-row)
+ ([(meta shift down)] org-table-insert-row)
+ ([(meta up)] org-table-move-row-up)
+ ([(meta down)] org-table-move-row-down)
+ ("\C-c\C-w" org-table-cut-region)
+ ("\C-c\M-w" org-table-copy-region)
+ ("\C-c\C-y" org-table-paste-rectangle)
+ ("\C-c-" org-table-insert-hline)
+ ("\C-c}" org-table-toggle-coordinate-overlays)
+ ("\C-c{" org-table-toggle-formula-debugger)
+ ("\C-m" org-table-next-row)
+ ([(shift return)] org-table-copy-down)
+ ("\C-c?" org-table-field-info)
+ ("\C-c " org-table-blank-field)
+ ("\C-c+" org-table-sum)
+ ("\C-c=" org-table-eval-formula)
+ ("\C-c'" org-table-edit-formulas)
+ ("\C-c`" org-table-edit-field)
+ ("\C-c*" org-table-recalculate)
+ ("\C-c^" org-table-sort-lines)
+ ("\M-a" org-table-beginning-of-field)
+ ("\M-e" org-table-end-of-field)
+ ([(control ?#)] org-table-rotate-recalc-marks)))
elt key fun cmd)
(while (setq elt (pop bindings))
(setq nfunc (1+ nfunc))
@@ -3731,13 +3841,13 @@ overwritten, and the table is not marked as requiring realignment."
(funcall func table nil)))
(defun orgtbl-gather-send-defs ()
- "Gathers a plist of :name, :transform, :params for each destination before
+ "Gather a plist of :name, :transform, :params for each destination before
a radio table."
(save-excursion
(goto-char (org-table-begin))
(let (rtn)
(beginning-of-line 0)
- (while (looking-at "[ \t]*#\\+ORGTBL[: \t][ \t]*SEND +\\([a-zA-Z0-9_]+\\) +\\([^ \t\r\n]+\\)\\( +.*\\)?")
+ (while (looking-at "[ \t]*#\\+ORGTBL[: \t][ \t]*SEND[ \t]+\\([^ \t\r\n]+\\)[ \t]+\\([^ \t\r\n]+\\)\\([ \t]+.*\\)?")
(let ((name (org-no-properties (match-string 1)))
(transform (intern (match-string 2)))
(params (if (match-end 3)
@@ -3888,17 +3998,17 @@ First element has index 0, or I0 if given."
(defvar *orgtbl-rtn* nil
"Formatting routines push the output lines here.")
;; Formatting parameters for the current table section.
-(defvar *orgtbl-hline* nil "Text used for horizontal lines")
-(defvar *orgtbl-sep* nil "Text used as a column separator")
-(defvar *orgtbl-default-fmt* nil "Default format for each entry")
-(defvar *orgtbl-fmt* nil "Format for each entry")
-(defvar *orgtbl-efmt* nil "Format for numbers")
-(defvar *orgtbl-lfmt* nil "Format for an entire line, overrides fmt")
-(defvar *orgtbl-llfmt* nil "Specializes lfmt for the last row")
-(defvar *orgtbl-lstart* nil "Text starting a row")
-(defvar *orgtbl-llstart* nil "Specializes lstart for the last row")
-(defvar *orgtbl-lend* nil "Text ending a row")
-(defvar *orgtbl-llend* nil "Specializes lend for the last row")
+(defvar *orgtbl-hline* nil "Text used for horizontal lines.")
+(defvar *orgtbl-sep* nil "Text used as a column separator.")
+(defvar *orgtbl-default-fmt* nil "Default format for each entry.")
+(defvar *orgtbl-fmt* nil "Format for each entry.")
+(defvar *orgtbl-efmt* nil "Format for numbers.")
+(defvar *orgtbl-lfmt* nil "Format for an entire line, overrides fmt.")
+(defvar *orgtbl-llfmt* nil "Specializes lfmt for the last row.")
+(defvar *orgtbl-lstart* nil "Text starting a row.")
+(defvar *orgtbl-llstart* nil "Specializes lstart for the last row.")
+(defvar *orgtbl-lend* nil "Text ending a row.")
+(defvar *orgtbl-llend* nil "Specializes lend for the last row.")
(defsubst orgtbl-get-fmt (fmt i)
"Retrieve the format from FMT corresponding to the Ith column."
@@ -4018,6 +4128,7 @@ directly by `orgtbl-send-table'. See manual."
(let* ((splicep (plist-get params :splice))
(hline (plist-get params :hline))
(remove-nil-linesp (plist-get params :remove-nil-lines))
+ (remove-newlines (plist-get params :remove-newlines))
(*orgtbl-hline* hline)
(*orgtbl-table* table)
(*orgtbl-sep* (plist-get params :sep))
@@ -4072,9 +4183,13 @@ directly by `orgtbl-send-table'. See manual."
(let ((tend (orgtbl-eval-str (plist-get params :tend))))
(if tend (push tend *orgtbl-rtn*)))))
- (mapconcat 'identity (nreverse (if remove-nil-linesp
- (remq nil *orgtbl-rtn*)
- *orgtbl-rtn*)) "\n")))
+ (mapconcat (if remove-newlines
+ (lambda (tend)
+ (replace-regexp-in-string "[\n\r\t\f]" "\\\\n" tend))
+ 'identity)
+ (nreverse (if remove-nil-linesp
+ (remq nil *orgtbl-rtn*)
+ *orgtbl-rtn*)) "\n")))
(defun orgtbl-to-tsv (table params)
"Convert the orgtbl-mode table to TAB separated material."
@@ -4125,7 +4240,7 @@ this function is called."
(orgtbl-to-generic table (org-combine-plists params2 params))))
(defun orgtbl-to-html (table params)
- "Convert the orgtbl-mode TABLE to LaTeX.
+ "Convert the orgtbl-mode TABLE to HTML.
TABLE is a list, each entry either the symbol `hline' for a horizontal
separator line, or a list of fields for that line.
PARAMS is a property list of parameters that can influence the conversion.
@@ -4147,7 +4262,7 @@ so you cannot specify parameters for it."
(lambda (x)
(if (eq x 'hline)
"|----+----|"
- (concat "| " (mapconcat 'identity x " | ") " |")))
+ (concat "| " (mapconcat 'org-html-expand x " | ") " |")))
table)
splicep))
(if (string-match "\n+\\'" html)
@@ -4200,6 +4315,7 @@ and :tend suppress strings without splicing; they can be set to
provide ORGTBL directives for the generated table."
(let* ((params2
(list
+ :remove-newlines t
:tstart nil :tend nil
:hline "|---"
:sep " | "
@@ -4247,23 +4363,23 @@ list of the fields in the rectangle ."
(setq buffer (marker-buffer id-loc)
loc (marker-position id-loc))
(move-marker id-loc nil)))
- (switch-to-buffer buffer)
- (save-excursion
- (save-restriction
- (widen)
- (goto-char loc)
- (forward-char 1)
- (unless (and (re-search-forward "^\\(\\*+ \\)\\|[ \t]*|" nil t)
- (not (match-beginning 1)))
- (error "Cannot find a table at NAME or ID %s" name-or-id))
- (setq tbeg (point-at-bol))
- (org-table-get-specials)
- (setq form (org-table-formula-substitute-names form))
- (if (and (string-match org-table-range-regexp form)
- (> (length (match-string 0 form)) 1))
- (save-match-data
- (org-table-get-range (match-string 0 form) tbeg 1))
- form))))))))
+ (with-current-buffer buffer
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char loc)
+ (forward-char 1)
+ (unless (and (re-search-forward "^\\(\\*+ \\)\\|[ \t]*|" nil t)
+ (not (match-beginning 1)))
+ (error "Cannot find a table at NAME or ID %s" name-or-id))
+ (setq tbeg (point-at-bol))
+ (org-table-get-specials)
+ (setq form (org-table-formula-substitute-names form))
+ (if (and (string-match org-table-range-regexp form)
+ (> (length (match-string 0 form)) 1))
+ (save-match-data
+ (org-table-get-range (match-string 0 form) tbeg 1))
+ form)))))))))
(provide 'org-table)
diff --git a/lisp/org/org-taskjuggler.el b/lisp/org/org-taskjuggler.el
new file mode 100644
index 00000000000..d03cd591b81
--- /dev/null
+++ b/lisp/org/org-taskjuggler.el
@@ -0,0 +1,648 @@
+;;; org-taskjuggler.el --- TaskJuggler exporter for org-mode
+;;
+;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;
+;; Emacs Lisp Archive Entry
+;; Filename: org-taskjuggler.el
+;; Version: 7.3
+;; Author: Christian Egli
+;; Maintainer: Christian Egli
+;; Keywords: org, taskjuggler, project planning
+;; Description: Converts an org-mode buffer into a taskjuggler project plan
+;; URL:
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;; Commentary:
+;;
+;; This library implements a TaskJuggler exporter for org-mode.
+;; TaskJuggler uses a text format to define projects, tasks and
+;; resources, so it is a natural fit for org-mode. It can produce all
+;; sorts of reports for tasks or resources in either HTML, CSV or PDF.
+;; The current version of TaskJuggler requires KDE but the next
+;; version is implemented in Ruby and should therefore run on any
+;; platform.
+;;
+;; The exporter is a bit different from other exporters, such as the
+;; HTML and LaTeX exporters for example, in that it does not export
+;; all the nodes of a document or strictly follow the order of the
+;; nodes in the document.
+;;
+;; Instead the TaskJuggler exporter looks for a tree that defines the
+;; tasks and a optionally tree that defines the resources for this
+;; project. It then creates a TaskJuggler file based on these trees
+;; and the attributes defined in all the nodes.
+;;
+;; * Installation
+;;
+;; Put this file into your load-path and the following line into your
+;; ~/.emacs:
+;;
+;; (require 'org-taskjuggler)
+;;
+;; The interactive functions are similar to those of the HTML and LaTeX
+;; exporters:
+;;
+;; M-x `org-export-as-taskjuggler'
+;; M-x `org-export-as-taskjuggler-and-open'
+;;
+;; * Tasks
+;;
+;; Let's illustrate the usage with a small example. Create your tasks
+;; as you usually do with org-mode. Assign efforts to each task using
+;; properties (it's easiest to do this in the column view). You should
+;; end up with something similar to the example by Peter Jones in
+;; http://www.contextualdevelopment.com/static/artifacts/articles/2008/project-planning/project-planning.org.
+;; Now mark the top node of your tasks with a tag named
+;; "taskjuggler_project" (or whatever you customized
+;; `org-export-taskjuggler-project-tag' to). You are now ready to
+;; export the project plan with `org-export-as-taskjuggler-and-open'
+;; which will export the project plan and open a gant chart in
+;; TaskJugglerUI.
+;;
+;; * Resources
+;;
+;; Next you can define resources and assign those to work on specific
+;; tasks. You can group your resources hierarchically. Tag the top
+;; node of the resources with "taskjuggler_resource" (or whatever you
+;; customized `org-export-taskjuggler-resource-tag' to). You can
+;; optionally assign an identifier (named "resource_id") to the
+;; resources (using the standard org properties commands) or you can
+;; let the exporter generate identifiers automatically (the exporter
+;; picks the first word of the headline as the identifier as long as
+;; it is unique, see the documentation of
+;; `org-taskjuggler-get-unique-id'). Using that identifier you can
+;; then allocate resources to tasks. This is again done with the
+;; "allocate" property on the tasks. Do this in column view or when on
+;; the task type
+;;
+;; C-c C-x p allocate RET <resource_id> RET
+;;
+;; Once the allocations are done you can again export to TaskJuggler
+;; and check in the Resource Allocation Graph which person is working
+;; on what task at what time.
+;;
+;; * Export of properties
+;;
+;; The exporter also takes TODO state information into consideration,
+;; i.e. if a task is marked as done it will have the corresponding
+;; attribute in TaskJuggler ("complete 100"). Also it will export any
+;; property on a task resource or resource node which is known to
+;; TaskJuggler, such as limits, vacation, shift, booking, efficiency,
+;; journalentry, rate for resources or account, start, note, duration,
+;; end, journalentry, milestone, reference, responsible, scheduling,
+;; etc for tasks.
+;;
+;; * Dependencies
+;;
+;; The exporter will handle dependencies that are defined in the tasks
+;; either with the ORDERED attribute (see TODO dependencies in the Org
+;; mode manual) or with the BLOCKER attribute (see org-depend.el) or
+;; alternatively with a depends attribute. Both the BLOCKER and the
+;; depends attribute can be either "previous-sibling" or a reference
+;; to an identifier (named "task_id") which is defined for another
+;; task in the project. BLOCKER and the depends attribute can define
+;; multiple dependencies separated by either space or comma. You can
+;; also specify optional attributes on the dependency by simply
+;; appending it. The following examples should illustrate this:
+;;
+;; * Training material
+;; :PROPERTIES:
+;; :task_id: training_material
+;; :ORDERED: t
+;; :END:
+;; ** Markup Guidelines
+;; :PROPERTIES:
+;; :Effort: 2.0
+;; :END:
+;; ** Workflow Guidelines
+;; :PROPERTIES:
+;; :Effort: 2.0
+;; :END:
+;; * Presentation
+;; :PROPERTIES:
+;; :Effort: 2.0
+;; :BLOCKER: training_material { gapduration 1d } some_other_task
+;; :END:
+;;
+;;;; * TODO
+;; - Use SCHEDULED and DEADLINE information (not just start and end
+;; properties).
+;; - Look at org-file-properties, org-global-properties and
+;; org-global-properties-fixed
+;; - What about property inheritance and org-property-inherit-p?
+;; - Use TYPE_TODO as an way to assign resources
+;; - Make sure multiple dependency definitions (i.e. BLOCKER on
+;; previous-sibling and on a specific task_id) in multiple
+;; attributes are properly exported.
+;;
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+
+(require 'org)
+(require 'org-exp)
+
+;;; User variables:
+
+(defgroup org-export-taskjuggler nil
+ "Options for exporting Org-mode files to TaskJuggler."
+ :tag "Org Export TaskJuggler"
+ :group 'org-export)
+
+(defcustom org-export-taskjuggler-extension ".tjp"
+ "Extension of TaskJuggler files."
+ :group 'org-export-taskjuggler
+ :type 'string)
+
+(defcustom org-export-taskjuggler-project-tag "taskjuggler_project"
+ "Tag, property or todo used to find the tree containing all
+the tasks for the project."
+ :group 'org-export-taskjuggler
+ :type 'string)
+
+(defcustom org-export-taskjuggler-resource-tag "taskjuggler_resource"
+ "Tag, property or todo used to find the tree containing all the
+resources for the project."
+ :group 'org-export-taskjuggler
+ :type 'string)
+
+(defcustom org-export-taskjuggler-default-project-version "1.0"
+ "Default version string for the project."
+ :group 'org-export-taskjuggler
+ :type 'string)
+
+(defcustom org-export-taskjuggler-default-project-duration 280
+ "Default project duration if no start and end date have been defined
+in the root node of the task tree, i.e. the tree that has been marked
+with `org-export-taskjuggler-project-tag'"
+ :group 'org-export-taskjuggler
+ :type 'integer)
+
+(defcustom org-export-taskjuggler-default-reports
+ '("taskreport \"Gantt Chart\" {
+ headline \"Project Gantt Chart\"
+ columns hierarchindex, name, start, end, effort, duration, completed, chart
+ timeformat \"%Y-%m-%d\"
+ hideresource 1
+ loadunit shortauto
+}"
+"resourcereport \"Resource Graph\" {
+ headline \"Resource Allocation Graph\"
+ columns no, name, utilization, freeload, chart
+ loadunit shortauto
+ sorttasks startup
+ hidetask ~isleaf()
+}")
+ "Default reports for the project."
+ :group 'org-export-taskjuggler
+ :type '(repeat (string :tag "Report")))
+
+(defcustom org-export-taskjuggler-default-global-properties
+ "shift s40 \"Part time shift\" {
+ workinghours wed, thu, fri off
+}
+"
+ "Default global properties for the project. Here you typically
+define global properties such as shifts, accounts, rates,
+vacation, macros and flags. Any property that is allowed within
+the TaskJuggler file can be inserted. You could for example
+include another TaskJuggler file.
+
+The global properties are inserted after the project declaration
+but before any resource and task declarations."
+ :group 'org-export-taskjuggler
+ :type '(string :tag "Preamble"))
+
+;;; Hooks
+
+(defvar org-export-taskjuggler-final-hook nil
+ "Hook run at the end of TaskJuggler export, in the new buffer.")
+
+;;; Autoload functions:
+
+;; avoid compiler warning about free variable
+(defvar org-export-taskjuggler-old-level)
+
+;;;###autoload
+(defun org-export-as-taskjuggler ()
+ "Export parts of the current buffer as a TaskJuggler file.
+The exporter looks for a tree with tag, property or todo that
+matches `org-export-taskjuggler-project-tag' and takes this as
+the tasks for this project. The first node of this tree defines
+the project properties such as project name and project period.
+If there is a tree with tag, property or todo that matches
+`org-export-taskjuggler-resource-tag' this three is taken as
+resources for the project. If no resources are specified, a
+default resource is created and allocated to the project. Also
+the taskjuggler project will be created with default reports as
+defined in `org-export-taskjuggler-default-reports'."
+ (interactive)
+
+ (message "Exporting...")
+ (setq-default org-done-keywords org-done-keywords)
+ (let* ((tasks
+ (org-taskjuggler-resolve-dependencies
+ (org-taskjuggler-assign-task-ids
+ (org-map-entries
+ '(org-taskjuggler-components)
+ org-export-taskjuggler-project-tag nil 'archive 'comment))))
+ (resources
+ (org-taskjuggler-assign-resource-ids
+ (org-map-entries
+ '(org-taskjuggler-components)
+ org-export-taskjuggler-resource-tag nil 'archive 'comment)))
+ (filename (expand-file-name
+ (concat
+ (file-name-sans-extension
+ (file-name-nondirectory buffer-file-name))
+ org-export-taskjuggler-extension)))
+ (buffer (find-file-noselect filename))
+ (org-export-taskjuggler-old-level 0)
+ task resource)
+ (unless tasks
+ (error "No tasks specified"))
+ ;; add a default resource
+ (unless resources
+ (setq resources
+ `((("resource_id" . ,(user-login-name))
+ ("headline" . ,user-full-name)
+ ("level" . 1)))))
+ ;; add a default allocation to the first task if none was given
+ (unless (assoc "allocate" (car tasks))
+ (let ((task (car tasks))
+ (resource-id (cdr (assoc "resource_id" (car resources)))))
+ (setcar tasks (push (cons "allocate" resource-id) task))))
+ ;; add a default start date to the first task if none was given
+ (unless (assoc "start" (car tasks))
+ (let ((task (car tasks))
+ (time-string (format-time-string "%Y-%m-%d")))
+ (setcar tasks (push (cons "start" time-string) task))))
+ ;; add a default version if none was given
+ (unless (assoc "version" (car tasks))
+ (let ((task (car tasks))
+ (version org-export-taskjuggler-default-project-version))
+ (setcar tasks (push (cons "version" version) task))))
+ (with-current-buffer buffer
+ (erase-buffer)
+ (org-taskjuggler-open-project (car tasks))
+ (insert org-export-taskjuggler-default-global-properties)
+ (insert "\n")
+ (dolist (resource resources)
+ (let ((level (cdr (assoc "level" resource))))
+ (org-taskjuggler-close-maybe level)
+ (org-taskjuggler-open-resource resource)
+ (setq org-export-taskjuggler-old-level level)))
+ (org-taskjuggler-close-maybe 1)
+ (setq org-export-taskjuggler-old-level 0)
+ (dolist (task tasks)
+ (let ((level (cdr (assoc "level" task))))
+ (org-taskjuggler-close-maybe level)
+ (org-taskjuggler-open-task task)
+ (setq org-export-taskjuggler-old-level level)))
+ (org-taskjuggler-close-maybe 1)
+ (org-taskjuggler-insert-reports)
+ (save-buffer)
+ (or (org-export-push-to-kill-ring "TaskJuggler")
+ (message "Exporting... done"))
+ (current-buffer))))
+
+;;;###autoload
+(defun org-export-as-taskjuggler-and-open ()
+ "Export the current buffer as a TaskJuggler file and open it
+with the TaskJuggler GUI."
+ (interactive)
+ (let* ((file-name (buffer-file-name (org-export-as-taskjuggler)))
+ (process-name "TaskJugglerUI")
+ (command (concat process-name " " file-name)))
+ (start-process-shell-command process-name nil command)))
+
+(defun org-taskjuggler-parent-is-ordered-p ()
+ "Return true if the parent of the current node has a property
+\"ORDERED\". Return nil otherwise."
+ (save-excursion
+ (and (org-up-heading-safe) (org-entry-get (point) "ORDERED"))))
+
+(defun org-taskjuggler-components ()
+ "Return an alist containing all the pertinent information for
+the current node such as the headline, the level, todo state
+information, all the properties, etc."
+ (let* ((props (org-entry-properties))
+ (components (org-heading-components))
+ (level (nth 1 components))
+ (headline (nth 4 components))
+ (parent-ordered (org-taskjuggler-parent-is-ordered-p)))
+ (push (cons "level" level) props)
+ (push (cons "headline" headline) props)
+ (push (cons "parent-ordered" parent-ordered) props)))
+
+(defun org-taskjuggler-assign-task-ids (tasks)
+ "Given a list of tasks return the same list assigning a unique id
+and the full path to each task. Taskjuggler takes hierarchical ids.
+For that reason we have to make ids locally unique and we have to keep
+a path to the current task."
+ (let ((previous-level 0)
+ unique-ids unique-id
+ path
+ task resolved-tasks tmp)
+ (dolist (task tasks resolved-tasks)
+ (let ((level (cdr (assoc "level" task))))
+ (cond
+ ((< previous-level level)
+ (setq unique-id (org-taskjuggler-get-unique-id task (car unique-ids)))
+ (dotimes (tmp (- level previous-level))
+ (push (list unique-id) unique-ids)
+ (push unique-id path)))
+ ((= previous-level level)
+ (setq unique-id (org-taskjuggler-get-unique-id task (car unique-ids)))
+ (push unique-id (car unique-ids))
+ (setcar path unique-id))
+ ((> previous-level level)
+ (dotimes (tmp (- previous-level level))
+ (pop unique-ids)
+ (pop path))
+ (setq unique-id (org-taskjuggler-get-unique-id task (car unique-ids)))
+ (push unique-id (car unique-ids))
+ (setcar path unique-id)))
+ (push (cons "unique-id" unique-id) task)
+ (push (cons "path" (mapconcat 'identity (reverse path) ".")) task)
+ (setq previous-level level)
+ (setq resolved-tasks (append resolved-tasks (list task)))))))
+
+(defun org-taskjuggler-assign-resource-ids (resources &optional unique-ids)
+ "Given a list of resources return the same list, assigning a
+unique id to each resource."
+ (cond
+ ((null resources) nil)
+ (t
+ (let* ((resource (car resources))
+ (unique-id (org-taskjuggler-get-unique-id resource unique-ids)))
+ (push (cons "unique-id" unique-id) resource)
+ (cons resource
+ (org-taskjuggler-assign-resource-ids (cdr resources)
+ (cons unique-id unique-ids)))))))
+
+(defun org-taskjuggler-resolve-dependencies (tasks)
+ (let ((previous-level 0)
+ siblings
+ task resolved-tasks)
+ (dolist (task tasks resolved-tasks)
+ (let* ((level (cdr (assoc "level" task)))
+ (depends (cdr (assoc "depends" task)))
+ (parent-ordered (cdr (assoc "parent-ordered" task)))
+ (blocker (cdr (assoc "BLOCKER" task)))
+ (blocked-on-previous
+ (and blocker (string-match "previous-sibling" blocker)))
+ (dependencies
+ (org-taskjuggler-resolve-explicit-dependencies
+ (append
+ (and depends (org-taskjuggler-tokenize-dependencies depends))
+ (and blocker (org-taskjuggler-tokenize-dependencies blocker)))
+ tasks))
+ previous-sibling)
+ ; update previous sibling info
+ (cond
+ ((< previous-level level)
+ (dotimes (tmp (- level previous-level))
+ (push task siblings)))
+ ((= previous-level level)
+ (setq previous-sibling (car siblings))
+ (setcar siblings task))
+ ((> previous-level level)
+ (dotimes (tmp (- previous-level level))
+ (pop siblings))
+ (setq previous-sibling (car siblings))
+ (setcar siblings task)))
+ ; insert a dependency on previous sibling if the parent is
+ ; ordered or if the tasks has a BLOCKER attribute with value "previous-sibling"
+ (when (or (and previous-sibling parent-ordered) blocked-on-previous)
+ (push (format "!%s" (cdr (assoc "unique-id" previous-sibling))) dependencies))
+ ; store dependency information
+ (when dependencies
+ (push (cons "depends" (mapconcat 'identity dependencies ", ")) task))
+ (setq previous-level level)
+ (setq resolved-tasks (append resolved-tasks (list task)))))))
+
+(defun org-taskjuggler-tokenize-dependencies (dependencies)
+ "Split a dependency property value DEPENDENCIES into the
+individual dependencies and return them as a list while keeping
+the optional arguments (such as gapduration) for the
+dependencies. A dependency will have to match `[-a-zA-Z0-9_]+'."
+ (cond
+ ((string-match "^ *$" dependencies) nil)
+ ((string-match "^[ \t]*\\([-a-zA-Z0-9_]+\\([ \t]*{[^}]+}\\)?\\)[ \t,]*" dependencies)
+ (cons
+ (substring dependencies (match-beginning 1) (match-end 1))
+ (org-taskjuggler-tokenize-dependencies (substring dependencies (match-end 0)))))
+ (t (error (format "invalid dependency id %s" dependencies)))))
+
+(defun org-taskjuggler-resolve-explicit-dependencies (dependencies tasks)
+ "For each dependency in DEPENDENCIES try to find a
+corresponding task with a matching property \"task_id\" in TASKS.
+Return a list containing the resolved links for all DEPENDENCIES
+where a matching tasks was found. If the dependency is
+\"previous-sibling\" it is ignored (as this is dealt with in
+`org-taskjuggler-resolve-dependencies'). If there is no matching
+task the dependency is ignored and a warning is displayed ."
+ (unless (null dependencies)
+ (let*
+ ;; the dependency might have optional attributes such as "{
+ ;; gapduration 5d }", so only use the first string as id for the
+ ;; dependency
+ ((dependency (car dependencies))
+ (id (car (split-string dependency)))
+ (optional-attributes
+ (mapconcat 'identity (cdr (split-string dependency)) " "))
+ (path (org-taskjuggler-find-task-with-id id tasks)))
+ (cond
+ ;; ignore previous sibling dependencies
+ ((equal (car dependencies) "previous-sibling")
+ (org-taskjuggler-resolve-explicit-dependencies (cdr dependencies) tasks))
+ ;; if the id is found in another task use its path
+ ((not (null path))
+ (cons (mapconcat 'identity (list path optional-attributes) " ")
+ (org-taskjuggler-resolve-explicit-dependencies
+ (cdr dependencies) tasks)))
+ ;; warn about dangling dependency but otherwise ignore it
+ (t (display-warning
+ 'org-export-taskjuggler
+ (format "No task with matching property \"task_id\" found for id %s" id))
+ (org-taskjuggler-resolve-explicit-dependencies (cdr dependencies) tasks))))))
+
+(defun org-taskjuggler-find-task-with-id (id tasks)
+ "Find ID in tasks. If found return the path of task. Otherwise
+return nil."
+ (let ((task-id (cdr (assoc "task_id" (car tasks))))
+ (path (cdr (assoc "path" (car tasks)))))
+ (cond
+ ((null tasks) nil)
+ ((equal task-id id) path)
+ (t (org-taskjuggler-find-task-with-id id (cdr tasks))))))
+
+(defun org-taskjuggler-get-unique-id (item unique-ids)
+ "Return a unique id for an ITEM which can be a task or a resource.
+The id is derived from the headline and made unique against
+UNIQUE-IDS. If the (downcased) first token of the headline is not
+unique try to add more (downcased) tokens of the headline or
+finally add more underscore characters (\"_\")."
+ (let* ((headline (cdr (assoc "headline" item)))
+ (parts (split-string headline))
+ (id (org-taskjuggler-clean-id (downcase (pop parts)))))
+ ; try to add more parts of the headline to make it unique
+ (while (and (member id unique-ids) (car parts))
+ (setq id (concat id "_" (org-taskjuggler-clean-id (downcase (pop parts))))))
+ ; if its still not unique add "_"
+ (while (member id unique-ids)
+ (setq id (concat id "_")))
+ id))
+
+(defun org-taskjuggler-clean-id (id)
+ "Clean and return ID to make it acceptable for taskjuggler."
+ (and id (replace-regexp-in-string "[^a-zA-Z0-9_]" "_" id)))
+
+(defun org-taskjuggler-open-project (project)
+ "Insert the beginning of a project declaration. All valid
+attributes from the PROJECT alist are inserted. If no end date is
+specified it is calculated
+`org-export-taskjuggler-default-project-duration' days from now."
+ (let* ((unique-id (cdr (assoc "unique-id" project)))
+ (headline (cdr (assoc "headline" project)))
+ (version (cdr (assoc "version" project)))
+ (start (cdr (assoc "start" project)))
+ (end (cdr (assoc "end" project))))
+ (insert
+ (format "project %s \"%s\" \"%s\" %s +%sd {\n }\n"
+ unique-id headline version start
+ org-export-taskjuggler-default-project-duration))))
+
+(defun org-taskjuggler-filter-and-join (items)
+ "Filter all nil elements from ITEMS and join the remaining ones
+with separator \"\n\"."
+ (let ((filtered-items (remq nil items)))
+ (and filtered-items (mapconcat 'identity filtered-items "\n"))))
+
+(defun org-taskjuggler-get-attributes (item attributes)
+ "Return all attribute as a single formated string. ITEM is an
+alist representing either a resource or a task. ATTRIBUTES is a
+list of symbols. Only entries from ITEM are considered that are
+listed in ATTRIBUTES."
+ (org-taskjuggler-filter-and-join
+ (mapcar
+ (lambda (attribute)
+ (org-taskjuggler-filter-and-join
+ (org-taskjuggler-get-attribute item attribute)))
+ attributes)))
+
+(defun org-taskjuggler-get-attribute (item attribute)
+ "Return a list of strings containing the properly formatted
+taskjuggler declaration for a given ATTRIBUTE in ITEM (an alist).
+If the ATTRIBUTE is not in ITEM return nil."
+ (cond
+ ((null item) nil)
+ ((equal (symbol-name attribute) (car (car item)))
+ (cons (format "%s %s" (symbol-name attribute) (cdr (car item)))
+ (org-taskjuggler-get-attribute (cdr item) attribute)))
+ (t (org-taskjuggler-get-attribute (cdr item) attribute))))
+
+(defun org-taskjuggler-open-resource (resource)
+ "Insert the beginning of a resource declaration. All valid
+attributes from the RESOURCE alist are inserted. If the RESOURCE
+defines a property \"resource_id\" it will be used as the id for
+this resource. Otherwise it will use the ID property. If neither
+is defined it will calculate a unique id for the resource using
+`org-taskjuggler-get-unique-id'."
+ (let ((id (org-taskjuggler-clean-id
+ (or (cdr (assoc "resource_id" resource))
+ (cdr (assoc "ID" resource))
+ (cdr (assoc "unique-id" resource)))))
+ (headline (cdr (assoc "headline" resource)))
+ (attributes '(limits vacation shift booking efficiency journalentry rate)))
+ (insert
+ (concat
+ "resource " id " \"" headline "\" {\n "
+ (org-taskjuggler-get-attributes resource attributes) "\n"))))
+
+(defun org-taskjuggler-clean-effort (effort)
+ "Translate effort strings into a format acceptable to taskjuggler,
+i.e. REAL UNIT. If the effort string is something like 5:30 it
+will be assumed to be hours and will be translated into 5.5h.
+Otherwise if it contains something like 3.0 it is assumed to be
+days and will be translated into 3.0d. Other formats that
+taskjuggler supports (like weeks, months and years) are currently
+not supported."
+ (cond
+ ((null effort) effort)
+ ((string-match "\\([0-9]+\\):\\([0-9]+\\)" effort)
+ (let ((hours (string-to-number (match-string 1 effort)))
+ (minutes (string-to-number (match-string 2 effort))))
+ (format "%dh" (+ hours (/ minutes 60.0)))))
+ ((string-match "\\([0-9]+\\).\\([0-9]+\\)" effort) (concat effort "d"))
+ (t (error "Not a valid effort (%s)" effort))))
+
+(defun org-taskjuggler-get-priority (priority)
+ "Return a priority between 1 and 1000 based on PRIORITY, an
+org-mode priority string."
+ (max 1 (/ (* 1000 (- org-lowest-priority (string-to-char priority)))
+ (- org-lowest-priority org-highest-priority))))
+
+(defun org-taskjuggler-open-task (task)
+ (let* ((unique-id (cdr (assoc "unique-id" task)))
+ (headline (cdr (assoc "headline" task)))
+ (effort (org-taskjuggler-clean-effort (cdr (assoc org-effort-property task))))
+ (depends (cdr (assoc "depends" task)))
+ (allocate (cdr (assoc "allocate" task)))
+ (priority-raw (cdr (assoc "PRIORITY" task)))
+ (priority (and priority-raw (org-taskjuggler-get-priority priority-raw)))
+ (state (cdr (assoc "TODO" task)))
+ (complete (or (and (member state org-done-keywords) "100")
+ (cdr (assoc "complete" task))))
+ (parent-ordered (cdr (assoc "parent-ordered" task)))
+ (previous-sibling (cdr (assoc "previous-sibling" task)))
+ (attributes
+ '(account start note duration endbuffer endcredit end
+ flags journalentry length maxend maxstart milestone
+ minend minstart period reference responsible
+ scheduling startbuffer startcredit statusnote)))
+ (insert
+ (concat
+ "task " unique-id " \"" headline "\" {\n"
+ (if (and parent-ordered previous-sibling)
+ (format " depends %s\n" previous-sibling)
+ (and depends (format " depends %s\n" depends)))
+ (and allocate (format " purge allocations\n allocate %s\n" allocate))
+ (and complete (format " complete %s\n" complete))
+ (and effort (format " effort %s\n" effort))
+ (and priority (format " priority %s\n" priority))
+
+ (org-taskjuggler-get-attributes task attributes)
+ "\n"))))
+
+(defun org-taskjuggler-close-maybe (level)
+ (while (> org-export-taskjuggler-old-level level)
+ (insert "}\n")
+ (setq org-export-taskjuggler-old-level (1- org-export-taskjuggler-old-level)))
+ (when (= org-export-taskjuggler-old-level level)
+ (insert "}\n")))
+
+(defun org-taskjuggler-insert-reports ()
+ (let (report)
+ (dolist (report org-export-taskjuggler-default-reports)
+ (insert report "\n"))))
+
+(provide 'org-taskjuggler)
+
+;;; org-taskjuggler.el ends here
diff --git a/lisp/org/org-timer.el b/lisp/org/org-timer.el
index f26060d4564..6c1f4984cf1 100644
--- a/lisp/org/org-timer.el
+++ b/lisp/org/org-timer.el
@@ -5,7 +5,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -27,9 +27,11 @@
;; This file contains the relative timer code for Org-mode
+;;; Code:
+
(require 'org)
-(declare-function org-show-notification "org-clock" (parameters))
+(declare-function org-notify "org-clock" (notification &optional play-sound))
(declare-function org-agenda-error "org-agenda" ())
(defvar org-timer-start-time nil
@@ -48,6 +50,30 @@ the value of the relative timer."
:group 'org-time
:type 'string)
+(defcustom org-timer-default-timer 0
+ "The default timer when a timer is set.
+When 0, the user is prompted for a value."
+ :group 'org-time
+ :type 'number)
+
+(defvar org-timer-start-hook nil
+ "Hook run after relative timer is started.")
+
+(defvar org-timer-stop-hook nil
+ "Hook run before relative timer is stopped.")
+
+(defvar org-timer-pause-hook nil
+ "Hook run before relative timer is paused.")
+
+(defvar org-timer-set-hook nil
+ "Hook run after countdown timer is set.")
+
+(defvar org-timer-done-hook nil
+ "Hook run after countdown timer reaches zero.")
+
+(defvar org-timer-cancel-hook nil
+ "Hook run before countdown timer is canceled.")
+
;;;###autoload
(defun org-timer-start (&optional offset)
"Set the starting time for the relative timer to now.
@@ -78,14 +104,16 @@ the region 0:00:00."
(setq delta (org-timer-hms-to-secs (org-timer-fix-incomplete s)))))
(setq org-timer-start-time
(seconds-to-time
- (- (org-float-time) (org-timer-hms-to-secs s)))))
+ (- (org-float-time) delta))))
(org-timer-set-mode-line 'on)
(message "Timer start time set to %s, current value is %s"
(format-time-string "%T" org-timer-start-time)
- (org-timer-secs-to-hms (or delta 0))))))
+ (org-timer-secs-to-hms (or delta 0)))
+ (run-hooks 'org-timer-start-hook))))
(defun org-timer-pause-or-continue (&optional stop)
- "Pause or continue the relative timer. With prefix arg, stop it entirely."
+ "Pause or continue the relative timer.
+With prefix arg STOP, stop it entirely."
(interactive "P")
(cond
(stop (org-timer-stop))
@@ -103,6 +131,7 @@ the region 0:00:00."
(message "Timer continues at %s" (org-timer-value-string)))
(t
;; pause timer
+ (run-hooks 'org-timer-pause-hook)
(setq org-timer-pause-time (current-time))
(org-timer-set-mode-line 'pause)
(message "Timer paused at %s" (org-timer-value-string)))))
@@ -110,29 +139,39 @@ the region 0:00:00."
(defun org-timer-stop ()
"Stop the relative timer."
(interactive)
+ (run-hooks 'org-timer-stop-hook)
(setq org-timer-start-time nil
org-timer-pause-time nil)
(org-timer-set-mode-line 'off))
;;;###autoload
-(defun org-timer (&optional restart)
+(defun org-timer (&optional restart no-insert-p)
"Insert a H:MM:SS string from the timer into the buffer.
The first time this command is used, the timer is started. When used with
-a `C-u' prefix, force restarting the timer.
-When used with a double prefix arg `C-u C-u', change all the timer string
+a \\[universal-argument] prefix, force restarting the timer.
+When used with a double prefix argument \\[universal-argument], change all the timer string
in the region by a fixed amount. This can be used to recalibrate a timer
-that was not started at the correct moment."
+that was not started at the correct moment.
+
+If NO-INSERT-P is non-nil, return the string instead of inserting
+it in the buffer."
(interactive "P")
- (if (equal restart '(4)) (org-timer-start))
- (or org-timer-start-time (org-timer-start))
- (insert (org-timer-value-string)))
+ (when (or (equal restart '(4)) (not org-timer-start-time))
+ (org-timer-start))
+ (if no-insert-p
+ (org-timer-value-string)
+ (insert (org-timer-value-string))))
(defun org-timer-value-string ()
(format org-timer-format (org-timer-secs-to-hms (floor (org-timer-seconds)))))
+(defvar org-timer-timer-is-countdown nil)
(defun org-timer-seconds ()
- (- (org-float-time (or org-timer-pause-time (current-time)))
- (org-float-time org-timer-start-time)))
+ (if org-timer-timer-is-countdown
+ (- (org-float-time org-timer-start-time)
+ (org-float-time (current-time)))
+ (- (org-float-time (or org-timer-pause-time (current-time)))
+ (org-float-time org-timer-start-time))))
;;;###autoload
(defun org-timer-change-times-in-region (beg end delta)
@@ -164,19 +203,22 @@ that was not started at the correct moment."
(defun org-timer-item (&optional arg)
"Insert a description-type item with the current timer value."
(interactive "P")
- (let ((ind 0))
- (save-excursion
- (skip-chars-backward " \n\t")
- (condition-case nil
- (progn
- (org-beginning-of-item)
- (setq ind (org-get-indentation)))
- (error nil)))
- (or (bolp) (newline))
- (org-indent-line-to ind)
- (insert "- ")
- (org-timer (if arg '(4)))
- (insert ":: ")))
+ (cond
+ ;; In a timer list, insert with `org-list-insert-item-generic'.
+ ((and (org-in-item-p)
+ (save-excursion (org-beginning-of-item) (org-at-item-timer-p)))
+ (org-list-insert-item-generic
+ (point) nil (concat (org-timer (when arg '(4)) t) ":: ")))
+ ;; In a list of another type, don't break anything: throw an error.
+ ((org-in-item-p)
+ (error "This is not a timer list"))
+ ;; Else, insert the timer correctly indented at bol.
+ (t
+ (beginning-of-line)
+ (org-indent-line-function)
+ (insert "- ")
+ (org-timer (when arg '(4)))
+ (insert ":: "))))
(defun org-timer-fix-incomplete (hms)
"If hms is a H:MM:SS string with missing hour or hour and minute, fix it."
@@ -254,45 +296,59 @@ VALUE can be `on', `off', or `pause'."
(concat " <" (substring (org-timer-value-string) 0 -1) ">"))
(force-mode-line-update)))
-(defvar org-timer-timer1 nil)
-(defvar org-timer-timer2 nil)
-(defvar org-timer-timer3 nil)
-(defvar org-timer-last-timer nil)
-
-(defun org-timer-cancel-timers ()
- "Reset all timers."
+(defvar org-timer-current-timer nil)
+(defun org-timer-cancel-timer ()
+ "Cancel the current timer."
(interactive)
- (mapc (lambda(timer)
- (when (eval timer)
- (cancel-timer timer)
- (setq timer nil)))
- '(org-timer-timer1
- org-timer-timer2
- org-timer-timer3))
- (message "All timers reset"))
+ (when (eval org-timer-current-timer)
+ (run-hooks 'org-timer-cancel-hook)
+ (cancel-timer org-timer-current-timer)
+ (setq org-timer-current-timer nil)
+ (setq org-timer-timer-is-countdown nil)
+ (org-timer-set-mode-line 'off))
+ (message "Last timer canceled"))
(defun org-timer-show-remaining-time ()
"Display the remaining time before the timer ends."
(interactive)
(require 'time)
- (if (and (not org-timer-timer1)
- (not org-timer-timer2)
- (not org-timer-timer3))
+ (if (not org-timer-current-timer)
(message "No timer set")
(let* ((rtime (decode-time
- (time-subtract (timer--time org-timer-last-timer)
+ (time-subtract (timer--time org-timer-current-timer)
(current-time))))
(rsecs (nth 0 rtime))
(rmins (nth 1 rtime)))
- (message "%d minutes %d seconds left before next time out"
+ (message "%d minute(s) %d seconds left before next time out"
rmins rsecs))))
;;;###autoload
-(defun org-timer-set-timer (minutes)
- "Set a timer."
- (interactive "sTime out in (min)? ")
- (if (not (string-match "[0-9]+" minutes))
- (org-timer-show-remaining-time)
+(defun org-timer-set-timer (&optional opt)
+ "Prompt for a duration and set a timer.
+
+If `org-timer-default-timer' is not zero, suggest this value as
+the default duration for the timer. If a timer is already set,
+prompt the user if she wants to replace it.
+
+Called with a numeric prefix argument, use this numeric value as
+the duration of the timer.
+
+Called with a `C-u' prefix arguments, use `org-timer-default-timer'
+without prompting the user for a duration.
+
+With two `C-u' prefix arguments, use `org-timer-default-timer'
+without prompting the user for a duration and automatically
+replace any running timer."
+ (interactive "P")
+ (let ((minutes (or (and (numberp opt) (number-to-string opt))
+ (and (listp opt) (not (null opt))
+ (number-to-string org-timer-default-timer))
+ (read-from-minibuffer
+ "How many minutes left? "
+ (if (not (eq org-timer-default-timer 0))
+ (number-to-string org-timer-default-timer))))))
+ (if (not (string-match "[0-9]+" minutes))
+ (org-timer-show-remaining-time)
(let* ((mins (string-to-number (match-string 0 minutes)))
(secs (* mins 60))
(hl (cond
@@ -306,21 +362,35 @@ VALUE can be `on', `off', or `pause'."
(widen)
(goto-char pos)
(org-show-entry)
- (org-get-heading))))
+ (or (ignore-errors (org-get-heading))
+ (concat "File:" (file-name-nondirectory (buffer-file-name)))))))
((eq major-mode 'org-mode)
- (org-get-heading))
+ (or (ignore-errors (org-get-heading))
+ (concat "File:" (file-name-nondirectory (buffer-file-name)))))
(t (error "Not in an Org buffer"))))
timer-set)
- (mapcar (lambda(timer)
- (when (not (or (eval timer) timer-set))
- (setq timer-set t)
- (setq org-timer-last-timer
- (run-with-timer
- secs nil 'org-notify (format "%s: time out" hl) t))
- (set timer org-timer-last-timer)))
- '(org-timer-timer1
- org-timer-timer2
- org-timer-timer3)))))
+ (if (or (and org-timer-current-timer
+ (or (equal opt '(16))
+ (y-or-n-p "Replace current timer? ")))
+ (not org-timer-current-timer))
+ (progn
+ (require 'org-clock)
+ (when org-timer-current-timer
+ (cancel-timer org-timer-current-timer))
+ (setq org-timer-current-timer
+ (run-with-timer
+ secs nil `(lambda ()
+ (setq org-timer-current-timer nil)
+ (org-notify ,(format "%s: time out" hl) t)
+ (setq org-timer-timer-is-countdown nil)
+ (org-timer-set-mode-line 'off)
+ (run-hooks 'org-timer-done-hook))))
+ (run-hooks 'org-timer-set-hook)
+ (setq org-timer-timer-is-countdown t
+ org-timer-start-time
+ (time-add (current-time) (seconds-to-time (* mins 60))))
+ (org-timer-set-mode-line 'on))
+ (message "No timer set"))))))
(provide 'org-timer)
diff --git a/lisp/org/org-vm.el b/lisp/org/org-vm.el
index fc7fcd8947e..629258dec94 100644
--- a/lisp/org/org-vm.el
+++ b/lisp/org/org-vm.el
@@ -6,7 +6,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -66,9 +66,19 @@
(to (vm-get-header-contents message "To"))
(from (vm-get-header-contents message "From"))
(message-id (vm-su-message-id message))
+ (date (vm-get-header-contents message "Date"))
+ (date-ts (and date (format-time-string
+ (org-time-stamp-format t)
+ (date-to-time date))))
+ (date-ts-ia (and date (format-time-string
+ (org-time-stamp-format t t)
+ (date-to-time date))))
desc link)
(org-store-link-props :type "vm" :from from :to to :subject subject
:message-id message-id)
+ (when date
+ (org-add-link-props :date date :date-timestamp date-ts
+ :date-timestamp-inactive date-ts-ia))
(setq message-id (org-remove-angle-brackets message-id))
(setq folder (abbreviate-file-name folder))
(if (and vm-folder-directory
diff --git a/lisp/org/org-w3m.el b/lisp/org/org-w3m.el
index 59aba5c2366..072020a65e7 100644
--- a/lisp/org/org-w3m.el
+++ b/lisp/org/org-w3m.el
@@ -5,7 +5,7 @@
;; Author: Andy Stewart <lazycat dot manatee at gmail dot com>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -28,11 +28,11 @@
;; This file implements copying HTML content from a w3m buffer and
;; transforming the text on the fly so that it can be pasted into
;; an org-mode buffer with hot links. It will also work for regions
-;; in gnus buffers that have ben washed with w3m.
+;; in gnus buffers that have been washed with w3m.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
-;;; Acknowledgements:
+;;; Acknowledgments:
;; Richard Riley <rileyrgdev at googlemail dot com>
;;
@@ -40,8 +40,9 @@
;; proposed by Richard, I'm just coding it.
;;
+;;; Code:
+
(require 'org)
-(declare-function w3m-anchor "ext:w3m-util" (position))
(defun org-w3m-copy-for-org-mode ()
"Copy current buffer content or active region with `org-mode' style links.
@@ -68,7 +69,7 @@ so that it can be yanked into an Org-mode buffer with links working correctly."
;; store current point before jump next anchor
(setq temp-position (point))
;; move to next anchor when current point is not at anchor
- (or (w3m-anchor (point)) (org-w3m-get-next-link-start))
+ (or (get-text-property (point) 'w3m-href-anchor) (org-w3m-get-next-link-start))
(if (<= (point) transform-end) ; if point is inside transform bound
(progn
;; get content between two links.
@@ -77,7 +78,7 @@ so that it can be yanked into an Org-mode buffer with links working correctly."
(buffer-substring
temp-position (point)))))
;; get link location at current point.
- (setq link-location (w3m-anchor (point)))
+ (setq link-location (get-text-property (point) 'w3m-href-anchor))
;; get link title at current point.
(setq link-title (buffer-substring (point)
(org-w3m-get-anchor-end)))
@@ -115,7 +116,7 @@ so that it can be yanked into an Org-mode buffer with links working correctly."
(while (next-single-property-change (point) 'w3m-anchor-sequence)
;; jump to next anchor
(goto-char (next-single-property-change (point) 'w3m-anchor-sequence))
- (when (w3m-anchor (point))
+ (when (get-text-property (point) 'w3m-href-anchor)
;; return point when current is valid link
(throw 'reach nil))))
(point))
@@ -126,7 +127,7 @@ so that it can be yanked into an Org-mode buffer with links working correctly."
(while (previous-single-property-change (point) 'w3m-anchor-sequence)
;; jump to previous anchor
(goto-char (previous-single-property-change (point) 'w3m-anchor-sequence))
- (when (w3m-anchor (point))
+ (when (get-text-property (point) 'w3m-href-anchor)
;; return point when current is valid link
(throw 'reach nil))))
(point))
diff --git a/lisp/org/org-wl.el b/lisp/org/org-wl.el
index 2c8374a7b89..54d35c98f2f 100644
--- a/lisp/org/org-wl.el
+++ b/lisp/org/org-wl.el
@@ -4,9 +4,10 @@
;; Free Software Foundation, Inc.
;; Author: Tokuya Kameshima <kames at fa2 dot so-net dot ne dot jp>
+;; David Maus <dmaus at ictsoc dot de>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -40,9 +41,36 @@
:group 'org-link)
(defcustom org-wl-link-to-refile-destination t
- "Create a link to the refile destination if the message is marked as refile."
- :group 'org-wl
- :type 'boolean)
+ "Create a link to the refile destination if the message is marked as refile."
+ :group 'org-wl
+ :type 'boolean)
+
+(defcustom org-wl-link-remove-filter nil
+ "Remove filter condition if message is filter folder."
+ :group 'org-wl
+ :type 'boolean)
+
+(defcustom org-wl-shimbun-prefer-web-links nil
+ "If non-nil create web links for shimbun messages."
+ :group 'org-wl
+ :type 'boolean)
+
+(defcustom org-wl-nntp-prefer-web-links nil
+ "If non-nil create web links for nntp messages.
+When folder name contains string \"gmane\" link to gmane,
+googlegroups otherwise."
+ :type 'boolean
+ :group 'org-wl)
+
+(defcustom org-wl-disable-folder-check t
+ "Disable check for new messages when open a link."
+ :type 'boolean
+ :group 'org-wl)
+
+(defcustom org-wl-namazu-default-index nil
+ "Default namazu search index."
+ :type 'directory
+ :group 'org-wl)
;; Declare external functions and variables
(declare-function elmo-folder-exists-p "ext:elmo" (folder) t)
@@ -56,6 +84,8 @@
(declare-function wl-summary-buffer-msgdb "ext:wl-folder" () t)
(declare-function wl-summary-jump-to-msg-by-message-id "ext:wl-summary"
(&optional id))
+(declare-function wl-summary-jump-to-msg "ext:wl-summary"
+ (&optional number beg end))
(declare-function wl-summary-line-from "ext:wl-summary" ())
(declare-function wl-summary-line-subject "ext:wl-summary" ())
(declare-function wl-summary-message-number "ext:wl-summary" ())
@@ -63,80 +93,220 @@
(declare-function wl-summary-registered-temp-mark "ext:wl-action" (number))
(declare-function wl-folder-goto-folder-subr "ext:wl-folder"
(&optional folder sticky))
+(declare-function wl-folder-get-petname "ext:wl-folder" (name))
+(declare-function wl-folder-get-entity-from-buffer "ext:wl-folder"
+ (&optional getid))
+(declare-function wl-folder-buffer-group-p "ext:wl-folder")
(defvar wl-init)
(defvar wl-summary-buffer-elmo-folder)
(defvar wl-summary-buffer-folder-name)
+(defvar wl-folder-group-regexp)
+(defvar wl-auto-check-folder-name)
+(defvar elmo-nntp-default-server)
+
+(defconst org-wl-folder-types
+ '(("%" . imap) ("-" . nntp) ("+" . mh) ("=" . spool)
+ ("$" . archive) ("&" . pop) ("@" . shimbun) ("[" . search)
+ ("*" . multi) ("/" . filter) ("|" . pipe) ("'" . internal))
+ "List of folder indicators. See Wanderlust manual, section 3.")
;; Install the link type
(org-add-link-type "wl" 'org-wl-open)
(add-hook 'org-store-link-functions 'org-wl-store-link)
;; Implementation
+
+(defun org-wl-folder-type (folder)
+ "Return symbol that indicates the type of FOLDER.
+FOLDER is the wanderlust folder name. The first character of the
+folder name determines the the folder type."
+ (let* ((indicator (substring folder 0 1))
+ (type (cdr (assoc indicator org-wl-folder-types))))
+ ;; maybe access or file folder
+ (when (not type)
+ (setq type
+ (cond
+ ((and (>= (length folder) 5)
+ (string= (substring folder 0 5) "file:"))
+ 'file)
+ ((and (>= (length folder) 7)
+ (string= (substring folder 0 7) "access:"))
+ 'access)
+ (t
+ nil))))
+ type))
+
+(defun org-wl-message-field (field entity)
+ "Return content of FIELD in ENTITY.
+FIELD is a symbol of a rfc822 message header field.
+ENTITY is a message entity."
+ (let ((content (elmo-message-entity-field entity field 'string)))
+ (if (listp content) (car content) content)))
+
(defun org-wl-store-link ()
- "Store a link to a WL folder or message."
- (when (eq major-mode 'wl-summary-mode)
- (let* ((msgnum (wl-summary-message-number))
- (mark-info (wl-summary-registered-temp-mark msgnum))
- (folder-name
- (if (and org-wl-link-to-refile-destination
- mark-info
- (equal (nth 1 mark-info) "o")) ; marked as refile
- (nth 2 mark-info)
- wl-summary-buffer-folder-name))
- (message-id (elmo-message-field wl-summary-buffer-elmo-folder
- msgnum 'message-id))
- (wl-message-entity
- (if (fboundp 'elmo-message-entity)
- (elmo-message-entity
- wl-summary-buffer-elmo-folder msgnum)
- (elmo-msgdb-overview-get-entity
- msgnum (wl-summary-buffer-msgdb))))
- (from (let ((from-field (elmo-message-entity-field wl-message-entity
- 'from)))
- (if (listp from-field)
- (car from-field)
- from-field)))
- (to (let ((to-field (elmo-message-entity-field wl-message-entity
- 'to)))
- (if (listp to-field)
- (car to-field)
- to-field)))
- (subject (let (wl-thr-indent-string wl-parent-message-entity)
- (wl-summary-line-subject)))
- desc link)
- (org-store-link-props :type "wl" :from from :to to
- :subject subject :message-id message-id)
- (setq message-id (org-remove-angle-brackets message-id))
- (setq desc (org-email-link-description))
- (setq link (org-make-link "wl:" folder-name
- "#" message-id))
- (org-add-link-props :link link :description desc)
- link)))
+ "Store a link to a WL message or folder."
+ (unless (eobp)
+ (cond
+ ((memq major-mode '(wl-summary-mode mime-view-mode))
+ (org-wl-store-link-message))
+ ((eq major-mode 'wl-folder-mode)
+ (org-wl-store-link-folder))
+ (t
+ nil))))
+
+(defun org-wl-store-link-folder ()
+ "Store a link to a WL folder."
+ (let* ((folder (wl-folder-get-entity-from-buffer))
+ (petname (wl-folder-get-petname folder))
+ (link (org-make-link "wl:" folder)))
+ (save-excursion
+ (beginning-of-line)
+ (unless (and (wl-folder-buffer-group-p)
+ (looking-at wl-folder-group-regexp))
+ (org-store-link-props :type "wl" :description petname
+ :link link)
+ link))))
+
+(defun org-wl-store-link-message ()
+ "Store a link to a WL message."
+ (save-excursion
+ (let ((buf (if (eq major-mode 'wl-summary-mode)
+ (current-buffer)
+ (and (boundp 'wl-message-buffer-cur-summary-buffer)
+ wl-message-buffer-cur-summary-buffer))))
+ (when buf
+ (with-current-buffer buf
+ (let* ((msgnum (wl-summary-message-number))
+ (mark-info (wl-summary-registered-temp-mark msgnum))
+ (folder-name
+ (if (and org-wl-link-to-refile-destination
+ mark-info
+ (equal (nth 1 mark-info) "o")) ; marked as refile
+ (nth 2 mark-info)
+ wl-summary-buffer-folder-name))
+ (folder-type (org-wl-folder-type folder-name))
+ (wl-message-entity
+ (if (fboundp 'elmo-message-entity)
+ (elmo-message-entity
+ wl-summary-buffer-elmo-folder msgnum)
+ (elmo-msgdb-overview-get-entity
+ msgnum (wl-summary-buffer-msgdb))))
+ (message-id
+ (org-wl-message-field 'message-id wl-message-entity))
+ (message-id-no-brackets
+ (org-remove-angle-brackets message-id))
+ (from (org-wl-message-field 'from wl-message-entity))
+ (to (org-wl-message-field 'to wl-message-entity))
+ (xref (org-wl-message-field 'xref wl-message-entity))
+ (subject (org-wl-message-field 'subject wl-message-entity))
+ (date (org-wl-message-field 'date wl-message-entity))
+ (date-ts (and date (format-time-string
+ (org-time-stamp-format t)
+ (date-to-time date))))
+ (date-ts-ia (and date (format-time-string
+ (org-time-stamp-format t t)
+ (date-to-time date))))
+ desc link)
+
+ ;; remove text properties of subject string to avoid possible bug
+ ;; when formatting the subject
+ ;; (Emacs bug #5306, fixed)
+ (set-text-properties 0 (length subject) nil subject)
+
+ ;; maybe remove filter condition
+ (when (and (eq folder-type 'filter) org-wl-link-remove-filter)
+ (while (eq (org-wl-folder-type folder-name) 'filter)
+ (setq folder-name
+ (replace-regexp-in-string "^/[^/]+/" "" folder-name))))
+
+ ;; maybe create http link
+ (cond
+ ((and (eq folder-type 'shimbun)
+ org-wl-shimbun-prefer-web-links xref)
+ (org-store-link-props :type "http" :link xref :description subject
+ :from from :to to :message-id message-id
+ :message-id-no-brackets message-id-no-brackets
+ :subject subject))
+ ((and (eq folder-type 'nntp) org-wl-nntp-prefer-web-links)
+ (setq link
+ (format
+ (if (string-match "gmane\\." folder-name)
+ "http://mid.gmane.org/%s"
+ "http://groups.google.com/groups/search?as_umsgid=%s")
+ (org-fixup-message-id-for-http message-id)))
+ (org-store-link-props :type "http" :link link :description subject
+ :from from :to to :message-id message-id
+ :message-id-no-brackets message-id-no-brackets
+ :subject subject))
+ (t
+ (org-store-link-props :type "wl" :from from :to to
+ :subject subject :message-id message-id
+ :message-id-no-brackets message-id-no-brackets)
+ (setq desc (org-email-link-description))
+ (setq link (org-make-link "wl:" folder-name "#" message-id-no-brackets))
+ (org-add-link-props :link link :description desc)))
+ (when date
+ (org-add-link-props :date date :date-timestamp date-ts
+ :date-timestamp-inactive date-ts-ia))
+ (or link xref)))))))
+
+(defun org-wl-open-nntp (path)
+ "Follow the nntp: link specified by PATH."
+ (let* ((spec (split-string path "/"))
+ (server (split-string (nth 2 spec) "@"))
+ (group (nth 3 spec))
+ (article (nth 4 spec)))
+ (org-wl-open
+ (concat "-" group ":" (if (cdr server)
+ (car (split-string (car server) ":"))
+ "")
+ (if (string= elmo-nntp-default-server (nth 2 spec))
+ ""
+ (concat "@" (or (cdr server) (car server))))
+ (if article (concat "#" article) "")))))
(defun org-wl-open (path)
- "Follow the WL message link specified by PATH."
- (require 'wl)
- (unless wl-init (wl))
- ;; XXX: The imap-uw's MH folder names start with "%#".
- (if (not (string-match "\\`\\(\\(?:%#\\)?[^#]+\\)\\(#\\(.*\\)\\)?" path))
- (error "Error in Wanderlust link"))
- (let ((folder (match-string 1 path))
- (article (match-string 3 path)))
- (if (not (elmo-folder-exists-p (org-no-warnings
- (wl-folder-get-elmo-folder folder))))
- (error "No such folder: %s" folder))
- (let ((old-buf (current-buffer))
- (old-point (point-marker)))
- (wl-folder-goto-folder-subr folder)
- (save-excursion
- ;; XXX: `wl-folder-goto-folder-subr' moves point to the
- ;; beginning of the current line. So, restore the point
- ;; in the old buffer.
- (set-buffer old-buf)
- (goto-char old-point))
- (and (wl-summary-jump-to-msg-by-message-id (org-add-angle-brackets
- article))
- (wl-summary-redisplay)))))
+ "Follow the WL message link specified by PATH.
+When called with one prefix, open message in namazu search folder
+with `org-wl-namazu-default-index' as search index. When called
+with two prefixes or `org-wl-namazu-default-index' is nil, ask
+for namazu index."
+ (require 'wl)
+ (let ((wl-auto-check-folder-name
+ (if org-wl-disable-folder-check
+ 'none
+ wl-auto-check-folder-name)))
+ (unless wl-init (wl))
+ ;; XXX: The imap-uw's MH folder names start with "%#".
+ (if (not (string-match "\\`\\(\\(?:%#\\)?[^#]+\\)\\(#\\(.*\\)\\)?" path))
+ (error "Error in Wanderlust link"))
+ (let ((folder (match-string 1 path))
+ (article (match-string 3 path)))
+ ;; maybe open message in namazu search folder
+ (when current-prefix-arg
+ (setq folder (concat "[" article "]"
+ (if (and (equal current-prefix-arg '(4))
+ org-wl-namazu-default-index)
+ org-wl-namazu-default-index
+ (read-directory-name "Namazu index: ")))))
+ (if (not (elmo-folder-exists-p (org-no-warnings
+ (wl-folder-get-elmo-folder folder))))
+ (error "No such folder: %s" folder))
+ (let ((old-buf (current-buffer))
+ (old-point (point-marker)))
+ (wl-folder-goto-folder-subr folder)
+ (with-current-buffer old-buf
+ ;; XXX: `wl-folder-goto-folder-subr' moves point to the
+ ;; beginning of the current line. So, restore the point
+ ;; in the old buffer.
+ (goto-char old-point))
+ (when article
+ (if (org-string-match-p "@" article)
+ (wl-summary-jump-to-msg-by-message-id (org-add-angle-brackets
+ article))
+ (or (wl-summary-jump-to-msg (string-to-number article))
+ (error "No such message: %s" article)))
+ (wl-summary-redisplay))))))
(provide 'org-wl)
diff --git a/lisp/org/org-xoxo.el b/lisp/org/org-xoxo.el
index e117bea0c29..b5656d9406f 100644
--- a/lisp/org/org-xoxo.el
+++ b/lisp/org/org-xoxo.el
@@ -6,7 +6,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -25,10 +25,11 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
+;; XOXO export
-(require 'org-exp)
+;;; Code:
-;;; XOXO export
+(require 'org-exp)
(defvar org-export-xoxo-final-hook nil
"Hook run after XOXO export, in the new buffer.")
@@ -43,6 +44,7 @@
"Export the org buffer as XOXO.
The XOXO buffer is named *xoxo-<source buffer name>*"
(interactive (list (current-buffer)))
+ (run-hooks 'org-export-first-hook)
;; A quickie abstraction
;; Output everything as XOXO
diff --git a/lisp/org/org.el b/lisp/org/org.el
index a404551f3cb..f7e7c9fd2f4 100644
--- a/lisp/org/org.el
+++ b/lisp/org/org.el
@@ -6,7 +6,7 @@
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.33x
+;; Version: 7.3
;;
;; This file is part of GNU Emacs.
;;
@@ -72,30 +72,121 @@
(eval-when-compile
(require 'cl)
- (require 'gnus-sum)
- (require 'calendar))
-;; For XEmacs, noutline is not yet provided by outline.el, so arrange for
-;; the file noutline.el being loaded.
-(if (featurep 'xemacs) (condition-case nil (require 'noutline)))
-;; We require noutline, which might be provided in outline.el
+ (require 'gnus-sum))
+
+(require 'calendar)
+;; Emacs 22 calendar compatibility: Make sure the new variables are available
+(when (fboundp 'defvaralias)
+ (unless (boundp 'calendar-view-holidays-initially-flag)
+ (defvaralias 'calendar-view-holidays-initially-flag
+ 'view-calendar-holidays-initially))
+ (unless (boundp 'calendar-view-diary-initially-flag)
+ (defvaralias 'calendar-view-diary-initially-flag
+ 'view-diary-entries-initially))
+ (unless (boundp 'diary-fancy-buffer)
+ (defvaralias 'diary-fancy-buffer 'fancy-diary-buffer)))
+
(require 'outline) (require 'noutline)
;; Other stuff we need.
(require 'time-date)
(unless (fboundp 'time-subtract) (defalias 'time-subtract 'subtract-time))
(require 'easymenu)
+(require 'overlay)
(require 'org-macs)
+(require 'org-entities)
(require 'org-compat)
(require 'org-faces)
(require 'org-list)
(require 'org-src)
(require 'org-footnote)
+;; babel
+(require 'ob)
+(require 'ob-table)
+(require 'ob-lob)
+(require 'ob-ref)
+(require 'ob-tangle)
+(require 'ob-comint)
+(require 'ob-keys)
+
+;; load languages based on value of `org-babel-load-languages'
+(defvar org-babel-load-languages)
+;;;###autoload
+(defun org-babel-do-load-languages (sym value)
+ "Load the languages defined in `org-babel-load-languages'."
+ (set-default sym value)
+ (mapc (lambda (pair)
+ (let ((active (cdr pair)) (lang (symbol-name (car pair))))
+ (if active
+ (progn
+ (require (intern (concat "ob-" lang))))
+ (progn
+ (funcall 'fmakunbound
+ (intern (concat "org-babel-execute:" lang)))
+ (funcall 'fmakunbound
+ (intern (concat "org-babel-expand-body:" lang)))))))
+ org-babel-load-languages))
+
+(defcustom org-babel-load-languages '((emacs-lisp . t))
+ "Languages which can be evaluated in Org-mode buffers.
+This list can be used to load support for any of the languages
+below, note that each language will depend on a different set of
+system executables and/or Emacs modes. When a language is
+\"loaded\", then code blocks in that language can be evaluated
+with `org-babel-execute-src-block' bound by default to C-c
+C-c (note the `org-babel-no-eval-on-ctrl-c-ctrl-c' variable can
+be set to remove code block evaluation from the C-c C-c
+keybinding. By default only Emacs Lisp (which has no
+requirements) is loaded."
+ :group 'org-babel
+ :set 'org-babel-do-load-languages
+ :type '(alist :tag "Babel Languages"
+ :key-type
+ (choice
+ (const :tag "C" C)
+ (const :tag "R" R)
+ (const :tag "Asymptote" asymptote)
+ (const :tag "Calc" calc)
+ (const :tag "Clojure" clojure)
+ (const :tag "CSS" css)
+ (const :tag "Ditaa" ditaa)
+ (const :tag "Dot" dot)
+ (const :tag "Emacs Lisp" emacs-lisp)
+ (const :tag "Gnuplot" gnuplot)
+ (const :tag "Haskell" haskell)
+ (const :tag "Javascript" js)
+ (const :tag "Latex" latex)
+ (const :tag "Ledger" ledger)
+ (const :tag "Matlab" matlab)
+ (const :tag "Mscgen" mscgen)
+ (const :tag "Ocaml" ocaml)
+ (const :tag "Octave" octave)
+ (const :tag "Org" org)
+ (const :tag "Perl" perl)
+ (const :tag "PlantUML" plantuml)
+ (const :tag "Python" python)
+ (const :tag "Ruby" ruby)
+ (const :tag "Sass" sass)
+ (const :tag "Scheme" scheme)
+ (const :tag "Screen" screen)
+ (const :tag "Shell Script" sh)
+ (const :tag "Sql" sql)
+ (const :tag "Sqlite" sqlite))
+ :value-type (boolean :tag "Activate" :value t)))
+
;;;; Customization variables
+(defcustom org-clone-delete-id nil
+ "Remove ID property of clones of a subtree.
+When non-nil, clones of a subtree don't inherit the ID property.
+Otherwise they inherit the ID property with a new unique
+identifier."
+ :type 'boolean
+ :group 'org-id)
;;; Version
-(defconst org-version "6.33x"
+(defconst org-version "7.3"
"The version number of the file org.el.")
(defun org-version (&optional here)
@@ -134,7 +225,6 @@ With prefix arg HERE, insert it at point."
"Outline-based notes management and organizer."
:tag "Org"
:group 'outlines
- :group 'hypermedia
:group 'calendar)
(defcustom org-mode-hook nil
@@ -170,7 +260,7 @@ With prefix arg HERE, insert it at point."
(let ((a (member 'org-infojs org-modules)))
(and a (setcar a 'org-jsinfo))))
-(defcustom org-modules '(org-bbdb org-bibtex org-gnus org-info org-jsinfo org-irc org-mew org-mhe org-rmail org-vm org-w3m org-wl)
+(defcustom org-modules '(org-bbdb org-bibtex org-docview org-gnus org-info org-jsinfo org-irc org-mew org-mhe org-rmail org-vm org-w3m org-wl)
"Modules that should always be loaded together with org.el.
If a description starts with <C>, the file is not part of Emacs
and loading it will require that you have downloaded and properly installed
@@ -189,6 +279,8 @@ to add the symbol `xyz', and the package must have a call to
(const :tag " bbdb: Links to BBDB entries" org-bbdb)
(const :tag " bibtex: Links to BibTeX entries" org-bibtex)
(const :tag " crypt: Encryption of subtrees" org-crypt)
+ (const :tag " ctags: Access to Emacs tags with links" org-ctags)
+ (const :tag " docview: Links to doc-view buffers" org-docview)
(const :tag " gnus: Links to GNUS folders/messages" org-gnus)
(const :tag " id: Global IDs for identifying entries" org-id)
(const :tag " info: Links to Info nodes" org-info)
@@ -205,6 +297,7 @@ to add the symbol `xyz', and the package must have a call to
(const :tag " wl: Links to Wanderlust folders/messages" org-wl)
(const :tag " w3m: Special cut/paste from w3m to Org-mode." org-w3m)
(const :tag " mouse: Additional mouse support" org-mouse)
+ (const :tag " TaskJuggler: Export tasks to a TaskJuggler project" org-taskjuggler)
(const :tag "C annotate-file: Annotate a file with org syntax" org-annotate-file)
(const :tag "C bookmark: Org-mode links to bookmarks" org-bookmark)
@@ -226,24 +319,27 @@ to add the symbol `xyz', and the package must have a call to
(const :tag "C learn: SuperMemo's incremental learning algorithm" org-learn)
(const :tag "C mairix: Hook mairix search into Org-mode for different MUAs" org-mairix)
(const :tag "C mac-iCal Imports events from iCal.app to the Emacs diary" org-mac-iCal)
+ (const :tag "C mac-link-grabber Grab links and URLs from various Mac applications" org-mac-link-grabber)
(const :tag "C man: Support for links to manpages in Org-mode" org-man)
(const :tag "C mtags: Support for muse-like tags" org-mtags)
(const :tag "C panel: Simple routines for us with bad memory" org-panel)
- (const :tag "C R: Computation using the R language" org-R)
(const :tag "C registry: A registry for Org-mode links" org-registry)
(const :tag "C org2rem: Convert org appointments into reminders" org2rem)
(const :tag "C screen: Visit screen sessions through Org-mode links" org-screen)
+ (const :tag "C secretary: Team management with org-mode" org-secretary)
(const :tag "C special-blocks: Turn blocks into LaTeX envs and HTML divs" org-special-blocks)
(const :tag "C sqlinsert: Convert Org-mode tables to SQL insertions" orgtbl-sqlinsert)
(const :tag "C toc: Table of contents for Org-mode buffer" org-toc)
(const :tag "C track: Keep up with Org-mode development" org-track)
+ (const :tag "C velocity Something like Notational Velocity for Org" org-velocity)
+ (const :tag "C wikinodes: CamelCase wiki-like links" org-wikinodes)
(repeat :tag "External packages" :inline t (symbol :tag "Package"))))
(defcustom org-support-shift-select nil
- "Non-nil means, make shift-cursor commands select text when possible.
+ "Non-nil means make shift-cursor commands select text when possible.
In Emacs 23, when `shift-select-mode' is on, shifted cursor keys start
-selecting a region, or enlarge thusly regions started in this way.
+selecting a region, or enlarge regions started in this way.
In Org-mode, in special contexts, these same keys are used for other
purposes, important enough to compete with shift selection. Org tries
to balance these needs by supporting `shift-select-mode' outside these
@@ -288,7 +384,7 @@ is Emacs 23 only."
:group 'org)
(defcustom org-startup-folded t
- "Non-nil means, entering Org-mode will switch to OVERVIEW.
+ "Non-nil means entering Org-mode will switch to OVERVIEW.
This can also be configured on a per-file basis by adding one of
the following lines anywhere in the buffer:
@@ -304,14 +400,14 @@ the following lines anywhere in the buffer:
(const :tag "show everything, even drawers" showeverything)))
(defcustom org-startup-truncated t
- "Non-nil means, entering Org-mode will set `truncate-lines'.
+ "Non-nil means entering Org-mode will set `truncate-lines'.
This is useful since some lines containing links can be very long and
uninteresting. Also tables look terrible when wrapped."
:group 'org-startup
:type 'boolean)
(defcustom org-startup-indented nil
- "Non-nil means, turn on `org-indent-mode' on startup.
+ "Non-nil means turn on `org-indent-mode' on startup.
This can also be configured on a per-file basis by adding one of
the following lines anywhere in the buffer:
@@ -322,8 +418,51 @@ the following lines anywhere in the buffer:
(const :tag "Not" nil)
(const :tag "Globally (slow on startup in large files)" t)))
+(defcustom org-use-sub-superscripts t
+ "Non-nil means interpret \"_\" and \"^\" for export.
+When this option is turned on, you can use TeX-like syntax for sub- and
+superscripts. Several characters after \"_\" or \"^\" will be
+considered as a single item - so grouping with {} is normally not
+needed. For example, the following things will be parsed as single
+sub- or superscripts.
+
+ 10^24 or 10^tau several digits will be considered 1 item.
+ 10^-12 or 10^-tau a leading sign with digits or a word
+ x^2-y^3 will be read as x^2 - y^3, because items are
+ terminated by almost any nonword/nondigit char.
+ x_{i^2} or x^(2-i) braces or parenthesis do grouping.
+
+Still, ambiguity is possible - so when in doubt use {} to enclose the
+sub/superscript. If you set this variable to the symbol `{}',
+the braces are *required* in order to trigger interpretations as
+sub/superscript. This can be helpful in documents that need \"_\"
+frequently in plain text.
+
+Not all export backends support this, but HTML does.
+
+This option can also be set with the +OPTIONS line, e.g. \"^:nil\"."
+ :group 'org-startup
+ :group 'org-export-translation
+ :type '(choice
+ (const :tag "Always interpret" t)
+ (const :tag "Only with braces" {})
+ (const :tag "Never interpret" nil)))
+
+(if (fboundp 'defvaralias)
+ (defvaralias 'org-export-with-sub-superscripts 'org-use-sub-superscripts))
+
+
+(defcustom org-startup-with-beamer-mode nil
+ "Non-nil means turn on `org-beamer-mode' on startup.
+This can also be configured on a per-file basis by adding one of
+the following lines anywhere in the buffer:
+
+ #+STARTUP: beamer"
+ :group 'org-startup
+ :type 'boolean)
+
(defcustom org-startup-align-all-tables nil
- "Non-nil means, align all tables when visiting a file.
+ "Non-nil means align all tables when visiting a file.
This is useful when the column width in tables is forced with <N> cookies
in table fields. Such tables will look correct only after the first re-align.
This can also be configured on a per-file basis by adding one of
@@ -333,6 +472,15 @@ the following lines anywhere in the buffer:
:group 'org-startup
:type 'boolean)
+(defcustom org-startup-with-inline-images nil
+ "Non-nil means show inline images when loading a new Org file.
+This can also be configured on a per-file basis by adding one of
+the following lines anywhere in the buffer:
+ #+STARTUP: inlineimages
+ #+STARTUP: noinlineimages"
+ :group 'org-startup
+ :type 'boolean)
+
(defcustom org-insert-mode-line-in-empty-file nil
"Non-nil means insert the first line setting Org-mode in empty files.
When the function `org-mode' is called interactively in an empty file, this
@@ -360,10 +508,10 @@ become effective."
:type 'boolean)
(defcustom org-use-extra-keys nil
- "Non-nil means use extra key sequence definitions for certain
-commands. This happens automatically if you run XEmacs or if
-window-system is nil. This variable lets you do the same
-manually. You must set it before loading org.
+ "Non-nil means use extra key sequence definitions for certain commands.
+This happens automatically if you run XEmacs or if `window-system'
+is nil. This variable lets you do the same manually. You must
+set it before loading org.
Example: on Carbon Emacs 22 running graphically, with an external
keyboard on a Powerbook, the default way of setting M-left might
@@ -394,14 +542,17 @@ therefore you'll have to restart Emacs to apply it after changing."
(defun org-key (key)
"Select key according to `org-replace-disputed-keys' and `org-disputed-keys'.
-Or return the original if not disputed."
- (if org-replace-disputed-keys
- (let* ((nkey (key-description key))
- (x (org-find-if (lambda (x)
- (equal (key-description (car x)) nkey))
- org-disputed-keys)))
- (if x (cdr x) key))
- key))
+Or return the original if not disputed.
+Also apply the translations defined in `org-xemacs-key-equivalents'."
+ (when org-replace-disputed-keys
+ (let* ((nkey (key-description key))
+ (x (org-find-if (lambda (x)
+ (equal (key-description (car x)) nkey))
+ org-disputed-keys)))
+ (setq key (if x (cdr x) key))))
+ (when (featurep 'xemacs)
+ (setq key (or (cdr (assoc key org-xemacs-key-equivalents)) key)))
+ key)
(defun org-find-if (predicate seq)
(catch 'exit
@@ -514,7 +665,7 @@ After a match, group 1 contains the repeat expression.")
"Contexts for the reveal options.")
(defcustom org-show-hierarchy-above '((default . t))
- "Non-nil means, show full hierarchy when revealing a location.
+ "Non-nil means show full hierarchy when revealing a location.
Org-mode often shows locations in an org-mode file which might have
been invisible before. When this is set, the hierarchy of headings
above the exposed location is shown.
@@ -534,7 +685,7 @@ contexts. Valid contexts are
:type org-context-choice)
(defcustom org-show-following-heading '((default . nil))
- "Non-nil means, show following heading when revealing a location.
+ "Non-nil means show following heading when revealing a location.
Org-mode often shows locations in an org-mode file which might have
been invisible before. When this is set, the heading following the
match is shown.
@@ -547,7 +698,7 @@ contexts. See `org-show-hierarchy-above' for valid contexts."
:type org-context-choice)
(defcustom org-show-siblings '((default . nil) (isearch t))
- "Non-nil means, show all sibling heading when revealing a location.
+ "Non-nil means show all sibling heading when revealing a location.
Org-mode often shows locations in an org-mode file which might have
been invisible before. When this is set, the sibling of the current entry
heading are all made visible. If `org-show-hierarchy-above' is t,
@@ -563,7 +714,7 @@ contexts. See `org-show-hierarchy-above' for valid contexts."
:type org-context-choice)
(defcustom org-show-entry-below '((default . nil))
- "Non-nil means, show the entry below a headline when revealing a location.
+ "Non-nil means show the entry below a headline when revealing a location.
Org-mode often shows locations in an org-mode file which might have
been invisible before. When this is set, the text below the headline that is
exposed is also shown.
@@ -594,7 +745,7 @@ new-frame Make a new frame each time. Note that in this case
(const :tag "One dedicated frame" dedicated-frame)))
(defcustom org-use-speed-commands nil
- "Non-nil means, activate single letter commands at beginning of a headline.
+ "Non-nil means activate single letter commands at beginning of a headline.
This may also be a function to test for appropriate locations where speed
commands should be active."
:group 'org-structure
@@ -614,7 +765,7 @@ The cdr is either a command to be called interactively, a function
to be called, or a form to be evaluated.
An entry that is just a list with a single string will be interpreted
as a descriptive headline that will be added when listing the speed
-copmmands in the Help buffer using the `?' speed command."
+commands in the Help buffer using the `?' speed command."
:group 'org-structure
:type '(repeat :value ("k" . ignore)
(choice :value ("k" . ignore)
@@ -631,7 +782,7 @@ copmmands in the Help buffer using the `?' speed command."
:group 'org-structure)
(defcustom org-cycle-skip-children-state-if-no-children t
- "Non-nil means, skip CHILDREN state in entries that don't have any."
+ "Non-nil means skip CHILDREN state in entries that don't have any."
:group 'org-cycle
:type 'boolean)
@@ -668,7 +819,7 @@ Drawers can be defined on the per-file basis with a line like:
:type '(repeat (string :tag "Drawer Name")))
(defcustom org-hide-block-startup nil
- "Non-nil means, , entering Org-mode will fold all blocks.
+ "Non-nil means entering Org-mode will fold all blocks.
This can also be set in on a per-file basis with
#+STARTUP: hideblocks
@@ -680,7 +831,8 @@ This can also be set in on a per-file basis with
(defcustom org-cycle-global-at-bob nil
"Cycle globally if cursor is at beginning of buffer and not at a headline.
This makes it possible to do global cycling without having to use S-TAB or
-C-u TAB. For this special case to work, the first line of the buffer
+\\[universal-argument] TAB. For this special case to work, the first line \
+of the buffer
must not be a headline - it may be empty or some other text. When used in
this way, `org-cycle-hook' is disables temporarily, to make sure the
cursor stays at the beginning of the buffer.
@@ -690,11 +842,11 @@ of the buffer."
:type 'boolean)
(defcustom org-cycle-level-after-item/entry-creation t
- "Non-nil means, cycle entry level or item indentation in new empty entries.
+ "Non-nil means cycle entry level or item indentation in new empty entries.
When the cursor is at the end of an empty headline, i.e with only stars
and maybe a TODO keyword, TAB will then switch the entry to become a child,
-and then all possible anchestor states, before returning to the original state.
+and then all possible ancestor states, before returning to the original state.
This makes data entry extremely fast: M-RET to create a new headline,
on TAB to make it a child, two or more tabs to make it a (grand-)uncle.
@@ -727,7 +879,7 @@ If you leave an empty line between the end of a subtree and the following
headline, this empty line is hidden when the subtree is folded.
Org-mode will leave (exactly) one empty line visible if the number of
empty lines is equal or larger to the number given in this variable.
-So the default 2 means, at least 2 empty lines after the end of a subtree
+So the default 2 means at least 2 empty lines after the end of a subtree
are needed to produce free space between a collapsed subtree and the
following headline.
@@ -768,7 +920,7 @@ the values `folded', `children', or `subtree'."
:group 'org-structure)
(defcustom org-odd-levels-only nil
- "Non-nil means, skip even levels and only use odd levels for the outline.
+ "Non-nil means skip even levels and only use odd levels for the outline.
This has the effect that two stars are being added/taken away in
promotion/demotion commands. It also influences how levels are
handled by the exporters.
@@ -780,11 +932,11 @@ lines to the buffer:
#+STARTUP: odd
#+STARTUP: oddeven"
:group 'org-edit-structure
- :group 'org-font-lock
+ :group 'org-appearance
:type 'boolean)
(defcustom org-adapt-indentation t
- "Non-nil means, adapt indentation to outline node level.
+ "Non-nil means adapt indentation to outline node level.
When this variable is set, Org assumes that you write outlines by
indenting text in each node to align with the headline (after the stars).
@@ -857,8 +1009,20 @@ When t, the following will happen while the cursor is in the headline:
:group 'org-edit-structure
:type 'boolean)
+(defcustom org-ctrl-k-protect-subtree nil
+ "Non-nil means, do not delete a hidden subtree with C-k.
+When set to the symbol `error', simply throw an error when C-k is
+used to kill (part-of) a headline that has hidden text behind it.
+Any other non-nil value will result in a query to the user, if it is
+OK to kill that hidden subtree. When nil, kill without remorse."
+ :group 'org-edit-structure
+ :type '(choice
+ (const :tag "Do not protect hidden subtrees" nil)
+ (const :tag "Protect hidden subtrees with a security query" t)
+ (const :tag "Never kill a hidden subtree with C-k" error)))
+
(defcustom org-yank-folded-subtrees t
- "Non-nil means, when yanking subtrees, fold them.
+ "Non-nil means when yanking subtrees, fold them.
If the kill is a single subtree, or a sequence of subtrees, i.e. if
it starts with a heading and all other headings in it are either children
or siblings, then fold all the subtrees. However, do this only if no
@@ -867,14 +1031,14 @@ text after the yank would be swallowed into a folded tree by this action."
:type 'boolean)
(defcustom org-yank-adjusted-subtrees nil
- "Non-nil means, when yanking subtrees, adjust the level.
+ "Non-nil means when yanking subtrees, adjust the level.
With this setting, `org-paste-subtree' is used to insert the subtree, see
this function for details."
:group 'org-edit-structure
:type 'boolean)
(defcustom org-M-RET-may-split-line '((default . t))
- "Non-nil means, M-RET will split the line at the cursor position.
+ "Non-nil means M-RET will split the line at the cursor position.
When nil, it will go to the end of the line before making a
new line.
You may also set this option in a different way for different
@@ -901,7 +1065,7 @@ default the value to be used for all contexts not explicitly
(defcustom org-insert-heading-respect-content nil
- "Non-nil means, insert new headings after the current subtree.
+ "Non-nil means insert new headings after the current subtree.
When nil, the new heading is created directly after the current line.
The commands \\[org-insert-heading-respect-content] and
\\[org-insert-todo-heading-respect-content] turn this variable on
@@ -913,9 +1077,13 @@ for the duration of the command."
(plain-list-item . auto))
"Should `org-insert-heading' leave a blank line before new heading/item?
The value is an alist, with `heading' and `plain-list-item' as car,
-and a boolean flag as cdr. For plain lists, if the variable
-`org-empty-line-terminates-plain-lists' is set, the setting here
-is ignored and no empty line is inserted, to keep the list in tact."
+and a boolean flag as cdr. The cdr may lso be the symbol `auto', and then
+Org will look at the surrounding headings/items and try to make an
+intelligent decision wether to insert a blank line or not.
+
+For plain lists, if the variable `org-empty-line-terminates-plain-lists' is
+set, the setting here is ignored and no empty line is inserted, to avoid
+breaking the list structure."
:group 'org-edit-structure
:type '(list
(cons (const heading)
@@ -933,16 +1101,15 @@ is ignored and no empty line is inserted, to keep the list in tact."
:type 'hook)
(defcustom org-enable-fixed-width-editor t
- "Non-nil means, lines starting with \":\" are treated as fixed-width.
-This currently only means, they are never auto-wrapped.
+ "Non-nil means lines starting with \":\" are treated as fixed-width.
+This currently only means they are never auto-wrapped.
When nil, such lines will be treated like ordinary lines.
See also the QUOTE keyword."
:group 'org-edit-structure
:type 'boolean)
-
(defcustom org-goto-auto-isearch t
- "Non-nil means, typing characters in org-goto starts incremental search."
+ "Non-nil means typing characters in `org-goto' starts incremental search."
:group 'org-edit-structure
:type 'boolean)
@@ -952,14 +1119,14 @@ See also the QUOTE keyword."
:group 'org-structure)
(defcustom org-highlight-sparse-tree-matches t
- "Non-nil means, highlight all matches that define a sparse tree.
+ "Non-nil means highlight all matches that define a sparse tree.
The highlights will automatically disappear the next time the buffer is
changed by an edit command."
:group 'org-sparse-trees
:type 'boolean)
(defcustom org-remove-highlights-with-change t
- "Non-nil means, any change to the buffer will remove temporary highlights.
+ "Non-nil means any change to the buffer will remove temporary highlights.
Such highlights are created by `org-occur' and `org-clock-display'.
When nil, `C-c C-c needs to be used to get rid of the highlights.
The highlights created by `org-preview-latex-fragment' always need
@@ -993,7 +1160,7 @@ This also applied for speedbar access."
:group 'org)
(defcustom org-enable-table-editor 'optimized
- "Non-nil means, lines starting with \"|\" are handled by the table editor.
+ "Non-nil means lines starting with \"|\" are handled by the table editor.
When nil, such lines will be treated like ordinary lines.
When equal to the symbol `optimized', the table editor will be optimized to
@@ -1032,7 +1199,7 @@ This is configurable, because there is some impact on typing performance."
:type 'boolean)
(defcustom org-table-tab-recognizes-table.el t
- "Non-nil means, TAB will automatically notice a table.el table.
+ "Non-nil means TAB will automatically notice a table.el table.
When it sees such a table, it moves point into it and - if necessary -
calls `table-recognize-table'."
:group 'org-table-editing
@@ -1077,7 +1244,7 @@ See the manual for examples."
(function)))))
(defcustom org-descriptive-links t
- "Non-nil means, hide link part and only show description of bracket links.
+ "Non-nil means hide link part and only show description of bracket links.
Bracket links are like [[link][description]]. This variable sets the initial
state in new org-mode buffers. The setting can then be toggled on a
per-buffer basis from the Org->Hyperlinks menu."
@@ -1108,7 +1275,7 @@ type. In principle, it does not hurt to turn on most link types - there may
be a small gain when turning off unused link types. The types are:
bracket The recommended [[link][description]] or [[link]] links with hiding.
-angular Links in angular brackets that may contain whitespace like
+angle Links in angular brackets that may contain whitespace like
<bbdb:Carsten Dominik>.
plain Plain links in normal text, no whitespace, like http://google.com.
radio Text that is matched by a radio target, see manual for details.
@@ -1119,8 +1286,8 @@ footnote Footnote labels.
Changing this variable requires a restart of Emacs to become effective."
:group 'org-link
:type '(set :greedy t
- (const :tag "Double bracket links (new style)" bracket)
- (const :tag "Angular bracket links (old style)" angular)
+ (const :tag "Double bracket links" bracket)
+ (const :tag "Angular bracket links" angle)
(const :tag "Plain text links" plain)
(const :tag "Radio target matches" radio)
(const :tag "Tags" tag)
@@ -1128,11 +1295,11 @@ Changing this variable requires a restart of Emacs to become effective."
(const :tag "Footnotes" footnote)))
(defcustom org-make-link-description-function nil
- "Function to use to generate link descriptions from links. If
-nil the link location will be used. This function must take two
-parameters; the first is the link and the second the description
-org-insert-link has generated, and should return the description
-to use."
+ "Function to use to generate link descriptions from links.
+If nil the link location will be used. This function must take
+two parameters; the first is the link and the second the
+description `org-insert-link' has generated, and should return the
+description to use."
:group 'org-link
:type 'function)
@@ -1174,7 +1341,7 @@ It should match if the message is from the user him/herself."
:type 'regexp)
(defcustom org-link-to-org-use-id 'create-if-interactive-and-no-custom-id
- "Non-nil means, storing a link to an Org file will use entry IDs.
+ "Non-nil means storing a link to an Org file will use entry IDs.
Note that before this variable is even considered, org-id must be loaded,
so please customize `org-modules' and turn it on.
@@ -1214,7 +1381,7 @@ nil Never use an ID to make a link, instead link using a text search for
(const :tag "Do not use ID to create link" nil)))
(defcustom org-context-in-file-links t
- "Non-nil means, file links from `org-store-link' contain context.
+ "Non-nil means file links from `org-store-link' contain context.
A search string will be added to the file name with :: as separator and
used to find the context when the link is activated by the command
`org-open-at-point'.
@@ -1224,7 +1391,7 @@ negates this setting for the duration of the command."
:type 'boolean)
(defcustom org-keep-stored-link-after-insertion nil
- "Non-nil means, keep link in list for entire session.
+ "Non-nil means keep link in list for entire session.
The command `org-store-link' adds a link pointing to the current
location to an internal list. These links accumulate during a session.
@@ -1261,7 +1428,7 @@ links created by planner."
:type 'hook)
(defcustom org-tab-follows-link nil
- "Non-nil means, on links TAB will follow the link.
+ "Non-nil means on links TAB will follow the link.
Needs to be set before org.el is loaded.
This really should not be used, it does not make sense, and the
implementation is bad."
@@ -1269,29 +1436,40 @@ implementation is bad."
:type 'boolean)
(defcustom org-return-follows-link nil
- "Non-nil means, on links RET will follow the link.
-Needs to be set before org.el is loaded."
+ "Non-nil means on links RET will follow the link."
:group 'org-link-follow
:type 'boolean)
(defcustom org-mouse-1-follows-link
(if (boundp 'mouse-1-click-follows-link) mouse-1-click-follows-link t)
- "Non-nil means, mouse-1 on a link will follow the link.
+ "Non-nil means mouse-1 on a link will follow the link.
A longer mouse click will still set point. Does not work on XEmacs.
Needs to be set before org.el is loaded."
:group 'org-link-follow
:type 'boolean)
(defcustom org-mark-ring-length 4
- "Number of different positions to be recorded in the ring
+ "Number of different positions to be recorded in the ring.
Changing this requires a restart of Emacs to work correctly."
:group 'org-link-follow
:type 'integer)
+(defcustom org-link-search-must-match-exact-headline 'query-to-create
+ "Non-nil means internal links in Org files must exactly match a headline.
+When nil, the link search tries to match a phrase will all words
+in the search text."
+ :group 'org-link-follow
+ :type '(choice
+ (const :tag "Use fuzy text search" nil)
+ (const :tag "Match only exact headline" t)
+ (const :tag "Match extact headline or query to create it"
+ query-to-create)))
+
(defcustom org-link-frame-setup
'((vm . vm-visit-folder-other-frame)
- (gnus . gnus-other-frame)
- (file . find-file-other-window))
+ (gnus . org-gnus-no-new-news)
+ (file . find-file-other-window)
+ (wl . wl-other-frame))
"Setup the frame configuration for following links.
When following a link with Emacs, it may often be useful to display
this link in another window or frame. This variable can be used to
@@ -1307,6 +1485,9 @@ For FILE, use any of
`find-file'
`find-file-other-window'
`find-file-other-frame'
+For Wanderlust use any of
+ `wl'
+ `wl-other-frame'
For the calendar, use the variable `calendar-setup'.
For BBDB, it is currently only possible to display the matches in
another window."
@@ -1326,13 +1507,18 @@ another window."
(choice
(const find-file)
(const find-file-other-window)
- (const find-file-other-frame)))))
+ (const find-file-other-frame)))
+ (cons (const wl)
+ (choice
+ (const wl)
+ (const wl-other-frame)))))
(defcustom org-display-internal-link-with-indirect-buffer nil
- "Non-nil means, use indirect buffer to display infile links.
+ "Non-nil means use indirect buffer to display infile links.
Activating internal links (from one location in a file to another location
in the same file) normally just jumps to the location. When the link is
-activated with a C-u prefix (or with mouse-3), the link is displayed in
+activated with a \\[universal-argument] prefix (or with mouse-3), the link \
+is displayed in
another window. When this option is set, the other window actually displays
an indirect buffer clone of the current buffer, to avoid any visibility
changes to the current buffer."
@@ -1340,7 +1526,7 @@ changes to the current buffer."
:type 'boolean)
(defcustom org-open-non-existing-files nil
- "Non-nil means, `org-open-file' will open non-existing files.
+ "Non-nil means `org-open-file' will open non-existing files.
When nil, an error will be generated.
This variable applies only to external applications because they
might choke on non-existing files. If the link is to a file that
@@ -1349,7 +1535,7 @@ will be opened in Emacs, the variable is ignored."
:type 'boolean)
(defcustom org-open-directory-means-index-dot-org nil
- "Non-nil means, a link to a directory really means to index.org.
+ "Non-nil means a link to a directory really means to index.org.
When nil, following a directory link will run dired or open a finder/explorer
window on that directory."
:group 'org-link-follow
@@ -1357,7 +1543,7 @@ window on that directory."
(defcustom org-link-mailto-program '(browse-url "mailto:%a?subject=%s")
"Function and arguments to call for following mailto links.
-This is a list with the first element being a lisp function, and the
+This is a list with the first element being a Lisp function, and the
remaining elements being arguments to the function. In string arguments,
%a will be replaced by the address, and %s will be replaced by the subject
if one was given like in <mailto:arthur@galaxy.org::this subject>."
@@ -1369,7 +1555,7 @@ if one was given like in <mailto:arthur@galaxy.org::this subject>."
(cons :tag "other" (function) (repeat :tag "argument" sexp))))
(defcustom org-confirm-shell-link-function 'yes-or-no-p
- "Non-nil means, ask for confirmation before executing shell links.
+ "Non-nil means ask for confirmation before executing shell links.
Shell links can be dangerous: just think about a link
[[shell:rm -rf ~/*][Google Search]]
@@ -1384,9 +1570,12 @@ single keystroke rather than having to type \"yes\"."
(const :tag "with yes-or-no (safer)" yes-or-no-p)
(const :tag "with y-or-n (faster)" y-or-n-p)
(const :tag "no confirmation (dangerous)" nil)))
+(put 'org-confirm-shell-link-function
+ 'safe-local-variable
+ '(lambda (x) (member x '(yes-or-no-p y-or-n-p))))
(defcustom org-confirm-elisp-link-function 'yes-or-no-p
- "Non-nil means, ask for confirmation before executing Emacs Lisp links.
+ "Non-nil means ask for confirmation before executing Emacs Lisp links.
Elisp links can be dangerous: just think about a link
[[elisp:(shell-command \"rm -rf ~/*\")][Google Search]]
@@ -1401,6 +1590,9 @@ single keystroke rather than having to type \"yes\"."
(const :tag "with yes-or-no (safer)" yes-or-no-p)
(const :tag "with y-or-n (faster)" y-or-n-p)
(const :tag "no confirmation (dangerous)" nil)))
+(put 'org-confirm-shell-link-function
+ 'safe-local-variable
+ '(lambda (x) (member x '(yes-or-no-p y-or-n-p))))
(defconst org-file-apps-defaults-gnu
'((remote . emacs)
@@ -1452,9 +1644,37 @@ you can use this variable to set the application for a given file
extension. The entries in this list are cons cells where the car identifies
files and the cdr the corresponding command. Possible values for the
file identifier are
- \"regex\" Regular expression matched against the file name. For backward
- compatibility, this can also be a string with only alphanumeric
- characters, which is then interpreted as an extension.
+ \"string\" A string as a file identifier can be interpreted in different
+ ways, depending on its contents:
+
+ - Alphanumeric characters only:
+ Match links with this file extension.
+ Example: (\"pdf\" . \"evince %s\")
+ to open PDFs with evince.
+
+ - Regular expression: Match links where the
+ filename matches the regexp. If you want to
+ use groups here, use shy groups.
+
+ Example: (\"\\.x?html\\'\" . \"firefox %s\")
+ (\"\\(?:xhtml\\|html\\)\" . \"firefox %s\")
+ to open *.html and *.xhtml with firefox.
+
+ - Regular expression which contains (non-shy) groups:
+ Match links where the whole link, including \"::\", and
+ anything after that, matches the regexp.
+ In a custom command string, %1, %2, etc. are replaced with
+ the parts of the link that were matched by the groups.
+ For backwards compatibility, if a command string is given
+ that does not use any of the group matches, this case is
+ handled identically to the second one (i.e. match against
+ file name only).
+ In a custom lisp form, you can access the group matches with
+ (match-string n link).
+
+ Example: (\"\\.pdf::\\(\\d+\\)\\'\" . \"evince -p %1 %s\")
+ to open [[file:document.pdf::5]] with evince at page 5.
+
`directory' Matches a directory
`remote' Matches a remote file, accessible through tramp or efs.
Remote files most likely should be visited through Emacs
@@ -1468,7 +1688,7 @@ file identifier are
`system' The system command to open files, like `open' on Windows
and Mac OS X, and mailcap under GNU/Linux. This is the command
that will be selected if you call `C-c C-o' with a double
- `C-u C-u' prefix.
+ \\[universal-argument] \\[universal-argument] prefix.
Possible values for the command are:
`emacs' The file will be visited by the current Emacs process.
@@ -1507,6 +1727,8 @@ For more examples, see the system specific constants
(string :tag "Command")
(sexp :tag "Lisp form")))))
+
+
(defgroup org-refile nil
"Options concerning refiling entries in Org-mode."
:tag "Org Refile"
@@ -1530,10 +1752,8 @@ following situations:
(defcustom org-default-notes-file (convert-standard-filename "~/.notes")
"Default target for storing notes.
-Used by the hooks for remember.el. This can be a string, or nil to mean
-the value of `remember-data-file'.
-You can set this on a per-template basis with the variable
-`org-remember-templates'."
+Used as a fall back file for org-remember.el and org-capture.el, for
+templates that do not specify a target file."
:group 'org-refile
:group 'org-remember
:type '(choice
@@ -1555,12 +1775,12 @@ outline-path-completion Headlines in the current buffer are offered via
(const :tag "Outline-path-completion" outline-path-completion)))
(defcustom org-goto-max-level 5
- "Maximum level to be considered when running org-goto with refile interface."
+ "Maximum target level when running `org-goto' with refile interface."
:group 'org-refile
:type 'integer)
(defcustom org-reverse-note-order nil
- "Non-nil means, store new notes at the beginning of a file or entry.
+ "Non-nil means store new notes at the beginning of a file or entry.
When nil, new notes will be filed to the end of a file or entry.
This can also be a list with cons cells of regular expressions that
are matched against file names, and values."
@@ -1572,13 +1792,40 @@ are matched against file names, and values."
(repeat :tag "By file name regexp"
(cons regexp boolean))))
+(defcustom org-log-refile nil
+ "Information to record when a task is refiled.
+
+Possible values are:
+
+nil Don't add anything
+time Add a time stamp to the task
+note Prompt for a note and add it with template `org-log-note-headings'
+
+This option can also be set with on a per-file-basis with
+
+ #+STARTUP: nologrefile
+ #+STARTUP: logrefile
+ #+STARTUP: lognoterefile
+
+You can have local logging settings for a subtree by setting the LOGGING
+property to one or more of these keywords.
+
+When bulk-refiling from the agenda, the value `note' is forbidden and
+will temporarily be changed to `time'."
+ :group 'org-refile
+ :group 'org-progress
+ :type '(choice
+ (const :tag "No logging" nil)
+ (const :tag "Record timestamp" time)
+ (const :tag "Record timestamp with note." note)))
+
(defcustom org-refile-targets nil
"Targets for refiling entries with \\[org-refile].
This is list of cons cells. Each cell contains:
- a specification of the files to be considered, either a list of files,
or a symbol whose function or variable value will be used to retrieve
a file name or a list of file names. If you use `org-agenda-files' for
- that, all agenda files will be scanned for targets. Nil means, consider
+ that, all agenda files will be scanned for targets. Nil means consider
headings in the current buffer.
- A specification of how to find candidate refile targets. This may be
any of:
@@ -1597,7 +1844,7 @@ This is list of cons cells. Each cell contains:
order in hierarchy, not to the number of stars.
You can set the variable `org-refile-target-verify-function' to a function
-to verify each headline found by the simple critery above.
+to verify each headline found by the simple criteria above.
When this variable is nil, all top-level headlines in the current buffer
are used, equivalent to the value `((nil . (:level . 1))'."
@@ -1629,8 +1876,19 @@ of the subtree."
:group 'org-refile
:type 'function)
+(defcustom org-refile-use-cache nil
+ "Non-nil means cache refile targets to speed up the process.
+The cache for a particular file will be updated automatically when
+the buffer has been killed, or when any of the marker used for flagging
+refile targets no longer points at a live buffer.
+If you have added new entries to a buffer that might themselves be targets,
+you need to clear the cache manually by pressing `C-0 C-c C-w' or, if you
+find that easier, `C-u C-u C-u C-c C-w'."
+ :group 'org-refile
+ :type 'boolean)
+
(defcustom org-refile-use-outline-path nil
- "Non-nil means, provide refile targets as paths.
+ "Non-nil means provide refile targets as paths.
So a level 3 headline will be available as level1/level2/level3.
When the value is `file', also include the file name (without directory)
@@ -1646,7 +1904,7 @@ the file name, to get entries inserted as top level in the file.
(const :tag "Start with full file path" full-file-path)))
(defcustom org-outline-path-complete-in-steps t
- "Non-nil means, complete the outline path in hierarchical steps.
+ "Non-nil means complete the outline path in hierarchical steps.
When Org-mode uses the refile interface to select an outline path
\(see variable `org-refile-use-outline-path'), the completion of
the path can be done is a single go, or if can be done in steps down
@@ -1658,7 +1916,7 @@ fast, while still showing the whole path to the entry."
:type 'boolean)
(defcustom org-refile-allow-creating-parent-nodes nil
- "Non-nil means, allow to create new nodes as refile targets.
+ "Non-nil means allow to create new nodes as refile targets.
New nodes are then created by adding \"/new node name\" to the completion
of an existing node. When the value of this variable is `confirm',
new node creation must be confirmed by the user (recommended)
@@ -1688,9 +1946,8 @@ heading."
'(
(:tag "Sequence (cycling hits every state)" sequence)
(:tag "Type (cycling directly to DONE)" type))
- "The available interpretation symbols for customizing
- `org-todo-keywords'.
- Interested libraries should add to this list.")
+ "The available interpretation symbols for customizing `org-todo-keywords'.
+Interested libraries should add to this list.")
(defcustom org-todo-keywords '((sequence "TODO" "DONE"))
"List of TODO entry keyword sequences and their interpretation.
@@ -1716,7 +1973,7 @@ Each keyword can optionally specify a character for fast state selection
\(in combination with the variable `org-use-fast-todo-selection')
and specifiers for state change logging, using the same syntax
that is used in the \"#+TODO:\" lines. For example, \"WAIT(w)\" says
-that the WAIT state can be selected with the \"w\" key. \"WAIT(w!)\"
+that the WAIT state can be selected with the \"w\" key. \"WAIT(w!)\"
indicates to record a time stamp each time this state is selected.
Each keyword may also specify if a timestamp or a note should be
@@ -1794,7 +2051,7 @@ more information."
(const type)))
(defcustom org-use-fast-todo-selection t
- "Non-nil means, use the fast todo selection scheme with C-c C-t.
+ "Non-nil means use the fast todo selection scheme with C-c C-t.
This variable describes if and under what circumstances the cycling
mechanism for TODO keywords will be replaced by a single-key, direct
selection scheme.
@@ -1818,7 +2075,7 @@ by a letter in parenthesis, like TODO(t)."
(const :tag "Only with C-u C-c C-t" prefix)))
(defcustom org-provide-todo-statistics t
- "Non-nil means, update todo statistics after insert and toggle.
+ "Non-nil means update todo statistics after insert and toggle.
ALL-HEADLINES means update todo statistics by including headlines
with no TODO keyword as well, counting them as not done.
A list of TODO keywords means the same, but skip keywords that are
@@ -1835,7 +2092,7 @@ current entry each time a todo state is changed."
(other :tag "No TODO statistics" nil)))
(defcustom org-hierarchical-todo-statistics t
- "Non-nil means, TODO statistics covers just direct children.
+ "Non-nil means TODO statistics covers just direct children.
When nil, all entries in the subtree are considered.
This has only an effect if `org-provide-todo-statistics' is set.
To set this to nil for only a single subtree, use a COOKIE_DATA
@@ -1880,7 +2137,7 @@ TODO state changes
:to new state, like in :from")
(defcustom org-enforce-todo-dependencies nil
- "Non-nil means, undone TODO entries will block switching the parent to DONE.
+ "Non-nil means undone TODO entries will block switching the parent to DONE.
Also, if a parent has an :ORDERED: property, switching an entry to DONE will
be blocked if any prior sibling is not yet done.
Finally, if the parent is blocked because of ordered siblings of its own,
@@ -1899,7 +2156,7 @@ to change is while Emacs is running is through the customize interface."
:type 'boolean)
(defcustom org-enforce-todo-checkbox-dependencies nil
- "Non-nil means, unchecked boxes will block switching the parent to DONE.
+ "Non-nil means unchecked boxes will block switching the parent to DONE.
When this is nil, checkboxes have no influence on switching TODO states.
When non-nil, you first need to check off all check boxes before the TODO
entry can be switched to DONE.
@@ -1917,7 +2174,7 @@ to change is while Emacs is running is through the customize interface."
:type 'boolean)
(defcustom org-treat-insert-todo-heading-as-state-change nil
- "Non-nil means, inserting a TODO heading is treated as state change.
+ "Non-nil means inserting a TODO heading is treated as state change.
So when the command \\[org-insert-todo-heading] is used, state change
logging will apply if appropriate. When nil, the new TODO item will
be inserted directly, and no logging will take place."
@@ -1925,7 +2182,7 @@ be inserted directly, and no logging will take place."
:type 'boolean)
(defcustom org-treat-S-cursor-todo-selection-as-state-change t
- "Non-nil means, switching TODO states with S-cursor counts as state change.
+ "Non-nil means switching TODO states with S-cursor counts as state change.
This is the default behavior. However, setting this to nil allows a
convenient way to select a TODO state and bypass any logging associated
with that."
@@ -2029,7 +2286,7 @@ property to one or more of these keywords."
(const :tag "Record timestamp with note." note)))
(defcustom org-log-note-clock-out nil
- "Non-nil means, record a note when clocking out of an item.
+ "Non-nil means record a note when clocking out of an item.
This can also be configured on a per-file basis by adding one of
the following lines anywhere in the buffer:
@@ -2040,7 +2297,7 @@ the following lines anywhere in the buffer:
:type 'boolean)
(defcustom org-log-done-with-time t
- "Non-nil means, the CLOSED time stamp will contain date and time.
+ "Non-nil means the CLOSED time stamp will contain date and time.
When nil, only the date will be recorded."
:group 'org-progress
:type 'boolean)
@@ -2050,17 +2307,24 @@ When nil, only the date will be recorded."
(state . "State %-12s from %-12S %t")
(note . "Note taken on %t")
(reschedule . "Rescheduled from %S on %t")
+ (delschedule . "Not scheduled, was %S on %t")
(redeadline . "New deadline from %S on %t")
+ (deldeadline . "Removed deadline, was %S on %t")
+ (refile . "Refiled on %t")
(clock-out . ""))
"Headings for notes added to entries.
The value is an alist, with the car being a symbol indicating the note
context, and the cdr is the heading to be used. The heading may also be the
empty string.
%t in the heading will be replaced by a time stamp.
+%T will be an active time stamp instead the default inactive one
%s will be replaced by the new TODO state, in double quotes.
%S will be replaced by the old TODO state, in double quotes.
%u will be replaced by the user name.
-%U will be replaced by the full user name."
+%U will be replaced by the full user name.
+
+In fact, it is not a good idea to change the `state' entry, because
+agenda log mode depends on the format of these entries."
:group 'org-todo
:group 'org-progress
:type '(list :greedy t
@@ -2070,14 +2334,17 @@ empty string.
state) string)
(cons (const :tag "Heading when just taking a note" note) string)
(cons (const :tag "Heading when clocking out" clock-out) string)
+ (cons (const :tag "Heading when an item is no longer scheduled" delschedule) string)
(cons (const :tag "Heading when rescheduling" reschedule) string)
- (cons (const :tag "Heading when changing deadline" redeadline) string)))
+ (cons (const :tag "Heading when changing deadline" redeadline) string)
+ (cons (const :tag "Heading when deleting a deadline" deldeadline) string)
+ (cons (const :tag "Heading when refiling" refile) string)))
(unless (assq 'note org-log-note-headings)
(push '(note . "%t") org-log-note-headings))
(defcustom org-log-into-drawer nil
- "Non-nil means, insert state change notes and time stamps into a drawer.
+ "Non-nil means insert state change notes and time stamps into a drawer.
When nil, state changes notes will be inserted after the headline and
any scheduling and clock lines, but not inside a drawer.
@@ -2113,7 +2380,7 @@ used instead of the default value."
(t p))))
(defcustom org-log-state-notes-insert-after-drawers nil
- "Non-nil means, insert state change notes after any drawers in entry.
+ "Non-nil means insert state change notes after any drawers in entry.
Only the drawers that *immediately* follow the headline and the
deadline/scheduled line are skipped.
When nil, insert notes right after the heading and perhaps the line
@@ -2126,16 +2393,25 @@ set."
:type 'boolean)
(defcustom org-log-states-order-reversed t
- "Non-nil means, the latest state change note will be directly after heading.
-When nil, the notes will be orderer according to time."
+ "Non-nil means the latest state note will be directly after heading.
+When nil, the state change notes will be ordered according to time."
:group 'org-todo
:group 'org-progress
:type 'boolean)
+(defcustom org-todo-repeat-to-state nil
+ "The TODO state to which a repeater should return the repeating task.
+By default this is the first task in a TODO sequence, or the previous state
+in a TODO_TYP set. But you can specify another task here.
+alternatively, set the :REPEAT_TO_STATE: property of the entry."
+ :group 'org-todo
+ :type '(choice (const :tag "Head of sequence" nil)
+ (string :tag "Specific state")))
+
(defcustom org-log-repeat 'time
- "Non-nil means, record moving through the DONE state when triggering repeat.
+ "Non-nil means record moving through the DONE state when triggering repeat.
An auto-repeating task is immediately switched back to TODO when
-marked DONE. If you are not logging state changes (by adding \"@\"
+marked DONE. If you are not logging state changes (by adding \"@\"
or \"!\" to the TODO keyword definition), or set `org-log-done' to
record a closing note, there will be no record of the task moving
through DONE. This variable forces taking a note anyway.
@@ -2166,7 +2442,7 @@ property to one or more of these keywords."
:group 'org-todo)
(defcustom org-enable-priority-commands t
- "Non-nil means, priority commands are active.
+ "Non-nil means priority commands are active.
When nil, these commands will be disabled, so that you never accidentally
set a priority."
:group 'org-priorities
@@ -2191,7 +2467,7 @@ This is the priority an item get if no explicit priority is given."
:type 'character)
(defcustom org-priority-start-cycle-with-default t
- "Non-nil means, start with default priority when starting to cycle.
+ "Non-nil means start with default priority when starting to cycle.
When this is nil, the first step in the cycle will be (depending on the
command used) one higher or lower that the default priority."
:group 'org-priorities
@@ -2203,7 +2479,7 @@ command used) one higher or lower that the default priority."
:group 'org)
(defcustom org-insert-labeled-timestamps-at-point nil
- "Non-nil means, SCHEDULED and DEADLINE timestamps are inserted at point.
+ "Non-nil means SCHEDULED and DEADLINE timestamps are inserted at point.
When nil, these labeled time stamps are forces into the second line of an
entry, just after the headline. When scheduling from the global TODO list,
the time stamp will always be forced into the second line."
@@ -2224,12 +2500,12 @@ of N minutes, as given by the second value.
When a setting is 0 or 1, insert the time unmodified. Useful rounding
numbers should be factors of 60, so for example 5, 10, 15.
-When this is larger than 1, you can still force an exact time-stamp by using
-a double prefix argument to a time-stamp command like `C-c .' or `C-c !',
+When this is larger than 1, you can still force an exact time stamp by using
+a double prefix argument to a time stamp command like `C-c .' or `C-c !',
and by using a prefix arg to `S-up/down' to specify the exact number
of minutes to shift."
:group 'org-time
- :get '(lambda (var) ; Make sure all entries have 5 elements
+ :get '(lambda (var) ; Make sure both elements are there
(if (integerp (default-value var))
(list (default-value var) 5)
(default-value var)))
@@ -2244,7 +2520,7 @@ of minutes to shift."
org-time-stamp-rounding-minutes)))
(defcustom org-display-custom-times nil
- "Non-nil means, overlay custom formats over all time stamps.
+ "Non-nil means overlay custom formats over all time stamps.
The formats are defined through the variable `org-time-stamp-custom-formats'.
To turn this on on a per-file basis, insert anywhere in the file:
#+STARTUP: customtime"
@@ -2272,8 +2548,8 @@ commands, if custom time display is turned on at the time of export."
f)))
(defcustom org-time-clocksum-format "%d:%02d"
- "The format string used when creating CLOCKSUM lines, or when
-org-mode generates a time duration."
+ "The format string used when creating CLOCKSUM lines.
+This is also used when org-mode generates a time duration."
:group 'org-time
:type 'string)
@@ -2301,11 +2577,11 @@ Custom commands can set this variable in the options section."
:type 'integer)
(defcustom org-read-date-prefer-future t
- "Non-nil means, assume future for incomplete date input from user.
+ "Non-nil means assume future for incomplete date input from user.
This affects the following situations:
1. The user gives a month but not a year.
- For example, if it is april and you enter \"feb 2\", this will be read
- as feb 2, *next* year. \"May 5\", however, will be this year.
+ For example, if it is April and you enter \"feb 2\", this will be read
+ as Feb 2, *next* year. \"May 5\", however, will be this year.
2. The user gives a day, but no month.
For example, if today is the 15th, and you enter \"3\", Org-mode will
read this as the third of *next* month. However, if you enter \"17\",
@@ -2320,21 +2596,36 @@ will work:
Currently none of this works for ISO week specifications.
When this option is nil, the current day, month and year will always be
-used as defaults."
+used as defaults.
+
+See also `org-agenda-jump-prefer-future'."
:group 'org-time
:type '(choice
(const :tag "Never" nil)
(const :tag "Check month and day" t)
(const :tag "Check month, day, and time" time)))
+(defcustom org-agenda-jump-prefer-future 'org-read-date-prefer-future
+ "Should the agenda jump command prefer the future for incomplete dates?
+The default is to do the same as configured in `org-read-date-prefer-future'.
+But you can alse set a deviating value here.
+This may t or nil, or the symbol `org-read-date-prefer-future'."
+ :group 'org-agenda
+ :group 'org-time
+ :type '(choice
+ (const :tag "Use org-aread-date-prefer-future"
+ org-read-date-prefer-future)
+ (const :tag "Never" nil)
+ (const :tag "Always" t)))
+
(defcustom org-read-date-display-live t
- "Non-nil means, display current interpretation of date prompt live.
+ "Non-nil means display current interpretation of date prompt live.
This display will be in an overlay, in the minibuffer."
:group 'org-time
:type 'boolean)
(defcustom org-read-date-popup-calendar t
- "Non-nil means, pop up a calendar when prompting for a date.
+ "Non-nil means pop up a calendar when prompting for a date.
In the calendar, the date can be selected with mouse-1. However, the
minibuffer will also be active, and you can simply enter the date as well.
When nil, only the minibuffer will be available."
@@ -2367,13 +2658,13 @@ be the favorite working time of John Wiegley :-)"
:type 'integer)
(defcustom org-edit-timestamp-down-means-later nil
- "Non-nil means, S-down will increase the time in a time stamp.
+ "Non-nil means S-down will increase the time in a time stamp.
When nil, S-up will increase."
:group 'org-time
:type 'boolean)
(defcustom org-calendar-follow-timestamp-change t
- "Non-nil means, make the calendar window follow timestamp changes.
+ "Non-nil means make the calendar window follow timestamp changes.
When a timestamp is modified and the calendar window is visible, it will be
moved to the new date."
:group 'org-time
@@ -2425,6 +2716,20 @@ To disable these tags on a per-file basis, insert anywhere in the file:
(const :tag "End radio group" (:endgroup))
(const :tag "New line" (:newline)))))
+(defcustom org-complete-tags-always-offer-all-agenda-tags nil
+ "If non-nil, always offer completion for all tags of all agenda files.
+Instead of customizing this variable directly, you might want to
+set it locally for remember buffers, because there no list of
+tags in that file can be created dynamically (there are none).
+
+ (add-hook 'org-remember-mode-hook
+ (lambda ()
+ (set (make-local-variable
+ 'org-complete-tags-always-offer-all-agenda-tags)
+ t)))"
+ :group 'org-tags
+ :type 'boolean)
+
(defvar org-file-tags nil
"List of tags that can be inherited by all entries in the file.
The tags will be inherited if the variable `org-use-tag-inheritance'
@@ -2432,7 +2737,7 @@ says they should be.
This variable is populated from #+FILETAGS lines.")
(defcustom org-use-fast-tag-selection 'auto
- "Non-nil means, use fast tag selection scheme.
+ "Non-nil means use fast tag selection scheme.
This is a special interface to select and deselect tags with single keys.
When nil, fast selection is never used.
When the symbol `auto', fast selection is used if and only if selection
@@ -2447,7 +2752,7 @@ automatically if necessary."
(const :tag "When selection characters are configured" 'auto)))
(defcustom org-fast-tag-selection-single-key nil
- "Non-nil means, fast tag selection exits after first change.
+ "Non-nil means fast tag selection exits after first change.
When nil, you have to press RET to exit it.
During fast tag selection, you can toggle this flag with `C-c'.
This variable can also have the value `expert'. In this case, the window
@@ -2459,7 +2764,7 @@ displaying the tags menu is not even shown, until you press C-c again."
(const :tag "Expert" expert)))
(defvar org-fast-tag-selection-include-todo nil
- "Non-nil means, fast tags selection interface will also offer TODO states.
+ "Non-nil means fast tags selection interface will also offer TODO states.
This is an undocumented feature, you should not rely on it.")
(defcustom org-tags-column (if (featurep 'xemacs) -76 -77)
@@ -2471,7 +2776,7 @@ it means that the tags should be flushright to that column. For example,
:type 'integer)
(defcustom org-auto-align-tags t
- "Non-nil means, realign tags after pro/demotion of TODO state change.
+ "Non-nil means realign tags after pro/demotion of TODO state change.
These operations change the length of a headline and therefore shift
the tags around. With this options turned on, after each such operation
the tags are again aligned to `org-tags-column'."
@@ -2479,7 +2784,7 @@ the tags are again aligned to `org-tags-column'."
:type 'boolean)
(defcustom org-use-tag-inheritance t
- "Non-nil means, tags in levels apply also for sublevels.
+ "Non-nil means tags in levels apply also for sublevels.
When nil, only the tags directly given in a specific line apply there.
This may also be a list of tags that should be inherited, or a regexp that
matches tags that should be inherited. Additional control is possible
@@ -2541,7 +2846,7 @@ is better to limit inheritance to certain tags using the variables
(const :tag "List them, indented with leading dots" indented)))
(defcustom org-tags-sort-function nil
- "When set, tags are sorted using this function as a comparator"
+ "When set, tags are sorted using this function as a comparator."
:group 'org-tags
:type '(choice
(const :tag "No sorting" nil)
@@ -2570,9 +2875,9 @@ lined-up with respect to each other."
:type 'string)
(defcustom org-use-property-inheritance nil
- "Non-nil means, properties apply also for sublevels.
+ "Non-nil means properties apply also for sublevels.
-This setting is chiefly used during property searches. Turning it on can
+This setting is chiefly used during property searches. Turning it on can
cause significant overhead when doing a search, which is why it is not
on by default.
@@ -2714,7 +3019,9 @@ If an entry is a directory, all files in that directory that are matched by
If the value of the variable is not a list but a single file name, then
the list of agenda files is actually stored and maintained in that file, one
-agenda file per line."
+agenda file per line. In this file paths can be given relative to
+`org-directory'. Tilde expansion and environment variable substitution
+are also made."
:group 'org-agenda
:type '(choice
(repeat :tag "List of files and directories" file)
@@ -2810,15 +3117,15 @@ points to a file, `org-agenda-diary-entry' will be used instead."
(defcustom org-format-latex-options
'(:foreground default :background default :scale 1.0
- :html-foreground "Black" :html-background "Transparent" :html-scale 1.0
- :matchers ("begin" "$1" "$" "$$" "\\(" "\\["))
+ :html-foreground "Black" :html-background "Transparent"
+ :html-scale 1.0 :matchers ("begin" "$1" "$" "$$" "\\(" "\\["))
"Options for creating images from LaTeX fragments.
This is a property list with the following properties:
:foreground the foreground color for images embedded in Emacs, e.g. \"Black\".
`default' means use the foreground of the default face.
:background the background color, or \"Transparent\".
`default' means use the background of the default face.
-:scale a scaling factor for the size of the images.
+:scale a scaling factor for the size of the images, to get more pixels
:html-foreground, :html-background, :html-scale
the same numbers for HTML export.
:matchers a list indicating which matchers should be used to
@@ -2832,13 +3139,19 @@ This is a property list with the following properties:
:group 'org-latex
:type 'plist)
+(defcustom org-format-latex-signal-error t
+ "Non-nil means signal an error when image creation of LaTeX snippets fails.
+When nil, just push out a message."
+ :group 'org-latex
+ :type 'boolean)
+
(defcustom org-format-latex-header "\\documentclass{article}
-\\usepackage{amssymb}
\\usepackage[usenames]{color}
\\usepackage{amsmath}
-\\usepackage{latexsym}
\\usepackage[mathscr]{eucal}
\\pagestyle{empty} % do not remove
+\[PACKAGES]
+\[DEFAULT-PACKAGES]
% The settings below are copied from fullpage.sty
\\setlength{\\textwidth}{\\paperwidth}
\\addtolength{\\textwidth}{-3cm}
@@ -2854,25 +3167,110 @@ This is a property list with the following properties:
\\addtolength{\\topmargin}{-2.54cm}"
"The document header used for processing LaTeX fragments.
It is imperative that this header make sure that no page number
-appears on the page."
+appears on the page. The package defined in the variables
+`org-export-latex-default-packages-alist' and `org-export-latex-packages-alist'
+will either replace the placeholder \"[PACKAGES]\" in this header, or they
+will be appended."
:group 'org-latex
:type 'string)
-;; The following variable is defined here because is it also used
+(defvar org-format-latex-header-extra nil)
+
+(defun org-set-packages-alist (var val)
+ "Set the packages alist and make sure it has 3 elements per entry."
+ (set var (mapcar (lambda (x)
+ (if (and (consp x) (= (length x) 2))
+ (list (car x) (nth 1 x) t)
+ x))
+ val)))
+
+(defun org-get-packages-alist (var)
+
+ "Get the packages alist and make sure it has 3 elements per entry."
+ (mapcar (lambda (x)
+ (if (and (consp x) (= (length x) 2))
+ (list (car x) (nth 1 x) t)
+ x))
+ (default-value var)))
+
+;; The following variables are defined here because is it also used
;; when formatting latex fragments. Originally it was part of the
;; LaTeX exporter, which is why the name includes "export".
+(defcustom org-export-latex-default-packages-alist
+ '(("AUTO" "inputenc" t)
+ ("T1" "fontenc" t)
+ ("" "fixltx2e" nil)
+ ("" "graphicx" t)
+ ("" "longtable" nil)
+ ("" "float" nil)
+ ("" "wrapfig" nil)
+ ("" "soul" t)
+ ("" "textcomp" t)
+ ("" "marvosym" t)
+ ("" "wasysym" t)
+ ("" "latexsym" t)
+ ("" "amssymb" t)
+ ("" "hyperref" nil)
+ "\\tolerance=1000"
+ )
+ "Alist of default packages to be inserted in the header.
+Change this only if one of the packages here causes an incompatibility
+with another package you are using.
+The packages in this list are needed by one part or another of Org-mode
+to function properly.
+
+- inputenc, fontenc: for basic font and character selection
+- textcomp, marvosymb, wasysym, latexsym, amssym: for various symbols used
+ for interpreting the entities in `org-entities'. You can skip some of these
+ packages if you don't use any of the symbols in it.
+- graphicx: for including images
+- float, wrapfig: for figure placement
+- longtable: for long tables
+- hyperref: for cross references
+
+Therefore you should not modify this variable unless you know what you
+are doing. The one reason to change it anyway is that you might be loading
+some other package that conflicts with one of the default packages.
+Each cell is of the format \( \"options\" \"package\" snippet-flag\).
+If SNIPPET-FLAG is t, the package also needs to be included when
+compiling LaTeX snippets into images for inclusion into HTML."
+ :group 'org-export-latex
+ :set 'org-set-packages-alist
+ :get 'org-get-packages-alist
+ :type '(repeat
+ (choice
+ (list :tag "options/package pair"
+ (string :tag "options")
+ (string :tag "package")
+ (boolean :tag "Snippet"))
+ (string :tag "A line of LaTeX"))))
+
(defcustom org-export-latex-packages-alist nil
- "Alist of packages to be inserted in the header.
-Each cell is of the format \( \"option\" . \"package\" \)."
+ "Alist of packages to be inserted in every LaTeX header.
+These will be inserted after `org-export-latex-default-packages-alist'.
+Each cell is of the format \( \"options\" \"package\" snippet-flag \).
+SNIPPET-FLAG, when t, indicates that this package is also needed when
+turning LaTeX snippets into images for inclusion into HTML.
+Make sure that you only list packages here which:
+- you want in every file
+- do not conflict with the default packages in
+ `org-export-latex-default-packages-alist'
+- do not conflict with the setup in `org-format-latex-header'."
:group 'org-export-latex
+ :set 'org-set-packages-alist
+ :get 'org-get-packages-alist
:type '(repeat
- (list
- (string :tag "option")
- (string :tag "package"))))
+ (choice
+ (list :tag "options/package pair"
+ (string :tag "options")
+ (string :tag "package")
+ (boolean :tag "Snippet"))
+ (string :tag "A line of LaTeX"))))
+
-(defgroup org-font-lock nil
- "Font-lock settings for highlighting in Org-mode."
- :tag "Org Font Lock"
+(defgroup org-appearance nil
+ "Settings for Org-mode appearance."
+ :tag "Org Appearance"
:group 'org)
(defcustom org-level-color-stars-only nil
@@ -2880,11 +3278,11 @@ Each cell is of the format \( \"option\" . \"package\" \)."
When nil, the entire headline is fontified.
Changing it requires restart of `font-lock-mode' to become effective
also in regions already fontified."
- :group 'org-font-lock
+ :group 'org-appearance
:type 'boolean)
(defcustom org-hide-leading-stars nil
- "Non-nil means, hide the first N-1 stars in a headline.
+ "Non-nil means hide the first N-1 stars in a headline.
This works by using the face `org-hide' for these stars. This
face is white for a light background, and black for a dark
background. You may have to customize the face `org-hide' to
@@ -2896,42 +3294,72 @@ lines to the buffer:
#+STARTUP: hidestars
#+STARTUP: showstars"
- :group 'org-font-lock
+ :group 'org-appearance
:type 'boolean)
+(defcustom org-hidden-keywords nil
+ "List of keywords that should be hidden when typed in the org buffer.
+For example, add #+TITLE to this list in order to make the
+document title appear in the buffer without the initial #+TITLE:
+keyword."
+ :group 'org-appearance
+ :type '(set (const :tag "#+AUTHOR" author)
+ (const :tag "#+DATE" date)
+ (const :tag "#+EMAIL" email)
+ (const :tag "#+TITLE" title)))
+
(defcustom org-fontify-done-headline nil
- "Non-nil means, change the face of a headline if it is marked DONE.
+ "Non-nil means change the face of a headline if it is marked DONE.
Normally, only the TODO/DONE keyword indicates the state of a headline.
When this is non-nil, the headline after the keyword is set to the
`org-headline-done' as an additional indication."
- :group 'org-font-lock
+ :group 'org-appearance
:type 'boolean)
(defcustom org-fontify-emphasized-text t
"Non-nil means fontify *bold*, /italic/ and _underlined_ text.
Changing this variable requires a restart of Emacs to take effect."
- :group 'org-font-lock
+ :group 'org-appearance
:type 'boolean)
(defcustom org-fontify-whole-heading-line nil
"Non-nil means fontify the whole line for headings.
This is useful when setting a background color for the
org-level-* faces."
- :group 'org-font-lock
+ :group 'org-appearance
:type 'boolean)
(defcustom org-highlight-latex-fragments-and-specials nil
- "Non-nil means, fontify what is treated specially by the exporters."
- :group 'org-font-lock
+ "Non-nil means fontify what is treated specially by the exporters."
+ :group 'org-appearance
:type 'boolean)
(defcustom org-hide-emphasis-markers nil
"Non-nil mean font-lock should hide the emphasis marker characters."
- :group 'org-font-lock
+ :group 'org-appearance
+ :type 'boolean)
+
+(defcustom org-pretty-entities nil
+ "Non-nil means show entities as UTF8 characters.
+When nil, the \\name form remains in the buffer."
+ :group 'org-appearance
+ :type 'boolean)
+
+(defcustom org-pretty-entities-include-sub-superscripts t
+ "Non-nil means, pretty entity display includes formatting sub/superscripts."
+ :group 'org-appearance
:type 'boolean)
(defvar org-emph-re nil
- "Regular expression for matching emphasis.")
+ "Regular expression for matching emphasis.
+After a match, the match groups contain these elements:
+0 The match of the full regular expression, including the characters
+ before and after the proper match
+1 The character before the proper match, or empty at beginning of line
+2 The proper match, including the leading and trailing markers
+3 The leading marker like * or /, indicating the type of highlighting
+4 The text between the emphasis markers, not including the markers
+5 The character after the match, empty at the end of a line")
(defvar org-verbatim-re nil
"Regular expression for matching verbatim text.")
(defvar org-emphasis-regexp-components) ; defined just below
@@ -3008,7 +3436,7 @@ body-regexp A regexp like \".\" to match a body character. Don't use
newline The maximum number of newlines allowed in an emphasis exp.
Use customize to modify this, or restart Emacs after changing it."
- :group 'org-font-lock
+ :group 'org-appearance
:set 'org-set-emph-re
:type '(list
(sexp :tag "Allowed chars in pre ")
@@ -3033,8 +3461,9 @@ example *bold*, _underlined_ and /italic/. This variable sets the marker
characters, the face to be used by font-lock for highlighting in Org-mode
Emacs buffers, and the HTML tags to be used for this.
For LaTeX export, see the variable `org-export-latex-emphasis-alist'.
+For DocBook export, see the variable `org-export-docbook-emphasis-alist'.
Use customize to modify this, or restart Emacs after changing it."
- :group 'org-font-lock
+ :group 'org-appearance
:set 'org-set-emph-re
:type '(repeat
(list
@@ -3059,7 +3488,7 @@ This is needed for font-lock setup.")
:group 'org)
(defcustom org-completion-use-ido nil
- "Non-nil means, use ido completion wherever possible.
+ "Non-nil means use ido completion wherever possible.
Note that `ido-mode' must be active for this variable to be relevant.
If you decide to turn this variable on, you might well want to turn off
`org-outline-path-complete-in-steps'.
@@ -3068,7 +3497,7 @@ See also `org-completion-use-iswitchb'."
:type 'boolean)
(defcustom org-completion-use-iswitchb nil
- "Non-nil means, use iswitchb completion wherever possible.
+ "Non-nil means use iswitchb completion wherever possible.
Note that `iswitchb-mode' must be active for this variable to be relevant.
If you decide to turn this variable on, you might well want to turn off
`org-outline-path-complete-in-steps'.
@@ -3078,7 +3507,7 @@ Note that this variable has only an effect if `org-completion-use-ido' is nil."
(defcustom org-completion-fallback-command 'hippie-expand
"The expansion command called by \\[org-complete] in normal context.
-Normal means, no org-mode-specific context."
+Normal means no org-mode-specific context."
:group 'org-completion
:type 'function)
@@ -3125,9 +3554,11 @@ Normal means, no org-mode-specific context."
(declare-function org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item
"org-agenda" (&optional end))
(declare-function org-inlinetask-remove-END-maybe "org-inlinetask" ())
+(declare-function org-inlinetask-in-task-p "org-inlinetask" ())
(declare-function org-indent-mode "org-indent" (&optional arg))
(declare-function parse-time-string "parse-time" (string))
(declare-function org-attach-reveal "org-attach" (&optional if-exists))
+(declare-function org-export-latex-fix-inputenc "org-latex" ())
(defvar remember-data-file)
(defvar texmathp-why)
(declare-function speedbar-line-directory "speedbar" (&optional depth))
@@ -3144,18 +3575,18 @@ Normal means, no org-mode-specific context."
;; by the functions setting up org-mode or checking for table context.
(defconst org-table-any-line-regexp "^[ \t]*\\(|\\|\\+-[-+]\\)"
- "Detects an org-type or table-type table.")
+ "Detect an org-type or table-type table.")
(defconst org-table-line-regexp "^[ \t]*|"
- "Detects an org-type table line.")
+ "Detect an org-type table line.")
(defconst org-table-dataline-regexp "^[ \t]*|[^-]"
- "Detects an org-type table line.")
+ "Detect an org-type table line.")
(defconst org-table-hline-regexp "^[ \t]*|-"
- "Detects an org-type table hline.")
+ "Detect an org-type table hline.")
(defconst org-table1-hline-regexp "^[ \t]*\\+-[-+]"
- "Detects a table-type table hline.")
+ "Detect a table-type table hline.")
(defconst org-table-any-border-regexp "^[ \t]*[^|+ \t]"
- "Searching from within a table (any type) this finds the first line
-outside the table.")
+ "Detect the first line outside a table when searching from within it.
+This works for both table types.")
;; Autoload the functions in org-table.el that are needed by functions here.
@@ -3182,7 +3613,9 @@ outside the table.")
org-table-rotate-recalc-marks org-table-sort-lines org-table-sum
org-table-toggle-coordinate-overlays
org-table-toggle-formula-debugger org-table-wrap-region
- orgtbl-mode turn-on-orgtbl org-table-to-lisp)))
+ orgtbl-mode turn-on-orgtbl org-table-to-lisp
+ orgtbl-to-generic orgtbl-to-tsv orgtbl-to-csv orgtbl-to-latex
+ orgtbl-to-orgtbl orgtbl-to-html orgtbl-to-texinfo)))
(defun org-at-table-p (&optional table-type)
"Return t if the cursor is inside an org-type table.
@@ -3222,7 +3655,7 @@ If TABLE-TYPE is non-nil, also check for table.el-type tables."
(message "recognizing table.el table...")
(table-recognize-table)
(message "recognizing table.el table...done")))
- (error "This should not happen..."))
+ (error "This should not happen"))
t)
nil)
nil))
@@ -3237,21 +3670,22 @@ If TABLE-TYPE is non-nil, also check for table.el-type tables."
(defvar org-table-clean-did-remove-column nil)
-(defun org-table-map-tables (function)
+(defun org-table-map-tables (function &optional quietly)
"Apply FUNCTION to the start of all tables in the buffer."
(save-excursion
(save-restriction
(widen)
(goto-char (point-min))
(while (re-search-forward org-table-any-line-regexp nil t)
- (message "Mapping tables: %d%%" (/ (* 100.0 (point)) (buffer-size)))
+ (unless quietly
+ (message "Mapping tables: %d%%" (/ (* 100.0 (point)) (buffer-size))))
(beginning-of-line 1)
(when (looking-at org-table-line-regexp)
(save-excursion (funcall function))
(or (looking-at org-table-line-regexp)
(forward-char 1)))
(re-search-forward org-table-any-border-regexp nil 1))))
- (message "Mapping tables: done"))
+ (unless quietly (message "Mapping tables: done")))
;; Declare and autoload functions from org-exp.el & Co
@@ -3267,16 +3701,27 @@ If TABLE-TYPE is non-nil, also check for table.el-type tables."
'(org-export-as-ascii org-export-ascii-preprocess
org-export-as-ascii-to-buffer org-replace-region-by-ascii
org-export-region-as-ascii))
+ (org-autoload "org-latex"
+ '(org-export-as-latex-batch org-export-as-latex-to-buffer
+ org-replace-region-by-latex org-export-region-as-latex
+ org-export-as-latex org-export-as-pdf
+ org-export-as-pdf-and-open))
(org-autoload "org-html"
'(org-export-as-html-and-open
org-export-as-html-batch org-export-as-html-to-buffer
org-replace-region-by-html org-export-region-as-html
org-export-as-html))
+ (org-autoload "org-docbook"
+ '(org-export-as-docbook-batch org-export-as-docbook-to-buffer
+ org-replace-region-by-docbook org-export-region-as-docbook
+ org-export-as-docbook-pdf org-export-as-docbook-pdf-and-open
+ org-export-as-docbook))
(org-autoload "org-icalendar"
'(org-export-icalendar-this-file
org-export-icalendar-all-agenda-files
org-export-icalendar-combine-agenda-files))
- (org-autoload "org-xoxo" '(org-export-as-xoxo)))
+ (org-autoload "org-xoxo" '(org-export-as-xoxo))
+ (org-autoload "org-beamer" '(org-beamer-mode org-beamer-sectioning)))
;; Declare and autoload functions from org-agenda.el
@@ -3294,8 +3739,12 @@ If TABLE-TYPE is non-nil, also check for table.el-type tables."
'(org-remember-insinuate org-remember-annotation
org-remember-apply-template org-remember org-remember-handler)))
-;; Autoload org-clock.el
+(eval-and-compile
+ (org-autoload "org-capture"
+ '(org-capture org-capture-insert-template-here
+ org-capture-import-remember-templates)))
+;; Autoload org-clock.el
(declare-function org-clock-save-markers-for-cut-and-paste "org-clock"
(beg end))
@@ -3487,7 +3936,7 @@ get the proper fontification."
:type 'string)
(defcustom org-agenda-skip-archived-trees t
- "Non-nil means, the agenda will skip any items located in archived trees.
+ "Non-nil means the agenda will skip any items located in archived trees.
An archived tree is a tree marked with the tag ARCHIVE. The use of this
variable is no longer recommended, you should leave it at the value t.
Instead, use the key `v' to cycle the archives-mode in the agenda."
@@ -3496,13 +3945,13 @@ Instead, use the key `v' to cycle the archives-mode in the agenda."
:type 'boolean)
(defcustom org-columns-skip-archived-trees t
- "Non-nil means, ignore archived trees when creating column view."
+ "Non-nil means ignore archived trees when creating column view."
:group 'org-archive
:group 'org-properties
:type 'boolean)
(defcustom org-cycle-open-archived-trees nil
- "Non-nil means, `org-cycle' will open archived trees.
+ "Non-nil means `org-cycle' will open archived trees.
An archived tree is a tree marked with the tag ARCHIVE.
When nil, archived trees will stay folded. You can still open them with
normal outline commands like `show-all', but not with the cycling commands."
@@ -3545,8 +3994,9 @@ collapsed state."
(let* ((re (concat ":" org-archive-tag ":")))
(goto-char beg)
(while (re-search-forward re end t)
- (and (org-on-heading-p) (org-flag-subtree t))
- (org-end-of-subtree t)))))
+ (when (org-on-heading-p)
+ (org-flag-subtree t)
+ (org-end-of-subtree t))))))
(defun org-flag-subtree (flag)
(save-excursion
@@ -3585,7 +4035,7 @@ collapsed state."
(org-autoload "org-id"
'(org-id-get-create org-id-new org-id-copy org-id-get
org-id-get-with-outline-path-completion
- org-id-get-with-outline-drilling
+ org-id-get-with-outline-drilling org-id-store-link
org-id-goto org-id-find org-id-store-link))
;; Autoload Plotting Code
@@ -3618,7 +4068,11 @@ group 3: Priority cookie
group 4: True headline
group 5: Tags")
(make-variable-buffer-local 'org-complex-heading-regexp)
-(defvar org-complex-heading-regexp-format nil)
+(defvar org-complex-heading-regexp-format nil
+ "Printf format to make regexp to match an exact headline.
+This regexp will match the headline of any node which hase the exact
+headline text that is put into the format, but may have any TODO state,
+priority and tags.")
(make-variable-buffer-local 'org-complex-heading-regexp-format)
(defvar org-todo-line-tags-regexp nil
"Matches a headline and puts TODO state into group 2 if present.
@@ -3659,11 +4113,14 @@ Also put tags into group 4 if tags are present.")
"Matches any of the 3 keywords, together with the time stamp.")
(make-variable-buffer-local 'org-keyword-time-not-clock-regexp)
(defvar org-maybe-keyword-time-regexp nil
- "Matches a timestamp, possibly preceeded by a keyword.")
+ "Matches a timestamp, possibly preceded by a keyword.")
(make-variable-buffer-local 'org-maybe-keyword-time-regexp)
(defvar org-planning-or-clock-line-re nil
"Matches a line with planning or clock info.")
(make-variable-buffer-local 'org-planning-or-clock-line-re)
+(defvar org-all-time-keywords nil
+ "List of time keywords.")
+(make-variable-buffer-local 'org-all-time-keywords)
(defconst org-plain-time-of-day-regexp
(concat
@@ -3720,6 +4177,8 @@ After a match, the following groups carry important information:
("oddeven" org-odd-levels-only nil)
("align" org-startup-align-all-tables t)
("noalign" org-startup-align-all-tables nil)
+ ("inlineimages" org-startup-with-inline-images t)
+ ("noinlineimages" org-startup-with-inline-images nil)
("customtime" org-display-custom-times t)
("logdone" org-log-done time)
("lognotedone" org-log-done note)
@@ -3735,6 +4194,9 @@ After a match, the following groups carry important information:
("logredeadline" org-log-redeadline time)
("lognoteredeadline" org-log-redeadline note)
("nologredeadline" org-log-redeadline nil)
+ ("logrefile" org-log-refile time)
+ ("lognoterefile" org-log-refile note)
+ ("nologrefile" org-log-refile nil)
("fninline" org-footnote-define-inline t)
("nofninline" org-footnote-define-inline nil)
("fnlocal" org-footnote-section nil)
@@ -3748,7 +4210,10 @@ After a match, the following groups carry important information:
("constSI" constants-unit-system SI)
("noptag" org-tag-persistent-alist nil)
("hideblocks" org-hide-block-startup t)
- ("nohideblocks" org-hide-block-startup nil))
+ ("nohideblocks" org-hide-block-startup nil)
+ ("beamer" org-startup-with-beamer-mode t)
+ ("entitiespretty" org-pretty-entities t)
+ ("entitiesplain" org-pretty-entities nil))
"Variable associated with STARTUP options for org-mode.
Each element is a list of three items: The startup options as written
in the #+STARTUP line, the corresponding variable, and the value to
@@ -3771,11 +4236,13 @@ means to push this value onto the list in the variable.")
(let ((re (org-make-options-regexp
'("CATEGORY" "TODO" "COLUMNS"
"STARTUP" "ARCHIVE" "FILETAGS" "TAGS" "LINK" "PRIORITIES"
- "CONSTANTS" "PROPERTY" "DRAWERS" "SETUPFILE")
+ "CONSTANTS" "PROPERTY" "DRAWERS" "SETUPFILE" "LATEX_CLASS"
+ "OPTIONS")
"\\(?:[a-zA-Z][0-9a-zA-Z_]*_TODO\\)"))
(splitre "[ \t]+")
+ (scripts org-use-sub-superscripts)
kwds kws0 kwsa key log value cat arch tags const links hw dws
- tail sep kws1 prio props ftags drawers
+ tail sep kws1 prio props ftags drawers beamer-p
ext-setup-or-nil setup-contents (start 0))
(save-excursion
(save-restriction
@@ -3788,10 +4255,9 @@ means to push this value onto the list in the variable.")
(re-search-forward re nil t)))
(setq key (upcase (match-string 1 ext-setup-or-nil))
value (org-match-string-no-properties 2 ext-setup-or-nil))
+ (if (stringp value) (setq value (org-trim value)))
(cond
((equal key "CATEGORY")
- (if (string-match "[ \t]+$" value)
- (setq value (replace-match "" t t value)))
(setq cat value))
((member key '("SEQ_TODO" "TODO"))
(push (cons 'sequence (org-split-string value splitre)) kwds))
@@ -3842,10 +4308,14 @@ means to push this value onto the list in the variable.")
(set (make-local-variable var) (symbol-value var))
(add-to-list var val))))))
((equal key "ARCHIVE")
- (string-match " *$" value)
- (setq arch (replace-match "" t t value))
+ (setq arch value)
(remove-text-properties 0 (length arch)
'(face t fontified t) arch))
+ ((equal key "LATEX_CLASS")
+ (setq beamer-p (equal value "beamer")))
+ ((equal key "OPTIONS")
+ (if (string-match "\\([ \t]\\|\\`\\)\\^:\\(t\\|nil\\|{}\\)" value)
+ (setq scripts (read (match-string 2 value)))))
((equal key "SETUPFILE")
(setq setup-contents (org-file-contents
(expand-file-name
@@ -3858,6 +4328,7 @@ means to push this value onto the list in the variable.")
"\n" setup-contents "\n"
(substring ext-setup-or-nil start)))))
))))
+ (org-set-local 'org-use-sub-superscripts scripts)
(when cat
(org-set-local 'org-category (intern cat))
(push (cons "CATEGORY" cat) props))
@@ -3936,7 +4407,7 @@ means to push this value onto the list in the variable.")
((equal e "{") (push '(:startgroup) tgs))
((equal e "}") (push '(:endgroup) tgs))
((equal e "\\n") (push '(:newline) tgs))
- ((string-match (org-re "^\\([[:alnum:]_@]+\\)(\\(.\\))$") e)
+ ((string-match (org-re "^\\([[:alnum:]_@#%]+\\)(\\(.\\))$") e)
(push (cons (match-string 1 e)
(string-to-char (match-string 2 e)))
tgs))
@@ -3980,12 +4451,16 @@ means to push this value onto the list in the variable.")
(concat "^\\(\\*+\\)[ \t]+\\(?:\\("
(mapconcat 'regexp-quote org-todo-keywords-1 "\\|")
"\\)\\>\\)?\\(?:[ \t]*\\(\\[#.\\]\\)\\)?[ \t]*\\(.*?\\)"
- "\\(?:[ \t]+\\(:[[:alnum:]_@:]+:\\)\\)?[ \t]*$")
+ "\\(?:[ \t]+\\(:[[:alnum:]_@#%:]+:\\)\\)?[ \t]*$")
org-complex-heading-regexp-format
(concat "^\\(\\*+\\)[ \t]+\\(?:\\("
(mapconcat 'regexp-quote org-todo-keywords-1 "\\|")
- "\\)\\>\\)?\\(?:[ \t]*\\(\\[#.\\]\\)\\)?[ \t]*\\(%s\\)"
- "\\(?:[ \t]+\\(:[[:alnum:]_@:]+:\\)\\)?[ \t]*$")
+ "\\)\\>\\)?"
+ "\\(?:[ \t]*\\(\\[#.\\]\\)\\)?"
+ "\\(?:[ \t]*\\(?:\\[[0-9%%/]+\\]\\)\\)?" ;; stats cookie
+ "[ \t]*\\(%s\\)"
+ "\\(?:[ \t]*\\(?:\\[[0-9%%/]+\\]\\)\\)?" ;; stats cookie
+ "\\(?:[ \t]+\\(:[[:alnum:]_@#%%:]+:\\)\\)?[ \t]*$")
org-nl-done-regexp
(concat "\n\\*+[ \t]+"
"\\(?:" (mapconcat 'regexp-quote org-done-keywords "\\|")
@@ -3994,7 +4469,7 @@ means to push this value onto the list in the variable.")
(concat "^\\(\\*+\\)[ \t]+\\(?:\\("
(mapconcat 'regexp-quote org-todo-keywords-1 "\\|")
(org-re
- "\\)\\>\\)? *\\(.*?\\([ \t]:[[:alnum:]:_@]+:[ \t]*\\)?$\\)"))
+ "\\)\\>\\)? *\\(.*?\\([ \t]:[[:alnum:]:_@#%]+:[ \t]*\\)?$\\)"))
org-looking-at-done-regexp
(concat "^" "\\(?:"
(mapconcat 'regexp-quote org-done-keywords "\\|") "\\)"
@@ -4033,6 +4508,10 @@ means to push this value onto the list in the variable.")
"\\|" org-deadline-string
"\\|" org-closed-string "\\|" org-clock-string
"\\)\\>\\)")
+ org-all-time-keywords
+ (mapcar (lambda (w) (substring w 0 -1))
+ (list org-scheduled-string org-deadline-string
+ org-clock-string org-closed-string))
)
(org-compute-latex-and-specials-regexp)
(org-set-font-lock-defaults))))
@@ -4043,10 +4522,10 @@ means to push this value onto the list in the variable.")
(not (file-readable-p file)))
(if noerror
(progn
- (message "Cannot read file %s" file)
+ (message "Cannot read file \"%s\"" file)
(ding) (sit-for 2)
"")
- (error "Cannot read file %s" file))
+ (error "Cannot read file \"%s\"" file))
(with-temp-buffer
(insert-file-contents file)
(buffer-string))))
@@ -4073,30 +4552,24 @@ This will extract info from a string like \"WAIT(w@/!)\"."
x))
list))
-;; FIXME: this could be done much better, using second characters etc.
(defun org-assign-fast-keys (alist)
"Assign fast keys to a keyword-key alist.
Respect keys that are already there."
- (let (new e k c c1 c2 (char ?a))
+ (let (new e (alt ?0))
(while (setq e (pop alist))
- (cond
- ((equal e '(:startgroup)) (push e new))
- ((equal e '(:endgroup)) (push e new))
- ((equal e '(:newline)) (push e new))
- (t
- (setq k (car e) c2 nil)
- (if (cdr e)
- (setq c (cdr e))
- ;; automatically assign a character.
- (setq c1 (string-to-char
- (downcase (substring
- k (if (= (string-to-char k) ?@) 1 0)))))
- (if (or (rassoc c1 new) (rassoc c1 alist))
- (while (or (rassoc char new) (rassoc char alist))
- (setq char (1+ char)))
- (setq c2 c1))
- (setq c (or c2 char)))
- (push (cons k c) new))))
+ (if (or (memq (car e) '(:newline :endgroup :startgroup))
+ (cdr e)) ;; Key already assigned.
+ (push e new)
+ (let ((clist (string-to-list (downcase (car e))))
+ (used (append new alist)))
+ (when (= (car clist) ?@)
+ (pop clist))
+ (while (and clist (rassoc (car clist) used))
+ (pop clist))
+ (unless clist
+ (while (rassoc alt used)
+ (incf alt)))
+ (push (cons (car e) (or (car clist) alt)) new))))
(nreverse new)))
;;; Some variables used in various places
@@ -4117,7 +4590,7 @@ This is for getting out of special buffers like remember.")
(defvar date)
;; Defined somewhere in this file, but used before definition.
-(defvar org-html-entities)
+(defvar org-entities) ;; defined in org-entities.el
(defvar org-struct-menu)
(defvar org-org-menu)
(defvar org-tbl-menu)
@@ -4125,7 +4598,7 @@ This is for getting out of special buffers like remember.")
;;;; Define the Org-mode
(if (and (not (keymapp outline-mode-map)) (featurep 'allout))
- (error "Conflict with outdated version of allout.el. Load org.el before allout.el, or upgrade to newer allout, for example by switching to Emacs 22."))
+ (error "Conflict with outdated version of allout.el. Load org.el before allout.el, or upgrade to newer allout, for example by switching to Emacs 22"))
;; We use a before-change function to check if a table might need
@@ -4139,6 +4612,7 @@ This variable is set by `org-before-change-function'.
(setq org-table-may-need-update t))
(defvar org-mode-map)
(defvar org-inhibit-startup nil) ; Dynamically-scoped param.
+(defvar org-inhibit-startup-visibility-stuff nil) ; Dynamically-scoped param.
(defvar org-agenda-keep-modes nil) ; Dynamically-scoped param.
(defvar org-inhibit-logging nil) ; Dynamically-scoped param.
(defvar org-inhibit-blocking nil) ; Dynamically-scoped param.
@@ -4171,7 +4645,7 @@ The following commands are available:
;; we switch another buffer into org-mode.
(if (featurep 'xemacs)
(when (boundp 'outline-mode-menu-heading)
- ;; Assume this is Greg's port, it used easymenu
+ ;; Assume this is Greg's port, it uses easymenu
(easy-menu-remove outline-mode-menu-heading)
(easy-menu-remove outline-mode-menu-show)
(easy-menu-remove outline-mode-menu-hide))
@@ -4183,9 +4657,9 @@ The following commands are available:
(easy-menu-add org-org-menu)
(easy-menu-add org-tbl-menu)
(org-install-agenda-files-menu)
- (if org-descriptive-links (org-add-to-invisibility-spec '(org-link)))
- (org-add-to-invisibility-spec '(org-cwidth))
- (org-add-to-invisibility-spec '(org-hide-block . t))
+ (if org-descriptive-links (add-to-invisibility-spec '(org-link)))
+ (add-to-invisibility-spec '(org-cwidth))
+ (add-to-invisibility-spec '(org-hide-block . t))
(when (featurep 'xemacs)
(org-set-local 'line-move-ignore-invisible t))
(org-set-local 'outline-regexp org-outline-regexp)
@@ -4208,7 +4682,6 @@ The following commands are available:
(org-set-tag-faces 'org-tag-faces org-tag-faces))
;; Calc embedded
(org-set-local 'calc-embedded-open-mode "# ")
- (modify-syntax-entry ?# "<")
(modify-syntax-entry ?@ "w")
(if org-startup-truncated (setq truncate-lines t))
(org-set-local 'font-lock-unfontify-region-function
@@ -4223,6 +4696,9 @@ The following commands are available:
(org-set-autofill-regexps)
(setq indent-line-function 'org-indent-line-function)
(org-update-radio-target-regexp)
+ ;; Beginning/end of defun
+ (org-set-local 'beginning-of-defun-function 'org-beginning-of-defun)
+ (org-set-local 'end-of-defun-function 'org-end-of-defun)
;; Make sure dependence stuff works reliably, even for users who set it
;; too late :-(
(if org-enforce-todo-dependencies
@@ -4237,7 +4713,7 @@ The following commands are available:
'org-block-todo-from-checkboxes))
;; Comment characters
-; (org-set-local 'comment-start "#") ;; FIXME: this breaks wrapping
+ (org-set-local 'comment-start "#")
(org-set-local 'comment-padding " ")
;; Align options lines
@@ -4260,21 +4736,26 @@ The following commands are available:
(org-set-local 'outline-isearch-open-invisible-function
(lambda (&rest ignore) (org-show-context 'isearch))))
+ ;; Turn on org-beamer-mode?
+ (and org-startup-with-beamer-mode (org-beamer-mode 1))
+
;; If empty file that did not turn on org-mode automatically, make it to.
(if (and org-insert-mode-line-in-empty-file
(interactive-p)
(= (point-min) (point-max)))
(insert "# -*- mode: org -*-\n\n"))
-
(unless org-inhibit-startup
(when org-startup-align-all-tables
(let ((bmp (buffer-modified-p)))
- (org-table-map-tables 'org-table-align)
+ (org-table-map-tables 'org-table-align 'quietly)
(set-buffer-modified-p bmp)))
+ (when org-startup-with-inline-images
+ (org-display-inline-images))
(when org-startup-indented
(require 'org-indent)
(org-indent-mode 1))
- (org-set-startup-visibility)))
+ (unless org-inhibit-startup-visibility-stuff
+ (org-set-startup-visibility))))
(when (fboundp 'abbrev-table-put)
(abbrev-table-put org-mode-abbrev-table
@@ -4295,10 +4776,8 @@ The following commands are available:
;;;; Font-Lock stuff, including the activators
(defvar org-mouse-map (make-sparse-keymap))
-(org-defkey org-mouse-map
- (if (featurep 'xemacs) [button2] [mouse-2]) 'org-open-at-mouse)
-(org-defkey org-mouse-map
- (if (featurep 'xemacs) [button3] [mouse-3]) 'org-find-file-at-mouse)
+(org-defkey org-mouse-map [mouse-2] 'org-open-at-mouse)
+(org-defkey org-mouse-map [mouse-3] 'org-find-file-at-mouse)
(when org-mouse-1-follows-link
(org-defkey org-mouse-map [follow-link] 'mouse-face))
(when org-tab-follows-link
@@ -4309,7 +4788,7 @@ The following commands are available:
(defconst org-non-link-chars "]\t\n\r<>")
(defvar org-link-types '("http" "https" "ftp" "mailto" "file" "news"
- "shell" "elisp"))
+ "shell" "elisp" "doi" "message"))
(defvar org-link-types-re nil
"Matches a link that has a url-like prefix like \"http:\"")
(defvar org-link-re-with-space nil
@@ -4333,49 +4812,91 @@ Here is what the match groups contain after a match:
4: [desc]
5: desc")
(defvar org-bracket-link-analytic-regexp++ nil
- "Like org-bracket-link-analytic-regexp, but include coderef internal type.")
+ "Like `org-bracket-link-analytic-regexp', but include coderef internal type.")
(defvar org-any-link-re nil
"Regular expression matching any link.")
+(defcustom org-match-sexp-depth 3
+ "Number of stacked braces for sub/superscript matching.
+This has to be set before loading org.el to be effective."
+ :group 'org-export-translation ; ??????????????????????????/
+ :type 'integer)
+
+(defun org-create-multibrace-regexp (left right n)
+ "Create a regular expression which will match a balanced sexp.
+Opening delimiter is LEFT, and closing delimiter is RIGHT, both given
+as single character strings.
+The regexp returned will match the entire expression including the
+delimiters. It will also define a single group which contains the
+match except for the outermost delimiters. The maximum depth of
+stacked delimiters is N. Escaping delimiters is not possible."
+ (let* ((nothing (concat "[^" left right "]*?"))
+ (or "\\|")
+ (re nothing)
+ (next (concat "\\(?:" nothing left nothing right "\\)+" nothing)))
+ (while (> n 1)
+ (setq n (1- n)
+ re (concat re or next)
+ next (concat "\\(?:" nothing left next right "\\)+" nothing)))
+ (concat left "\\(" re "\\)" right)))
+
+(defvar org-match-substring-regexp
+ (concat
+ "\\([^\\]\\)\\([_^]\\)\\("
+ "\\(" (org-create-multibrace-regexp "{" "}" org-match-sexp-depth) "\\)"
+ "\\|"
+ "\\(" (org-create-multibrace-regexp "(" ")" org-match-sexp-depth) "\\)"
+ "\\|"
+ "\\(\\(?:\\*\\|[-+]?[^-+*!@#$%^_ \t\r\n,:\"?<>~;./{}=()]+\\)\\)\\)")
+ "The regular expression matching a sub- or superscript.")
+
+(defvar org-match-substring-with-braces-regexp
+ (concat
+ "\\([^\\]\\)\\([_^]\\)\\("
+ "\\(" (org-create-multibrace-regexp "{" "}" org-match-sexp-depth) "\\)"
+ "\\)")
+ "The regular expression matching a sub- or superscript, forcing braces.")
+
(defun org-make-link-regexps ()
"Update the link regular expressions.
This should be called after the variable `org-link-types' has changed."
(setq org-link-types-re
(concat
- "\\`\\(" (mapconcat 'identity org-link-types "\\|") "\\):")
+ "\\`\\(" (mapconcat 'regexp-quote org-link-types "\\|") "\\):")
org-link-re-with-space
(concat
- "<?\\(" (mapconcat 'identity org-link-types "\\|") "\\):"
+ "<?\\(" (mapconcat 'regexp-quote org-link-types "\\|") "\\):"
"\\([^" org-non-link-chars " ]"
"[^" org-non-link-chars "]*"
"[^" org-non-link-chars " ]\\)>?")
org-link-re-with-space2
(concat
- "<?\\(" (mapconcat 'identity org-link-types "\\|") "\\):"
+ "<?\\(" (mapconcat 'regexp-quote org-link-types "\\|") "\\):"
"\\([^" org-non-link-chars " ]"
"[^\t\n\r]*"
"[^" org-non-link-chars " ]\\)>?")
org-link-re-with-space3
(concat
- "<?\\(" (mapconcat 'identity org-link-types "\\|") "\\):"
+ "<?\\(" (mapconcat 'regexp-quote org-link-types "\\|") "\\):"
"\\([^" org-non-link-chars " ]"
"[^\t\n\r]*\\)")
org-angle-link-re
(concat
- "<\\(" (mapconcat 'identity org-link-types "\\|") "\\):"
+ "<\\(" (mapconcat 'regexp-quote org-link-types "\\|") "\\):"
"\\([^" org-non-link-chars " ]"
"[^" org-non-link-chars "]*"
"\\)>")
org-plain-link-re
(concat
- "\\<\\(" (mapconcat 'identity org-link-types "\\|") "\\):"
- "\\([^]\t\n\r<>() ]+[^]\t\n\r<>,.;() ]\\)")
+ "\\<\\(" (mapconcat 'regexp-quote org-link-types "\\|") "\\):"
+ (org-re "\\([^ \t\n()<>]+\\(?:([[:word:]0-9_]+)\\|\\([^[:punct:] \t\n]\\|/\\)\\)\\)"))
+ ;; "\\([^]\t\n\r<>() ]+[^]\t\n\r<>,.;() ]\\)")
org-bracket-link-regexp
"\\[\\[\\([^][]+\\)\\]\\(\\[\\([^][]+\\)\\]\\)?\\]"
org-bracket-link-analytic-regexp
(concat
"\\[\\["
- "\\(\\(" (mapconcat 'identity org-link-types "\\|") "\\):\\)?"
+ "\\(\\(" (mapconcat 'regexp-quote org-link-types "\\|") "\\):\\)?"
"\\([^]]+\\)"
"\\]"
"\\(\\[" "\\([^]]+\\)" "\\]\\)?"
@@ -4383,7 +4904,7 @@ This should be called after the variable `org-link-types' has changed."
org-bracket-link-analytic-regexp++
(concat
"\\[\\["
- "\\(\\(" (mapconcat 'identity (cons "coderef" org-link-types) "\\|") "\\):\\)?"
+ "\\(\\(" (mapconcat 'regexp-quote (cons "coderef" org-link-types) "\\|") "\\):\\)?"
"\\([^]]+\\)"
"\\]"
"\\(\\[" "\\([^]]+\\)" "\\]\\)?"
@@ -4440,7 +4961,7 @@ The time stamps may be either active or inactive.")
(org-remove-flyspell-overlays-in
(match-beginning 0) (match-end 0)))
(add-text-properties (match-beginning 2) (match-end 2)
- '(font-lock-multiline t))
+ '(font-lock-multiline t org-emphasis t))
(when org-hide-emphasis-markers
(add-text-properties (match-end 4) (match-beginning 5)
'(invisible org-link))
@@ -4495,8 +5016,9 @@ will be prompted for."
(string-match (concat "[" (nth 0 erc) "\n]")
(char-to-string (char-before (point)))))
(insert " "))
- (unless (string-match (concat "[" (nth 1 erc) "\n]")
- (char-to-string (char-after (point))))
+ (unless (or (eobp)
+ (string-match (concat "[" (nth 1 erc) "\n]")
+ (char-to-string (char-after (point)))))
(insert " ") (backward-char 1))
(insert string)
(and move (backward-char 1))))
@@ -4533,13 +5055,22 @@ will be prompted for."
'(display t invisible t intangible t))
t)))
+(defcustom org-src-fontify-natively nil
+ "When non-nil, fontify code in code blocks."
+ :type 'boolean
+ :group 'org-appearance
+ :group 'org-babel)
+
(defun org-fontify-meta-lines-and-blocks (limit)
"Fontify #+ lines and blocks, in the correct ways."
(let ((case-fold-search t))
(if (re-search-forward
- "^\\([ \t]*#\\+\\(\\([a-zA-Z]+:?\\| \\|$\\)\\(_\\([a-zA-Z]+\\)\\)?\\)\\(.*\\)\\)"
+ "^\\([ \t]*#\\+\\(\\([a-zA-Z]+:?\\| \\|$\\)\\(_\\([a-zA-Z]+\\)\\)?\\)[ \t]*\\(\\([^ \t\n]*\\)[ \t]*\\(.*\\)\\)\\)"
limit t)
(let ((beg (match-beginning 0))
+ (block-start (match-end 0))
+ (block-end nil)
+ (lang (match-string 7))
(beg1 (line-beginning-position 2))
(dc1 (downcase (match-string 2)))
(dc3 (downcase (match-string 3)))
@@ -4552,17 +5083,19 @@ will be prompted for."
'(display t invisible t intangible t))
(add-text-properties (match-beginning 1) (match-end 3)
'(font-lock-fontified t face org-meta-line))
- (add-text-properties (match-beginning 6) (match-end 6)
+ (add-text-properties (match-beginning 6) (+ (match-end 6) 1)
'(font-lock-fontified t face org-block))
+ ; for backend-specific code
t)
((and (match-end 4) (equal dc3 "begin"))
- ;; Truely a block
+ ;; Truly a block
(setq block-type (downcase (match-string 5))
quoting (member block-type org-protecting-blocks))
(when (re-search-forward
(concat "^[ \t]*#\\+end" (match-string 4) "\\>.*")
nil t) ;; on purpose, we look further than LIMIT
(setq end (match-end 0) end1 (1- (match-beginning 0)))
+ (setq block-end (match-beginning 0))
(when quoting
(remove-text-properties beg end
'(display t invisible t intangible t)))
@@ -4570,15 +5103,32 @@ will be prompted for."
beg end
'(font-lock-fontified t font-lock-multiline t))
(add-text-properties beg beg1 '(face org-meta-line))
- (add-text-properties end1 end '(face org-meta-line))
+ (add-text-properties end1 (+ end 1) '(face org-meta-line))
+ ; for end_src
(cond
+ ((and lang org-src-fontify-natively)
+ (org-src-font-lock-fontify-block lang block-start block-end))
(quoting
- (add-text-properties beg1 end1 '(face org-block)))
+ (add-text-properties beg1 (+ end1 1) '(face
+ org-block)))
+ ; end of source block
+ ((not org-fontify-quote-and-verse-blocks))
((string= block-type "quote")
(add-text-properties beg1 end1 '(face org-quote)))
((string= block-type "verse")
(add-text-properties beg1 end1 '(face org-verse))))
t))
+ ((member dc1 '("title:" "author:" "email:" "date:"))
+ (add-text-properties
+ beg (match-end 3)
+ (if (member (intern (substring dc1 0 -1)) org-hidden-keywords)
+ '(font-lock-fontified t invisible t)
+ '(font-lock-fontified t face org-document-info-keyword)))
+ (add-text-properties
+ (match-beginning 6) (match-end 6)
+ (if (string-equal dc1 "title:")
+ '(font-lock-fontified t face org-document-title)
+ '(font-lock-fontified t face org-document-info))))
((not (member (char-after beg) '(?\ ?\t)))
;; just any other in-buffer setting, but not indented
(add-text-properties
@@ -4586,7 +5136,8 @@ will be prompted for."
'(font-lock-fontified t face org-meta-line))
t)
((or (member dc1 '("begin:" "end:" "caption:" "label:"
- "orgtbl:" "tblfm:" "tblname:"))
+ "orgtbl:" "tblfm:" "tblname:" "result:"
+ "results:" "source:" "srcname:" "call:"))
(and (match-end 4) (equal dc3 "attr")))
(add-text-properties
beg (match-end 0)
@@ -4742,6 +5293,7 @@ will be prompted for."
((matchers (plist-get org-format-latex-options :matchers))
(latexs (delq nil (mapcar (lambda (x) (if (member (car x) matchers) x))
org-latex-regexps)))
+ (org-export-allow-BIND nil)
(options (org-combine-plists (org-default-export-plist)
(org-infile-export-plist)))
(org-export-with-sub-superscripts (plist-get options :sub-superscript))
@@ -4763,12 +5315,17 @@ will be prompted for."
(if org-export-with-TeX-macros
(list (concat "\\\\"
(regexp-opt
- (append (mapcar 'car org-html-entities)
- (if (boundp 'org-latex-entities)
- (mapcar (lambda (x)
- (or (car-safe x) x))
- org-latex-entities)
- nil))
+ (append
+
+ (delq nil
+ (mapcar 'car-safe
+ (append org-entities-user
+ org-entities)))
+ (if (boundp 'org-latex-entities)
+ (mapcar (lambda (x)
+ (or (car-safe x) x))
+ org-latex-entities)
+ nil))
'words))) ; FIXME
))
;; (list "\\\\\\(?:[a-zA-Z]+\\)")))
@@ -4807,7 +5364,7 @@ will be prompted for."
rtn)))
(defun org-restart-font-lock ()
- "Restart font-lock-mode, to force refontification."
+ "Restart `font-lock-mode', to force refontification."
(when (and (boundp 'font-lock-mode) font-lock-mode)
(font-lock-mode -1)
(font-lock-mode 1)))
@@ -4840,9 +5397,9 @@ between words."
"\\)\\>")))
(defun org-activate-tags (limit)
- (if (re-search-forward (org-re "^\\*+.*[ \t]\\(:[[:alnum:]_@:]+:\\)[ \r\n]") limit t)
+ (if (re-search-forward (org-re "^\\*+.*[ \t]\\(:[[:alnum:]_@#%:]+:\\)[ \r\n]") limit t)
(progn
- (org-remove-flyspell-overlays-in (match-beginning 0) (match-end 0))
+ (org-remove-flyspell-overlays-in (match-beginning 1) (match-end 1))
(add-text-properties (match-beginning 1) (match-end 1)
(list 'mouse-face 'highlight
'keymap org-mouse-map))
@@ -4852,7 +5409,7 @@ between words."
(defun org-outline-level ()
"Compute the outline level of the heading at point.
This function assumes that the cursor is at the beginning of a line matched
-by outline-regexp. Otherwise it returns garbage.
+by `outline-regexp'. Otherwise it returns garbage.
If this is called at a normal headline, the level is the number of stars.
Use `org-reduced-level' to remove the effect of `org-odd-levels'.
For plain list items, if they are matched by `outline-regexp', this returns
@@ -4871,6 +5428,12 @@ For plain list items, if they are matched by `outline-regexp', this returns
(defvar org-font-lock-hook nil
"Functions to be called for special font lock stuff.")
+(defvar org-font-lock-set-keywords-hook nil
+ "Functions that can manipulate `org-font-lock-extra-keywords'.
+This is calles after `org-font-lock-extra-keywords' is defined, but before
+it is installed to be used by font lock. This can be useful if something
+needs to be inserted at a specific position in the font-lock sequence.")
+
(defun org-font-lock-hook (limit)
(run-hook-with-args 'org-font-lock-hook limit))
@@ -4895,7 +5458,7 @@ For plain list items, if they are matched by `outline-regexp', this returns
'("^[ \t]*|\\(?:.*?|\\)? *\\(:?=[^|\n]*\\)" (1 'org-formula t))
'("^[ \t]*| *\\([#*]\\) *|" (1 'org-formula t))
'("^[ \t]*|\\( *\\([$!_^/]\\) *|.*\\)|" (1 'org-formula t))
- '("| *\\(<[lr]?[0-9]*>\\)" (1 'org-formula t))
+ '("| *\\(<[lrc]?[0-9]*>\\)" (1 'org-formula t))
;; Drawers
(list org-drawer-regexp '(0 'org-special-keyword t))
(list "^[ \t]*:END:" '(0 'org-special-keyword t))
@@ -4939,19 +5502,21 @@ For plain list items, if they are matched by `outline-regexp', this returns
'(org-do-emphasis-faces (0 nil append))
'(org-do-emphasis-faces)))
;; Checkboxes
- '("^[ \t]*\\([-+*]\\|[0-9]+[.)]\\) +\\(\\[[- X]\\]\\)"
- 2 'org-checkbox prepend)
- (if org-provide-checkbox-statistics
+ '("^[ \t]*\\(?:[-+*]\\|[0-9]+[.)]\\)[ \t]+\\(?:\\[@\\(?:start:\\)?[0-9]+\\][ \t]*\\)?\\(\\[[- X]\\]\\)"
+ 1 'org-checkbox prepend)
+ (if (cdr (assq 'checkbox org-list-automatic-rules))
'("\\[\\([0-9]*%\\)\\]\\|\\[\\([0-9]*\\)/\\([0-9]*\\)\\]"
(0 (org-get-checkbox-statistics-face) t)))
;; Description list items
- '("^[ \t]*\\([-+*]\\|[0-9]+[.)]\\) +\\(.*? ::\\)"
+ '("^[ \t]*\\([-+*]\\|[0-9]+[.)]\\)[ \t]+\\(.*? ::\\)"
2 'bold prepend)
;; ARCHIVEd headings
(list (concat "^\\*+ \\(.*:" org-archive-tag ":.*\\)")
'(1 'org-archived prepend))
;; Specials
'(org-do-latex-and-special-faces)
+ '(org-fontify-entities)
+ '(org-raise-scripts)
;; Code
'(org-activate-code (1 'org-code t))
;; COMMENT
@@ -4963,14 +5528,48 @@ For plain list items, if they are matched by `outline-regexp', this returns
'(org-fontify-meta-lines-and-blocks)
)))
(setq org-font-lock-extra-keywords (delq nil org-font-lock-extra-keywords))
+ (run-hooks 'org-font-lock-set-keywords-hook)
;; Now set the full font-lock-keywords
(org-set-local 'org-font-lock-keywords org-font-lock-extra-keywords)
(org-set-local 'font-lock-defaults
'(org-font-lock-keywords t nil nil backward-paragraph))
(kill-local-variable 'font-lock-keywords) nil))
+(defun org-toggle-pretty-entities ()
+ "Toggle the composition display of entities as UTF8 characters."
+ (interactive)
+ (org-set-local 'org-pretty-entities (not org-pretty-entities))
+ (org-restart-font-lock)
+ (if org-pretty-entities
+ (message "Entities are displayed as UTF8 characers")
+ (save-restriction
+ (widen)
+ (org-decompose-region (point-min) (point-max))
+ (message "Entities are displayed plain"))))
+
+(defun org-fontify-entities (limit)
+ "Find an entity to fontify."
+ (let (ee)
+ (when org-pretty-entities
+ (catch 'match
+ (while (re-search-forward
+ "\\\\\\([a-zA-Z][a-zA-Z0-9]*\\)\\($\\|[^[:alnum:]\n]\\)"
+ limit t)
+ (if (and (not (org-in-indented-comment-line))
+ (setq ee (org-entity-get (match-string 1)))
+ (= (length (nth 6 ee)) 1))
+ (progn
+ (add-text-properties
+ (match-beginning 0) (match-end 1)
+ (list 'font-lock-fontified t))
+ (compose-region (match-beginning 0) (match-end 1)
+ (nth 6 ee) nil)
+ (backward-char 1)
+ (throw 'match t))))
+ nil))))
+
(defun org-fontify-like-in-org-mode (s &optional odd-levels)
- "Fontify string S like in Org-mode"
+ "Fontify string S like in Org-mode."
(with-temp-buffer
(insert s)
(let ((org-odd-levels-only odd-levels))
@@ -4995,10 +5594,20 @@ For plain list items, if they are matched by `outline-regexp', this returns
"Get the right face for a TODO keyword KWD.
If KWD is a number, get the corresponding match group."
(if (numberp kwd) (setq kwd (match-string kwd)))
- (or (cdr (assoc kwd org-todo-keyword-faces))
+ (or (org-face-from-face-or-color
+ 'todo 'org-todo (cdr (assoc kwd org-todo-keyword-faces)))
(and (member kwd org-done-keywords) 'org-done)
'org-todo))
+(defun org-face-from-face-or-color (context inherit face-or-color)
+ "Create a face list that inherits INHERIT, but sets the foreground color.
+When FACE-OR-COLOR is not a string, just return it."
+ (if (stringp face-or-color)
+ (list :inherit inherit
+ (cdr (assoc context org-faces-easy-properties))
+ face-or-color)
+ face-or-color))
+
(defun org-font-lock-add-tag-faces (limit)
"Add the special tag faces."
(when (and org-tag-faces org-tags-special-faces-re)
@@ -5013,8 +5622,10 @@ If KWD is a number, get the corresponding match group."
(while (re-search-forward "\\[#\\([A-Z0-9]\\)\\]" limit t)
(add-text-properties
(match-beginning 0) (match-end 0)
- (list 'face (or (cdr (assoc (char-after (match-beginning 1))
- org-priority-faces))
+ (list 'face (or (org-face-from-face-or-color
+ 'priority 'org-special-keyword
+ (cdr (assoc (char-after (match-beginning 1))
+ org-priority-faces)))
'org-special-keyword)
'font-lock-fontified t))))
@@ -5022,7 +5633,8 @@ If KWD is a number, get the corresponding match group."
"Get the right face for a TODO keyword KWD.
If KWD is a number, get the corresponding match group."
(if (numberp kwd) (setq kwd (match-string kwd)))
- (or (cdr (assoc kwd org-tag-faces))
+ (or (org-face-from-face-or-color
+ 'tag 'org-tag (cdr (assoc kwd org-tag-faces)))
'org-tag))
(defun org-unfontify-region (beg end &optional maybe_loudly)
@@ -5032,6 +5644,7 @@ If KWD is a number, get the corresponding match group."
(inhibit-read-only t) (inhibit-point-motion-hooks t)
(inhibit-modification-hooks t)
deactivate-mark buffer-file-name buffer-file-truename)
+ (org-decompose-region beg end)
(remove-text-properties
beg end
(if org-indent-mode
@@ -5039,10 +5652,69 @@ If KWD is a number, get the corresponding match group."
'(mouse-face t keymap t org-linked-text t
invisible t intangible t
line-prefix t wrap-prefix t
- org-no-flyspell t)
+ org-no-flyspell t org-emphasis t)
'(mouse-face t keymap t org-linked-text t
invisible t intangible t
- org-no-flyspell t)))))
+ org-no-flyspell t org-emphasis t)))
+ (org-remove-font-lock-display-properties beg end)))
+
+(defconst org-script-display '(((raise -0.3) (height 0.7))
+ ((raise 0.3) (height 0.7))
+ ((raise -0.5))
+ ((raise 0.5)))
+ "Display properties for showing superscripts and subscripts.")
+
+(defun org-remove-font-lock-display-properties (beg end)
+ "Remove specific display properties that have been added by font lock.
+The will remove the raise properties that are used to show superscripts
+and subscripts."
+ (let (next prop)
+ (while (< beg end)
+ (setq next (next-single-property-change beg 'display nil end)
+ prop (get-text-property beg 'display))
+ (if (member prop org-script-display)
+ (put-text-property beg next 'display nil))
+ (setq beg next))))
+
+(defun org-raise-scripts (limit)
+ "Add raise properties to sub/superscripts."
+ (when (and org-pretty-entities org-pretty-entities-include-sub-superscripts)
+ (if (re-search-forward
+ (if (eq org-use-sub-superscripts t)
+ org-match-substring-regexp
+ org-match-substring-with-braces-regexp)
+ limit t)
+ (let* ((pos (point)) table-p comment-p
+ (mpos (match-beginning 3))
+ (emph-p (get-text-property mpos 'org-emphasis))
+ (link-p (get-text-property mpos 'mouse-face))
+ (keyw-p (eq 'org-special-keyword (get-text-property mpos 'face))))
+ (goto-char (point-at-bol))
+ (setq table-p (org-looking-at-p org-table-dataline-regexp)
+ comment-p (org-looking-at-p "[ \t]*#"))
+ (goto-char pos)
+ ;; FIXME: Should we go back one character here, for a_b^c
+ ;; (goto-char (1- pos)) ;????????????????????
+ (if (or comment-p emph-p link-p keyw-p)
+ t
+ (put-text-property (match-beginning 3) (match-end 0)
+ 'display
+ (if (equal (char-after (match-beginning 2)) ?^)
+ (nth (if table-p 3 1) org-script-display)
+ (nth (if table-p 2 0) org-script-display)))
+ (add-text-properties (match-beginning 2) (match-end 2)
+ (list 'invisible t
+ 'org-dwidth t 'org-dwidth-n 1))
+ (if (and (eq (char-after (match-beginning 3)) ?{)
+ (eq (char-before (match-end 3)) ?}))
+ (progn
+ (add-text-properties
+ (match-beginning 3) (1+ (match-beginning 3))
+ (list 'invisible t 'org-dwidth t 'org-dwidth-n 1))
+ (add-text-properties
+ (1- (match-end 3)) (match-end 3)
+ (list 'invisible t 'org-dwidth t 'org-dwidth-n 1))))
+ t)))))
;;;; Visibility cycling, including org-goto and indirect buffer
@@ -5086,6 +5758,12 @@ in special contexts.
3. SUBTREE: Show the entire subtree, including body text.
If there is no subtree, switch directly from CHILDREN to FOLDED.
+- When point is at the beginning of an empty headline and the variable
+ `org-cycle-level-after-item/entry-creation' is set, cycle the level
+ of the headline by demoting and promoting it to likely levels. This
+ speeds up creation document structure by pressing TAB once or several
+ times right after creating a new headline.
+
- When there is a numeric prefix, go up to a heading with level ARG, do
a `show-subtree' and return to the previous cursor position. If ARG
is negative, go up that many levels.
@@ -5095,7 +5773,8 @@ in special contexts.
`org-cycle-emulate-tab' for details.
- Special case: if point is at the beginning of the buffer and there is
- no headline in line 1, this function will act as if called with prefix arg.
+ no headline in line 1, this function will act as if called with prefix arg
+ (C-u TAB, same as S-TAB) also when called without prefix arg.
But only if also the variable `org-cycle-global-at-bob' is t."
(interactive "P")
(org-load-modules-maybe)
@@ -5121,7 +5800,7 @@ in special contexts.
(if nstars (format "\\{1,%d\\}" nstars) "+")
" \\|\\([ \t]*\\)\\([-+*]\\|[0-9]+[.)]\\) \\)"))
(t (concat "\\*" (if nstars (format "\\{1,%d\\} " nstars) "+ ")))))
- (bob-special (and org-cycle-global-at-bob (bobp)
+ (bob-special (and org-cycle-global-at-bob (not arg) (bobp)
(not (looking-at outline-regexp))))
(org-cycle-hook
(if bob-special
@@ -5137,6 +5816,7 @@ in special contexts.
(cond
((equal arg '(16))
+ (setq last-command 'dummy)
(org-set-startup-visibility)
(message "Startup visibility, plus VISIBILITY properties"))
@@ -5146,11 +5826,11 @@ in special contexts.
((org-at-table-p 'any)
;; Enter the table or move to the next field in the table
- (or (org-table-recognize-table.el)
- (progn
- (if arg (org-table-edit-field t)
- (org-table-justify-field-maybe)
- (call-interactively 'org-table-next-field)))))
+ (if (org-at-table.el-p)
+ (message "Use C-c ' to edit table.el tables")
+ (if arg (org-table-edit-field t)
+ (org-table-justify-field-maybe)
+ (call-interactively 'org-table-next-field))))
((run-hook-with-args-until-success
'org-tab-after-check-for-table-hook))
@@ -5244,7 +5924,6 @@ in special contexts.
(defun org-cycle-internal-local ()
"Do the local cycling action."
- (org-back-to-heading)
(let ((goal-column 0) eoh eol eos level has-children children-skipped)
;; First, some boundaries
(save-excursion
@@ -5261,7 +5940,6 @@ in special contexts.
(while (and (not (eobp)) ;; this is like `next-line'
(get-char-property (1- (point)) 'invisible))
(goto-char (next-single-char-property-change (point) 'invisible))
-;;;??? (or (bolp) (beginning-of-line 2))))
(and (eolp) (beginning-of-line 2))))
(setq eol (point)))
(outline-end-of-heading) (setq eoh (point))
@@ -5269,12 +5947,15 @@ in special contexts.
(outline-next-heading)
(setq has-children (and (org-at-heading-p t)
(> (funcall outline-level) level))))
- (org-end-of-subtree t)
- (unless (eobp)
- (skip-chars-forward " \t\n")
- (beginning-of-line 1) ; in case this is an item
- )
- (setq eos (if (eobp) (point) (1- (point)))))
+ ;; if we're in a list, org-end-of-subtree is in fact org-end-of-item.
+ (if (org-at-item-p)
+ (setq eos (if (and (org-end-of-item) (bolp))
+ (1- (point))
+ (point)))
+ (org-end-of-subtree t)
+ (unless (eobp)
+ (skip-chars-forward " \t\n"))
+ (setq eos (if (eobp) (point) (1- (point))))))
;; Find out what to do next and set `this-command'
(cond
((= eos eoh)
@@ -5308,14 +5989,14 @@ in special contexts.
;; We just showed the children, or no children are there,
;; now show everything.
(run-hook-with-args 'org-pre-cycle-hook 'subtree)
- (org-show-subtree)
+ (outline-flag-region eoh eos nil)
(message (if children-skipped "SUBTREE (NO CHILDREN)" "SUBTREE"))
(setq org-cycle-subtree-status 'subtree)
(run-hook-with-args 'org-cycle-hook 'subtree))
(t
;; Default action: hide the subtree.
(run-hook-with-args 'org-pre-cycle-hook 'folded)
- (hide-subtree)
+ (outline-flag-region eoh eos t)
(message "FOLDED")
(setq org-cycle-subtree-status 'folded)
(run-hook-with-args 'org-cycle-hook 'folded)))))
@@ -5323,7 +6004,7 @@ in special contexts.
;;;###autoload
(defun org-global-cycle (&optional arg)
"Cycle the global visibility. For details see `org-cycle'.
-With C-u prefix arg, switch to startup visibility.
+With \\[universal-argument] prefix arg, switch to startup visibility.
With a numeric prefix, show all headlines up to that level."
(interactive "P")
(let ((org-cycle-include-plain-lists
@@ -5352,15 +6033,15 @@ With a numeric prefix, show all headlines up to that level."
(org-set-visibility-according-to-property 'no-cleanup)
(org-cycle-hide-archived-subtrees 'all)
(org-cycle-hide-drawers 'all)
- (org-cycle-show-empty-lines 'all)))
+ (org-cycle-show-empty-lines t)))
(defun org-set-visibility-according-to-property (&optional no-cleanup)
"Switch subtree visibilities according to :VISIBILITY: property."
(interactive)
(let (org-show-entry-below state)
(save-excursion
- (goto-char (point-min))
- (while (re-search-forward
+ (goto-char (point-max))
+ (while (re-search-backward
"^[ \t]*:VISIBILITY:[ \t]+\\([a-z]+\\)"
nil t)
(setq state (match-string 1))
@@ -5436,11 +6117,11 @@ This function is the default value of the hook `org-cycle-hook'."
"Remove outline overlays that do not contain non-white stuff."
(mapc
(lambda (o)
- (and (eq 'outline (org-overlay-get o 'invisible))
- (not (string-match "\\S-" (buffer-substring (org-overlay-start o)
- (org-overlay-end o))))
- (org-delete-overlay o)))
- (org-overlays-at pos)))
+ (and (eq 'outline (overlay-get o 'invisible))
+ (not (string-match "\\S-" (buffer-substring (overlay-start o)
+ (overlay-end o))))
+ (delete-overlay o)))
+ (overlays-at pos)))
(defun org-clean-visibility-after-subtree-move ()
"Fix visibility issues after moving a subtree."
@@ -5466,7 +6147,9 @@ This function is the default value of the hook `org-cycle-hook'."
;; Properly fold already folded siblings
(goto-char (point-min))
(while (re-search-forward re nil t)
- (if (save-excursion (goto-char (point-at-eol)) (org-invisible-p))
+ (if (and (not (org-invisible-p))
+ (save-excursion
+ (goto-char (point-at-eol)) (org-invisible-p)))
(hide-entry))))
(org-cycle-show-empty-lines 'overview)
(org-cycle-hide-drawers 'overview)))))
@@ -5580,12 +6263,49 @@ open and agenda-wise Org files."
(defun org-first-headline-recenter (&optional N)
"Move cursor to the first headline and recenter the headline.
-Optional argument N means, put the headline into the Nth line of the window."
+Optional argument N means put the headline into the Nth line of the window."
(goto-char (point-min))
(when (re-search-forward (concat "^\\(" outline-regexp "\\)") nil t)
(beginning-of-line)
(recenter (prefix-numeric-value N))))
+;;; Saving and restoring visibility
+
+(defun org-outline-overlay-data (&optional use-markers)
+ "Return a list of the locations of all outline overlays.
+These are overlays with the `invisible' property value `outline'.
+The return value is a list of cons cells, with start and stop
+positions for each overlay.
+If USE-MARKERS is set, return the positions as markers."
+ (let (beg end)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (delq nil
+ (mapcar (lambda (o)
+ (when (eq (overlay-get o 'invisible) 'outline)
+ (setq beg (overlay-start o)
+ end (overlay-end o))
+ (and beg end (> end beg)
+ (if use-markers
+ (cons (move-marker (make-marker) beg)
+ (move-marker (make-marker) end))
+ (cons beg end)))))
+ (overlays-in (point-min) (point-max))))))))
+
+(defun org-set-outline-overlay-data (data)
+ "Create visibility overlays for all positions in DATA.
+DATA should have been made by `org-outline-overlay-data'."
+ (let (o)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (show-all)
+ (mapc (lambda (c)
+ (setq o (make-overlay (car c) (cdr c)))
+ (overlay-put o 'invisible 'outline))
+ data)))))
+
;;; Folding of blocks
(defconst org-block-regexp
@@ -5598,9 +6318,8 @@ Optional argument N means, put the headline into the Nth line of the window."
(make-variable-buffer-local 'org-hide-block-overlays)
(defun org-block-map (function &optional start end)
- "Call func at the head of all source blocks in the current
-buffer. Optional arguments START and END can be used to limit
-the range."
+ "Call FUNCTION at the head of all source blocks in the current buffer.
+Optional arguments START and END can be used to limit the range."
(let ((start (or start (point-min)))
(end (or end (point-max))))
(save-excursion
@@ -5623,7 +6342,8 @@ the range."
(defun org-show-block-all ()
"Unfold all blocks in the current buffer."
- (mapc 'org-delete-overlay org-hide-block-overlays)
+ (interactive)
+ (mapc 'delete-overlay org-hide-block-overlays)
(setq org-hide-block-overlays nil))
(defun org-hide-block-toggle-maybe ()
@@ -5647,30 +6367,30 @@ the range."
(end (match-end 0)) ;; end of entire body
ov)
(if (memq t (mapcar (lambda (overlay)
- (eq (org-overlay-get overlay 'invisible)
+ (eq (overlay-get overlay 'invisible)
'org-hide-block))
- (org-overlays-at start)))
+ (overlays-at start)))
(if (or (not force) (eq force 'off))
(mapc (lambda (ov)
(when (member ov org-hide-block-overlays)
(setq org-hide-block-overlays
(delq ov org-hide-block-overlays)))
- (when (eq (org-overlay-get ov 'invisible)
+ (when (eq (overlay-get ov 'invisible)
'org-hide-block)
- (org-delete-overlay ov)))
- (org-overlays-at start)))
- (setq ov (org-make-overlay start end))
- (org-overlay-put ov 'invisible 'org-hide-block)
+ (delete-overlay ov)))
+ (overlays-at start)))
+ (setq ov (make-overlay start end))
+ (overlay-put ov 'invisible 'org-hide-block)
;; make the block accessible to isearch
- (org-overlay-put
+ (overlay-put
ov 'isearch-open-invisible
(lambda (ov)
(when (member ov org-hide-block-overlays)
(setq org-hide-block-overlays
(delq ov org-hide-block-overlays)))
- (when (eq (org-overlay-get ov 'invisible)
+ (when (eq (overlay-get ov 'invisible)
'org-hide-block)
- (org-delete-overlay ov))))
+ (delete-overlay ov))))
(push ov org-hide-block-overlays)))
(error "Not looking at a source block"))))
@@ -5755,7 +6475,9 @@ the headline hierarchy above."
(selected-point
(if (eq interface 'outline)
(car (org-get-location (current-buffer) org-goto-help))
- (nth 3 (org-refile-get-location "Goto: ")))))
+ (let ((pa (org-refile-get-location "Goto: ")))
+ (org-refile-check-position pa)
+ (nth 3 pa)))))
(if selected-point
(progn
(org-mark-ring-push org-goto-start-pos)
@@ -5776,7 +6498,11 @@ or nil."
(isearch-hide-immediately nil)
(isearch-search-fun-function
(lambda () 'org-goto-local-search-headings))
- (org-goto-selected-point org-goto-exit-command))
+ (org-goto-selected-point org-goto-exit-command)
+ (pop-up-frames nil)
+ (special-display-buffer-names nil)
+ (special-display-regexps nil)
+ (special-display-function nil))
(save-excursion
(save-window-excursion
(delete-other-windows)
@@ -5883,10 +6609,12 @@ With numerical prefix ARG, go up to this level and then take that tree.
If ARG is negative, go up that many levels.
If `org-indirect-buffer-display' is not `new-frame', the command removes the
indirect buffer previously made with this command, to avoid proliferation of
-indirect buffers. However, when you call the command with a `C-u' prefix, or
+indirect buffers. However, when you call the command with a \
+\\[universal-argument] prefix, or
when `org-indirect-buffer-display' is `new-frame', the last buffer
is kept so that you can work with several indirect buffers at the same time.
-If `org-indirect-buffer-display' is `dedicated-frame', the C-u prefix also
+If `org-indirect-buffer-display' is `dedicated-frame', the \
+\\[universal-argument] prefix also
requests that a new frame be made for the new buffer, so that the dedicated
frame is not changed."
(interactive "P")
@@ -5903,7 +6631,9 @@ frame is not changed."
(outline-up-heading 1 t)))
(setq beg (point)
heading (org-get-heading))
- (org-end-of-subtree t t) (setq end (point)))
+ (org-end-of-subtree t t)
+ (if (org-on-heading-p) (backward-char 1))
+ (setq end (point)))
(if (and (buffer-live-p org-last-indirect-buffer)
(not (eq org-indirect-buffer-display 'new-frame))
(not arg))
@@ -5965,21 +6695,44 @@ frame is not changed."
(save-match-data
(looking-at "[ \t]*$")))))
-(defun org-insert-heading (&optional force-heading)
+(defun org-insert-heading (&optional force-heading invisible-ok)
"Insert a new heading or item with same depth at point.
If point is in a plain list and FORCE-HEADING is nil, create a new list item.
If point is at the beginning of a headline, insert a sibling before the
-current headline. If point is not at the beginning, do not split the line,
-but create the new headline after the current line."
+current headline. If point is not at the beginning, split the line,
+create the new headline with the text in the current line after point
+\(but see also the variable `org-M-RET-may-split-line').
+
+When INVISIBLE-OK is set, stop at invisible headlines when going back.
+This is important for non-interactive uses of the command."
(interactive "P")
- (if (= (buffer-size) 0)
- (insert "\n* ")
+ (if (or (= (buffer-size) 0)
+ (and (not (save-excursion
+ (and (ignore-errors (org-back-to-heading invisible-ok))
+ (org-on-heading-p))))
+ (not (org-in-item-p))))
+ (progn
+ (insert "\n* ")
+ (run-hooks 'org-insert-heading-hook))
(when (or force-heading (not (org-insert-item)))
(let* ((empty-line-p nil)
+ (level nil)
+ (on-heading (org-on-heading-p))
(head (save-excursion
(condition-case nil
(progn
- (org-back-to-heading)
+ (org-back-to-heading invisible-ok)
+ (when (and (not on-heading)
+ (featurep 'org-inlinetask)
+ (integerp org-inlinetask-min-level)
+ (>= (length (match-string 0))
+ org-inlinetask-min-level))
+ ;; Find a heading level before the inline task
+ (while (and (setq level (org-up-heading-safe))
+ (>= level org-inlinetask-min-level)))
+ (if (org-on-heading-p)
+ (org-back-to-heading invisible-ok)
+ (error "This should not happen")))
(setq empty-line-p (org-previous-line-empty-p))
(match-string 0))
(error "*"))))
@@ -6017,6 +6770,12 @@ but create the new headline after the current line."
(cond
(org-insert-heading-respect-content
(org-end-of-subtree nil t)
+ (when (featurep 'org-inlinetask)
+ (while (and (not (eobp))
+ (looking-at "\\(\\*+\\)[ \t]+")
+ (>= (length (match-string 1))
+ org-inlinetask-min-level))
+ (org-end-of-subtree nil t)))
(or (bolp) (newline))
(or (org-previous-line-empty-p)
(and blank (newline)))
@@ -6025,13 +6784,16 @@ but create the new headline after the current line."
(when hide-previous
(show-children)
(org-show-entry))
- (looking-at ".*?\\([ \t]+\\(:[[:alnum:]_@:]+:\\)\\)?[ \t]*$")
+ (looking-at ".*?\\([ \t]+\\(:[[:alnum:]_@#%:]+:\\)\\)?[ \t]*$")
(setq tags (and (match-end 2) (match-string 2)))
(and (match-end 1)
(delete-region (match-beginning 1) (match-end 1)))
(setq pos (point-at-bol))
(or split (end-of-line 1))
(delete-horizontal-space)
+ (if (string-match "\\`\\*+\\'"
+ (buffer-substring (point-at-bol) (point)))
+ (insert " "))
(newline (if blank 2 1))
(when tags
(save-excursion
@@ -6058,7 +6820,7 @@ but create the new headline after the current line."
(org-back-to-heading t)
(if (looking-at
(if no-tags
- (org-re "\\*+[ \t]+\\([^\n\r]*?\\)\\([ \t]+:[[:alnum:]:_@]+:[ \t]*\\)?$")
+ (org-re "\\*+[ \t]+\\([^\n\r]*?\\)\\([ \t]+:[[:alnum:]:_@#%]+:[ \t]*\\)?$")
"\\*+[ \t]+\\([^\r\n]*\\)"))
(match-string 1) "")))
@@ -6073,7 +6835,7 @@ This is a list with the following elements:
- the tags string, or nil."
(save-excursion
(org-back-to-heading t)
- (if (looking-at org-complex-heading-regexp)
+ (if (let (case-fold-search) (looking-at org-complex-heading-regexp))
(list (length (match-string 1))
(org-reduced-level (length (match-string 1)))
(org-match-string-no-properties 2)
@@ -6143,7 +6905,7 @@ Works for outline headings and for plain lists alike."
(org-insert-heading arg)
(cond
((org-on-heading-p) (org-do-demote))
- ((org-at-item-p) (org-indent-item 1))))
+ ((org-at-item-p) (org-indent-item))))
(defun org-insert-todo-subheading (arg)
"Insert a new subheading with TODO keyword or checkbox and demote it.
@@ -6152,7 +6914,7 @@ Works for outline headings and for plain lists alike."
(org-insert-todo-heading arg)
(cond
((org-on-heading-p) (org-do-demote))
- ((org-at-item-p) (org-indent-item 1))))
+ ((org-at-item-p) (org-indent-item))))
;;; Promotion and Demotion
@@ -6226,11 +6988,30 @@ The level is the number of stars at the beginning of the headline."
(funcall outline-level))
(error nil))))
+(defun org-get-previous-line-level ()
+ "Return the outline depth of the last headline before the current line.
+Returns 0 for the first headline in the buffer, and nil if before the
+first headline."
+ (let ((current-level (org-current-level))
+ (prev-level (when (> (line-number-at-pos) 1)
+ (save-excursion
+ (beginning-of-line 0)
+ (org-current-level)))))
+ (cond ((null current-level) nil) ; Before first headline
+ ((null prev-level) 0) ; At first headline
+ (prev-level))))
+
(defun org-reduced-level (l)
"Compute the effective level of a heading.
This takes into account the setting of `org-odd-levels-only'."
(if org-odd-levels-only (1+ (floor (/ l 2))) l))
+(defun org-level-increment ()
+ "Return the number of stars that will be added or removed at a
+time to headlines when structure editing, based on the value of
+`org-odd-levels-only'."
+ (if org-odd-levels-only 2 1))
+
(defun org-get-valid-level (level &optional change)
"Rectify a level change under the influence of `org-odd-levels-only'
LEVEL is a current level, CHANGE is by how much the level should be
@@ -6278,30 +7059,41 @@ in the region."
(if org-adapt-indentation (org-fixup-indentation diff))
(run-hooks 'org-after-demote-entry-hook)))
-(defvar org-tab-ind-state nil)
-
(defun org-cycle-level ()
+ "Cycle the level of an empty headline through possible states.
+This goes first to child, then to parent, level, then up the hierarchy.
+After top level, it switches back to sibling level."
+ (interactive)
(let ((org-adapt-indentation nil))
- (when (and (looking-at "[ \t]*$")
- (looking-back
- (concat "^\\(\\*+\\)[ \t]+\\(" org-todo-regexp "\\)?[ \t]*")))
- (setq this-command 'org-cycle-level)
- (if (eq last-command 'org-cycle-level)
- (condition-case nil
- (progn (org-do-promote)
- (if (equal org-tab-ind-state (org-current-level))
- (org-do-promote)))
- (error
- (progn
- (save-excursion
- (beginning-of-line 1)
- (and (looking-at "\\*+")
- (replace-match
- (make-string org-tab-ind-state ?*))))
- (setq this-command 'org-cycle))))
- (setq org-tab-ind-state (- (match-end 1) (match-beginning 1)))
- (org-do-demote))
- t)))
+ (when (org-point-at-end-of-empty-headline)
+ (setq this-command 'org-cycle-level) ; Only needed for caching
+ (let ((cur-level (org-current-level))
+ (prev-level (org-get-previous-line-level)))
+ (cond
+ ;; If first headline in file, promote to top-level.
+ ((= prev-level 0)
+ (loop repeat (/ (- cur-level 1) (org-level-increment))
+ do (org-do-promote)))
+ ;; If same level as prev, demote one.
+ ((= prev-level cur-level)
+ (org-do-demote))
+ ;; If parent is top-level, promote to top level if not already.
+ ((= prev-level 1)
+ (loop repeat (/ (- cur-level 1) (org-level-increment))
+ do (org-do-promote)))
+ ;; If top-level, return to prev-level.
+ ((= cur-level 1)
+ (loop repeat (/ (- prev-level 1) (org-level-increment))
+ do (org-do-demote)))
+ ;; If less than prev-level, promote one.
+ ((< cur-level prev-level)
+ (org-do-promote))
+ ;; If deeper than prev-level, promote until higher than
+ ;; prev-level.
+ ((> cur-level prev-level)
+ (loop repeat (+ 1 (/ (- cur-level prev-level) (org-level-increment)))
+ do (org-do-promote))))
+ t))))
(defun org-map-tree (fun)
"Call FUN for every heading underneath the current one."
@@ -6331,7 +7123,7 @@ in the region."
(funcall fun)))))
(defun org-fixup-indentation (diff)
- "Change the indentation in the current entry by DIFF
+ "Change the indentation in the current entry by DIFF.
However, if any line in the current entry has no indentation, or if it
would end up with no indentation after the change, nothing at all is done."
(save-excursion
@@ -6369,10 +7161,11 @@ level 5 etc."
(end-of-line 1))))))
(defun org-convert-to-oddeven-levels ()
- "Convert an org-mode file with only odd levels to one with odd and even levels.
-This promotes level 3 to level 2, level 5 to level 3 etc. If the file contains a
-section with an even level, conversion would destroy the structure of the file. An error
-is signaled in this case."
+ "Convert an org-mode file with only odd levels to one with odd/even levels.
+This promotes level 3 to level 2, level 5 to level 3 etc. If the
+file contains a section with an even level, conversion would
+destroy the structure of the file. An error is signaled in this
+case."
(interactive)
(goto-char (point-min))
;; First check if there are no even levels
@@ -6707,20 +7500,26 @@ If yes, remember the marker and the distance to BEG."
(save-match-data
(narrow-to-region
(progn (org-back-to-heading t) (point))
- (progn (org-end-of-subtree t t) (point))))))
+ (progn (org-end-of-subtree t t)
+ (if (org-on-heading-p) (backward-char 1))
+ (point))))))
+
+(eval-when-compile
+ (defvar org-property-drawer-re))
(defun org-clone-subtree-with-time-shift (n &optional shift)
"Clone the task (subtree) at point N times.
The clones will be inserted as siblings.
-In interactive use, the user will be prompted for the number of clones
-to be produced, and for a time SHIFT, which may be a repeater as used
-in time stamps, for example `+3d'.
+In interactive use, the user will be prompted for the number of
+clones to be produced, and for a time SHIFT, which may be a
+repeater as used in time stamps, for example `+3d'.
-When a valid repeater is given and the entry contains any time stamps,
-the clones will become a sequence in time, with time stamps in the
-subtree shifted for each clone produced. If SHIFT is nil or the
-empty string, time stamps will be left alone.
+When a valid repeater is given and the entry contains any time
+stamps, the clones will become a sequence in time, with time
+stamps in the subtree shifted for each clone produced. If SHIFT
+is nil or the empty string, time stamps will be left alone. The
+ID property of the original subtree is removed.
If the original subtree did contain time stamps with a repeater,
the following will happen:
@@ -6734,7 +7533,7 @@ the following will happen:
I this way you can spell out a number of instances of a repeating task,
and still retain the repeater to cover future instances of the task."
(interactive "nNumber of clones to produce: \nsDate shift per clone (e.g. +1w, empty to copy unchanged): ")
- (let (beg end template task
+ (let (beg end template task idprop
shift-n shift-what doshift nmin nmax (n-no-remove -1))
(if (not (and (integerp n) (> n 0)))
(error "Invalid number of replications %s" n))
@@ -6751,6 +7550,7 @@ and still retain the repeater to cover future instances of the task."
(setq nmin 1 nmax n)
(org-back-to-heading t)
(setq beg (point))
+ (setq idprop (org-entry-get nil "ID"))
(org-end-of-subtree t t)
(or (bolp) (insert "\n"))
(setq end (point))
@@ -6762,12 +7562,18 @@ and still retain the repeater to cover future instances of the task."
(setq nmin 0 nmax (1+ nmax) n-no-remove nmax))
(goto-char end)
(loop for n from nmin to nmax do
- (if (not doshift)
- (setq task template)
- (with-temp-buffer
- (insert template)
- (org-mode)
- (goto-char (point-min))
+ ;; prepare clone
+ (with-temp-buffer
+ (insert template)
+ (org-mode)
+ (goto-char (point-min))
+ (and idprop (if org-clone-delete-id
+ (org-entry-delete nil "ID")
+ (org-id-get-create t)))
+ (while (re-search-forward org-property-drawer-re nil t)
+ (org-remove-empty-drawer-at "PROPERTIES" (point)))
+ (goto-char (point-min))
+ (when doshift
(while (re-search-forward org-ts-regexp-both nil t)
(org-timestamp-change (* n shift-n) shift-what))
(unless (= n n-no-remove)
@@ -6776,21 +7582,23 @@ and still retain the repeater to cover future instances of the task."
(save-excursion
(goto-char (match-beginning 0))
(if (looking-at "<[^<>\n]+\\( +\\+[0-9]+[dwmy]\\)")
- (delete-region (match-beginning 1) (match-end 1))))))
- (setq task (buffer-string))))
+ (delete-region (match-beginning 1) (match-end 1)))))))
+ (setq task (buffer-string)))
(insert task))
(goto-char beg)))
;;; Outline Sorting
(defun org-sort (with-case)
- "Call `org-sort-entries-or-items' or `org-table-sort-lines'.
+ "Call `org-sort-entries', `org-table-sort-lines' or `org-sort-list'.
Optional argument WITH-CASE means sort case-sensitively.
With a double prefix argument, also remove duplicate entries."
(interactive "P")
- (if (org-at-table-p)
- (org-call-with-arg 'org-table-sort-lines with-case)
- (org-call-with-arg 'org-sort-entries-or-items with-case)))
+ (cond
+ ((org-at-table-p) (org-call-with-arg 'org-table-sort-lines with-case))
+ ((org-at-item-p) (org-call-with-arg 'org-sort-list with-case))
+ (t
+ (org-call-with-arg 'org-sort-entries with-case))))
(defun org-sort-remove-invisible (s)
(remove-text-properties 0 (length s) org-rm-props s)
@@ -6808,20 +7616,18 @@ When children are sorted, the cursor is in the parent line when this
hook gets called. When a region or a plain list is sorted, the cursor
will be in the first entry of the sorted region/list.")
-(defun org-sort-entries-or-items
+(defun org-sort-entries
(&optional with-case sorting-type getkey-func compare-func property)
- "Sort entries on a certain level of an outline tree, or plain list items.
+ "Sort entries on a certain level of an outline tree.
If there is an active region, the entries in the region are sorted.
Else, if the cursor is before the first entry, sort the top-level items.
Else, the children of the entry at point are sorted.
-If the cursor is at the first item in a plain list, the list items will be
-sorted.
Sorting can be alphabetically, numerically, by date/time as given by
a time stamp, by a property or by priority.
The command prompts for the sorting type unless it has been given to the
-function through the SORTING-TYPE argument, which needs to a character,
+function through the SORTING-TYPE argument, which needs to be a character,
\(?n ?N ?a ?A ?t ?T ?s ?S ?d ?D ?p ?P ?r ?R ?f ?F). Here is the
precise meaning of each character:
@@ -6829,7 +7635,6 @@ n Numerically, by converting the beginning of the entry/item to a number.
a Alphabetically, ignoring the TODO keyword and the priority, if any.
t By date/time, either the first active time stamp in the entry, or, if
none exist, by the first inactive one.
- In items, only the first line will be checked.
s By the scheduled date/time.
d By deadline date/time.
c By creation time, which is assumed to be the first inactive time stamp
@@ -6848,7 +7653,7 @@ WITH-CASE, the sorting considers case as well."
(interactive "P")
(let ((case-func (if with-case 'identity 'downcase))
start beg end stars re re2
- txt what tmp plain-list-p)
+ txt what tmp)
;; Find beginning and end of region to sort
(cond
((org-region-active-p)
@@ -6858,15 +7663,6 @@ WITH-CASE, the sorting considers case as well."
(goto-char (region-beginning))
(if (not (org-on-heading-p)) (outline-next-heading))
(setq start (point)))
- ((org-at-item-p)
- ;; we will sort this plain list
- (org-beginning-of-item-list) (setq start (point))
- (org-end-of-item-list)
- (or (bolp) (insert "\n"))
- (setq end (point))
- (goto-char start)
- (setq plain-list-p t
- what "plain list"))
((or (org-on-heading-p)
(condition-case nil (progn (org-back-to-heading) t) (error nil)))
;; we will sort the children of the current headline
@@ -6899,43 +7695,39 @@ WITH-CASE, the sorting considers case as well."
(setq beg (point))
(if (>= beg end) (error "Nothing to sort"))
- (unless plain-list-p
- (looking-at "\\(\\*+\\)")
- (setq stars (match-string 1)
- re (concat "^" (regexp-quote stars) " +")
- re2 (concat "^" (regexp-quote (substring stars 0 -1)) "[^*]")
- txt (buffer-substring beg end))
- (if (not (equal (substring txt -1) "\n")) (setq txt (concat txt "\n")))
- (if (and (not (equal stars "*")) (string-match re2 txt))
- (error "Region to sort contains a level above the first entry")))
+ (looking-at "\\(\\*+\\)")
+ (setq stars (match-string 1)
+ re (concat "^" (regexp-quote stars) " +")
+ re2 (concat "^" (regexp-quote (substring stars 0 -1)) "[^*]")
+ txt (buffer-substring beg end))
+ (if (not (equal (substring txt -1) "\n")) (setq txt (concat txt "\n")))
+ (if (and (not (equal stars "*")) (string-match re2 txt))
+ (error "Region to sort contains a level above the first entry"))
(unless sorting-type
(message
- (if plain-list-p
- "Sort %s: [a]lpha [n]umeric [t]ime [f]unc A/N/T/F means reversed:"
- "Sort %s: [a]lpha [n]umeric [p]riority p[r]operty todo[o]rder [f]unc
+ "Sort %s: [a]lpha [n]umeric [p]riority p[r]operty todo[o]rder [f]unc
[t]ime [s]cheduled [d]eadline [c]reated
- A/N/T/S/D/C/P/O/F means reversed:")
+ A/N/T/S/D/C/P/O/F means reversed:"
what)
(setq sorting-type (read-char-exclusive))
(and (= (downcase sorting-type) ?f)
(setq getkey-func
(org-icompleting-read "Sort using function: "
- obarray 'fboundp t nil nil))
+ obarray 'fboundp t nil nil))
(setq getkey-func (intern getkey-func)))
(and (= (downcase sorting-type) ?r)
(setq property
(org-icompleting-read "Property: "
- (mapcar 'list (org-buffer-property-keys t))
- nil t))))
+ (mapcar 'list (org-buffer-property-keys t))
+ nil t))))
(message "Sorting entries...")
(save-restriction
(narrow-to-region start end)
-
(let ((dcst (downcase sorting-type))
(case-fold-search nil)
(now (current-time)))
@@ -6943,99 +7735,70 @@ WITH-CASE, the sorting considers case as well."
(/= dcst sorting-type)
;; This function moves to the beginning character of the "record" to
;; be sorted.
- (if plain-list-p
- (lambda nil
- (if (org-at-item-p) t (goto-char (point-max))))
- (lambda nil
- (if (re-search-forward re nil t)
- (goto-char (match-beginning 0))
- (goto-char (point-max)))))
+ (lambda nil
+ (if (re-search-forward re nil t)
+ (goto-char (match-beginning 0))
+ (goto-char (point-max))))
;; This function moves to the last character of the "record" being
;; sorted.
- (if plain-list-p
- 'org-end-of-item
- (lambda nil
- (save-match-data
- (condition-case nil
- (outline-forward-same-level 1)
- (error
- (goto-char (point-max)))))))
-
+ (lambda nil
+ (save-match-data
+ (condition-case nil
+ (outline-forward-same-level 1)
+ (error
+ (goto-char (point-max))))))
;; This function returns the value that gets sorted against.
- (if plain-list-p
- (lambda nil
- (when (looking-at "[ \t]*[-+*0-9.)]+[ \t]+")
- (cond
- ((= dcst ?n)
- (string-to-number (buffer-substring (match-end 0)
- (point-at-eol))))
- ((= dcst ?a)
- (buffer-substring (match-end 0) (point-at-eol)))
- ((= dcst ?t)
- (if (or (re-search-forward org-ts-regexp (point-at-eol) t)
- (re-search-forward org-ts-regexp-both
- (point-at-eol) t))
- (org-time-string-to-seconds (match-string 0))
- (org-float-time now)))
- ((= dcst ?f)
- (if getkey-func
- (progn
- (setq tmp (funcall getkey-func))
- (if (stringp tmp) (setq tmp (funcall case-func tmp)))
- tmp)
- (error "Invalid key function `%s'" getkey-func)))
- (t (error "Invalid sorting type `%c'" sorting-type)))))
- (lambda nil
- (cond
- ((= dcst ?n)
- (if (looking-at org-complex-heading-regexp)
- (string-to-number (match-string 4))
- nil))
- ((= dcst ?a)
- (if (looking-at org-complex-heading-regexp)
- (funcall case-func (match-string 4))
- nil))
- ((= dcst ?t)
- (let ((end (save-excursion (outline-next-heading) (point))))
- (if (or (re-search-forward org-ts-regexp end t)
- (re-search-forward org-ts-regexp-both end t))
- (org-time-string-to-seconds (match-string 0))
- (org-float-time now))))
- ((= dcst ?c)
- (let ((end (save-excursion (outline-next-heading) (point))))
- (if (re-search-forward
- (concat "^[ \t]*\\[" org-ts-regexp1 "\\]")
- end t)
- (org-time-string-to-seconds (match-string 0))
- (org-float-time now))))
- ((= dcst ?s)
- (let ((end (save-excursion (outline-next-heading) (point))))
- (if (re-search-forward org-scheduled-time-regexp end t)
- (org-time-string-to-seconds (match-string 1))
- (org-float-time now))))
- ((= dcst ?d)
- (let ((end (save-excursion (outline-next-heading) (point))))
- (if (re-search-forward org-deadline-time-regexp end t)
- (org-time-string-to-seconds (match-string 1))
- (org-float-time now))))
- ((= dcst ?p)
- (if (re-search-forward org-priority-regexp (point-at-eol) t)
- (string-to-char (match-string 2))
- org-default-priority))
- ((= dcst ?r)
- (or (org-entry-get nil property) ""))
- ((= dcst ?o)
- (if (looking-at org-complex-heading-regexp)
- (- 9999 (length (member (match-string 2)
- org-todo-keywords-1)))))
- ((= dcst ?f)
- (if getkey-func
- (progn
- (setq tmp (funcall getkey-func))
- (if (stringp tmp) (setq tmp (funcall case-func tmp)))
- tmp)
- (error "Invalid key function `%s'" getkey-func)))
- (t (error "Invalid sorting type `%c'" sorting-type)))))
+ (lambda nil
+ (cond
+ ((= dcst ?n)
+ (if (looking-at org-complex-heading-regexp)
+ (string-to-number (match-string 4))
+ nil))
+ ((= dcst ?a)
+ (if (looking-at org-complex-heading-regexp)
+ (funcall case-func (match-string 4))
+ nil))
+ ((= dcst ?t)
+ (let ((end (save-excursion (outline-next-heading) (point))))
+ (if (or (re-search-forward org-ts-regexp end t)
+ (re-search-forward org-ts-regexp-both end t))
+ (org-time-string-to-seconds (match-string 0))
+ (org-float-time now))))
+ ((= dcst ?c)
+ (let ((end (save-excursion (outline-next-heading) (point))))
+ (if (re-search-forward
+ (concat "^[ \t]*\\[" org-ts-regexp1 "\\]")
+ end t)
+ (org-time-string-to-seconds (match-string 0))
+ (org-float-time now))))
+ ((= dcst ?s)
+ (let ((end (save-excursion (outline-next-heading) (point))))
+ (if (re-search-forward org-scheduled-time-regexp end t)
+ (org-time-string-to-seconds (match-string 1))
+ (org-float-time now))))
+ ((= dcst ?d)
+ (let ((end (save-excursion (outline-next-heading) (point))))
+ (if (re-search-forward org-deadline-time-regexp end t)
+ (org-time-string-to-seconds (match-string 1))
+ (org-float-time now))))
+ ((= dcst ?p)
+ (if (re-search-forward org-priority-regexp (point-at-eol) t)
+ (string-to-char (match-string 2))
+ org-default-priority))
+ ((= dcst ?r)
+ (or (org-entry-get nil property) ""))
+ ((= dcst ?o)
+ (if (looking-at org-complex-heading-regexp)
+ (- 9999 (length (member (match-string 2)
+ org-todo-keywords-1)))))
+ ((= dcst ?f)
+ (if getkey-func
+ (progn
+ (setq tmp (funcall getkey-func))
+ (if (stringp tmp) (setq tmp (funcall case-func tmp)))
+ tmp)
+ (error "Invalid key function `%s'" getkey-func)))
+ (t (error "Invalid sorting type `%c'" sorting-type))))
nil
(cond
((= dcst ?a) 'string<)
@@ -7114,15 +7877,15 @@ If WITH-CASE is non-nil, the sorting will be case-sensitive."
"Keymap for the minor `orgstruct-mode'.")
(defvar org-local-vars nil
- "List of local variables, for use by `orgstruct-mode'")
+ "List of local variables, for use by `orgstruct-mode'.")
;;;###autoload
(define-minor-mode orgstruct-mode
- "Toggle the minor more `orgstruct-mode'.
-This mode is for using Org-mode structure commands in other modes.
-The following key behave as if Org-mode was active, if the cursor
-is on a headline, or on a plain list item (both in the definition
-of Org-mode).
+ "Toggle the minor mode `orgstruct-mode'.
+This mode is for using Org-mode structure commands in other
+modes. The following keys behave as if Org-mode were active, if
+the cursor is on a headline, or on a plain list item (both as
+defined by Org-mode).
M-up Move entry/item up
M-down Move entry/item down
@@ -7173,7 +7936,7 @@ major mode, for example with \\[normal-mode]."
(org-set-local 'orgstruct-is-++ t))))
(defvar orgstruct-is-++ nil
- "Is orgstruct-mode in ++ version in the current-buffer?")
+ "Is `orgstruct-mode' in ++ version in the current-buffer?")
(make-variable-buffer-local 'orgstruct-is-++)
;;;###autoload
@@ -7415,7 +8178,7 @@ If yes, it should return a non-nil value after a calling
`org-store-link-props' with a list of properties and values.
Special properties are:
-:type The link prefix. like \"http\". This must be given.
+:type The link prefix, like \"http\". This must be given.
:link The link, like \"http://www.astro.uva.nl/~dominik\".
This is obligatory as well.
:description Optional default description for the second pair
@@ -7440,11 +8203,13 @@ It should be a function accepting three arguments:
path the path of the link, the text after the prefix (like \"http:\")
desc the description of the link, if any, nil if there was no description
- format the export format, a symbol like `html' or `latex'.
+ format the export format, a symbol like `html' or `latex' or `ascii'..
The function may use the FORMAT information to return different values
depending on the format. The return value will be put literally into
-the exported file.
+the exported file. If the return value is nil, this means Org should
+do what it normally does with links which do not have EXPORT defined.
+
Org-mode has a built-in default for exporting links. If you are happy with
this default, there is no need to define an export function for the link
type. For a simple example of an export function, see `org-bbdb.el'."
@@ -7469,7 +8234,7 @@ For file links, arg negates `org-context-in-file-links'."
(org-load-modules-maybe)
(setq org-store-link-plist nil) ; reset
(let ((outline-regexp (org-get-limited-outline-regexp))
- link cpltxt desc description search txt custom-id)
+ link cpltxt desc description search txt custom-id agenda-link)
(cond
((run-hook-with-args-until-success 'org-store-link-functions)
@@ -7501,7 +8266,10 @@ For file links, arg negates `org-context-in-file-links'."
(get-text-property (point) 'org-marker))))
(when m
(org-with-point-at m
- (call-interactively 'org-store-link)))))
+ (setq agenda-link
+ (if (interactive-p)
+ (call-interactively 'org-store-link)
+ (org-store-link nil)))))))
((eq major-mode 'calendar-mode)
(let ((cd (calendar-cursor-to-date)))
@@ -7540,19 +8308,23 @@ For file links, arg negates `org-context-in-file-links'."
((eq major-mode 'dired-mode)
;; link to the file in the current line
- (setq cpltxt (concat "file:"
- (abbreviate-file-name
- (expand-file-name
- (dired-get-filename nil t))))
- link (org-make-link cpltxt)))
-
- ((and buffer-file-name (org-mode-p))
+ (let ((file (dired-get-filename nil t)))
+ (setq file (if file
+ (abbreviate-file-name
+ (expand-file-name (dired-get-filename nil t)))
+ ;; otherwise, no file so use current directory.
+ default-directory))
+ (setq cpltxt (concat "file:" file)
+ link (org-make-link cpltxt))))
+
+ ((and (buffer-file-name (buffer-base-buffer)) (org-mode-p))
(setq custom-id (ignore-errors (org-entry-get nil "CUSTOM_ID")))
(cond
((org-in-regexp "<<\\(.*?\\)>>")
(setq cpltxt
(concat "file:"
- (abbreviate-file-name buffer-file-name)
+ (abbreviate-file-name
+ (buffer-file-name (buffer-base-buffer)))
"::" (match-string 1))
link (org-make-link cpltxt)))
((and (featurep 'org-id)
@@ -7574,11 +8346,13 @@ For file links, arg negates `org-context-in-file-links'."
(error
;; probably before first headline, link to file only
(concat "file:"
- (abbreviate-file-name buffer-file-name))))))
+ (abbreviate-file-name
+ (buffer-file-name (buffer-base-buffer))))))))
(t
;; Just link to current headline
(setq cpltxt (concat "file:"
- (abbreviate-file-name buffer-file-name)))
+ (abbreviate-file-name
+ (buffer-file-name (buffer-base-buffer)))))
;; Add a context search string
(when (org-xor org-context-in-file-links arg)
(setq txt (cond
@@ -7635,7 +8409,7 @@ For file links, arg negates `org-context-in-file-links'."
"::#" custom-id))
(setq org-stored-links
(cons (list link desc) org-stored-links))))
- (and link (org-make-link-string link desc)))))
+ (or agenda-link (and link (org-make-link-string link desc))))))
(defun org-store-link-props (&rest plist)
"Store link properties, extract names and addresses."
@@ -7699,7 +8473,7 @@ according to FMT (default from `org-email-link-description-format')."
;; We are using a headline, clean up garbage in there.
(if (string-match org-todo-regexp s)
(setq s (replace-match "" t t s)))
- (if (string-match (org-re ":[[:alnum:]_@:]+:[ \t]*$") s)
+ (if (string-match (org-re ":[[:alnum:]_@#%:]+:[ \t]*$") s)
(setq s (replace-match "" t t s)))
(setq s (org-trim s))
(if (string-match (concat "^\\(" org-quote-string "\\|"
@@ -7707,8 +8481,6 @@ according to FMT (default from `org-email-link-description-format')."
(setq s (replace-match "" t t s)))
(while (string-match org-ts-regexp s)
(setq s (replace-match "" t t s))))
- (while (string-match "[^a-zA-Z_0-9 \t]+" s)
- (setq s (replace-match " " t t s)))
(or string (setq s (concat "*" s))) ; Add * for headlines
(mapconcat 'identity (org-split-string s "[ \t]+") " ")))
@@ -7736,7 +8508,11 @@ according to FMT (default from `org-email-link-description-format')."
(when (and (not description)
(not (equal link (org-link-escape link))))
(setq description (org-extract-attributes link)))
- (concat "[[" (org-link-escape link) "]"
+ (setq link (if (string-match org-link-types-re link)
+ (concat (match-string 1 link)
+ (org-link-escape (substring link (match-end 1))))
+ (org-link-escape link)))
+ (concat "[[" link "]"
(if description (concat "[" description "]") "")
"]"))
@@ -7755,7 +8531,7 @@ according to FMT (default from `org-email-link-description-format')."
(?\371 . "%F9") ; `u
(?\373 . "%FB") ; ^u
(?\; . "%3B")
- (?? . "%3F")
+;; (?? . "%3F")
(?= . "%3D")
(?+ . "%2B")
)
@@ -7771,7 +8547,7 @@ This is the list that is used before handing over to the browser.")
(defun org-link-escape (text &optional table)
"Escape characters in TEXT that are problematic for links."
- (if org-url-encoding-use-url-hexify
+ (if (and org-url-encoding-use-url-hexify (not table))
(url-hexify-string text)
(setq table (or table org-link-escape-chars))
(when text
@@ -7788,16 +8564,18 @@ This is the list that is used before handing over to the browser.")
(defun org-link-unescape (text &optional table)
"Reverse the action of `org-link-escape'."
- (if org-url-encoding-use-url-hexify
+ (if (and org-url-encoding-use-url-hexify (not table))
(url-unhex-string text)
(setq table (or table org-link-escape-chars))
(when text
- (let ((re (mapconcat (lambda (x) (regexp-quote (cdr x)))
+ (let ((case-fold-search t)
+ (re (mapconcat (lambda (x) (regexp-quote (downcase (cdr x))))
table "\\|")))
(while (string-match re text)
(setq text
(replace-match
- (char-to-string (car (rassoc (match-string 0 text) table)))
+ (char-to-string (car (rassoc (upcase (match-string 0 text))
+ table)))
t t text)))
text))))
@@ -7807,6 +8585,12 @@ This is the list that is used before handing over to the browser.")
(defun org-fixup-message-id-for-http (s)
"Replace special characters in a message id, so it can be used in an http query."
+ (when (string-match "%" s)
+ (setq s (mapconcat (lambda (c)
+ (if (eq c ?%)
+ "%25"
+ (char-to-string c)))
+ s "")))
(while (string-match "<" s)
(setq s (replace-match "%3C" t t s)))
(while (string-match ">" s)
@@ -7899,7 +8683,7 @@ Use TAB to complete link prefixes, then RET for type-specific completion support
(if (nth 1 x) (concat (car x) " (" (nth 1 x) ")") (car x)))
(reverse org-stored-links) "\n"))))
(let ((cw (selected-window)))
- (select-window (get-buffer-window "*Org Links*"))
+ (select-window (get-buffer-window "*Org Links*" 'visible))
(setq truncate-lines t)
(unless (pos-visible-in-window-p (point-max))
(org-fit-window-to-buffer))
@@ -7924,6 +8708,8 @@ Use TAB to complete link prefixes, then RET for type-specific completion support
nil nil nil
'tmphist
(car (car org-stored-links)))))
+ (if (not (string-match "\\S-" link))
+ (error "No link selected"))
(if (or (member link all-prefixes)
(and (equal ":" (substring link -1))
(member (substring link 0 -1) all-prefixes)
@@ -7956,8 +8742,9 @@ Use TAB to complete link prefixes, then RET for type-specific completion support
(setq link search)))))
;; Check if we can/should use a relative path. If yes, simplify the link
- (when (string-match "^file:\\(.*\\)" link)
- (let* ((path (match-string 1 link))
+ (when (string-match "^\\(file:\\|docview:\\)\\(.*\\)" link)
+ (let* ((type (match-string 1 link))
+ (path (match-string 2 link))
(origpath path)
(case-fold-search nil))
(cond
@@ -7971,14 +8758,15 @@ Use TAB to complete link prefixes, then RET for type-specific completion support
(t
(save-match-data
(if (string-match (concat "^" (regexp-quote
- (file-name-as-directory
- (expand-file-name "."))))
+ (expand-file-name
+ (file-name-as-directory
+ default-directory))))
(expand-file-name path))
;; We are linking a file with relative path name.
(setq path (substring (expand-file-name path)
(match-end 0)))
(setq path (abbreviate-file-name (expand-file-name path)))))))
- (setq link (concat "file:" path))
+ (setq link (concat type path))
(if (equal desc origpath)
(setq desc path))))
@@ -8097,6 +8885,23 @@ from."
(defvar org-link-search-failed nil)
+(defvar org-open-link-functions nil
+ "Hook for functions finding a plain text link.
+These functions must take a single argument, the link content.
+They will be called for links that look like [[link text][description]]
+when LINK TEXT does not have a protocol like \"http:\" and does not look
+like a filename (e.g. \"./blue.png\").
+
+These functions will be called *before* Org attempts to resolve the
+link by doing text searches in the current buffer - so if you want a
+link \"[[target]]\" to still find \"<<target>>\", your function should
+handle this as a special case.
+
+When the function does handle the link, it must return a non-nil value.
+If it decides that it is not responsible for this link, it must return
+nil to indicate that that Org-mode can continue with other options
+like exact and fuzzy text search.")
+
(defun org-next-link ()
"Move forward to the next link.
If the link is in hidden text, expose it."
@@ -8209,8 +9014,19 @@ Org-mode syntax."
(org-mode)
(insert s)
(goto-char (point-min))
+ (when reference-buffer
+ (setq org-link-abbrev-alist-local
+ (with-current-buffer reference-buffer
+ org-link-abbrev-alist-local)))
(org-open-at-point arg reference-buffer)))))
+(defvar org-open-at-point-functions nil
+ "Hook that is run when following a link at point.
+
+Functions in this hook must return t if they identify and follow
+a link at point. If they don't find anything interesting at point,
+they must return nil.")
+
(defun org-open-at-point (&optional in-emacs reference-buffer)
"Open link at or after point.
If there is no link at point, this function will search forward up to
@@ -8220,6 +9036,8 @@ optional argument IN-EMACS is non-nil, Emacs will visit the file.
With a double prefix argument, try to open outside of Emacs, in the
application the system uses for this file type."
(interactive "P")
+ ;; if in a code block, then open the block's results
+ (unless (call-interactively #'org-babel-open-src-block-result)
(org-load-modules-maybe)
(move-marker org-open-link-marker (point))
(setq org-window-config-before-follow-link (current-window-configuration))
@@ -8230,9 +9048,11 @@ application the system uses for this file type."
(concat org-plain-link-re "\\|"
org-bracket-link-regexp "\\|"
org-angle-link-re "\\|"
- "[ \t]:[^ \t\n]+:[ \t]*$"))))
+ "[ \t]:[^ \t\n]+:[ \t]*$")))
+ (not (get-text-property (point) 'org-linked-text)))
(or (org-offer-links-in-entry in-emacs)
(progn (require 'org-attach) (org-attach-reveal 'if-exists))))
+ ((run-hook-with-args-until-success 'org-open-at-point-functions))
((org-at-timestamp-p t) (org-follow-timestamp-link))
((or (org-footnote-at-reference-p) (org-footnote-at-definition-p))
(org-footnote-action))
@@ -8241,7 +9061,7 @@ application the system uses for this file type."
(catch 'match
(save-excursion
(skip-chars-forward "^]\n\r")
- (when (org-in-regexp org-bracket-link-regexp)
+ (when (org-in-regexp org-bracket-link-regexp 1)
(setq link (org-extract-attributes
(org-link-unescape (org-match-string-no-properties 1))))
(while (string-match " *\n *" link)
@@ -8271,7 +9091,7 @@ application the system uses for this file type."
(setq type (match-string 1) path (match-string 2))
(throw 'match t)))
(save-excursion
- (when (org-in-regexp (org-re "\\(:[[:alnum:]_@:]+\\):[ \t]*$"))
+ (when (org-in-regexp (org-re "\\(:[[:alnum:]_@#%:]+\\):[ \t]*$"))
(setq type "tags"
path (match-string 1))
(while (string-match ":" path)
@@ -8325,24 +9145,16 @@ application the system uses for this file type."
(browse-url (concat type ":" (org-link-escape
path org-link-escape-chars-browser))))
+ ((string= type "doi")
+ (browse-url (concat "http://dx.doi.org/"
+ (org-link-escape
+ path org-link-escape-chars-browser))))
+
((member type '("message"))
(browse-url (concat type ":" path)))
((string= type "tags")
(org-tags-view in-emacs path))
- ((string= type "thisfile")
- (if in-emacs
- (switch-to-buffer-other-window
- (org-get-buffer-for-internal-link (current-buffer)))
- (org-mark-ring-push))
- (let ((cmd `(org-link-search
- ,path
- ,(cond ((equal in-emacs '(4)) 'occur)
- ((equal in-emacs '(16)) 'org-occur)
- (t nil))
- ,pos)))
- (condition-case nil (eval cmd)
- (error (progn (widen) (eval cmd))))))
((string= type "tree-match")
(org-occur (concat "\\[" (regexp-quote path) "\\]")))
@@ -8387,10 +9199,28 @@ application the system uses for this file type."
(call-interactively (read cmd))))
(error "Abort"))))
+ ((and (string= type "thisfile")
+ (run-hook-with-args-until-success
+ 'org-open-link-functions path)))
+
+ ((string= type "thisfile")
+ (if in-emacs
+ (switch-to-buffer-other-window
+ (org-get-buffer-for-internal-link (current-buffer)))
+ (org-mark-ring-push))
+ (let ((cmd `(org-link-search
+ ,path
+ ,(cond ((equal in-emacs '(4)) 'occur)
+ ((equal in-emacs '(16)) 'org-occur)
+ (t nil))
+ ,pos)))
+ (condition-case nil (eval cmd)
+ (error (progn (widen) (eval cmd))))))
+
(t
(browse-url-at-point)))))))
(move-marker org-open-link-marker nil)
- (run-hook-with-args 'org-follow-link-hook))
+ (run-hook-with-args 'org-follow-link-hook)))
(defun org-offer-links-in-entry (&optional nth zero)
"Offer links in the current entry and follow the selected link.
@@ -8418,7 +9248,7 @@ there is one, offer it as link number zero."
((null links)
(message "No links"))
((equal (length links) 1)
- (setq link (car links)))
+ (setq link (list (car links))))
((and (integerp nth) (>= (length links) (if have-zero (1+ nth) nth)))
(setq link (nth (if have-zero nth (1- nth)) links)))
(t ; we have to select a link
@@ -8437,19 +9267,44 @@ there is one, offer it as link number zero."
(match-string 1 l))))))
links))
(org-fit-window-to-buffer (get-buffer-window "*Select Link*"))
- (message "Select link to open:")
+ (message "Select link to open, RET to open all:")
(setq c (read-char-exclusive))
(and (get-buffer "*Select Link*") (kill-buffer "*Select Link*"))))
(when (equal c ?q) (error "Abort"))
- (setq nth (- c ?0))
- (if have-zero (setq nth (1+ nth)))
- (unless (and (integerp nth) (>= (length links) nth))
- (error "Invalid link selection"))
- (setq link (nth (1- nth) links))))
+ (if (equal c ?\C-m)
+ (setq link links)
+ (setq nth (- c ?0))
+ (if have-zero (setq nth (1+ nth)))
+ (unless (and (integerp nth) (>= (length links) nth))
+ (error "Invalid link selection"))
+ (setq link (list (nth (1- nth) links))))))
(if link
- (progn (org-open-link-from-string link in-emacs (current-buffer)) t)
+ (let ((buf (current-buffer)))
+ (dolist (l link)
+ (org-open-link-from-string l in-emacs buf))
+ t)
nil)))
+;; Add special file links that specify the way of opening
+
+(org-add-link-type "file+sys" 'org-open-file-with-system)
+(org-add-link-type "file+emacs" 'org-open-file-with-emacs)
+(defun org-open-file-with-system (path)
+ "Open file at PATH using the system way of opening it."
+ (org-open-file path 'system))
+(defun org-open-file-with-emacs (path)
+ "Open file at PATH in Emacs."
+ (org-open-file path 'emacs))
+(defun org-remove-file-link-modifiers ()
+ "Remove the file link modifiers in `file+sys:' and `file+emacs:' links."
+ (goto-char (point-min))
+ (while (re-search-forward "\\<file\\+\\(sys\\|emacs\\):" nil t)
+ (org-if-unprotected
+ (replace-match "file:" t t))))
+(eval-after-load "org-exp"
+ '(add-hook 'org-export-preprocess-before-normalizing-links-hook
+ 'org-remove-file-link-modifiers))
+
;;;; Time estimates
(defun org-get-effort (&optional pom)
@@ -8464,8 +9319,8 @@ These functions are called in turn with point at the location to
which the link should point.
A function in the hook should first test if it would like to
-handle this file type, for example by checking the major-mode or
-the file extension. If it decides not to handle this file, it
+handle this file type, for example by checking the `major-mode'
+or the file extension. If it decides not to handle this file, it
should just return nil to give other functions a chance. If it
does handle the file, it must return the search string to be used
when following the link. The search string will be part of the
@@ -8486,8 +9341,8 @@ buffer with \\[org-insert-link].")
Functions added to this hook must accept a single argument, the
search string that was part of the file link, the part after the
double colon. The function must first check if it would like to
-handle this search, for example by checking the major-mode or the
-file extension. If it decides not to handle this search, it
+handle this search, for example by checking the `major-mode' or
+the file extension. If it decides not to handle this search, it
should just return nil to give other functions a chance. If it
does handle the search, it must return a non-nil value to keep
other functions from trying.
@@ -8502,6 +9357,7 @@ the window configuration before `org-open-at-point' was called using:
(set-window-configuration org-window-config-before-follow-link)")
+(defvar org-link-search-inhibit-query nil) ;; dynamically scoped
(defun org-link-search (s &optional type avoid-pos)
"Search for a link search option.
If S is surrounded by forward slashes, it is interpreted as a
@@ -8519,7 +9375,7 @@ in all files. If AVOID-POS is given, ignore matches near that position."
(pre nil) (post nil)
words re0 re1 re2 re3 re4_ re4 re5 re2a re2a_ reall)
(cond
- ;; First check if there are any special
+ ;; First check if there are any special search functions
((run-hook-with-args-until-success 'org-execute-file-search-functions s))
;; Now try the builtin stuff
((and (equal (string-to-char s0) ?#)
@@ -8564,12 +9420,33 @@ in all files. If AVOID-POS is given, ignore matches near that position."
;;((eq major-mode 'dired-mode)
;; (grep (concat "grep -n -e '" (match-string 1 s) "' *")))
(t (org-do-occur (match-string 1 s)))))
+ ((and (org-mode-p) org-link-search-must-match-exact-headline)
+ (and (equal (string-to-char s) ?*) (setq s (substring s 1)))
+ (goto-char (point-min))
+ (cond
+ ((let (case-fold-search)
+ (re-search-forward (format org-complex-heading-regexp-format
+ (regexp-quote s))
+ nil t))
+ ;; OK, found a match
+ (setq type 'dedicated)
+ (goto-char (match-beginning 0)))
+ ((and (not org-link-search-inhibit-query)
+ (eq org-link-search-must-match-exact-headline 'query-to-create)
+ (y-or-n-p "No match - create this as a new heading? "))
+ (goto-char (point-max))
+ (or (bolp) (newline))
+ (insert "* " s "\n")
+ (beginning-of-line 0))
+ (t
+ (goto-char pos)
+ (error "No match"))))
(t
- ;; A normal search strings
+ ;; A normal search string
(when (equal (string-to-char s) ?*)
;; Anchor on headlines, post may include tags.
(setq pre "^\\*+[ \t]+\\(?:\\sw+\\)?[ \t]*"
- post (org-re "[ \t]*\\(?:[ \t]+:[[:alnum:]_@:+]:[ \t]*\\)?$")
+ post (org-re "[ \t]*\\(?:[ \t]+:[[:alnum:]_@#%:+]:[ \t]*\\)?$")
s (substring s 1)))
(remove-text-properties
0 (length s)
@@ -8610,13 +9487,7 @@ in all files. If AVOID-POS is given, ignore matches near that position."
)
(goto-char (match-beginning 1))
(goto-char pos)
- (error "No match")))))
- (t
- ;; Normal string-search
- (goto-char (point-min))
- (if (search-forward s nil t)
- (goto-char (match-beginning 0))
- (error "No match"))))
+ (error "No match"))))))
(and (org-mode-p) (org-show-context 'link-search))
type))
@@ -8759,18 +9630,23 @@ entry for this file type, and if yes, the corresponding command is launched.
If no application is found, Emacs simply visits the file.
With optional prefix argument IN-EMACS, Emacs will visit the file.
-With a double C-c C-u prefix arg, Org tries to avoid opening in Emacs
-and o use an external application to visit the file.
-
-Optional LINE specifies a line to go to, optional SEARCH a string to
-search for. If LINE or SEARCH is given, the file will always be
-opened in Emacs.
+With a double \\[universal-argument] \\[universal-argument] \
+prefix arg, Org tries to avoid opening in Emacs
+and to use an external application to visit the file.
+
+Optional LINE specifies a line to go to, optional SEARCH a string
+to search for. If LINE or SEARCH is given, the file will be
+opened in Emacs, unless an entry from org-file-apps that makes
+use of groups in a regexp matches.
If the file does not exist, an error is thrown."
- (setq in-emacs (or in-emacs line search))
(let* ((file (if (equal path "")
buffer-file-name
(substitute-in-file-name (expand-file-name path))))
- (apps (append org-file-apps (org-default-apps)))
+ (file-apps (append org-file-apps (org-default-apps)))
+ (apps (org-remove-if
+ 'org-file-apps-entry-match-against-dlink-p file-apps))
+ (apps-dlink (org-remove-if-not
+ 'org-file-apps-entry-match-against-dlink-p file-apps))
(remp (and (assq 'remote apps) (org-file-remote-p file)))
(dirp (if remp nil (file-directory-p file)))
(file (if (and dirp org-open-directory-means-index-dot-org)
@@ -8778,21 +9654,41 @@ If the file does not exist, an error is thrown."
file))
(a-m-a-p (assq 'auto-mode apps))
(dfile (downcase file))
+ ;; reconstruct the original file: link from the PATH, LINE and SEARCH args
+ (link (cond ((and (eq line nil)
+ (eq search nil))
+ file)
+ (line
+ (concat file "::" (number-to-string line)))
+ (search
+ (concat file "::" search))))
+ (dlink (downcase link))
(old-buffer (current-buffer))
(old-pos (point))
(old-mode major-mode)
- ext cmd)
+ ext cmd link-match-data)
(if (string-match "^.*\\.\\([a-zA-Z0-9]+\\.gz\\)$" dfile)
(setq ext (match-string 1 dfile))
(if (string-match "^.*\\.\\([a-zA-Z0-9]+\\)$" dfile)
(setq ext (match-string 1 dfile))))
(cond
- ((equal in-emacs '(16))
+ ((member in-emacs '((16) system))
(setq cmd (cdr (assoc 'system apps))))
(in-emacs (setq cmd 'emacs))
(t
(setq cmd (or (and remp (cdr (assoc 'remote apps)))
(and dirp (cdr (assoc 'directory apps)))
+ ; first, try matching against apps-dlink
+ ; if we get a match here, store the match data for later
+ (let ((match (assoc-default dlink apps-dlink
+ 'string-match)))
+ (if match
+ (progn (setq link-match-data (match-data))
+ match)
+ (progn (setq in-emacs (or in-emacs line search))
+ nil))) ; if we have no match in apps-dlink,
+ ; always open the file in emacs if line or search
+ ; is given (for backwards compatibility)
(assoc-default dfile (org-apps-regexp-alist apps a-m-a-p)
'string-match)
(cdr (assoc ext apps))
@@ -8824,6 +9720,19 @@ If the file does not exist, an error is thrown."
(shell-quote-argument
(convert-standard-filename file)))
t t cmd)))
+
+ ;; Replace "%1", "%2" etc. in command with group matches from regex
+ (save-match-data
+ (let ((match-index 1)
+ (number-of-groups (- (/ (length link-match-data) 2) 1)))
+ (set-match-data link-match-data)
+ (while (<= match-index number-of-groups)
+ (let ((regex (concat "%" (number-to-string match-index)))
+ (replace-with (match-string match-index dlink)))
+ (while (string-match regex cmd)
+ (setq cmd (replace-match replace-with t t cmd))))
+ (setq match-index (+ match-index 1)))))
+
(save-window-excursion
(start-process-shell-command cmd nil cmd)
(and (boundp 'org-wait) (numberp org-wait) (sit-for org-wait))
@@ -8836,13 +9745,34 @@ If the file does not exist, an error is thrown."
(if search (org-link-search search))))
((consp cmd)
(let ((file (convert-standard-filename file)))
- (eval cmd)))
+ (save-match-data
+ (set-match-data link-match-data)
+ (eval cmd))))
(t (funcall (cdr (assq 'file org-link-frame-setup)) file)))
(and (org-mode-p) (eq old-mode 'org-mode)
(or (not (equal old-buffer (current-buffer)))
(not (equal old-pos (point))))
(org-mark-ring-push old-pos old-buffer))))
+(defun org-file-apps-entry-match-against-dlink-p (entry)
+ "This function returns non-nil if `entry' uses a regular
+expression which should be matched against the whole link by
+org-open-file.
+
+It assumes that is the case when the entry uses a regular
+expression which has at least one grouping construct and the
+action is either a lisp form or a command string containing
+'%1', i.e. using at least one subexpression match as a
+parameter."
+ (let ((selector (car entry))
+ (action (cdr entry)))
+ (if (stringp selector)
+ (and (> (regexp-opt-depth selector) 0)
+ (or (and (stringp action)
+ (string-match "%[0-9]" action))
+ (consp action)))
+ nil)))
+
(defun org-default-apps ()
"Return the default applications for this operating system."
(cond
@@ -8917,12 +9847,64 @@ on the system \"/user@host:\"."
(defvar org-agenda-new-buffers nil
"Buffers created to visit agenda files.")
+(defvar org-refile-cache nil
+ "Cache for refile targets.")
+
+
+(defvar org-refile-markers nil
+ "All the markers used for caching refile locations.")
+
+(defun org-refile-marker (pos)
+ "Get a new refile marker, but only if caching is in use."
+ (if (not org-refile-use-cache)
+ pos
+ (let ((m (make-marker)))
+ (move-marker m pos)
+ (push m org-refile-markers)
+ m)))
+
+(defun org-refile-cache-clear ()
+ "Clear the refile cache and disable all the markers."
+ (mapc (lambda (m) (move-marker m nil)) org-refile-markers)
+ (setq org-refile-markers nil)
+ (setq org-refile-cache nil)
+ (message "Refile cache has been cleared"))
+
+(defun org-refile-cache-check-set (set)
+ "Check if all the markers in the cache still have live buffers."
+ (let (marker)
+ (catch 'exit
+ (while (and set (setq marker (nth 3 (pop set))))
+ ;; if org-refile-use-outline-path is 'file, marker may be nil
+ (when (and marker (null (marker-buffer marker)))
+ (message "not found") (sit-for 3)
+ (throw 'exit nil)))
+ t)))
+
+(defun org-refile-cache-put (set &rest identifiers)
+ "Push the refile targets SET into the cache, under IDENTIFIERS."
+ (let* ((key (sha1 (prin1-to-string identifiers)))
+ (entry (assoc key org-refile-cache)))
+ (if entry
+ (setcdr entry set)
+ (push (cons key set) org-refile-cache))))
+
+(defun org-refile-cache-get (&rest identifiers)
+ "Retrieve the cached value for refile targets given by IDENTIFIERS."
+ (cond
+ ((not org-refile-cache) nil)
+ ((not org-refile-use-cache) (org-refile-cache-clear) nil)
+ (t
+ (let ((set (cdr (assoc (sha1 (prin1-to-string identifiers))
+ org-refile-cache))))
+ (and set (org-refile-cache-check-set set) set)))))
+
(defun org-get-refile-targets (&optional default-buffer)
"Produce a table with refile targets."
(let ((case-fold-search nil)
;; otherwise org confuses "TODO" as a kw and "Todo" as a word
(entries (or org-refile-targets '((nil . (:level . 1)))))
- targets txt re files f desc descre fast-path-p level pos0)
+ targets tgs txt re files f desc descre fast-path-p level pos0)
(message "Getting targets...")
(with-current-buffer (or default-buffer (current-buffer))
(while (setq entry (pop entries))
@@ -8961,46 +9943,58 @@ on the system \"/user@host:\"."
(while (setq f (pop files))
(with-current-buffer
(if (bufferp f) f (org-get-agenda-file-buffer f))
- (if (bufferp f) (setq f (buffer-file-name (buffer-base-buffer f))))
- (setq f (expand-file-name f))
- (if (eq org-refile-use-outline-path 'file)
- (push (list (file-name-nondirectory f) f nil nil) targets))
- (save-excursion
- (save-restriction
- (widen)
- (goto-char (point-min))
- (while (re-search-forward descre nil t)
- (goto-char (setq pos0 (point-at-bol)))
- (catch 'next
- (when org-refile-target-verify-function
- (save-match-data
- (or (funcall org-refile-target-verify-function)
- (throw 'next t))))
- (when (looking-at org-complex-heading-regexp)
- (setq level (org-reduced-level (- (match-end 1) (match-beginning 1)))
- txt (org-link-display-format (match-string 4))
- re (concat "^" (regexp-quote
- (buffer-substring (match-beginning 1)
- (match-end 4)))))
- (if (match-end 5) (setq re (concat re "[ \t]+"
- (regexp-quote
- (match-string 5)))))
- (setq re (concat re "[ \t]*$"))
- (when org-refile-use-outline-path
- (setq txt (mapconcat 'org-protect-slash
- (append
- (if (eq org-refile-use-outline-path 'file)
- (list (file-name-nondirectory
- (buffer-file-name (buffer-base-buffer))))
- (if (eq org-refile-use-outline-path 'full-file-path)
- (list (buffer-file-name (buffer-base-buffer)))))
- (org-get-outline-path fast-path-p level txt)
- (list txt))
- "/")))
- (push (list txt f re (point)) targets)))
- (when (= (point) pos0)
- ;; verification function has not moved point
- (goto-char (point-at-eol))))))))))
+ (or
+ (setq tgs (org-refile-cache-get (buffer-file-name) descre))
+ (progn
+ (if (bufferp f) (setq f (buffer-file-name
+ (buffer-base-buffer f))))
+ (setq f (and f (expand-file-name f)))
+ (if (eq org-refile-use-outline-path 'file)
+ (push (list (file-name-nondirectory f) f nil nil) tgs))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (while (re-search-forward descre nil t)
+ (goto-char (setq pos0 (point-at-bol)))
+ (catch 'next
+ (when org-refile-target-verify-function
+ (save-match-data
+ (or (funcall org-refile-target-verify-function)
+ (throw 'next t))))
+ (when (looking-at org-complex-heading-regexp)
+ (setq level (org-reduced-level
+ (- (match-end 1) (match-beginning 1)))
+ txt (org-link-display-format (match-string 4))
+ txt (replace-regexp-in-string "\\( *\[[0-9]+/?[0-9]*%?\]\\)+$" "" txt)
+ re (format org-complex-heading-regexp-format
+ (regexp-quote (match-string 4))))
+ (when org-refile-use-outline-path
+ (setq txt (mapconcat
+ 'org-protect-slash
+ (append
+ (if (eq org-refile-use-outline-path
+ 'file)
+ (list (file-name-nondirectory
+ (buffer-file-name
+ (buffer-base-buffer))))
+ (if (eq org-refile-use-outline-path
+ 'full-file-path)
+ (list (buffer-file-name
+ (buffer-base-buffer)))))
+ (org-get-outline-path fast-path-p
+ level txt)
+ (list txt))
+ "/")))
+ (push (list txt f re (org-refile-marker (point)))
+ tgs)))
+ (when (= (point) pos0)
+ ;; verification function has not moved point
+ (goto-char (point-at-eol))))))))
+ (when org-refile-use-cache
+ (org-refile-cache-put tgs (buffer-file-name) descre))
+ (setq targets (append tgs targets))
+ ))))
(message "Getting targets...done")
(nreverse targets)))
@@ -9013,9 +10007,10 @@ on the system \"/user@host:\"."
(defun org-get-outline-path (&optional fastp level heading)
"Return the outline path to the current entry, as a list.
-The parameters FASTP, LEVEL, and HEADING are for use be a scanner
+
+The parameters FASTP, LEVEL, and HEADING are for use by a scanner
routine which makes outline path derivations for an entire file,
-avoiding backtracing."
+avoiding backtracing. Refile target collection makes use of that."
(if fastp
(progn
(if (> level 19)
@@ -9025,7 +10020,7 @@ avoiding backtracing."
(prog1
(delq nil (append org-olpa nil))
(aset org-olpa level heading)))
- (let (rtn)
+ (let (rtn case-fold-search)
(save-excursion
(save-restriction
(widen)
@@ -9035,7 +10030,7 @@ avoiding backtracing."
rtn)))))
(defun org-format-outline-path (path &optional width prefix)
- "Format the outlie path PATH for display.
+ "Format the outline path PATH for display.
Width is the maximum number of characters that is available.
Prefix is a prefix to be included in the returned string,
such as the file name."
@@ -9075,8 +10070,9 @@ such as the file name."
(defun org-display-outline-path (&optional file current)
"Display the current outline path in the echo area."
(interactive "P")
- (let ((bfn (buffer-file-name (buffer-base-buffer)))
- (path (and (org-mode-p) (org-get-outline-path))))
+ (let* ((bfn (buffer-file-name (buffer-base-buffer)))
+ (case-fold-search nil)
+ (path (and (org-mode-p) (org-get-outline-path))))
(if current (setq path (append path
(save-excursion
(org-back-to-heading t)
@@ -9096,6 +10092,7 @@ such as the file name."
Note that this is still *before* the stuff will be removed from
the *old* location.")
+(defvar org-capture-last-stored-marker)
(defun org-refile (&optional goto default-buffer rfloc)
"Move the entry at point to another heading.
The list of target headings is compiled using the information in
@@ -9107,113 +10104,130 @@ Depending on `org-reverse-note-order', the new subitem will either be the
first or the last subitem.
If there is an active region, all entries in that region will be moved.
-However, the region must fulfil the requirement that the first heading
+However, the region must fulfill the requirement that the first heading
is the first one sets the top-level of the moved text - at most siblings
below it are allowed.
With prefix arg GOTO, the command will only visit the target location,
not actually move anything.
-With a double prefix `C-u C-u', go to the location where the last refiling
+With a double prefix arg \\[universal-argument] \\[universal-argument], \
+go to the location where the last refiling
operation has put the subtree.
With a prefix argument of `2', refile to the running clock.
RFLOC can be a refile location obtained in a different way.
-See also `org-refile-use-outline-path' and `org-completion-use-ido'"
+See also `org-refile-use-outline-path' and `org-completion-use-ido'.
+
+If you are using target caching (see `org-refile-use-cache'),
+You have to clear the target cache in order to find new targets.
+This can be done with a 0 prefix: `C-0 C-c C-w'"
(interactive "P")
- (let* ((cbuf (current-buffer))
- (regionp (org-region-active-p))
- (region-start (and regionp (region-beginning)))
- (region-end (and regionp (region-end)))
- (region-length (and regionp (- region-end region-start)))
- (filename (buffer-file-name (buffer-base-buffer cbuf)))
- pos it nbuf file re level reversed)
- (setq last-command nil)
- (when regionp
- (goto-char region-start)
- (or (bolp) (goto-char (point-at-bol)))
- (setq region-start (point))
- (unless (org-kill-is-subtree-p
- (buffer-substring region-start region-end))
- (error "The region is not a (sequence of) subtree(s)")))
- (if (equal goto '(16))
- (org-refile-goto-last-stored)
- (when (or
- (and (equal goto 2)
- org-clock-hd-marker (marker-buffer org-clock-hd-marker)
- (prog1
- (setq it (list (or org-clock-heading "running clock")
- (buffer-file-name
- (marker-buffer org-clock-hd-marker))
- ""
- (marker-position org-clock-hd-marker)))
- (setq goto nil)))
- (setq it (or rfloc
- (save-excursion
- (org-refile-get-location
- (if goto "Goto: " "Refile to: ") default-buffer
- org-refile-allow-creating-parent-nodes)))))
- (setq file (nth 1 it)
- re (nth 2 it)
- pos (nth 3 it))
- (if (and (not goto)
- pos
- (equal (buffer-file-name) file)
- (if regionp
- (and (>= pos region-start)
- (<= pos region-end))
- (and (>= pos (point))
- (< pos (save-excursion
- (org-end-of-subtree t t))))))
- (error "Cannot refile to position inside the tree or region"))
-
- (setq nbuf (or (find-buffer-visiting file)
- (find-file-noselect file)))
- (if goto
- (progn
- (switch-to-buffer nbuf)
- (goto-char pos)
- (org-show-context 'org-goto))
- (if regionp
+ (if (member goto '(0 (64)))
+ (org-refile-cache-clear)
+ (let* ((cbuf (current-buffer))
+ (regionp (org-region-active-p))
+ (region-start (and regionp (region-beginning)))
+ (region-end (and regionp (region-end)))
+ (region-length (and regionp (- region-end region-start)))
+ (filename (buffer-file-name (buffer-base-buffer cbuf)))
+ pos it nbuf file re level reversed)
+ (setq last-command nil)
+ (when regionp
+ (goto-char region-start)
+ (or (bolp) (goto-char (point-at-bol)))
+ (setq region-start (point))
+ (unless (org-kill-is-subtree-p
+ (buffer-substring region-start region-end))
+ (error "The region is not a (sequence of) subtree(s)")))
+ (if (equal goto '(16))
+ (org-refile-goto-last-stored)
+ (when (or
+ (and (equal goto 2)
+ org-clock-hd-marker (marker-buffer org-clock-hd-marker)
+ (prog1
+ (setq it (list (or org-clock-heading "running clock")
+ (buffer-file-name
+ (marker-buffer org-clock-hd-marker))
+ ""
+ (marker-position org-clock-hd-marker)))
+ (setq goto nil)))
+ (setq it (or rfloc
+ (save-excursion
+ (org-refile-get-location
+ (if goto "Goto: " "Refile to: ") default-buffer
+ org-refile-allow-creating-parent-nodes)))))
+ (setq file (nth 1 it)
+ re (nth 2 it)
+ pos (nth 3 it))
+ (if (and (not goto)
+ pos
+ (equal (buffer-file-name) file)
+ (if regionp
+ (and (>= pos region-start)
+ (<= pos region-end))
+ (and (>= pos (point))
+ (< pos (save-excursion
+ (org-end-of-subtree t t))))))
+ (error "Cannot refile to position inside the tree or region"))
+
+ (setq nbuf (or (find-buffer-visiting file)
+ (find-file-noselect file)))
+ (if goto
(progn
- (org-kill-new (buffer-substring region-start region-end))
- (org-save-markers-in-region region-start region-end))
- (org-copy-subtree 1 nil t))
- (with-current-buffer (setq nbuf (or (find-buffer-visiting file)
- (find-file-noselect file)))
- (setq reversed (org-notes-order-reversed-p))
- (save-excursion
- (save-restriction
- (widen)
- (if pos
- (progn
- (goto-char pos)
- (looking-at outline-regexp)
- (setq level (org-get-valid-level (funcall outline-level) 1))
- (goto-char
- (if reversed
- (or (outline-next-heading) (point-max))
- (or (save-excursion (org-get-next-sibling))
- (org-end-of-subtree t t)
- (point-max)))))
- (setq level 1)
- (if (not reversed)
- (goto-char (point-max))
- (goto-char (point-min))
- (or (outline-next-heading) (goto-char (point-max)))))
- (if (not (bolp)) (newline))
- (bookmark-set "org-refile-last-stored")
- (org-paste-subtree level)
- (if (fboundp 'deactivate-mark) (deactivate-mark))
- (run-hooks 'org-after-refile-insert-hook))))
- (if regionp
- (delete-region (point) (+ (point) region-length))
- (org-cut-subtree))
- (when (featurep 'org-inlinetask)
- (org-inlinetask-remove-END-maybe))
- (setq org-markers-to-move nil)
- (message "Refiled to \"%s\"" (car it))))))
- (org-reveal))
+ (switch-to-buffer nbuf)
+ (goto-char pos)
+ (org-show-context 'org-goto))
+ (if regionp
+ (progn
+ (org-kill-new (buffer-substring region-start region-end))
+ (org-save-markers-in-region region-start region-end))
+ (org-copy-subtree 1 nil t))
+ (with-current-buffer (setq nbuf (or (find-buffer-visiting file)
+ (find-file-noselect file)))
+ (setq reversed (org-notes-order-reversed-p))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (if pos
+ (progn
+ (goto-char pos)
+ (looking-at outline-regexp)
+ (setq level (org-get-valid-level (funcall outline-level) 1))
+ (goto-char
+ (if reversed
+ (or (outline-next-heading) (point-max))
+ (or (save-excursion (org-get-next-sibling))
+ (org-end-of-subtree t t)
+ (point-max)))))
+ (setq level 1)
+ (if (not reversed)
+ (goto-char (point-max))
+ (goto-char (point-min))
+ (or (outline-next-heading) (goto-char (point-max)))))
+ (if (not (bolp)) (newline))
+ (org-paste-subtree level)
+ (when org-log-refile
+ (org-add-log-setup 'refile nil nil 'findpos
+ org-log-refile)
+ (unless (eq org-log-refile 'note)
+ (save-excursion (org-add-log-note))))
+ (and org-auto-align-tags (org-set-tags nil t))
+ (bookmark-set "org-refile-last-stored")
+ ;; If we are refiling for capture, make sure that the
+ ;; last-capture pointers point here
+ (when (org-bound-and-true-p org-refile-for-capture)
+ (bookmark-set "org-capture-last-stored-marker")
+ (move-marker org-capture-last-stored-marker (point)))
+ (if (fboundp 'deactivate-mark) (deactivate-mark))
+ (run-hooks 'org-after-refile-insert-hook))))
+ (if regionp
+ (delete-region (point) (+ (point) region-length))
+ (org-cut-subtree))
+ (when (featurep 'org-inlinetask)
+ (org-inlinetask-remove-END-maybe))
+ (setq org-markers-to-move nil)
+ (message "Refiled to \"%s\" in file %s" (car it) file)))))))
(defun org-refile-goto-last-stored ()
"Go to the location where the last refile was stored."
@@ -9253,6 +10267,7 @@ See also `org-refile-use-outline-path' and `org-completion-use-ido'"
(setq answ (funcall cfunc prompt tbl nil (not new-nodes)
nil 'org-refile-history))
(setq pa (or (assoc answ tbl) (assoc (concat answ "/") tbl)))
+ (org-refile-check-position pa)
(if pa
(progn
(when (or (not org-refile-history)
@@ -9265,15 +10280,39 @@ See also `org-refile-use-outline-path' and `org-completion-use-ido'"
(if (equal (car org-refile-history) (nth 1 org-refile-history))
(pop org-refile-history)))
pa)
- (when (string-match "\\`\\(.*\\)/\\([^/]+\\)\\'" answ)
- (setq parent (match-string 1 answ)
- child (match-string 2 answ))
- (setq parent-target (or (assoc parent tbl) (assoc (concat parent "/") tbl)))
- (when (and parent-target
- (or (eq new-nodes t)
- (and (eq new-nodes 'confirm)
- (y-or-n-p (format "Create new node \"%s\"? " child)))))
- (org-refile-new-child parent-target child))))))
+ (if (string-match "\\`\\(.*\\)/\\([^/]+\\)\\'" answ)
+ (progn
+ (setq parent (match-string 1 answ)
+ child (match-string 2 answ))
+ (setq parent-target (or (assoc parent tbl)
+ (assoc (concat parent "/") tbl)))
+ (when (and parent-target
+ (or (eq new-nodes t)
+ (and (eq new-nodes 'confirm)
+ (y-or-n-p (format "Create new node \"%s\"? "
+ child)))))
+ (org-refile-new-child parent-target child)))
+ (error "Invalid target location")))))
+
+(defun org-refile-check-position (refile-pointer)
+ "Check if the refile pointer matches the readline to which it points."
+ (let* ((file (nth 1 refile-pointer))
+ (re (nth 2 refile-pointer))
+ (pos (nth 3 refile-pointer))
+ buffer)
+ (when (org-string-nw-p re)
+ (setq buffer (if (markerp pos)
+ (marker-buffer pos)
+ (or (find-buffer-visiting file)
+ (find-file-noselect file))))
+ (with-current-buffer buffer
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char pos)
+ (beginning-of-line 1)
+ (unless (org-looking-at-p re)
+ (error "Invalid refile position, please rebuild the cache"))))))))
(defun org-refile-new-child (parent-target child)
"Use refile target PARENT-TARGET to add new CHILD below it."
@@ -9398,16 +10437,15 @@ the property list including an extra property :name with the block name."
(defun org-map-dblocks (&optional command)
"Apply COMMAND to all dynamic blocks in the current buffer.
If COMMAND is not given, use `org-update-dblock'."
- (let ((cmd (or command 'org-update-dblock))
- pos)
+ (let ((cmd (or command 'org-update-dblock)))
(save-excursion
(goto-char (point-min))
(while (re-search-forward org-dblock-start-re nil t)
- (goto-char (setq pos (match-beginning 0)))
- (condition-case nil
- (funcall cmd)
- (error (message "Error during update of dynamic block")))
- (goto-char pos)
+ (goto-char (match-beginning 0))
+ (save-excursion
+ (condition-case nil
+ (funcall cmd)
+ (error (message "Error during update of dynamic block"))))
(unless (re-search-forward org-dblock-end-re nil t)
(error "Dynamic block not terminated"))))))
@@ -9423,7 +10461,7 @@ blocks in the buffer."
(org-update-dblock)))
(defun org-update-dblock ()
- "Update the dynamic block at point
+ "Update the dynamic block at point.
This means to empty the block, parse for parameters and then call
the correct writing function."
(save-window-excursion
@@ -9476,7 +10514,8 @@ This function can be used in a hook."
(defconst org-additional-option-like-keywords
'("BEGIN_HTML" "END_HTML" "HTML:" "ATTR_HTML"
"BEGIN_DocBook" "END_DocBook" "DocBook:" "ATTR_DocBook"
- "BEGIN_LaTeX" "END_LaTeX" "LaTeX:" "LATEX_HEADER:" "LATEX_CLASS:" "ATTR_LaTeX"
+ "BEGIN_LaTeX" "END_LaTeX" "LaTeX:" "LATEX_HEADER:"
+ "LATEX_CLASS:" "LATEX_CLASS_OPTIONS:" "ATTR_LaTeX"
"BEGIN:" "END:"
"ORGTBL" "TBLFM:" "TBLNAME:"
"BEGIN_EXAMPLE" "END_EXAMPLE"
@@ -9484,7 +10523,7 @@ This function can be used in a hook."
"BEGIN_VERSE" "END_VERSE"
"BEGIN_CENTER" "END_CENTER"
"BEGIN_SRC" "END_SRC"
- "CATEGORY" "COLUMNS"
+ "CATEGORY" "COLUMNS" "PROPERTY"
"CAPTION" "LABEL"
"SETUPFILE"
"BIND"
@@ -9517,12 +10556,12 @@ This function can be used in a hook."
)
"Structure completion elements.
This is a list of abbreviation keys and values. The value gets inserted
-it you type @samp{.} followed by the key and then the completion key,
+if you type `<' followed by the key and then press the completion key,
usually `M-TAB'. %file will be replaced by a file name after prompting
for the file using completion.
There are two templates for each key, the first uses the original Org syntax,
the second uses Emacs Muse-like syntax tags. These Muse-like tags become
-the default when the /org-mtags.el/ module has been loaded. See also the
+the default when the /org-mtags.el/ module has been loaded. See also the
variable `org-mtags-prefer-muse-templates'.
This is an experimental feature, it is undecided if it is going to stay in."
:group 'org-completion
@@ -9588,7 +10627,7 @@ At all other locations, this simply calls the value of
(let* ((a nil)
(end (point))
(beg1 (save-excursion
- (skip-chars-backward (org-re "[:alnum:]_@"))
+ (skip-chars-backward (org-re "[:alnum:]_@#%"))
(point)))
(beg (save-excursion
(skip-chars-backward "a-zA-Z0-9_:$")
@@ -9603,8 +10642,10 @@ At all other locations, this simply calls the value of
(throw 'exit t)))
(tag (and (equal (char-before beg1) ?:)
(equal (char-after (point-at-bol)) ?*)))
- (prop (and (equal (char-before beg1) ?:)
- (not (equal (char-after (point-at-bol)) ?*))))
+ (prop (or (and (equal (char-before beg1) ?:)
+ (not (equal (char-after (point-at-bol)) ?*)))
+ (string-match "^#\\+PROPERTY:.*"
+ (buffer-substring (point-at-bol) (point)))))
(texp (equal (char-before beg) ?\\))
(link (equal (char-before beg) ?\[))
(opt (equal (buffer-substring (max (point-at-bol) (- beg 2))
@@ -9636,7 +10677,7 @@ At all other locations, this simply calls the value of
org-link-abbrev-alist))
(texp
(setq type :tex)
- org-html-entities)
+ (append org-entities-user org-entities))
((string-match "\\`\\*+[ \t]+\\'"
(buffer-substring (point-at-bol) beg))
(setq type :todo)
@@ -9681,7 +10722,10 @@ At all other locations, this simply calls the value of
(delete-window (get-buffer-window "*Completions*")))
(if (assoc completion table)
(if (eq type :todo) (insert " ")
- (if (memq type '(:tag :prop)) (insert ":"))))
+ (if (and (memq type '(:tag :prop))
+ (not (string-match "^#[ \t]*\\+property:"
+ (org-current-line-string t))))
+ (insert ":"))))
(if (and (equal type :opt) (assoc completion table))
(message "%s" (substitute-command-keys
"Press \\[org-complete] again to insert example settings"))))
@@ -9719,38 +10763,15 @@ this is nil.")
(defvar org-setting-tags nil) ; dynamically skipped
-(defun org-parse-local-options (string var)
- "Parse STRING for startup setting relevant for variable VAR."
- (let ((rtn (symbol-value var))
- e opts)
- (save-match-data
- (if (or (not string) (not (string-match "\\S-" string)))
- rtn
- (setq opts (delq nil (mapcar (lambda (x)
- (setq e (assoc x org-startup-options))
- (if (eq (nth 1 e) var) e nil))
- (org-split-string string "[ \t]+"))))
- (if (not opts)
- rtn
- (setq rtn nil)
- (while (setq e (pop opts))
- (if (not (nth 3 e))
- (setq rtn (nth 2 e))
- (if (not (listp rtn)) (setq rtn nil))
- (push (nth 2 e) rtn)))
- rtn)))))
-
(defvar org-todo-setup-filter-hook nil
"Hook for functions that pre-filter todo specs.
-
-Each function takes a todo spec and returns either `nil' or the spec
+Each function takes a todo spec and returns either nil or the spec
transformed into canonical form." )
(defvar org-todo-get-default-hook nil
"Hook for functions that get a default item for todo.
-
Each function takes arguments (NEW-MARK OLD-MARK) and returns either
-`nil' or a string to be used for the todo mark." )
+nil or a string to be used for the todo mark." )
(defvar org-agenda-headline-snapshot-before-repeat)
@@ -9767,10 +10788,12 @@ So for this example: when the item starts with TODO, it is changed to DONE.
When it starts with DONE, the DONE is removed. And when neither TODO nor
DONE are present, add TODO at the beginning of the heading.
-With C-u prefix arg, use completion to determine the new state.
+With \\[universal-argument] prefix arg, use completion to determine the new \
+state.
With numeric prefix arg, switch to that state.
-With a double C-u prefix, switch to the next set of TODO keywords (nextset).
-With a triple C-u prefix, circumvent any state blocking.
+With a double \\[universal-argument] prefix, switch to the next set of TODO \
+keywords (nextset).
+With a triple \\[universal-argument] prefix, circumvent any state blocking.
For calling through lisp, arg is also interpreted in the following way:
'none -> empty state
@@ -9798,7 +10821,7 @@ For calling through lisp, arg is also interpreted in the following way:
(looking-at " *"))
(let* ((match-data (match-data))
(startpos (point-at-bol))
- (logging (save-match-data (org-entry-get nil "LOGGING" t)))
+ (logging (save-match-data (org-entry-get nil "LOGGING" t t)))
(org-log-done org-log-done)
(org-log-repeat org-log-repeat)
(org-todo-log-states org-todo-log-states)
@@ -9980,54 +11003,56 @@ changes. Such blocking occurs when:
3. The parent of the task is blocked because it has siblings that should
be done first, or is child of a block grandparent TODO entry."
- (catch 'dont-block
- ;; If this is not a todo state change, or if this entry is already DONE,
- ;; do not block
- (when (or (not (eq (plist-get change-plist :type) 'todo-state-change))
- (member (plist-get change-plist :from)
- (cons 'done org-done-keywords))
- (member (plist-get change-plist :to)
- (cons 'todo org-not-done-keywords))
- (not (plist-get change-plist :to)))
- (throw 'dont-block t))
- ;; If this task has children, and any are undone, it's blocked
- (save-excursion
- (org-back-to-heading t)
- (let ((this-level (funcall outline-level)))
- (outline-next-heading)
- (let ((child-level (funcall outline-level)))
- (while (and (not (eobp))
- (> child-level this-level))
- ;; this todo has children, check whether they are all
- ;; completed
- (if (and (not (org-entry-is-done-p))
- (org-entry-is-todo-p))
- (throw 'dont-block nil))
- (outline-next-heading)
- (setq child-level (funcall outline-level))))))
- ;; Otherwise, if the task's parent has the :ORDERED: property, and
- ;; any previous siblings are undone, it's blocked
- (save-excursion
- (org-back-to-heading t)
- (let* ((pos (point))
- (parent-pos (and (org-up-heading-safe) (point))))
- (if (not parent-pos) (throw 'dont-block t)) ; no parent
- (when (and (org-entry-get (point) "ORDERED")
- (forward-line 1)
- (re-search-forward org-not-done-heading-regexp pos t))
- (throw 'dont-block nil)) ; block, there is an older sibling not done.
- ;; Search further up the hierarchy, to see if an anchestor is blocked
- (while t
- (goto-char parent-pos)
- (if (not (looking-at org-not-done-heading-regexp))
- (throw 'dont-block t)) ; do not block, parent is not a TODO
- (setq pos (point))
- (setq parent-pos (and (org-up-heading-safe) (point)))
+ (if (not org-enforce-todo-dependencies)
+ t ; if locally turned off don't block
+ (catch 'dont-block
+ ;; If this is not a todo state change, or if this entry is already DONE,
+ ;; do not block
+ (when (or (not (eq (plist-get change-plist :type) 'todo-state-change))
+ (member (plist-get change-plist :from)
+ (cons 'done org-done-keywords))
+ (member (plist-get change-plist :to)
+ (cons 'todo org-not-done-keywords))
+ (not (plist-get change-plist :to)))
+ (throw 'dont-block t))
+ ;; If this task has children, and any are undone, it's blocked
+ (save-excursion
+ (org-back-to-heading t)
+ (let ((this-level (funcall outline-level)))
+ (outline-next-heading)
+ (let ((child-level (funcall outline-level)))
+ (while (and (not (eobp))
+ (> child-level this-level))
+ ;; this todo has children, check whether they are all
+ ;; completed
+ (if (and (not (org-entry-is-done-p))
+ (org-entry-is-todo-p))
+ (throw 'dont-block nil))
+ (outline-next-heading)
+ (setq child-level (funcall outline-level))))))
+ ;; Otherwise, if the task's parent has the :ORDERED: property, and
+ ;; any previous siblings are undone, it's blocked
+ (save-excursion
+ (org-back-to-heading t)
+ (let* ((pos (point))
+ (parent-pos (and (org-up-heading-safe) (point))))
(if (not parent-pos) (throw 'dont-block t)) ; no parent
- (when (and (org-entry-get (point) "ORDERED")
+ (when (and (org-not-nil (org-entry-get (point) "ORDERED"))
(forward-line 1)
(re-search-forward org-not-done-heading-regexp pos t))
- (throw 'dont-block nil))))))) ; block, older sibling not done.
+ (throw 'dont-block nil)) ; block, there is an older sibling not done.
+ ;; Search further up the hierarchy, to see if an anchestor is blocked
+ (while t
+ (goto-char parent-pos)
+ (if (not (looking-at org-not-done-heading-regexp))
+ (throw 'dont-block t)) ; do not block, parent is not a TODO
+ (setq pos (point))
+ (setq parent-pos (and (org-up-heading-safe) (point)))
+ (if (not parent-pos) (throw 'dont-block t)) ; no parent
+ (when (and (org-not-nil (org-entry-get (point) "ORDERED"))
+ (forward-line 1)
+ (re-search-forward org-not-done-heading-regexp pos t))
+ (throw 'dont-block nil)))))))) ; block, older sibling not done.
(defcustom org-track-ordered-property-with-tag nil
"Should the ORDERED property also be shown as a tag?
@@ -10071,30 +11096,44 @@ See variable `org-track-ordered-property-with-tag'."
"Block turning an entry into a TODO, using checkboxes.
This checks whether the current task should be blocked from state
changes because there are unchecked boxes in this entry."
- (catch 'dont-block
- ;; If this is not a todo state change, or if this entry is already DONE,
- ;; do not block
- (when (or (not (eq (plist-get change-plist :type) 'todo-state-change))
- (member (plist-get change-plist :from)
- (cons 'done org-done-keywords))
- (member (plist-get change-plist :to)
- (cons 'todo org-not-done-keywords))
- (not (plist-get change-plist :to)))
- (throw 'dont-block t))
- ;; If this task has checkboxes that are not checked, it's blocked
- (save-excursion
- (org-back-to-heading t)
- (let ((beg (point)) end)
- (outline-next-heading)
- (setq end (point))
- (goto-char beg)
- (if (re-search-forward "^[ \t]*\\([-+*]\\|[0-9]+[.)]\\)[ \t]+\\[[- ]\\]"
- end t)
- (progn
- (if (boundp 'org-blocked-by-checkboxes)
- (setq org-blocked-by-checkboxes t))
- (throw 'dont-block nil)))))
- t)) ; do not block
+ (if (not org-enforce-todo-checkbox-dependencies)
+ t ; if locally turned off don't block
+ (catch 'dont-block
+ ;; If this is not a todo state change, or if this entry is already DONE,
+ ;; do not block
+ (when (or (not (eq (plist-get change-plist :type) 'todo-state-change))
+ (member (plist-get change-plist :from)
+ (cons 'done org-done-keywords))
+ (member (plist-get change-plist :to)
+ (cons 'todo org-not-done-keywords))
+ (not (plist-get change-plist :to)))
+ (throw 'dont-block t))
+ ;; If this task has checkboxes that are not checked, it's blocked
+ (save-excursion
+ (org-back-to-heading t)
+ (let ((beg (point)) end)
+ (outline-next-heading)
+ (setq end (point))
+ (goto-char beg)
+ (if (re-search-forward "^[ \t]*\\([-+*]\\|[0-9]+[.)]\\)[ \t]+\\[[- ]\\]"
+ end t)
+ (progn
+ (if (boundp 'org-blocked-by-checkboxes)
+ (setq org-blocked-by-checkboxes t))
+ (throw 'dont-block nil)))))
+ t))) ; do not block
+
+(defun org-entry-blocked-p ()
+ "Is the current entry blocked?"
+ (if (org-entry-get nil "NOBLOCKING")
+ nil ;; Never block this entry
+ (not
+ (run-hook-with-args-until-failure
+ 'org-blocker-hook
+ (list :type 'todo-state-change
+ :position (point)
+ :from 'todo
+ :to 'done)))))
(defun org-update-statistics-cookies (all)
"Update the statistics cookie, either from TODO or from checkboxes.
@@ -10116,8 +11155,9 @@ This should be called with the cursor in a line with a statistics cookie."
(outline-next-heading)
(if (org-on-heading-p) (setq l2 (org-outline-level)))
(point)))
- (if (and (save-excursion (re-search-forward
- "^[ \t]*[-+*] \\[[- X]\\]" end t))
+ (if (and (save-excursion
+ (re-search-forward
+ "^[ \t]*\\([-+*]\\|[0-9]+[.)]\\) \\[[- X]\\]" end t))
(not (save-excursion (re-search-forward
":COOKIE_DATA:.*\\<todo\\>" end t))))
(org-update-checkbox-count)
@@ -10125,7 +11165,12 @@ This should be called with the cursor in a line with a statistics cookie."
(progn
(goto-char end)
(org-update-parent-todo-statistics))
- (error "No data for statistics cookie"))))
+ (goto-char pos)
+ (beginning-of-line 1)
+ (while (re-search-forward
+ "\\(\\(\\[[0-9]*%\\]\\)\\|\\(\\[[0-9]*/[0-9]*\\]\\)\\)"
+ (point-at-eol) t)
+ (replace-match (if (match-end 2) "[100%]" "[0/0]") t t)))))
(goto-char pos)
(move-marker pos nil)))))
@@ -10397,13 +11442,17 @@ This function is run automatically after each state change to a DONE state."
(msg "Entry repeats: ")
(org-log-done nil)
(org-todo-log-states nil)
- (nshiftmax 10) (nshift 0)
- re type n what ts time)
+ re type n what ts time to-state)
(when repeat
(if (eq org-log-repeat t) (setq org-log-repeat 'state))
- (org-todo (if (eq interpret 'type) last-state head))
- (org-entry-put nil "LAST_REPEAT" (format-time-string
- (org-time-stamp-format t t)))
+ (setq to-state (or (org-entry-get nil "REPEAT_TO_STATE")
+ org-todo-repeat-to-state))
+ (unless (and to-state (member to-state org-todo-keywords-1))
+ (setq to-state (if (eq interpret 'type) last-state head)))
+ (org-todo to-state)
+ (when (or org-log-repeat (org-entry-get nil "CLOCK"))
+ (org-entry-put nil "LAST_REPEAT" (format-time-string
+ (org-time-stamp-format t t))))
(when org-log-repeat
(if (or (memq 'org-add-log-note (default-value 'post-command-hook))
(memq 'org-add-log-note post-command-hook))
@@ -10439,15 +11488,17 @@ This function is run automatically after each state change to a DONE state."
(- (time-to-days (current-time)) (time-to-days time))
'day))
((equal (match-string 1 ts) "+")
- (while (or (= nshift 0)
- (<= (time-to-days time) (time-to-days (current-time))))
- (when (= (incf nshift) nshiftmax)
- (or (y-or-n-p (message "%d repeater intervals were not enough to shift date past today. Continue? " nshift))
- (error "Abort")))
- (org-timestamp-change n (cdr (assoc what whata)))
- (org-at-timestamp-p t)
- (setq ts (match-string 1))
- (setq time (save-match-data (org-time-string-to-time ts))))
+ (let ((nshiftmax 10) (nshift 0))
+ (while (or (= nshift 0)
+ (<= (time-to-days time)
+ (time-to-days (current-time))))
+ (when (= (incf nshift) nshiftmax)
+ (or (y-or-n-p (message "%d repeater intervals were not enough to shift date past today. Continue? " nshift))
+ (error "Abort")))
+ (org-timestamp-change n (cdr (assoc what whata)))
+ (org-at-timestamp-p t)
+ (setq ts (match-string 1))
+ (setq time (save-match-data (org-time-string-to-time ts)))))
(org-timestamp-change (- n) (cdr (assoc what whata)))
;; rematch, so that we have everything in place for the real shift
(org-at-timestamp-p t)
@@ -10488,20 +11539,37 @@ With argument REMOVE, remove any deadline from the item.
When TIME is set, it should be an internal time specification, and the
scheduling will use the corresponding date."
(interactive "P")
- (let ((old-date (org-entry-get nil "DEADLINE")))
+ (let* ((old-date (org-entry-get nil "DEADLINE"))
+ (repeater (and old-date
+ (string-match "\\([.+]+[0-9]+[dwmy]\\) ?" old-date)
+ (match-string 1 old-date))))
(if remove
(progn
+ (when (and old-date org-log-redeadline)
+ (org-add-log-setup 'deldeadline nil old-date 'findpos
+ org-log-redeadline))
(org-remove-timestamp-with-keyword org-deadline-string)
(message "Item no longer has a deadline."))
- (if (org-get-repeat)
- (error "Cannot change deadline on task with repeater, please do that by hand")
- (org-add-planning-info 'deadline time 'closed)
- (when (and old-date org-log-redeadline
- (not (equal old-date
- (substring org-last-inserted-timestamp 1 -1))))
- (org-add-log-setup 'redeadline nil old-date 'findpos
- org-log-redeadline))
- (message "Deadline on %s" org-last-inserted-timestamp)))))
+ (org-add-planning-info 'deadline time 'closed)
+ (when (and old-date org-log-redeadline
+ (not (equal old-date
+ (substring org-last-inserted-timestamp 1 -1))))
+ (org-add-log-setup 'redeadline nil old-date 'findpos
+ org-log-redeadline))
+ (when repeater
+ (save-excursion
+ (org-back-to-heading t)
+ (when (re-search-forward (concat org-deadline-string " "
+ org-last-inserted-timestamp)
+ (save-excursion
+ (outline-next-heading) (point)) t)
+ (goto-char (1- (match-end 0)))
+ (insert " " repeater)
+ (setq org-last-inserted-timestamp
+ (concat (substring org-last-inserted-timestamp 0 -1)
+ " " repeater
+ (substring org-last-inserted-timestamp -1))))))
+ (message "Deadline on %s" org-last-inserted-timestamp))))
(defun org-schedule (&optional remove time)
"Insert the SCHEDULED: string with a timestamp to schedule a TODO item.
@@ -10509,20 +11577,37 @@ With argument REMOVE, remove any scheduling date from the item.
When TIME is set, it should be an internal time specification, and the
scheduling will use the corresponding date."
(interactive "P")
- (let ((old-date (org-entry-get nil "SCHEDULED")))
+ (let* ((old-date (org-entry-get nil "SCHEDULED"))
+ (repeater (and old-date
+ (string-match "\\([.+]+[0-9]+[dwmy]\\) ?" old-date)
+ (match-string 1 old-date))))
(if remove
(progn
+ (when (and old-date org-log-reschedule)
+ (org-add-log-setup 'delschedule nil old-date 'findpos
+ org-log-reschedule))
(org-remove-timestamp-with-keyword org-scheduled-string)
(message "Item is no longer scheduled."))
- (if (org-get-repeat)
- (error "Cannot reschedule task with repeater, please do that by hand")
- (org-add-planning-info 'scheduled time 'closed)
- (when (and old-date org-log-reschedule
- (not (equal old-date
- (substring org-last-inserted-timestamp 1 -1))))
- (org-add-log-setup 'reschedule nil old-date 'findpos
- org-log-reschedule))
- (message "Scheduled to %s" org-last-inserted-timestamp)))))
+ (org-add-planning-info 'scheduled time 'closed)
+ (when (and old-date org-log-reschedule
+ (not (equal old-date
+ (substring org-last-inserted-timestamp 1 -1))))
+ (org-add-log-setup 'reschedule nil old-date 'findpos
+ org-log-reschedule))
+ (when repeater
+ (save-excursion
+ (org-back-to-heading t)
+ (when (re-search-forward (concat org-scheduled-string " "
+ org-last-inserted-timestamp)
+ (save-excursion
+ (outline-next-heading) (point)) t)
+ (goto-char (1- (match-end 0)))
+ (insert " " repeater)
+ (setq org-last-inserted-timestamp
+ (concat (substring org-last-inserted-timestamp 0 -1)
+ " " repeater
+ (substring org-last-inserted-timestamp -1))))))
+ (message "Scheduled to %s" org-last-inserted-timestamp))))
(defun org-get-scheduled-time (pom &optional inherit)
"Get the scheduled time as a time tuple, of a format suitable
@@ -10533,7 +11618,7 @@ returns nil."
(apply 'encode-time (org-parse-time-string time)))))
(defun org-get-deadline-time (pom &optional inherit)
- "Get the deadine as a time tuple, of a format suitable for
+ "Get the deadline as a time tuple, of a format suitable for
calling org-deadline with, or if there is no scheduling, returns
nil."
(let ((time (org-entry-get pom "DEADLINE" inherit)))
@@ -10651,7 +11736,7 @@ be removed."
(end-of-line 1))
(goto-char (point-min))
(widen)
- (if (and (looking-at "[ \t]+\n")
+ (if (and (looking-at "[ \t]*\n")
(equal (char-before) ?\n))
(delete-region (1- (point)) (point-at-eol)))
ts))))))
@@ -10676,7 +11761,7 @@ This is done in the same way as adding a state change note."
(defvar org-property-end-re)
(defun org-add-log-setup (&optional purpose state prev-state
- findpos how &optional extra)
+ findpos how extra)
"Set up the post command hook to take a note.
If this is about to TODO state change, the new state is expected in STATE.
When FINDPOS is non-nil, find the correct position for the note in
@@ -10737,10 +11822,11 @@ EXTRA is additional text that will be inserted into the notes buffer."
(defun org-skip-over-state-notes ()
"Skip past the list of State notes in an entry."
(if (looking-at "\n[ \t]*- State") (forward-char 1))
- (while (looking-at "[ \t]*- State")
- (condition-case nil
- (org-next-item)
- (error (org-end-of-item)))))
+ (when (org-in-item-p)
+ (let ((limit (org-list-bottom-point)))
+ (while (looking-at "[ \t]*- State")
+ (goto-char (or (org-get-next-item (point) limit)
+ (org-get-end-of-item limit)))))))
(defun org-add-log-note (&optional purpose)
"Pop up a window for taking a note, and add this note later at point."
@@ -10766,8 +11852,14 @@ EXTRA is additional text that will be inserted into the notes buffer."
(or org-log-note-state "")))
((eq org-log-note-purpose 'reschedule)
"rescheduling")
+ ((eq org-log-note-purpose 'delschedule)
+ "no longer scheduled")
((eq org-log-note-purpose 'redeadline)
"changing deadline")
+ ((eq org-log-note-purpose 'deldeadline)
+ "removing deadline")
+ ((eq org-log-note-purpose 'refile)
+ "refiling")
((eq org-log-note-purpose 'note)
"this entry")
(t (error "This should not happen")))))
@@ -10779,7 +11871,7 @@ EXTRA is additional text that will be inserted into the notes buffer."
"Finish taking a log note, and insert it to where it belongs."
(let ((txt (buffer-string))
(note (cdr (assq org-log-note-purpose org-log-note-headings)))
- lines ind)
+ lines ind bul)
(kill-buffer (current-buffer))
(while (string-match "\\`#.*\n[ \t\n]*" txt)
(setq txt (replace-match "" t t txt)))
@@ -10795,6 +11887,9 @@ EXTRA is additional text that will be inserted into the notes buffer."
(cons "%t" (format-time-string
(org-time-stamp-format 'long 'inactive)
(current-time)))
+ (cons "%T" (format-time-string
+ (org-time-stamp-format 'long nil)
+ (current-time)))
(cons "%s" (if org-log-note-state
(concat "\"" org-log-note-state "\"")
""))
@@ -10816,13 +11911,26 @@ EXTRA is additional text that will be inserted into the notes buffer."
(move-marker org-log-note-marker nil)
(end-of-line 1)
(if (not (bolp)) (let ((inhibit-read-only t)) (insert "\n")))
- (insert "- " (pop lines))
- (org-indent-line-function)
- (beginning-of-line 1)
- (looking-at "[ \t]*")
- (setq ind (concat (match-string 0) " "))
- (end-of-line 1)
- (while lines (insert "\n" ind (pop lines)))
+ (setq ind (save-excursion
+ (if (org-in-item-p)
+ (progn
+ (goto-char (org-list-top-point))
+ (org-get-indentation))
+ (skip-chars-backward " \r\t\n")
+ (cond
+ ((and (org-at-heading-p)
+ org-adapt-indentation)
+ (1+ (org-current-level)))
+ ((org-at-heading-p) 0)
+ (t (org-get-indentation))))))
+ (setq bul (org-list-bullet-string "-"))
+ (org-indent-line-to ind)
+ (insert bul (pop lines))
+ (let ((ind-body (+ (length bul) ind)))
+ (while lines
+ (insert "\n")
+ (org-indent-line-to ind-body)
+ (insert (pop lines))))
(message "Note stored")
(org-back-to-heading t)
(org-cycle-hide-drawers 'children)))))
@@ -10849,7 +11957,8 @@ POS may also be a marker."
This command can create sparse trees. You first need to select the type
of match used to create the tree:
-t Show entries with a specific TODO keyword.
+t Show all TODO entries.
+T Show entries with a specific TODO keyword.
m Show entries selected by a tags/property match.
p Enter a property name and its value (both with completion on existing
names/values) and show entries with that property.
@@ -10859,7 +11968,7 @@ b Show deadlines and scheduled items before a date.
a Show deadlines and scheduled items after a date."
(interactive "P")
(let (ans kwd value)
- (message "Sparse tree: [/]regexp [t]odo-kwd [m]atch [p]roperty [d]eadlines [b]efore-date [a]fter-date")
+ (message "Sparse tree: [/]regexp [t]odo [T]odo-kwd [m]atch [p]roperty [d]eadlines\n [b]efore-date [a]fter-date")
(setq ans (read-char-exclusive))
(cond
((equal ans ?d)
@@ -10869,6 +11978,8 @@ a Show deadlines and scheduled items after a date."
((equal ans ?a)
(call-interactively 'org-check-after-date))
((equal ans ?t)
+ (org-show-todo-tree nil))
+ ((equal ans ?T)
(org-show-todo-tree '(4)))
((member ans '(?T ?m))
(call-interactively 'org-match-sparse-tree))
@@ -10940,7 +12051,7 @@ that the match should indeed be shown."
cnt))
(defun org-show-context (&optional key)
- "Make sure point and context and visible.
+ "Make sure point and context are visible.
How much context is shown depends upon the variables
`org-show-hierarchy-above', `org-show-following-heading'. and
`org-show-siblings'."
@@ -10971,6 +12082,9 @@ How much context is shown depends upon the variables
(org-flag-heading nil)
(when siblings-p (org-show-siblings))))))))
+(defvar org-reveal-start-hook nil
+ "Hook run before revealing a location.")
+
(defun org-reveal (&optional siblings)
"Show current entry, hierarchy above it, and the following headline.
This can be used to show a consistent set of context around locations
@@ -10979,17 +12093,26 @@ not t for the search context.
With optional argument SIBLINGS, on each level of the hierarchy all
siblings are shown. This repairs the tree structure to what it would
-look like when opened with hierarchical calls to `org-cycle'."
+look like when opened with hierarchical calls to `org-cycle'.
+With double optional argument \\[universal-argument] \\[universal-argument], \
+go to the parent and show the
+entire tree."
(interactive "P")
+ (run-hooks 'org-reveal-start-hook)
(let ((org-show-hierarchy-above t)
(org-show-following-heading t)
(org-show-siblings (if siblings t org-show-siblings)))
- (org-show-context nil)))
+ (org-show-context nil))
+ (when (equal siblings '(16))
+ (save-excursion
+ (when (org-up-heading-safe)
+ (org-show-subtree)
+ (run-hook-with-args 'org-cycle-hook 'subtree)))))
(defun org-highlight-new-match (beg end)
"Highlight from BEG to END and mark the highlight is an occur headline."
- (let ((ov (org-make-overlay beg end)))
- (org-overlay-put ov 'face 'secondary-selection)
+ (let ((ov (make-overlay beg end)))
+ (overlay-put ov 'face 'secondary-selection)
(push ov org-occur-highlights)))
(defun org-remove-occur-highlights (&optional beg end noremove)
@@ -10998,7 +12121,7 @@ BEG and END are ignored. If NOREMOVE is nil, remove this function
from the `before-change-functions' in the current buffer."
(interactive)
(unless org-inhibit-highlight-removal
- (mapc 'org-delete-overlay org-occur-highlights)
+ (mapc 'delete-overlay org-occur-highlights)
(setq org-occur-highlights nil)
(setq org-occur-parameters nil)
(unless noremove
@@ -11045,7 +12168,8 @@ ACTION can be `set', `up', `down', or a character."
(setq new action)
(message "Priority %c-%c, SPC to remove: "
org-highest-priority org-lowest-priority)
- (setq new (read-char-exclusive)))
+ (save-match-data
+ (setq new (read-char-exclusive))))
(if (and (= (upcase org-highest-priority) org-highest-priority)
(= (upcase org-lowest-priority) org-lowest-priority))
(setq new (upcase new)))
@@ -11130,7 +12254,7 @@ only lines with a TODO keyword are included in the output."
(let* ((re (concat "^" outline-regexp " *\\(\\<\\("
(mapconcat 'regexp-quote org-todo-keywords-1 "\\|")
(org-re
- "\\>\\)\\)? *\\(.*?\\)\\(:[[:alnum:]_@:]+:\\)?[ \t]*$")))
+ "\\>\\)\\)? *\\(.*?\\)\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*$")))
(props (list 'face 'default
'done-face 'org-agenda-done
'undone-face 'default
@@ -11330,7 +12454,7 @@ also TODO lines."
;; Parse the string and create a lisp form
(let ((match0 match)
- (re (org-re "^&?\\([-+:]\\)?\\({[^}]+}\\|LEVEL\\([<=>]\\{1,2\\}\\)\\([0-9]+\\)\\|\\([[:alnum:]_]+\\)\\([<>=]\\{1,2\\}\\)\\({[^}]+}\\|\"[^\"]*\"\\|-?[.0-9]+\\(?:[eE][-+]?[0-9]+\\)?\\)\\|[[:alnum:]_@]+\\)"))
+ (re (org-re "^&?\\([-+:]\\)?\\({[^}]+}\\|LEVEL\\([<=>]\\{1,2\\}\\)\\([0-9]+\\)\\|\\(\\(?:[[:alnum:]_]+\\(?:\\\\-\\)*\\)+\\)\\([<>=]\\{1,2\\}\\)\\({[^}]+}\\|\"[^\"]*\"\\|-?[.0-9]+\\(?:[eE][-+]?[0-9]+\\)?\\)\\|[[:alnum:]_@#%]+\\)"))
minus tag mm
tagsmatch todomatch tagsmatcher todomatcher kwd matcher
orterms term orlist re-p str-p level-p level-op time-p
@@ -11358,7 +12482,9 @@ also TODO lines."
(setq rest (substring term (match-end 0))
minus (and (match-end 1)
(equal (match-string 1 term) "-"))
- tag (match-string 2 term)
+ tag (save-match-data (replace-regexp-in-string
+ "\\\\-" "-"
+ (match-string 2 term)))
re-p (equal (string-to-char tag) ?{)
level-p (match-end 4)
prop-p (match-end 5)
@@ -11501,7 +12627,7 @@ epoch to the beginning of today (00:00)."
(delq nil list))
(defvar org-add-colon-after-tag-completion nil) ;; dynamically scoped param
-(defvar org-tags-overlay (org-make-overlay 1 1))
+(defvar org-tags-overlay (make-overlay 1 1))
(org-detach-overlay org-tags-overlay)
(defun org-get-local-tags-at (&optional pos)
@@ -11537,7 +12663,7 @@ ignore inherited ones."
(while (not (equal lastpos (point)))
(setq lastpos (point))
(when (looking-at
- (org-re "[^\r\n]+?:\\([[:alnum:]_@:]+\\):[ \t]*$"))
+ (org-re "[^\r\n]+?:\\([[:alnum:]_@#%:]+\\):[ \t]*$"))
(setq ltags (org-split-string
(org-match-string-no-properties 1) ":"))
(when parent
@@ -11564,7 +12690,7 @@ If ONOFF is `on' or `off', don't toggle but set to this state."
(let (res current)
(save-excursion
(org-back-to-heading t)
- (if (re-search-forward (org-re "[ \t]:\\([[:alnum:]_@:]+\\):[ \t]*$")
+ (if (re-search-forward (org-re "[ \t]:\\([[:alnum:]_@#%:]+\\):[ \t]*$")
(point-at-eol) t)
(progn
(setq current (match-string 1))
@@ -11594,7 +12720,7 @@ If ONOFF is `on' or `off', don't toggle but set to this state."
;; Assumes that this is a headline
(let ((pos (point)) (col (current-column)) ncol tags-l p)
(beginning-of-line 1)
- (if (and (looking-at (org-re ".*?\\([ \t]+\\)\\(:[[:alnum:]_@:]+:\\)[ \t]*$"))
+ (if (and (looking-at (org-re ".*?\\([ \t]+\\)\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$"))
(< pos (match-beginning 2)))
(progn
(setq tags-l (- (match-end 2) (match-beginning 2)))
@@ -11654,6 +12780,17 @@ If DATA is nil or the empty string, any tags will be removed."
(if (looking-at ".*?\\([ \t]+\\)$")
(delete-region (match-beginning 1) (match-end 1))))))
+(defun org-align-all-tags ()
+ "Align the tags i all headings."
+ (interactive)
+ (save-excursion
+ (or (ignore-errors (org-back-to-heading t))
+ (outline-next-heading))
+ (if (org-on-heading-p)
+ (org-set-tags t)
+ (message "No headings"))))
+
+(defvar org-indent-indentation-per-level)
(defun org-set-tags (&optional arg just-align)
"Set the tags for the current headline.
With prefix ARG, realign all tags in headings in the current buffer."
@@ -11663,7 +12800,7 @@ With prefix ARG, realign all tags in headings in the current buffer."
(col (current-column))
(org-setting-tags t)
table current-tags inherited-tags ; computed below when needed
- tags p0 c0 c1 rpl)
+ tags p0 c0 c1 rpl di tc level)
(if arg
(save-excursion
(goto-char (point-min))
@@ -11677,7 +12814,11 @@ With prefix ARG, realign all tags in headings in the current buffer."
;; Get a new set of tags from the user
(save-excursion
(setq table (append org-tag-persistent-alist
- (or org-tag-alist (org-get-buffer-tags)))
+ (or org-tag-alist (org-get-buffer-tags))
+ (and
+ org-complete-tags-always-offer-all-agenda-tags
+ (org-global-tags-completion-table
+ (org-agenda-files))))
org-last-tags-completion-table table
current-tags (org-split-string current ":")
inherited-tags (nreverse
@@ -11689,19 +12830,24 @@ With prefix ARG, realign all tags in headings in the current buffer."
(delq nil (mapcar 'cdr table))))
(org-fast-tag-selection
current-tags inherited-tags table
- (if org-fast-tag-selection-include-todo org-todo-key-alist))
+ (if org-fast-tag-selection-include-todo
+ org-todo-key-alist))
(let ((org-add-colon-after-tag-completion t))
(org-trim
(org-without-partial-completion
- (org-icompleting-read "Tags: " 'org-tags-completion-function
+ (org-icompleting-read "Tags: "
+ 'org-tags-completion-function
nil nil current 'org-tags-history)))))))
(while (string-match "[-+&]+" tags)
;; No boolean logic, just a list
(setq tags (replace-match ":" t t tags))))
+ (setq tags (replace-regexp-in-string "[ ,]" ":" tags))
+
(if org-tags-sort-function
(setq tags (mapconcat 'identity
- (sort (org-split-string tags (org-re "[^[:alnum:]_@]+"))
+ (sort (org-split-string
+ tags (org-re "[^[:alnum:]_@#%]+"))
org-tags-sort-function) ":")))
(if (string-match "\\`[\t ]*\\'" tags)
@@ -11711,6 +12857,9 @@ With prefix ARG, realign all tags in headings in the current buffer."
;; Insert new tags at the correct column
(beginning-of-line 1)
+ (setq level (or (and (looking-at org-outline-regexp)
+ (- (match-end 0) (point) 1))
+ 1))
(cond
((and (equal current "") (equal tags "")))
((re-search-forward
@@ -11719,10 +12868,14 @@ With prefix ARG, realign all tags in headings in the current buffer."
(if (equal tags "")
(setq rpl "")
(goto-char (match-beginning 0))
- (setq c0 (current-column) p0 (point)
- c1 (max (1+ c0) (if (> org-tags-column 0)
- org-tags-column
- (- (- org-tags-column) (length tags))))
+ (setq c0 (current-column)
+ ;; compute offset for the case of org-indent-mode active
+ di (if org-indent-mode
+ (* (1- org-indent-indentation-per-level) (1- level))
+ 0)
+ p0 (if (equal (char-before) ?*) (1+ (point)) (point))
+ tc (+ org-tags-column (if (> org-tags-column 0) (- di) di))
+ c1 (max (1+ c0) (if (> tc 0) tc (- (- tc) (length tags))))
rpl (concat (make-string (max 0 (- c1 c0)) ?\ ) tags)))
(replace-match rpl t t)
(and (not (featurep 'xemacs)) c0 indent-tabs-mode (tabify p0 (point)))
@@ -11774,7 +12927,7 @@ This works in the agenda, and also in an org-mode buffer."
(defun org-tags-completion-function (string predicate &optional flag)
(let (s1 s2 rtn (ctable org-last-tags-completion-table)
(confirm (lambda (x) (stringp (car x)))))
- (if (string-match "^\\(.*[-+:&|]\\)\\([^-+:&|]*\\)$" string)
+ (if (string-match "^\\(.*[-+:&,|]\\)\\([^-+:&,|]*\\)$" string)
(setq s1 (match-string 1 string)
s2 (match-string 2 string))
(setq s1 "" s2 string))
@@ -11822,6 +12975,7 @@ This works in the agenda, and also in an org-mode buffer."
(put-text-property 0 (length s) 'face '(secondary-selection org-tag) s)
(org-overlay-display org-tags-overlay (concat prefix s)))))
+(defvar org-last-tag-selection-key nil)
(defun org-fast-tag-selection (current inherited table &optional todo-table)
"Fast tag selection with single keys.
CURRENT is the current list of tags in the headline, INHERITED is the
@@ -11850,7 +13004,7 @@ Returns the new tags string, or nil to not change the current settings."
(save-excursion
(beginning-of-line 1)
(if (looking-at
- (org-re ".*[ \t]\\(:[[:alnum:]_@:]+:\\)[ \t]*$"))
+ (org-re ".*[ \t]\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$"))
(setq ov-start (match-beginning 1)
ov-end (match-end 1)
ov-prefix "")
@@ -11863,7 +13017,7 @@ Returns the new tags string, or nil to not change the current settings."
(if (> (current-column) org-tags-column)
" "
(make-string (- org-tags-column (current-column)) ?\ ))))))
- (org-move-overlay org-tags-overlay ov-start ov-end)
+ (move-overlay org-tags-overlay ov-start ov-end)
(save-window-excursion
(if expert
(set-buffer (get-buffer-create " *Org tags*"))
@@ -11936,6 +13090,7 @@ Returns the new tags string, or nil to not change the current settings."
(if (not groups) "no " "")
(if expert " [C-c]:window" (if exit-after-next " [C-c]:single" " [C-c]:multi")))
(setq c (let ((inhibit-quit t)) (read-char-exclusive)))
+ (setq org-last-tag-selection-key c)
(cond
((= c ?\r) (throw 'exit t))
((= c ?!)
@@ -11999,7 +13154,7 @@ Returns the new tags string, or nil to not change the current settings."
(org-fast-tag-insert "Current" current c-face)
(org-set-current-tags-overlay current ov-prefix)
(while (re-search-forward
- (org-re "\\[.\\] \\([[:alnum:]_@]+\\)") nil t)
+ (org-re "\\[.\\] \\([[:alnum:]_@#%]+\\)") nil t)
(setq tg (match-string 1))
(add-text-properties
(match-beginning 1) (match-end 1)
@@ -12020,7 +13175,7 @@ Returns the new tags string, or nil to not change the current settings."
(error "Not on a heading"))
(save-excursion
(beginning-of-line 1)
- (if (looking-at (org-re ".*[ \t]\\(:[[:alnum:]_@:]+:\\)[ \t]*$"))
+ (if (looking-at (org-re ".*[ \t]\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$"))
(org-match-string-no-properties 1)
"")))
@@ -12034,7 +13189,7 @@ Returns the new tags string, or nil to not change the current settings."
(save-excursion
(goto-char (point-min))
(while (re-search-forward
- (org-re "[ \t]:\\([[:alnum:]_@:]+\\):[ \t\r\n]") nil t)
+ (org-re "[ \t]:\\([[:alnum:]_@#%:]+\\):[ \t\r\n]") nil t)
(when (equal (char-after (point-at-bol 0)) ?*)
(mapc (lambda (x) (add-to-list 'tags x))
(org-split-string (org-match-string-no-properties 1) ":")))))
@@ -12159,7 +13314,7 @@ a *different* entry, you cannot use these techniques."
(defconst org-special-properties
'("TODO" "TAGS" "ALLTAGS" "DEADLINE" "SCHEDULED" "CLOCK" "CLOSED" "PRIORITY"
- "TIMESTAMP" "TIMESTAMP_IA")
+ "TIMESTAMP" "TIMESTAMP_IA" "BLOCKED")
"The special properties valid in Org-mode.
These are properties that are not defined in the property drawer,
@@ -12170,8 +13325,8 @@ but in some other way.")
"LOCATION" "LOGGING" "COLUMNS" "VISIBILITY"
"TABLE_EXPORT_FORMAT" "TABLE_EXPORT_FILE"
"EXPORT_FILE_NAME" "EXPORT_TITLE" "EXPORT_AUTHOR" "EXPORT_DATE"
- "ORDERED" "NOBLOCKING" "COOKIE_DATA" "LOG_INTO_DRAWER"
- "CLOCK_MODELINE_TOTAL" "STYLE")
+ "ORDERED" "NOBLOCKING" "COOKIE_DATA" "LOG_INTO_DRAWER" "REPEAT_TO_STATE"
+ "CLOCK_MODELINE_TOTAL" "STYLE" "HTML_CONTAINER_CLASS")
"Some properties that are used by Org-mode for various purposes.
Being in this list makes sure that they are offered for completion.")
@@ -12179,7 +13334,7 @@ Being in this list makes sure that they are offered for completion.")
"Regular expression matching the first line of a property drawer.")
(defconst org-property-end-re "^[ \t]*:END:[ \t]*$"
- "Regular expression matching the first line of a property drawer.")
+ "Regular expression matching the last line of a property drawer.")
(defconst org-clock-drawer-start-re "^[ \t]*:CLOCK:[ \t]*$"
"Regular expression matching the first line of a property drawer.")
@@ -12256,13 +13411,15 @@ allowed value."
(message "%s is now %s" prop val)))
(defun org-at-property-p ()
- "Is the cursor in a property line?"
- ;; FIXME: Does not check if we are actually in the drawer.
- ;; FIXME: also returns true on any drawers.....
- ;; This is used by C-c C-c for property action.
+ "Is cursor inside a property drawer?"
(save-excursion
(beginning-of-line 1)
- (looking-at (org-re "^[ \t]*\\(:\\([[:alpha:]][[:alnum:]_-]*\\):\\)[ \t]*\\(.*\\)"))))
+ (when (looking-at (org-re "^[ \t]*\\(:\\([[:alpha:]][[:alnum:]_-]*\\):\\)[ \t]*\\(.*\\)"))
+ (save-match-data ;; Used by calling procedures
+ (let ((p (point))
+ (range (unless (org-before-first-heading-p)
+ (org-get-property-block))))
+ (and range (<= (car range) p) (< p (cdr range))))))))
(defun org-get-property-block (&optional beg end force)
"Return the (beg . end) range of the body of the property drawer.
@@ -12293,7 +13450,7 @@ If the drawer does not exist and FORCE is non-nil, create the drawer."
(insert ":END:\n"))
(cons beg end)))))
-(defun org-entry-properties (&optional pom which)
+(defun org-entry-properties (&optional pom which specific)
"Get all properties of the entry at point-or-marker POM.
This includes the TODO keyword, the tags, time strings for deadline,
scheduled, and clocking, and any additional properties defined in the
@@ -12301,12 +13458,16 @@ entry. The return value is an alist, keys may occur multiple times
if the property key was used several times.
POM may also be nil, in which case the current entry is used.
If WHICH is nil or `all', get all properties. If WHICH is
-`special' or `standard', only get that subclass."
+`special' or `standard', only get that subclass. If WHICH
+is a string only get exactly this property. Specific can be a string, the
+specific property we are interested in. Specifying it can speed
+things up because then unnecessary parsing is avoided."
(setq which (or which 'all))
(org-with-point-at pom
(let ((clockstr (substring org-clock-string 0 -1))
- (excluded '("TODO" "TAGS" "ALLTAGS" "PRIORITY"))
- beg end range props sum-props key value string clocksum)
+ (excluded '("TODO" "TAGS" "ALLTAGS" "PRIORITY" "BLOCKED"))
+ (case-fold-search nil)
+ beg end range props sum-props key key1 value string clocksum)
(save-excursion
(when (condition-case nil
(and (org-mode-p) (org-back-to-heading t))
@@ -12319,31 +13480,53 @@ If WHICH is nil or `all', get all properties. If WHICH is
(when (memq which '(all special))
;; Get the special properties, like TODO and tags
(goto-char beg)
- (when (and (looking-at org-todo-line-regexp) (match-end 2))
+ (when (and (or (not specific) (string= specific "TODO"))
+ (looking-at org-todo-line-regexp) (match-end 2))
(push (cons "TODO" (org-match-string-no-properties 2)) props))
- (when (looking-at org-priority-regexp)
+ (when (and (or (not specific) (string= specific "PRIORITY"))
+ (looking-at org-priority-regexp))
(push (cons "PRIORITY" (org-match-string-no-properties 2)) props))
- (when (and (setq value (org-get-tags-string))
+ (when (and (or (not specific) (string= specific "TAGS"))
+ (setq value (org-get-tags-string))
(string-match "\\S-" value))
(push (cons "TAGS" value) props))
- (when (setq value (org-get-tags-at))
- (push (cons "ALLTAGS" (concat ":" (mapconcat 'identity value ":") ":"))
+ (when (and (or (not specific) (string= specific "ALLTAGS"))
+ (setq value (org-get-tags-at)))
+ (push (cons "ALLTAGS" (concat ":" (mapconcat 'identity value ":")
+ ":"))
props))
- (while (re-search-forward org-maybe-keyword-time-regexp end t)
- (setq key (if (match-end 1) (substring (org-match-string-no-properties 1) 0 -1))
- string (if (equal key clockstr)
- (org-no-properties
- (org-trim
- (buffer-substring
- (match-beginning 3) (goto-char (point-at-eol)))))
- (substring (org-match-string-no-properties 3) 1 -1)))
- (unless key
- (if (= (char-after (match-beginning 3)) ?\[)
- (setq key "TIMESTAMP_IA")
- (setq key "TIMESTAMP")))
- (when (or (equal key clockstr) (not (assoc key props)))
- (push (cons key string) props)))
-
+ (when (or (not specific) (string= specific "BLOCKED"))
+ (push (cons "BLOCKED" (if (org-entry-blocked-p) "t" "")) props))
+ (when (or (not specific)
+ (member specific
+ '("SCHEDULED" "DEADLINE" "CLOCK" "CLOSED"
+ "TIMESTAMP" "TIMESTAMP_IA")))
+ (while (re-search-forward org-maybe-keyword-time-regexp end t)
+ (setq key (if (match-end 1)
+ (substring (org-match-string-no-properties 1)
+ 0 -1))
+ string (if (equal key clockstr)
+ (org-no-properties
+ (org-trim
+ (buffer-substring
+ (match-beginning 3) (goto-char
+ (point-at-eol)))))
+ (substring (org-match-string-no-properties 3)
+ 1 -1)))
+ ;; Get the correct property name from the key. This is
+ ;; necessary if the user has configured time keywords.
+ (setq key1 (concat key ":"))
+ (cond
+ ((not key)
+ (setq key
+ (if (= (char-after (match-beginning 3)) ?\[)
+ "TIMESTAMP_IA" "TIMESTAMP")))
+ ((equal key1 org-scheduled-string) (setq key "SCHEDULED"))
+ ((equal key1 org-deadline-string) (setq key "DEADLINE"))
+ ((equal key1 org-closed-string) (setq key "CLOSED"))
+ ((equal key1 org-clock-string) (setq key "CLOCK")))
+ (when (or (equal key "CLOCK") (not (assoc key props)))
+ (push (cons key string) props))))
)
(when (memq which '(all standard))
@@ -12370,22 +13553,27 @@ If WHICH is nil or `all', get all properties. If WHICH is
(push (cons "CATEGORY" value) props))
(append sum-props (nreverse props)))))))
-(defun org-entry-get (pom property &optional inherit)
+(defun org-entry-get (pom property &optional inherit literal-nil)
"Get value of PROPERTY for entry at point-or-marker POM.
If INHERIT is non-nil and the entry does not have the property,
then also check higher levels of the hierarchy.
If INHERIT is the symbol `selective', use inheritance only if the setting
in `org-use-property-inheritance' selects PROPERTY for inheritance.
If the property is present but empty, the return value is the empty string.
-If the property is not present at all, nil is returned."
+If the property is not present at all, nil is returned.
+
+If LITERAL-NIL is set, return the string value \"nil\" as a string,
+do not interpret it as the list atom nil. This is used for inheritance
+when a \"nil\" value can supersede a non-nil value higher up the hierarchy."
(org-with-point-at pom
(if (and inherit (if (eq inherit 'selective)
(org-property-inherit-p property)
t))
- (org-entry-get-with-inheritance property)
+ (org-entry-get-with-inheritance property literal-nil)
(if (member property org-special-properties)
- ;; We need a special property. Use brute force, get all properties.
- (cdr (assoc property (org-entry-properties nil 'special)))
+ ;; We need a special property. Use `org-entry-properties' to
+ ;; retrieve it, but specify the wanted property
+ (cdr (assoc property (org-entry-properties nil 'special property)))
(let ((range (org-get-property-block)))
(if (and range
(goto-char (car range))
@@ -12394,7 +13582,9 @@ If the property is not present at all, nil is returned."
(cdr range) t))
;; Found the property, return it.
(if (match-end 1)
- (org-match-string-no-properties 1)
+ (if literal-nil
+ (org-match-string-no-properties 1)
+ (org-not-nil (org-match-string-no-properties 1)))
"")))))))
(defun org-property-or-variable-value (var &optional inherit)
@@ -12489,8 +13679,12 @@ no match, the marker will point nowhere.
Note that also `org-entry-get' calls this function, if the INHERIT flag
is set.")
-(defun org-entry-get-with-inheritance (property)
- "Get entry property, and search higher levels if not present."
+(defun org-entry-get-with-inheritance (property &optional literal-nil)
+ "Get entry property, and search higher levels if not present.
+The search will stop at the first ancestor which has the property defined.
+If the value found is \"nil\", return nil to show that the property
+should be considered as undefined (this is the meaning of nil here).
+However, if LITERAL-NIL is set, return the string value \"nil\" instead."
(move-marker org-entry-property-inherited-from nil)
(let (tmp)
(save-excursion
@@ -12498,15 +13692,21 @@ is set.")
(widen)
(catch 'ex
(while t
- (when (setq tmp (org-entry-get nil property))
+ (when (setq tmp (org-entry-get nil property nil 'literal-nil))
(org-back-to-heading t)
(move-marker org-entry-property-inherited-from (point))
(throw 'ex tmp))
(or (org-up-heading-safe) (throw 'ex nil)))))
- (or tmp
- (cdr (assoc property org-file-properties))
- (cdr (assoc property org-global-properties))
- (cdr (assoc property org-global-properties-fixed))))))
+ (setq tmp (or tmp
+ (cdr (assoc property org-file-properties))
+ (cdr (assoc property org-global-properties))
+ (cdr (assoc property org-global-properties-fixed))))
+ (if literal-nil tmp (org-not-nil tmp)))))
+
+(defvar org-property-changed-functions nil
+ "Hook called when the value of a property has changed.
+Each hook function should accept two arguments, the name of the property
+and the new value.")
(defun org-entry-put (pom property value)
"Set PROPERTY to VALUE for entry at point-or-marker POM."
@@ -12560,7 +13760,8 @@ is set.")
(org-indent-line-function)
(insert ":" property ":"))
(and value (insert " " value))
- (org-indent-line-function)))))))
+ (org-indent-line-function)))))
+ (run-hook-with-args 'org-property-changed-functions property value)))
(defun org-buffer-property-keys (&optional include-specials include-defaults include-columns)
"Get all property keys in the current buffer.
@@ -12680,16 +13881,17 @@ in the current file."
keys)))
prop0)))
(cur (org-entry-get nil prop))
+ (prompt (concat prop " value"
+ (if (and cur (string-match "\\S-" cur))
+ (concat " [" cur "]") "") ": "))
(allowed (org-property-get-allowed-values nil prop 'table))
(existing (mapcar 'list (org-property-values prop)))
(val (if allowed
- (org-completing-read "Value: " allowed nil 'req-match)
+ (org-completing-read prompt allowed nil
+ (not (get-text-property 0 'org-unrestricted
+ (caar allowed))))
(let (org-completion-use-ido org-completion-use-iswitchb)
- (org-completing-read
- (concat "Value " (if (and cur (string-match "\\S-" cur))
- (concat "[" cur "]") "")
- ": ")
- existing nil nil "" nil cur)))))
+ (org-completing-read prompt existing nil nil "" nil cur)))))
(list prop (if (equal val "") cur val))))
(unless (equal (org-entry-get nil property) value)
(org-entry-put nil property value)))
@@ -12698,8 +13900,8 @@ in the current file."
"In the current entry, delete PROPERTY."
(interactive
(let* ((completion-ignore-case t)
- (prop (org-icompleting-read
- "Property: " (org-entry-properties nil 'standard))))
+ (prop (org-icompleting-read "Property: "
+ (org-entry-properties nil 'standard))))
(list prop)))
(message "Property %s %s" property
(if (org-entry-delete nil property)
@@ -12741,6 +13943,15 @@ then applies it to the property in the column format's scope."
(error "No operator defined for property %s" prop))
(org-columns-compute prop)))
+(defvar org-property-allowed-value-functions nil
+ "Hook for functions supplying allowed values for a specific property.
+The functions must take a single argument, the name of the property, and
+return a flat list of allowed values. If \":ETC\" is one of
+the values, this means that these values are intended as defaults for
+completion, but that other values should be allowed too.
+The functions must return nil if they are not responsible for this
+property.")
+
(defun org-property-get-allowed-values (pom property &optional table)
"Get allowed values for the property PROPERTY.
When TABLE is non-nil, return an alist that can directly be used for
@@ -12756,9 +13967,10 @@ completion."
(push (char-to-string n) vals)
(setq n (1- n)))))
((member property org-special-properties))
+ ((setq vals (run-hook-with-args-until-success
+ 'org-property-allowed-value-functions property)))
(t
(setq vals (org-entry-get pom (concat property "_ALL") 'inherit))
-
(when (and vals (string-match "\\S-" vals))
(setq vals (car (read-from-string (concat "(" vals ")"))))
(setq vals (mapcar (lambda (x)
@@ -12767,6 +13979,9 @@ completion."
((symbolp x) (symbol-name x))
(t "???")))
vals)))))
+ (when (member ":ETC" vals)
+ (setq vals (remove ":ETC" vals))
+ (org-add-props (car vals) '(org-unrestricted t)))
(if table (mapcar 'list vals) vals)))
(defun org-property-previous-allowed-value (&optional previous)
@@ -12797,7 +14012,89 @@ completion."
(replace-match (concat " :" key ": " nval) t t)
(org-indent-line-function)
(beginning-of-line 1)
- (skip-chars-forward " \t")))
+ (skip-chars-forward " \t")
+ (run-hook-with-args 'org-property-changed-functions key nval)))
+
+(defun org-find-olp (path &optional this-buffer)
+ "Return a marker pointing to the entry at outline path OLP.
+If anything goes wrong, throw an error.
+You can wrap this call to catch the error like this:
+
+ (condition-case msg
+ (org-mobile-locate-entry (match-string 4))
+ (error (nth 1 msg)))
+
+The return value will then be either a string with the error message,
+or a marker if everything is OK.
+
+If THIS-BUFFER is set, the outline path does not contain a file,
+only headings."
+ (let* ((file (if this-buffer buffer-file-name (pop path)))
+ (buffer (if this-buffer (current-buffer) (find-file-noselect file)))
+ (level 1)
+ (lmin 1)
+ (lmax 1)
+ limit re end found pos heading cnt)
+ (unless buffer (error "File not found :%s" file))
+ (with-current-buffer buffer
+ (save-excursion
+ (save-restriction
+ (widen)
+ (setq limit (point-max))
+ (goto-char (point-min))
+ (while (setq heading (pop path))
+ (setq re (format org-complex-heading-regexp-format
+ (regexp-quote heading)))
+ (setq cnt 0 pos (point))
+ (while (re-search-forward re end t)
+ (setq level (- (match-end 1) (match-beginning 1)))
+ (if (and (>= level lmin) (<= level lmax))
+ (setq found (match-beginning 0) cnt (1+ cnt))))
+ (when (= cnt 0) (error "Heading not found on level %d: %s"
+ lmax heading))
+ (when (> cnt 1) (error "Heading not unique on level %d: %s"
+ lmax heading))
+ (goto-char found)
+ (setq lmin (1+ level) lmax (+ lmin (if org-odd-levels-only 1 0)))
+ (setq end (save-excursion (org-end-of-subtree t t))))
+ (when (org-on-heading-p)
+ (move-marker (make-marker) (point))))))))
+
+(defun org-find-exact-headline-in-buffer (heading &optional buffer pos-only)
+ "Find node HEADING in BUFFER.
+Return a marker to the heading if it was found, or nil if not.
+If POS-ONLY is set, return just the position instead of a marker.
+
+The heading text must match exact, but it may have a TODO keyword,
+a priority cookie and tags in the standard locations."
+ (with-current-buffer (or buffer (current-buffer))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (let (case-fold-search)
+ (if (re-search-forward
+ (format org-complex-heading-regexp-format
+ (regexp-quote heading)) nil t)
+ (if pos-only
+ (match-beginning 0)
+ (move-marker (make-marker) (match-beginning 0)))))))))
+
+(defun org-find-exact-heading-in-directory (heading &optional dir)
+ "Find Org node headline HEADING in all .org files in directory DIR.
+When the target headline is found, return a marker to this location."
+ (let ((files (directory-files (or dir default-directory)
+ nil "\\`[^.#].*\\.org\\'"))
+ file visiting m buffer)
+ (catch 'found
+ (while (setq file (pop files))
+ (message "trying %s" file)
+ (setq visiting (org-find-base-buffer-visiting file))
+ (setq buffer (or visiting (find-file-noselect file)))
+ (setq m (org-find-exact-headline-in-buffer
+ heading buffer))
+ (when (and (not m) (not visiting)) (kill-buffer buffer))
+ (and m (throw 'found m))))))
(defun org-find-entry-with-id (ident)
"Locate the entry that contains the ID property with exact value IDENT.
@@ -12905,8 +14202,8 @@ So these are more for recording a certain time/date."
(interactive "P")
(org-time-stamp arg 'inactive))
-(defvar org-date-ovl (org-make-overlay 1 1))
-(org-overlay-put org-date-ovl 'face 'org-warning)
+(defvar org-date-ovl (make-overlay 1 1))
+(overlay-put org-date-ovl 'face 'org-warning)
(org-detach-overlay org-date-ovl)
(defvar org-ans1) ; dynamically scoped parameter
@@ -12927,10 +14224,15 @@ The prompt will suggest to enter an ISO date, but you can also enter anything
which will at least partially be understood by `parse-time-string'.
Unrecognized parts of the date will default to the current day, month, year,
hour and minute. If this command is called to replace a timestamp at point,
-of to enter the second timestamp of a range, the default time is taken from the
-existing stamp. For example,
+of to enter the second timestamp of a range, the default time is taken
+from the existing stamp. Furthermore, the command prefers the future,
+so if you are giving a date where the year is not given, and the day-month
+combination is already past in the current year, it will assume you
+mean next year. For details, see the manual. A few examples:
+
3-2-5 --> 2003-02-05
feb 15 --> currentyear-02-15
+ 2/15 --> currentyear-02-15
sep 12 9 --> 2009-09-12
12:45 --> today 12:45
22 sept 0:34 --> currentyear-09-22 0:34
@@ -12983,11 +14285,10 @@ user."
(setq def (apply 'encode-time defdecode)
defdecode (decode-time def)))))
(calendar-frame-setup nil)
+ (calendar-setup nil)
(calendar-move-hook nil)
(calendar-view-diary-initially-flag nil)
- (view-diary-entries-initially nil)
(calendar-view-holidays-initially-flag nil)
- (view-calendar-holidays-initially nil)
(timestr (format-time-string
(if with-time "%Y-%m-%d %H:%M" "%Y-%m-%d") def))
(prompt (concat (if prompt (concat prompt " ") "")
@@ -13008,10 +14309,8 @@ user."
(map (copy-keymap calendar-mode-map))
(minibuffer-local-map (copy-keymap minibuffer-local-map)))
(org-defkey map (kbd "RET") 'org-calendar-select)
- (org-defkey map (if (featurep 'xemacs) [button1] [mouse-1])
- 'org-calendar-select-mouse)
- (org-defkey map (if (featurep 'xemacs) [button2] [mouse-2])
- 'org-calendar-select-mouse)
+ (org-defkey map [mouse-1] 'org-calendar-select-mouse)
+ (org-defkey map [mouse-2] 'org-calendar-select-mouse)
(org-defkey minibuffer-local-map [(meta shift left)]
(lambda () (interactive)
(org-eval-in-calendar '(calendar-backward-month 1))))
@@ -13054,6 +14353,14 @@ user."
(org-defkey minibuffer-local-map "<"
(lambda () (interactive)
(org-eval-in-calendar '(scroll-calendar-right 1))))
+ (org-defkey minibuffer-local-map "\C-v"
+ (lambda () (interactive)
+ (org-eval-in-calendar
+ '(calendar-scroll-left-three-months 1))))
+ (org-defkey minibuffer-local-map "\M-v"
+ (lambda () (interactive)
+ (org-eval-in-calendar
+ '(calendar-scroll-right-three-months 1))))
(run-hooks 'org-read-date-minibuffer-setup-hook)
(unwind-protect
(progn
@@ -13068,7 +14375,7 @@ user."
(remove-hook 'post-command-hook 'org-read-date-display)
(use-local-map old-map)
(when org-read-date-overlay
- (org-delete-overlay org-read-date-overlay)
+ (delete-overlay org-read-date-overlay)
(setq org-read-date-overlay nil)))))))
(t ; Naked prompt only
@@ -13076,10 +14383,14 @@ user."
(setq ans (read-string prompt default-input
'org-read-date-history timestr))
(when org-read-date-overlay
- (org-delete-overlay org-read-date-overlay)
+ (delete-overlay org-read-date-overlay)
(setq org-read-date-overlay nil)))))
(setq final (org-read-date-analyze ans def defdecode))
+
+ ;; One round trip to get rid of 34th of August and stuff like that....
+ (setq final (decode-time (apply 'encode-time final)))
+
(setq org-read-date-final-answer ans)
(if to-time
@@ -13098,7 +14409,7 @@ user."
"Display the current date prompt interpretation in the minibuffer."
(when org-read-date-display-live
(when org-read-date-overlay
- (org-delete-overlay org-read-date-overlay))
+ (delete-overlay org-read-date-overlay))
(let ((p (point)))
(end-of-line 1)
(while (not (equal (buffer-substring
@@ -13126,15 +14437,16 @@ user."
(when org-read-date-analyze-futurep
(setq txt (concat txt " (=>F)")))
(setq org-read-date-overlay
- (org-make-overlay (1- (point-at-eol)) (point-at-eol)))
+ (make-overlay (1- (point-at-eol)) (point-at-eol)))
(org-overlay-display org-read-date-overlay txt 'secondary-selection))))
(defun org-read-date-analyze (ans def defdecode)
- "Analyse the combined answer of the date prompt."
+ "Analyze the combined answer of the date prompt."
;; FIXME: cleanup and comment
- (let (delta deltan deltaw deltadef year month day
- hour minute second wday pm h2 m2 tl wday1
- iso-year iso-weekday iso-week iso-year iso-date futurep)
+ (let ((nowdecode (decode-time (current-time)))
+ delta deltan deltaw deltadef year month day
+ hour minute second wday pm h2 m2 tl wday1
+ iso-year iso-weekday iso-week iso-year iso-date futurep kill-year)
(setq org-read-date-analyze-futurep nil)
(when (string-match "\\`[ \t]*\\.[ \t]*\\'" ans)
(setq ans "+0"))
@@ -13149,22 +14461,38 @@ user."
;; If yes, store the info and postpone interpreting it until the rest
;; of the parsing is done
(when (string-match "\\<\\(?:\\([0-9]+\\)-\\)?[wW]\\([0-9]\\{1,2\\}\\)\\(?:-\\([0-6]\\)\\)?\\([ \t]\\|$\\)" ans)
- (setq iso-year (if (match-end 1) (org-small-year-to-year (string-to-number (match-string 1 ans))))
- iso-weekday (if (match-end 3) (string-to-number (match-string 3 ans)))
+ (setq iso-year (if (match-end 1)
+ (org-small-year-to-year
+ (string-to-number (match-string 1 ans))))
+ iso-weekday (if (match-end 3)
+ (string-to-number (match-string 3 ans)))
iso-week (string-to-number (match-string 2 ans)))
(setq ans (replace-match "" t t ans)))
- ;; Help matching ISO dates with single digit month ot day, like 2006-8-11.
+ ;; Help matching ISO dates with single digit month or day, like 2006-8-11.
(when (string-match
"^ *\\(\\([0-9]+\\)-\\)?\\([0-1]?[0-9]\\)-\\([0-3]?[0-9]\\)\\([^-0-9]\\|$\\)" ans)
(setq year (if (match-end 2)
(string-to-number (match-string 2 ans))
- (string-to-number (format-time-string "%Y")))
+ (progn (setq kill-year t)
+ (string-to-number (format-time-string "%Y"))))
month (string-to-number (match-string 3 ans))
day (string-to-number (match-string 4 ans)))
(if (< year 100) (setq year (+ 2000 year)))
(setq ans (replace-match (format "%04d-%02d-%02d\\5" year month day)
t nil ans)))
+ ;; Help matching american dates, like 5/30 or 5/30/7
+ (when (string-match
+ "^ *\\(0?[1-9]\\|1[012]\\)/\\(0?[1-9]\\|[12][0-9]\\|3[01]\\)\\(/\\([0-9]+\\)\\)?\\([^/0-9]\\|$\\)" ans)
+ (setq year (if (match-end 4)
+ (string-to-number (match-string 4 ans))
+ (progn (setq kill-year t)
+ (string-to-number (format-time-string "%Y"))))
+ month (string-to-number (match-string 1 ans))
+ day (string-to-number (match-string 2 ans)))
+ (if (< year 100) (setq year (+ 2000 year)))
+ (setq ans (replace-match (format "%04d-%02d-%02d\\5" year month day)
+ t nil ans)))
;; Help matching am/pm times, because `parse-time-string' does not do that.
;; If there is a time with am/pm, and *no* time without it, we convert
;; so that matching will be successful.
@@ -13207,13 +14535,13 @@ user."
day (or (nth 3 tl) (nth 3 defdecode))
month (or (nth 4 tl)
(if (and org-read-date-prefer-future
- (nth 3 tl) (< (nth 3 tl) (nth 3 defdecode)))
- (prog1 (1+ (nth 4 defdecode)) (setq futurep t))
+ (nth 3 tl) (< (nth 3 tl) (nth 3 nowdecode)))
+ (prog1 (1+ (nth 4 nowdecode)) (setq futurep t))
(nth 4 defdecode)))
- year (or (nth 5 tl)
+ year (or (and (not kill-year) (nth 5 tl))
(if (and org-read-date-prefer-future
- (nth 4 tl) (< (nth 4 tl) (nth 4 defdecode)))
- (prog1 (1+ (nth 5 defdecode)) (setq futurep t))
+ (nth 4 tl) (< (nth 4 tl) (nth 4 nowdecode)))
+ (prog1 (1+ (nth 5 nowdecode)) (setq futurep t))
(nth 5 defdecode)))
hour (or (nth 2 tl) (nth 2 defdecode))
minute (or (nth 1 tl) (nth 1 defdecode))
@@ -13222,14 +14550,14 @@ user."
(when (and (eq org-read-date-prefer-future 'time)
(not (nth 3 tl)) (not (nth 4 tl)) (not (nth 5 tl))
- (equal day (nth 3 defdecode))
- (equal month (nth 4 defdecode))
- (equal year (nth 5 defdecode))
+ (equal day (nth 3 nowdecode))
+ (equal month (nth 4 nowdecode))
+ (equal year (nth 5 nowdecode))
(nth 2 tl)
- (or (< (nth 2 tl) (nth 2 defdecode))
- (and (= (nth 2 tl) (nth 2 defdecode))
+ (or (< (nth 2 tl) (nth 2 nowdecode))
+ (and (= (nth 2 tl) (nth 2 nowdecode))
(nth 1 tl)
- (< (nth 1 tl) (nth 1 defdecode)))))
+ (< (nth 1 tl) (nth 1 nowdecode)))))
(setq day (1+ day)
futurep t))
@@ -13237,6 +14565,7 @@ user."
(cond
(iso-week
;; There was an iso week
+ (require 'cal-iso)
(setq futurep nil)
(setq year (or iso-year year)
day (or iso-weekday wday 1)
@@ -13316,6 +14645,24 @@ DEF-FLAG is t when a double ++ or -- indicates shift relative to
(list delta "d" rel))
(list (* n (if (= dir ?-) -1 1)) what rel)))))
+(defun org-order-calendar-date-args (arg1 arg2 arg3)
+ "Turn a user-specified date into the internal representation.
+The internal representation needed by the calendar is (month day year).
+This is a wrapper to handle the brain-dead convention in calendar that
+user function argument order change dependent on argument order."
+ (if (boundp 'calendar-date-style)
+ (cond
+ ((eq calendar-date-style 'american)
+ (list arg1 arg2 arg3))
+ ((eq calendar-date-style 'european)
+ (list arg2 arg1 arg3))
+ ((eq calendar-date-style 'iso)
+ (list arg2 arg3 arg1)))
+ (with-no-warnings ;; european-calendar-style is obsolete as of version 23.1
+ (if (org-bound-and-true-p european-calendar-style)
+ (list arg2 arg1 arg3)
+ (list arg1 arg2 arg3)))))
+
(defun org-eval-in-calendar (form &optional keepdate)
"Eval FORM in the calendar window and return to current window.
Also, store the cursor date in variable org-ans2."
@@ -13327,7 +14674,7 @@ Also, store the cursor date in variable org-ans2."
(let* ((date (calendar-cursor-to-date))
(time (encode-time 0 0 0 (nth 1 date) (nth 0 date) (nth 2 date))))
(setq org-ans2 (format-time-string "%Y-%m-%d" time))))
- (org-move-overlay org-date-ovl (1- (point)) (1+ (point)) (current-buffer))
+ (move-overlay org-date-ovl (1- (point)) (1+ (point)) (current-buffer))
(select-window sw)
(org-select-frame-set-input-focus sf)))
@@ -13343,7 +14690,7 @@ This is used by `org-read-date' in a temporary keymap for the calendar buffer."
(defun org-insert-time-stamp (time &optional with-hm inactive pre post extra)
"Insert a date stamp for the date given by the internal TIME.
-WITH-HM means, use the stamp format that includes the time of the day.
+WITH-HM means use the stamp format that includes the time of the day.
INACTIVE means use square brackets instead of angular ones, so that the
stamp will not contribute to the agenda.
PRE and POST are optional strings to be inserted before and after the
@@ -13353,7 +14700,6 @@ The command returns the inserted time stamp."
stamp)
(if inactive (setq fmt (concat "[" (substring fmt 1 -1) "]")))
(insert-before-markers (or pre ""))
- (insert-before-markers (setq stamp (format-time-string fmt time)))
(when (listp extra)
(setq extra (car extra))
(if (and (stringp extra)
@@ -13363,9 +14709,8 @@ The command returns the inserted time stamp."
(string-to-number (match-string 2 extra))))
(setq extra nil)))
(when extra
- (backward-char 1)
- (insert-before-markers extra)
- (forward-char 1))
+ (setq fmt (concat (substring fmt 0 -1) extra (substring fmt -1))))
+ (insert-before-markers (setq stamp (format-time-string fmt time)))
(insert-before-markers (or post ""))
(setq org-last-inserted-timestamp stamp)))
@@ -13621,7 +14966,7 @@ days in order to avoid rounding problems."
(defun org-time-string-to-absolute (s &optional daynr prefer show-all)
"Convert a time stamp to an absolute day number.
-If there is a specifyer for a cyclic time stamp, get the closest date to
+If there is a specifier for a cyclic time stamp, get the closest date to
DAYNR.
PREFER and SHOW-ALL are passed through to `org-closest-date'.
the variable date is bound by the calendar when this is called."
@@ -13682,7 +15027,10 @@ D may be an absolute day number, or a calendar-type list (month day year)."
(sleep-for 2))))))
(cond ((stringp result) result)
((and (consp result)
+ (not (consp (cdr result)))
(stringp (cdr result))) (cdr result))
+ ((and (consp result)
+ (stringp (car result))) result)
(result entry)
(t nil))))
@@ -13734,7 +15082,7 @@ When SHOW-ALL is nil, only return the current occurrence of a time stamp."
(if (string-match "\\(\\+[0-9]+\\)\\([dwmy]\\)" change)
(setq dn (string-to-number (match-string 1 change))
dw (cdr (assoc (match-string 2 change) a1)))
- (error "Invalid change specifyer: %s" change))
+ (error "Invalid change specifier: %s" change))
(if (eq dw 'week) (setq dw 'day dn (* 7 dn)))
(cond
((eq dw 'day)
@@ -13780,7 +15128,7 @@ When SHOW-ALL is nil, only return the current occurrence of a time stamp."
(t (if (= cday n1) n1 n2)))))))
(defun org-date-to-gregorian (date)
- "Turn any specification of DATE into a gregorian date for the calendar."
+ "Turn any specification of DATE into a Gregorian date for the calendar."
(cond ((integerp date) (calendar-gregorian-from-absolute date))
((and (listp date) (= (length date) 3)) date)
((stringp date)
@@ -13812,7 +15160,7 @@ If the cursor is on the year, change the year. If it is on the month or
the day, change that.
With prefix ARG, change by that many units."
(interactive "p")
- (org-timestamp-change (prefix-numeric-value arg)))
+ (org-timestamp-change (prefix-numeric-value arg) nil 'updown))
(defun org-timestamp-down (&optional arg)
"Decrease the date item at the cursor by one.
@@ -13820,7 +15168,7 @@ If the cursor is on the year, change the year. If it is on the month or
the day, change that.
With prefix ARG, change by that many units."
(interactive "p")
- (org-timestamp-change (- (prefix-numeric-value arg))))
+ (org-timestamp-change (- (prefix-numeric-value arg)) nil 'updown))
(defun org-timestamp-up-day (&optional arg)
"Increase the date in the time stamp by one day.
@@ -13829,7 +15177,7 @@ With prefix ARG, change that many days."
(if (and (not (org-at-timestamp-p t))
(org-on-heading-p))
(org-todo 'up)
- (org-timestamp-change (prefix-numeric-value arg) 'day)))
+ (org-timestamp-change (prefix-numeric-value arg) 'day 'updown)))
(defun org-timestamp-down-day (&optional arg)
"Decrease the date in the time stamp by one day.
@@ -13838,7 +15186,7 @@ With prefix ARG, change that many days."
(if (and (not (org-at-timestamp-p t))
(org-on-heading-p))
(org-todo 'down)
- (org-timestamp-change (- (prefix-numeric-value arg)) 'day)))
+ (org-timestamp-change (- (prefix-numeric-value arg)) 'day) 'updown))
(defun org-at-timestamp-p (&optional inactive-ok)
"Determine if the cursor is in or at a timestamp."
@@ -13883,7 +15231,7 @@ With prefix ARG, change that many days."
(message "Timestamp is now %sactive"
(if (equal (char-after beg) ?<) "" "in")))))
-(defun org-timestamp-change (n &optional what)
+(defun org-timestamp-change (n &optional what updown)
"Change the date in the time stamp at point.
The date will be changed by N times WHAT. WHAT can be `day', `month',
`year', `minute', `second'. If WHAT is not given, the cursor position
@@ -13914,8 +15262,10 @@ in the timestamp determines what will be changed."
(if (string-match "^.\\{10\\}.*?[0-9]+:[0-9][0-9]" ts)
(setq with-hm t))
(setq time0 (org-parse-time-string ts))
- (when (and (eq org-ts-what 'minute)
- (eq current-prefix-arg nil))
+ (when (and updown
+ (eq org-ts-what 'minute)
+ (not current-prefix-arg))
+ ;; This looks like s-up and s-down. Change by one rounding step.
(setq n (* dm (cond ((> n 0) 1) ((< n 0) -1) (t 0))))
(when (not (= 0 (setq rem (% (nth 1 time0) dm))))
(setcar (cdr time0) (+ (nth 1 time0)
@@ -14012,9 +15362,7 @@ A prefix ARG can be used to force the current date."
(let ((tsr org-ts-regexp) diff
(calendar-move-hook nil)
(calendar-view-holidays-initially-flag nil)
- (view-calendar-holidays-initially nil)
- (calendar-view-diary-initially-flag nil)
- (view-diary-entries-initially nil))
+ (calendar-view-diary-initially-flag nil))
(if (or (org-at-timestamp-p)
(save-excursion
(beginning-of-line 1)
@@ -14104,21 +15452,31 @@ changes from another. I believe the procedure must be like this:
;;;; Agenda files
;;;###autoload
-(defun org-iswitchb (&optional arg)
- "Use `org-icompleting-read' to prompt for an Org buffer to switch to.
+(defun org-switchb (&optional arg)
+ "Switch between Org buffers.
With a prefix argument, restrict available to files.
-With two prefix arguments, restrict available buffers to agenda files."
+With two prefix arguments, restrict available buffers to agenda files.
+
+Defaults to `iswitchb' for buffer name completion.
+Set `org-completion-use-ido' to make it use ido instead."
(interactive "P")
(let ((blist (cond ((equal arg '(4)) (org-buffer-list 'files))
((equal arg '(16)) (org-buffer-list 'agenda))
- (t (org-buffer-list)))))
+ (t (org-buffer-list))))
+ (org-completion-use-iswitchb org-completion-use-iswitchb)
+ (org-completion-use-ido org-completion-use-ido))
+ (unless (or org-completion-use-ido org-completion-use-iswitchb)
+ (setq org-completion-use-iswitchb t))
(switch-to-buffer
(org-icompleting-read "Org buffer: "
- (mapcar 'list (mapcar 'buffer-name blist))
- nil t))))
+ (mapcar 'list (mapcar 'buffer-name blist))
+ nil t))))
+;;; Define some older names previously used for this functionality
+;;;###autoload
+(defalias 'org-ido-switchb 'org-switchb)
;;;###autoload
-(defalias 'org-ido-switchb 'org-iswitchb)
+(defalias 'org-iswitchb 'org-switchb)
(defun org-buffer-list (&optional predicate exclude-tmp)
"Return a list of Org buffers.
@@ -14162,7 +15520,7 @@ If EXCLUDE-TMP is non-nil, ignore temporary buffers."
"Get the list of agenda files.
Optional UNRESTRICTED means return the full list even if a restriction
is currently in place.
-When ARCHIVES is t, include all archive files hat are really being
+When ARCHIVES is t, include all archive files that are really being
used by the agenda files. If ARCHIVE is `ifmode', do this only if
`org-agenda-archives-mode' is t."
(let ((files
@@ -14189,6 +15547,13 @@ used by the agenda files. If ARCHIVE is `ifmode', do this only if
(setq files (org-add-archive-files files)))
files))
+(defun org-agenda-file-p (&optional file)
+ "Return non-nil, if FILE is an agenda file.
+If FILE is omitted, use the file associated with the current
+buffer."
+ (member (or file (buffer-file-name))
+ (org-agenda-files t)))
+
(defun org-edit-agenda-file-list ()
"Edit the list of agenda files.
Depending on setup, this either uses customize to edit the variable
@@ -14215,24 +15580,41 @@ the buffer and restores the previous window configuration."
(defun org-store-new-agenda-file-list (list)
"Set new value for the agenda file list and save it correctly."
(if (stringp org-agenda-files)
- (let ((f org-agenda-files) b)
- (while (setq b (find-buffer-visiting f)) (kill-buffer b))
- (with-temp-file f
- (insert (mapconcat 'identity list "\n") "\n")))
+ (let ((fe (org-read-agenda-file-list t)) b u)
+ (while (setq b (find-buffer-visiting org-agenda-files))
+ (kill-buffer b))
+ (with-temp-file org-agenda-files
+ (insert
+ (mapconcat
+ (lambda (f) ;; Keep un-expanded entries.
+ (if (setq u (assoc f fe))
+ (cdr u)
+ f))
+ list "\n")
+ "\n")))
(let ((org-mode-hook nil) (org-inhibit-startup t)
(org-insert-mode-line-in-empty-file nil))
(setq org-agenda-files list)
(customize-save-variable 'org-agenda-files org-agenda-files))))
-(defun org-read-agenda-file-list ()
- "Read the list of agenda files from a file."
+(defun org-read-agenda-file-list (&optional pair-with-expansion)
+ "Read the list of agenda files from a file.
+If PAIR-WITH-EXPANSION is t return pairs with un-expanded
+filenames, used by `org-store-new-agenda-file-list' to write back
+un-expanded file names."
(when (file-directory-p org-agenda-files)
(error "`org-agenda-files' cannot be a single directory"))
(when (stringp org-agenda-files)
(with-temp-buffer
(insert-file-contents org-agenda-files)
- (org-split-string (buffer-string) "[ \t\r\n]*?[\r\n][ \t\r\n]*"))))
-
+ (mapcar
+ (lambda (f)
+ (let ((e (expand-file-name (substitute-in-file-name f)
+ org-directory)))
+ (if pair-with-expansion
+ (cons e f)
+ e)))
+ (org-split-string (buffer-string) "[ \t\r\n]*?[\r\n][ \t\r\n]*")))))
;;;###autoload
(defun org-cycle-agenda-files ()
@@ -14280,7 +15662,7 @@ end of the list."
(defun org-remove-file (&optional file)
"Remove current file from the list of files in variable `org-agenda-files'.
These are the files which are being checked for agenda entries.
-Optional argument FILE means, use this file instead of the current."
+Optional argument FILE means use this file instead of the current."
(interactive)
(let* ((org-agenda-skip-unavailable-files nil)
(file (or file buffer-file-name))
@@ -14382,6 +15764,8 @@ When a buffer is unmodified, it is just killed. When modified, it is saved
(add-text-properties
(match-beginning 0) (org-end-of-subtree t) pc)))
(set-buffer-modified-p bmp)))))
+ (setq org-todo-keywords-for-agenda
+ (org-uniquify org-todo-keywords-for-agenda))
(setq org-todo-keyword-alist-for-agenda
(org-uniquify org-todo-keyword-alist-for-agenda)
org-tag-alist-for-agenda (org-uniquify org-tag-alist-for-agenda))))
@@ -14477,6 +15861,11 @@ looks only before point, not after."
(goto-char pos)
(if dd-on (cons "$$" m))))))
+(defun org-inside-latex-macro-p ()
+ "Is point inside a LaTeX macro or its arguments?"
+ (save-match-data
+ (org-in-regexp
+ "\\\\[a-zA-Z]+\\*?\\(\\(\\[[^][\n{}]*\\]\\)\\|\\({[^{}\n]*}\\)\\)*")))
(defun org-try-cdlatex-tab ()
"Check if it makes sense to execute `cdlatex-tab', and do it if yes.
@@ -14519,7 +15908,7 @@ Revert to the normal definition outside of these fragments."
(defun org-remove-latex-fragment-image-overlays ()
"Remove all overlays with LaTeX fragment images in current buffer."
- (mapc 'org-delete-overlay org-latex-fragment-image-overlays)
+ (mapc 'delete-overlay org-latex-fragment-image-overlays)
(setq org-latex-fragment-image-overlays nil))
(defun org-preview-latex-fragment (&optional subtree)
@@ -14528,7 +15917,8 @@ If the cursor is in a LaTeX fragment, create the image and overlay
it over the source code. If there is no fragment at point, display
all fragments in the current text, from one headline to the next. With
prefix SUBTREE, display all fragments in the current subtree. With a
-double prefix `C-u C-u', or when the cursor is before the first headline,
+double prefix arg \\[universal-argument] \\[universal-argument], or when \
+the cursor is before the first headline,
display all fragments in the buffer.
The images can be removed again with \\[org-ctrl-c-ctrl-c]."
(interactive "P")
@@ -14560,7 +15950,7 @@ The images can be removed again with \\[org-ctrl-c-ctrl-c]."
(concat "ltxpng/" (file-name-sans-extension
(file-name-nondirectory
buffer-file-name)))
- default-directory 'overlays msg at 'forbuffer)
+ default-directory 'overlays msg at 'forbuffer 'dvipng)
(message msg "done. Use `C-c C-c' to remove images.")))))
(defvar org-latex-regexps
@@ -14574,7 +15964,9 @@ The images can be removed again with \\[org-ctrl-c-ctrl-c]."
("$$" "\\$\\$[^\000]*?\\$\\$" 0 nil))
"Regular expressions for matching embedded LaTeX.")
-(defun org-format-latex (prefix &optional dir overlays msg at forbuffer)
+(defvar org-export-have-math nil) ;; dynamic scoping
+(defun org-format-latex (prefix &optional dir overlays msg at
+ forbuffer processing-type)
"Replace LaTeX fragments with links to an image, and produce images.
Some of the options can be changed using the variable
`org-format-latex-options'."
@@ -14585,8 +15977,10 @@ Some of the options can be changed using the variable
(opt org-format-latex-options)
(matchers (plist-get opt :matchers))
(re-list org-latex-regexps)
+ (org-format-latex-header-extra
+ (plist-get (org-infile-export-plist) :latex-header-extra))
(cnt 0) txt hash link beg end re e checkdir
- executables-checked
+ executables-checked string
m n block linkfile movefile ov)
;; Check the different regular expressions
(while (setq e (pop re-list))
@@ -14602,56 +15996,81 @@ Some of the options can be changed using the variable
(not (eq (get-char-property (match-beginning n)
'org-overlay-type)
'org-latex-overlay))))
- (setq txt (match-string n)
- beg (match-beginning n) end (match-end n)
- cnt (1+ cnt)
- link (concat block "[[file:" linkfile "]]" block))
- (let (print-length print-level) ; make sure full list is printed
- (setq hash (sha1 (prin1-to-string
- (list org-format-latex-header
- org-export-latex-packages-alist
- org-format-latex-options
- forbuffer txt)))
- linkfile (format "%s_%s.png" prefix hash)
- movefile (format "%s_%s.png" absprefix hash)))
- (if msg (message msg cnt))
- (goto-char beg)
- (unless checkdir ; make sure the directory exists
- (setq checkdir t)
- (or (file-directory-p todir) (make-directory todir)))
-
- (unless executables-checked
- (org-check-external-command
- "latex" "needed to convert LaTeX fragments to images")
- (org-check-external-command
- "dvipng" "needed to convert LaTeX fragments to images")
- (setq executables-checked t))
-
- (unless (file-exists-p movefile)
- (org-create-formula-image
- txt movefile opt forbuffer))
- (if overlays
- (progn
- (mapc (lambda (o)
- (if (eq (org-overlay-get o 'org-overlay-type)
- 'org-latex-overlay)
- (org-delete-overlay o)))
- (org-overlays-in beg end))
- (setq ov (org-make-overlay beg end))
- (org-overlay-put ov 'org-overlay-type 'org-latex-overlay)
- (if (featurep 'xemacs)
- (progn
- (org-overlay-put ov 'invisible t)
- (org-overlay-put
- ov 'end-glyph
- (make-glyph (vector 'png :file movefile))))
- (org-overlay-put
- ov 'display
- (list 'image :type 'png :file movefile :ascent 'center)))
- (push ov org-latex-fragment-image-overlays)
- (goto-char end))
- (delete-region beg end)
- (insert link))))))))
+ (setq org-export-have-math t)
+ (cond
+ ((eq processing-type 'verbatim)
+ ;; Leave the text verbatim, just protect it
+ (add-text-properties (match-beginning n) (match-end n)
+ '(org-protected t)))
+ ((eq processing-type 'mathjax)
+ ;; Prepare for MathJax processing
+ (setq string (match-string n))
+ (if (member m '("$" "$1"))
+ (save-excursion
+ (delete-region (match-beginning n) (match-end n))
+ (goto-char (match-beginning n))
+ (insert (org-add-props (concat "\\(" (substring string 1 -1)
+ "\\)")
+ '(org-protected t))))
+ (add-text-properties (match-beginning n) (match-end n)
+ '(org-protected t))))
+ ((or (eq processing-type 'dvipng) t)
+ ;; Process to an image
+ (setq txt (match-string n)
+ beg (match-beginning n) end (match-end n)
+ cnt (1+ cnt))
+ (let (print-length print-level) ; make sure full list is printed
+ (setq hash (sha1 (prin1-to-string
+ (list org-format-latex-header
+ org-format-latex-header-extra
+ org-export-latex-default-packages-alist
+ org-export-latex-packages-alist
+ org-format-latex-options
+ forbuffer txt)))
+ linkfile (format "%s_%s.png" prefix hash)
+ movefile (format "%s_%s.png" absprefix hash)))
+ (setq link (concat block "[[file:" linkfile "]]" block))
+ (if msg (message msg cnt))
+ (goto-char beg)
+ (unless checkdir ; make sure the directory exists
+ (setq checkdir t)
+ (or (file-directory-p todir) (make-directory todir t)))
+
+ (unless executables-checked
+ (org-check-external-command
+ "latex" "needed to convert LaTeX fragments to images")
+ (org-check-external-command
+ "dvipng" "needed to convert LaTeX fragments to images")
+ (setq executables-checked t))
+
+ (unless (file-exists-p movefile)
+ (org-create-formula-image
+ txt movefile opt forbuffer))
+ (if overlays
+ (progn
+ (mapc (lambda (o)
+ (if (eq (overlay-get o 'org-overlay-type)
+ 'org-latex-overlay)
+ (delete-overlay o)))
+ (overlays-in beg end))
+ (setq ov (make-overlay beg end))
+ (overlay-put ov 'org-overlay-type 'org-latex-overlay)
+ (if (featurep 'xemacs)
+ (progn
+ (overlay-put ov 'invisible t)
+ (overlay-put
+ ov 'end-glyph
+ (make-glyph (vector 'png :file movefile))))
+ (overlay-put
+ ov 'display
+ (list 'image :type 'png :file movefile :ascent 'center)))
+ (push ov org-latex-fragment-image-overlays)
+ (goto-char end))
+ (delete-region beg end)
+ (insert (org-add-props link
+ (list 'org-latex-src
+ (replace-regexp-in-string
+ "\"" "" txt)))))))))))))
;; This function borrows from Ganesh Swami's latex2png.el
(defun org-create-formula-image (string tofile options buffer)
@@ -14677,17 +16096,14 @@ Some of the options can be changed using the variable
(if (eq fg 'default) (setq fg (org-dvipng-color :foreground)))
(if (eq bg 'default) (setq bg (org-dvipng-color :background)))
(with-temp-file texfile
- (insert org-format-latex-header
- (if org-export-latex-packages-alist
- (concat "\n"
- (mapconcat (lambda(p)
- (if (equal "" (car p))
- (format "\\usepackage{%s}" (cadr p))
- (format "\\usepackage[%s]{%s}"
- (car p) (cadr p))))
- org-export-latex-packages-alist "\n"))
- "")
- "\n\\begin{document}\n" string "\n\\end{document}\n"))
+ (insert (org-splice-latex-header
+ org-format-latex-header
+ org-export-latex-default-packages-alist
+ org-export-latex-packages-alist t
+ org-format-latex-header-extra))
+ (insert "\n\\begin{document}\n" string "\n\\end{document}\n")
+ (require 'org-latex)
+ (org-export-latex-fix-inputenc))
(let ((dir default-directory))
(condition-case nil
(progn
@@ -14707,13 +16123,75 @@ Some of the options can be changed using the variable
dvifile)
(error nil))
(if (not (file-exists-p pngfile))
- (progn (message "Failed to create png file from %s" texfile) nil)
+ (if org-format-latex-signal-error
+ (error "Failed to create png file from %s" texfile)
+ (message "Failed to create png file from %s" texfile)
+ nil)
;; Use the requested file name and clean up
(copy-file pngfile tofile 'replace)
(loop for e in '(".dvi" ".tex" ".aux" ".log" ".png") do
(delete-file (concat texfilebase e)))
pngfile))))
+(defun org-splice-latex-header (tpl def-pkg pkg snippets-p &optional extra)
+ "Fill a LaTeX header template TPL.
+In the template, the following place holders will be recognized:
+
+ [DEFAULT-PACKAGES] \\usepackage statements for DEF-PKG
+ [NO-DEFAULT-PACKAGES] do not include DEF-PKG
+ [PACKAGES] \\usepackage statements for PKG
+ [NO-PACKAGES] do not include PKG
+ [EXTRA] the string EXTRA
+ [NO-EXTRA] do not include EXTRA
+
+For backward compatibility, if both the positive and the negative place
+holder is missing, the positive one (without the \"NO-\") will be
+assumed to be present at the end of the template.
+DEF-PKG and PKG are assumed to be alists of options/packagename lists.
+EXTRA is a string.
+SNIPPETS-P indicates if this is run to create snippet images for HTML."
+ (let (rpl (end ""))
+ (if (string-match "^[ \t]*\\[\\(NO-\\)?DEFAULT-PACKAGES\\][ \t]*\n?" tpl)
+ (setq rpl (if (or (match-end 1) (not def-pkg))
+ "" (org-latex-packages-to-string def-pkg snippets-p t))
+ tpl (replace-match rpl t t tpl))
+ (if def-pkg (setq end (org-latex-packages-to-string def-pkg snippets-p))))
+
+ (if (string-match "\\[\\(NO-\\)?PACKAGES\\][ \t]*\n?" tpl)
+ (setq rpl (if (or (match-end 1) (not pkg))
+ "" (org-latex-packages-to-string pkg snippets-p t))
+ tpl (replace-match rpl t t tpl))
+ (if pkg (setq end
+ (concat end "\n"
+ (org-latex-packages-to-string pkg snippets-p)))))
+
+ (if (string-match "\\[\\(NO-\\)?EXTRA\\][ \t]*\n?" tpl)
+ (setq rpl (if (or (match-end 1) (not extra))
+ "" (concat extra "\n"))
+ tpl (replace-match rpl t t tpl))
+ (if (and extra (string-match "\\S-" extra))
+ (setq end (concat end "\n" extra))))
+
+ (if (string-match "\\S-" end)
+ (concat tpl "\n" end)
+ tpl)))
+
+(defun org-latex-packages-to-string (pkg &optional snippets-p newline)
+ "Turn an alist of packages into a string with the \\usepackage macros."
+ (setq pkg (mapconcat (lambda(p)
+ (cond
+ ((stringp p) p)
+ ((and snippets-p (>= (length p) 3) (not (nth 2 p)))
+ (format "%% Package %s omitted" (cadr p)))
+ ((equal "" (car p))
+ (format "\\usepackage{%s}" (cadr p)))
+ (t
+ (format "\\usepackage[%s]{%s}"
+ (car p) (cadr p)))))
+ pkg
+ "\n"))
+ (if newline (concat pkg "\n") pkg))
+
(defun org-dvipng-color (attr)
"Return an rgb color specification for dvipng."
(apply 'format "rgb %s %s %s"
@@ -14724,6 +16202,80 @@ Some of the options can be changed using the variable
"Return string to be used as color value for an RGB component."
(format "%g" (/ value 65535.0)))
+;; Image display
+
+
+(defvar org-inline-image-overlays nil)
+(make-variable-buffer-local 'org-inline-image-overlays)
+
+(defun org-toggle-inline-images (&optional include-linked)
+ "Toggle the display of inline images.
+INCLUDE-LINKED is passed to `org-display-inline-images'."
+ (interactive "P")
+ (if org-inline-image-overlays
+ (progn
+ (org-remove-inline-images)
+ (message "Inline image display turned off"))
+ (org-display-inline-images include-linked)
+ (if org-inline-image-overlays
+ (message "%d images displayed inline"
+ (length org-inline-image-overlays))
+ (message "No images to display inline"))))
+
+(defun org-display-inline-images (&optional include-linked refresh beg end)
+ "Display inline images.
+Normally only links without a description part are inlined, because this
+is how it will work for export. When INCLUDE-LINKED is set, also links
+with a description part will be inlined. This can be nice for a quick
+look at those images, but it does not reflect what exported files will look
+like.
+When REFRESH is set, refresh existing images between BEG and END.
+This will create new image displays only if necessary.
+BEG and END default to the buffer boundaries."
+ (interactive "P")
+ (unless refresh
+ (org-remove-inline-images)
+ (clear-image-cache))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (setq beg (or beg (point-min)) end (or end (point-max)))
+ (goto-char (point-min))
+ (let ((re (concat "\\[\\[\\(\\(file:\\)\\|\\([./~]\\)\\)\\([^]\n]+?"
+ (substring (org-image-file-name-regexp) 0 -2)
+ "\\)\\]" (if include-linked "" "\\]")))
+ old file ov img)
+ (while (re-search-forward re end t)
+ (setq old (get-char-property-and-overlay (match-beginning 1)
+ 'org-image-overlay))
+ (setq file (expand-file-name
+ (concat (or (match-string 3) "") (match-string 4))))
+ (when (file-exists-p file)
+ (if (and (car-safe old) refresh)
+ (image-refresh (overlay-get (cdr old) 'display))
+ (setq img (save-match-data (create-image file)))
+ (when img
+ (setq ov (make-overlay (match-beginning 0) (match-end 0)))
+ (overlay-put ov 'display img)
+ (overlay-put ov 'face 'default)
+ (overlay-put ov 'org-image-overlay t)
+ (overlay-put ov 'modification-hooks
+ (list 'org-display-inline-modification-hook))
+ (push ov org-inline-image-overlays)))))))))
+
+(defun org-display-inline-modification-hook (ov after beg end &optional len)
+ "Remove inline-display overlay if a corresponding region is modified."
+ (let ((inhibit-modification-hooks t))
+ (when (and ov after)
+ (delete ov org-inline-image-overlays)
+ (delete-overlay ov))))
+
+(defun org-remove-inline-images ()
+ "Remove inline display of images."
+ (interactive)
+ (mapc 'delete-overlay org-inline-image-overlays)
+ (setq org-inline-image-overlays nil))
+
;;;; Key bindings
;; Make `C-c C-x' a prefix key
@@ -14765,6 +16317,12 @@ Some of the options can be changed using the variable
(org-defkey org-mode-map [(control shift right)] 'org-shiftcontrolright)
(org-defkey org-mode-map [(control shift left)] 'org-shiftcontrolleft)
+;; Babel keys
+(define-key org-mode-map org-babel-key-prefix org-babel-map)
+(mapc (lambda (pair)
+ (define-key org-babel-map (car pair) (cdr pair)))
+ org-babel-key-bindings)
+
;;; Extra keys for tty access.
;; We only set them when really needed because otherwise the
;; menus don't show the simple keys
@@ -14822,7 +16380,6 @@ Some of the options can be changed using the variable
(org-defkey org-mode-map "\C-c\C-s" 'org-schedule)
(org-defkey org-mode-map "\C-c\C-d" 'org-deadline)
(org-defkey org-mode-map "\C-c;" 'org-toggle-comment)
-(org-defkey org-mode-map "\C-c\C-v" 'org-show-todo-tree)
(org-defkey org-mode-map "\C-c\C-w" 'org-refile)
(org-defkey org-mode-map "\C-c/" 'org-sparse-tree) ; Minor-mode reserved
(org-defkey org-mode-map "\C-c\\" 'org-match-sparse-tree) ; Minor-mode res.
@@ -14893,16 +16450,20 @@ Some of the options can be changed using the variable
(org-defkey org-mode-map "\C-c\C-x\C-r" 'org-clock-report)
(org-defkey org-mode-map "\C-c\C-x\C-u" 'org-dblock-update)
(org-defkey org-mode-map "\C-c\C-x\C-l" 'org-preview-latex-fragment)
+(org-defkey org-mode-map "\C-c\C-x\C-v" 'org-toggle-inline-images)
+(org-defkey org-mode-map "\C-c\C-x\\" 'org-toggle-pretty-entities)
(org-defkey org-mode-map "\C-c\C-x\C-b" 'org-toggle-checkbox)
(org-defkey org-mode-map "\C-c\C-xp" 'org-set-property)
(org-defkey org-mode-map "\C-c\C-xe" 'org-set-effort)
(org-defkey org-mode-map "\C-c\C-xo" 'org-toggle-ordered-property)
(org-defkey org-mode-map "\C-c\C-xi" 'org-insert-columns-dblock)
(org-defkey org-mode-map [(control ?c) (control ?x) ?\;] 'org-timer-set-timer)
+(org-defkey org-mode-map [(control ?c) (control ?x) ?\:] 'org-timer-cancel-timer)
(org-defkey org-mode-map "\C-c\C-x." 'org-timer)
(org-defkey org-mode-map "\C-c\C-x-" 'org-timer-item)
(org-defkey org-mode-map "\C-c\C-x0" 'org-timer-start)
+(org-defkey org-mode-map "\C-c\C-x_" 'org-timer-stop)
(org-defkey org-mode-map "\C-c\C-x," 'org-timer-pause-or-continue)
(define-key org-mode-map "\C-c\C-x\C-c" 'org-columns)
@@ -14963,6 +16524,8 @@ Some of the options can be changed using the variable
("Misc")
("o" . org-open-at-point)
("?" . org-speed-command-help)
+ ("<" . (org-agenda-set-restriction-lock 'subtree))
+ (">" . (org-agenda-remove-restriction-lock))
)
"The default speed commands.")
@@ -15009,6 +16572,40 @@ If not, return to the original position and throw an error."
(defvar org-table-auto-blank-field) ; defined in org-table.el
(defvar org-speed-command nil)
+
+(defun org-speed-command-default-hook (keys)
+ "Hook for activating single-letter speed commands.
+`org-speed-commands-default' specifies a minimal command set. Use
+`org-speed-commands-user' for further customization."
+ (when (or (and (bolp) (looking-at outline-regexp))
+ (and (functionp org-use-speed-commands)
+ (funcall org-use-speed-commands)))
+ (cdr (assoc keys (append org-speed-commands-user
+ org-speed-commands-default)))))
+
+(defun org-babel-speed-command-hook (keys)
+ "Hook for activating single-letter code block commands."
+ (when (and (bolp) (looking-at org-babel-src-block-regexp))
+ (cdr (assoc keys org-babel-key-bindings))))
+
+(defcustom org-speed-command-hook
+ '(org-speed-command-default-hook org-babel-speed-command-hook)
+ "Hook for activating speed commands at strategic locations.
+Hook functions are called in sequence until a valid handler is
+found.
+
+Each hook takes a single argument, a user-pressed command key
+which is also a `self-insert-command' from the global map.
+
+Within the hook, examine the cursor position and the command key
+and return nil or a valid handler as appropriate. Handler could
+be one of an interactive command, a function, or a form.
+
+Set `org-use-speed-commands' to non-nil value to enable this
+hook. The default setting is `org-speed-command-default-hook'."
+ :group 'org-structure
+ :type 'hook)
+
(defun org-self-insert-command (N)
"Like `self-insert-command', use overwrite-mode for whitespace in tables.
If the cursor is in a table looking at whitespace, the whitespace is
@@ -15016,13 +16613,9 @@ overwritten, and the table is not marked as requiring realignment."
(interactive "p")
(cond
((and org-use-speed-commands
- (or (and (bolp) (looking-at outline-regexp))
- (and (functionp org-use-speed-commands)
- (funcall org-use-speed-commands)))
- (setq
- org-speed-command
- (or (cdr (assoc (this-command-keys) org-speed-commands-user))
- (cdr (assoc (this-command-keys) org-speed-commands-default)))))
+ (setq org-speed-command
+ (run-hook-with-args-until-success
+ 'org-speed-command-hook (this-command-keys))))
(cond
((commandp org-speed-command)
(setq this-command org-speed-command)
@@ -15089,9 +16682,11 @@ because, in this case the deletion might narrow the column."
(noalign (looking-at "[^|\n\r]* |"))
(c org-table-may-need-update))
(backward-delete-char N)
- (skip-chars-forward "^|")
- (insert " ")
- (goto-char (1- pos))
+ (if (not overwrite-mode)
+ (progn
+ (skip-chars-forward "^|")
+ (insert " ")
+ (goto-char (1- pos))))
;; noalign: if there were two spaces at the end, this field
;; does not determine the width of the column.
(if noalign (setq org-table-may-need-update c)))
@@ -15178,8 +16773,9 @@ See `org-ctrl-c-ctrl-c-hook' for more information.
This hook runs as the first action when TAB is pressed, even before
`org-cycle' messes around with the `outline-regexp' to cater for
inline tasks and plain list item folding.
-If any function in this hook returns t, not other actions like table
-field motion visibility cycling will be done.")
+If any function in this hook returns t, any other actions that
+would have been caused by TAB (such as table field motion or visibility
+cycling) will not occur.")
(defvar org-tab-after-check-for-table-hook nil
"Hook for functions to attach themselves to TAB.
@@ -15230,6 +16826,34 @@ See `org-ctrl-c-ctrl-c-hook' for more information.")
(defvar org-metareturn-hook nil
"Hook for functions attaching themselves to `M-RET'.
See `org-ctrl-c-ctrl-c-hook' for more information.")
+(defvar org-shiftup-hook nil
+ "Hook for functions attaching themselves to `S-up'.
+See `org-ctrl-c-ctrl-c-hook' for more information.")
+(defvar org-shiftup-final-hook nil
+ "Hook for functions attaching themselves to `S-up'.
+This one runs after all other options except shift-select have been excluded.
+See `org-ctrl-c-ctrl-c-hook' for more information.")
+(defvar org-shiftdown-hook nil
+ "Hook for functions attaching themselves to `S-down'.
+See `org-ctrl-c-ctrl-c-hook' for more information.")
+(defvar org-shiftdown-final-hook nil
+ "Hook for functions attaching themselves to `S-down'.
+This one runs after all other options except shift-select have been excluded.
+See `org-ctrl-c-ctrl-c-hook' for more information.")
+(defvar org-shiftleft-hook nil
+ "Hook for functions attaching themselves to `S-left'.
+See `org-ctrl-c-ctrl-c-hook' for more information.")
+(defvar org-shiftleft-final-hook nil
+ "Hook for functions attaching themselves to `S-left'.
+This one runs after all other options except shift-select have been excluded.
+See `org-ctrl-c-ctrl-c-hook' for more information.")
+(defvar org-shiftright-hook nil
+ "Hook for functions attaching themselves to `S-right'.
+See `org-ctrl-c-ctrl-c-hook' for more information.")
+(defvar org-shiftright-final-hook nil
+ "Hook for functions attaching themselves to `S-right'.
+This one runs after all other options except shift-select have been excluded.
+See `org-ctrl-c-ctrl-c-hook' for more information.")
(defun org-modifier-cursor-error ()
"Throw an error, a modified cursor command was applied in wrong context."
@@ -15270,7 +16894,7 @@ See the individual commands for more information."
((run-hook-with-args-until-success 'org-shiftmetaleft-hook))
((org-at-table-p) (call-interactively 'org-table-delete-column))
((org-on-heading-p) (call-interactively 'org-promote-subtree))
- ((org-at-item-p) (call-interactively 'org-outdent-item))
+ ((org-at-item-p) (call-interactively 'org-outdent-item-tree))
(t (org-modifier-cursor-error))))
(defun org-shiftmetaright ()
@@ -15283,7 +16907,7 @@ See the individual commands for more information."
((run-hook-with-args-until-success 'org-shiftmetaright-hook))
((org-at-table-p) (call-interactively 'org-table-insert-column))
((org-on-heading-p) (call-interactively 'org-demote-subtree))
- ((org-at-item-p) (call-interactively 'org-indent-item))
+ ((org-at-item-p) (call-interactively 'org-indent-item-tree))
(t (org-modifier-cursor-error))))
(defun org-shiftmetaup (&optional arg)
@@ -15312,6 +16936,10 @@ commands for more information."
((org-at-item-p) (call-interactively 'org-move-item-down))
(t (org-modifier-cursor-error))))
+(defsubst org-hidden-tree-error ()
+ (error
+ "Hidden subtree, open with TAB or use subtree command M-S-<left>/<right>"))
+
(defun org-metaleft (&optional arg)
"Promote heading or move table column to left.
Calls `org-do-promote' or `org-table-move-column', depending on context.
@@ -15326,12 +16954,14 @@ See the individual commands for more information."
(save-excursion
(goto-char (region-beginning))
(org-on-heading-p))))
+ (when (org-check-for-hidden 'headlines) (org-hidden-tree-error))
(call-interactively 'org-do-promote))
((or (org-at-item-p)
(and (org-region-active-p)
(save-excursion
(goto-char (region-beginning))
(org-at-item-p))))
+ (when (org-check-for-hidden 'items) (org-hidden-tree-error))
(call-interactively 'org-outdent-item))
(t (call-interactively 'backward-word))))
@@ -15349,15 +16979,44 @@ See the individual commands for more information."
(save-excursion
(goto-char (region-beginning))
(org-on-heading-p))))
+ (when (org-check-for-hidden 'headlines) (org-hidden-tree-error))
(call-interactively 'org-do-demote))
((or (org-at-item-p)
(and (org-region-active-p)
(save-excursion
(goto-char (region-beginning))
(org-at-item-p))))
+ (when (org-check-for-hidden 'items) (org-hidden-tree-error))
(call-interactively 'org-indent-item))
(t (call-interactively 'forward-word))))
+(defun org-check-for-hidden (what)
+ "Check if there are hidden headlines/items in the current visual line.
+WHAT can be either `headlines' or `items'. If the current line is
+an outline or item heading and it has a folded subtree below it,
+this function returns t, nil otherwise."
+ (let ((re (cond
+ ((eq what 'headlines) (concat "^" org-outline-regexp))
+ ((eq what 'items) (concat "^" (org-item-re t)))
+ (t (error "This should not happen"))))
+ beg end)
+ (save-excursion
+ (catch 'exit
+ (unless (org-region-active-p)
+ (setq beg (point-at-bol))
+ (beginning-of-line 2)
+ (while (and (not (eobp)) ;; this is like `next-line'
+ (get-char-property (1- (point)) 'invisible))
+ (beginning-of-line 2))
+ (setq end (point))
+ (goto-char beg)
+ (goto-char (point-at-eol))
+ (setq end (max end (point)))
+ (while (re-search-forward re end t)
+ (if (get-char-property (match-beginning 0) 'invisible)
+ (throw 'exit t))))
+ nil))))
+
(defun org-metaup (&optional arg)
"Move subtree up or move table row up.
Calls `org-move-subtree-up' or `org-table-move-row' or
@@ -15390,6 +17049,7 @@ Calls `org-timestamp-up' or `org-priority-up', or `org-previous-item',
depending on context. See the individual commands for more information."
(interactive "P")
(cond
+ ((run-hook-with-args-until-success 'org-shiftup-hook))
((and org-support-shift-select (org-region-active-p))
(org-call-for-shift-select 'previous-line))
((org-at-timestamp-p t)
@@ -15402,6 +17062,7 @@ depending on context. See the individual commands for more information."
((and (not org-support-shift-select) (org-at-item-p))
(call-interactively 'org-previous-item))
((org-clocktable-try-shift 'up arg))
+ ((run-hook-with-args-until-success 'org-shiftup-final-hook))
(org-support-shift-select
(org-call-for-shift-select 'previous-line))
(t (org-shiftselect-error))))
@@ -15412,6 +17073,7 @@ Calls `org-timestamp-down' or `org-priority-down', or `org-next-item'
depending on context. See the individual commands for more information."
(interactive "P")
(cond
+ ((run-hook-with-args-until-success 'org-shiftdown-hook))
((and org-support-shift-select (org-region-active-p))
(org-call-for-shift-select 'next-line))
((org-at-timestamp-p t)
@@ -15424,6 +17086,7 @@ depending on context. See the individual commands for more information."
((and (not org-support-shift-select) (org-at-item-p))
(call-interactively 'org-next-item))
((org-clocktable-try-shift 'down arg))
+ ((run-hook-with-args-until-success 'org-shiftdown-final-hook))
(org-support-shift-select
(org-call-for-shift-select 'next-line))
(t (org-shiftselect-error))))
@@ -15439,6 +17102,7 @@ Depending on context, this does one of the following:
- on a clocktable definition line, move time block into the future"
(interactive "P")
(cond
+ ((run-hook-with-args-until-success 'org-shiftright-hook))
((and org-support-shift-select (org-region-active-p))
(org-call-for-shift-select 'forward-char))
((org-at-timestamp-p t) (call-interactively 'org-timestamp-up-day))
@@ -15458,6 +17122,7 @@ Depending on context, this does one of the following:
(org-at-property-p))
(call-interactively 'org-property-next-allowed-value))
((org-clocktable-try-shift 'right arg))
+ ((run-hook-with-args-until-success 'org-shiftright-final-hook))
(org-support-shift-select
(org-call-for-shift-select 'forward-char))
(t (org-shiftselect-error))))
@@ -15473,6 +17138,7 @@ Depending on context, this does one of the following:
- on a clocktable definition line, move time block into the past"
(interactive "P")
(cond
+ ((run-hook-with-args-until-success 'org-shiftleft-hook))
((and org-support-shift-select (org-region-active-p))
(org-call-for-shift-select 'backward-char))
((org-at-timestamp-p t) (call-interactively 'org-timestamp-down-day))
@@ -15492,6 +17158,7 @@ Depending on context, this does one of the following:
(org-at-property-p))
(call-interactively 'org-property-previous-allowed-value))
((org-clocktable-try-shift 'left arg))
+ ((run-hook-with-args-until-success 'org-shiftleft-final-hook))
(org-support-shift-select
(org-call-for-shift-select 'backward-char))
(t (org-shiftselect-error))))
@@ -15554,22 +17221,33 @@ See the individual commands for more information."
(org-table-paste-rectangle)
(org-paste-subtree arg)))
-(defun org-edit-special ()
+(defun org-edit-special (&optional arg)
"Call a special editor for the stuff at point.
When at a table, call the formula editor with `org-table-edit-formulas'.
When at the first line of an src example, call `org-edit-src-code'.
When in an #+include line, visit the include file. Otherwise call
`ffap' to visit the file at point."
(interactive)
- (cond
- ((org-at-table-p)
- (call-interactively 'org-table-edit-formulas))
+ ;; possibly prep session before editing source
+ (when arg
+ (let* ((info (org-babel-get-src-block-info))
+ (lang (nth 0 info))
+ (params (nth 2 info))
+ (session (cdr (assoc :session params))))
+ (when (and info session) ;; we are in a source-code block with a session
+ (funcall
+ (intern (concat "org-babel-prep-session:" lang)) session params))))
+ (cond ;; proceed with `org-edit-special'
((save-excursion
(beginning-of-line 1)
(looking-at "\\(?:#\\+\\(?:setupfile\\|include\\):?[ \t]+\"?\\|[ \t]*<include\\>.*?file=\"\\)\\([^\"\n>]+\\)"))
(find-file (org-trim (match-string 1))))
((org-edit-src-code))
((org-edit-fixed-width-region))
+ ((org-at-table.el-p)
+ (org-edit-src-code))
+ ((org-at-table-p)
+ (call-interactively 'org-table-edit-formulas))
(t (call-interactively 'ffap))))
@@ -15602,21 +17280,21 @@ This command does many different things, depending on context:
- If the cursor is a the beginning of a dynamic block, update it.
-- If the cursor is inside a table created by the table.el package,
- activate that table.
-
-- If the current buffer is a remember buffer, close note and file
- it. A prefix argument of 1 files to the default location
- without further interaction. A prefix argument of 2 files to
- the currently clocking task.
+- If the current buffer is a capture buffer, close note and file it.
-- If the cursor is on a <<<target>>>, update radio targets and corresponding
- links in this buffer.
+- If the cursor is on a <<<target>>>, update radio targets and
+ corresponding links in this buffer.
- If the cursor is on a numbered item in a plain list, renumber the
ordered list.
-- If the cursor is on a checkbox, toggle it."
+- If the cursor is on a checkbox, toggle it.
+
+- If the cursor is on a code block, evaluate it. The variable
+ `org-confirm-babel-evaluate' can be used to control prompting
+ before code block evaluation, by default every code block
+ evaluation requires confirmation. Code block evaluation can be
+ inhibited by setting `org-babel-no-eval-on-ctrl-c-ctrl-c'."
(interactive "P")
(let ((org-enable-table-editor t))
(cond
@@ -15631,7 +17309,8 @@ This command does many different things, depending on context:
(fboundp org-finish-function))
(funcall org-finish-function))
((run-hook-with-args-until-success 'org-ctrl-c-ctrl-c-hook))
- ((org-at-property-p)
+ ((or (looking-at org-property-start-re)
+ (org-at-property-p))
(call-interactively 'org-property-action))
((org-on-target-p) (call-interactively 'org-update-radio-target-regexp))
((and (org-in-regexp "\\[\\([0-9]*%\\|[0-9]*/[0-9]*\\)\\]")
@@ -15639,10 +17318,7 @@ This command does many different things, depending on context:
(call-interactively 'org-update-statistics-cookies))
((org-on-heading-p) (call-interactively 'org-set-tags))
((org-at-table.el-p)
- (require 'table)
- (beginning-of-line 1)
- (re-search-forward "|" (save-excursion (end-of-line 2) (point)))
- (call-interactively 'table-recognize-table))
+ (message "Use C-c ' to edit table.el tables"))
((org-at-table-p)
(org-table-maybe-eval-formula)
(if arg
@@ -15653,11 +17329,13 @@ This command does many different things, depending on context:
(org-footnote-at-definition-p))
(call-interactively 'org-footnote-action))
((org-at-item-checkbox-p)
- (call-interactively 'org-toggle-checkbox))
+ (call-interactively 'org-list-repair)
+ (call-interactively 'org-toggle-checkbox)
+ (org-list-send-list 'maybe))
((org-at-item-p)
- (if arg
- (call-interactively 'org-toggle-checkbox)
- (call-interactively 'org-maybe-renumber-ordered-list)))
+ (call-interactively 'org-list-repair)
+ (when arg (call-interactively 'org-toggle-checkbox))
+ (org-list-send-list 'maybe))
((save-excursion (beginning-of-line 1) (looking-at org-dblock-start-re))
;; Dynamic block
(beginning-of-line 1)
@@ -15674,9 +17352,9 @@ This command does many different things, depending on context:
(if (org-at-table-p)
(org-call-with-arg 'org-table-recalculate (or arg t)))))
(t
-; (org-set-regexps-and-options)
-; (org-restart-font-lock)
- (let ((org-inhibit-startup t)) (org-mode-restart))
+ (let ((org-inhibit-startup-visibility-stuff t)
+ (org-startup-align-all-tables nil))
+ (org-save-outline-visibility 'use-markers (org-mode-restart)))
(message "Local setup has been refreshed"))))
((org-clock-update-time-maybe))
(t (error "C-c C-c can do nothing useful at this location")))))
@@ -15692,7 +17370,9 @@ Also updates the keyword regular expressions."
"If this is a Note buffer, abort storing the note. Else call `show-branches'."
(interactive)
(if (not org-finish-function)
- (call-interactively 'show-branches)
+ (progn
+ (hide-subtree)
+ (call-interactively 'show-branches))
(let ((org-note-abort t))
(funcall org-finish-function))))
@@ -15711,7 +17391,7 @@ See the individual commands for more information."
(call-interactively 'org-open-at-point))
((and (org-at-heading-p)
(looking-at
- (org-re "\\([ \t]+\\(:[[:alnum:]_@:]+:\\)\\)[ \t]*$")))
+ (org-re "\\([ \t]+\\(:[[:alnum:]_@#%:]+:\\)\\)[ \t]*$")))
(org-show-entry)
(end-of-line 1)
(newline))
@@ -15777,21 +17457,21 @@ If the first line is normal text, add an item bullet to each line."
;; We already have items, de-itemize
(while (< (setq l (1+ l)) l2)
(when (org-at-item-p)
- (goto-char (match-beginning 2))
- (delete-region (match-beginning 2) (match-end 2))
- (and (looking-at "[ \t]+") (replace-match "")))
+ (skip-chars-forward " \t")
+ (delete-region (point) (match-end 0)))
(beginning-of-line 2))
(if (org-on-heading-p)
;; Headings, convert to items
(while (< (setq l (1+ l)) l2)
(if (looking-at org-outline-regexp)
- (replace-match "- " t t))
+ (replace-match (org-list-bullet-string "-") t t))
(beginning-of-line 2))
;; normal lines, turn them into items
(while (< (setq l (1+ l)) l2)
(unless (org-at-item-p)
(if (looking-at "\\([ \t]*\\)\\(\\S-\\)")
- (replace-match "\\1- \\2")))
+ (replace-match
+ (concat "\\1" (org-list-bullet-string "-") "\\2"))))
(beginning-of-line 2)))))))
(defun org-toggle-heading (&optional nstars)
@@ -15987,7 +17667,7 @@ See the individual commands for more information."
["Previous link" org-previous-link t]
"--"
["Descriptive Links"
- (progn (org-add-to-invisibility-spec '(org-link)) (org-restart-font-lock))
+ (progn (add-to-invisibility-spec '(org-link)) (org-restart-font-lock))
:style radio
:selected (member '(org-link) buffer-invisibility-spec)]
["Literal Links"
@@ -16004,8 +17684,8 @@ See the individual commands for more information."
["Complete Keyword" org-complete (assq :todo-keyword (org-context))]
["Next keyword set" org-shiftcontrolright (and (> (length org-todo-sets) 1) (org-on-heading-p))]
["Previous keyword set" org-shiftcontrolright (and (> (length org-todo-sets) 1) (org-on-heading-p))])
- ["Show TODO Tree" org-show-todo-tree t]
- ["Global TODO list" org-todo-list t]
+ ["Show TODO Tree" org-show-todo-tree :active t :keys "C-c / t"]
+ ["Global TODO list" org-todo-list :active t :keys "C-c a t"]
"--"
["Enforce dependencies" (customize-variable 'org-enforce-todo-dependencies)
:selected org-enforce-todo-dependencies :style toggle :active t]
@@ -16093,13 +17773,7 @@ See the individual commands for more information."
(org-inside-LaTeX-fragment-p)]
["Insert citation" org-reftex-citation t]
"--"
- ["Export LaTeX fragments as images"
- (if (featurep 'org-exp)
- (setq org-export-with-LaTeX-fragments
- (not org-export-with-LaTeX-fragments))
- (require 'org-exp))
- :style toggle :selected (and (boundp 'org-export-with-LaTeX-fragments)
- org-export-with-LaTeX-fragments)])
+ ["Template for BEAMER" org-insert-beamer-options-template t])
"--"
("MobileOrg"
["Push Files and Views" org-mobile-push t]
@@ -16232,8 +17906,18 @@ With prefix arg UNCOMPILED, load the uncompiled versions."
(dir-org-contrib (ignore-errors
(file-name-directory
(org-find-library-name "org-contribdir"))))
+ (babel-files
+ (mapcar (lambda (el) (concat "ob" (when el (format "-%s" el)) ".el"))
+ (append (list nil "comint" "eval" "exp" "keys"
+ "lob" "ref" "table" "tangle")
+ (delq nil
+ (mapcar
+ (lambda (lang)
+ (when (cdr lang) (symbol-name (car lang))))
+ org-babel-load-languages)))))
(files
(append (directory-files dir-org t file-re)
+ babel-files
(and dir-org-contrib
(directory-files dir-org-contrib t file-re))))
(remove-re (concat (if (featurep 'xemacs)
@@ -16300,9 +17984,7 @@ With prefix arg UNCOMPILED, load the uncompiled versions."
"Display the given MESSAGE as a warning."
(if (fboundp 'display-warning)
(display-warning 'org message
- (if (featurep 'xemacs)
- 'warning
- :warning))
+ (if (featurep 'xemacs) 'warning :warning))
(let ((buf (get-buffer-create "*Org warnings*")))
(with-current-buffer buf
(goto-char (point-max))
@@ -16316,6 +17998,13 @@ With prefix arg UNCOMPILED, load the uncompiled versions."
"Is point in a line starting with `#'?"
(equal (char-after (point-at-bol)) ?#))
+(defun org-in-indented-comment-line ()
+ "Is point in a line starting with `#' after some white space?"
+ (save-excursion
+ (save-match-data
+ (goto-char (point-at-bol))
+ (looking-at "[ \t]*#"))))
+
(defun org-in-verbatim-emphasis ()
(save-match-data
(and (org-in-regexp org-emph-re 2) (member (match-string 3) '("=" "~")))))
@@ -16440,7 +18129,8 @@ N may optionally be the number of spaces to remove."
(defun org-fill-template (template alist)
"Find each %key of ALIST in TEMPLATE and replace it."
- (let (entry key value)
+ (let ((case-fold-search nil)
+ entry key value)
(setq alist (sort (copy-sequence alist)
(lambda (a b) (< (length (car a)) (length (car b))))))
(while (setq entry (pop alist))
@@ -16622,11 +18312,11 @@ and :keyword."
(mapcar
(lambda (x)
(if (memq x org-latex-fragment-image-overlays) x))
- (org-overlays-at (point))))))
+ (overlays-at (point))))))
(push (list :latex-fragment
- (org-overlay-start o) (org-overlay-end o)) clist)
+ (overlay-start o) (overlay-end o)) clist)
(push (list :latex-preview
- (org-overlay-start o) (org-overlay-end o)) clist))
+ (overlay-start o) (overlay-end o)) clist))
((org-inside-LaTeX-fragment-p)
;; FIXME: positions wrong.
(push (list :latex-fragment (point) (point)) clist)))
@@ -16664,6 +18354,24 @@ really on, so that the block visually is on the match."
(throw 'exit t)))
nil))))
+(defun org-in-regexps-block-p (start-re end-re &optional bound)
+ "Return t if the current point is between matches of START-RE and END-RE.
+This will also return t if point is on one of the two matches or
+in an unfinished block. END-RE can be a string or a form
+returning a string.
+
+An optional third argument bounds the search for START-RE. It
+defaults to previous heading or `point-min'."
+ (let ((pos (point))
+ (limit (or bound (save-excursion (outline-previous-heading)))))
+ (save-excursion
+ ;; we're on a block when point is on start-re...
+ (or (org-at-regexp-p start-re)
+ ;; ... or start-re can be found above...
+ (and (re-search-backward start-re limit t)
+ ;; ... but no end-re between start-re and point.
+ (not (re-search-forward (eval end-re) pos t)))))))
+
(defun org-occur-in-agenda-files (regexp &optional nlines)
"Call `multi-occur' with buffers for all agenda files."
(interactive "sOrg-files matching: \np")
@@ -16731,6 +18439,33 @@ for the search purpose."
(setq list (delete (pop elts) list)))
list)
+(defun org-count (cl-item cl-seq)
+ "Count the number of occurrences of ITEM in SEQ.
+Taken from `count' in cl-seq.el with all keyword arguments removed."
+ (let ((cl-end (length cl-seq)) (cl-start 0) (cl-count 0) cl-x)
+ (when (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq)))
+ (while (< cl-start cl-end)
+ (setq cl-x (if (consp cl-seq) (pop cl-seq) (aref cl-seq cl-start)))
+ (if (equal cl-item cl-x) (setq cl-count (1+ cl-count)))
+ (setq cl-start (1+ cl-start)))
+ cl-count))
+
+(defun org-remove-if (predicate seq)
+ "Remove everything from SEQ that fulfills PREDICATE."
+ (let (res e)
+ (while seq
+ (setq e (pop seq))
+ (if (not (funcall predicate e)) (push e res)))
+ (nreverse res)))
+
+(defun org-remove-if-not (predicate seq)
+ "Remove everything from SEQ that does not fulfill PREDICATE."
+ (let (res e)
+ (while seq
+ (setq e (pop seq))
+ (if (funcall predicate e) (push e res)))
+ (nreverse res)))
+
(defun org-back-over-empty-lines ()
"Move backwards over whitespace, to the beginning of the first empty line.
Returns the number of empty lines passed."
@@ -16746,7 +18481,7 @@ Returns the number of empty lines passed."
(defun org-point-in-group (point group &optional context)
"Check if POINT is in match-group GROUP.
If CONTEXT is non-nil, return a list with CONTEXT and the boundaries of the
-match. If the match group does ot exist or point is not inside it,
+match. If the match group does not exist or point is not inside it,
return nil."
(and (match-beginning group)
(>= point (match-beginning group))
@@ -16757,7 +18492,8 @@ return nil."
(defun org-switch-to-buffer-other-window (&rest args)
"Switch to buffer in a second window on the current frame.
-In particular, do not allow pop-up frames."
+In particular, do not allow pop-up frames.
+Returns the newly created buffer."
(let (pop-up-frames special-display-buffer-names special-display-regexps
special-display-function)
(apply 'switch-to-buffer-other-window args)))
@@ -16808,17 +18544,27 @@ TABLE is an association list with keys like \"%a\" and string values.
The sequences in STRING may contain normal field width and padding information,
for example \"%-5s\". Replacements happen in the sequence given by TABLE,
so values can contain further %-escapes if they are define later in TABLE."
- (let ((case-fold-search nil)
- e re rpl)
- (while (setq e (pop table))
+ (let ((tbl (copy-alist table))
+ (case-fold-search nil)
+ (pchg 0)
+ e re rpl)
+ (while (setq e (pop tbl))
(setq re (concat "%-?[0-9.]*" (substring (car e) 1)))
+ (when (and (cdr e) (string-match re (cdr e)))
+ (let ((sref (substring (cdr e) (match-beginning 0) (match-end 0)))
+ (safe "SREF"))
+ (add-text-properties 0 3 (list 'sref sref) safe)
+ (setcdr e (replace-match safe t t (cdr e)))))
(while (string-match re string)
- (setq rpl (format (concat (substring (match-string 0 string) 0 -1) "s")
- (cdr e)))
- (setq string (replace-match rpl t t string))))
+ (setq rpl (format (concat (substring (match-string 0 string) 0 -1) "s")
+ (cdr e)))
+ (setq string (replace-match rpl t t string))))
+ (while (setq pchg (next-property-change pchg string))
+ (let ((sref (get-text-property pchg 'sref string)))
+ (when (and sref (string-match "SREF" string pchg))
+ (setq string (replace-match sref t t string)))))
string))
-
(defun org-sublist (list start end)
"Return a section of LIST, from START to END.
Counting starts at 1."
@@ -16900,61 +18646,90 @@ which make use of the date at the cursor."
(itemp (org-at-item-p))
(case-fold-search t)
(org-drawer-regexp (or org-drawer-regexp "\000"))
+ (inline-task-p (and (featurep 'org-inlinetask)
+ (org-inlinetask-in-task-p)))
column bpos bcol tpos tcol bullet btype bullet-type)
;; Find the previous relevant line
(beginning-of-line 1)
(cond
+ ;; Comments
((looking-at "#") (setq column 0))
+ ;; Headings
((looking-at "\\*+ ") (setq column 0))
+ ;; Drawers
((and (looking-at "[ \t]*:END:")
(save-excursion (re-search-backward org-drawer-regexp nil t)))
(save-excursion
(goto-char (1- (match-beginning 1)))
(setq column (current-column))))
- ((and (looking-at "[ \t]+#\\+end_\\([a-z]+\\)")
+ ;; Special blocks
+ ((and (looking-at "[ \t]*#\\+end_\\([a-z]+\\)")
(save-excursion
(re-search-backward
(concat "^[ \t]*#\\+begin_" (downcase (match-string 1))) nil t)))
(setq column (org-get-indentation (match-string 0))))
+ ((and (not (looking-at "[ \t]*#\\+begin_"))
+ (org-in-regexps-block-p "^[ \t]*#\\+begin_" "[ \t]*#\\+end_"))
+ (save-excursion
+ (re-search-backward "^[ \t]*#\\+begin_\\([a-z]+\\)" nil t))
+ (setq column
+ (if (equal (downcase (match-string 1)) "src")
+ ;; src blocks: let `org-edit-src-exit' handle them
+ (org-get-indentation)
+ (org-get-indentation (match-string 0)))))
+ ;; Lists
+ ((org-in-item-p)
+ (org-beginning-of-item)
+ (looking-at "[ \t]*\\(\\S-+\\)[ \t]*\\(\\(:?\\[@\\(:?start:\\)?[0-9]+\\][ \t]*\\)?\\[[- X]\\][ \t]*\\|.*? :: \\)?")
+ (setq bpos (match-beginning 1) tpos (match-end 0)
+ bcol (progn (goto-char bpos) (current-column))
+ tcol (progn (goto-char tpos) (current-column))
+ bullet (match-string 1)
+ bullet-type (if (string-match "[0-9]" bullet) "n" bullet))
+ (if (> tcol (+ bcol org-description-max-indent))
+ (setq tcol (+ bcol 5)))
+ (if (not itemp)
+ (setq column tcol)
+ (beginning-of-line 1)
+ (goto-char pos)
+ (if (looking-at "\\S-")
+ (progn
+ (looking-at "[ \t]*\\(\\S-+\\)[ \t]*")
+ (setq bullet (match-string 1)
+ btype (if (string-match "[0-9]" bullet) "n" bullet))
+ (setq column (if (equal btype bullet-type) bcol tcol)))
+ (setq column (org-get-indentation)))))
+ ;; This line has nothing special, look upside to get a clue about
+ ;; what to do.
(t
(beginning-of-line 0)
- (while (and (not (bobp)) (looking-at "[ \t]*[\n:#|]")
- (not (looking-at "[ \t]*:END:"))
- (not (looking-at org-drawer-regexp)))
- (beginning-of-line 0))
+ (while (and (not (bobp))
+ ;; skip comments, verbatim, empty lines, tables,
+ ;; inline tasks
+ (or (looking-at "[ \t]*[\n:#|]")
+ (and (org-in-item-p) (goto-char (org-list-top-point)))
+ (and (not inline-task-p)
+ (featurep 'org-inlinetask)
+ (org-inlinetask-in-task-p)))
+ (not (looking-at "[ \t]*:END:"))
+ (not (looking-at org-drawer-regexp)))
+ (beginning-of-line 0))
(cond
+ ;; There was an heading above.
((looking-at "\\*+[ \t]+")
(if (not org-adapt-indentation)
(setq column 0)
(goto-char (match-end 0))
(setq column (current-column))))
+ ;; A drawer had started and is unfinished: indent consequently.
((looking-at org-drawer-regexp)
- (goto-char (1- (match-beginning 1)))
- (setq column (current-column)))
+ (goto-char (1- (match-beginning 1)))
+ (setq column (current-column)))
+ ;; The drawer had ended: indent like its :END: line.
((looking-at "\\([ \t]*\\):END:")
- (goto-char (match-end 1))
- (setq column (current-column)))
- ((org-in-item-p)
- (org-beginning-of-item)
- (looking-at "[ \t]*\\(\\S-+\\)[ \t]*\\(\\[[- X]\\][ \t]*\\|.*? :: \\)?")
- (setq bpos (match-beginning 1) tpos (match-end 0)
- bcol (progn (goto-char bpos) (current-column))
- tcol (progn (goto-char tpos) (current-column))
- bullet (match-string 1)
- bullet-type (if (string-match "[0-9]" bullet) "n" bullet))
- (if (> tcol (+ bcol org-description-max-indent))
- (setq tcol (+ bcol 5)))
- (if (not itemp)
- (setq column tcol)
- (goto-char pos)
- (beginning-of-line 1)
- (if (looking-at "\\S-")
- (progn
- (looking-at "[ \t]*\\(\\S-+\\)[ \t]*")
- (setq bullet (match-string 1)
- btype (if (string-match "[0-9]" bullet) "n" bullet))
- (setq column (if (equal btype bullet-type) bcol tcol)))
- (setq column (org-get-indentation)))))
+ (goto-char (match-end 1))
+ (setq column (current-column)))
+ ;; Else, nothing noticeable found: get indentation and go on.
(t (setq column (org-get-indentation))))))
(goto-char pos)
(if (<= (current-column) (current-indentation))
@@ -16970,6 +18745,12 @@ which make use of the date at the cursor."
t t))
(org-move-to-column column)))
+(defvar org-adaptive-fill-regexp-backup adaptive-fill-regexp
+ "Variable to store copy of `adaptive-fill-regexp'.
+Since `adaptive-fill-regexp' is set to never match, we need to
+store a backup of its value before entering `org-mode' so that
+the functionality can be provided as a fall-back.")
+
(defun org-set-autofill-regexps ()
(interactive)
;; In the paragraph separator we include headlines, because filling
@@ -17005,8 +18786,11 @@ which make use of the date at the cursor."
;; and fixed-width regions are not wrapped. That function will pass
;; through to `fill-paragraph' when appropriate.
(org-set-local 'fill-paragraph-function 'org-fill-paragraph)
- ; Adaptive filling: To get full control, first make sure that
+ ;; Adaptive filling: To get full control, first make sure that
;; `adaptive-fill-regexp' never matches. Then install our own matcher.
+ (unless (local-variable-p 'adaptive-fill-regexp (current-buffer))
+ (org-set-local 'org-adaptive-fill-regexp-backup
+ adaptive-fill-regexp))
(org-set-local 'adaptive-fill-regexp "\000")
(org-set-local 'adaptive-fill-function
'org-adaptive-fill-function)
@@ -17035,8 +18819,11 @@ which make use of the date at the cursor."
"Return a fill prefix for org-mode files.
In particular, this makes sure hanging paragraphs for hand-formatted lists
work correctly."
- (cond ((looking-at "#[ \t]+")
- (match-string 0))
+ (cond
+ ;; Comment line
+ ((looking-at "#[ \t]+")
+ (match-string-no-properties 0))
+ ;; Description list
((looking-at "[ \t]*\\([-*+] .*? :: \\)")
(save-excursion
(if (> (match-end 1) (+ (match-beginning 1)
@@ -17044,11 +18831,14 @@ work correctly."
(goto-char (+ (match-beginning 1) 5))
(goto-char (match-end 0)))
(make-string (current-column) ?\ )))
- ((looking-at "[ \t]*\\([-*+] \\|[0-9]+[.)] ?\\)?")
+ ;; Ordered or unordered list
+ ((looking-at "[ \t]*\\([-*+] \\|[0-9]+[.)] ?\\)")
(save-excursion
(goto-char (match-end 0))
(make-string (current-column) ?\ )))
- (t nil)))
+ ;; Other text
+ ((looking-at org-adaptive-fill-regexp-backup)
+ (match-string-no-properties 0))))
;;; Other stuff.
@@ -17149,8 +18939,8 @@ beyond the end of the headline."
(if (bobp)
nil
(backward-char 1)
- (if (org-invisible-p)
- (while (and (not (bobp)) (org-invisible-p))
+ (if (org-truely-invisible-p)
+ (while (and (not (bobp)) (org-truely-invisible-p))
(backward-char 1)
(beginning-of-line 1))
(forward-char 1))))
@@ -17198,7 +18988,7 @@ beyond the end of the headline."
(t 'end-of-line)))
(let ((pos (point)))
(beginning-of-line 1)
- (if (looking-at (org-re ".*?\\(?:\\([ \t]*\\)\\(:[[:alnum:]_@:]+:\\)?[ \t]*\\)?$"))
+ (if (looking-at (org-re ".*?\\(?:\\([ \t]*\\)\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*\\)?$"))
(if (eq special t)
(if (or (< pos (match-beginning 1))
(= pos (match-end 0)))
@@ -17246,8 +19036,13 @@ depending on context."
((or (not org-special-ctrl-k)
(bolp)
(not (org-on-heading-p)))
+ (if (and (get-char-property (min (point-max) (point-at-eol)) 'invisible)
+ org-ctrl-k-protect-subtree)
+ (if (or (eq org-ctrl-k-protect-subtree 'error)
+ (not (y-or-n-p "Kill hidden subtree along with headline? ")))
+ (error "C-k aborted - would kill hidden subtree")))
(call-interactively 'kill-line))
- ((looking-at (org-re ".*?\\S-\\([ \t]+\\(:[[:alnum:]_@:]+:\\)\\)[ \t]*$"))
+ ((looking-at (org-re ".*?\\S-\\([ \t]+\\(:[[:alnum:]_@#%:]+:\\)\\)[ \t]*$"))
(kill-region (point) (match-beginning 1))
(org-set-tags nil t))
(t (kill-region (point) (point-at-eol)))))
@@ -17273,7 +19068,8 @@ org-yank-adjusted-subtrees
*visible* surrounding headings.
Any prefix to this command will cause `yank' to be called directly with
-no special treatment. In particular, a simple `C-u' prefix will just
+no special treatment. In particular, a simple \\[universal-argument] prefix \
+will just
plainly yank the text as it is.
\[1] The test checks if the first non-white line is a heading
@@ -17363,6 +19159,17 @@ interactive command with similar behavior."
(outline-invisible-p)
(get-char-property (point) 'invisible)))
+(defun org-truely-invisible-p ()
+ "Check if point is at a character currently not visible.
+This version does not only check the character property, but also
+`visible-mode'."
+ ;; Early versions of noutline don't have `outline-invisible-p'.
+ (if (org-bound-and-true-p visible-mode)
+ nil
+ (if (fboundp 'outline-invisible-p)
+ (outline-invisible-p)
+ (get-char-property (point) 'invisible))))
+
(defun org-invisible-p2 ()
"Check if point is at a character currently not visible."
(save-excursion
@@ -17379,6 +19186,13 @@ interactive command with similar behavior."
(error (error "Before first headline at position %d in buffer %s"
(point) (current-buffer)))))
+(defun org-beginning-of-defun ()
+ "Go to the beginning of the subtree, i.e. back to the heading."
+ (org-back-to-heading))
+(defun org-end-of-defun ()
+ "Go to the end of the subtree."
+ (org-end-of-subtree nil t))
+
(defun org-before-first-heading-p ()
"Before first heading?"
(save-excursion
@@ -17389,6 +19203,15 @@ interactive command with similar behavior."
(defun org-at-heading-p (&optional ignored)
(outline-on-heading-p t))
+(defun org-point-at-end-of-empty-headline ()
+ "If point is at the end of an empty headline, return t, else nil.
+If the heading only contains a TODO keyword, it is still still considered
+empty."
+ (and (looking-at "[ \t]*$")
+ (save-excursion
+ (beginning-of-line 1)
+ (looking-at (concat "^\\(\\*+\\)[ \t]+\\(" org-todo-regexp
+ "\\)?[ \t]*$")))))
(defun org-at-heading-or-item-p ()
(or (org-on-heading-p) (org-at-item-p)))
@@ -17463,6 +19286,18 @@ move point."
(while (org-goto-sibling 'previous)
(org-flag-heading nil))))
+(defun org-goto-first-child ()
+ "Goto the first child, even if it is invisible.
+Return t when a child was found. Otherwise don't move point and
+return nil."
+ (let (level (pos (point)) (re (concat "^" outline-regexp)))
+ (when (condition-case nil (org-back-to-heading t) (error nil))
+ (setq level (outline-level))
+ (forward-char 1)
+ (if (and (re-search-forward re nil t) (> (outline-level) level))
+ (progn (goto-char (match-beginning 0)) t)
+ (goto-char pos) nil))))
+
(defun org-show-hidden-entry ()
"Show an entry where even the heading is hidden."
(save-excursion
@@ -17554,7 +19389,9 @@ If there is no such heading, return nil."
(defun org-forward-same-level (arg &optional invisible-ok)
"Move forward to the arg'th subheading at same level as this one.
-Stop at the first and last subheadings of a superior heading."
+Stop at the first and last subheadings of a superior heading.
+Normally this only looks at visible headings, but when INVISIBLE-OK is non-nil
+it wil also look at invisible ones."
(interactive "p")
(org-back-to-heading invisible-ok)
(org-on-heading-p)
@@ -17567,7 +19404,7 @@ Stop at the first and last subheadings of a superior heading."
(setq l (- (match-end 0) (match-beginning 0) 1))
(= l level)
(not invisible-ok)
- (org-invisible-p))
+ (progn (backward-char 1) (org-invisible-p)))
(if (< l level) (setq arg 1)))
(setq arg (1- arg)))
(beginning-of-line 1)))
@@ -17714,11 +19551,11 @@ if no description is present"
;; Speedbar support
-(defvar org-speedbar-restriction-lock-overlay (org-make-overlay 1 1)
+(defvar org-speedbar-restriction-lock-overlay (make-overlay 1 1)
"Overlay marking the agenda restriction line in speedbar.")
-(org-overlay-put org-speedbar-restriction-lock-overlay
+(overlay-put org-speedbar-restriction-lock-overlay
'face 'org-agenda-restriction-lock)
-(org-overlay-put org-speedbar-restriction-lock-overlay
+(overlay-put org-speedbar-restriction-lock-overlay
'help-echo "Agendas are currently limited to this item.")
(org-detach-overlay org-speedbar-restriction-lock-overlay)
@@ -17751,8 +19588,8 @@ To get rid of the restriction, use \\[org-agenda-remove-restriction-lock]."
(error "Cannot restrict to non-Org-mode file"))
(org-agenda-set-restriction-lock 'file)))
(t (error "Don't know how to restrict Org-mode's agenda")))
- (org-move-overlay org-speedbar-restriction-lock-overlay
- (point-at-bol) (point-at-eol))
+ (move-overlay org-speedbar-restriction-lock-overlay
+ (point-at-bol) (point-at-eol))
(setq current-prefix-arg nil)
(org-agenda-maybe-redo)))
@@ -17766,14 +19603,13 @@ To get rid of the restriction, use \\[org-agenda-remove-restriction-lock]."
(add-hook 'speedbar-visiting-tag-hook
(lambda () (and (org-mode-p) (org-show-context 'org-goto))))))
-
;;; Fixes and Hacks for problems with other packages
;; Make flyspell not check words in links, to not mess up our keymap
(defun org-mode-flyspell-verify ()
"Don't let flyspell put overlays at active buttons."
- (and (not (get-text-property (point) 'keymap))
- (not (get-text-property (point) 'org-no-flyspell))))
+ (and (not (get-text-property (max (1- (point)) (point-min)) 'keymap))
+ (not (get-text-property (max (1- (point)) (point-min)) 'org-no-flyspell))))
(defun org-remove-flyspell-overlays-in (beg end)
"Remove flyspell overlays in region."
@@ -17849,4 +19685,3 @@ Still experimental, may disappear in the future."
;; arch-tag: e77da1a7-acc7-4336-b19e-efa25af3f9fd
;;; org.el ends here
-
diff --git a/lisp/outline.el b/lisp/outline.el
index b5d3d798714..95cc450973a 100644
--- a/lisp/outline.el
+++ b/lisp/outline.el
@@ -1,7 +1,8 @@
;;; outline.el --- outline mode commands for Emacs
;; Copyright (C) 1986, 1993, 1994, 1995, 1997, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: outlines
@@ -41,7 +42,7 @@
(defgroup outlines nil
"Support for hierarchical outlining."
:prefix "outline-"
- :group 'editing)
+ :group 'wp)
(defcustom outline-regexp "[*\^L]+"
"Regular expression to match the beginning of a heading.
@@ -445,10 +446,6 @@ at the end of the buffer."
"Non-nil if the character after point is invisible."
(get-char-property (or pos (point)) 'invisible))
-(defun outline-visible ()
- (not (outline-invisible-p)))
-(make-obsolete 'outline-visible 'outline-invisible-p "21.1")
-
(defun outline-back-to-heading (&optional invisible-ok)
"Move to previous heading line, or beg of this line if it's a heading.
Only visible heading lines are considered, unless INVISIBLE-OK is non-nil."
@@ -915,7 +912,11 @@ Show the heading too, if it is currently invisible."
(lambda ()
(if (<= (funcall outline-level) levels)
(outline-show-heading)))
- beg end)))
+ beg end)
+ ;; Finally unhide any trailing newline.
+ (goto-char (point-max))
+ (if (and (bolp) (not (bobp)) (outline-invisible-p (1- (point))))
+ (outline-flag-region (1- (point)) (point) nil))))
(run-hooks 'outline-view-change-hook))
(defun hide-other ()
diff --git a/lisp/paren.el b/lisp/paren.el
index 783a783338b..bdc15a66cc0 100644
--- a/lisp/paren.el
+++ b/lisp/paren.el
@@ -52,8 +52,7 @@ otherwise)."
:type '(choice (const parenthesis) (const expression) (const mixed))
:group 'paren-showing)
-(defcustom show-paren-delay
- (if (featurep 'lisp-float-type) (/ (float 1) (float 8)) 1)
+(defcustom show-paren-delay 0.125
"Time in seconds to delay before showing a matching paren."
:type '(number :tag "seconds")
:group 'paren-showing)
@@ -253,5 +252,4 @@ in `show-paren-style' after `show-paren-delay' seconds of Emacs idle time."
(provide 'paren)
-;; arch-tag: d0969b88-7ac0-4bd0-bd53-e73b892b86a9
;;; paren.el ends here
diff --git a/lisp/password-cache.el b/lisp/password-cache.el
index 301201ea0eb..7c67ab17702 100644
--- a/lisp/password-cache.el
+++ b/lisp/password-cache.el
@@ -1,7 +1,7 @@
;;; password-cache.el --- Read passwords, possibly using a password cache.
-;; Copyright (C) 1999, 2000, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2000, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+;; 2010 Free Software Foundation, Inc.
;; Author: Simon Josefsson <simon@josefsson.org>
;; Created: 2003-12-21
@@ -51,11 +51,15 @@
;;; Code:
+;; Options are autoloaded since they are used by eg mml-sec.el.
+
+;;;###autoload
(defcustom password-cache t
"Whether to cache passwords."
:group 'password
:type 'boolean)
+;;;###autoload
(defcustom password-cache-expiry 16
"How many seconds passwords are cached, or nil to disable expiring.
Whether passwords are cached at all is controlled by `password-cache'."
@@ -101,7 +105,7 @@ remove incorrect ones from the cache."
(defun password-cache-remove (key)
"Remove password indexed by KEY from password cache.
-This is typically run be a timer setup from `password-cache-add',
+This is typically run by a timer setup from `password-cache-add',
but can be invoked at any time to forcefully remove passwords
from the cache. This may be useful when it has been detected
that a password is invalid, so that `password-read' query the
@@ -130,5 +134,4 @@ The password is removed by a timer after `password-cache-expiry' seconds."
(provide 'password-cache)
-;; arch-tag: ab160494-16c8-4c68-a4a1-73eebf6686e5
;;; password-cache.el ends here
diff --git a/lisp/paths.el b/lisp/paths.el
index 510caa3a876..095326e9c8e 100644
--- a/lisp/paths.el
+++ b/lisp/paths.el
@@ -5,6 +5,7 @@
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/pcmpl-cvs.el b/lisp/pcmpl-cvs.el
index 8b394826e63..98d1e476669 100644
--- a/lisp/pcmpl-cvs.el
+++ b/lisp/pcmpl-cvs.el
@@ -4,6 +4,7 @@
;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
+;; Package: pcomplete
;; This file is part of GNU Emacs.
diff --git a/lisp/pcmpl-gnu.el b/lisp/pcmpl-gnu.el
index accab1dea9d..df1f055506c 100644
--- a/lisp/pcmpl-gnu.el
+++ b/lisp/pcmpl-gnu.el
@@ -3,6 +3,8 @@
;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Package: pcomplete
+
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
diff --git a/lisp/pcmpl-linux.el b/lisp/pcmpl-linux.el
index 67ef8e76aad..59c084fffae 100644
--- a/lisp/pcmpl-linux.el
+++ b/lisp/pcmpl-linux.el
@@ -3,6 +3,8 @@
;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Package: pcomplete
+
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
diff --git a/lisp/pcmpl-rpm.el b/lisp/pcmpl-rpm.el
index 754d7ce7434..7960141f03e 100644
--- a/lisp/pcmpl-rpm.el
+++ b/lisp/pcmpl-rpm.el
@@ -3,6 +3,8 @@
;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
;; 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Package: pcomplete
+
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
diff --git a/lisp/pcmpl-unix.el b/lisp/pcmpl-unix.el
index 9282fe87b5a..f2c19ca71c4 100644
--- a/lisp/pcmpl-unix.el
+++ b/lisp/pcmpl-unix.el
@@ -3,6 +3,8 @@
;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Package: pcomplete
+
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el
index 80f09492fee..cd216ad8d36 100644
--- a/lisp/pcomplete.el
+++ b/lisp/pcomplete.el
@@ -444,12 +444,14 @@ in the same way as TABLE completes strings of the form (concat S2 S)."
;; I don't think such commands are usable before first setting up buffer-local
;; variables to parse args, so there's no point autoloading it.
;; ;;;###autoload
-(defun pcomplete-std-complete ()
+(defun pcomplete-completions-at-point ()
"Provide standard completion using pcomplete's completion tables.
Same as `pcomplete' but using the standard completion UI."
- (interactive)
;; FIXME: it only completes the text before point, whereas the
;; standard UI may also consider text after point.
+ ;; FIXME: the `pcomplete' UI may be used internally during
+ ;; pcomplete-completions and then throw to `pcompleted', thus
+ ;; imposing the pcomplete UI over the standard UI.
(catch 'pcompleted
(let* ((pcomplete-stub)
pcomplete-seen pcomplete-norm-func
@@ -516,7 +518,7 @@ Same as `pcomplete' but using the standard completion UI."
(directory-file-name f))
pcomplete-seen))))))
- (completion-in-region
+ (list
beg (point)
;; Add a space at the end of completion. Use a terminator-regexp
;; that never matches since the terminator cannot appear
@@ -527,7 +529,14 @@ Same as `pcomplete' but using the standard completion UI."
(cons pcomplete-termination-string
"\\`a\\`")
table))
- pred))))
+ :predicate pred))))
+
+ ;; I don't think such commands are usable before first setting up buffer-local
+ ;; variables to parse args, so there's no point autoloading it.
+ ;; ;;;###autoload
+(defun pcomplete-std-complete ()
+ (let ((completion-at-point-functions '(pcomplete-completions-at-point)))
+ (completion-at-point)))
;;; Pcomplete's native UI.
@@ -544,7 +553,7 @@ completion functions list (it should occur fairly early in the list)."
pcomplete-expand-and-complete
pcomplete-reverse)))
(progn
- (delete-backward-char pcomplete-last-completion-length)
+ (delete-char (- pcomplete-last-completion-length))
(if (eq this-command 'pcomplete-reverse)
(progn
(push (car (last pcomplete-current-completions))
@@ -607,7 +616,7 @@ This will modify the current buffer."
(pcomplete)
(when (and pcomplete-current-completions
(> (length pcomplete-current-completions) 0)) ;??
- (delete-backward-char pcomplete-last-completion-length)
+ (delete-char (- pcomplete-last-completion-length))
(while pcomplete-current-completions
(unless (pcomplete-insert-entry
"" (car pcomplete-current-completions) t
@@ -630,7 +639,7 @@ This will modify the current buffer."
(when (and pcomplete-cycle-completions
pcomplete-current-completions
(eq last-command 'pcomplete-argument))
- (delete-backward-char pcomplete-last-completion-length)
+ (delete-char (- pcomplete-last-completion-length))
(setq pcomplete-current-completions nil
pcomplete-last-completion-raw nil))
(let ((pcomplete-show-list t))
@@ -1113,7 +1122,7 @@ generate the completions list. This means that the hook
(defmacro pcomplete-here* (&optional form stub form-only)
"An alternate form which does not participate in argument paring."
(declare (debug t))
- `(pcomplete-here (lambda () ,form) ,stub t ,form-only))
+ `(pcomplete-here ,form ,stub t ,form-only))
;; display support
@@ -1198,7 +1207,7 @@ Returns non-nil if a space was appended at the end."
;; FIXME: Here we presume that quoting `stub' gives us the exact
;; text in the buffer before point, which is not guaranteed;
;; e.g. it is not the case in eshell when completing ${FOO}tm[TAB].
- (delete-backward-char (length (pcomplete-quote-argument stub)))
+ (delete-char (- (length (pcomplete-quote-argument stub))))
;; if there is already a backslash present to handle the first
;; character, don't bother quoting it
(when (eq (char-before) ?\\)
diff --git a/lisp/pgg-def.el b/lisp/pgg-def.el
index c506d579283..d1b78ccb30b 100644
--- a/lisp/pgg-def.el
+++ b/lisp/pgg-def.el
@@ -6,6 +6,7 @@
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Created: 1999/11/02
;; Keywords: PGP, OpenPGP, GnuPG
+;; Package: pgg
;; This file is part of GNU Emacs.
@@ -94,5 +95,4 @@ Whether the passphrase is cached at all is controlled by
(provide 'pgg-def)
-;; arch-tag: c425f3ab-ed75-4055-bb46-431a418c94b7
;;; pgg-def.el ends here
diff --git a/lisp/pgg-gpg.el b/lisp/pgg-gpg.el
index e8375fe58fe..97b3b3e3d42 100644
--- a/lisp/pgg-gpg.el
+++ b/lisp/pgg-gpg.el
@@ -4,10 +4,11 @@
;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Daiki Ueno <ueno@unixuser.org>
-;; Symmetric encryption and gpg-agent support added by:
+;; Symmetric encryption and gpg-agent support added by:
;; Sascha Wilde <wilde@sha-bang.de>
;; Created: 1999/10/28
;; Keywords: PGP, OpenPGP, GnuPG
+;; Package: pgg
;; This file is part of GNU Emacs.
@@ -406,5 +407,4 @@ passphrase cache or user."
(provide 'pgg-gpg)
-;; arch-tag: 2aa5d5d8-93a0-4865-9312-33e29830e000
;;; pgg-gpg.el ends here
diff --git a/lisp/pgg-parse.el b/lisp/pgg-parse.el
index b0f2a815cbd..72f8729de77 100644
--- a/lisp/pgg-parse.el
+++ b/lisp/pgg-parse.el
@@ -6,6 +6,7 @@
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Created: 1999/10/28
;; Keywords: PGP, OpenPGP, GnuPG
+;; Package: pgg
;; This file is part of GNU Emacs.
@@ -35,6 +36,7 @@
;;; Code:
(eval-when-compile
+ ;; For Emacs <22.2 and XEmacs.
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
(require 'cl))
@@ -503,8 +505,8 @@
(defun pgg-parse-armor (string)
(with-temp-buffer
(buffer-disable-undo)
- (if (fboundp 'set-buffer-multibyte)
- (set-buffer-multibyte nil))
+ (unless (featurep 'xemacs)
+ (set-buffer-multibyte nil))
(insert string)
(pgg-decode-armor-region (point-min)(point))))
@@ -518,5 +520,4 @@
(provide 'pgg-parse)
-;; arch-tag: 16c2eb82-1313-4a7c-a70f-420709b5b43e
;;; pgg-parse.el ends here
diff --git a/lisp/pgg-pgp.el b/lisp/pgg-pgp.el
index c1c9249a736..dfa02d78353 100644
--- a/lisp/pgg-pgp.el
+++ b/lisp/pgg-pgp.el
@@ -6,6 +6,7 @@
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Created: 1999/11/02
;; Keywords: PGP, OpenPGP
+;; Package: pgg
;; This file is part of GNU Emacs.
@@ -253,5 +254,4 @@ passphrase cache or user."
(provide 'pgg-pgp)
-;; arch-tag: 076b7801-37b2-49a6-97c3-218fdecde33c
;;; pgg-pgp.el ends here
diff --git a/lisp/pgg-pgp5.el b/lisp/pgg-pgp5.el
index cb2cfd915fb..49731190946 100644
--- a/lisp/pgg-pgp5.el
+++ b/lisp/pgg-pgp5.el
@@ -6,6 +6,7 @@
;; Author: Daiki Ueno <ueno@unixuser.org>
;; Created: 1999/11/02
;; Keywords: PGP, OpenPGP
+;; Package: pgg
;; This file is part of GNU Emacs.
@@ -254,5 +255,4 @@ Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"."
(provide 'pgg-pgp5)
-;; arch-tag: 3dbd1073-6b3a-466c-9f55-5c587ffa6d7b
;;; pgg-pgp5.el ends here
diff --git a/lisp/pgg.el b/lisp/pgg.el
index 7364d3782ac..f654f3dc35e 100644
--- a/lisp/pgg.el
+++ b/lisp/pgg.el
@@ -36,6 +36,7 @@
;; Don't merge these two `eval-when-compile's.
(eval-when-compile
+ ;; For Emacs <22.2 and XEmacs.
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
(require 'cl))
@@ -43,10 +44,8 @@
;;;
(eval-when-compile
- ;; Define it as a null macro for Emacs in order to suppress a byte
- ;; compile warning that Emacs 21 issues.
- (defmacro pgg-run-at-time-1 (time repeat function args)
- (when (featurep 'xemacs)
+ (when (featurep 'xemacs)
+ (defmacro pgg-run-at-time-1 (time repeat function args)
(if (condition-case nil
(let ((delete-itimer 'delete-itimer)
(itimer-driver-start 'itimer-driver-start)
@@ -75,36 +74,36 @@
`(let ((time ,time))
(apply #'start-itimer "pgg-run-at-time"
,function (if time (max time 1e-9) 1e-9)
- ,repeat nil t ,args)))
- `(let ((time ,time)
- (itimers (list nil)))
- (setcar
- itimers
- (apply #'start-itimer "pgg-run-at-time"
- (lambda (itimers repeat function &rest args)
- (let ((itimer (car itimers)))
- (if repeat
- (progn
- (set-itimer-function
- itimer
- (lambda (itimer repeat function &rest args)
- (set-itimer-restart itimer repeat)
- (set-itimer-function itimer function)
- (set-itimer-function-arguments itimer args)
- (apply function args)))
- (set-itimer-function-arguments
- itimer
- (append (list itimer repeat function) args)))
- (set-itimer-function
- itimer
- (lambda (itimer function &rest args)
- (delete-itimer itimer)
- (apply function args)))
- (set-itimer-function-arguments
- itimer
- (append (list itimer function) args)))))
- 1e-9 (if time (max time 1e-9) 1e-9)
- nil t itimers ,repeat ,function ,args))))))
+ ,repeat nil t ,args))
+ `(let ((time ,time)
+ (itimers (list nil)))
+ (setcar
+ itimers
+ (apply #'start-itimer "pgg-run-at-time"
+ (lambda (itimers repeat function &rest args)
+ (let ((itimer (car itimers)))
+ (if repeat
+ (progn
+ (set-itimer-function
+ itimer
+ (lambda (itimer repeat function &rest args)
+ (set-itimer-restart itimer repeat)
+ (set-itimer-function itimer function)
+ (set-itimer-function-arguments itimer args)
+ (apply function args)))
+ (set-itimer-function-arguments
+ itimer
+ (append (list itimer repeat function) args)))
+ (set-itimer-function
+ itimer
+ (lambda (itimer function &rest args)
+ (delete-itimer itimer)
+ (apply function args)))
+ (set-itimer-function-arguments
+ itimer
+ (append (list itimer function) args)))))
+ 1e-9 (if time (max time 1e-9) 1e-9)
+ nil t itimers ,repeat ,function ,args)))))))
(eval-and-compile
(if (featurep 'xemacs)
@@ -475,8 +474,8 @@ signer's public key from `pgg-default-keyserver-address'."
(if (null signature) nil
(with-temp-buffer
(buffer-disable-undo)
- (if (fboundp 'set-buffer-multibyte)
- (set-buffer-multibyte nil))
+ (unless (featurep 'xemacs)
+ (set-buffer-multibyte nil))
(insert-file-contents signature)
(cdr (assq 2 (pgg-decode-armor-region
(point-min)(point-max)))))))
@@ -602,5 +601,4 @@ within the region."
(provide 'pgg)
-;; arch-tag: 9cc705dd-1e6a-4c90-8dce-c3561f9a2cf4
;;; pgg.el ends here
diff --git a/lisp/play/5x5.el b/lisp/play/5x5.el
index 5263cf11bc7..918587db132 100644
--- a/lisp/play/5x5.el
+++ b/lisp/play/5x5.el
@@ -108,12 +108,7 @@
(defvar 5x5-buffer-name "*5x5*"
"Name of the 5x5 play buffer.")
-(defvar 5x5-mode-map nil
- "Local keymap for the 5x5 game.")
-
-;; Keymap.
-
-(unless 5x5-mode-map
+(defvar 5x5-mode-map
(let ((map (make-sparse-keymap)))
(suppress-keymap map t)
(define-key map "?" #'describe-mode)
@@ -141,7 +136,8 @@
(define-key map [(control c) (control x)] #'5x5-crack-xor-mutate)
(define-key map "n" #'5x5-new-game)
(define-key map "q" #'5x5-quit-game)
- (setq 5x5-mode-map map)))
+ map)
+ "Local keymap for the 5x5 game.")
;; Menu definition.
diff --git a/lisp/play/decipher.el b/lisp/play/decipher.el
index 897832d2195..f0a602be70b 100644
--- a/lisp/play/decipher.el
+++ b/lisp/play/decipher.el
@@ -154,38 +154,37 @@ For example, to display ciphertext in the `bold' face, use
'bold)))
in your `.emacs' file.")
-(defvar decipher-mode-map nil
+(defvar decipher-mode-map
+ (let ((map (make-keymap)))
+ (suppress-keymap map)
+ (define-key map "A" 'decipher-show-alphabet)
+ (define-key map "C" 'decipher-complete-alphabet)
+ (define-key map "D" 'decipher-digram-list)
+ (define-key map "F" 'decipher-frequency-count)
+ (define-key map "M" 'decipher-make-checkpoint)
+ (define-key map "N" 'decipher-adjacency-list)
+ (define-key map "R" 'decipher-restore-checkpoint)
+ (define-key map "U" 'decipher-undo)
+ (define-key map " " 'decipher-keypress)
+ (define-key map [remap undo] 'decipher-undo)
+ (define-key map [remap advertised-undo] 'decipher-undo)
+ (let ((key ?a))
+ (while (<= key ?z)
+ (define-key map (vector key) 'decipher-keypress)
+ (incf key)))
+ map)
"Keymap for Decipher mode.")
-(if (not decipher-mode-map)
- (progn
- (setq decipher-mode-map (make-keymap))
- (suppress-keymap decipher-mode-map)
- (define-key decipher-mode-map "A" 'decipher-show-alphabet)
- (define-key decipher-mode-map "C" 'decipher-complete-alphabet)
- (define-key decipher-mode-map "D" 'decipher-digram-list)
- (define-key decipher-mode-map "F" 'decipher-frequency-count)
- (define-key decipher-mode-map "M" 'decipher-make-checkpoint)
- (define-key decipher-mode-map "N" 'decipher-adjacency-list)
- (define-key decipher-mode-map "R" 'decipher-restore-checkpoint)
- (define-key decipher-mode-map "U" 'decipher-undo)
- (define-key decipher-mode-map " " 'decipher-keypress)
- (define-key decipher-mode-map [remap undo] 'decipher-undo)
- (define-key decipher-mode-map [remap advertised-undo] 'decipher-undo)
- (let ((key ?a))
- (while (<= key ?z)
- (define-key decipher-mode-map (vector key) 'decipher-keypress)
- (incf key)))))
-
-(defvar decipher-stats-mode-map nil
- "Keymap for Decipher-Stats mode.")
-(if (not decipher-stats-mode-map)
- (progn
- (setq decipher-stats-mode-map (make-keymap))
- (suppress-keymap decipher-stats-mode-map)
- (define-key decipher-stats-mode-map "D" 'decipher-digram-list)
- (define-key decipher-stats-mode-map "F" 'decipher-frequency-count)
- (define-key decipher-stats-mode-map "N" 'decipher-adjacency-list)
- ))
+
+
+(defvar decipher-stats-mode-map
+ (let ((map (make-keymap)))
+ (suppress-keymap map)
+ (define-key map "D" 'decipher-digram-list)
+ (define-key map "F" 'decipher-frequency-count)
+ (define-key map "N" 'decipher-adjacency-list)
+ map)
+"Keymap for Decipher-Stats mode.")
+
(defvar decipher-mode-syntax-table nil
"Decipher mode syntax table")
@@ -488,7 +487,7 @@ The most useful commands are:
(let ((font-lock-fontify-region-function 'ignore))
;; insert-and-inherit will pick the right face automatically
(while (search-forward-regexp "^:" nil t)
- (setq bound (save-excursion (end-of-line) (point)))
+ (setq bound (point-at-eol))
(while (search-forward cipher-string bound 'end)
(decipher-insert plain-char)))))))
@@ -1060,8 +1059,7 @@ if it can't, it signals an error."
;; (insert ?\()
;; (while (setq undo-map (pop undo-rec))
;; (insert (cdr undo-map) (car undo-map) ?\ ))
-;; (delete-backward-char 1)
+;; (delete-char -1)
;; (insert ")\n"))))))
-;; arch-tag: 8f094d88-ffe1-4f99-afe3-a5e81dd939d9
;;; decipher.el ends here
diff --git a/lisp/play/doctor.el b/lisp/play/doctor.el
index 4d4dfa70c55..e892c5dcfbb 100644
--- a/lisp/play/doctor.el
+++ b/lisp/play/doctor.el
@@ -29,40 +29,94 @@
;;; Code:
-(defvar **mad**) (defvar *debug*) (defvar *print-space*)
-(defvar *print-upcase*) (defvar abuselst) (defvar abusewords)
-(defvar account) (defvar afraidof) (defvar arerelated)
-(defvar areyou) (defvar bak) (defvar beclst)
-(defvar bother) (defvar bye) (defvar canyou)
-(defvar chatlst) (defvar continue) (defvar deathlst)
-(defvar describe) (defvar drnk) (defvar drugs)
-(defvar eliza-flag) (defvar elizalst) (defvar famlst)
-(defvar feared) (defvar fears) (defvar feelings-about)
-(defvar foullst) (defvar found) (defvar hello)
-(defvar history) (defvar howareyoulst) (defvar howdyflag)
-(defvar huhlst) (defvar ibelieve) (defvar improve)
-(defvar inter) (defvar isee) (defvar isrelated)
-(defvar lincount) (defvar longhuhlst) (defvar lover)
-(defvar machlst) (defvar mathlst) (defvar maybe)
-(defvar moods) (defvar neglst) (defvar obj)
-(defvar object) (defvar owner) (defvar please)
-(defvar problems) (defvar qlist) (defvar random-adjective)
-(defvar relation) (defvar remlst) (defvar repetitive-shortness)
-(defvar replist) (defvar rms-flag) (defvar schoollst)
-(defvar sent) (defvar sexlst) (defvar shortbeclst)
-(defvar shortlst) (defvar something) (defvar sportslst)
-(defvar stallmanlst) (defvar states) (defvar subj)
-(defvar suicide-flag) (defvar sure) (defvar thing)
-(defvar things) (defvar thlst) (defvar toklst)
-(defvar typos) (defvar verb) (defvar want)
-(defvar whatwhen) (defvar whereoutp) (defvar whysay)
-(defvar whywant) (defvar zippy-flag) (defvar zippylst)
+(defvar doctor--**mad**)
+(defvar doctor--*print-space*)
+(defvar doctor--*print-upcase*)
+(defvar doctor--abuselst)
+(defvar doctor--abusewords)
+(defvar doctor--afraidof)
+(defvar doctor--arerelated)
+(defvar doctor--areyou)
+(defvar doctor--bak)
+(defvar doctor--beclst)
+(defvar doctor--bother)
+(defvar doctor--bye)
+(defvar doctor--canyou) ; unused?
+(defvar doctor--chatlst)
+(defvar doctor--continue)
+(defvar doctor--deathlst)
+(defvar doctor--describe)
+(defvar doctor--drnk)
+(defvar doctor--drugs)
+(defvar doctor--eliza-flag)
+(defvar doctor--elizalst)
+(defvar doctor--famlst)
+(defvar doctor--feared)
+(defvar doctor--fears)
+(defvar doctor--feelings-about)
+(defvar doctor--foullst)
+(defvar doctor-found)
+(defvar doctor--hello)
+(defvar doctor--history)
+(defvar doctor--howareyoulst)
+(defvar doctor--howdyflag)
+(defvar doctor--huhlst)
+(defvar doctor--ibelieve)
+(defvar doctor--improve)
+(defvar doctor--inter)
+(defvar doctor--isee)
+(defvar doctor--isrelated)
+(defvar doctor--lincount)
+(defvar doctor--longhuhlst)
+(defvar doctor--lover)
+(defvar doctor--machlst)
+(defvar doctor--mathlst)
+(defvar doctor--maybe)
+(defvar doctor--moods)
+(defvar doctor--neglst)
+(defvar doctor-obj)
+(defvar doctor-object)
+(defvar doctor-owner)
+(defvar doctor--please)
+(defvar doctor--problems)
+(defvar doctor--qlist)
+(defvar doctor--random-adjective)
+(defvar doctor--relation)
+(defvar doctor--remlst)
+(defvar doctor--repetitive-shortness)
+(defvar doctor--replist)
+(defvar doctor--rms-flag)
+(defvar doctor--schoollst)
+(defvar doctor-sent)
+(defvar doctor--sexlst)
+(defvar doctor--shortbeclst)
+(defvar doctor--shortlst)
+(defvar doctor--something)
+(defvar doctor--sportslst)
+(defvar doctor--stallmanlst)
+(defvar doctor--states)
+(defvar doctor-subj)
+(defvar doctor--suicide-flag)
+(defvar doctor--sure)
+(defvar doctor--thing)
+(defvar doctor--things)
+(defvar doctor--thlst)
+(defvar doctor--toklst)
+(defvar doctor--typos)
+(defvar doctor-verb)
+(defvar doctor--want)
+(defvar doctor--whatwhen)
+(defvar doctor--whereoutp)
+(defvar doctor--whysay)
+(defvar doctor--whywant)
+(defvar doctor--zippy-flag)
+(defvar doctor--zippylst)
(defun doc// (x) x)
(defmacro doc$ (what)
"quoted arg form of doctor-$"
- (list 'doctor-$ (list 'quote what)))
+ `(doctor-$ ',what))
(defun doctor-$ (what)
"Return the car of a list, rotating the list each time"
@@ -86,484 +140,411 @@ reads the sentence before point, and prints the Doctor's answer."
(make-doctor-variables)
(turn-on-auto-fill)
(doctor-type '(i am the psychotherapist \.
- (doc$ please) (doc$ describe) your (doc$ problems) \.
+ (doc$ doctor--please) (doc$ doctor--describe) your (doc$ doctor--problems) \.
each time you are finished talking, type \R\E\T twice \.))
(insert "\n"))
(defun make-doctor-variables ()
- (make-local-variable 'typos)
- (setq typos
- (mapcar (function (lambda (x)
- (put (car x) 'doctor-correction (cadr x))
- (put (cadr x) 'doctor-expansion (car (cddr x)))
- (car x)))
- '((theyll they\'ll (they will))
- (theyre they\'re (they are))
- (hes he\'s (he is))
- (he7s he\'s (he is))
- (im i\'m (you are))
- (i7m i\'m (you are))
- (isa is\ a (is a))
- (thier their (their))
- (dont don\'t (do not))
- (don7t don\'t (do not))
- (you7re you\'re (i am))
- (you7ve you\'ve (i have))
- (you7ll you\'ll (i will)))))
- (make-local-variable 'found)
- (setq found nil)
- (make-local-variable 'owner)
- (setq owner nil)
- (make-local-variable 'history)
- (setq history nil)
- (make-local-variable '*debug*)
- (setq *debug* nil)
- (make-local-variable 'inter)
- (setq inter
- '((well\,)
- (hmmm \.\.\.\ so\,)
- (so)
- (\.\.\.and)
- (then)))
- (make-local-variable 'continue)
- (setq continue
- '((continue)
- (proceed)
- (go on)
- (keep going) ))
- (make-local-variable 'relation)
- (setq relation
- '((your relationship with)
- (something you remember about)
- (your feelings toward)
- (some experiences you have had with)
- (how you feel about)))
- (make-local-variable 'fears)
- (setq fears '( ((doc$ whysay) you are (doc$ afraidof) (doc// feared) \?)
- (you seem terrified by (doc// feared) \.)
- (when did you first feel (doc$ afraidof) (doc// feared) \?) ))
- (make-local-variable 'sure)
- (setq sure '((sure)(positive)(certain)(absolutely sure)))
- (make-local-variable 'afraidof)
- (setq afraidof '( (afraid of) (frightened by) (scared of) ))
- (make-local-variable 'areyou)
- (setq areyou '( (are you)(have you been)(have you been) ))
- (make-local-variable 'isrelated)
- (setq isrelated '( (has something to do with)(is related to)
- (could be the reason for) (is caused by)(is because of)))
- (make-local-variable 'arerelated)
- (setq arerelated '((have something to do with)(are related to)
- (could have caused)(could be the reason for) (are caused by)
- (are because of)))
- (make-local-variable 'moods)
- (setq moods '( ((doc$ areyou)(doc// found) often \?)
- (what causes you to be (doc// found) \?)
- ((doc$ whysay) you are (doc// found) \?) ))
- (make-local-variable 'maybe)
- (setq maybe
- '((maybe)
- (perhaps)
- (possibly)))
- (make-local-variable 'whatwhen)
- (setq whatwhen
- '((what happened when)
- (what would happen if)))
- (make-local-variable 'hello)
- (setq hello
- '((how do you do \?) (hello \.) (howdy!) (hello \.) (hi \.) (hi there \.)))
- (make-local-variable 'drnk)
- (setq drnk
- '((do you drink a lot of (doc// found) \?)
- (do you get drunk often \?)
- ((doc$ describe) your drinking habits \.) ))
- (make-local-variable 'drugs)
- (setq drugs '( (do you use (doc// found) often \?)((doc$ areyou)
- addicted to (doc// found) \?)(do you realize that drugs can
- be very harmful \?)((doc$ maybe) you should try to quit using (doc// found)
- \.)))
- (make-local-variable 'whywant)
- (setq whywant '( ((doc$ whysay) (doc// subj) might (doc$ want) (doc// obj) \?)
- (how does it feel to want \?)
- (why should (doc// subj) get (doc// obj) \?)
- (when did (doc// subj) first (doc$ want) (doc// obj) \?)
- ((doc$ areyou) obsessed with (doc// obj) \?)
- (why should i give (doc// obj) to (doc// subj) \?)
- (have you ever gotten (doc// obj) \?) ))
- (make-local-variable 'canyou)
- (setq canyou '((of course i can \.)
- (why should i \?)
- (what makes you think i would even want to \?)
- (i am the doctor\, i can do anything i damn please \.)
- (not really\, it\'s not up to me \.)
- (depends\, how important is it \?)
- (i could\, but i don\'t think it would be a wise thing to do \.)
- (can you \?)
- (maybe i can\, maybe i can\'t \.\.\.)
- (i don\'t think i should do that \.)))
- (make-local-variable 'want)
- (setq want '( (want) (desire) (wish) (want) (hope) ))
- (make-local-variable 'shortlst)
- (setq shortlst
- '((can you elaborate on that \?)
- ((doc$ please) continue \.)
- (go on\, don\'t be afraid \.)
- (i need a little more detail please \.)
- (you\'re being a bit brief\, (doc$ please) go into detail \.)
- (can you be more explicit \?)
- (and \?)
- ((doc$ please) go into more detail \?)
- (you aren\'t being very talkative today\!)
- (is that all there is to it \?)
- (why must you respond so briefly \?)))
-
- (make-local-variable 'famlst)
- (setq famlst
- '((tell me (doc$ something) about (doc// owner) family \.)
- (you seem to dwell on (doc// owner) family \.)
- ((doc$ areyou) hung up on (doc// owner) family \?)))
- (make-local-variable 'huhlst)
- (setq huhlst
- '(((doc$ whysay)(doc// sent) \?)
- (is it because of (doc$ things) that you say (doc// sent) \?) ))
- (make-local-variable 'longhuhlst)
- (setq longhuhlst
- '(((doc$ whysay) that \?)
- (i don\'t understand \.)
- ((doc$ thlst))
- ((doc$ areyou) (doc$ afraidof) that \?)))
- (make-local-variable 'feelings-about)
- (setq feelings-about
- '((feelings about)
- (apprehensions toward)
- (thoughts on)
- (emotions toward)))
- (make-local-variable 'random-adjective)
- (setq random-adjective
- '((vivid)
- (emotionally stimulating)
- (exciting)
- (boring)
- (interesting)
- (recent)
- (random) ;How can we omit this?
- (unusual)
- (shocking)
- (embarrassing)))
- (make-local-variable 'whysay)
- (setq whysay
- '((why do you say)
- (what makes you believe)
- (are you sure that)
- (do you really think)
- (what makes you think) ))
- (make-local-variable 'isee)
- (setq isee
- '((i see \.\.\.)
- (yes\,)
- (i understand \.)
- (oh \.) ))
- (make-local-variable 'please)
- (setq please
- '((please\,)
- (i would appreciate it if you would)
- (perhaps you could)
- (please\,)
- (would you please)
- (why don\'t you)
- (could you)))
- (make-local-variable 'bye)
- (setq bye
- '((my secretary will send you a bill \.)
- (bye bye \.)
- (see ya \.)
- (ok\, talk to you some other time \.)
- (talk to you later \.)
- (ok\, have fun \.)
- (ciao \.)))
- (make-local-variable 'something)
- (setq something
- '((something)
- (more)
- (how you feel)))
- (make-local-variable 'thing)
- (setq thing
- '((your life)
- (your sex life)))
- (make-local-variable 'things)
- (setq things
- '((your plans)
- (the people you hang around with)
- (problems at school)
- (any hobbies you have)
- (hangups you have)
- (your inhibitions)
- (some problems in your childhood)
- (some problems at home)))
- (make-local-variable 'describe)
- (setq describe
- '((describe)
- (tell me about)
- (talk about)
- (discuss)
- (tell me more about)
- (elaborate on)))
- (make-local-variable 'ibelieve)
- (setq ibelieve
- '((i believe) (i think) (i have a feeling) (it seems to me that)
- (it looks like)))
- (make-local-variable 'problems)
- (setq problems '( (problems)
- (inhibitions)
- (hangups)
- (difficulties)
- (anxieties)
- (frustrations) ))
- (make-local-variable 'bother)
- (setq bother
- '((does it bother you that)
- (are you annoyed that)
- (did you ever regret)
- (are you sorry)
- (are you satisfied with the fact that)))
- (make-local-variable 'machlst)
- (setq machlst
- '((you have your mind on (doc// found) \, it seems \.)
- (you think too much about (doc// found) \.)
- (you should try taking your mind off of (doc// found)\.)
- (are you a computer hacker \?)))
- (make-local-variable 'qlist)
- (setq qlist
- '((what do you think \?)
- (i\'ll ask the questions\, if you don\'t mind!)
- (i could ask the same thing myself \.)
- ((doc$ please) allow me to do the questioning \.)
- (i have asked myself that question many times \.)
- ((doc$ please) try to answer that question yourself \.)))
- (make-local-variable 'foullst)
- (setq foullst
- '(((doc$ please) watch your tongue!)
- ((doc$ please) avoid such unwholesome thoughts \.)
- ((doc$ please) get your mind out of the gutter \.)
- (such lewdness is not appreciated \.)))
- (make-local-variable 'deathlst)
- (setq deathlst
- '((this is not a healthy way of thinking \.)
- ((doc$ bother) you\, too\, may die someday \?)
- (i am worried by your obsession with this topic!)
- (did you watch a lot of crime and violence on television as a child \?))
- )
- (make-local-variable 'sexlst)
- (setq sexlst
- '(((doc$ areyou) (doc$ afraidof) sex \?)
- ((doc$ describe)(doc$ something) about your sexual history \.)
- ((doc$ please)(doc$ describe) your sex life \.\.\.)
- ((doc$ describe) your (doc$ feelings-about) your sexual partner \.)
- ((doc$ describe) your most (doc$ random-adjective) sexual experience \.)
- ((doc$ areyou) satisfied with (doc// lover) \.\.\. \?)))
- (make-local-variable 'neglst)
- (setq neglst
- '((why not \?)
- ((doc$ bother) i ask that \?)
- (why not \?)
- (why not \?)
- (how come \?)
- ((doc$ bother) i ask that \?)))
- (make-local-variable 'beclst)
- (setq beclst '(
- (is it because (doc// sent) that you came to me \?)
- ((doc$ bother)(doc// sent) \?)
- (when did you first know that (doc// sent) \?)
- (is the fact that (doc// sent) the real reason \?)
- (does the fact that (doc// sent) explain anything else \?)
- ((doc$ areyou)(doc$ sure)(doc// sent) \? ) ))
- (make-local-variable 'shortbeclst)
- (setq shortbeclst '(
- ((doc$ bother) i ask you that \?)
- (that\'s not much of an answer!)
- ((doc$ inter) why won\'t you talk about it \?)
- (speak up!)
- ((doc$ areyou) (doc$ afraidof) talking about it \?)
- (don\'t be (doc$ afraidof) elaborating \.)
- ((doc$ please) go into more detail \.)))
- (make-local-variable 'thlst)
- (setq thlst '(
- ((doc$ maybe)(doc$ thing)(doc$ isrelated) this \.)
- ((doc$ maybe)(doc$ things)(doc$ arerelated) this \.)
- (is it because of (doc$ things) that you are going through all this \?)
- (how do you reconcile (doc$ things) \? )
- ((doc$ maybe) this (doc$ isrelated)(doc$ things) \?) ))
- (make-local-variable 'remlst)
- (setq remlst '( (earlier you said (doc$ history) \?)
- (you mentioned that (doc$ history) \?)
- ((doc$ whysay)(doc$ history) \? ) ))
- (make-local-variable 'toklst)
- (setq toklst
- '((is this how you relax \?)
- (how long have you been smoking grass \?)
- ((doc$ areyou) (doc$ afraidof) of being drawn to using harder stuff \?)))
- (make-local-variable 'states)
- (setq states
- '((do you get (doc// found) often \?)
- (do you enjoy being (doc// found) \?)
- (what makes you (doc// found) \?)
- (how often (doc$ areyou)(doc// found) \?)
- (when were you last (doc// found) \?)))
- (make-local-variable 'replist)
- (setq replist
- '((i . (you))
- (my . (your))
- (me . (you))
- (you . (me))
- (your . (my))
- (mine . (yours))
- (yours . (mine))
- (our . (your))
- (ours . (yours))
- (we . (you))
- (dunno . (do not know))
-;; (yes . ())
- (no\, . ())
- (yes\, . ())
- (ya . (i))
- (aint . (am not))
- (wanna . (want to))
- (gimme . (give me))
- (gotta . (have to))
- (gonna . (going to))
- (never . (not ever))
- (doesn\'t . (does not))
- (don\'t . (do not))
- (aren\'t . (are not))
- (isn\'t . (is not))
- (won\'t . (will not))
- (can\'t . (cannot))
- (haven\'t . (have not))
- (i\'m . (you are))
- (ourselves . (yourselves))
- (myself . (yourself))
- (yourself . (myself))
- (you\'re . (i am))
- (you\'ve . (i have))
- (i\'ve . (you have))
- (i\'ll . (you will))
- (you\'ll . (i shall))
- (i\'d . (you would))
- (you\'d . (i would))
- (here . (there))
- (please . ())
- (eh\, . ())
- (eh . ())
- (oh\, . ())
- (oh . ())
- (shouldn\'t . (should not))
- (wouldn\'t . (would not))
- (won\'t . (will not))
- (hasn\'t . (has not))))
- (make-local-variable 'stallmanlst)
- (setq stallmanlst '(
- ((doc$ describe) your (doc$ feelings-about) him \.)
- ((doc$ areyou) a friend of Stallman \?)
- ((doc$ bother) Stallman is (doc$ random-adjective) \?)
- ((doc$ ibelieve) you are (doc$ afraidof) him \.)))
- (make-local-variable 'schoollst)
- (setq schoollst '(
- ((doc$ describe) your (doc// found) \.)
- ((doc$ bother) your grades could (doc$ improve) \?)
- ((doc$ areyou) (doc$ afraidof) (doc// found) \?)
- ((doc$ maybe) this (doc$ isrelated) to your attitude \.)
- ((doc$ areyou) absent often \?)
- ((doc$ maybe) you should study (doc$ something) \.)))
- (make-local-variable 'improve)
- (setq improve '((improve) (be better) (be improved) (be higher)))
- (make-local-variable 'elizalst)
- (setq elizalst '(
- ((doc$ areyou) (doc$ sure) \?)
- ((doc$ ibelieve) you have (doc$ problems) with (doc// found) \.)
- ((doc$ whysay) (doc// sent) \?)))
- (make-local-variable 'sportslst)
- (setq sportslst '(
- (tell me (doc$ something) about (doc// found) \.)
- ((doc$ describe) (doc$ relation) (doc// found) \.)
- (do you find (doc// found) (doc$ random-adjective) \?)))
- (make-local-variable 'mathlst)
- (setq mathlst '(
- ((doc$ describe) (doc$ something) about math \.)
- ((doc$ maybe) your (doc$ problems) (doc$ arerelated) (doc// found) \.)
- (i don\'t know much (doc// found) \, but (doc$ continue)
- anyway \.)))
- (make-local-variable 'zippylst)
- (setq zippylst '(
- ((doc$ areyou) Zippy \?)
- ((doc$ ibelieve) you have some serious (doc$ problems) \.)
- ((doc$ bother) you are a pinhead \?)))
- (make-local-variable 'chatlst)
- (setq chatlst '(
- ((doc$ maybe) we could chat \.)
- ((doc$ please) (doc$ describe) (doc$ something) about chat mode \.)
- ((doc$ bother) our discussion is so (doc$ random-adjective) \?)))
- (make-local-variable 'abuselst)
- (setq abuselst '(
- ((doc$ please) try to be less abusive \.)
- ((doc$ describe) why you call me (doc// found) \.)
- (i\'ve had enough of you!)))
- (make-local-variable 'abusewords)
- (setq abusewords '(boring bozo clown clumsy cretin dumb dummy
- fool foolish gnerd gnurd idiot jerk
- lose loser louse lousy luse luser
- moron nerd nurd oaf oafish reek
- stink stupid tool toolish twit))
- (make-local-variable 'howareyoulst)
- (setq howareyoulst '((how are you) (hows it going) (hows it going eh)
- (how\'s it going) (how\'s it going eh) (how goes it)
- (whats up) (whats new) (what\'s up) (what\'s new)
- (howre you) (how\'re you) (how\'s everything)
- (how is everything) (how do you do)
- (how\'s it hanging) (que pasa)
- (how are you doing) (what do you say)))
- (make-local-variable 'whereoutp)
- (setq whereoutp '( huh remem rthing ) )
- (make-local-variable 'subj)
- (setq subj nil)
- (make-local-variable 'verb)
- (setq verb nil)
- (make-local-variable 'obj)
- (setq obj nil)
- (make-local-variable 'feared)
- (setq feared nil)
- (make-local-variable 'repetitive-shortness)
- (setq repetitive-shortness '(0 . 0))
- (make-local-variable '**mad**)
- (setq **mad** nil)
- (make-local-variable 'rms-flag)
- (setq rms-flag nil)
- (make-local-variable 'eliza-flag)
- (setq eliza-flag nil)
- (make-local-variable 'zippy-flag)
- (setq zippy-flag nil)
- (make-local-variable 'suicide-flag)
- (setq suicide-flag nil)
- (make-local-variable 'lover)
- (setq lover '(your partner))
- (make-local-variable 'bak)
- (setq bak nil)
- (make-local-variable 'lincount)
- (setq lincount 0)
- (make-local-variable '*print-upcase*)
- (setq *print-upcase* nil)
- (make-local-variable '*print-space*)
- (setq *print-space* nil)
- (make-local-variable 'howdyflag)
- (setq howdyflag nil)
- (make-local-variable 'object)
- (setq object nil))
+ (set (make-local-variable 'doctor--typos)
+ (mapcar (lambda (x)
+ (put (car x) 'doctor-correction (cadr x))
+ (put (cadr x) 'doctor-expansion (car (cddr x)))
+ (car x))
+ '((theyll they\'ll (they will))
+ (theyre they\'re (they are))
+ (hes he\'s (he is))
+ (he7s he\'s (he is))
+ (im i\'m (you are))
+ (i7m i\'m (you are))
+ (isa is\ a (is a))
+ (thier their (their))
+ (dont don\'t (do not))
+ (don7t don\'t (do not))
+ (you7re you\'re (i am))
+ (you7ve you\'ve (i have))
+ (you7ll you\'ll (i will)))))
+ (set (make-local-variable 'doctor-found) nil)
+ (set (make-local-variable 'doctor-owner) nil)
+ (set (make-local-variable 'doctor--history) nil)
+ (set (make-local-variable 'doctor--inter) '((well\,)
+ (hmmm \.\.\.\ so\,)
+ (so)
+ (\.\.\.and)
+ (then)))
+ (set (make-local-variable 'doctor--continue) '((continue)
+ (proceed)
+ (go on)
+ (keep going)))
+ (set (make-local-variable 'doctor--relation)
+ '((your relationship with)
+ (something you remember about)
+ (your feelings toward)
+ (some experiences you have had with)
+ (how you feel about)))
+ (set (make-local-variable 'doctor--fears)
+ '(((doc$ doctor--whysay) you are (doc$ doctor--afraidof) (doc// doctor--feared) \?)
+ (you seem terrified by (doc// doctor--feared) \.)
+ (when did you first feel (doc$ doctor--afraidof) (doc// doctor--feared) \?)))
+ (set (make-local-variable 'doctor--sure) '((sure)
+ (positive)
+ (certain)
+ (absolutely sure)))
+ (set (make-local-variable 'doctor--afraidof) '((afraid of)
+ (frightened by)
+ (scared of)))
+ (set (make-local-variable 'doctor--areyou) '((are you)
+ (have you been)
+ (have you been)))
+ (set (make-local-variable 'doctor--isrelated)
+ '((has something to do with)
+ (is related to)
+ (could be the reason for)
+ (is caused by)
+ (is because of)))
+ (set (make-local-variable 'doctor--arerelated) '((have something to do with)
+ (are related to)
+ (could have caused)
+ (could be the reason for)
+ (are caused by)
+ (are because of)))
+ (set (make-local-variable 'doctor--moods)
+ '(((doc$ doctor--areyou) (doc// doctor-found) often \?)
+ (what causes you to be (doc// doctor-found) \?)
+ ((doc$ doctor--whysay) you are (doc// doctor-found) \?)))
+ (set (make-local-variable 'doctor--maybe) '((maybe)
+ (perhaps)
+ (possibly)))
+ (set (make-local-variable 'doctor--whatwhen) '((what happened when)
+ (what would happen if)))
+ (set (make-local-variable 'doctor--hello) '((how do you do \?)
+ (hello \.)
+ (howdy!)
+ (hello \.)
+ (hi \.)
+ (hi there \.)))
+ (set (make-local-variable 'doctor--drnk)
+ '((do you drink a lot of (doc// doctor-found) \?)
+ (do you get drunk often \?)
+ ((doc$ doctor--describe) your drinking habits \.)))
+ (set (make-local-variable 'doctor--drugs)
+ '((do you use (doc// doctor-found) often \?)
+ ((doc$ doctor--areyou) addicted to (doc// doctor-found) \?)
+ (do you realize that drugs can be very harmful \?)
+ ((doc$ doctor--maybe) you should try to quit using (doc// doctor-found) \.)))
+ (set (make-local-variable 'doctor--whywant)
+ '(((doc$ doctor--whysay) (doc// doctor-subj) might (doc$ doctor--want) (doc// doctor-obj) \?)
+ (how does it feel to want \?)
+ (why should (doc// doctor-subj) get (doc// doctor-obj) \?)
+ (when did (doc// doctor-subj) first (doc$ doctor--want) (doc// doctor-obj) \?)
+ ((doc$ doctor--areyou) obsessed with (doc// doctor-obj) \?)
+ (why should i give (doc// doctor-obj) to (doc// doctor-subj) \?)
+ (have you ever gotten (doc// doctor-obj) \?)))
+ (set (make-local-variable 'doctor--canyou)
+ '((of course i can \.)
+ (why should i \?)
+ (what makes you think i would even want to \?)
+ (i am the doctor\, i can do anything i damn please \.)
+ (not really\, it\'s not up to me \.)
+ (depends\, how important is it \?)
+ (i could\, but i don\'t think it would be a wise thing to do \.)
+ (can you \?)
+ (maybe i can\, maybe i can\'t \.\.\.)
+ (i don\'t think i should do that \.)))
+ (set (make-local-variable 'doctor--want) '((want) (desire) (wish) (want) (hope)))
+ (set (make-local-variable 'doctor--shortlst)
+ '((can you elaborate on that \?)
+ ((doc$ doctor--please) continue \.)
+ (go on\, don\'t be afraid \.)
+ (i need a little more detail please \.)
+ (you\'re being a bit brief\, (doc$ doctor--please) go into detail \.)
+ (can you be more explicit \?)
+ (and \?)
+ ((doc$ doctor--please) go into more detail \?)
+ (you aren\'t being very talkative today\!)
+ (is that all there is to it \?)
+ (why must you respond so briefly \?)))
+ (set (make-local-variable 'doctor--famlst)
+ '((tell me (doc$ doctor--something) about (doc// doctor-owner) family \.)
+ (you seem to dwell on (doc// doctor-owner) family \.)
+ ((doc$ doctor--areyou) hung up on (doc// doctor-owner) family \?)))
+ (set (make-local-variable 'doctor--huhlst)
+ '(((doc$ doctor--whysay)(doc// doctor-sent) \?)
+ (is it because of (doc$ doctor--things) that you say (doc// doctor-sent) \?)))
+ (set (make-local-variable 'doctor--longhuhlst)
+ '(((doc$ doctor--whysay) that \?)
+ (i don\'t understand \.)
+ ((doc$ doctor--thlst))
+ ((doc$ doctor--areyou) (doc$ doctor--afraidof) that \?)))
+ (set (make-local-variable 'doctor--feelings-about) '((feelings about)
+ (apprehensions toward)
+ (thoughts on)
+ (emotions toward)))
+ (set (make-local-variable 'doctor--random-adjective)
+ '((vivid)
+ (emotionally stimulating)
+ (exciting)
+ (boring)
+ (interesting)
+ (recent)
+ (random) ; how can we omit this?
+ (unusual)
+ (shocking)
+ (embarrassing)))
+ (set (make-local-variable 'doctor--whysay) '((why do you say)
+ (what makes you believe)
+ (are you sure that)
+ (do you really think)
+ (what makes you think)))
+ (set (make-local-variable 'doctor--isee) '((i see \.\.\.)
+ (yes\,)
+ (i understand \.)
+ (oh \.) ))
+ (set (make-local-variable 'doctor--please) '((please\,)
+ (i would appreciate it if you would)
+ (perhaps you could)
+ (please\,)
+ (would you please)
+ (why don\'t you)
+ (could you)))
+ (set (make-local-variable 'doctor--bye)
+ '((my secretary will send you a bill \.)
+ (bye bye \.)
+ (see ya \.)
+ (ok\, talk to you some other time \.)
+ (talk to you later \.)
+ (ok\, have fun \.)
+ (ciao \.)))
+ (set (make-local-variable 'doctor--something) '((something)
+ (more)
+ (how you feel)))
+ (set (make-local-variable 'doctor--thing) '((your life)
+ (your sex life)))
+ (set (make-local-variable 'doctor--things) '((your plans)
+ (the people you hang around with)
+ (problems at school)
+ (any hobbies you have)
+ (hangups you have)
+ (your inhibitions)
+ (some problems in your childhood)
+ (some problems at home)))
+ (set (make-local-variable 'doctor--describe) '((describe)
+ (tell me about)
+ (talk about)
+ (discuss)
+ (tell me more about)
+ (elaborate on)))
+ (set (make-local-variable 'doctor--ibelieve)
+ '((i believe) (i think) (i have a feeling) (it seems to me that)
+ (it looks like)))
+ (set (make-local-variable 'doctor--problems) '((problems)
+ (inhibitions)
+ (hangups)
+ (difficulties)
+ (anxieties)
+ (frustrations)))
+ (set (make-local-variable 'doctor--bother) '((does it bother you that)
+ (are you annoyed that)
+ (did you ever regret)
+ (are you sorry)
+ (are you satisfied with the fact that)))
+ (set (make-local-variable 'doctor--machlst)
+ '((you have your mind on (doc// doctor-found) \, it seems \.)
+ (you think too much about (doc// doctor-found) \.)
+ (you should try taking your mind off of (doc// doctor-found)\.)
+ (are you a computer hacker \?)))
+ (set (make-local-variable 'doctor--qlist)
+ '((what do you think \?)
+ (i\'ll ask the questions\, if you don\'t mind!)
+ (i could ask the same thing myself \.)
+ ((doc$ doctor--please) allow me to do the questioning \.)
+ (i have asked myself that question many times \.)
+ ((doc$ doctor--please) try to answer that question yourself \.)))
+ (set (make-local-variable 'doctor--foullst)
+ '(((doc$ doctor--please) watch your tongue!)
+ ((doc$ doctor--please) avoid such unwholesome thoughts \.)
+ ((doc$ doctor--please) get your mind out of the gutter \.)
+ (such lewdness is not appreciated \.)))
+ (set (make-local-variable 'doctor--deathlst)
+ '((this is not a healthy way of thinking \.)
+ ((doc$ doctor--bother) you\, too\, may die someday \?)
+ (i am worried by your obsession with this topic!)
+ (did you watch a lot of crime and violence on television as a child \?)))
+ (set (make-local-variable 'doctor--sexlst)
+ '(((doc$ doctor--areyou) (doc$ doctor--afraidof) sex \?)
+ ((doc$ doctor--describe)(doc$ doctor--something) about your sexual history \.)
+ ((doc$ doctor--please)(doc$ doctor--describe) your sex life \.\.\.)
+ ((doc$ doctor--describe) your (doc$ doctor--feelings-about) your sexual partner \.)
+ ((doc$ doctor--describe) your most (doc$ doctor--random-adjective) sexual experience \.)
+ ((doc$ doctor--areyou) satisfied with (doc// doctor--lover) \.\.\. \?)))
+ (set (make-local-variable 'doctor--neglst) '((why not \?)
+ ((doc$ doctor--bother) i ask that \?)
+ (why not \?)
+ (why not \?)
+ (how come \?)
+ ((doc$ doctor--bother) i ask that \?)))
+ (set (make-local-variable 'doctor--beclst)
+ '((is it because (doc// doctor-sent) that you came to me \?)
+ ((doc$ doctor--bother)(doc// doctor-sent) \?)
+ (when did you first know that (doc// doctor-sent) \?)
+ (is the fact that (doc// doctor-sent) the real reason \?)
+ (does the fact that (doc// doctor-sent) explain anything else \?)
+ ((doc$ doctor--areyou)(doc$ doctor--sure)(doc// doctor-sent) \? )))
+ (set (make-local-variable 'doctor--shortbeclst)
+ '(((doc$ doctor--bother) i ask you that \?)
+ (that\'s not much of an answer!)
+ ((doc$ doctor--inter) why won\'t you talk about it \?)
+ (speak up!)
+ ((doc$ doctor--areyou) (doc$ doctor--afraidof) talking about it \?)
+ (don\'t be (doc$ doctor--afraidof) elaborating \.)
+ ((doc$ doctor--please) go into more detail \.)))
+ (set (make-local-variable 'doctor--thlst)
+ '(((doc$ doctor--maybe)(doc$ doctor--thing)(doc$ doctor--isrelated) this \.)
+ ((doc$ doctor--maybe)(doc$ doctor--things)(doc$ doctor--arerelated) this \.)
+ (is it because of (doc$ doctor--things) that you are going through all this \?)
+ (how do you reconcile (doc$ doctor--things) \? )
+ ((doc$ doctor--maybe) this (doc$ doctor--isrelated)(doc$ doctor--things) \?)))
+ (set (make-local-variable 'doctor--remlst)
+ '((earlier you said (doc$ doctor--history) \?)
+ (you mentioned that (doc$ doctor--history) \?)
+ ((doc$ doctor--whysay)(doc$ doctor--history) \? )))
+ (set (make-local-variable 'doctor--toklst)
+ '((is this how you relax \?)
+ (how long have you been smoking grass \?)
+ ((doc$ doctor--areyou) (doc$ doctor--afraidof) of being drawn to using harder stuff \?)))
+ (set (make-local-variable 'doctor--states)
+ '((do you get (doc// doctor-found) often \?)
+ (do you enjoy being (doc// doctor-found) \?)
+ (what makes you (doc// doctor-found) \?)
+ (how often (doc$ doctor--areyou)(doc// doctor-found) \?)
+ (when were you last (doc// doctor-found) \?)))
+ (set (make-local-variable 'doctor--replist) '((i . (you))
+ (my . (your))
+ (me . (you))
+ (you . (me))
+ (your . (my))
+ (mine . (yours))
+ (yours . (mine))
+ (our . (your))
+ (ours . (yours))
+ (we . (you))
+ (dunno . (do not know))
+ ;; (yes . ())
+ (no\, . ())
+ (yes\, . ())
+ (ya . (i))
+ (aint . (am not))
+ (wanna . (want to))
+ (gimme . (give me))
+ (gotta . (have to))
+ (gonna . (going to))
+ (never . (not ever))
+ (doesn\'t . (does not))
+ (don\'t . (do not))
+ (aren\'t . (are not))
+ (isn\'t . (is not))
+ (won\'t . (will not))
+ (can\'t . (cannot))
+ (haven\'t . (have not))
+ (i\'m . (you are))
+ (ourselves . (yourselves))
+ (myself . (yourself))
+ (yourself . (myself))
+ (you\'re . (i am))
+ (you\'ve . (i have))
+ (i\'ve . (you have))
+ (i\'ll . (you will))
+ (you\'ll . (i shall))
+ (i\'d . (you would))
+ (you\'d . (i would))
+ (here . (there))
+ (please . ())
+ (eh\, . ())
+ (eh . ())
+ (oh\, . ())
+ (oh . ())
+ (shouldn\'t . (should not))
+ (wouldn\'t . (would not))
+ (won\'t . (will not))
+ (hasn\'t . (has not))))
+ (set (make-local-variable 'doctor--stallmanlst)
+ '(((doc$ doctor--describe) your (doc$ doctor--feelings-about) him \.)
+ ((doc$ doctor--areyou) a friend of Stallman \?)
+ ((doc$ doctor--bother) Stallman is (doc$ doctor--random-adjective) \?)
+ ((doc$ doctor--ibelieve) you are (doc$ doctor--afraidof) him \.)))
+ (set (make-local-variable 'doctor--schoollst)
+ '(((doc$ doctor--describe) your (doc// doctor-found) \.)
+ ((doc$ doctor--bother) your grades could (doc$ doctor--improve) \?)
+ ((doc$ doctor--areyou) (doc$ doctor--afraidof) (doc// doctor-found) \?)
+ ((doc$ doctor--maybe) this (doc$ doctor--isrelated) to your attitude \.)
+ ((doc$ doctor--areyou) absent often \?)
+ ((doc$ doctor--maybe) you should study (doc$ doctor--something) \.)))
+ (set (make-local-variable 'doctor--improve)
+ '((improve) (be better) (be improved) (be higher)))
+ (set (make-local-variable 'doctor--elizalst)
+ '(((doc$ doctor--areyou) (doc$ doctor--sure) \?)
+ ((doc$ doctor--ibelieve) you have (doc$ doctor--problems) with (doc// doctor-found) \.)
+ ((doc$ doctor--whysay) (doc// doctor-sent) \?)))
+ (set (make-local-variable 'doctor--sportslst)
+ '((tell me (doc$ doctor--something) about (doc// doctor-found) \.)
+ ((doc$ doctor--describe) (doc$ doctor--relation) (doc// doctor-found) \.)
+ (do you find (doc// doctor-found) (doc$ doctor--random-adjective) \?)))
+ (set (make-local-variable 'doctor--mathlst)
+ '(((doc$ doctor--describe) (doc$ doctor--something) about math \.)
+ ((doc$ doctor--maybe) your (doc$ doctor--problems) (doc$ doctor--arerelated) (doc// doctor-found) \.)
+ (i don\'t know much (doc// doctor-found) \, but (doc$ doctor--continue)
+ anyway \.)))
+ (set (make-local-variable 'doctor--zippylst)
+ '(((doc$ doctor--areyou) Zippy \?)
+ ((doc$ doctor--ibelieve) you have some serious (doc$ doctor--problems) \.)
+ ((doc$ doctor--bother) you are a pinhead \?)))
+ (set (make-local-variable 'doctor--chatlst)
+ '(((doc$ doctor--maybe) we could chat \.)
+ ((doc$ doctor--please) (doc$ doctor--describe) (doc$ doctor--something) about chat mode \.)
+ ((doc$ doctor--bother) our discussion is so (doc$ doctor--random-adjective) \?)))
+ (set (make-local-variable 'doctor--abuselst)
+ '(((doc$ doctor--please) try to be less abusive \.)
+ ((doc$ doctor--describe) why you call me (doc// doctor-found) \.)
+ (i\'ve had enough of you!)))
+ (set (make-local-variable 'doctor--abusewords)
+ '(boring bozo clown clumsy cretin dumb dummy
+ fool foolish gnerd gnurd idiot jerk
+ lose loser louse lousy luse luser
+ moron nerd nurd oaf oafish reek
+ stink stupid tool toolish twit))
+ (set (make-local-variable 'doctor--howareyoulst)
+ '((how are you) (hows it going) (hows it going eh)
+ (how\'s it going) (how\'s it going eh) (how goes it)
+ (whats up) (whats new) (what\'s up) (what\'s new)
+ (howre you) (how\'re you) (how\'s everything)
+ (how is everything) (how do you do)
+ (how\'s it hanging) (que pasa)
+ (how are you doing) (what do you say)))
+ (set (make-local-variable 'doctor--whereoutp) '(huh remem rthing))
+ (set (make-local-variable 'doctor-subj) nil)
+ (set (make-local-variable 'doctor-verb) nil)
+ (set (make-local-variable 'doctor-obj) nil)
+ (set (make-local-variable 'doctor--feared) nil)
+ (set (make-local-variable 'doctor--repetitive-shortness) '(0 . 0))
+ (set (make-local-variable 'doctor--**mad**) nil)
+ (set (make-local-variable 'doctor--rms-flag) nil)
+ (set (make-local-variable 'doctor--eliza-flag) nil)
+ (set (make-local-variable 'doctor--zippy-flag) nil)
+ (set (make-local-variable 'doctor--suicide-flag) nil)
+ (set (make-local-variable 'doctor--lover) '(your partner))
+ (set (make-local-variable 'doctor--bak) nil)
+ (set (make-local-variable 'doctor--lincount) 0)
+ (set (make-local-variable 'doctor--*print-upcase*) nil)
+ (set (make-local-variable 'doctor--*print-space*) nil)
+ (set (make-local-variable 'doctor--howdyflag) nil)
+ (set (make-local-variable 'doctor-object) nil))
;; Define equivalence classes of words that get treated alike.
(defun doctor-meaning (x) (get x 'doctor-meaning))
(defmacro doctor-put-meaning (symb val)
- "Store the base meaning of a word on the property list."
- (list 'put (list 'quote symb) ''doctor-meaning val))
+ "Store the base meaning of a word on the property list."
+ `(put ',symb 'doctor-meaning ,val))
(doctor-put-meaning howdy 'howdy)
(doctor-put-meaning hi 'howdy)
@@ -855,10 +836,10 @@ Otherwise call the Doctor to parse preceding sentence."
(interactive)
(let ((sent (doctor-readin)))
(insert "\n")
- (setq lincount (1+ lincount))
+ (setq doctor--lincount (1+ doctor--lincount))
(doctor-doc sent)
(insert "\n")
- (setq bak sent)))
+ (setq doctor--bak sent)))
(defun doctor-readin nil
"Read a sentence. Return it as a list of words."
@@ -878,70 +859,70 @@ Otherwise call the Doctor to parse preceding sentence."
;; Main processing function for sentences that have been read.
-(defun doctor-doc (sent)
+(defun doctor-doc (doctor-sent)
(cond
- ((equal sent '(foo))
- (doctor-type '(bar! (doc$ please)(doc$ continue) \.)))
- ((member sent howareyoulst)
- (doctor-type '(i\'m ok \. (doc$ describe) yourself \.)))
- ((or (member sent '((good bye) (see you later) (i quit) (so long)
+ ((equal doctor-sent '(foo))
+ (doctor-type '(bar! (doc$ doctor--please)(doc$ doctor--continue) \.)))
+ ((member doctor-sent doctor--howareyoulst)
+ (doctor-type '(i\'m ok \. (doc$ doctor--describe) yourself \.)))
+ ((or (member doctor-sent '((good bye) (see you later) (i quit) (so long)
(go away) (get lost)))
- (memq (car sent)
+ (memq (car doctor-sent)
'(bye halt break quit done exit goodbye
bye\, stop pause goodbye\, stop pause)))
- (doctor-type (doc$ bye)))
- ((and (eq (car sent) 'you)
- (memq (cadr sent) abusewords))
- (setq found (cadr sent))
- (doctor-type (doc$ abuselst)))
- ((eq (car sent) 'whatmeans)
- (doctor-def (cadr sent)))
- ((equal sent '(parse))
- (doctor-type (list 'subj '= subj ", "
- 'verb '= verb "\n"
- 'object 'phrase '= obj ","
- 'noun 'form '= object "\n"
- 'current 'keyword 'is found
+ (doctor-type (doc$ doctor--bye)))
+ ((and (eq (car doctor-sent) 'you)
+ (memq (cadr doctor-sent) doctor--abusewords))
+ (setq doctor-found (cadr doctor-sent))
+ (doctor-type (doc$ doctor--abuselst)))
+ ((eq (car doctor-sent) 'whatmeans)
+ (doctor-def (cadr doctor-sent)))
+ ((equal doctor-sent '(parse))
+ (doctor-type (list 'subj '= doctor-subj ", "
+ 'verb '= doctor-verb "\n"
+ 'object 'phrase '= doctor-obj ","
+ 'noun 'form '= doctor-object "\n"
+ 'current 'keyword 'is doctor-found
", "
'most 'recent 'possessive
- 'is owner "\n"
+ 'is doctor-owner "\n"
'sentence 'used 'was
"..."
- '(doc// bak))))
- ((memq (car sent) '(are is do has have how when where who why))
- (doctor-type (doc$ qlist)))
- ;; ((eq (car sent) 'forget)
- ;; (set (cadr sent) nil)
- ;; (doctor-type '((doc$ isee)(doc$ please)
- ;; (doc$ continue)\.)))
+ '(doc// doctor--bak))))
+ ((memq (car doctor-sent) '(are is do has have how when where who why))
+ (doctor-type (doc$ doctor--qlist)))
+ ;; ((eq (car doctor-sent) 'forget)
+ ;; (set (cadr doctor-sent) nil)
+ ;; (doctor-type '((doc$ doctor--isee)(doc$ doctor--please)
+ ;; (doc$ doctor--continue)\.)))
(t
- (if (doctor-defq sent) (doctor-define sent found))
- (if (> (length sent) 12)(setq sent (doctor-shorten sent)))
- (setq sent (doctor-correct-spelling (doctor-replace sent replist)))
- (cond ((and (not (memq 'me sent))(not (memq 'i sent))
- (memq 'am sent))
- (setq sent (doctor-replace sent '((am . (are)))))))
- (cond ((equal (car sent) 'yow) (doctor-zippy))
- ((< (length sent) 2)
- (cond ((eq (doctor-meaning (car sent)) 'howdy)
+ (if (doctor-defq doctor-sent) (doctor-define doctor-sent doctor-found))
+ (if (> (length doctor-sent) 12)(setq doctor-sent (doctor-shorten doctor-sent)))
+ (setq doctor-sent (doctor-correct-spelling (doctor-replace doctor-sent doctor--replist)))
+ (cond ((and (not (memq 'me doctor-sent))(not (memq 'i doctor-sent))
+ (memq 'am doctor-sent))
+ (setq doctor-sent (doctor-replace doctor-sent '((am . (are)))))))
+ (cond ((equal (car doctor-sent) 'yow) (doctor-zippy))
+ ((< (length doctor-sent) 2)
+ (cond ((eq (doctor-meaning (car doctor-sent)) 'howdy)
(doctor-howdy))
(t (doctor-short))))
(t
- (if (memq 'am sent)
- (setq sent (doctor-replace sent '((me . (i))))))
- (setq sent (doctor-fixup sent))
- (if (and (eq (car sent) 'do) (eq (cadr sent) 'not))
+ (if (memq 'am doctor-sent)
+ (setq doctor-sent (doctor-replace doctor-sent '((me . (i))))))
+ (setq doctor-sent (doctor-fixup doctor-sent))
+ (if (and (eq (car doctor-sent) 'do) (eq (cadr doctor-sent) 'not))
(cond ((zerop (random 3))
- (doctor-type '(are you (doc$ afraidof) that \?)))
+ (doctor-type '(are you (doc$ doctor--afraidof) that \?)))
((zerop (random 2))
(doctor-type '(don\'t tell me what to do \. i am the
doctor here!))
(doctor-rthing))
(t
- (doctor-type '((doc$ whysay) that i shouldn\'t
- (cddr sent)
+ (doctor-type '((doc$ doctor--whysay) that i shouldn\'t
+ (cddr doctor-sent)
\?))))
- (doctor-go (doctor-wherego sent))))))))
+ (doctor-go (doctor-wherego doctor-sent))))))))
;; Things done to process sentences once read.
@@ -949,8 +930,9 @@ Otherwise call the Doctor to parse preceding sentence."
"Correct the spelling and expand each word in sentence."
(if sent
(apply 'append (mapcar (lambda (word)
- (if (memq word typos)
- (get (get word 'doctor-correction) 'doctor-expansion)
+ (if (memq word doctor--typos)
+ (get (get word 'doctor-correction)
+ 'doctor-expansion)
(list word)))
sent))))
@@ -972,33 +954,32 @@ Otherwise call the Doctor to parse preceding sentence."
(defun doctor-define (sent found)
(doctor-svo sent found 1 nil)
(and
- (doctor-nounp subj)
- (not (doctor-pronounp subj))
- subj
- (doctor-meaning object)
- (put subj 'doctor-meaning (doctor-meaning object))
+ (doctor-nounp doctor-subj)
+ (not (doctor-pronounp doctor-subj))
+ doctor-subj
+ (doctor-meaning doctor-object)
+ (put doctor-subj 'doctor-meaning (doctor-meaning doctor-object))
t))
(defun doctor-defq (sent)
- "Set global var FOUND to first keyword found in sentence SENT."
- (setq found nil)
+ "Set global var DOCTOR-FOUND to first keyword found in sentence SENT."
+ (setq doctor-found nil)
(let ((temp '(means applies mean refers refer related
similar defined associated linked like same)))
(while temp
(if (memq (car temp) sent)
- (setq found (car temp)
+ (setq doctor-found (car temp)
temp nil)
(setq temp (cdr temp)))))
- found)
+ doctor-found)
(defun doctor-def (x)
- (progn
- (doctor-type (list 'the 'word x 'means (doctor-meaning x) 'to 'me))
- nil))
+ (doctor-type (list 'the 'word x 'means (doctor-meaning x) 'to 'me))
+ nil)
(defun doctor-forget ()
"Delete the last element of the history list."
- (setq history (reverse (cdr (reverse history)))))
+ (setq doctor--history (reverse (cdr (reverse doctor--history)))))
(defun doctor-query (x)
"Prompt for a line of input from the minibuffer until a noun or verb is seen.
@@ -1026,16 +1007,16 @@ Put dialogue in buffer."
(defun doctor-subjsearch (sent key type)
"Search for the subject of a sentence SENT, looking for the noun closest
-to and preceding KEY by at least TYPE words. Set global variable subj to
+to and preceding KEY by at least TYPE words. Set global variable doctor-subj to
the subject noun, and return the portion of the sentence following it."
(let ((i (- (length sent) (length (memq key sent)) type)))
(while (and (> i -1) (not (doctor-nounp (nth i sent))))
(setq i (1- i)))
(cond ((> i -1)
- (setq subj (nth i sent))
+ (setq doctor-subj (nth i sent))
(nthcdr (1+ i) sent))
(t
- (setq subj 'you)
+ (setq doctor-subj 'you)
nil))))
(defun doctor-nounp (x)
@@ -1149,12 +1130,12 @@ the subject noun, and return the portion of the sentence following it."
(t 'something))))
(defun doctor-getnoun (x)
- (cond ((null x)(setq object 'something))
- ((atom x)(setq object x))
+ (cond ((null x)(setq doctor-object 'something))
+ ((atom x)(setq doctor-object x))
((eq (length x) 1)
- (setq object (cond
- ((doctor-nounp (setq object (car x))) object)
- (t (doctor-query object)))))
+ (setq doctor-object (cond
+ ((doctor-nounp (setq doctor-object (car x))) doctor-object)
+ (t (doctor-query doctor-object)))))
((eq (car x) 'to)
(doctor-build 'to\ (doctor-getnoun (cdr x))))
((doctor-prepp (car x))
@@ -1170,7 +1151,7 @@ the subject noun, and return the portion of the sentence following it."
(car x) (car x))))))
" ")
(doctor-getnoun (cdr x))))
- (t (setq object (car x))
+ (t (setq doctor-object (car x))
(doctor-build (doctor-build (car x) " ") (doctor-getnoun (cdr x))))
))
@@ -1238,9 +1219,9 @@ the subject noun, and return the portion of the sentence following it."
under underneath with without)))
(defun doctor-remember (thing)
- (cond ((null history)
- (setq history (list thing)))
- (t (setq history (append history (list thing))))))
+ (cond ((null doctor--history)
+ (setq doctor--history (list thing)))
+ (t (setq doctor--history (append doctor--history (list thing))))))
(defun doctor-type (x)
(setq x (doctor-fix-2 x))
@@ -1317,57 +1298,58 @@ the subject noun, and return the portion of the sentence following it."
element pair in RLIST."
(apply 'append
(mapcar
- (function
(lambda (x)
(cdr (or (assq x rlist) ; either find a replacement
- (list x x))))) ; or fake an identity mapping
- sent)))
+ (list x x)))) ; or fake an identity mapping
+ sent)))
(defun doctor-wherego (sent)
- (cond ((null sent)(doc$ whereoutp))
+ (cond ((null sent)(doc$ doctor--whereoutp))
((null (doctor-meaning (car sent)))
(doctor-wherego (cond ((zerop (random 2))
(reverse (cdr sent)))
(t (cdr sent)))))
(t
- (setq found (car sent))
+ (setq doctor-found (car sent))
(doctor-meaning (car sent)))))
(defun doctor-svo (sent key type mem)
"Find subject, verb and object in sentence SENT with focus on word KEY.
TYPE is number of words preceding KEY to start looking for subject.
MEM is t if results are to be put on Doctor's memory stack.
-Return in the global variables SUBJ, VERB and OBJECT."
+Return in the global variables DOCTOR-SUBJ, DOCTOR-VERB, DOCTOR-OBJECT,
+and DOCTOR-OBJ."
(let ((foo (doctor-subjsearch sent key type)))
(or foo
(setq foo sent
mem nil))
(while (and (null (doctor-verbp (car foo))) (cdr foo))
(setq foo (cdr foo)))
- (setq verb (car foo))
- (setq obj (doctor-getnoun (cdr foo)))
- (cond ((eq object 'i)(setq object 'me))
- ((eq subj 'me)(setq subj 'i)))
- (cond (mem (doctor-remember (list subj verb obj))))))
+ (setq doctor-verb (car foo))
+ (setq doctor-obj (doctor-getnoun (cdr foo)))
+ (cond ((eq doctor-object 'i)(setq doctor-object 'me))
+ ((eq doctor-subj 'me)(setq doctor-subj 'i)))
+ (cond (mem (doctor-remember (list doctor-subj doctor-verb doctor-obj))))))
(defun doctor-possess (sent key)
"Set possessive in SENT for keyword KEY.
-Hack on previous word, setting global variable OWNER to correct result."
+Hack on previous word, setting global variable DOCTOR-OWNER to correct result."
(let* ((i (- (length sent) (length (memq key sent)) 1))
(prev (if (< i 0) 'your
(nth i sent))))
- (setq owner (if (or (doctor-possessivepronounp prev)
- (string-equal "s"
- (substring (doctor-make-string prev)
- -1)))
- prev
- 'your))))
+ (setq doctor-owner
+ (if (or (doctor-possessivepronounp prev)
+ (string-equal "s"
+ (substring (doctor-make-string prev)
+ -1)))
+ prev
+ 'your))))
;; Output of replies.
(defun doctor-txtype (ans)
"Output to buffer a list of symbols or strings as a sentence."
- (setq *print-upcase* t *print-space* nil)
+ (setq doctor--*print-upcase* t doctor--*print-space* nil)
(mapc 'doctor-type-symbol ans)
(insert "\n"))
@@ -1375,20 +1357,18 @@ Hack on previous word, setting global variable OWNER to correct result."
"Output a symbol to the buffer with some fancy case and spacing hacks."
(setq word (doctor-make-string word))
(if (string-equal word "i") (setq word "I"))
- (if *print-upcase*
- (progn
- (setq word (capitalize word))
- (if *print-space*
- (insert " "))))
+ (when doctor--*print-upcase*
+ (setq word (capitalize word))
+ (if doctor--*print-space* (insert " ")))
(cond ((or (string-match "^[.,;:?! ]" word)
- (not *print-space*))
+ (not doctor--*print-space*))
(insert word))
(t (insert ?\s word)))
(and auto-fill-function
(> (current-column) fill-column)
(apply auto-fill-function nil))
- (setq *print-upcase* (string-match "[.?!]$" word)
- *print-space* t))
+ (setq doctor--*print-upcase* (string-match "[.?!]$" word)
+ doctor--*print-space* t))
(defun doctor-build (str1 str2)
"Make a symbol out of the concatenation of the two non-list arguments."
@@ -1426,220 +1406,219 @@ Hack on previous word, setting global variable OWNER to correct result."
(funcall (intern (concat "doctor-" (doctor-make-string destination)))))
(defun doctor-desire1 ()
- (doctor-go (doc$ whereoutp)))
+ (doctor-go (doc$ doctor--whereoutp)))
(defun doctor-huh ()
- (cond ((< (length sent) 9) (doctor-type (doc$ huhlst)))
- (t (doctor-type (doc$ longhuhlst)))))
+ (cond ((< (length doctor-sent) 9) (doctor-type (doc$ doctor--huhlst)))
+ (t (doctor-type (doc$ doctor--longhuhlst)))))
-(defun doctor-rthing () (doctor-type (doc$ thlst)))
+(defun doctor-rthing () (doctor-type (doc$ doctor--thlst)))
-(defun doctor-remem () (cond ((null history)(doctor-huh))
- ((doctor-type (doc$ remlst)))))
+(defun doctor-remem () (cond ((null doctor--history)(doctor-huh))
+ ((doctor-type (doc$ doctor--remlst)))))
(defun doctor-howdy ()
- (cond ((not howdyflag)
- (doctor-type '((doc$ hello) what brings you to see me \?))
- (setq howdyflag t))
+ (cond ((not doctor--howdyflag)
+ (doctor-type '((doc$ doctor--hello) what brings you to see me \?))
+ (setq doctor--howdyflag t))
(t
- (doctor-type '((doc$ ibelieve) we\'ve introduced ourselves already \.))
- (doctor-type '((doc$ please) (doc$ describe) (doc$ things) \.)))))
+ (doctor-type '((doc$ doctor--ibelieve) we\'ve introduced ourselves already \.))
+ (doctor-type '((doc$ doctor--please) (doc$ doctor--describe) (doc$ doctor--things) \.)))))
(defun doctor-when ()
- (cond ((< (length (memq found sent)) 3)(doctor-short))
+ (cond ((< (length (memq doctor-found doctor-sent)) 3)(doctor-short))
(t
- (setq sent (cdr (memq found sent)))
- (setq sent (doctor-fixup sent))
- (doctor-type '((doc$ whatwhen)(doc// sent) \?)))))
+ (setq doctor-sent (cdr (memq doctor-found doctor-sent)))
+ (setq doctor-sent (doctor-fixup doctor-sent))
+ (doctor-type '((doc$ doctor--whatwhen)(doc// doctor-sent) \?)))))
(defun doctor-conj ()
- (cond ((< (length (memq found sent)) 4)(doctor-short))
+ (cond ((< (length (memq doctor-found doctor-sent)) 4)(doctor-short))
(t
- (setq sent (cdr (memq found sent)))
- (setq sent (doctor-fixup sent))
- (cond ((eq (car sent) 'of)
- (doctor-type '(are you (doc$ sure) that is the real reason \?))
- (setq things (cons (cdr sent) things)))
+ (setq doctor-sent (cdr (memq doctor-found doctor-sent)))
+ (setq doctor-sent (doctor-fixup doctor-sent))
+ (cond ((eq (car doctor-sent) 'of)
+ (doctor-type '(are you (doc$ doctor--sure) that is the real reason \?))
+ (setq doctor--things (cons (cdr doctor-sent) doctor--things)))
(t
- (doctor-remember sent)
- (doctor-type (doc$ beclst)))))))
+ (doctor-remember doctor-sent)
+ (doctor-type (doc$ doctor--beclst)))))))
(defun doctor-short ()
- (cond ((= (car repetitive-shortness) (1- lincount))
- (rplacd repetitive-shortness
- (1+ (cdr repetitive-shortness))))
+ (cond ((= (car doctor--repetitive-shortness) (1- doctor--lincount))
+ (rplacd doctor--repetitive-shortness
+ (1+ (cdr doctor--repetitive-shortness))))
(t
- (rplacd repetitive-shortness 1)))
- (rplaca repetitive-shortness lincount)
- (cond ((> (cdr repetitive-shortness) 6)
- (cond ((not **mad**)
- (doctor-type '((doc$ areyou)
+ (rplacd doctor--repetitive-shortness 1)))
+ (rplaca doctor--repetitive-shortness doctor--lincount)
+ (cond ((> (cdr doctor--repetitive-shortness) 6)
+ (cond ((not doctor--**mad**)
+ (doctor-type '((doc$ doctor--areyou)
just trying to see what kind of things
i have in my vocabulary \? please try to
carry on a reasonable conversation!))
- (setq **mad** t))
+ (setq doctor--**mad** t))
(t
(doctor-type '(i give up \. you need a lesson in creative
writing \.\.\.))
)))
(t
- (cond ((equal sent (doctor-assm '(yes)))
- (doctor-type '((doc$ isee) (doc$ inter) (doc$ whysay) this is so \?)))
- ((equal sent (doctor-assm '(because)))
- (doctor-type (doc$ shortbeclst)))
- ((equal sent (doctor-assm '(no)))
- (doctor-type (doc$ neglst)))
- (t (doctor-type (doc$ shortlst)))))))
+ (cond ((equal doctor-sent (doctor-assm '(yes)))
+ (doctor-type '((doc$ doctor--isee) (doc$ doctor--inter) (doc$ doctor--whysay) this is so \?)))
+ ((equal doctor-sent (doctor-assm '(because)))
+ (doctor-type (doc$ doctor--shortbeclst)))
+ ((equal doctor-sent (doctor-assm '(no)))
+ (doctor-type (doc$ doctor--neglst)))
+ (t (doctor-type (doc$ doctor--shortlst)))))))
-(defun doctor-alcohol () (doctor-type (doc$ drnk)))
+(defun doctor-alcohol () (doctor-type (doc$ doctor--drnk)))
(defun doctor-desire ()
- (let ((foo (memq found sent)))
+ (let ((foo (memq doctor-found doctor-sent)))
(cond ((< (length foo) 2)
- (doctor-go (doctor-build (doctor-meaning found) 1)))
+ (doctor-go (doctor-build (doctor-meaning doctor-found) 1)))
((memq (cadr foo) '(a an))
(rplacd foo (append '(to have) (cdr foo)))
- (doctor-svo sent found 1 nil)
- (doctor-remember (list subj 'would 'like obj))
- (doctor-type (doc$ whywant)))
+ (doctor-svo doctor-sent doctor-found 1 nil)
+ (doctor-remember (list doctor-subj 'would 'like doctor-obj))
+ (doctor-type (doc$ doctor--whywant)))
((not (eq (cadr foo) 'to))
- (doctor-go (doctor-build (doctor-meaning found) 1)))
+ (doctor-go (doctor-build (doctor-meaning doctor-found) 1)))
(t
- (doctor-svo sent found 1 nil)
- (doctor-remember (list subj 'would 'like obj))
- (doctor-type (doc$ whywant))))))
+ (doctor-svo doctor-sent doctor-found 1 nil)
+ (doctor-remember (list doctor-subj 'would 'like doctor-obj))
+ (doctor-type (doc$ doctor--whywant))))))
(defun doctor-drug ()
- (doctor-type (doc$ drugs))
- (doctor-remember (list 'you 'used found)))
+ (doctor-type (doc$ doctor--drugs))
+ (doctor-remember (list 'you 'used doctor-found)))
(defun doctor-toke ()
- (doctor-type (doc$ toklst)))
+ (doctor-type (doc$ doctor--toklst)))
(defun doctor-state ()
- (doctor-type (doc$ states))(doctor-remember (list 'you 'were found)))
+ (doctor-type (doc$ doctor--states))(doctor-remember (list 'you 'were doctor-found)))
(defun doctor-mood ()
- (doctor-type (doc$ moods))(doctor-remember (list 'you 'felt found)))
+ (doctor-type (doc$ doctor--moods))(doctor-remember (list 'you 'felt doctor-found)))
(defun doctor-fear ()
- (setq feared (doctor-setprep sent found))
- (doctor-type (doc$ fears))
- (doctor-remember (list 'you 'were 'afraid 'of feared)))
+ (setq doctor--feared (doctor-setprep doctor-sent doctor-found))
+ (doctor-type (doc$ doctor--fears))
+ (doctor-remember (list 'you 'were 'afraid 'of doctor--feared)))
(defun doctor-hate ()
- (doctor-svo sent found 1 t)
- (cond ((memq 'not sent) (doctor-forget) (doctor-huh))
- ((equal subj 'you)
- (doctor-type '(why do you (doc// verb)(doc// obj) \?)))
- (t (doctor-type '((doc$ whysay)(list subj verb obj))))))
+ (doctor-svo doctor-sent doctor-found 1 t)
+ (cond ((memq 'not doctor-sent) (doctor-forget) (doctor-huh))
+ ((equal doctor-subj 'you)
+ (doctor-type '(why do you (doc// doctor-verb)(doc// doctor-obj) \?)))
+ (t (doctor-type '((doc$ doctor--whysay)(list doctor-subj doctor-verb doctor-obj))))))
(defun doctor-symptoms ()
- (doctor-type '((doc$ maybe) you should consult a medical doctor\;
+ (doctor-type '((doc$ doctor--maybe) you should consult a medical doctor\;
i am a psychotherapist. \.)))
(defun doctor-hates ()
- (doctor-svo sent found 1 t)
+ (doctor-svo doctor-sent doctor-found 1 t)
(doctor-hates1))
(defun doctor-hates1 ()
- (doctor-type '((doc$ whysay)(list subj verb obj) \?)))
+ (doctor-type '((doc$ doctor--whysay)(list doctor-subj doctor-verb doctor-obj) \?)))
(defun doctor-loves ()
- (doctor-svo sent found 1 t)
+ (doctor-svo doctor-sent doctor-found 1 t)
(doctor-qloves))
(defun doctor-qloves ()
- (doctor-type '((doc$ bother)(list subj verb obj) \?)))
+ (doctor-type '((doc$ doctor--bother)(list doctor-subj doctor-verb doctor-obj) \?)))
(defun doctor-love ()
- (doctor-svo sent found 1 t)
- (cond ((memq 'not sent) (doctor-forget) (doctor-huh))
- ((memq 'to sent) (doctor-hates1))
+ (doctor-svo doctor-sent doctor-found 1 t)
+ (cond ((memq 'not doctor-sent) (doctor-forget) (doctor-huh))
+ ((memq 'to doctor-sent) (doctor-hates1))
(t
- (cond ((equal object 'something)
- (setq object '(this person you love))))
- (cond ((equal subj 'you)
- (setq lover obj)
- (cond ((equal lover '(this person you love))
- (setq lover '(your partner))
+ (cond ((equal doctor-object 'something)
+ (setq doctor-object '(this person you love))))
+ (cond ((equal doctor-subj 'you)
+ (setq doctor--lover doctor-obj)
+ (cond ((equal doctor--lover '(this person you love))
+ (setq doctor--lover '(your partner))
(doctor-forget)
(doctor-type '(with whom are you in love \?)))
- ((doctor-type '((doc$ please)
- (doc$ describe)
- (doc$ relation)
- (doc// lover)
+ ((doctor-type '((doc$ doctor--please)
+ (doc$ doctor--describe)
+ (doc$ doctor--relation)
+ (doc// doctor--lover)
\.)))))
- ((equal subj 'i)
+ ((equal doctor-subj 'i)
(doctor-txtype '(we were discussing you!)))
(t (doctor-forget)
- (setq obj 'someone)
- (setq verb (doctor-build verb 's))
+ (setq doctor-obj 'someone)
+ (setq doctor-verb (doctor-build doctor-verb 's))
(doctor-qloves))))))
(defun doctor-mach ()
- (setq found (doctor-plural found))
- (doctor-type (doc$ machlst)))
+ (setq doctor-found (doctor-plural doctor-found))
+ (doctor-type (doc$ doctor--machlst)))
(defun doctor-sexnoun () (doctor-sexverb))
(defun doctor-sexverb ()
- (if (or (memq 'me sent)(memq 'myself sent)(memq 'i sent))
+ (if (or (memq 'me doctor-sent)(memq 'myself doctor-sent)(memq 'i doctor-sent))
(doctor-foul)
- (doctor-type (doc$ sexlst))))
+ (doctor-type (doc$ doctor--sexlst))))
(defun doctor-death ()
- (cond (suicide-flag (doctor-type (doc$ deathlst)))
- ((or (equal found 'suicide)
- (and (or (equal found 'kill)
- (equal found 'killing))
- (memq 'yourself sent)))
- (setq suicide-flag t)
+ (cond (doctor--suicide-flag (doctor-type (doc$ doctor--deathlst)))
+ ((or (equal doctor-found 'suicide)
+ (and (or (equal doctor-found 'kill)
+ (equal doctor-found 'killing))
+ (memq 'yourself doctor-sent)))
+ (setq doctor--suicide-flag t)
(doctor-type '(If you are really suicidal, you might
want to contact the Samaritans via
E-mail: jo@samaritans.org or, at your option,
anonymous E-mail: samaritans@anon.twwells.com\ \.
or find a Befrienders crisis center at
http://www.befrienders.org/\ \.
- (doc$ please) (doc$ continue) \.)))
- (t (doctor-type (doc$ deathlst)))))
+ (doc$ doctor--please) (doc$ doctor--continue) \.)))
+ (t (doctor-type (doc$ doctor--deathlst)))))
(defun doctor-foul ()
- (doctor-type (doc$ foullst)))
+ (doctor-type (doc$ doctor--foullst)))
(defun doctor-family ()
- (doctor-possess sent found)
- (doctor-type (doc$ famlst)))
+ (doctor-possess doctor-sent doctor-found)
+ (doctor-type (doc$ doctor--famlst)))
;; I did not add this -- rms.
;; But he might have removed it. I put it back. --roland
(defun doctor-rms ()
- (cond (rms-flag (doctor-type (doc$ stallmanlst)))
- (t (setq rms-flag t) (doctor-type '(do you know Stallman \?)))))
+ (cond (doctor--rms-flag (doctor-type (doc$ doctor--stallmanlst)))
+ (t (setq doctor--rms-flag t) (doctor-type '(do you know Stallman \?)))))
-(defun doctor-school nil (doctor-type (doc$ schoollst)))
+(defun doctor-school nil (doctor-type (doc$ doctor--schoollst)))
(defun doctor-eliza ()
- (cond (eliza-flag (doctor-type (doc$ elizalst)))
- (t (setq eliza-flag t)
- (doctor-type '((doc// found) \? hah !
- (doc$ please) (doc$ continue) \.)))))
+ (cond (doctor--eliza-flag (doctor-type (doc$ doctor--elizalst)))
+ (t (setq doctor--eliza-flag t)
+ (doctor-type '((doc// doctor-found) \? hah !
+ (doc$ doctor--please) (doc$ doctor--continue) \.)))))
-(defun doctor-sports () (doctor-type (doc$ sportslst)))
+(defun doctor-sports () (doctor-type (doc$ doctor--sportslst)))
-(defun doctor-math () (doctor-type (doc$ mathlst)))
+(defun doctor-math () (doctor-type (doc$ doctor--mathlst)))
(defun doctor-zippy ()
- (cond (zippy-flag (doctor-type (doc$ zippylst)))
- (t (setq zippy-flag t)
+ (cond (doctor--zippy-flag (doctor-type (doc$ doctor--zippylst)))
+ (t (setq doctor--zippy-flag t)
(doctor-type '(yow! are we interactive yet \?)))))
-(defun doctor-chat () (doctor-type (doc$ chatlst)))
+(defun doctor-chat () (doctor-type (doc$ doctor--chatlst)))
(random t)
(provide 'doctor)
-;; arch-tag: 579380f6-4902-4ea5-bccb-6339e30e1257
;;; doctor.el ends here
diff --git a/lisp/play/gametree.el b/lisp/play/gametree.el
index 6fcc3136d07..215d95db341 100644
--- a/lisp/play/gametree.el
+++ b/lisp/play/gametree.el
@@ -201,7 +201,7 @@ should be no leading white space."
(let ((boundary (concat "[ \t]*\\([1-9][0-9]*\\)\\("
gametree-full-ply-regexp "\\|"
gametree-half-ply-regexp "\\)"))
- (limit (save-excursion (beginning-of-line 1) (point))))
+ (limit (line-beginning-position 1)))
(if (looking-at boundary)
(+ (* 2 (string-to-number (match-string 1)))
(if (string-match gametree-half-ply-regexp (match-string 2)) 1 0))
@@ -617,5 +617,4 @@ shogi, etc.) players, it is a slightly modified version of Outline mode.
(provide 'gametree)
-;; arch-tag: aaa30943-9ae4-4cc1-813d-a46f96b7e4f1
;;; gametree.el ends here
diff --git a/lisp/play/gomoku.el b/lisp/play/gomoku.el
index 1b11388a0d7..2c77aa62df1 100644
--- a/lisp/play/gomoku.el
+++ b/lisp/play/gomoku.el
@@ -102,59 +102,60 @@ One useful value to include is `turn-on-font-lock' to highlight the pieces."
"*Number of lines between the Gomoku board and the top of the window.")
-(defvar gomoku-mode-map nil
+(defvar gomoku-mode-map
+ (let ((map (make-sparse-keymap)))
+
+ ;; Key bindings for cursor motion.
+ (define-key map "y" 'gomoku-move-nw) ; y
+ (define-key map "u" 'gomoku-move-ne) ; u
+ (define-key map "b" 'gomoku-move-sw) ; b
+ (define-key map "n" 'gomoku-move-se) ; n
+ (define-key map "h" 'backward-char) ; h
+ (define-key map "l" 'forward-char) ; l
+ (define-key map "j" 'gomoku-move-down) ; j
+ (define-key map "k" 'gomoku-move-up) ; k
+
+ (define-key map [kp-7] 'gomoku-move-nw)
+ (define-key map [kp-9] 'gomoku-move-ne)
+ (define-key map [kp-1] 'gomoku-move-sw)
+ (define-key map [kp-3] 'gomoku-move-se)
+ (define-key map [kp-4] 'backward-char)
+ (define-key map [kp-6] 'forward-char)
+ (define-key map [kp-2] 'gomoku-move-down)
+ (define-key map [kp-8] 'gomoku-move-up)
+
+ (define-key map "\C-n" 'gomoku-move-down) ; C-n
+ (define-key map "\C-p" 'gomoku-move-up) ; C-p
+
+ ;; Key bindings for entering Human moves.
+ (define-key map "X" 'gomoku-human-plays) ; X
+ (define-key map "x" 'gomoku-human-plays) ; x
+ (define-key map " " 'gomoku-human-plays) ; SPC
+ (define-key map "\C-m" 'gomoku-human-plays) ; RET
+ (define-key map "\C-c\C-p" 'gomoku-human-plays) ; C-c C-p
+ (define-key map "\C-c\C-b" 'gomoku-human-takes-back) ; C-c C-b
+ (define-key map "\C-c\C-r" 'gomoku-human-resigns) ; C-c C-r
+ (define-key map "\C-c\C-e" 'gomoku-emacs-plays) ; C-c C-e
+
+ (define-key map [kp-enter] 'gomoku-human-plays)
+ (define-key map [insert] 'gomoku-human-plays)
+ (define-key map [down-mouse-1] 'gomoku-click)
+ (define-key map [drag-mouse-1] 'gomoku-click)
+ (define-key map [mouse-1] 'gomoku-click)
+ (define-key map [down-mouse-2] 'gomoku-click)
+ (define-key map [mouse-2] 'gomoku-mouse-play)
+ (define-key map [drag-mouse-2] 'gomoku-mouse-play)
+
+ (define-key map [remap previous-line] 'gomoku-move-up)
+ (define-key map [remap next-line] 'gomoku-move-down)
+ (define-key map [remap move-beginning-of-line] 'gomoku-beginning-of-line)
+ (define-key map [remap move-end-of-line] 'gomoku-end-of-line)
+ (define-key map [remap undo] 'gomoku-human-takes-back)
+ (define-key map [remap advertised-undo] 'gomoku-human-takes-back)
+ map)
+
"Local keymap to use in Gomoku mode.")
-(if gomoku-mode-map nil
- (setq gomoku-mode-map (make-sparse-keymap))
-
- ;; Key bindings for cursor motion.
- (define-key gomoku-mode-map "y" 'gomoku-move-nw) ; y
- (define-key gomoku-mode-map "u" 'gomoku-move-ne) ; u
- (define-key gomoku-mode-map "b" 'gomoku-move-sw) ; b
- (define-key gomoku-mode-map "n" 'gomoku-move-se) ; n
- (define-key gomoku-mode-map "h" 'backward-char) ; h
- (define-key gomoku-mode-map "l" 'forward-char) ; l
- (define-key gomoku-mode-map "j" 'gomoku-move-down) ; j
- (define-key gomoku-mode-map "k" 'gomoku-move-up) ; k
-
- (define-key gomoku-mode-map [kp-7] 'gomoku-move-nw)
- (define-key gomoku-mode-map [kp-9] 'gomoku-move-ne)
- (define-key gomoku-mode-map [kp-1] 'gomoku-move-sw)
- (define-key gomoku-mode-map [kp-3] 'gomoku-move-se)
- (define-key gomoku-mode-map [kp-4] 'backward-char)
- (define-key gomoku-mode-map [kp-6] 'forward-char)
- (define-key gomoku-mode-map [kp-2] 'gomoku-move-down)
- (define-key gomoku-mode-map [kp-8] 'gomoku-move-up)
-
- (define-key gomoku-mode-map "\C-n" 'gomoku-move-down) ; C-n
- (define-key gomoku-mode-map "\C-p" 'gomoku-move-up) ; C-p
-
- ;; Key bindings for entering Human moves.
- (define-key gomoku-mode-map "X" 'gomoku-human-plays) ; X
- (define-key gomoku-mode-map "x" 'gomoku-human-plays) ; x
- (define-key gomoku-mode-map " " 'gomoku-human-plays) ; SPC
- (define-key gomoku-mode-map "\C-m" 'gomoku-human-plays) ; RET
- (define-key gomoku-mode-map "\C-c\C-p" 'gomoku-human-plays) ; C-c C-p
- (define-key gomoku-mode-map "\C-c\C-b" 'gomoku-human-takes-back) ; C-c C-b
- (define-key gomoku-mode-map "\C-c\C-r" 'gomoku-human-resigns) ; C-c C-r
- (define-key gomoku-mode-map "\C-c\C-e" 'gomoku-emacs-plays) ; C-c C-e
-
- (define-key gomoku-mode-map [kp-enter] 'gomoku-human-plays)
- (define-key gomoku-mode-map [insert] 'gomoku-human-plays)
- (define-key gomoku-mode-map [down-mouse-1] 'gomoku-click)
- (define-key gomoku-mode-map [drag-mouse-1] 'gomoku-click)
- (define-key gomoku-mode-map [mouse-1] 'gomoku-click)
- (define-key gomoku-mode-map [down-mouse-2] 'gomoku-click)
- (define-key gomoku-mode-map [mouse-2] 'gomoku-mouse-play)
- (define-key gomoku-mode-map [drag-mouse-2] 'gomoku-mouse-play)
-
- (define-key gomoku-mode-map [remap previous-line] 'gomoku-move-up)
- (define-key gomoku-mode-map [remap next-line] 'gomoku-move-down)
- (define-key gomoku-mode-map [remap move-beginning-of-line] 'gomoku-beginning-of-line)
- (define-key gomoku-mode-map [remap move-end-of-line] 'gomoku-end-of-line)
- (define-key gomoku-mode-map [remap undo] 'gomoku-human-takes-back)
- (define-key gomoku-mode-map [remap advertised-undo] 'gomoku-human-takes-back))
(defvar gomoku-emacs-won ()
"For making font-lock use the winner's face for the line.")
@@ -182,28 +183,20 @@ One useful value to include is `turn-on-font-lock' to highlight the pieces."
;; allow View Mode to be activated in its buffer.
(put 'gomoku-mode 'mode-class 'special)
-(defun gomoku-mode ()
+(define-derived-mode gomoku-mode nil "Gomoku"
"Major mode for playing Gomoku against Emacs.
You and Emacs play in turn by marking a free square. You mark it with X
and Emacs marks it with O. The winner is the first to get five contiguous
marks horizontally, vertically or in diagonal.
-
+\\<gomoku-mode-map>
You play by moving the cursor over the square you choose and hitting \\[gomoku-human-plays].
-Other useful commands:
-\\{gomoku-mode-map}
-Entry to this mode calls the value of `gomoku-mode-hook' if that value
-is non-nil."
- (interactive)
- (kill-all-local-variables)
- (setq major-mode 'gomoku-mode
- mode-name "Gomoku")
+Other useful commands:\n
+\\{gomoku-mode-map}"
(gomoku-display-statistics)
- (use-local-map gomoku-mode-map)
(make-local-variable 'font-lock-defaults)
(setq font-lock-defaults '(gomoku-font-lock-keywords t)
- buffer-read-only t)
- (run-mode-hooks 'gomoku-mode-hook))
+ buffer-read-only t))
;;;
;;; THE BOARD.
@@ -285,7 +278,7 @@ is non-nil."
;; its contents as a set, i.e. not considering the order of its elements. The
;; highest score is given to the "OOOO" qtuples because playing in such a
;; qtuple is winning the game. Just after this comes the "XXXX" qtuple because
-;; not playing in it is just loosing the game, and so on. Note that a
+;; not playing in it is just losing the game, and so on. Note that a
;; "polluted" qtuple, i.e. one containing at least one X and at least one O,
;; has score zero because there is no more any point in playing in it, from
;; both an attacking and a defending point of view.
@@ -306,15 +299,15 @@ is non-nil."
;; these values will change (hopefully improve) the strength of the program
;; and may change its style (rather aggressive here).
-(defconst nil-score 7 "Score of an empty qtuple.")
-(defconst Xscore 15 "Score of a qtuple containing one X.")
-(defconst XXscore 400 "Score of a qtuple containing two X's.")
-(defconst XXXscore 1800 "Score of a qtuple containing three X's.")
-(defconst XXXXscore 100000 "Score of a qtuple containing four X's.")
-(defconst Oscore 35 "Score of a qtuple containing one O.")
-(defconst OOscore 800 "Score of a qtuple containing two O's.")
-(defconst OOOscore 15000 "Score of a qtuple containing three O's.")
-(defconst OOOOscore 800000 "Score of a qtuple containing four O's.")
+(defconst gomoku-nil-score 7 "Score of an empty qtuple.")
+(defconst gomoku-Xscore 15 "Score of a qtuple containing one X.")
+(defconst gomoku-XXscore 400 "Score of a qtuple containing two X's.")
+(defconst gomoku-XXXscore 1800 "Score of a qtuple containing three X's.")
+(defconst gomoku-XXXXscore 100000 "Score of a qtuple containing four X's.")
+(defconst gomoku-Oscore 35 "Score of a qtuple containing one O.")
+(defconst gomoku-OOscore 800 "Score of a qtuple containing two O's.")
+(defconst gomoku-OOOscore 15000 "Score of a qtuple containing three O's.")
+(defconst gomoku-OOOOscore 800000 "Score of a qtuple containing four O's.")
;; These values are not just random: if, given the following situation:
;;
@@ -327,7 +320,7 @@ is non-nil."
;; you want Emacs to play in "a" and not in "b", then the parameters must
;; satisfy the inequality:
;;
-;; 6 * XXscore > XXXscore + XXscore
+;; 6 * gomoku-XXscore > gomoku-XXXscore + gomoku-XXscore
;;
;; because "a" mainly belongs to six "XX" qtuples (the others are less
;; important) while "b" belongs to one "XXX" and one "XX" qtuples. Other
@@ -341,26 +334,26 @@ is non-nil."
;; we just have to set up a translation table.
(defconst gomoku-score-trans-table
- (vector nil-score Xscore XXscore XXXscore XXXXscore 0
- Oscore 0 0 0 0 0
- OOscore 0 0 0 0 0
- OOOscore 0 0 0 0 0
- OOOOscore 0 0 0 0 0
+ (vector gomoku-nil-score gomoku-Xscore gomoku-XXscore gomoku-XXXscore gomoku-XXXXscore 0
+ gomoku-Oscore 0 0 0 0 0
+ gomoku-OOscore 0 0 0 0 0
+ gomoku-OOOscore 0 0 0 0 0
+ gomoku-OOOOscore 0 0 0 0 0
0)
"Vector associating qtuple contents to their score.")
;; If you do not modify drastically the previous constants, the only way for a
-;; square to have a score higher than OOOOscore is to belong to a "OOOO"
+;; square to have a score higher than gomoku-OOOOscore is to belong to a "OOOO"
;; qtuple, thus to be a winning move. Similarly, the only way for a square to
-;; have a score between XXXXscore and OOOOscore is to belong to a "XXXX"
+;; have a score between gomoku-XXXXscore and gomoku-OOOOscore is to belong to a "XXXX"
;; qtuple. We may use these considerations to detect when a given move is
-;; winning or loosing.
+;; winning or losing.
-(defconst gomoku-winning-threshold OOOOscore
+(defconst gomoku-winning-threshold gomoku-OOOOscore
"Threshold score beyond which an Emacs move is winning.")
-(defconst gomoku-loosing-threshold XXXXscore
+(defconst gomoku-losing-threshold gomoku-XXXXscore
"Threshold score beyond which a human move is winning.")
@@ -401,10 +394,10 @@ is non-nil."
;;;
;; At initialization the board is empty so that every qtuple amounts for
-;; nil-score. Therefore, the score of any square is nil-score times the number
+;; gomoku-nil-score. Therefore, the score of any square is gomoku-nil-score times the number
;; of qtuples that pass through it. This number is 3 in a corner and 20 if you
;; are sufficiently far from the sides. As computing the number is time
-;; consuming, we initialize every square with 20*nil-score and then only
+;; consuming, we initialize every square with 20*gomoku-nil-score and then only
;; consider squares at less than 5 squares from one side. We speed this up by
;; taking symmetry into account.
;; Also, as it is likely that successive games will be played on a board with
@@ -428,7 +421,7 @@ is non-nil."
(setq gomoku-score-table (copy-sequence gomoku-saved-score-table))
;; No, compute it:
(setq gomoku-score-table
- (make-vector gomoku-vector-length (* 20 nil-score)))
+ (make-vector gomoku-vector-length (* 20 gomoku-nil-score)))
(let (i j maxi maxj maxi2 maxj2)
(setq maxi (/ (1+ gomoku-board-width) 2)
maxj (/ (1+ gomoku-board-height) 2)
@@ -879,7 +872,7 @@ If the game is finished, this command requests for another game."
(t
(setq score (aref gomoku-score-table square))
(gomoku-play-move square 1)
- (cond ((and (>= score gomoku-loosing-threshold)
+ (cond ((and (>= score gomoku-losing-threshold)
;; Just testing SCORE > THRESHOLD is not enough for
;; detecting wins, it just gives an indication that
;; we confirm with GOMOKU-FIND-FILLED-QTUPLE.
@@ -936,11 +929,7 @@ If the game is finished, this command requests for another game."
"Display a message asking for Human's move."
(message (if (zerop gomoku-number-of-human-moves)
"Your move? (Move to a free square and hit X, RET ...)"
- "Your move?"))
- ;; This may seem silly, but if one omits the following line (or a similar
- ;; one), the cursor may very well go to some place where POINT is not.
- ;; FIXME: this can't be right!! --Stef
- (save-excursion (set-buffer (other-buffer))))
+ "Your move?")))
(defun gomoku-prompt-for-other-game ()
"Ask for another game, and start it."
diff --git a/lisp/play/landmark.el b/lisp/play/landmark.el
index 0c8fa7c261e..e6a271caec2 100644
--- a/lisp/play/landmark.el
+++ b/lisp/play/landmark.el
@@ -30,31 +30,31 @@
;;; Commentary:
-;;; Lm is a relatively non-participatory game in which a robot
-;;; attempts to maneuver towards a tree at the center of the window
-;;; based on unique olfactory cues from each of the 4 directions. If
-;;; the smell of the tree increases, then the weights in the robot's
-;;; brain are adjusted to encourage this odor-driven behavior in the
-;;; future. If the smell of the tree decreases, the robots weights are
-;;; adjusted to discourage a correct move.
-
-;;; In laymen's terms, the search space is initially flat. The point
-;;; of training is to "turn up the edges of the search space" so that
-;;; the robot rolls toward the center.
-
-;;; Further, do not become alarmed if the robot appears to oscillate
-;;; back and forth between two or a few positions. This simply means
-;;; it is currently caught in a local minimum and is doing its best to
-;;; work its way out.
-
-;;; The version of this program as described has a small problem. a
-;;; move in a net direction can produce gross credit assignment. for
-;;; example, if moving south will produce positive payoff, then, if in
-;;; a single move, one moves east,west and south, then both east and
-;;; west will be improved when they shouldn't
-
-;;; Many thanks to Yuri Pryadkin (yuri@rana.usc.edu) for this
-;;; concise problem description.
+;; Lm is a relatively non-participatory game in which a robot
+;; attempts to maneuver towards a tree at the center of the window
+;; based on unique olfactory cues from each of the 4 directions. If
+;; the smell of the tree increases, then the weights in the robot's
+;; brain are adjusted to encourage this odor-driven behavior in the
+;; future. If the smell of the tree decreases, the robots weights are
+;; adjusted to discourage a correct move.
+
+;; In laymen's terms, the search space is initially flat. The point
+;; of training is to "turn up the edges of the search space" so that
+;; the robot rolls toward the center.
+
+;; Further, do not become alarmed if the robot appears to oscillate
+;; back and forth between two or a few positions. This simply means
+;; it is currently caught in a local minimum and is doing its best to
+;; work its way out.
+
+;; The version of this program as described has a small problem. a
+;; move in a net direction can produce gross credit assignment. for
+;; example, if moving south will produce positive payoff, then, if in
+;; a single move, one moves east,west and south, then both east and
+;; west will be improved when they shouldn't
+
+;; Many thanks to Yuri Pryadkin (yuri@rana.usc.edu) for this
+;; concise problem description.
;;;_* Require
(eval-when-compile (require 'cl))
@@ -159,52 +159,52 @@
:type 'hook
:group 'lm)
-(defvar lm-mode-map nil
+(defvar lm-mode-map
+ (let ((map (make-sparse-keymap)))
+ ;; Key bindings for cursor motion.
+ (define-key map "y" 'lm-move-nw) ; y
+ (define-key map "u" 'lm-move-ne) ; u
+ (define-key map "b" 'lm-move-sw) ; b
+ (define-key map "n" 'lm-move-se) ; n
+ (define-key map "h" 'backward-char) ; h
+ (define-key map "l" 'forward-char) ; l
+ (define-key map "j" 'lm-move-down) ; j
+ (define-key map "k" 'lm-move-up) ; k
+
+ (define-key map [kp-7] 'lm-move-nw)
+ (define-key map [kp-9] 'lm-move-ne)
+ (define-key map [kp-1] 'lm-move-sw)
+ (define-key map [kp-3] 'lm-move-se)
+ (define-key map [kp-4] 'backward-char)
+ (define-key map [kp-6] 'forward-char)
+ (define-key map [kp-2] 'lm-move-down)
+ (define-key map [kp-8] 'lm-move-up)
+
+ (define-key map "\C-n" 'lm-move-down) ; C-n
+ (define-key map "\C-p" 'lm-move-up) ; C-p
+
+ ;; Key bindings for entering Human moves.
+ (define-key map "X" 'lm-human-plays) ; X
+ (define-key map "x" 'lm-human-plays) ; x
+
+ (define-key map " " 'lm-start-robot) ; SPC
+ (define-key map [down-mouse-1] 'lm-start-robot)
+ (define-key map [drag-mouse-1] 'lm-click)
+ (define-key map [mouse-1] 'lm-click)
+ (define-key map [down-mouse-2] 'lm-click)
+ (define-key map [mouse-2] 'lm-mouse-play)
+ (define-key map [drag-mouse-2] 'lm-mouse-play)
+
+ (define-key map [remap previous-line] 'lm-move-up)
+ (define-key map [remap next-line] 'lm-move-down)
+ (define-key map [remap beginning-of-line] 'lm-beginning-of-line)
+ (define-key map [remap end-of-line] 'lm-end-of-line)
+ (define-key map [remap undo] 'lm-human-takes-back)
+ (define-key map [remap advertised-undo] 'lm-human-takes-back)
+ map)
"Local keymap to use in Lm mode.")
-(if lm-mode-map nil
- (setq lm-mode-map (make-sparse-keymap))
-
- ;; Key bindings for cursor motion.
- (define-key lm-mode-map "y" 'lm-move-nw) ; y
- (define-key lm-mode-map "u" 'lm-move-ne) ; u
- (define-key lm-mode-map "b" 'lm-move-sw) ; b
- (define-key lm-mode-map "n" 'lm-move-se) ; n
- (define-key lm-mode-map "h" 'backward-char) ; h
- (define-key lm-mode-map "l" 'forward-char) ; l
- (define-key lm-mode-map "j" 'lm-move-down) ; j
- (define-key lm-mode-map "k" 'lm-move-up) ; k
-
- (define-key lm-mode-map [kp-7] 'lm-move-nw)
- (define-key lm-mode-map [kp-9] 'lm-move-ne)
- (define-key lm-mode-map [kp-1] 'lm-move-sw)
- (define-key lm-mode-map [kp-3] 'lm-move-se)
- (define-key lm-mode-map [kp-4] 'backward-char)
- (define-key lm-mode-map [kp-6] 'forward-char)
- (define-key lm-mode-map [kp-2] 'lm-move-down)
- (define-key lm-mode-map [kp-8] 'lm-move-up)
-
- (define-key lm-mode-map "\C-n" 'lm-move-down) ; C-n
- (define-key lm-mode-map "\C-p" 'lm-move-up) ; C-p
-
- ;; Key bindings for entering Human moves.
- (define-key lm-mode-map "X" 'lm-human-plays) ; X
- (define-key lm-mode-map "x" 'lm-human-plays) ; x
-
- (define-key lm-mode-map " " 'lm-start-robot) ; SPC
- (define-key lm-mode-map [down-mouse-1] 'lm-start-robot)
- (define-key lm-mode-map [drag-mouse-1] 'lm-click)
- (define-key lm-mode-map [mouse-1] 'lm-click)
- (define-key lm-mode-map [down-mouse-2] 'lm-click)
- (define-key lm-mode-map [mouse-2] 'lm-mouse-play)
- (define-key lm-mode-map [drag-mouse-2] 'lm-mouse-play)
-
- (define-key lm-mode-map [remap previous-line] 'lm-move-up)
- (define-key lm-mode-map [remap next-line] 'lm-move-down)
- (define-key lm-mode-map [remap beginning-of-line] 'lm-beginning-of-line)
- (define-key lm-mode-map [remap end-of-line] 'lm-end-of-line)
- (define-key lm-mode-map [remap undo] 'lm-human-takes-back)
- (define-key lm-mode-map [remap advertised-undo] 'lm-human-takes-back))
+
(defvar lm-emacs-won ()
"*For making font-lock use the winner's face for the line.")
@@ -282,7 +282,7 @@ is non-nil. One interesting value is `turn-on-font-lock'."
;; its contents as a set, i.e. not considering the order of its elements. The
;; highest score is given to the "OOOO" qtuples because playing in such a
;; qtuple is winning the game. Just after this comes the "XXXX" qtuple because
-;; not playing in it is just loosing the game, and so on. Note that a
+;; not playing in it is just losing the game, and so on. Note that a
;; "polluted" qtuple, i.e. one containing at least one X and at least one O,
;; has score zero because there is no more any point in playing in it, from
;; both an attacking and a defending point of view.
@@ -303,47 +303,47 @@ is non-nil. One interesting value is `turn-on-font-lock'."
;; these values will change (hopefully improve) the strength of the program
;; and may change its style (rather aggressive here).
-(defconst nil-score 7 "Score of an empty qtuple.")
-(defconst Xscore 15 "Score of a qtuple containing one X.")
-(defconst XXscore 400 "Score of a qtuple containing two X's.")
-(defconst XXXscore 1800 "Score of a qtuple containing three X's.")
-(defconst XXXXscore 100000 "Score of a qtuple containing four X's.")
-(defconst Oscore 35 "Score of a qtuple containing one O.")
-(defconst OOscore 800 "Score of a qtuple containing two O's.")
-(defconst OOOscore 15000 "Score of a qtuple containing three O's.")
-(defconst OOOOscore 800000 "Score of a qtuple containing four O's.")
-
-;; These values are not just random: if, given the following situation:
-;;
-;; . . . . . . . O .
-;; . X X a . . . X .
-;; . . . X . . . X .
-;; . . . X . . . X .
-;; . . . . . . . b .
-;;
-;; you want Emacs to play in "a" and not in "b", then the parameters must
-;; satisfy the inequality:
-;;
-;; 6 * XXscore > XXXscore + XXscore
-;;
-;; because "a" mainly belongs to six "XX" qtuples (the others are less
-;; important) while "b" belongs to one "XXX" and one "XX" qtuples. Other
-;; conditions are required to obtain sensible moves, but the previous example
-;; should illustrate the point. If you manage to improve on these values,
-;; please send me a note. Thanks.
-
-
-;; As we chose values 0, 1 and 6 to denote empty, X and O squares, the
-;; contents of a qtuple are uniquely determined by the sum of its elements and
-;; we just have to set up a translation table.
+(defconst lm-nil-score 7 "Score of an empty qtuple.")
(defconst lm-score-trans-table
- (vector nil-score Xscore XXscore XXXscore XXXXscore 0
- Oscore 0 0 0 0 0
- OOscore 0 0 0 0 0
- OOOscore 0 0 0 0 0
- OOOOscore 0 0 0 0 0
- 0)
+ (let ((Xscore 15) ; Score of a qtuple containing one X.
+ (XXscore 400) ; Score of a qtuple containing two X's.
+ (XXXscore 1800) ; Score of a qtuple containing three X's.
+ (XXXXscore 100000) ; Score of a qtuple containing four X's.
+ (Oscore 35) ; Score of a qtuple containing one O.
+ (OOscore 800) ; Score of a qtuple containing two O's.
+ (OOOscore 15000) ; Score of a qtuple containing three O's.
+ (OOOOscore 800000)) ; Score of a qtuple containing four O's.
+
+ ;; These values are not just random: if, given the following situation:
+ ;;
+ ;; . . . . . . . O .
+ ;; . X X a . . . X .
+ ;; . . . X . . . X .
+ ;; . . . X . . . X .
+ ;; . . . . . . . b .
+ ;;
+ ;; you want Emacs to play in "a" and not in "b", then the parameters must
+ ;; satisfy the inequality:
+ ;;
+ ;; 6 * XXscore > XXXscore + XXscore
+ ;;
+ ;; because "a" mainly belongs to six "XX" qtuples (the others are less
+ ;; important) while "b" belongs to one "XXX" and one "XX" qtuples.
+ ;; Other conditions are required to obtain sensible moves, but the
+ ;; previous example should illustrate the point. If you manage to
+ ;; improve on these values, please send me a note. Thanks.
+
+
+ ;; As we chose values 0, 1 and 6 to denote empty, X and O squares,
+ ;; the contents of a qtuple are uniquely determined by the sum of
+ ;; its elements and we just have to set up a translation table.
+ (vector lm-nil-score Xscore XXscore XXXscore XXXXscore 0
+ Oscore 0 0 0 0 0
+ OOscore 0 0 0 0 0
+ OOOscore 0 0 0 0 0
+ OOOOscore 0 0 0 0 0
+ 0))
"Vector associating qtuple contents to their score.")
@@ -352,12 +352,14 @@ is non-nil. One interesting value is `turn-on-font-lock'."
;; qtuple, thus to be a winning move. Similarly, the only way for a square to
;; have a score between XXXXscore and OOOOscore is to belong to a "XXXX"
;; qtuple. We may use these considerations to detect when a given move is
-;; winning or loosing.
+;; winning or losing.
-(defconst lm-winning-threshold OOOOscore
+(defconst lm-winning-threshold
+ (aref lm-score-trans-table (+ 6 6 6 6)) ;; OOOOscore
"Threshold score beyond which an Emacs move is winning.")
-(defconst lm-loosing-threshold XXXXscore
+(defconst lm-losing-threshold
+ (aref lm-score-trans-table (+ 1 1 1 1)) ;; XXXXscore
"Threshold score beyond which a human move is winning.")
@@ -423,7 +425,7 @@ is non-nil. One interesting value is `turn-on-font-lock'."
(setq lm-score-table (copy-sequence lm-saved-score-table))
;; No, compute it:
(setq lm-score-table
- (make-vector lm-vector-length (* 20 nil-score)))
+ (make-vector lm-vector-length (* 20 lm-nil-score)))
(let (i j maxi maxj maxi2 maxj2)
(setq maxi (/ (1+ lm-board-width) 2)
maxj (/ (1+ lm-board-height) 2)
@@ -769,7 +771,7 @@ If the game is finished, this command requests for another game."
(t
(setq score (aref lm-score-table square))
(lm-play-move square 1)
- (cond ((and (>= score lm-loosing-threshold)
+ (cond ((and (>= score lm-losing-threshold)
;; Just testing SCORE > THRESHOLD is not enough for
;; detecting wins, it just gives an indication that
;; we confirm with LM-FIND-FILLED-QTUPLE.
@@ -824,11 +826,7 @@ If the game is finished, this command requests for another game."
"Display a message asking for Human's move."
(message (if (zerop lm-number-of-human-moves)
"Your move? (move to a free square and hit X, RET ...)"
- "Your move?"))
- ;; This may seem silly, but if one omits the following line (or a similar
- ;; one), the cursor may very well go to some place where POINT is not.
- ;; FIXME: this can't be right!! --Stef
- (save-excursion (set-buffer (other-buffer))))
+ "Your move?")))
(defun lm-prompt-for-other-game ()
"Ask for another game, and start it."
diff --git a/lisp/play/life.el b/lisp/play/life.el
index f4a6ee1836e..996b0c6144b 100644
--- a/lisp/play/life.el
+++ b/lisp/play/life.el
@@ -1,7 +1,7 @@
;;; life.el --- John Horton Conway's `Life' game for GNU Emacs
-;; Copyright (C) 1988, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1988, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+;; 2009, 2010 Free Software Foundation, Inc.
;; Author: Kyle Jones <kyleuunet.uu.net>
;; Maintainer: FSF
@@ -163,7 +163,7 @@ generations (this defaults to 1)."
(replace-match (life-life-string) t t))
;; center the pattern horizontally
(goto-char (point-min))
- (setq n (/ (- fill-column (save-excursion (end-of-line) (point))) 2))
+ (setq n (/ (- fill-column (line-end-position)) 2))
(while (not (eobp))
(indent-to n)
(forward-line))
@@ -302,5 +302,4 @@ generations (this defaults to 1)."
(provide 'life)
-;; arch-tag: e9373544-755e-42f5-a9a1-4d4c422bb97a
;;; life.el ends here
diff --git a/lisp/play/mpuz.el b/lisp/play/mpuz.el
index 954730c9491..c5b74a8499f 100644
--- a/lisp/play/mpuz.el
+++ b/lisp/play/mpuz.el
@@ -87,33 +87,34 @@ t means never ding, and `error' means only ding on wrong input."
:type 'hook
:group 'mpuz)
-(defvar mpuz-mode-map nil
+(defvar mpuz-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "a" 'mpuz-try-letter)
+ (define-key map "b" 'mpuz-try-letter)
+ (define-key map "c" 'mpuz-try-letter)
+ (define-key map "d" 'mpuz-try-letter)
+ (define-key map "e" 'mpuz-try-letter)
+ (define-key map "f" 'mpuz-try-letter)
+ (define-key map "g" 'mpuz-try-letter)
+ (define-key map "h" 'mpuz-try-letter)
+ (define-key map "i" 'mpuz-try-letter)
+ (define-key map "j" 'mpuz-try-letter)
+ (define-key map "A" 'mpuz-try-letter)
+ (define-key map "B" 'mpuz-try-letter)
+ (define-key map "C" 'mpuz-try-letter)
+ (define-key map "D" 'mpuz-try-letter)
+ (define-key map "E" 'mpuz-try-letter)
+ (define-key map "F" 'mpuz-try-letter)
+ (define-key map "G" 'mpuz-try-letter)
+ (define-key map "H" 'mpuz-try-letter)
+ (define-key map "I" 'mpuz-try-letter)
+ (define-key map "J" 'mpuz-try-letter)
+ (define-key map "\C-g" 'mpuz-offer-abort)
+ (define-key map "?" 'describe-mode)
+ map)
"Local keymap to use in Mult Puzzle.")
-(if mpuz-mode-map nil
- (setq mpuz-mode-map (make-sparse-keymap))
- (define-key mpuz-mode-map "a" 'mpuz-try-letter)
- (define-key mpuz-mode-map "b" 'mpuz-try-letter)
- (define-key mpuz-mode-map "c" 'mpuz-try-letter)
- (define-key mpuz-mode-map "d" 'mpuz-try-letter)
- (define-key mpuz-mode-map "e" 'mpuz-try-letter)
- (define-key mpuz-mode-map "f" 'mpuz-try-letter)
- (define-key mpuz-mode-map "g" 'mpuz-try-letter)
- (define-key mpuz-mode-map "h" 'mpuz-try-letter)
- (define-key mpuz-mode-map "i" 'mpuz-try-letter)
- (define-key mpuz-mode-map "j" 'mpuz-try-letter)
- (define-key mpuz-mode-map "A" 'mpuz-try-letter)
- (define-key mpuz-mode-map "B" 'mpuz-try-letter)
- (define-key mpuz-mode-map "C" 'mpuz-try-letter)
- (define-key mpuz-mode-map "D" 'mpuz-try-letter)
- (define-key mpuz-mode-map "E" 'mpuz-try-letter)
- (define-key mpuz-mode-map "F" 'mpuz-try-letter)
- (define-key mpuz-mode-map "G" 'mpuz-try-letter)
- (define-key mpuz-mode-map "H" 'mpuz-try-letter)
- (define-key mpuz-mode-map "I" 'mpuz-try-letter)
- (define-key mpuz-mode-map "J" 'mpuz-try-letter)
- (define-key mpuz-mode-map "\C-g" 'mpuz-offer-abort)
- (define-key mpuz-mode-map "?" 'describe-mode))
+
(defun mpuz-mode ()
"Multiplication puzzle mode.
diff --git a/lisp/play/tetris.el b/lisp/play/tetris.el
index d38c5e44cc8..68d1590e571 100644
--- a/lisp/play/tetris.el
+++ b/lisp/play/tetris.el
@@ -35,7 +35,7 @@
;; ;;;;;;;;;;;;; customization variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgroup tetris nil
- "Play a game of tetris."
+ "Play a game of Tetris."
:prefix "tetris-"
:group 'games)
@@ -61,10 +61,10 @@
(defcustom tetris-update-speed-function
'tetris-default-update-speed-function
- "Function run whenever the Tetris score changes
+ "Function run whenever the Tetris score changes.
Called with two arguments: (SHAPES ROWS)
-SHAPES is the number of shapes which have been dropped
-ROWS is the number of rows which have been completed
+SHAPES is the number of shapes which have been dropped.
+ROWS is the number of rows which have been completed.
If the return value is a number, it is used as the timer period."
:group 'tetris
@@ -76,13 +76,12 @@ If the return value is a number, it is used as the timer period."
:type 'hook)
(defcustom tetris-tty-colors
- [nil "blue" "white" "yellow" "magenta" "cyan" "green" "red"]
- "Vector of colors of the various shapes in text mode
-Element 0 is ignored."
+ ["blue" "white" "yellow" "magenta" "cyan" "green" "red"]
+ "Vector of colors of the various shapes in text mode."
:group 'tetris
:type (let ((names `("Shape 1" "Shape 2" "Shape 3"
"Shape 4" "Shape 5" "Shape 6" "Shape 7"))
- (result `(vector (const nil))))
+ (result nil))
(while names
(add-to-list 'result
(cons 'choice
@@ -96,9 +95,8 @@ Element 0 is ignored."
result))
(defcustom tetris-x-colors
- [nil [0 0 1] [0.7 0 1] [1 1 0] [1 0 1] [0 1 1] [0 1 0] [1 0 0]]
- "Vector of colors of the various shapes
-Element 0 is ignored."
+ [[0 0 1] [0.7 0 1] [1 1 0] [1 0 1] [0 1 1] [0 1 0] [1 0 0]]
+ "Vector of colors of the various shapes."
:group 'tetris
:type 'sexp)
@@ -196,51 +194,44 @@ Element 0 is ignored."
;; ;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defconst tetris-shapes
- [[[[1 1 0 0] [1 1 0 0] [1 1 0 0] [1 1 0 0]]
- [[1 1 0 0] [1 1 0 0] [1 1 0 0] [1 1 0 0]]
- [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]
- [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
-
- [[[2 2 2 0] [0 2 0 0] [2 0 0 0] [2 2 0 0]]
- [[0 0 2 0] [0 2 0 0] [2 2 2 0] [2 0 0 0]]
- [[0 0 0 0] [2 2 0 0] [0 0 0 0] [2 0 0 0]]
- [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
-
- [[[3 3 3 0] [3 3 0 0] [0 0 3 0] [3 0 0 0]]
- [[3 0 0 0] [0 3 0 0] [3 3 3 0] [3 0 0 0]]
- [[0 0 0 0] [0 3 0 0] [0 0 0 0] [3 3 0 0]]
- [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
-
- [[[4 4 0 0] [0 4 0 0] [4 4 0 0] [0 4 0 0]]
- [[0 4 4 0] [4 4 0 0] [0 4 4 0] [4 4 0 0]]
- [[0 0 0 0] [4 0 0 0] [0 0 0 0] [4 0 0 0]]
- [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
-
- [[[0 5 5 0] [5 0 0 0] [0 5 5 0] [5 0 0 0]]
- [[5 5 0 0] [5 5 0 0] [5 5 0 0] [5 5 0 0]]
- [[0 0 0 0] [0 5 0 0] [0 0 0 0] [0 5 0 0]]
- [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
-
- [[[0 6 0 0] [6 0 0 0] [6 6 6 0] [0 6 0 0]]
- [[6 6 6 0] [6 6 0 0] [0 6 0 0] [6 6 0 0]]
- [[0 0 0 0] [6 0 0 0] [0 0 0 0] [0 6 0 0]]
- [[0 0 0 0] [0 0 0 0] [0 0 0 0] [0 0 0 0]]]
-
- [[[7 7 7 7] [7 0 0 0] [7 7 7 7] [7 0 0 0]]
- [[0 0 0 0] [7 0 0 0] [0 0 0 0] [7 0 0 0]]
- [[0 0 0 0] [7 0 0 0] [0 0 0 0] [7 0 0 0]]
- [[0 0 0 0] [7 0 0 0] [0 0 0 0] [7 0 0 0]]]])
+ [[[[0 0] [1 0] [0 1] [1 1]]]
+
+ [[[0 0] [1 0] [2 0] [2 1]]
+ [[1 -1] [1 0] [1 1] [0 1]]
+ [[0 -1] [0 0] [1 0] [2 0]]
+ [[1 -1] [2 -1] [1 0] [1 1]]]
+
+ [[[0 0] [1 0] [2 0] [0 1]]
+ [[0 -1] [1 -1] [1 0] [1 1]]
+ [[2 -1] [0 0] [1 0] [2 0]]
+ [[1 -1] [1 0] [1 1] [2 1]]]
+
+ [[[0 0] [1 0] [1 1] [2 1]]
+ [[1 0] [0 1] [1 1] [0 2]]]
+
+ [[[1 0] [2 0] [0 1] [1 1]]
+ [[0 0] [0 1] [1 1] [1 2]]]
+
+ [[[1 0] [0 1] [1 1] [2 1]]
+ [[1 0] [1 1] [2 1] [1 2]]
+ [[0 1] [1 1] [2 1] [1 2]]
+ [[1 0] [0 1] [1 1] [1 2]]]
+
+ [[[0 0] [1 0] [2 0] [3 0]]
+ [[1 -1] [1 0] [1 1] [1 2]]]]
+ "Each shape is described by a vector that contains the coordinates of
+each one of its four blocks.")
;;the scoring rules were taken from "xtetris". Blocks score differently
;;depending on their rotation
(defconst tetris-shape-scores
- [ [6 6 6 6] [6 7 6 7] [6 7 6 7] [6 7 6 7] [6 7 6 7] [5 5 6 5] [5 8 5 8]] )
+ [[6] [6 7 6 7] [6 7 6 7] [6 7] [6 7] [5 5 6 5] [5 8]] )
(defconst tetris-shape-dimensions
[[2 2] [3 2] [3 2] [3 2] [3 2] [3 2] [4 1]])
-(defconst tetris-blank 0)
+(defconst tetris-blank 7)
(defconst tetris-border 8)
@@ -274,22 +265,22 @@ Element 0 is ignored."
;; ;;;;;;;;;;;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar tetris-mode-map
- (make-sparse-keymap 'tetris-mode-map))
-
-(define-key tetris-mode-map "n" 'tetris-start-game)
-(define-key tetris-mode-map "q" 'tetris-end-game)
-(define-key tetris-mode-map "p" 'tetris-pause-game)
-
-(define-key tetris-mode-map " " 'tetris-move-bottom)
-(define-key tetris-mode-map [left] 'tetris-move-left)
-(define-key tetris-mode-map [right] 'tetris-move-right)
-(define-key tetris-mode-map [up] 'tetris-rotate-prev)
-(define-key tetris-mode-map [down] 'tetris-rotate-next)
+ (let ((map (make-sparse-keymap 'tetris-mode-map)))
+ (define-key map "n" 'tetris-start-game)
+ (define-key map "q" 'tetris-end-game)
+ (define-key map "p" 'tetris-pause-game)
+
+ (define-key map " " 'tetris-move-bottom)
+ (define-key map [left] 'tetris-move-left)
+ (define-key map [right] 'tetris-move-right)
+ (define-key map [up] 'tetris-rotate-prev)
+ (define-key map [down] 'tetris-rotate-next)
+ map))
(defvar tetris-null-map
- (make-sparse-keymap 'tetris-null-map))
-
-(define-key tetris-null-map "n" 'tetris-start-game)
+ (let ((map (make-sparse-keymap 'tetris-null-map)))
+ (define-key map "n" 'tetris-start-game)
+ map))
;; ;;;;;;;;;;;;;;;; game functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -299,7 +290,7 @@ Element 0 is ignored."
(aset options c
(cond ((= c tetris-blank)
tetris-blank-options)
- ((and (>= c 1) (<= c 7))
+ ((and (>= c 0) (<= c 6))
(append
tetris-cell-options
`((((glyph color-x) ,(aref tetris-x-colors c))
@@ -320,20 +311,16 @@ Element 0 is ignored."
tetris-n-rows nil)))
(and (numberp period) period))))
-(defun tetris-get-shape-cell (x y)
- (aref (aref (aref (aref tetris-shapes
- tetris-shape)
- y)
- tetris-rot)
- x))
+(defun tetris-get-shape-cell (block)
+ (aref (aref (aref tetris-shapes
+ tetris-shape) tetris-rot)
+ block))
(defun tetris-shape-width ()
- (aref (aref tetris-shape-dimensions tetris-shape)
- (% tetris-rot 2)))
+ (aref (aref tetris-shape-dimensions tetris-shape) 0))
-(defun tetris-shape-height ()
- (aref (aref tetris-shape-dimensions tetris-shape)
- (- 1 (% tetris-rot 2))))
+(defun tetris-shape-rotations ()
+ (length (aref tetris-shapes tetris-shape)))
(defun tetris-draw-score ()
(let ((strings (vector (format "Shapes: %05d" tetris-n-shapes)
@@ -365,52 +352,58 @@ Element 0 is ignored."
(tetris-update-score)))
(defun tetris-draw-next-shape ()
- (loop for y from 0 to 3 do
- (loop for x from 0 to 3 do
- (gamegrid-set-cell (+ tetris-next-x x)
- (+ tetris-next-y y)
- (let ((tetris-shape tetris-next-shape)
- (tetris-rot 0))
- (tetris-get-shape-cell x y))))))
+ (loop for x from 0 to 3 do
+ (loop for y from 0 to 3 do
+ (gamegrid-set-cell (+ tetris-next-x x)
+ (+ tetris-next-y y)
+ tetris-blank)))
+ (loop for i from 0 to 3 do
+ (let ((tetris-shape tetris-next-shape)
+ (tetris-rot 0))
+ (gamegrid-set-cell (+ tetris-next-x
+ (aref (tetris-get-shape-cell i) 0))
+ (+ tetris-next-y
+ (aref (tetris-get-shape-cell i) 1))
+ tetris-shape))))
(defun tetris-draw-shape ()
- (loop for y from 0 to (1- (tetris-shape-height)) do
- (loop for x from 0 to (1- (tetris-shape-width)) do
- (let ((c (tetris-get-shape-cell x y)))
- (if (/= c tetris-blank)
- (gamegrid-set-cell (+ tetris-top-left-x
- tetris-pos-x
- x)
- (+ tetris-top-left-y
- tetris-pos-y
- y)
- c))))))
+ (loop for i from 0 to 3 do
+ (let ((c (tetris-get-shape-cell i)))
+ (gamegrid-set-cell (+ tetris-top-left-x
+ tetris-pos-x
+ (aref c 0))
+ (+ tetris-top-left-y
+ tetris-pos-y
+ (aref c 1))
+ tetris-shape))))
(defun tetris-erase-shape ()
- (loop for y from 0 to (1- (tetris-shape-height)) do
- (loop for x from 0 to (1- (tetris-shape-width)) do
- (let ((c (tetris-get-shape-cell x y))
- (px (+ tetris-top-left-x tetris-pos-x x))
- (py (+ tetris-top-left-y tetris-pos-y y)))
- (if (/= c tetris-blank)
- (gamegrid-set-cell px py tetris-blank))))))
+ (loop for i from 0 to 3 do
+ (let ((c (tetris-get-shape-cell i)))
+ (gamegrid-set-cell (+ tetris-top-left-x
+ tetris-pos-x
+ (aref c 0))
+ (+ tetris-top-left-y
+ tetris-pos-y
+ (aref c 1))
+ tetris-blank))))
(defun tetris-test-shape ()
(let ((hit nil))
- (loop for y from 0 to (1- (tetris-shape-height)) do
- (loop for x from 0 to (1- (tetris-shape-width)) do
- (unless hit
- (setq hit
- (let* ((c (tetris-get-shape-cell x y))
- (xx (+ tetris-pos-x x))
- (yy (+ tetris-pos-y y))
- (px (+ tetris-top-left-x xx))
- (py (+ tetris-top-left-y yy)))
- (and (/= c tetris-blank)
- (or (>= xx tetris-width)
- (>= yy tetris-height)
- (/= (gamegrid-get-cell px py)
- tetris-blank))))))))
+ (loop for i from 0 to 3 do
+ (unless hit
+ (setq hit
+ (let* ((c (tetris-get-shape-cell i))
+ (xx (+ tetris-pos-x
+ (aref c 0)))
+ (yy (+ tetris-pos-y
+ (aref c 1))))
+ (or (>= xx tetris-width)
+ (>= yy tetris-height)
+ (/= (gamegrid-get-cell
+ (+ xx tetris-top-left-x)
+ (+ yy tetris-top-left-y))
+ tetris-blank))))))
hit))
(defun tetris-full-row (y)
@@ -508,35 +501,32 @@ Drops the shape one square, testing for collision."
(tetris-shape-done)))))
(defun tetris-move-bottom ()
- "Drops the shape to the bottom of the playing area"
+ "Drop the shape to the bottom of the playing area."
(interactive)
- (if (not tetris-paused)
- (let ((hit nil))
- (tetris-erase-shape)
- (while (not hit)
- (setq tetris-pos-y (1+ tetris-pos-y))
- (setq hit (tetris-test-shape)))
- (setq tetris-pos-y (1- tetris-pos-y))
- (tetris-draw-shape)
- (tetris-shape-done))))
+ (unless tetris-paused
+ (let ((hit nil))
+ (tetris-erase-shape)
+ (while (not hit)
+ (setq tetris-pos-y (1+ tetris-pos-y))
+ (setq hit (tetris-test-shape)))
+ (setq tetris-pos-y (1- tetris-pos-y))
+ (tetris-draw-shape)
+ (tetris-shape-done))))
(defun tetris-move-left ()
- "Moves the shape one square to the left"
+ "Move the shape one square to the left."
(interactive)
- (unless (or (= tetris-pos-x 0)
- tetris-paused)
+ (unless tetris-paused
(tetris-erase-shape)
(setq tetris-pos-x (1- tetris-pos-x))
(if (tetris-test-shape)
- (setq tetris-pos-x (1+ tetris-pos-x)))
+ (setq tetris-pos-x (1+ tetris-pos-x)))
(tetris-draw-shape)))
(defun tetris-move-right ()
- "Moves the shape one square to the right"
+ "Move the shape one square to the right."
(interactive)
- (unless (or (= (+ tetris-pos-x (tetris-shape-width))
- tetris-width)
- tetris-paused)
+ (unless tetris-paused
(tetris-erase-shape)
(setq tetris-pos-x (1+ tetris-pos-x))
(if (tetris-test-shape)
@@ -544,35 +534,38 @@ Drops the shape one square, testing for collision."
(tetris-draw-shape)))
(defun tetris-rotate-prev ()
- "Rotates the shape clockwise"
+ "Rotate the shape clockwise."
(interactive)
- (if (not tetris-paused)
- (progn (tetris-erase-shape)
- (setq tetris-rot (% (+ 1 tetris-rot) 4))
- (if (tetris-test-shape)
- (setq tetris-rot (% (+ 3 tetris-rot) 4)))
- (tetris-draw-shape))))
+ (unless tetris-paused
+ (tetris-erase-shape)
+ (setq tetris-rot (% (+ 1 tetris-rot)
+ (tetris-shape-rotations)))
+ (if (tetris-test-shape)
+ (setq tetris-rot (% (+ 3 tetris-rot)
+ (tetris-shape-rotations))))
+ (tetris-draw-shape)))
(defun tetris-rotate-next ()
- "Rotates the shape anticlockwise"
+ "Rotate the shape anticlockwise."
(interactive)
- (if (not tetris-paused)
- (progn
+ (unless tetris-paused
(tetris-erase-shape)
- (setq tetris-rot (% (+ 3 tetris-rot) 4))
+ (setq tetris-rot (% (+ 3 tetris-rot)
+ (tetris-shape-rotations)))
(if (tetris-test-shape)
- (setq tetris-rot (% (+ 1 tetris-rot) 4)))
- (tetris-draw-shape))))
+ (setq tetris-rot (% (+ 1 tetris-rot)
+ (tetris-shape-rotations))))
+ (tetris-draw-shape)))
(defun tetris-end-game ()
- "Terminates the current game"
+ "Terminate the current game."
(interactive)
(gamegrid-kill-timer)
(use-local-map tetris-null-map)
(gamegrid-add-score tetris-score-file tetris-score))
(defun tetris-start-game ()
- "Starts a new game of Tetris"
+ "Start a new game of Tetris."
(interactive)
(tetris-reset-game)
(use-local-map tetris-mode-map)
@@ -581,7 +574,7 @@ Drops the shape one square, testing for collision."
(gamegrid-start-timer period 'tetris-update-game)))
(defun tetris-pause-game ()
- "Pauses (or resumes) the current game"
+ "Pause (or resume) the current game."
(interactive)
(setq tetris-paused (not tetris-paused))
(message (and tetris-paused "Game paused (press p to resume)")))
@@ -591,21 +584,13 @@ Drops the shape one square, testing for collision."
(put 'tetris-mode 'mode-class 'special)
-(defun tetris-mode ()
- "A mode for playing Tetris.
-
-tetris-mode keybindings:
- \\{tetris-mode-map}
-"
- (kill-all-local-variables)
+(define-derived-mode tetris-mode nil "Tetris"
+ "A mode for playing Tetris."
(add-hook 'kill-buffer-hook 'gamegrid-kill-timer nil t)
(use-local-map tetris-null-map)
- (setq major-mode 'tetris-mode)
- (setq mode-name "Tetris")
-
(unless (featurep 'emacs)
(setq mode-popup-menu
'("Tetris Commands"
@@ -617,12 +602,12 @@ tetris-mode keybindings:
["Resume" tetris-pause-game
(and (tetris-active-p) tetris-paused)])))
+ (setq show-trailing-whitespace nil)
+
(setq gamegrid-use-glyphs tetris-use-glyphs)
(setq gamegrid-use-color tetris-use-color)
- (gamegrid-init (tetris-display-options))
-
- (run-mode-hooks 'tetris-mode-hook))
+ (gamegrid-init (tetris-display-options)))
;;;###autoload
(defun tetris ()
@@ -645,6 +630,8 @@ tetris-mode keybindings:
"
(interactive)
+ (select-window (or (get-buffer-window tetris-buffer-name)
+ (selected-window)))
(switch-to-buffer tetris-buffer-name)
(gamegrid-kill-timer)
(tetris-mode)
diff --git a/lisp/play/zone.el b/lisp/play/zone.el
index cf22be164d9..4fa5a8c3920 100644
--- a/lisp/play/zone.el
+++ b/lisp/play/zone.el
@@ -40,10 +40,6 @@
;;; Code:
-(require 'timer)
-(require 'tabify)
-(eval-when-compile (require 'cl))
-
(defvar zone-timer nil
"The timer we use to decide when to zone out, or nil if none.")
@@ -210,19 +206,20 @@ If the element is a function or a list of a function and a number,
(insert s)))
(defun zone-shift-left ()
- (let (s)
+ (let ((inhibit-point-motion-hooks t)
+ s)
(while (not (eobp))
(unless (eolp)
(setq s (buffer-substring (point) (1+ (point))))
(delete-char 1)
(end-of-line)
(insert s))
- (forward-char 1))))
+ (ignore-errors (forward-char 1)))))
(defun zone-shift-right ()
(goto-char (point-max))
- (end-of-line)
- (let (s)
+ (let ((inhibit-point-motion-hooks t)
+ s)
(while (not (bobp))
(unless (bolp)
(setq s (buffer-substring (1- (point)) (point)))
@@ -348,15 +345,8 @@ If the element is a function or a list of a function and a number,
(let ((np (+ 2 (random 5)))
(pm (point-max)))
(while (< np pm)
- (goto-char np)
- (let ((prec (preceding-char))
- (props (text-properties-at (1- (point)))))
- (insert (if (zerop (random 2))
- (upcase prec)
- (downcase prec)))
- (set-text-properties (1- (point)) (point) props))
- (backward-char 2)
- (delete-char 1)
+ (funcall (if (zerop (random 2)) 'upcase-region
+ 'downcase-region) (1- np) np)
(setq np (+ np (1+ (random 5))))))
(goto-char (point-min))
(sit-for 0 2)))
@@ -365,13 +355,14 @@ If the element is a function or a list of a function and a number,
;;;; rotating
(defun zone-line-specs ()
- (let (ret)
+ (let ((ok t)
+ ret)
(save-excursion
(goto-char (window-start))
- (while (< (point) (window-end))
+ (while (and ok (< (point) (window-end)))
(when (looking-at "[\t ]*\\([^\n]+\\)")
(setq ret (cons (cons (match-beginning 1) (match-end 1)) ret)))
- (forward-line 1)))
+ (setq ok (zerop (forward-line 1)))))
ret))
(defun zone-pgm-rotate (&optional random-style)
@@ -404,6 +395,7 @@ If the element is a function or a list of a function and a number,
(setq cut 1 paste 2)
(setq cut 2 paste 1))
(goto-char (aref ent cut))
+ (setq aamt (min aamt (- (point-max) (point))))
(setq txt (buffer-substring (point) (+ (point) aamt)))
(delete-char aamt)
(goto-char (aref ent paste))
@@ -447,19 +439,19 @@ If the element is a function or a list of a function and a number,
(hmm (cond
((string-match "[a-z]" c-string) (upcase c-string))
((string-match "[A-Z]" c-string) (downcase c-string))
- (t (propertize " " 'display `(space :width ,cw-ceil))))))
- (do ((i 0 (1+ i))
- (wait 0.5 (* wait 0.8)))
- ((= i 20))
+ (t (propertize " " 'display `(space :width ,cw-ceil)))))
+ (wait 0.5))
+ (dotimes (i 20)
(goto-char pos)
(delete-char 1)
(insert (if (= 0 (% i 2)) hmm c-string))
- (zone-park/sit-for wbeg wait))
+ (zone-park/sit-for wbeg (setq wait (* wait 0.8))))
(delete-char -1) (insert c-string)))
(defun zone-fill-out-screen (width height)
(let ((start (window-start))
- (line (make-string width 32)))
+ (line (make-string width 32))
+ (inhibit-point-motion-hooks t))
(goto-char start)
;; fill out rectangular ws block
(while (progn (end-of-line)
@@ -473,8 +465,7 @@ If the element is a function or a list of a function and a number,
(let ((nl (- height (count-lines (point-min) (point)))))
(when (> nl 0)
(setq line (concat line "\n"))
- (do ((i 0 (1+ i)))
- ((= i nl))
+ (dotimes (i nl)
(insert line))))
(goto-char start)
(recenter 0)
@@ -589,11 +580,12 @@ If the element is a function or a list of a function and a number,
(defun zone-pgm-stress ()
(goto-char (point-min))
- (let (lines)
- (while (< (point) (point-max))
+ (let ((ok t)
+ lines)
+ (while (and ok (< (point) (point-max)))
(let ((p (point)))
- (forward-line 1)
- (setq lines (cons (buffer-substring p (point)) lines))))
+ (setq ok (zerop (forward-line 1))
+ lines (cons (buffer-substring p (point)) lines))))
(sit-for 5)
(zone-hiding-modeline
(let ((msg "Zoning... (zone-pgm-stress)"))
@@ -673,7 +665,8 @@ If nil, `zone-pgm-random-life' chooses a value from 0-3 (inclusive).")
(setq c (point))
(move-to-column 9)
(setq col (cons (buffer-substring (point) c) col))
- (end-of-line 0)
+; (let ((inhibit-point-motion-hooks t))
+ (end-of-line 0);)
(forward-char -10))
(let ((life-patterns (vector
(if (and col (search-forward "@" max t))
diff --git a/lisp/printing.el b/lisp/printing.el
index 3fbf4c53355..ecbc82e0144 100644
--- a/lisp/printing.el
+++ b/lisp/printing.el
@@ -1387,20 +1387,6 @@ Used by `pr-menu-bind' and `pr-update-menus'.")
(require 'easymenu)) ; to avoid compilation gripes
(eval-and-compile
- (cond
- ;; GNU Emacs 20
- ((< emacs-major-version 21)
- (defun pr-global-menubar (pr-menu-spec)
- (require 'easymenu)
- (easy-menu-change '("tools") "Printing" pr-menu-spec pr-menu-print-item)
- (when pr-menu-print-item
- (easy-menu-remove-item nil '("tools") pr-menu-print-item)
- (setq pr-menu-print-item nil
- pr-menu-bar (vector 'menu-bar 'tools
- (pr-get-symbol "Printing")))))
- )
- ;; GNU Emacs 21 & 22
- (t
(defun pr-global-menubar (pr-menu-spec)
(require 'easymenu)
(let ((menu-file (if (= emacs-major-version 21)
@@ -1422,8 +1408,7 @@ Used by `pr-menu-bind' and `pr-update-menus'.")
(t
(easy-menu-add-item global-map menu-file
(easy-menu-create-menu "Print" pr-menu-spec)))
- )))
- )))
+ ))))
(eval-and-compile
(cond
diff --git a/lisp/progmodes/ada-mode.el b/lisp/progmodes/ada-mode.el
index 95f9f6babf3..fe97b1e8a57 100644
--- a/lisp/progmodes/ada-mode.el
+++ b/lisp/progmodes/ada-mode.el
@@ -1,7 +1,8 @@
;;; ada-mode.el --- major-mode for editing Ada sources
-;; Copyright (C) 1994, 1995, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 1995, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+;; 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Rolf Ebert <ebert@inf.enst.fr>
;; Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de>
@@ -834,10 +835,7 @@ the 4 file locations can be clicked on and jumped to."
;;
;; On Emacs, this is done through the `syntax-table' text property. The
;; corresponding action is applied automatically each time the buffer
-;; changes. If `font-lock-mode' is enabled (the default) the action is
-;; set up by `font-lock-syntactic-keywords'. Otherwise, we do it
-;; manually in `ada-after-change-function'. The proper method is
-;; installed by `ada-handle-syntax-table-properties'.
+;; changes via syntax-propertize-function.
;;
;; on XEmacs, the `syntax-table' property does not exist and we have to use a
;; slow advice to `parse-partial-sexp' to do the same thing.
@@ -937,6 +935,12 @@ declares it as a word constituent."
(insert (caddar change))
(setq change (cdr change)))))))
+(unless (eval-when-compile (fboundp 'syntax-propertize-via-font-lock))
+ ;; Before `syntax-propertize', we had to use font-lock to apply syntax-table
+ ;; properties, and in some cases we even had to do it manually (in
+ ;; `ada-after-change-function'). `ada-handle-syntax-table-properties'
+ ;; decides which method to use.
+
(defun ada-set-syntax-table-properties ()
"Assign `syntax-table' properties in accessible part of buffer.
In particular, character constants are said to be strings, #...#
@@ -991,6 +995,8 @@ OLD-LEN indicates what the length of the replaced text was."
;; Take care of `syntax-table' properties manually.
(ada-initialize-syntax-table-properties)))
+) ;;(not (fboundp 'syntax-propertize))
+
;;------------------------------------------------------------------
;; Testing the grammatical context
;;------------------------------------------------------------------
@@ -1112,13 +1118,14 @@ the file name."
(funcall (symbol-function 'speedbar-add-supported-extension)
spec)
(funcall (symbol-function 'speedbar-add-supported-extension)
- body)))
- )
+ body))))
+(defvar ada-font-lock-syntactic-keywords) ; defined below
;;;###autoload
(defun ada-mode ()
- "Ada mode is the major mode for editing Ada code."
+ "Ada mode is the major mode for editing Ada code.
+\\{ada-mode-map}"
(interactive)
(kill-all-local-variables)
@@ -1161,9 +1168,9 @@ the file name."
(set (make-local-variable 'comment-padding) 0)
(set (make-local-variable 'parse-sexp-lookup-properties) t))
- (set 'case-fold-search t)
+ (setq case-fold-search t)
(if (boundp 'imenu-case-fold-search)
- (set 'imenu-case-fold-search t))
+ (setq imenu-case-fold-search t))
(set (make-local-variable 'fill-paragraph-function)
'ada-fill-comment-paragraph)
@@ -1186,8 +1193,13 @@ the file name."
'(ada-font-lock-keywords
nil t
((?\_ . "w") (?# . "."))
- beginning-of-line
- (font-lock-syntactic-keywords . ada-font-lock-syntactic-keywords)))
+ beginning-of-line))
+
+ (if (eval-when-compile (fboundp 'syntax-propertize-via-font-lock))
+ (set (make-local-variable 'syntax-propertize-function)
+ (syntax-propertize-via-font-lock ada-font-lock-syntactic-keywords))
+ (set (make-local-variable 'font-lock-syntactic-keywords)
+ ada-font-lock-syntactic-keywords))
;; Set up support for find-file.el.
(set (make-local-variable 'ff-other-file-alist)
@@ -1322,22 +1334,24 @@ the file name."
;; To be run after the hook, in case the user modified
;; ada-fill-comment-prefix
- (make-local-variable 'comment-start)
- (if ada-fill-comment-prefix
- (set 'comment-start ada-fill-comment-prefix)
- (set 'comment-start "-- "))
+ ;; FIXME: if the user modified ada-fill-comment-prefix in his .emacs
+ ;; then it was already available before running the hook, and if he
+ ;; modifies it in the hook, he might as well modify comment-start instead.
+ (set (make-local-variable 'comment-start) (or ada-fill-comment-prefix "-- "))
;; Run this after the hook to give the users a chance to activate
;; font-lock-mode
- (unless (featurep 'xemacs)
+ (unless (or (eval-when-compile (fboundp 'syntax-propertize-via-font-lock))
+ (featurep 'xemacs))
(ada-initialize-syntax-table-properties)
(add-hook 'font-lock-mode-hook 'ada-handle-syntax-table-properties nil t))
;; the following has to be done after running the ada-mode-hook
;; because users might want to set the values of these variable
;; inside the hook
-
+ ;; FIXME: it might even be set later on via file-local vars, no?
+ ;; so maybe ada-keywords should be set lazily.
(cond ((eq ada-language-version 'ada83)
(setq ada-keywords ada-83-keywords))
((eq ada-language-version 'ada95)
@@ -1397,25 +1411,21 @@ If WORD is not given, then the current word in the buffer is used instead.
The new word is added to the first file in `ada-case-exception-file'.
The standard casing rules will no longer apply to this word."
(interactive)
- (let ((previous-syntax-table (syntax-table))
- file-name
- )
-
- (cond ((stringp ada-case-exception-file)
- (setq file-name ada-case-exception-file))
- ((listp ada-case-exception-file)
- (setq file-name (car ada-case-exception-file)))
- (t
- (error (concat "No exception file specified. "
- "See variable ada-case-exception-file"))))
+ (let ((file-name
+ (cond ((stringp ada-case-exception-file)
+ ada-case-exception-file)
+ ((listp ada-case-exception-file)
+ (car ada-case-exception-file))
+ (t
+ (error (concat "No exception file specified. "
+ "See variable ada-case-exception-file"))))))
- (set-syntax-table ada-mode-symbol-syntax-table)
(unless word
- (save-excursion
- (skip-syntax-backward "w")
- (setq word (buffer-substring-no-properties
- (point) (save-excursion (forward-word 1) (point))))))
- (set-syntax-table previous-syntax-table)
+ (with-syntax-table ada-mode-symbol-syntax-table
+ (save-excursion
+ (skip-syntax-backward "w")
+ (setq word (buffer-substring-no-properties
+ (point) (save-excursion (forward-word 1) (point)))))))
;; Reread the exceptions file, in case it was modified by some other,
(ada-case-read-exceptions-from-file file-name)
@@ -1425,11 +1435,9 @@ The standard casing rules will no longer apply to this word."
(if (and (not (equal ada-case-exception '()))
(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))
- )
+ (add-to-list 'ada-case-exception (cons word t)))
- (ada-save-exceptions-to-file file-name)
- ))
+ (ada-save-exceptions-to-file file-name)))
(defun ada-create-case-exception-substring (&optional word)
"Define the substring WORD as an exception for the casing system.
@@ -1464,7 +1472,7 @@ word itself has a special casing."
(modify-syntax-entry ?_ "." (syntax-table))
(save-excursion
(skip-syntax-backward "w")
- (set 'word (buffer-substring-no-properties
+ (setq word (buffer-substring-no-properties
(point)
(save-excursion (forward-word 1) (point))))))
(modify-syntax-entry ?_ (make-string 1 underscore-syntax)
@@ -1633,37 +1641,30 @@ ARG is the prefix the user entered with \\[universal-argument]."
(interactive "P")
(if ada-auto-case
- (let ((lastk last-command-event)
- (previous-syntax-table (syntax-table)))
-
- (unwind-protect
- (progn
- (set-syntax-table ada-mode-symbol-syntax-table)
- (cond ((or (eq lastk ?\n)
- (eq lastk ?\r))
- ;; horrible kludge
- (insert " ")
- (ada-adjust-case)
- ;; horrible dekludge
- (delete-backward-char 1)
- ;; some special keys and their bindings
- (cond
- ((eq lastk ?\n)
- (funcall ada-lfd-binding))
- ((eq lastk ?\r)
- (funcall ada-ret-binding))))
- ((eq lastk ?\C-i) (ada-tab))
- ;; Else just insert the character
- ((self-insert-command (prefix-numeric-value arg))))
- ;; if there is a keyword in front of the underscore
- ;; then it should be part of an identifier (MH)
- (if (eq lastk ?_)
- (ada-adjust-case t)
- (ada-adjust-case))
- )
- ;; Restore the syntax table
- (set-syntax-table previous-syntax-table))
- )
+ (let ((lastk last-command-event))
+
+ (with-syntax-table ada-mode-symbol-syntax-table
+ (cond ((or (eq lastk ?\n)
+ (eq lastk ?\r))
+ ;; horrible kludge
+ (insert " ")
+ (ada-adjust-case)
+ ;; horrible dekludge
+ (delete-char -1)
+ ;; some special keys and their bindings
+ (cond
+ ((eq lastk ?\n)
+ (funcall ada-lfd-binding))
+ ((eq lastk ?\r)
+ (funcall ada-ret-binding))))
+ ((eq lastk ?\C-i) (ada-tab))
+ ;; Else just insert the character
+ ((self-insert-command (prefix-numeric-value arg))))
+ ;; if there is a keyword in front of the underscore
+ ;; then it should be part of an identifier (MH)
+ (if (eq lastk ?_)
+ (ada-adjust-case t)
+ (ada-adjust-case))))
;; Else, no auto-casing
(cond
@@ -1672,10 +1673,10 @@ ARG is the prefix the user entered with \\[universal-argument]."
((eq last-command-event ?\r)
(funcall ada-ret-binding))
(t
- (self-insert-command (prefix-numeric-value arg))))
- ))
+ (self-insert-command (prefix-numeric-value arg))))))
(defun ada-activate-keys-for-case ()
+ ;; FIXME: Use post-self-insert-hook instead of changing key bindings.
"Modify the key bindings for all the keys that should readjust the casing."
(interactive)
;; Save original key-bindings to allow swapping ret/lfd
@@ -1735,44 +1736,41 @@ Attention: This function might take very long for big regions!"
(let ((begin nil)
(end nil)
(keywordp nil)
- (attribp nil)
- (previous-syntax-table (syntax-table)))
+ (attribp nil))
(message "Adjusting case ...")
- (unwind-protect
- (save-excursion
- (set-syntax-table ada-mode-symbol-syntax-table)
- (goto-char to)
- ;;
- ;; loop: look for all identifiers, keywords, and attributes
- ;;
- (while (re-search-backward "\\<\\(\\sw+\\)\\>" from t)
- (setq end (match-end 1))
- (setq attribp
- (and (> (point) from)
- (save-excursion
- (forward-char -1)
- (setq attribp (looking-at "'.[^']")))))
- (or
- ;; do nothing if it is a string or comment
- (ada-in-string-or-comment-p)
- (progn
- ;;
- ;; get the identifier or keyword or attribute
- ;;
- (setq begin (point))
- (setq keywordp (looking-at ada-keywords))
- (goto-char end)
- ;;
- ;; casing according to user-option
- ;;
- (if attribp
- (funcall ada-case-attribute -1)
- (if keywordp
- (funcall ada-case-keyword -1)
- (ada-adjust-case-identifier)))
- (goto-char begin))))
- (message "Adjusting case ... Done"))
- (set-syntax-table previous-syntax-table))))
+ (with-syntax-table ada-mode-symbol-syntax-table
+ (save-excursion
+ (goto-char to)
+ ;;
+ ;; loop: look for all identifiers, keywords, and attributes
+ ;;
+ (while (re-search-backward "\\<\\(\\sw+\\)\\>" from t)
+ (setq end (match-end 1))
+ (setq attribp
+ (and (> (point) from)
+ (save-excursion
+ (forward-char -1)
+ (setq attribp (looking-at "'.[^']")))))
+ (or
+ ;; do nothing if it is a string or comment
+ (ada-in-string-or-comment-p)
+ (progn
+ ;;
+ ;; get the identifier or keyword or attribute
+ ;;
+ (setq begin (point))
+ (setq keywordp (looking-at ada-keywords))
+ (goto-char end)
+ ;;
+ ;; casing according to user-option
+ ;;
+ (if attribp
+ (funcall ada-case-attribute -1)
+ (if keywordp
+ (funcall ada-case-keyword -1)
+ (ada-adjust-case-identifier)))
+ (goto-char begin))))
+ (message "Adjusting case ... Done")))))
(defun ada-adjust-case-buffer ()
"Adjust the case of all words in the whole buffer.
@@ -1803,46 +1801,39 @@ ATTENTION: This function might take very long for big buffers!"
(let ((begin nil)
(end nil)
(delend nil)
- (paramlist nil)
- (previous-syntax-table (syntax-table)))
- (unwind-protect
- (progn
- (set-syntax-table ada-mode-symbol-syntax-table)
-
- ;; check if really inside parameter list
- (or (ada-in-paramlist-p)
- (error "Not in parameter list"))
+ (paramlist nil))
+ (with-syntax-table ada-mode-symbol-syntax-table
- ;; find start of current parameter-list
- (ada-search-ignore-string-comment
- (concat ada-subprog-start-re "\\|\\<body\\>" ) t nil)
- (down-list 1)
- (backward-char 1)
- (setq begin (point))
+ ;; check if really inside parameter list
+ (or (ada-in-paramlist-p)
+ (error "Not in parameter list"))
- ;; find end of parameter-list
- (forward-sexp 1)
- (setq delend (point))
- (delete-char -1)
- (insert "\n")
+ ;; find start of current parameter-list
+ (ada-search-ignore-string-comment
+ (concat ada-subprog-start-re "\\|\\<body\\>" ) t nil)
+ (down-list 1)
+ (backward-char 1)
+ (setq begin (point))
- ;; find end of last parameter-declaration
- (forward-comment -1000)
- (setq end (point))
+ ;; find end of parameter-list
+ (forward-sexp 1)
+ (setq delend (point))
+ (delete-char -1)
+ (insert "\n")
- ;; build a list of all elements of the parameter-list
- (setq paramlist (ada-scan-paramlist (1+ begin) end))
+ ;; find end of last parameter-declaration
+ (forward-comment -1000)
+ (setq end (point))
- ;; delete the original parameter-list
- (delete-region begin delend)
+ ;; build a list of all elements of the parameter-list
+ (setq paramlist (ada-scan-paramlist (1+ begin) end))
- ;; insert the new parameter-list
- (goto-char begin)
- (ada-insert-paramlist paramlist))
+ ;; delete the original parameter-list
+ (delete-region begin delend)
- ;; restore syntax-table
- (set-syntax-table previous-syntax-table)
- )))
+ ;; insert the new parameter-list
+ (goto-char begin)
+ (ada-insert-paramlist paramlist))))
(defun ada-scan-paramlist (begin end)
"Scan the parameter list found in between BEGIN and END.
@@ -2186,14 +2177,12 @@ Return the new position of point or nil if not found."
Return the calculation that was done, including the reference point
and the offset."
(interactive)
- (let ((previous-syntax-table (syntax-table))
- (orgpoint (point-marker))
+ (let ((orgpoint (point-marker))
cur-indent tmp-indent
prev-indent)
(unwind-protect
- (progn
- (set-syntax-table ada-mode-symbol-syntax-table)
+ (with-syntax-table ada-mode-symbol-syntax-table
;; This need to be done here so that the advice is not always
;; activated (this might interact badly with other modes)
@@ -2203,14 +2192,14 @@ and the offset."
(save-excursion
(setq cur-indent
- ;; Not First line in the buffer ?
- (if (save-excursion (zerop (forward-line -1)))
- (progn
- (back-to-indentation)
- (ada-get-current-indent))
+ ;; Not First line in the buffer ?
+ (if (save-excursion (zerop (forward-line -1)))
+ (progn
+ (back-to-indentation)
+ (ada-get-current-indent))
- ;; first line in the buffer
- (list (point-min) 0))))
+ ;; first line in the buffer
+ (list (point-min) 0))))
;; Evaluate the list to get the column to indent to
;; prev-indent contains the column to indent to
@@ -2242,14 +2231,10 @@ and the offset."
(if (< (current-column) (current-indentation))
(back-to-indentation)))
- ;; restore syntax-table
- (set-syntax-table previous-syntax-table)
(if (featurep 'xemacs)
- (ad-deactivate 'parse-partial-sexp))
- )
+ (ad-deactivate 'parse-partial-sexp)))
- cur-indent
- ))
+ cur-indent))
(defun ada-get-current-indent ()
"Return the indentation to use for the current line."
@@ -2487,8 +2472,7 @@ and the offset."
(if (and ada-indent-is-separate
(save-excursion
(goto-char (match-end 0))
- (ada-goto-next-non-ws (save-excursion (end-of-line)
- (point)))
+ (ada-goto-next-non-ws (point-at-eol))
(looking-at "\\<abstract\\>\\|\\<separate\\>")))
(save-excursion
(ada-goto-stmt-start)
@@ -2512,11 +2496,11 @@ and the offset."
(if (looking-at "renames")
(let (pos)
(save-excursion
- (set 'pos (ada-search-ignore-string-comment ";\\|return\\>" t)))
+ (setq pos (ada-search-ignore-string-comment ";\\|return\\>" t)))
(if (and pos
(= (downcase (char-after (car pos))) ?r))
(goto-char (car pos)))
- (set 'var 'ada-indent-renames)))
+ (setq var 'ada-indent-renames)))
(forward-comment -1000)
(if (= (char-before) ?\))
@@ -2533,7 +2517,7 @@ and the offset."
(looking-at "\\(function\\|procedure\\)\\>"))
(progn
(backward-word 1)
- (set 'num-back 2)
+ (setq num-back 2)
(looking-at "\\(function\\|procedure\\)\\>")))))
;; The indentation depends of the value of ada-indent-return
@@ -2595,10 +2579,7 @@ and the offset."
(forward-line -1)
(beginning-of-line)
(while (and (not pos)
- (search-forward "--"
- (save-excursion
- (end-of-line) (point))
- t))
+ (search-forward "--" (point-at-eol) t))
(unless (ada-in-string-p)
(setq pos (point))))
pos))
@@ -2617,7 +2598,7 @@ and the offset."
((and (= (char-after) ?#)
(equal ada-which-compiler 'gnat)
(looking-at "#[ \t]*\\(if\\|els\\(e\\|if\\)\\|end[ \t]*if\\)"))
- (list (save-excursion (beginning-of-line) (point)) 0))
+ (list (point-at-bol) 0))
;;--------------------------------
;; starting with ')' (end of a parameter list)
@@ -4046,8 +4027,7 @@ Point is moved at the beginning of the SEARCH-RE."
(let (found
begin
end
- parse-result
- (previous-syntax-table (syntax-table)))
+ parse-result)
;; FIXME: need to pass BACKWARD to search-func!
(unless search-func
@@ -4057,67 +4037,61 @@ Point is moved at the beginning of the SEARCH-RE."
;; search until found or end-of-buffer
;; We have to test that we do not look further than limit
;;
- (set-syntax-table ada-mode-symbol-syntax-table)
- (while (and (not found)
- (or (not limit)
- (or (and backward (<= limit (point)))
- (>= limit (point))))
- (funcall search-func search-re limit 1))
- (setq begin (match-beginning 0))
- (setq end (match-end 0))
-
- (setq parse-result (parse-partial-sexp
- (save-excursion (beginning-of-line) (point))
- (point)))
-
- (cond
- ;;
- ;; If inside a string, skip it (and the following comments)
- ;;
- ((ada-in-string-p parse-result)
- (if (featurep 'xemacs)
- (search-backward "\"" nil t)
- (goto-char (nth 8 parse-result)))
- (unless backward (forward-sexp 1)))
- ;;
- ;; If inside a comment, skip it (and the following comments)
- ;; There is a special code for comments at the end of the file
- ;;
- ((ada-in-comment-p parse-result)
- (if (featurep 'xemacs)
- (progn
- (forward-line 1)
- (beginning-of-line)
- (forward-comment -1))
- (goto-char (nth 8 parse-result)))
- (unless backward
- ;; at the end of the file, it is not possible to skip a comment
- ;; so we just go at the end of the line
- (if (forward-comment 1)
- (progn
- (forward-comment 1000)
- (beginning-of-line))
- (end-of-line))))
- ;;
- ;; directly in front of a comment => skip it, if searching forward
- ;;
- ((and (= (char-after begin) ?-) (= (char-after (1+ begin)) ?-))
- (unless backward (progn (forward-char -1) (forward-comment 1000))))
-
- ;;
- ;; found a parameter-list but should ignore it => skip it
- ;;
- ((and (not paramlists) (ada-in-paramlist-p))
- (if backward
- (search-backward "(" nil t)
- (search-forward ")" nil t)))
- ;;
- ;; found what we were looking for
- ;;
- (t
- (setq found t)))) ; end of loop
-
- (set-syntax-table previous-syntax-table)
+ (with-syntax-table ada-mode-symbol-syntax-table
+ (while (and (not found)
+ (or (not limit)
+ (or (and backward (<= limit (point)))
+ (>= limit (point))))
+ (funcall search-func search-re limit 1))
+ (setq begin (match-beginning 0))
+ (setq end (match-end 0))
+ (setq parse-result (parse-partial-sexp (point-at-bol) (point)))
+ (cond
+ ;;
+ ;; If inside a string, skip it (and the following comments)
+ ;;
+ ((ada-in-string-p parse-result)
+ (if (featurep 'xemacs)
+ (search-backward "\"" nil t)
+ (goto-char (nth 8 parse-result)))
+ (unless backward (forward-sexp 1)))
+ ;;
+ ;; If inside a comment, skip it (and the following comments)
+ ;; There is a special code for comments at the end of the file
+ ;;
+ ((ada-in-comment-p parse-result)
+ (if (featurep 'xemacs)
+ (progn
+ (forward-line 1)
+ (beginning-of-line)
+ (forward-comment -1))
+ (goto-char (nth 8 parse-result)))
+ (unless backward
+ ;; at the end of the file, it is not possible to skip a comment
+ ;; so we just go at the end of the line
+ (if (forward-comment 1)
+ (progn
+ (forward-comment 1000)
+ (beginning-of-line))
+ (end-of-line))))
+ ;;
+ ;; directly in front of a comment => skip it, if searching forward
+ ;;
+ ((and (= (char-after begin) ?-) (= (char-after (1+ begin)) ?-))
+ (unless backward (progn (forward-char -1) (forward-comment 1000))))
+
+ ;;
+ ;; found a parameter-list but should ignore it => skip it
+ ;;
+ ((and (not paramlists) (ada-in-paramlist-p))
+ (if backward
+ (search-backward "(" nil t)
+ (search-forward ")" nil t)))
+ ;;
+ ;; found what we were looking for
+ ;;
+ (t
+ (setq found t))))) ; end of loop
(if found
(cons begin end)
@@ -4290,16 +4264,12 @@ of the region. Otherwise, operate only on the current line."
(save-excursion
(beginning-of-line)
(insert-char ? ada-indent))
- (if (save-excursion (= (point) (progn (beginning-of-line) (point))))
- (forward-char ada-indent)))
+ (if (bolp) (forward-char ada-indent)))
(defun ada-untab-hard ()
"Indent current line to previous tab stop."
(interactive)
- (let ((bol (save-excursion (progn (beginning-of-line) (point))))
- (eol (save-excursion (progn (end-of-line) (point)))))
- (indent-rigidly bol eol (- 0 ada-indent))))
-
+ (indent-rigidly (point-at-bol) (point-at-eol) (- 0 ada-indent)))
;; ------------------------------------------------------------
@@ -4398,122 +4368,109 @@ of the region. Otherwise, operate only on the current line."
(defun ada-move-to-start ()
"Move point to the matching start of the current Ada structure."
(interactive)
- (let ((pos (point))
- (previous-syntax-table (syntax-table)))
- (unwind-protect
- (progn
- (set-syntax-table ada-mode-symbol-syntax-table)
-
- (save-excursion
- ;;
- ;; do nothing if in string or comment or not on 'end ...;'
- ;; or if an error occurs during processing
- ;;
- (or
- (ada-in-string-or-comment-p)
- (and (progn
- (or (looking-at "[ \t]*\\<end\\>")
- (backward-word 1))
- (or (looking-at "[ \t]*\\<end\\>")
- (backward-word 1))
- (or (looking-at "[ \t]*\\<end\\>")
- (error "Not on end ...;")))
- (ada-goto-matching-start 1)
- (setq pos (point))
-
- ;;
- ;; on 'begin' => go on, according to user option
- ;;
- ada-move-to-declaration
- (looking-at "\\<begin\\>")
- (ada-goto-decl-start)
- (setq pos (point))))
-
- ) ; end of save-excursion
-
- ;; now really move to the found position
- (goto-char pos))
+ (let ((pos (point)))
+ (with-syntax-table ada-mode-symbol-syntax-table
- ;; restore syntax-table
- (set-syntax-table previous-syntax-table))))
+ (save-excursion
+ ;;
+ ;; do nothing if in string or comment or not on 'end ...;'
+ ;; or if an error occurs during processing
+ ;;
+ (or
+ (ada-in-string-or-comment-p)
+ (and (progn
+ (or (looking-at "[ \t]*\\<end\\>")
+ (backward-word 1))
+ (or (looking-at "[ \t]*\\<end\\>")
+ (backward-word 1))
+ (or (looking-at "[ \t]*\\<end\\>")
+ (error "Not on end ...;")))
+ (ada-goto-matching-start 1)
+ (setq pos (point))
+
+ ;;
+ ;; on 'begin' => go on, according to user option
+ ;;
+ ada-move-to-declaration
+ (looking-at "\\<begin\\>")
+ (ada-goto-decl-start)
+ (setq pos (point))))
+
+ ) ; end of save-excursion
+
+ ;; now really move to the found position
+ (goto-char pos))))
(defun ada-move-to-end ()
"Move point to the end of the block around point.
Moves to 'begin' if in a declarative part."
(interactive)
(let ((pos (point))
- decl-start
- (previous-syntax-table (syntax-table)))
- (unwind-protect
- (progn
- (set-syntax-table ada-mode-symbol-syntax-table)
-
- (save-excursion
-
- (cond
- ;; Go to the beginning of the current word, and check if we are
- ;; directly on 'begin'
- ((save-excursion
- (skip-syntax-backward "w")
- (looking-at "\\<begin\\>"))
- (ada-goto-matching-end 1)
- )
-
- ;; on first line of subprogram body
- ;; Do nothing for specs or generic instantion, since these are
- ;; handled as the general case (find the enclosing block)
- ;; We also need to make sure that we ignore nested subprograms
- ((save-excursion
- (and (skip-syntax-backward "w")
- (looking-at "\\<function\\>\\|\\<procedure\\>" )
- (ada-search-ignore-string-comment "is\\|;")
- (not (= (char-before) ?\;))
- ))
- (skip-syntax-backward "w")
- (ada-goto-matching-end 0 t))
-
- ;; on first line of task declaration
- ((save-excursion
- (and (ada-goto-stmt-start)
- (looking-at "\\<task\\>" )
- (forward-word 1)
- (ada-goto-next-non-ws)
- (looking-at "\\<body\\>")))
- (ada-search-ignore-string-comment "begin" nil nil nil
- 'word-search-forward))
- ;; accept block start
- ((save-excursion
- (and (ada-goto-stmt-start)
- (looking-at "\\<accept\\>" )))
- (ada-goto-matching-end 0))
- ;; package start
- ((save-excursion
- (setq decl-start (and (ada-goto-decl-start t) (point)))
- (and decl-start (looking-at "\\<package\\>")))
- (ada-goto-matching-end 1))
-
- ;; On a "declare" keyword
- ((save-excursion
- (skip-syntax-backward "w")
- (looking-at "\\<declare\\>"))
- (ada-goto-matching-end 0 t))
+ decl-start)
+ (with-syntax-table ada-mode-symbol-syntax-table
- ;; inside a 'begin' ... 'end' block
- (decl-start
- (goto-char decl-start)
- (ada-goto-matching-end 0 t))
-
- ;; (hopefully ;-) everything else
- (t
- (ada-goto-matching-end 1)))
- (setq pos (point))
- )
-
- ;; now really move to the position found
- (goto-char pos))
+ (save-excursion
- ;; restore syntax-table
- (set-syntax-table previous-syntax-table))))
+ (cond
+ ;; Go to the beginning of the current word, and check if we are
+ ;; directly on 'begin'
+ ((save-excursion
+ (skip-syntax-backward "w")
+ (looking-at "\\<begin\\>"))
+ (ada-goto-matching-end 1))
+
+ ;; on first line of subprogram body
+ ;; Do nothing for specs or generic instantion, since these are
+ ;; handled as the general case (find the enclosing block)
+ ;; We also need to make sure that we ignore nested subprograms
+ ((save-excursion
+ (and (skip-syntax-backward "w")
+ (looking-at "\\<function\\>\\|\\<procedure\\>" )
+ (ada-search-ignore-string-comment "is\\|;")
+ (not (= (char-before) ?\;))
+ ))
+ (skip-syntax-backward "w")
+ (ada-goto-matching-end 0 t))
+
+ ;; on first line of task declaration
+ ((save-excursion
+ (and (ada-goto-stmt-start)
+ (looking-at "\\<task\\>" )
+ (forward-word 1)
+ (ada-goto-next-non-ws)
+ (looking-at "\\<body\\>")))
+ (ada-search-ignore-string-comment "begin" nil nil nil
+ 'word-search-forward))
+ ;; accept block start
+ ((save-excursion
+ (and (ada-goto-stmt-start)
+ (looking-at "\\<accept\\>" )))
+ (ada-goto-matching-end 0))
+ ;; package start
+ ((save-excursion
+ (setq decl-start (and (ada-goto-decl-start t) (point)))
+ (and decl-start (looking-at "\\<package\\>")))
+ (ada-goto-matching-end 1))
+
+ ;; On a "declare" keyword
+ ((save-excursion
+ (skip-syntax-backward "w")
+ (looking-at "\\<declare\\>"))
+ (ada-goto-matching-end 0 t))
+
+ ;; inside a 'begin' ... 'end' block
+ (decl-start
+ (goto-char decl-start)
+ (ada-goto-matching-end 0 t))
+
+ ;; (hopefully ;-) everything else
+ (t
+ (ada-goto-matching-end 1)))
+ (setq pos (point))
+ )
+
+ ;; now really move to the position found
+ (goto-char pos))))
(defun ada-next-procedure ()
"Move point to next procedure."
@@ -4818,7 +4775,7 @@ Moves to 'begin' if in a declarative part."
(if (featurep 'xemacs)
(progn
(define-key ada-mode-map [menu-bar] ada-mode-menu)
- (set 'mode-popup-menu (cons "Ada mode" ada-mode-menu))))))
+ (setq mode-popup-menu (cons "Ada mode" ada-mode-menu))))))
;; -------------------------------------------------------
@@ -5040,7 +4997,7 @@ or the spec otherwise."
(ada-find-src-file-in-dir
(file-name-nondirectory (concat name (car suffixes))))))
(if other
- (set 'is-spec other)))
+ (setq is-spec other)))
;; Else search in the current directory
(if (file-exists-p (concat name (car suffixes)))
@@ -5324,11 +5281,7 @@ Use \\[widen] to go back to the full visibility for the buffer."
(widen)
(forward-line 1)
(ada-previous-procedure)
-
- (save-excursion
- (beginning-of-line)
- (setq end (point)))
-
+ (setq end (point-at-bol))
(ada-move-to-end)
(end-of-line)
(narrow-to-region end (point))
@@ -5570,5 +5523,4 @@ This function typically is to be hooked into `ff-file-created-hook'."
;;; provide ourselves
(provide 'ada-mode)
-;; arch-tag: 1b7d45ec-1698-43b5-8d4a-e479ea023270
;;; ada-mode.el ends here
diff --git a/lisp/progmodes/ada-prj.el b/lisp/progmodes/ada-prj.el
index 0ae93c392a7..c726c06d1d3 100644
--- a/lisp/progmodes/ada-prj.el
+++ b/lisp/progmodes/ada-prj.el
@@ -6,6 +6,7 @@
;; Author: Emmanuel Briot <briot@gnat.com>
;; Maintainer: Stephen Leake <stephen_leake@stephe-leake.org>
;; Keywords: languages, ada, project file
+;; Package: ada-mode
;; This file is part of GNU Emacs.
@@ -195,21 +196,17 @@ One item per line should be found in the file."
(widen)
(goto-char (point-min))
(while (not (eobp))
- (set 'line (buffer-substring-no-properties
- (point) (save-excursion (end-of-line) (point))))
+ (set 'line (buffer-substring-no-properties (point) (point-at-eol)))
(add-to-list 'list line)
- (forward-line 1)
- )
+ (forward-line 1))
(kill-buffer nil)
(set-buffer buffer)
(set 'ada-prj-current-values
(plist-put ada-prj-current-values
symbol
(append (plist-get ada-prj-current-values symbol)
- (reverse list))))
- )
- (ada-prj-display-page 2)
- ))
+ (reverse list)))))
+ (ada-prj-display-page 2)))
(defun ada-prj-subdirs-of (dir)
"Return a list of all the subdirectories of DIR, recursively."
@@ -567,8 +564,7 @@ Parameters WIDGET-MODIFIED, EVENT match :notify for the widget."
;; variables
(momentary-string-display
(concat "*****Help*****\n" text "\n**************\n")
- (save-excursion (forward-line) (beginning-of-line) (point)))
- )))
+ (point-at-bol 2)))))
(defun ada-prj-show-value (widget widget-modified event)
"Show the current field value in WIDGET.
@@ -680,5 +676,4 @@ AFTER-TEXT is inserted just after the widget."
(provide 'ada-prj)
-;; arch-tag: 65978c77-816e-49c6-896e-6905605d1b4c
;;; ada-prj.el ends here
diff --git a/lisp/progmodes/ada-stmt.el b/lisp/progmodes/ada-stmt.el
index 103bc093bdb..b618b26c73a 100644
--- a/lisp/progmodes/ada-stmt.el
+++ b/lisp/progmodes/ada-stmt.el
@@ -9,6 +9,7 @@
;; Rolf Ebert <ebert@waporo.muc.de>
;; Maintainer: Stephen Leake <stephen_leake@stephe-leake.org>
;; Keywords: languages, ada
+;; Package: ada-mode
;; This file is part of GNU Emacs.
diff --git a/lisp/progmodes/ada-xref.el b/lisp/progmodes/ada-xref.el
index bf836b20eee..36e297182cf 100644
--- a/lisp/progmodes/ada-xref.el
+++ b/lisp/progmodes/ada-xref.el
@@ -1,13 +1,15 @@
;; ada-xref.el --- for lookup and completion in Ada mode
-;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de>
;; Rolf Ebert <ebert@inf.enst.fr>
;; Emmanuel Briot <briot@gnat.com>
;; Maintainer: Stephen Leake <stephen_leake@stephe-leake.org>
;; Keywords: languages ada xref
+;; Package: ada-mode
;; This file is part of GNU Emacs.
@@ -108,10 +110,9 @@ the Ada mode project."
:type 'string :group 'ada)
(defcustom ada-prj-ada-project-path-sep
- (if (or (equal system-type 'windows-nt)
- (equal system-type 'ms-dos))
- ";"
- ":")
+ (cond ((boundp 'path-separator) path-separator) ; 20.3+
+ ((memq system-type '(windows-nt ms-dos)) ";")
+ (t ":"))
"Default separator for ada_project_path project variable."
:type 'string :group 'ada)
@@ -166,7 +167,7 @@ This has the same syntax as in the project file (with variable substitution)."
Otherwise, ask the user for the name of the project file to use."
:type 'boolean :group 'ada)
-(defconst is-windows (memq system-type (quote (windows-nt)))
+(defconst ada-on-ms-windows (memq system-type '(windows-nt))
"True if we are running on Windows.")
(defcustom ada-tight-gvd-integration nil
@@ -221,7 +222,7 @@ Used to go back to these positions.")
On Windows systems using `cmdproxy.exe' as the shell,
we need to use `/d' or the drive is never changed.")
-(defvar ada-command-separator (if is-windows " && " "\n")
+(defvar ada-command-separator (if ada-on-ms-windows " && " "\n")
"Separator to use between multiple commands to `compile' or `start-process'.
`cmdproxy.exe' doesn't recognize multiple-line commands, so we have to use
\"&&\" for now.")
@@ -324,7 +325,7 @@ CROSS-PREFIX is the prefix to use for the `gnatls' command."
(add-to-list 'ada-xref-runtime-library-specs-path
(buffer-substring-no-properties
(point)
- (save-excursion (end-of-line) (point)))))
+ (point-at-eol))))
(forward-line 1))
;; Object path
@@ -338,7 +339,7 @@ CROSS-PREFIX is the prefix to use for the `gnatls' command."
(add-to-list 'ada-xref-runtime-library-ali-path
(buffer-substring-no-properties
(point)
- (save-excursion (end-of-line) (point)))))
+ (point-at-eol))))
(forward-line 1))
)
(kill-buffer nil))))
@@ -381,9 +382,9 @@ Assumes environment variable ADA_PROJECT_PATH is set properly."
(forward-line 1) ; first directory in list
(while (not (looking-at "^$")) ; terminate on blank line
(back-to-indentation) ; skip whitespace
- (if (looking-at "<Current_Directory>")
- (add-to-list 'src-dir (expand-file-name "."))
- (add-to-list 'src-dir
+ (add-to-list 'src-dir
+ (if (looking-at "<Current_Directory>")
+ default-directory
(expand-file-name
(buffer-substring-no-properties
(point) (line-end-position)))))
@@ -395,9 +396,9 @@ Assumes environment variable ADA_PROJECT_PATH is set properly."
(forward-line 1)
(while (not (looking-at "^$"))
(back-to-indentation)
- (if (looking-at "<Current_Directory>")
- (add-to-list 'obj-dir (expand-file-name "."))
- (add-to-list 'obj-dir
+ (add-to-list 'obj-dir
+ (if (looking-at "<Current_Directory>")
+ default-directory
(expand-file-name
(buffer-substring-no-properties
(point) (line-end-position)))))
@@ -767,7 +768,7 @@ is non-nil, prompt the user to select one. If none are found, return
'comp_opt ada-prj-default-comp-opt
'cross_prefix ""
'debug_cmd (concat ada-prj-default-debugger
- " ${main}" (if is-windows ".exe")) ;; FIXME: don't need .exe?
+ " ${main}" (if ada-on-ms-windows ".exe")) ;; FIXME: don't need .exe?
'debug_post_cmd (list nil)
'debug_pre_cmd (list (concat ada-cd-command " ${build_dir}"))
'gnatmake_opt ada-prj-default-gnatmake-opt
@@ -781,7 +782,7 @@ is non-nil, prompt the user to select one. If none are found, return
'make_cmd (list ada-prj-default-make-cmd) ;; FIXME: should not a list
'obj_dir (list ".")
'remote_machine ""
- 'run_cmd (list (concat "./${main}" (if is-windows ".exe")))
+ 'run_cmd (list (concat "./${main}" (if ada-on-ms-windows ".exe")))
;; FIXME: should not a list
;; FIXME: don't need .exe?
'src_dir (list ".")
@@ -1015,7 +1016,7 @@ existing buffer `*gnatfind*', if there is one."
;; processed (gnatfind \"+\":...).
(let* ((quote-entity
(if (= (aref entity 0) ?\")
- (if is-windows
+ (if ada-on-ms-windows
(concat "\\\"" (substring entity 1 -1) "\\\"")
(concat "'\"" (substring entity 1 -1) "\"'"))
entity))
@@ -1817,7 +1818,7 @@ Information is extracted from the ali file."
(beginning-of-line)
(if declaration-found
(let ((current-line (buffer-substring
- (point) (save-excursion (end-of-line) (point)))))
+ (point) (point-at-eol))))
(save-excursion
(forward-line 1)
(beginning-of-line)
@@ -2379,5 +2380,4 @@ For instance, it creates the gnat-specific menus, sets some hooks for
(provide 'ada-xref)
-;; arch-tag: 415a39fe-577b-4676-b3b1-6ff6db7ca24e
;;; ada-xref.el ends here
diff --git a/lisp/progmodes/antlr-mode.el b/lisp/progmodes/antlr-mode.el
index 82b532e9cd5..742bcf726eb 100644
--- a/lisp/progmodes/antlr-mode.el
+++ b/lisp/progmodes/antlr-mode.el
@@ -5,7 +5,7 @@
;; Author: Christoph.Wedler@sap.com
;; Keywords: languages, ANTLR, code generator
-;; Version: (see `antlr-version' below)
+;; Version: 2.2c
;; X-URL: http://antlr-mode.sourceforge.net/
;; This file is part of GNU Emacs.
diff --git a/lisp/progmodes/asm-mode.el b/lisp/progmodes/asm-mode.el
index 0ce7d780d1f..f5fef76a009 100644
--- a/lisp/progmodes/asm-mode.el
+++ b/lisp/progmodes/asm-mode.el
@@ -109,7 +109,7 @@
"Additional expressions to highlight in Assembler mode.")
;;;###autoload
-(defun asm-mode ()
+(define-derived-mode asm-mode prog-mode "Assembler"
"Major mode for editing typical assembler code.
Features a private abbrev table and the following bindings:
@@ -128,13 +128,8 @@ Turning on Asm mode runs the hook `asm-mode-hook' at the end of initialization.
Special commands:
\\{asm-mode-map}"
- (interactive)
- (kill-all-local-variables)
- (setq mode-name "Assembler")
- (setq major-mode 'asm-mode)
(setq local-abbrev-table asm-mode-abbrev-table)
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults '(asm-font-lock-keywords))
+ (set (make-local-variable 'font-lock-defaults) '(asm-font-lock-keywords))
(set (make-local-variable 'indent-line-function) 'asm-indent-line)
;; Stay closer to the old TAB behavior (was tab-to-tab-stop).
(set (make-local-variable 'tab-always-indent) nil)
@@ -157,8 +152,7 @@ Special commands:
(setq comment-end-skip "[ \t]*\\(\\s>\\|\\*+/\\)")
(make-local-variable 'comment-end)
(setq comment-end "")
- (setq fill-prefix "\t")
- (run-mode-hooks 'asm-mode-hook))
+ (setq fill-prefix "\t"))
(defun asm-indent-line ()
"Auto-indent the current line."
diff --git a/lisp/progmodes/autoconf.el b/lisp/progmodes/autoconf.el
index a56623f22da..004bb3de78d 100644
--- a/lisp/progmodes/autoconf.el
+++ b/lisp/progmodes/autoconf.el
@@ -43,9 +43,6 @@
(defvar autoconf-mode-hook nil
"Hook run by `autoconf-mode'.")
-(defconst autoconf-font-lock-syntactic-keywords
- '(("\\<dnl\\>" 0 '(11))))
-
(defconst autoconf-definition-regexp
"AC_\\(SUBST\\|DEFINE\\(_UNQUOTED\\)?\\)(\\[*\\(\\sw+\\)\\]*")
@@ -94,8 +91,8 @@ searching backwards at another AC_... command."
"^[ \t]*A[CM]_\\(\\sw\\|\\s_\\)+")
(set (make-local-variable 'comment-start) "dnl ")
(set (make-local-variable 'comment-start-skip) "\\(?:\\<dnl\\|#\\) +")
- (set (make-local-variable 'font-lock-syntactic-keywords)
- autoconf-font-lock-syntactic-keywords)
+ (set (make-local-variable 'syntax-propertize-function)
+ (syntax-propertize-rules ("\\<dnl\\>" (0 "<"))))
(set (make-local-variable 'font-lock-defaults)
`(autoconf-font-lock-keywords nil nil (("_" . "w"))))
(set (make-local-variable 'imenu-generic-expression)
diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el
index d0cc5541b8a..4897581252f 100644
--- a/lisp/progmodes/bug-reference.el
+++ b/lisp/progmodes/bug-reference.el
@@ -41,13 +41,28 @@
(defvar bug-reference-url-format nil
"Format used to turn a bug number into a URL.
The bug number is supplied as a string, so this should have a single %s.
-There is no default setting for this, it must be set per file.")
+This can also be a function designator; it is called without arguments
+ and should return a string.
+It can use `match-string' to get parts matched against
+`bug-reference-bug-regexp', specifically:
+ 1. issue kind (bug, patch, rfe &c)
+ 2. issue number.
+
+There is no default setting for this, it must be set per file.
+If you set it to a symbol in the file Local Variables section,
+you need to add a `bug-reference-url-format' property to it:
+\(put 'my-bug-reference-url-format 'bug-reference-url-format t)
+so that it is considered safe, see `enable-local-variables'.")
;;;###autoload
-(put 'bug-reference-url-format 'safe-local-variable 'stringp)
+(put 'bug-reference-url-format 'safe-local-variable
+ (lambda (s)
+ (or (stringp s)
+ (and (symbolp s)
+ (get s 'bug-reference-url-format)))))
(defconst bug-reference-bug-regexp
- "\\(?:[Bb]ug ?#\\|PR [a-z-+]+/\\)\\([0-9]+\\)"
+ "\\([Bb]ug ?#\\|[Pp]atch ?#\\|RFE ?#\\|PR [a-z-+]+/\\)\\([0-9]+\\)"
"Regular expression which matches bug references.")
(defun bug-reference-set-overlay-properties ()
@@ -87,9 +102,11 @@ There is no default setting for this, it must be set per file.")
(overlay-put overlay 'category 'bug-reference)
;; Don't put a link if format is undefined
(when bug-reference-url-format
- (overlay-put overlay 'bug-reference-url
- (format bug-reference-url-format
- (match-string-no-properties 1))))))))))
+ (overlay-put overlay 'bug-reference-url
+ (if (stringp bug-reference-url-format)
+ (format bug-reference-url-format
+ (match-string-no-properties 2))
+ (funcall bug-reference-url-format))))))))))
;; Taken from button.el.
(defun bug-reference-push-button (&optional pos use-mouse-action)
diff --git a/lisp/progmodes/cc-align.el b/lisp/progmodes/cc-align.el
index e52a0d70e48..8224db79ace 100644
--- a/lisp/progmodes/cc-align.el
+++ b/lisp/progmodes/cc-align.el
@@ -12,8 +12,8 @@
;; 1985 Richard M. Stallman
;; Maintainer: bug-cc-mode@gnu.org
;; Created: 22-Apr-1997 (split from cc-mode.el)
-;; Version: See cc-mode.el
-;; Keywords: c languages oop
+;; Keywords: c languages
+;; Package: cc-mode
;; This file is part of GNU Emacs.
diff --git a/lisp/progmodes/cc-awk.el b/lisp/progmodes/cc-awk.el
index 25dc27a08ea..6c7db25612d 100644
--- a/lisp/progmodes/cc-awk.el
+++ b/lisp/progmodes/cc-awk.el
@@ -6,6 +6,7 @@
;; Author: Alan Mackenzie <acm@muc.de> (originally based on awk-mode.el)
;; Maintainer: FSF
;; Keywords: AWK, cc-mode, unix, languages
+;; Package: cc-mode
;; This file is part of GNU Emacs.
@@ -244,7 +245,7 @@
;; REGEXPS USED FOR FINDING THE POSITION OF A "virtual semicolon"
(defconst c-awk-_-harmless-nonws-char-re "[^#/\"\\\\\n\r \t]")
-;;;; NEW VERSION! (which will be restricted to the current line)
+;; NEW VERSION! (which will be restricted to the current line)
(defconst c-awk-one-line-non-syn-ws*-re
(concat "\\([ \t]*"
"\\(" c-awk-_-harmless-nonws-char-re "\\|"
@@ -503,7 +504,7 @@
(insert-char ?\n 1) ; ...artificial eol is needed for comment detection.
(setq extra-nl t))
(prog1 (c-awk-get-NL-prop-prev-line do-lim)
- (if extra-nl (delete-backward-char 1))))))
+ (if extra-nl (delete-char -1))))))
(defsubst c-awk-prev-line-incomplete-p (&optional do-lim)
;; Is there an incomplete statement at the end of the previous line?
@@ -519,14 +520,14 @@
;; This function might do hidden buffer changes.
(memq (c-awk-get-NL-prop-cur-line do-lim) '(?\\ ?\{)))
-;;;; NOTES ON "VIRTUAL SEMICOLONS"
-;;;;
-;;;; A "virtual semicolon" is what terminates a statement when there is no ;
-;;;; or } to do the job. Like point, it is considered to lie _between_ two
-;;;; characters. As from mid-March 2004, it is considered to lie just after
-;;;; the last non-syntactic-whitespace character on the line; (previously, it
-;;;; was considered an attribute of the EOL on the line). A real semicolon
-;;;; never counts as a virtual one.
+;; NOTES ON "VIRTUAL SEMICOLONS"
+;;
+;; A "virtual semicolon" is what terminates a statement when there is no ;
+;; or } to do the job. Like point, it is considered to lie _between_ two
+;; characters. As from mid-March 2004, it is considered to lie just after
+;; the last non-syntactic-whitespace character on the line; (previously, it
+;; was considered an attribute of the EOL on the line). A real semicolon
+;; never counts as a virtual one.
(defun c-awk-at-vsemi-p (&optional pos)
;; Is there a virtual semicolon at POS (or POINT)?
diff --git a/lisp/progmodes/cc-bytecomp.el b/lisp/progmodes/cc-bytecomp.el
index cde38d872b0..597267d4e5d 100644
--- a/lisp/progmodes/cc-bytecomp.el
+++ b/lisp/progmodes/cc-bytecomp.el
@@ -6,8 +6,8 @@
;; Author: Martin Stjernholm
;; Maintainer: bug-cc-mode@gnu.org
;; Created: 15-Jul-2000
-;; Version: See cc-mode.el
-;; Keywords: c languages oop
+;; Keywords: c languages
+;; Package: cc-mode
;; This file is part of GNU Emacs.
diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el
index 4eade6edf58..112fa50ce8f 100644
--- a/lisp/progmodes/cc-cmds.el
+++ b/lisp/progmodes/cc-cmds.el
@@ -12,8 +12,8 @@
;; 1985 Richard M. Stallman
;; Maintainer: bug-cc-mode@gnu.org
;; Created: 22-Apr-1997 (split from cc-mode.el)
-;; Version: See cc-mode.el
-;; Keywords: c languages oop
+;; Keywords: c languages
+;; Package: cc-mode
;; This file is part of GNU Emacs.
@@ -1086,104 +1086,76 @@ numeric argument is supplied, or the point is inside a literal."
(interactive "*P")
(let ((c-echo-syntactic-information-p nil)
- final-pos close-paren-inserted)
+ final-pos close-paren-inserted found-delim)
(self-insert-command (prefix-numeric-value arg))
(setq final-pos (point))
- (c-save-buffer-state (c-parse-and-markup-<>-arglists
- c-restricted-<>-arglists
- <-pos)
+;;;; 2010-01-31: There used to be code here to put a syntax-table text
+;;;; property on the new < or > and its mate (if any) when they are template
+;;;; parens. This is now done in an after-change function.
- (when c-recognize-<>-arglists
- (if (eq last-command-event ?<)
- (when (and (progn
- (backward-char)
- (= (point)
- (progn
- (c-beginning-of-current-token)
- (point))))
+ ;; Indent the line if appropriate.
+ (when (and c-electric-flag c-syntactic-indentation c-recognize-<>-arglists)
+ (setq found-delim
+ (if (eq last-command-event ?<)
+ ;; If a <, basically see if it's got "template" before it .....
+ (or (and (progn
+ (backward-char)
+ (= (point)
+ (progn (c-beginning-of-current-token) (point))))
+ (progn
+ (c-backward-token-2)
+ (looking-at c-opt-<>-sexp-key)))
+ ;; ..... or is a C++ << operator.
+ (and (c-major-mode-is 'c++-mode)
+ (progn
+ (goto-char (1- final-pos))
+ (c-beginning-of-current-token)
+ (looking-at "<<"))
+ (>= (match-end 0) final-pos)))
+
+ ;; It's a >. Either a C++ >> operator. ......
+ (or (and (c-major-mode-is 'c++-mode)
(progn
- (c-backward-token-2)
- (looking-at c-opt-<>-sexp-key)))
- (c-mark-<-as-paren (1- final-pos)))
-
- ;; It's a ">". Check if there's an earlier "<" which either has
- ;; open paren syntax already or that can be recognized as an arglist
- ;; together with this ">". Note that this won't work in cases like
- ;; "template <x, a < b, y>" but they ought to be rare.
-
- (save-restriction
- ;; Narrow to avoid that `c-forward-<>-arglist' below searches past
- ;; our position.
- (narrow-to-region (point-min) final-pos)
-
- (while (and
- (progn
- (goto-char final-pos)
- (c-syntactic-skip-backward "^<;}" nil t)
- (eq (char-before) ?<))
- (progn
- (backward-char)
- ;; If the "<" already got open paren syntax we know we
- ;; have the matching closer. Handle it and exit the
- ;; loop.
- (if (looking-at "\\s\(")
- (progn
- (c-mark->-as-paren (1- final-pos))
- (setq close-paren-inserted t)
- nil)
- t))
+ (goto-char (1- final-pos))
+ (c-beginning-of-current-token)
+ (looking-at ">>"))
+ (>= (match-end 0) final-pos))
+ ;; ...., or search back for a < which isn't already marked as an
+ ;; opening template delimiter.
+ (save-restriction
+ (widen)
+ ;; Narrow to avoid `c-forward-<>-arglist' below searching past
+ ;; our position.
+ (narrow-to-region (point-min) final-pos)
+ (goto-char final-pos)
+ (while
+ (and
+ (progn
+ (c-syntactic-skip-backward "^<;}" nil t)
+ (eq (char-before) ?<))
+ (progn
+ (backward-char)
+ (looking-at "\\s\("))))
+ (and (eq (char-after) ?<)
+ (not (looking-at "\\s\("))
+ (progn (c-backward-syntactic-ws)
+ (c-simple-skip-symbol-backward))
+ (or (looking-at c-opt-<>-sexp-key)
+ (not (looking-at c-keywords-regexp)))))))))
- (progn
- (setq <-pos (point))
- (c-backward-syntactic-ws)
- (c-simple-skip-symbol-backward))
- (or (looking-at c-opt-<>-sexp-key)
- (not (looking-at c-keywords-regexp)))
-
- (let ((c-parse-and-markup-<>-arglists t)
- c-restricted-<>-arglists
- (containing-sexp
- (c-most-enclosing-brace (c-parse-state))))
- (when (and containing-sexp
- (progn (goto-char containing-sexp)
- (eq (char-after) ?\())
- (not (eq (get-text-property (point) 'c-type)
- 'c-decl-arg-start)))
- (setq c-restricted-<>-arglists t))
- (goto-char <-pos)
- (c-forward-<>-arglist nil))
-
- ;; Loop here if the "<" we found above belongs to a nested
- ;; angle bracket sexp. When we start over we'll find the
- ;; previous or surrounding sexp.
- (if (< (point) final-pos)
- t
- (setq close-paren-inserted t)
- nil)))))))
(goto-char final-pos)
-
- ;; Indent the line if appropriate.
- (when (and c-electric-flag c-syntactic-indentation)
- (backward-char)
- (when (prog1 (or (looking-at "\\s\(\\|\\s\)")
- (and (c-major-mode-is 'c++-mode)
- (progn
- (c-beginning-of-current-token)
- (looking-at "<<\\|>>"))
- (= (match-end 0) final-pos)))
- (goto-char final-pos))
- (indent-according-to-mode)))
-
- (when (and close-paren-inserted
- (not executing-kbd-macro)
- blink-paren-function)
- ;; Note: Most paren blink functions, such as the standard
- ;; `blink-matching-open', currently doesn't handle paren chars
- ;; marked with text properties very well. Maybe we should avoid
- ;; this call for the time being?
- (funcall blink-paren-function))))
+ (when found-delim
+ (indent-according-to-mode)
+ (when (and (eq (char-before) ?>)
+ (not executing-kbd-macro)
+ blink-paren-function)
+ ;; Note: Most paren blink functions, such as the standard
+ ;; `blink-matching-open', currently doesn't handle paren chars
+ ;; marked with text properties very well. Maybe we should avoid
+ ;; this call for the time being?
+ (funcall blink-paren-function)))))
(defun c-electric-paren (arg)
"Insert a parenthesis.
@@ -1529,6 +1501,11 @@ defun."
(interactive "p")
(or arg (setq arg 1))
+ (or (not (eq this-command 'c-beginning-of-defun))
+ (eq last-command 'c-beginning-of-defun)
+ (and transient-mark-mode mark-active)
+ (push-mark))
+
(c-save-buffer-state
(beginning-of-defun-function end-of-defun-function
(start (point))
@@ -1632,6 +1609,11 @@ the open-parenthesis that starts a defun; see `beginning-of-defun'."
(interactive "p")
(or arg (setq arg 1))
+ (or (not (eq this-command 'c-end-of-defun))
+ (eq last-command 'c-end-of-defun)
+ (and transient-mark-mode mark-active)
+ (push-mark))
+
(c-save-buffer-state
(beginning-of-defun-function end-of-defun-function
(start (point))
@@ -3992,16 +3974,19 @@ command to conveniently insert and align the necessary backslashes."
;; "Invalid search bound (wrong side of point)"
;; error in the subsequent re-search. Maybe
;; another fix would be needed (2007-12-08).
- (and (> (- (cdr c-lit-limits) 2) (point))
- (search-forward-regexp
- (concat "\\=[ \t]*\\(" c-current-comment-prefix "\\)")
- (- (cdr c-lit-limits) 2) t)
- (not (search-forward-regexp
- "\\(\\s \\|\\sw\\)"
- (- (cdr c-lit-limits) 2) 'limit))
- ;; The comment ender IS on its own line. Exclude
- ;; this line from the filling.
- (set-marker end (c-point 'bol))))
+; (or (<= (- (cdr c-lit-limits) 2) (point))
+; 2010-10-17 Construct removed.
+; (or (< (- (cdr c-lit-limits) 2) (point))
+ (and
+ (search-forward-regexp
+ (concat "\\=[ \t]*\\(" c-current-comment-prefix "\\)")
+ (- (cdr c-lit-limits) 2) t)
+ (not (search-forward-regexp
+ "\\(\\s \\|\\sw\\)"
+ (- (cdr c-lit-limits) 2) 'limit))
+ ;; The comment ender IS on its own line. Exclude this
+ ;; line from the filling.
+ (set-marker end (c-point 'bol))));)
;; The comment ender is hanging. Replace all space between it
;; and the last word either by one or two 'x's (when
@@ -4018,6 +4003,14 @@ command to conveniently insert and align the necessary backslashes."
(goto-char ender-start)
(current-column)))
(point-rel (- ender-start here))
+ (sentence-ends-comment
+ (save-excursion
+ (goto-char ender-start)
+ (and (search-backward-regexp
+ (c-sentence-end) (c-point 'bol) t)
+ (goto-char (match-end 0))
+ (looking-at "[ \t]*")
+ (= (match-end 0) ender-start))))
spaces)
(save-excursion
@@ -4060,7 +4053,9 @@ command to conveniently insert and align the necessary backslashes."
(setq spaces
(max
(min spaces
- (if sentence-end-double-space 2 1))
+ (if (and sentence-ends-comment
+ sentence-end-double-space)
+ 2 1))
1)))
;; Insert the filler first to keep marks right.
(insert-char ?x spaces t)
@@ -4270,8 +4265,11 @@ Optional prefix ARG means justify paragraph as well."
(let ((fill-paragraph-function
;; Avoid infinite recursion.
(if (not (eq fill-paragraph-function 'c-fill-paragraph))
- fill-paragraph-function)))
- (c-mask-paragraph t nil 'fill-paragraph arg))
+ fill-paragraph-function))
+ (start-point (point-marker)))
+ (c-mask-paragraph
+ t nil (lambda () (fill-region-as-paragraph (point-min) (point-max) arg)))
+ (goto-char start-point))
;; Always return t. This has the effect that if filling isn't done
;; above, it isn't done at all, and it's therefore effectively
;; disabled in normal code.
diff --git a/lisp/progmodes/cc-compat.el b/lisp/progmodes/cc-compat.el
index 59a336f3c69..adfac2f5f9e 100644
--- a/lisp/progmodes/cc-compat.el
+++ b/lisp/progmodes/cc-compat.el
@@ -8,8 +8,8 @@
;; 1994-1999 Barry A. Warsaw
;; Maintainer: bug-cc-mode@gnu.org
;; Created: August 1994, split from cc-mode.el
-;; Version: See cc-mode.el
-;; Keywords: c languages oop
+;; Keywords: c languages
+;; Package: cc-mode
;; This file is part of GNU Emacs.
diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el
index 39036b743c6..147a0e2dc2a 100644
--- a/lisp/progmodes/cc-defs.el
+++ b/lisp/progmodes/cc-defs.el
@@ -12,8 +12,8 @@
;; 1985 Richard M. Stallman
;; Maintainer: bug-cc-mode@gnu.org
;; Created: 22-Apr-1997 (split from cc-mode.el)
-;; Version: See cc-mode.el
-;; Keywords: c languages oop
+;; Keywords: c languages
+;; Package: cc-mode
;; This file is part of GNU Emacs.
@@ -1029,6 +1029,44 @@ MODE is either a mode symbol or a list of mode symbols."
;; Emacs.
`(remove-text-properties ,from ,to '(,property nil))))
+(defmacro c-search-forward-char-property (property value &optional limit)
+ "Search forward for a text-property PROPERTY having value VALUE.
+LIMIT bounds the search. The comparison is done with `equal'.
+
+Leave point just after the character, and set the match data on
+this character, and return point. If VALUE isn't found, Return
+nil; point is then left undefined."
+ `(let ((place (point)))
+ (while
+ (and
+ (< place ,(or limit '(point-max)))
+ (not (equal (get-text-property place ,property) ,value)))
+ (setq place (next-single-property-change
+ place ,property nil ,(or limit '(point-max)))))
+ (when (< place ,(or limit '(point-max)))
+ (goto-char place)
+ (search-forward-regexp ".") ; to set the match-data.
+ (point))))
+
+(defmacro c-search-backward-char-property (property value &optional limit)
+ "Search backward for a text-property PROPERTY having value VALUE.
+LIMIT bounds the search. The comparison is done with `equal'.
+
+Leave point just before the character, set the match data on this
+character, and return point. If VALUE isn't found, Return nil;
+point is then left undefined."
+ `(let ((place (point)))
+ (while
+ (and
+ (> place ,(or limit '(point-min)))
+ (not (equal (get-text-property (1- place) ,property) ,value)))
+ (setq place (previous-single-property-change
+ place ,property nil ,(or limit '(point-min)))))
+ (when (> place ,(or limit '(point-max)))
+ (goto-char place)
+ (search-backward-regexp ".") ; to set the match-data.
+ (point))))
+
(defun c-clear-char-property-with-value-function (from to property value)
"Remove all text-properties PROPERTY from the region (FROM, TO)
which have the value VALUE, as tested by `equal'. These
@@ -1044,7 +1082,7 @@ been put there by c-put-char-property. POINT remains unchanged."
(setq place (next-single-property-change place property nil to)))
(< place to))
(setq end-place (next-single-property-change place property nil to))
- (put-text-property place end-place property nil)
+ (remove-text-properties place end-place (cons property nil))
;; Do we have to do anything with stickiness here?
(setq place end-place))))
@@ -1145,23 +1183,117 @@ been put there by c-put-char-property. POINT remains unchanged."
(goto-char (point-max)))))
(defconst c-<-as-paren-syntax '(4 . ?>))
+(put 'c-<-as-paren-syntax 'syntax-table c-<-as-paren-syntax)
(defsubst c-mark-<-as-paren (pos)
- ;; Mark the "<" character at POS as an sexp list opener using the
- ;; syntax-table property.
+ ;; Mark the "<" character at POS as a template opener using the
+ ;; `syntax-table' property via the `category' property.
;;
- ;; This function does a hidden buffer change.
- (c-put-char-property pos 'syntax-table c-<-as-paren-syntax))
+ ;; This function does a hidden buffer change. Note that we use
+ ;; indirection through the `category' text property. This allows us to
+ ;; toggle the property in all template brackets simultaneously and
+ ;; cheaply. We use this, for instance, in `c-parse-state'.
+ (c-put-char-property pos 'category 'c-<-as-paren-syntax))
(defconst c->-as-paren-syntax '(5 . ?<))
+(put 'c->-as-paren-syntax 'syntax-table c->-as-paren-syntax)
(defsubst c-mark->-as-paren (pos)
;; Mark the ">" character at POS as an sexp list closer using the
;; syntax-table property.
;;
- ;; This function does a hidden buffer change.
- (c-put-char-property pos 'syntax-table c->-as-paren-syntax))
-
+ ;; This function does a hidden buffer change. Note that we use
+ ;; indirection through the `category' text property. This allows us to
+ ;; toggle the property in all template brackets simultaneously and
+ ;; cheaply. We use this, for instance, in `c-parse-state'.
+ (c-put-char-property pos 'category 'c->-as-paren-syntax))
+
+(defsubst c-unmark-<->-as-paren (pos)
+ ;; Unmark the "<" or "<" character at POS as an sexp list opener using
+ ;; the syntax-table property indirectly through the `category' text
+ ;; property.
+ ;;
+ ;; This function does a hidden buffer change. Note that we use
+ ;; indirection through the `category' text property. This allows us to
+ ;; toggle the property in all template brackets simultaneously and
+ ;; cheaply. We use this, for instance, in `c-parse-state'.
+ (c-clear-char-property pos 'category))
+
+(defsubst c-suppress-<->-as-parens ()
+ ;; Suppress the syntactic effect of all marked < and > as parens. Note
+ ;; that this effect is NOT buffer local. You should probably not use
+ ;; this directly, but only through the macro
+ ;; `c-with-<->-as-parens-suppressed'
+ (put 'c-<-as-paren-syntax 'syntax-table nil)
+ (put 'c->-as-paren-syntax 'syntax-table nil))
+
+(defsubst c-restore-<->-as-parens ()
+ ;; Restore the syntactic effect of all marked <s and >s as parens. This
+ ;; has no effect on unmarked <s and >s
+ (put 'c-<-as-paren-syntax 'syntax-table c-<-as-paren-syntax)
+ (put 'c->-as-paren-syntax 'syntax-table c->-as-paren-syntax))
+
+(defmacro c-with-<->-as-parens-suppressed (&rest forms)
+ ;; Like progn, except that the paren property is suppressed on all
+ ;; template brackets whilst they are running. This macro does a hidden
+ ;; buffer change.
+ `(unwind-protect
+ (progn
+ (c-suppress-<->-as-parens)
+ ,@forms)
+ (c-restore-<->-as-parens)))
+
+;;;;;;;;;;;;;;;
+
+(defconst c-cpp-delimiter '(14)) ; generic comment syntax
+;; This is the value of the `category' text property placed on every #
+;; which introduces a CPP construct and every EOL (or EOB, or character
+;; preceding //, etc.) which terminates it. We can instantly "comment
+;; out" all CPP constructs by giving `c-cpp-delimiter' a syntax-table
+;; propery '(14) (generic comment delimiter).
+(defmacro c-set-cpp-delimiters (beg end)
+ ;; This macro does a hidden buffer change.
+ `(progn
+ (c-put-char-property ,beg 'category 'c-cpp-delimiter)
+ (if (< ,end (point-max))
+ (c-put-char-property ,end 'category 'c-cpp-delimiter))))
+(defmacro c-clear-cpp-delimiters (beg end)
+ ;; This macro does a hidden buffer change.
+ `(progn
+ (c-clear-char-property ,beg 'category)
+ (if (< ,end (point-max))
+ (c-clear-char-property ,end 'category))))
+
+(defsubst c-comment-out-cpps ()
+ ;; Render all preprocessor constructs syntactically commented out.
+ (put 'c-cpp-delimiter 'syntax-table c-cpp-delimiter))
+(defsubst c-uncomment-out-cpps ()
+ ;; Restore the syntactic visibility of preprocessor constructs.
+ (put 'c-cpp-delimiter 'syntax-table nil))
+
+(defmacro c-with-cpps-commented-out (&rest forms)
+ ;; Execute FORMS... whilst the syntactic effect of all characters in
+ ;; all CPP regions is suppressed. In particular, this is to suppress
+ ;; the syntactic significance of parens/braces/brackets to functions
+ ;; such as `scan-lists' and `parse-partial-sexp'.
+ `(unwind-protect
+ (c-save-buffer-state ()
+ (c-comment-out-cpps)
+ ,@forms)
+ (c-save-buffer-state ()
+ (c-uncomment-out-cpps))))
+
+(defmacro c-with-all-but-one-cpps-commented-out (beg end &rest forms)
+ ;; Execute FORMS... whilst the syntactic effect of all characters in
+ ;; every CPP region APART FROM THE ONE BETWEEN BEG and END is
+ ;; suppressed.
+ `(unwind-protect
+ (c-save-buffer-state ()
+ (c-clear-cpp-delimiters ,beg ,end)
+ ,`(c-with-cpps-commented-out ,@forms))
+ (c-save-buffer-state ()
+ (c-set-cpp-delimiters ,beg ,end))))
+
(defsubst c-intersect-lists (list alist)
;; return the element of ALIST that matches the first element found
;; in LIST. Uses assq.
diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el
index 9c04920a208..18010407eda 100644
--- a/lisp/progmodes/cc-engine.el
+++ b/lisp/progmodes/cc-engine.el
@@ -1,8 +1,8 @@
;;; cc-engine.el --- core syntax guessing engine for CC mode
;; Copyright (C) 1985, 1987, 1992, 1993, 1994, 1995, 1996, 1997, 1998,
-;; 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+;; 2010 Free Software Foundation, Inc.
;; Authors: 2001- Alan Mackenzie
;; 1998- Martin Stjernholm
@@ -12,8 +12,8 @@
;; 1985 Richard M. Stallman
;; Maintainer: bug-cc-mode@gnu.org
;; Created: 22-Apr-1997 (split from cc-mode.el)
-;; Version: See cc-mode.el
-;; Keywords: c languages oop
+;; Keywords: c languages
+;; Package: cc-mode
;; This file is part of GNU Emacs.
@@ -79,6 +79,10 @@
;; Note: This doc is for internal use only. Other packages should not
;; assume that these text properties are used as described here.
;;
+;; 'category
+;; Used for "indirection". With its help, some other property can
+;; be cheaply and easily switched on or off everywhere it occurs.
+;;
;; 'syntax-table
;; Used to modify the syntax of some characters. It is used to
;; mark the "<" and ">" of angle bracket parens with paren syntax, and
@@ -256,6 +260,27 @@ comment at the start of cc-engine.el for more info."
(forward-char)
t))))
+(defun c-syntactic-end-of-macro ()
+ ;; Go to the end of a CPP directive, or a "safe" pos just before.
+ ;;
+ ;; This is normally the end of the next non-escaped line. A "safe"
+ ;; position is one not within a string or comment. (The EOL on a line
+ ;; comment is NOT "safe").
+ ;;
+ ;; This function must only be called from the beginning of a CPP construct.
+ ;;
+ ;; Note that this function might do hidden buffer changes. See the comment
+ ;; at the start of cc-engine.el for more info.
+ (let* ((here (point))
+ (there (progn (c-end-of-macro) (point)))
+ (s (parse-partial-sexp here there)))
+ (while (and (or (nth 3 s) ; in a string
+ (nth 4 s)) ; in a comment (maybe at end of line comment)
+ (> there here)) ; No infinite loops, please.
+ (setq there (1- (nth 8 s)))
+ (setq s (parse-partial-sexp here there)))
+ (point)))
+
(defun c-forward-over-cpp-define-id ()
;; Assuming point is at the "#" that introduces a preprocessor
;; directive, it's moved forward to the end of the identifier which is
@@ -1947,10 +1972,18 @@ comment at the start of cc-engine.el for more info."
;; A system for finding noteworthy parens before the point.
+(defconst c-state-cache-too-far 5000)
+;; A maximum comfortable scanning distance, e.g. between
+;; `c-state-cache-good-pos' and "HERE" (where we call c-parse-state). When
+;; this distance is exceeded, we take "emergency meausures", e.g. by clearing
+;; the cache and starting again from point-min or a beginning of defun. This
+;; value can be tuned for efficiency or set to a lower value for testing.
+
(defvar c-state-cache nil)
(make-variable-buffer-local 'c-state-cache)
;; The state cache used by `c-parse-state' to cut down the amount of
-;; searching. It's the result from some earlier `c-parse-state' call.
+;; searching. It's the result from some earlier `c-parse-state' call. See
+;; `c-parse-state''s doc string for details of its structure.
;;
;; The use of the cached info is more effective if the next
;; `c-parse-state' call is on a line close by the one the cached state
@@ -1959,18 +1992,12 @@ comment at the start of cc-engine.el for more info."
;; most effective if `c-parse-state' is used on each line while moving
;; forward.
-(defvar c-state-cache-start 1)
-(make-variable-buffer-local 'c-state-cache-start)
-;; This is (point-min) when `c-state-cache' was calculated, since a
-;; change of narrowing is likely to affect the parens that are visible
-;; before the point.
-
(defvar c-state-cache-good-pos 1)
(make-variable-buffer-local 'c-state-cache-good-pos)
-;; This is a position where `c-state-cache' is known to be correct.
-;; It's a position inside one of the recorded unclosed parens or the
-;; top level, but not further nested inside any literal or subparen
-;; that is closed before the last recorded position.
+;; This is a position where `c-state-cache' is known to be correct, or
+;; nil (see below). It's a position inside one of the recorded unclosed
+;; parens or the top level, but not further nested inside any literal or
+;; subparen that is closed before the last recorded position.
;;
;; The exact position is chosen to try to be close to yet earlier than
;; the position where `c-state-cache' will be called next. Right now
@@ -1978,313 +2005,1074 @@ comment at the start of cc-engine.el for more info."
;; closing paren (of any type) before the line on which
;; `c-parse-state' was called. That is chosen primarily to work well
;; with refontification of the current line.
+;;
+;; 2009-07-28: When `c-state-point-min' and the last position where
+;; `c-parse-state' or for which `c-invalidate-state-cache' was called, are
+;; both in the same literal, there is no such "good position", and
+;; c-state-cache-good-pos is then nil. This is the ONLY circumstance in which
+;; it can be nil. In this case, `c-state-point-min-literal' will be non-nil.
+;;
+;; 2009-06-12: In a brace desert, c-state-cache-good-pos may also be in
+;; the middle of the desert, as long as it is not within a brace pair
+;; recorded in `c-state-cache' or a paren/bracket pair.
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; We maintain a simple cache of positions which aren't in a literal, so as to
+;; speed up testing for non-literality.
+(defconst c-state-nonlit-pos-interval 10000)
+;; The approximate interval between entries in `c-state-nonlit-pos-cache'.
+
+(defvar c-state-nonlit-pos-cache nil)
+(make-variable-buffer-local 'c-state-nonlit-pos-cache)
+;; A list of buffer positions which are known not to be in a literal. This is
+;; ordered with higher positions at the front of the list. Only those which
+;; are less than `c-state-nonlit-pos-cache-limit' are valid.
+
+(defvar c-state-nonlit-pos-cache-limit 1)
+(make-variable-buffer-local 'c-state-nonlit-pos-cache-limit)
+;; An upper limit on valid entries in `c-state-nonlit-pos-cache'. This is
+;; reduced by buffer changes, and increased by invocations of
+;; `c-state-literal-at'.
+
+(defsubst c-state-pp-to-literal (from to)
+ ;; Do a parse-partial-sexp from FROM to TO, returning the bounds of any
+ ;; literal at TO as a cons, otherwise NIL.
+ ;; FROM must not be in a literal, and the buffer should already be wide
+ ;; enough.
+ (save-excursion
+ (let ((s (parse-partial-sexp from to)))
+ (when (or (nth 3 s) (nth 4 s)) ; in a string or comment
+ (parse-partial-sexp (point) (point-max)
+ nil ; TARGETDEPTH
+ nil ; STOPBEFORE
+ s ; OLDSTATE
+ 'syntax-table) ; stop at end of literal
+ (cons (nth 8 s) (point))))))
+
+(defun c-state-literal-at (here)
+ ;; If position HERE is inside a literal, return (START . END), the
+ ;; boundaries of the literal (which may be outside the accessible bit of the
+ ;; buffer). Otherwise, return nil.
+ ;;
+ ;; This function is almost the same as `c-literal-limits'. It differs in
+ ;; that it is a lower level function, and that it rigourously follows the
+ ;; syntax from BOB, whereas `c-literal-limits' uses a "local" safe position.
+ (save-restriction
+ (widen)
+ (save-excursion
+ (let ((c c-state-nonlit-pos-cache)
+ pos npos lit)
+ ;; Trim the cache to take account of buffer changes.
+ (while (and c (> (car c) c-state-nonlit-pos-cache-limit))
+ (setq c (cdr c)))
+ (setq c-state-nonlit-pos-cache c)
+
+ (while (and c (> (car c) here))
+ (setq c (cdr c)))
+ (setq pos (or (car c) (point-min)))
+
+ (while (<= (setq npos (+ pos c-state-nonlit-pos-interval))
+ here)
+ (setq lit (c-state-pp-to-literal pos npos))
+ (setq pos (or (cdr lit) npos)) ; end of literal containing npos.
+ (setq c-state-nonlit-pos-cache (cons pos c-state-nonlit-pos-cache)))
+
+ (if (> pos c-state-nonlit-pos-cache-limit)
+ (setq c-state-nonlit-pos-cache-limit pos))
+ (if (< pos here)
+ (setq lit (c-state-pp-to-literal pos here)))
+ lit))))
+
+(defsubst c-state-lit-beg (pos)
+ ;; Return the start of the literal containing POS, or POS itself.
+ (or (car (c-state-literal-at pos))
+ pos))
+
+(defsubst c-state-cache-non-literal-place (pos state)
+ ;; Return a position outside of a string/comment at or before POS.
+ ;; STATE is the parse-partial-sexp state at POS.
+ (if (or (nth 3 state) ; in a string?
+ (nth 4 state)) ; in a comment?
+ (nth 8 state)
+ pos))
-(defsubst c-invalidate-state-cache (pos)
- ;; Invalidate all info on `c-state-cache' that applies to the buffer
- ;; at POS or higher. This is much like `c-whack-state-after', but
- ;; it never changes a paren pair element into an open paren element.
- ;; Doing that would mean that the new open paren wouldn't have the
- ;; required preceding paren pair element.
- (while (and (or c-state-cache
- (when (< pos c-state-cache-good-pos)
- (setq c-state-cache-good-pos 1)
- nil))
- (let ((elem (car c-state-cache)))
- (if (consp elem)
- (or (< pos (cdr elem))
- (when (< pos c-state-cache-good-pos)
- (setq c-state-cache-good-pos (cdr elem))
- nil))
- (or (<= pos elem)
- (when (< pos c-state-cache-good-pos)
- (setq c-state-cache-good-pos (1+ elem))
- nil)))))
- (setq c-state-cache (cdr c-state-cache))))
-
-(defun c-get-fallback-start-pos (here)
- ;; Return the start position for building `c-state-cache' from
- ;; scratch.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Stuff to do with point-min, and coping with any literal there.
+(defvar c-state-point-min 1)
+(make-variable-buffer-local 'c-state-point-min)
+;; This is (point-min) when `c-state-cache' was last calculated. A change of
+;; narrowing is likely to affect the parens that are visible before the point.
+
+(defvar c-state-point-min-lit-type nil)
+(make-variable-buffer-local 'c-state-point-min-lit-type)
+(defvar c-state-point-min-lit-start nil)
+(make-variable-buffer-local 'c-state-point-min-lit-start)
+;; These two variables define the literal, if any, containing point-min.
+;; Their values are, respectively, 'string, c, or c++, and the start of the
+;; literal. If there's no literal there, they're both nil.
+
+(defvar c-state-min-scan-pos 1)
+(make-variable-buffer-local 'c-state-min-scan-pos)
+;; This is the earliest buffer-pos from which scanning can be done. It is
+;; either the end of the literal containing point-min, or point-min itself.
+;; It becomes nil if the buffer is changed earlier than this point.
+(defun c-state-get-min-scan-pos ()
+ ;; Return the lowest valid scanning pos. This will be the end of the
+ ;; literal enclosing point-min, or point-min itself.
+ (or c-state-min-scan-pos
+ (save-restriction
+ (save-excursion
+ (widen)
+ (goto-char c-state-point-min-lit-start)
+ (if (eq c-state-point-min-lit-type 'string)
+ (forward-sexp)
+ (forward-comment 1))
+ (setq c-state-min-scan-pos (point))))))
+
+(defun c-state-mark-point-min-literal ()
+ ;; Determine the properties of any literal containing POINT-MIN, setting the
+ ;; variables `c-state-point-min-lit-type', `c-state-point-min-lit-start',
+ ;; and `c-state-min-scan-pos' accordingly. The return value is meaningless.
+ (let ((p-min (point-min))
+ lit)
+ (save-restriction
+ (widen)
+ (setq lit (c-state-literal-at p-min))
+ (if lit
+ (setq c-state-point-min-lit-type
+ (save-excursion
+ (goto-char (car lit))
+ (cond
+ ((looking-at c-block-comment-start-regexp) 'c)
+ ((looking-at c-line-comment-starter) 'c++)
+ (t 'string)))
+ c-state-point-min-lit-start (car lit)
+ c-state-min-scan-pos (cdr lit))
+ (setq c-state-point-min-lit-type nil
+ c-state-point-min-lit-start nil
+ c-state-min-scan-pos p-min)))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; A variable which signals a brace dessert - helpful for reducing the number
+;; of fruitless backward scans.
+(defvar c-state-brace-pair-desert nil)
+(make-variable-buffer-local 'c-state-brace-pair-desert)
+;; Used only in `c-append-lower-brace-pair-to-state-cache'. It is set when an
+;; that defun has searched backwards for a brace pair and not found one. Its
+;; value is either nil or a cons (PA . FROM), where PA is the position of the
+;; enclosing opening paren/brace/bracket which bounds the backwards search (or
+;; nil when at top level) and FROM is where the backward search started. It
+;; is reset to nil in `c-invalidate-state-cache'.
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Lowish level functions/macros which work directly on `c-state-cache', or a
+;; list of like structure.
+(defmacro c-state-cache-top-lparen (&optional cache)
+ ;; Return the address of the top left brace/bracket/paren recorded in CACHE
+ ;; (default `c-state-cache') (or nil).
+ (let ((cash (or cache 'c-state-cache)))
+ `(if (consp (car ,cash))
+ (caar ,cash)
+ (car ,cash))))
+
+(defmacro c-state-cache-top-paren (&optional cache)
+ ;; Return the address of the latest brace/bracket/paren (whether left or
+ ;; right) recorded in CACHE (default `c-state-cache') or nil.
+ (let ((cash (or cache 'c-state-cache)))
+ `(if (consp (car ,cash))
+ (cdar ,cash)
+ (car ,cash))))
+
+(defmacro c-state-cache-after-top-paren (&optional cache)
+ ;; Return the position just after the latest brace/bracket/paren (whether
+ ;; left or right) recorded in CACHE (default `c-state-cache') or nil.
+ (let ((cash (or cache 'c-state-cache)))
+ `(if (consp (car ,cash))
+ (cdar ,cash)
+ (and (car ,cash)
+ (1+ (car ,cash))))))
+
+(defun c-get-cache-scan-pos (here)
+ ;; From the state-cache, determine the buffer position from which we might
+ ;; scan forward to HERE to update this cache. This position will be just
+ ;; after a paren/brace/bracket recorded in the cache, if possible, otherwise
+ ;; return the earliest position in the accessible region which isn't within
+ ;; a literal. If the visible portion of the buffer is entirely within a
+ ;; literal, return NIL.
+ (let ((c c-state-cache) elt)
+ ;(while (>= (or (c-state-cache-top-lparen c) 1) here)
+ (while (and c
+ (>= (c-state-cache-top-lparen c) here))
+ (setq c (cdr c)))
+
+ (setq elt (car c))
+ (cond
+ ((consp elt)
+ (if (> (cdr elt) here)
+ (1+ (car elt))
+ (cdr elt)))
+ (elt (1+ elt))
+ ((<= (c-state-get-min-scan-pos) here)
+ (c-state-get-min-scan-pos))
+ (t nil))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Variables which keep track of preprocessor constructs.
+(defvar c-state-old-cpp-beg nil)
+(make-variable-buffer-local 'c-state-old-cpp-beg)
+(defvar c-state-old-cpp-end nil)
+(make-variable-buffer-local 'c-state-old-cpp-end)
+;; These are the limits of the macro containing point at the previous call of
+;; `c-parse-state', or nil.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Defuns which analyse the buffer, yet don't change `c-state-cache'.
+(defun c-get-fallback-scan-pos (here)
+ ;; Return a start position for building `c-state-cache' from
+ ;; scratch. This will be at the top level, 2 defuns back.
(save-excursion
;; Go back 2 bods, but ignore any bogus positions returned by
;; beginning-of-defun (i.e. open paren in column zero).
(goto-char here)
(let ((cnt 2))
(while (not (or (bobp) (zerop cnt)))
- (c-beginning-of-defun-1)
+ (c-beginning-of-defun-1) ; Pure elisp BOD.
(if (eq (char-after) ?\{)
(setq cnt (1- cnt)))))
(point)))
-(defun c-parse-state ()
- ;; Find and record all noteworthy parens between some good point
- ;; earlier in the file and point. That good point is at least the
- ;; beginning of the top-level construct we are in, or the beginning
- ;; of the preceding top-level construct if we aren't in one.
- ;;
- ;; The returned value is a list of the noteworthy parens with the
- ;; last one first. If an element in the list is an integer, it's
- ;; the position of an open paren which has not been closed before
- ;; the point. If an element is a cons, it gives the position of a
- ;; closed brace paren pair; the car is the start paren position and
- ;; the cdr is the position following the closing paren. Only the
- ;; last closed brace paren pair before each open paren and before
- ;; the point is recorded, and thus the state never contains two cons
- ;; elements in succession.
+(defun c-state-balance-parens-backwards (here- here+ top)
+ ;; Return the position of the opening paren/brace/bracket before HERE- which
+ ;; matches the outermost close p/b/b between HERE+ and TOP. Except when
+ ;; there's a macro, HERE- and HERE+ are the same. Like this:
+ ;;
+ ;; ............................................
+ ;; | |
+ ;; ( [ ( .........#macro.. ) ( ) ] )
+ ;; ^ ^ ^ ^
+ ;; | | | |
+ ;; return HERE- HERE+ TOP
+ ;;
+ ;; If there aren't enough opening paren/brace/brackets, return the position
+ ;; of the outermost one found, or HERE- if there are none. If there are no
+ ;; closeing p/b/bs between HERE+ and TOP, return HERE-. HERE-/+ and TOP
+ ;; must not be inside literals. Only the accessible portion of the buffer
+ ;; will be scanned.
+
+ ;; PART 1: scan from `here+' up to `top', accumulating ")"s which enclose
+ ;; `here'. Go round the next loop each time we pass over such a ")". These
+ ;; probably match "("s before `here-'.
+ (let (pos pa ren+1 lonely-rens)
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (point-min) top) ; This can move point, sometimes.
+ (setq pos here+)
+ (c-safe
+ (while
+ (setq ren+1 (scan-lists pos 1 1)) ; might signal
+ (setq lonely-rens (cons ren+1 lonely-rens)
+ pos ren+1)))))
+
+ ;; PART 2: Scan back before `here-' searching for the "("s
+ ;; matching/mismatching the ")"s found above. We only need to direct the
+ ;; caller to scan when we've encountered unmatched right parens.
+ (setq pos here-)
+ (when lonely-rens
+ (c-safe
+ (while
+ (and lonely-rens ; actual values aren't used.
+ (setq pa (scan-lists pos -1 1)))
+ (setq pos pa)
+ (setq lonely-rens (cdr lonely-rens)))))
+ pos))
+
+(defun c-parse-state-get-strategy (here good-pos)
+ ;; Determine the scanning strategy for adjusting `c-parse-state', attempting
+ ;; to minimise the amount of scanning. HERE is the pertinent position in
+ ;; the buffer, GOOD-POS is a position where `c-state-cache' (possibly with
+ ;; its head trimmed) is known to be good, or nil if there is no such
+ ;; position.
+ ;;
+ ;; The return value is a list, one of the following:
+ ;;
+ ;; o - ('forward CACHE-POS START-POINT) - scan forward from START-POINT,
+ ;; which is not less than CACHE-POS.
+ ;; o - ('backward CACHE-POS nil) - scan backwards (from HERE).
+ ;; o - ('BOD nil START-POINT) - scan forwards from START-POINT, which is at the
+ ;; top level.
+ ;; o - ('IN-LIT nil nil) - point is inside the literal containing point-min.
+ ;; , where CACHE-POS is the highest position recorded in `c-state-cache' at
+ ;; or below HERE.
+ (let ((cache-pos (c-get-cache-scan-pos here)) ; highest position below HERE in cache (or 1)
+ BOD-pos ; position of 2nd BOD before HERE.
+ strategy ; 'forward, 'backward, 'BOD, or 'IN-LIT.
+ start-point
+ how-far) ; putative scanning distance.
+ (setq good-pos (or good-pos (c-state-get-min-scan-pos)))
+ (cond
+ ((< here (c-state-get-min-scan-pos))
+ (setq strategy 'IN-LIT
+ start-point nil
+ cache-pos nil
+ how-far 0))
+ ((<= good-pos here)
+ (setq strategy 'forward
+ start-point (max good-pos cache-pos)
+ how-far (- here start-point)))
+ ((< (- good-pos here) (- here cache-pos)) ; FIXME!!! ; apply some sort of weighting.
+ (setq strategy 'backward
+ how-far (- good-pos here)))
+ (t
+ (setq strategy 'forward
+ how-far (- here cache-pos)
+ start-point cache-pos)))
+
+ ;; Might we be better off starting from the top level, two defuns back,
+ ;; instead?
+ (when (> how-far c-state-cache-too-far)
+ (setq BOD-pos (c-get-fallback-scan-pos here)) ; somewhat EXPENSIVE!!!
+ (if (< (- here BOD-pos) how-far)
+ (setq strategy 'BOD
+ start-point BOD-pos)))
+
+ (list
+ strategy
+ (and (memq strategy '(forward backward)) cache-pos)
+ (and (memq strategy '(forward BOD)) start-point))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Routines which change `c-state-cache' and associated values.
+(defun c-renarrow-state-cache ()
+ ;; The region (more precisely, point-min) has changed since we
+ ;; calculated `c-state-cache'. Amend `c-state-cache' accordingly.
+ (if (< (point-min) c-state-point-min)
+ ;; If point-min has MOVED BACKWARDS then we drop the state completely.
+ ;; It would be possible to do a better job here and recalculate the top
+ ;; only.
+ (progn
+ (c-state-mark-point-min-literal)
+ (setq c-state-cache nil
+ c-state-cache-good-pos c-state-min-scan-pos
+ c-state-brace-pair-desert nil))
+
+ ;; point-min has MOVED FORWARD.
+
+ ;; Is the new point-min inside a (different) literal?
+ (unless (and c-state-point-min-lit-start ; at prev. point-min
+ (< (point-min) (c-state-get-min-scan-pos)))
+ (c-state-mark-point-min-literal))
+
+ ;; Cut off a bit of the tail from `c-state-cache'.
+ (let ((ptr (cons nil c-state-cache))
+ pa)
+ (while (and (setq pa (c-state-cache-top-lparen (cdr ptr)))
+ (>= pa (point-min)))
+ (setq ptr (cdr ptr)))
+
+ (when (consp ptr)
+ (if (eq (cdr ptr) c-state-cache)
+ (setq c-state-cache nil
+ c-state-cache-good-pos c-state-min-scan-pos)
+ (setcdr ptr nil)
+ (setq c-state-cache-good-pos (1+ (c-state-cache-top-lparen))))
+ )))
+
+ (setq c-state-point-min (point-min)))
+
+(defun c-append-lower-brace-pair-to-state-cache (from &optional upper-lim)
+ ;; If there is a brace pair preceding FROM in the buffer (not necessarily
+ ;; immediately preceding), push a cons onto `c-state-cache' to represent it.
+ ;; FROM must not be inside a literal. If UPPER-LIM is non-nil, we append
+ ;; the highest brace pair whose "}" is below UPPER-LIM.
+ ;;
+ ;; Return non-nil when this has been done.
+ ;;
+ ;; This routine should be fast. Since it can get called a LOT, we maintain
+ ;; `c-state-brace-pair-desert', a small cache of "failures", such that we
+ ;; reduce the time wasted in repeated fruitless searches in brace deserts.
+ (save-excursion
+ (save-restriction
+ (let ((bra from) ce ; Positions of "{" and "}".
+ new-cons
+ (cache-pos (c-state-cache-top-lparen)) ; might be nil.
+ (macro-start-or-from
+ (progn (goto-char from)
+ (c-beginning-of-macro)
+ (point))))
+ (or upper-lim (setq upper-lim from))
+
+ ;; If we're essentially repeating a fruitless search, just give up.
+ (unless (and c-state-brace-pair-desert
+ (eq cache-pos (car c-state-brace-pair-desert))
+ (<= from (cdr c-state-brace-pair-desert)))
+ ;; Only search what we absolutely need to:
+ (if (and c-state-brace-pair-desert
+ (> from (cdr c-state-brace-pair-desert)))
+ (narrow-to-region (cdr c-state-brace-pair-desert) (point-max)))
+
+ ;; In the next pair of nested loops, the inner one moves back past a
+ ;; pair of (mis-)matching parens or brackets; the outer one moves
+ ;; back over a sequence of unmatched close brace/paren/bracket each
+ ;; time round.
+ (while
+ (progn
+ (c-safe
+ (while
+ (and (setq ce (scan-lists bra -1 -1)) ; back past )/]/}; might signal
+ (setq bra (scan-lists ce -1 1)) ; back past (/[/{; might signal
+ (or (> ce upper-lim)
+ (not (eq (char-after bra) ?\{))
+ (and (goto-char bra)
+ (c-beginning-of-macro)
+ (< (point) macro-start-or-from))))))
+ (and ce (< ce bra)))
+ (setq bra ce)) ; If we just backed over an unbalanced closing
+ ; brace, ignore it.
+
+ (if (and ce (< bra ce) (eq (char-after bra) ?\{))
+ ;; We've found the desired brace-pair.
+ (progn
+ (setq new-cons (cons bra (1+ ce)))
+ (cond
+ ((consp (car c-state-cache))
+ (setcar c-state-cache new-cons))
+ ((and (numberp (car c-state-cache)) ; probably never happens
+ (< ce (car c-state-cache)))
+ (setcdr c-state-cache
+ (cons new-cons (cdr c-state-cache))))
+ (t (setq c-state-cache (cons new-cons c-state-cache)))))
+
+ ;; We haven't found a brace pair. Record this.
+ (setq c-state-brace-pair-desert (cons cache-pos from))))))))
+
+(defsubst c-state-push-any-brace-pair (bra+1 macro-start-or-here)
+ ;; If BRA+1 is nil, do nothing. Otherwise, BRA+1 is the buffer position
+ ;; following a {, and that brace has a (mis-)matching } (or ]), and we
+ ;; "push" "a" brace pair onto `c-state-cache'.
+ ;;
+ ;; Here "push" means overwrite the top element if it's itself a brace-pair,
+ ;; otherwise push it normally.
+ ;;
+ ;; The brace pair we push is normally the one surrounding BRA+1, but if the
+ ;; latter is inside a macro, not being a macro containing
+ ;; MACRO-START-OR-HERE, we scan backwards through the buffer for a non-macro
+ ;; base pair. This latter case is assumed to be rare.
+ ;;
+ ;; Note: POINT is not preserved in this routine.
+ (if bra+1
+ (if (or (> bra+1 macro-start-or-here)
+ (progn (goto-char bra+1)
+ (not (c-beginning-of-macro))))
+ (setq c-state-cache
+ (cons (cons (1- bra+1)
+ (scan-lists bra+1 1 1))
+ (if (consp (car c-state-cache))
+ (cdr c-state-cache)
+ c-state-cache)))
+ ;; N.B. This defsubst codes one method for the simple, normal case,
+ ;; and a more sophisticated, slower way for the general case. Don't
+ ;; eliminate this defsubst - it's a speed optimisation.
+ (c-append-lower-brace-pair-to-state-cache (1- bra+1)))))
+
+(defun c-append-to-state-cache (from)
+ ;; Scan the buffer from FROM to (point-max), adding elements into
+ ;; `c-state-cache' for braces etc. Return a candidate for
+ ;; `c-state-cache-good-pos'.
+ ;;
+ ;; FROM must be after the latest brace/paren/bracket in `c-state-cache', if
+ ;; any. Typically, it is immediately after it. It must not be inside a
+ ;; literal.
+ (let ((here-bol (c-point 'bol (point-max)))
+ (macro-start-or-here
+ (save-excursion (goto-char (point-max))
+ (if (c-beginning-of-macro)
+ (point)
+ (point-max))))
+ pa+1 ; pos just after an opening PAren (or brace).
+ (ren+1 from) ; usually a pos just after an closing paREN etc.
+ ; Is actually the pos. to scan for a (/{/[ from,
+ ; which sometimes is after a silly )/}/].
+ paren+1 ; Pos after some opening or closing paren.
+ paren+1s ; A list of `paren+1's; used to determine a
+ ; good-pos.
+ bra+1 ce+1 ; just after L/R bra-ces.
+ bra+1s ; list of OLD values of bra+1.
+ mstart) ; start of a macro.
+
+ (save-excursion
+ ;; Each time round the following loop, we enter a succesively deeper
+ ;; level of brace/paren nesting. (Except sometimes we "continue at
+ ;; the existing level".) `pa+1' is a pos inside an opening
+ ;; brace/paren/bracket, usually just after it.
+ (while
+ (progn
+ ;; Each time round the next loop moves forward over an opening then
+ ;; a closing brace/bracket/paren. This loop is white hot, so it
+ ;; plays ugly tricks to go fast. DON'T PUT ANYTHING INTO THIS
+ ;; LOOP WHICH ISN'T ABSOLUTELY NECESSARY!!! It terminates when a
+ ;; call of `scan-lists' signals an error, which happens when there
+ ;; are no more b/b/p's to scan.
+ (c-safe
+ (while t
+ (setq pa+1 (scan-lists ren+1 1 -1) ; Into (/{/[; might signal
+ paren+1s (cons pa+1 paren+1s))
+ (setq ren+1 (scan-lists pa+1 1 1)) ; Out of )/}/]; might signal
+ (if (and (eq (char-before pa+1) ?{)) ; Check for a macro later.
+ (setq bra+1 pa+1))
+ (setcar paren+1s ren+1)))
+
+ (if (and pa+1 (> pa+1 ren+1))
+ ;; We've just entered a deeper nesting level.
+ (progn
+ ;; Insert the brace pair (if present) and the single open
+ ;; paren/brace/bracket into `c-state-cache' It cannot be
+ ;; inside a macro, except one around point, because of what
+ ;; `c-neutralize-syntax-in-CPP' has done.
+ (c-state-push-any-brace-pair bra+1 macro-start-or-here)
+ ;; Insert the opening brace/bracket/paren position.
+ (setq c-state-cache (cons (1- pa+1) c-state-cache))
+ ;; Clear admin stuff for the next more nested part of the scan.
+ (setq ren+1 pa+1 pa+1 nil bra+1 nil bra+1s nil)
+ t) ; Carry on the loop
+
+ ;; All open p/b/b's at this nesting level, if any, have probably
+ ;; been closed by matching/mismatching ones. We're probably
+ ;; finished - we just need to check for having found an
+ ;; unmatched )/}/], which we ignore. Such a )/}/] can't be in a
+ ;; macro, due the action of `c-neutralize-syntax-in-CPP'.
+ (c-safe (setq ren+1 (scan-lists ren+1 1 1)))))) ; acts as loop control.
+
+ ;; Record the final, innermost, brace-pair if there is one.
+ (c-state-push-any-brace-pair bra+1 macro-start-or-here)
+
+ ;; Determine a good pos
+ (while (and (setq paren+1 (car paren+1s))
+ (> (if (> paren+1 macro-start-or-here)
+ paren+1
+ (goto-char paren+1)
+ (setq mstart (and (c-beginning-of-macro)
+ (point)))
+ (or mstart paren+1))
+ here-bol))
+ (setq paren+1s (cdr paren+1s)))
+ (cond
+ ((and paren+1 mstart)
+ (min paren+1 mstart))
+ (paren+1)
+ (t from)))))
+
+(defun c-remove-stale-state-cache (good-pos pps-point)
+ ;; Remove stale entries from the `c-cache-state', i.e. those which will
+ ;; not be in it when it is amended for position (point-max).
+ ;; Additionally, the "outermost" open-brace entry before (point-max)
+ ;; will be converted to a cons if the matching close-brace is scanned.
+ ;;
+ ;; GOOD-POS is a "maximal" "safe position" - there must be no open
+ ;; parens/braces/brackets between GOOD-POS and (point-max).
+ ;;
+ ;; As a second thing, calculate the result of parse-partial-sexp at
+ ;; PPS-POINT, w.r.t. GOOD-POS. The motivation here is that
+ ;; `c-state-cache-good-pos' may become PPS-POINT, but the caller may need to
+ ;; adjust it to get outside a string/comment. (Sorry about this! The code
+ ;; needs to be FAST).
+ ;;
+ ;; Return a list (GOOD-POS SCAN-BACK-POS PPS-STATE), where
+ ;; o - GOOD-POS is a position where the new value `c-state-cache' is known
+ ;; to be good (we aim for this to be as high as possible);
+ ;; o - SCAN-BACK-POS, if not nil, indicates there may be a brace pair
+ ;; preceding POS which needs to be recorded in `c-state-cache'. It is a
+ ;; position to scan backwards from.
+ ;; o - PPS-STATE is the parse-partial-sexp state at PPS-POINT.
+ (save-restriction
+ (narrow-to-region 1 (point-max))
+ (save-excursion
+ (let* ((in-macro-start ; start of macro containing (point-max) or nil.
+ (save-excursion
+ (goto-char (point-max))
+ (and (c-beginning-of-macro)
+ (point))))
+ (good-pos-actual-macro-start ; Start of macro containing good-pos
+ ; or nil
+ (and (< good-pos (point-max))
+ (save-excursion
+ (goto-char good-pos)
+ (and (c-beginning-of-macro)
+ (point)))))
+ (good-pos-actual-macro-end ; End of this macro, (maybe
+ ; (point-max)), or nil.
+ (and good-pos-actual-macro-start
+ (save-excursion
+ (goto-char good-pos-actual-macro-start)
+ (c-end-of-macro)
+ (point))))
+ pps-state ; Will be 9 or 10 elements long.
+ pos
+ upper-lim ; ,beyond which `c-state-cache' entries are removed
+ scan-back-pos
+ pair-beg pps-point-state target-depth)
+
+ ;; Remove entries beyond (point-max). Also remove any entries inside
+ ;; a macro, unless (point-max) is in the same macro.
+ (setq upper-lim
+ (if (or (null c-state-old-cpp-beg)
+ (and (> (point-max) c-state-old-cpp-beg)
+ (< (point-max) c-state-old-cpp-end)))
+ (point-max)
+ (min (point-max) c-state-old-cpp-beg)))
+ (while (and c-state-cache (>= (c-state-cache-top-lparen) upper-lim))
+ (setq c-state-cache (cdr c-state-cache)))
+ ;; If `upper-lim' is inside the last recorded brace pair, remove its
+ ;; RBrace and indicate we'll need to search backwards for a previous
+ ;; brace pair.
+ (when (and c-state-cache
+ (consp (car c-state-cache))
+ (> (cdar c-state-cache) upper-lim))
+ (setcar c-state-cache (caar c-state-cache))
+ (setq scan-back-pos (car c-state-cache)))
+
+ ;; The next loop jumps forward out of a nested level of parens each
+ ;; time round; the corresponding elements in `c-state-cache' are
+ ;; removed. `pos' is just after the brace-pair or the open paren at
+ ;; (car c-state-cache). There can be no open parens/braces/brackets
+ ;; between `good-pos'/`good-pos-actual-macro-start' and (point-max),
+ ;; due to the interface spec to this function.
+ (setq pos (if (and good-pos-actual-macro-end
+ (not (eq good-pos-actual-macro-start
+ in-macro-start)))
+ (1+ good-pos-actual-macro-end) ; get outside the macro as
+ ; marked by a `category' text property.
+ good-pos))
+ (goto-char pos)
+ (while (and c-state-cache
+ (< (point) (point-max)))
+ (cond
+ ((null pps-state) ; first time through
+ (setq target-depth -1))
+ ((eq (car pps-state) target-depth) ; found closing ),},]
+ (setq target-depth (1- (car pps-state))))
+ ;; Do nothing when we've merely reached pps-point.
+ )
+
+ ;; Scan!
+ (setq pps-state
+ (parse-partial-sexp
+ (point) (if (< (point) pps-point) pps-point (point-max))
+ target-depth
+ nil pps-state))
+
+ (if (= (point) pps-point)
+ (setq pps-point-state pps-state))
+
+ (when (eq (car pps-state) target-depth)
+ (setq pos (point)) ; POS is now just after an R-paren/brace.
+ (cond
+ ((and (consp (car c-state-cache))
+ (eq (point) (cdar c-state-cache)))
+ ;; We've just moved out of the paren pair containing the brace-pair
+ ;; at (car c-state-cache). `pair-beg' is where the open paren is,
+ ;; and is potentially where the open brace of a cons in
+ ;; c-state-cache will be.
+ (setq pair-beg (car-safe (cdr c-state-cache))
+ c-state-cache (cdr-safe (cdr c-state-cache)))) ; remove {}pair + containing Lparen.
+ ((numberp (car c-state-cache))
+ (setq pair-beg (car c-state-cache)
+ c-state-cache (cdr c-state-cache))) ; remove this
+ ; containing Lparen
+ ((numberp (cadr c-state-cache))
+ (setq pair-beg (cadr c-state-cache)
+ c-state-cache (cddr c-state-cache))) ; Remove a paren pair
+ ; together with enclosed brace pair.
+ ;; (t nil) ; Ignore an unmated Rparen.
+ )))
+
+ (if (< (point) pps-point)
+ (setq pps-state (parse-partial-sexp (point) pps-point
+ nil nil ; TARGETDEPTH, STOPBEFORE
+ pps-state)))
+
+ ;; If the last paren pair we moved out of was actually a brace pair,
+ ;; insert it into `c-state-cache'.
+ (when (and pair-beg (eq (char-after pair-beg) ?{))
+ (if (consp (car-safe c-state-cache))
+ (setq c-state-cache (cdr c-state-cache)))
+ (setq c-state-cache (cons (cons pair-beg pos)
+ c-state-cache)))
+
+ (list pos scan-back-pos pps-state)))))
+
+(defun c-remove-stale-state-cache-backwards (here cache-pos)
+ ;; Strip stale elements of `c-state-cache' by moving backwards through the
+ ;; buffer, and inform the caller of the scenario detected.
+ ;;
+ ;; HERE is the position we're setting `c-state-cache' for.
+ ;; CACHE-POS is just after the latest recorded position in `c-state-cache'
+ ;; before HERE, or a position at or near point-min which isn't in a
+ ;; literal.
+ ;;
+ ;; This function must only be called only when (> `c-state-cache-good-pos'
+ ;; HERE). Usually the gap between CACHE-POS and HERE is large. It is thus
+ ;; optimised to eliminate (or minimise) scanning between these two
+ ;; positions.
+ ;;
+ ;; Return a three element list (GOOD-POS SCAN-BACK-POS FWD-FLAG), where:
+ ;; o - GOOD-POS is a "good position", where `c-state-cache' is valid, or
+ ;; could become so after missing elements are inserted into
+ ;; `c-state-cache'. This is JUST AFTER an opening or closing
+ ;; brace/paren/bracket which is already in `c-state-cache' or just before
+ ;; one otherwise. exceptionally (when there's no such b/p/b handy) the BOL
+ ;; before `here''s line, or the start of the literal containing it.
+ ;; o - SCAN-BACK-POS, if non-nil, indicates there may be a brace pair
+ ;; preceding POS which isn't recorded in `c-state-cache'. It is a position
+ ;; to scan backwards from.
+ ;; o - FWD-FLAG, if non-nil, indicates there may be parens/braces between
+ ;; POS and HERE which aren't recorded in `c-state-cache'.
+ ;;
+ ;; The comments in this defun use "paren" to mean parenthesis or square
+ ;; bracket (as contrasted with a brace), and "(" and ")" likewise.
+ ;;
+ ;; . {..} (..) (..) ( .. { } ) (...) ( .... . ..)
+ ;; | | | | | |
+ ;; CP E here D C good
+ (let ((pos c-state-cache-good-pos)
+ pa ren ; positions of "(" and ")"
+ dropped-cons ; whether the last element dropped from `c-state-cache'
+ ; was a cons (representing a brace-pair)
+ good-pos ; see above.
+ lit ; (START . END) of a literal containing some point.
+ here-lit-start here-lit-end ; bounds of literal containing `here'
+ ; or `here' itself.
+ here- here+ ; start/end of macro around HERE, or HERE
+ (here-bol (c-point 'bol here))
+ (too-far-back (max (- here c-state-cache-too-far) 1)))
+
+ ;; Remove completely irrelevant entries from `c-state-cache'.
+ (while (and c-state-cache
+ (>= (setq pa (c-state-cache-top-lparen)) here))
+ (setq dropped-cons (consp (car c-state-cache)))
+ (setq c-state-cache (cdr c-state-cache))
+ (setq pos pa))
+ ;; At this stage, (> pos here);
+ ;; (< (c-state-cache-top-lparen) here) (or is nil).
+
+ (cond
+ ((and (consp (car c-state-cache))
+ (> (cdar c-state-cache) here))
+ ;; CASE 1: The top of the cache is a brace pair which now encloses
+ ;; `here'. As good-pos, return the address. of the "{". Since we've no
+ ;; knowledge of what's inside these braces, we have no alternative but
+ ;; to direct the caller to scan the buffer from the opening brace.
+ (setq pos (caar c-state-cache))
+ (setcar c-state-cache pos)
+ (list (1+ pos) pos t)) ; return value. We've just converted a brace pair
+ ; entry into a { entry, so the caller needs to
+ ; search for a brace pair before the {.
+
+ ;; `here' might be inside a literal. Check for this.
+ ((progn
+ (setq lit (c-state-literal-at here)
+ here-lit-start (or (car lit) here)
+ here-lit-end (or (cdr lit) here))
+ ;; Has `here' just "newly entered" a macro?
+ (save-excursion
+ (goto-char here-lit-start)
+ (if (and (c-beginning-of-macro)
+ (or (null c-state-old-cpp-beg)
+ (not (= (point) c-state-old-cpp-beg))))
+ (progn
+ (setq here- (point))
+ (c-end-of-macro)
+ (setq here+ (point)))
+ (setq here- here-lit-start
+ here+ here-lit-end)))
+
+ ;; `here' might be nested inside any depth of parens (or brackets but
+ ;; not braces). Scan backwards to find the outermost such opening
+ ;; paren, if there is one. This will be the scan position to return.
+ (save-restriction
+ (narrow-to-region cache-pos (point-max))
+ (setq pos (c-state-balance-parens-backwards here- here+ pos)))
+ nil)) ; for the cond
+
+ ((< pos here-lit-start)
+ ;; CASE 2: Address of outermost ( or [ which now encloses `here', but
+ ;; didn't enclose the (previous) `c-state-cache-good-pos'. If there is
+ ;; a brace pair preceding this, it will already be in `c-state-cache',
+ ;; unless there was a brace pair after it, i.e. there'll only be one to
+ ;; scan for if we've just deleted one.
+ (list pos (and dropped-cons pos) t)) ; Return value.
+
+ ;; `here' isn't enclosed in a (previously unrecorded) bracket/paren.
+ ;; Further forward scanning isn't needed, but we still need to find a
+ ;; GOOD-POS. Step out of all enclosing "("s on HERE's line.
+ ((progn
+ (save-restriction
+ (narrow-to-region here-bol (point-max))
+ (setq pos here-lit-start)
+ (c-safe (while (setq pa (scan-lists pos -1 1))
+ (setq pos pa)))) ; might signal
+ nil)) ; for the cond
+
+ ((setq ren (c-safe-scan-lists pos -1 -1 too-far-back))
+ ;; CASE 3: After a }/)/] before `here''s BOL.
+ (list (1+ ren) (and dropped-cons pos) nil)) ; Return value
+
+ (t
+ ;; CASE 4; Best of a bad job: BOL before `here-bol', or beginning of
+ ;; literal containing it.
+ (setq good-pos (c-state-lit-beg (c-point 'bopl here-bol)))
+ (list good-pos (and dropped-cons good-pos) nil)))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Externally visible routines.
+
+(defun c-state-cache-init ()
+ (setq c-state-cache nil
+ c-state-cache-good-pos 1
+ c-state-nonlit-pos-cache nil
+ c-state-nonlit-pos-cache-limit 1
+ c-state-brace-pair-desert nil
+ c-state-point-min 1
+ c-state-point-min-lit-type nil
+ c-state-point-min-lit-start nil
+ c-state-min-scan-pos 1
+ c-state-old-cpp-beg nil
+ c-state-old-cpp-end nil)
+ (c-state-mark-point-min-literal))
+
+(defun c-invalidate-state-cache-1 (here)
+ ;; Invalidate all info on `c-state-cache' that applies to the buffer at HERE
+ ;; or higher and set `c-state-cache-good-pos' accordingly. The cache is
+ ;; left in a consistent state.
+ ;;
+ ;; This is much like `c-whack-state-after', but it never changes a paren
+ ;; pair element into an open paren element. Doing that would mean that the
+ ;; new open paren wouldn't have the required preceding paren pair element.
+ ;;
+ ;; This function is called from c-after-change.
+
+ ;; The cache of non-literals:
+ (if (< here c-state-nonlit-pos-cache-limit)
+ (setq c-state-nonlit-pos-cache-limit here))
+
+ ;; `c-state-cache':
+ ;; Case 1: if `here' is in a literal containing point-min, everything
+ ;; becomes (or is already) nil.
+ (if (or (null c-state-cache-good-pos)
+ (< here (c-state-get-min-scan-pos)))
+ (setq c-state-cache nil
+ c-state-cache-good-pos nil
+ c-state-min-scan-pos nil)
+
+;;; Truncate `c-state-cache' and set `c-state-cache-good-pos' to a value below
+;;; `here'. To maintain its consistency, we may need to insert a new brace
+;;; pair.
+ (let ((here-bol (c-point 'bol here))
+ too-high-pa ; recorded {/(/[ next above here, or nil.
+ dropped-cons ; was the last removed element a brace pair?
+ pa)
+ ;; The easy bit - knock over-the-top bits off `c-state-cache'.
+ (while (and c-state-cache
+ (>= (setq pa (c-state-cache-top-paren)) here))
+ (setq dropped-cons (consp (car c-state-cache))
+ too-high-pa (c-state-cache-top-lparen)
+ c-state-cache (cdr c-state-cache)))
+
+ ;; Do we need to add in an earlier brace pair, having lopped one off?
+ (if (and dropped-cons
+ (< too-high-pa (+ here c-state-cache-too-far)))
+ (c-append-lower-brace-pair-to-state-cache too-high-pa here-bol))
+ (setq c-state-cache-good-pos (or (c-state-cache-after-top-paren)
+ (c-state-get-min-scan-pos)))))
+
+ ;; The brace-pair desert marker:
+ (when (car c-state-brace-pair-desert)
+ (if (< here (car c-state-brace-pair-desert))
+ (setq c-state-brace-pair-desert nil)
+ (if (< here (cdr c-state-brace-pair-desert))
+ (setcdr c-state-brace-pair-desert here)))))
+
+(defun c-parse-state-1 ()
+ ;; Find and record all noteworthy parens between some good point earlier in
+ ;; the file and point. That good point is at least the beginning of the
+ ;; top-level construct we are in, or the beginning of the preceding
+ ;; top-level construct if we aren't in one.
+ ;;
+ ;; The returned value is a list of the noteworthy parens with the last one
+ ;; first. If an element in the list is an integer, it's the position of an
+ ;; open paren (of any type) which has not been closed before the point. If
+ ;; an element is a cons, it gives the position of a closed BRACE paren
+ ;; pair[*]; the car is the start brace position and the cdr is the position
+ ;; following the closing brace. Only the last closed brace paren pair
+ ;; before each open paren and before the point is recorded, and thus the
+ ;; state never contains two cons elements in succession. When a close brace
+ ;; has no matching open brace (e.g., the matching brace is outside the
+ ;; visible region), it is not represented in the returned value.
+ ;;
+ ;; [*] N.B. The close "brace" might be a mismatching close bracket or paren.
+ ;; This defun explicitly treats mismatching parens/braces/brackets as
+ ;; matching. It is the open brace which makes it a "brace" pair.
+ ;;
+ ;; If POINT is within a macro, open parens and brace pairs within
+ ;; THIS macro MIGHT be recorded. This depends on whether their
+ ;; syntactic properties have been suppressed by
+ ;; `c-neutralize-syntax-in-CPP'. This might need fixing (2008-12-11).
;;
;; Currently no characters which are given paren syntax with the
;; syntax-table property are recorded, i.e. angle bracket arglist
;; parens are never present here. Note that this might change.
;;
;; BUG: This function doesn't cope entirely well with unbalanced
- ;; parens in macros. E.g. in the following case the brace before
- ;; the macro isn't balanced with the one after it:
+ ;; parens in macros. (2008-12-11: this has probably been resolved
+ ;; by the function `c-neutralize-syntax-in-CPP'.) E.g. in the
+ ;; following case the brace before the macro isn't balanced with the
+ ;; one after it:
;;
;; {
;; #define X {
;; }
;;
+ ;; Note to maintainers: this function DOES get called with point
+ ;; within comments and strings, so don't assume it doesn't!
+ ;;
;; This function might do hidden buffer changes.
+ (let* ((here (point))
+ (here-bopl (c-point 'bopl))
+ strategy ; 'forward, 'backward etc..
+ ;; Candidate positions to start scanning from:
+ cache-pos ; highest position below HERE already existing in
+ ; cache (or 1).
+ good-pos
+ start-point
+ bopl-state
+ res
+ scan-backward-pos scan-forward-p) ; used for 'backward.
+ ;; If POINT-MIN has changed, adjust the cache
+ (unless (= (point-min) c-state-point-min)
+ (c-renarrow-state-cache))
+
+ ;; Strategy?
+ (setq res (c-parse-state-get-strategy here c-state-cache-good-pos)
+ strategy (car res)
+ cache-pos (cadr res)
+ start-point (nth 2 res))
+
+ (when (eq strategy 'BOD)
+ (setq c-state-cache nil
+ c-state-cache-good-pos start-point))
+
+ ;; SCAN!
+ (save-restriction
+ (cond
+ ((memq strategy '(forward BOD))
+ (narrow-to-region (point-min) here)
+ (setq res (c-remove-stale-state-cache start-point here-bopl))
+ (setq cache-pos (car res)
+ scan-backward-pos (cadr res)
+ bopl-state (car (cddr res))) ; will be nil if (< here-bopl
+ ; start-point)
+ (if scan-backward-pos
+ (c-append-lower-brace-pair-to-state-cache scan-backward-pos))
+ (setq good-pos
+ (c-append-to-state-cache cache-pos))
+ (setq c-state-cache-good-pos
+ (if (and bopl-state
+ (< good-pos (- here c-state-cache-too-far)))
+ (c-state-cache-non-literal-place here-bopl bopl-state)
+ good-pos)))
+
+ ((eq strategy 'backward)
+ (setq res (c-remove-stale-state-cache-backwards here cache-pos)
+ good-pos (car res)
+ scan-backward-pos (cadr res)
+ scan-forward-p (car (cddr res)))
+ (if scan-backward-pos
+ (c-append-lower-brace-pair-to-state-cache
+ scan-backward-pos))
+ (setq c-state-cache-good-pos
+ (if scan-forward-p
+ (progn (narrow-to-region (point-min) here)
+ (c-append-to-state-cache good-pos))
+
+ (c-get-cache-scan-pos good-pos))))
+
+ (t ; (eq strategy 'IN-LIT)
+ (setq c-state-cache nil
+ c-state-cache-good-pos nil)))))
+
+ c-state-cache)
+
+(defun c-invalidate-state-cache (here)
+ ;; This is a wrapper over `c-invalidate-state-cache-1'.
+ ;;
+ ;; It suppresses the syntactic effect of the < and > (template) brackets and
+ ;; of all parens in preprocessor constructs, except for any such construct
+ ;; containing point. We can then call `c-invalidate-state-cache-1' without
+ ;; worrying further about macros and template delimiters.
+ (c-with-<->-as-parens-suppressed
+ (if (and c-state-old-cpp-beg
+ (< c-state-old-cpp-beg here))
+ (c-with-all-but-one-cpps-commented-out
+ c-state-old-cpp-beg
+ (min c-state-old-cpp-end here)
+ (c-invalidate-state-cache-1 here))
+ (c-with-cpps-commented-out
+ (c-invalidate-state-cache-1 here)))))
- (save-restriction
- (let* ((here (point))
- (here-bol (c-point 'bol))
- (c-macro-start (c-query-macro-start))
- (in-macro-start (or c-macro-start (point)))
- old-state last-pos brace-pair-open brace-pair-close
- pos save-pos)
- (c-invalidate-state-cache here)
-
- ;; If the minimum position has changed due to narrowing then we
- ;; have to fix the tail of `c-state-cache' accordingly.
- (unless (= c-state-cache-start (point-min))
- (if (> (point-min) c-state-cache-start)
- ;; If point-min has moved forward then we just need to cut
- ;; off a bit of the tail.
- (let ((ptr (cons nil c-state-cache)) elem)
- (while (and (setq elem (car-safe (cdr ptr)))
- (>= (if (consp elem) (car elem) elem)
- (point-min)))
- (setq ptr (cdr ptr)))
- (when (consp ptr)
- (if (eq (cdr ptr) c-state-cache)
- (setq c-state-cache nil
- c-state-cache-good-pos 1)
- (setcdr ptr nil))))
- ;; If point-min has moved backward then we drop the state
- ;; completely. It's possible to do a better job here and
- ;; recalculate the top only.
- (setq c-state-cache nil
- c-state-cache-good-pos 1))
- (setq c-state-cache-start (point-min)))
-
- ;; Get the latest position we know are directly inside the
- ;; closest containing paren of the cached state.
- (setq last-pos (and c-state-cache
- (if (consp (car c-state-cache))
- (cdr (car c-state-cache))
- (1+ (car c-state-cache)))))
- (if (or (not last-pos)
- (< last-pos c-state-cache-good-pos))
- (setq last-pos c-state-cache-good-pos)
- ;; Take the opportunity to move the cached good position
- ;; further down.
- (if (< last-pos here-bol)
- (setq c-state-cache-good-pos last-pos)))
+(defun c-parse-state ()
+ ;; This is a wrapper over `c-parse-state-1'. See that function for a
+ ;; description of the functionality and return value.
+ ;;
+ ;; It suppresses the syntactic effect of the < and > (template) brackets and
+ ;; of all parens in preprocessor constructs, except for any such construct
+ ;; containing point. We can then call `c-parse-state-1' without worrying
+ ;; further about macros and template delimiters.
+ (let (here-cpp-beg here-cpp-end)
+ (save-excursion
+ (when (c-beginning-of-macro)
+ (setq here-cpp-beg (point))
+ (unless
+ (> (setq here-cpp-end (c-syntactic-end-of-macro))
+ here-cpp-beg)
+ (setq here-cpp-beg nil here-cpp-end nil))))
+ ;; FIXME!!! Put in a `condition-case' here to protect the integrity of the
+ ;; subsystem.
+ (prog1
+ (c-with-<->-as-parens-suppressed
+ (if (and here-cpp-beg (> here-cpp-end here-cpp-beg))
+ (c-with-all-but-one-cpps-commented-out
+ here-cpp-beg here-cpp-end
+ (c-parse-state-1))
+ (c-with-cpps-commented-out
+ (c-parse-state-1))))
+ (setq c-state-old-cpp-beg (and here-cpp-beg (copy-marker here-cpp-beg t))
+ c-state-old-cpp-end (and here-cpp-end (copy-marker here-cpp-end t)))
+ )))
- ;; Check if `last-pos' is in a macro. If it is, and we're not
- ;; in the same macro, we must discard everything on
- ;; `c-state-cache' that is inside the macro before using it.
- (save-excursion
- (goto-char last-pos)
- (when (and (c-beginning-of-macro)
- (/= (point) in-macro-start))
- (c-invalidate-state-cache (point))
- ;; Set `last-pos' again just like above except that there's
- ;; no use looking at `c-state-cache-good-pos' here.
- (setq last-pos (if c-state-cache
- (if (consp (car c-state-cache))
- (cdr (car c-state-cache))
- (1+ (car c-state-cache)))
- 1))))
-
- ;; If we've moved very far from the last cached position then
- ;; it's probably better to redo it from scratch, otherwise we
- ;; might spend a lot of time searching from `last-pos' down to
- ;; here.
- (when (< last-pos (- here 20000))
- ;; First get the fallback start position. If it turns out
- ;; that it's so far back that the cached state is closer then
- ;; we'll keep it afterall.
- (setq pos (c-get-fallback-start-pos here))
- (if (<= pos last-pos)
- (setq pos nil)
- (setq last-pos nil
- c-state-cache nil
- c-state-cache-good-pos 1)))
-
- ;; Find the start position for the forward search. (Can't
- ;; search in the backward direction since the point might be in
- ;; some kind of literal.)
-
- (unless pos
- (setq old-state c-state-cache)
-
- ;; There's a cached state with a containing paren. Pop off
- ;; the stale containing sexps from it by going forward out of
- ;; parens as far as possible.
- (narrow-to-region (point-min) here)
- (let (placeholder pair-beg)
- (while (and c-state-cache
- (setq placeholder
- (c-up-list-forward last-pos)))
- (setq last-pos placeholder)
- (if (consp (car c-state-cache))
- (setq pair-beg (car-safe (cdr c-state-cache))
- c-state-cache (cdr-safe (cdr c-state-cache)))
- (setq pair-beg (car c-state-cache)
- c-state-cache (cdr c-state-cache))))
-
- (when (and pair-beg (eq (char-after pair-beg) ?{))
- ;; The last paren pair we moved out from was a brace
- ;; pair. Modify the state to record this as a closed
- ;; pair now.
- (if (consp (car-safe c-state-cache))
- (setq c-state-cache (cdr c-state-cache)))
- (setq c-state-cache (cons (cons pair-beg last-pos)
- c-state-cache))))
-
- ;; Check if the preceding balanced paren is within a
- ;; macro; it should be ignored if we're outside the
- ;; macro. There's no need to check any further upwards;
- ;; if the macro contains an unbalanced opening paren then
- ;; we're smoked anyway.
- (when (and (<= (point) in-macro-start)
- (consp (car c-state-cache)))
- (save-excursion
- (goto-char (car (car c-state-cache)))
- (when (c-beginning-of-macro)
- (setq here (point)
- c-state-cache (cdr c-state-cache)))))
-
- (unless (eq c-state-cache old-state)
- ;; Have to adjust the cached good position if state has been
- ;; popped off.
- (setq c-state-cache-good-pos
- (if c-state-cache
- (if (consp (car c-state-cache))
- (cdr (car c-state-cache))
- (1+ (car c-state-cache)))
- 1)
- old-state c-state-cache))
-
- (when c-state-cache
- (setq pos last-pos)))
-
- ;; Get the fallback start position.
- (unless pos
- (setq pos (c-get-fallback-start-pos here)
- c-state-cache nil
- c-state-cache-good-pos 1))
-
- (narrow-to-region (point-min) here)
-
- (while pos
- (setq save-pos pos
- brace-pair-open nil)
-
- ;; Find the balanced brace pairs. This loop is hot, so it
- ;; does ugly tricks to go faster.
- (c-safe
- (let (set-good-pos set-brace-pair)
- (while t
- (setq last-pos nil
- last-pos (scan-lists pos 1 -1)) ; Might signal.
- (setq pos (scan-lists last-pos 1 1) ; Might signal.
- set-good-pos (< pos here-bol)
- set-brace-pair (eq (char-before last-pos) ?{))
-
- ;; Update the cached good position and record the brace
- ;; pair, whichever is applicable for the paren we've
- ;; just jumped over. But first check that it isn't
- ;; inside a macro and the point isn't inside the same
- ;; one.
- (when (and (or set-good-pos set-brace-pair)
- (or (>= pos in-macro-start)
- (save-excursion
- (goto-char pos)
- (not (c-beginning-of-macro)))))
- (if set-good-pos
- (setq c-state-cache-good-pos pos))
- (if set-brace-pair
- (setq brace-pair-open last-pos
- brace-pair-close pos))))))
-
- ;; Record the last brace pair.
- (when brace-pair-open
- (let ((head (car-safe c-state-cache)))
- (if (consp head)
- (progn
- (setcar head (1- brace-pair-open))
- (setcdr head brace-pair-close))
- (setq c-state-cache (cons (cons (1- brace-pair-open)
- brace-pair-close)
- c-state-cache)))))
-
- (if last-pos
- ;; Prepare to loop, but record the open paren only if it's
- ;; outside a macro or within the same macro as point, and
- ;; if it is a legitimate open paren and not some character
- ;; that got an open paren syntax-table property.
- (progn
- (setq pos last-pos)
- (when (and (or (>= last-pos in-macro-start)
- (save-excursion
- (goto-char last-pos)
- (not (c-beginning-of-macro))))
- ;; Check for known types of parens that we
- ;; want to record. The syntax table is not to
- ;; be trusted here since the caller might be
- ;; using e.g. `c++-template-syntax-table'.
- (memq (char-before last-pos) '(?{ ?\( ?\[)))
- (if (< last-pos here-bol)
- (setq c-state-cache-good-pos last-pos))
- (setq c-state-cache (cons (1- last-pos) c-state-cache))))
-
- (if (setq last-pos (c-up-list-forward pos))
- ;; Found a close paren without a corresponding opening
- ;; one. Maybe we didn't go back far enough, so try to
- ;; scan backward for the start paren and then start over.
- (progn
- (setq pos (c-up-list-backward pos)
- c-state-cache nil
- c-state-cache-good-pos c-state-cache-start)
- (when (or (not pos)
- ;; Emacs (up to at least 21.2) can get confused by
- ;; open parens in column zero inside comments: The
- ;; sexp functions can then misbehave and bring us
- ;; back to the same point again. Check this so that
- ;; we don't get an infinite loop.
- (>= pos save-pos))
- (setq pos last-pos
- c-parsing-error
- (format "Unbalanced close paren at line %d"
- (1+ (count-lines (point-min)
- (c-point 'bol last-pos)))))))
- (setq pos nil))))
-
- ;;(message "c-parse-state: %S end: %S" c-state-cache c-state-cache-good-pos)
- c-state-cache)))
-
-;; Debug tool to catch cache inconsistencies.
+;; Debug tool to catch cache inconsistencies. This is called from
+;; 000tests.el.
(defvar c-debug-parse-state nil)
(unless (fboundp 'c-real-parse-state)
(fset 'c-real-parse-state (symbol-function 'c-parse-state)))
(cc-bytecomp-defun c-real-parse-state)
(defun c-debug-parse-state ()
- (let ((res1 (c-real-parse-state)) res2)
+ (let ((here (point)) (res1 (c-real-parse-state)) res2)
(let ((c-state-cache nil)
- (c-state-cache-start 1)
- (c-state-cache-good-pos 1))
+ (c-state-cache-good-pos 1)
+ (c-state-nonlit-pos-cache nil)
+ (c-state-nonlit-pos-cache-limit 1)
+ (c-state-brace-pair-desert nil)
+ (c-state-point-min 1)
+ (c-state-point-min-lit-type nil)
+ (c-state-point-min-lit-start nil)
+ (c-state-min-scan-pos 1)
+ (c-state-old-cpp-beg nil)
+ (c-state-old-cpp-end nil))
(setq res2 (c-real-parse-state)))
(unless (equal res1 res2)
;; The cache can actually go further back due to the ad-hoc way
@@ -2296,10 +3084,11 @@ comment at the start of cc-engine.el for more info."
(while (not (or (bobp) (eq (char-after) ?{)))
(c-beginning-of-defun-1))
(unless (equal (c-whack-state-before (point) res1) res2)
- (message (concat "c-parse-state inconsistency: "
+ (message (concat "c-parse-state inconsistency at %s: "
"using cache: %s, from scratch: %s")
- res1 res2))))
+ here res1 res2))))
res1))
+
(defun c-toggle-parse-state-debug (&optional arg)
(interactive "P")
(setq c-debug-parse-state (c-calculate-state arg c-debug-parse-state))
@@ -2310,6 +3099,7 @@ comment at the start of cc-engine.el for more info."
(when c-debug-parse-state
(c-toggle-parse-state-debug 1))
+
(defun c-whack-state-before (bufpos paren-state)
;; Whack off any state information from PAREN-STATE which lies
;; before BUFPOS. Not destructive on PAREN-STATE.
@@ -4109,7 +4899,190 @@ comment at the start of cc-engine.el for more info."
)))
-;; Handling of small scale constructs like types and names.
+;; Setting and removing syntax properties on < and > in languages (C++
+;; and Java) where they can be template/generic delimiters as well as
+;; their normal meaning of "less/greater than".
+
+;; Normally, < and > have syntax 'punctuation'. When they are found to
+;; be delimiters, they are marked as such with the category properties
+;; c-<-as-paren-syntax, c->-as-paren-syntax respectively.
+
+;; STRATEGY:
+;;
+;; It is impossible to determine with certainty whether a <..> pair in
+;; C++ is two comparison operators or is template delimiters, unless
+;; one duplicates a lot of a C++ compiler. For example, the following
+;; code fragment:
+;;
+;; foo (a < b, c > d) ;
+;;
+;; could be a function call with two integer parameters (each a
+;; relational expression), or it could be a constructor for class foo
+;; taking one parameter d of templated type "a < b, c >". They are
+;; somewhat easier to distinguish in Java.
+;;
+;; The strategy now (2010-01) adopted is to mark and unmark < and
+;; > IN MATCHING PAIRS ONLY. [Previously, they were marked
+;; individually when their context so indicated. This gave rise to
+;; intractible problems when one of a matching pair was deleted, or
+;; pulled into a literal.]
+;;
+;; At each buffer change, the syntax-table properties are removed in a
+;; before-change function and reapplied, when needed, in an
+;; after-change function. It is far more important that the
+;; properties get removed when they they are spurious than that they
+;; be present when wanted.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun c-clear-<-pair-props (&optional pos)
+ ;; POS (default point) is at a < character. If it is marked with
+ ;; open paren syntax-table text property, remove the property,
+ ;; together with the close paren property on the matching > (if
+ ;; any).
+ (save-excursion
+ (if pos
+ (goto-char pos)
+ (setq pos (point)))
+ (when (equal (c-get-char-property (point) 'syntax-table)
+ c-<-as-paren-syntax)
+ (with-syntax-table c-no-parens-syntax-table ; ignore unbalanced [,{,(,..
+ (c-go-list-forward))
+ (when (equal (c-get-char-property (1- (point)) 'syntax-table)
+ c->-as-paren-syntax) ; should always be true.
+ (c-clear-char-property (1- (point)) 'category))
+ (c-clear-char-property pos 'category))))
+
+(defun c-clear->-pair-props (&optional pos)
+ ;; POS (default point) is at a > character. If it is marked with
+ ;; close paren syntax-table property, remove the property, together
+ ;; with the open paren property on the matching < (if any).
+ (save-excursion
+ (if pos
+ (goto-char pos)
+ (setq pos (point)))
+ (when (equal (c-get-char-property (point) 'syntax-table)
+ c->-as-paren-syntax)
+ (with-syntax-table c-no-parens-syntax-table ; ignore unbalanced [,{,(,..
+ (c-go-up-list-backward))
+ (when (equal (c-get-char-property (point) 'syntax-table)
+ c-<-as-paren-syntax) ; should always be true.
+ (c-clear-char-property (point) 'category))
+ (c-clear-char-property pos 'category))))
+
+(defun c-clear-<>-pair-props (&optional pos)
+ ;; POS (default point) is at a < or > character. If it has an
+ ;; open/close paren syntax-table property, remove this property both
+ ;; from the current character and its partner (which will also be
+ ;; thusly marked).
+ (cond
+ ((eq (char-after) ?\<)
+ (c-clear-<-pair-props pos))
+ ((eq (char-after) ?\>)
+ (c-clear->-pair-props pos))
+ (t (c-benign-error
+ "c-clear-<>-pair-props called from wrong position"))))
+
+(defun c-clear-<-pair-props-if-match-after (lim &optional pos)
+ ;; POS (default point) is at a < character. If it is both marked
+ ;; with open/close paren syntax-table property, and has a matching >
+ ;; (also marked) which is after LIM, remove the property both from
+ ;; the current > and its partner. Return t when this happens, nil
+ ;; when it doesn't.
+ (save-excursion
+ (if pos
+ (goto-char pos)
+ (setq pos (point)))
+ (when (equal (c-get-char-property (point) 'syntax-table)
+ c-<-as-paren-syntax)
+ (with-syntax-table c-no-parens-syntax-table ; ignore unbalanced [,{,(,..
+ (c-go-list-forward))
+ (when (and (>= (point) lim)
+ (equal (c-get-char-property (1- (point)) 'syntax-table)
+ c->-as-paren-syntax)) ; should always be true.
+ (c-unmark-<->-as-paren (1- (point)))
+ (c-unmark-<->-as-paren pos))
+ t)))
+
+(defun c-clear->-pair-props-if-match-before (lim &optional pos)
+ ;; POS (default point) is at a > character. If it is both marked
+ ;; with open/close paren syntax-table property, and has a matching <
+ ;; (also marked) which is before LIM, remove the property both from
+ ;; the current < and its partner. Return t when this happens, nil
+ ;; when it doesn't.
+ (save-excursion
+ (if pos
+ (goto-char pos)
+ (setq pos (point)))
+ (when (equal (c-get-char-property (point) 'syntax-table)
+ c->-as-paren-syntax)
+ (with-syntax-table c-no-parens-syntax-table ; ignore unbalanced [,{,(,..
+ (c-go-up-list-backward))
+ (when (and (<= (point) lim)
+ (equal (c-get-char-property (point) 'syntax-table)
+ c-<-as-paren-syntax)) ; should always be true.
+ (c-unmark-<->-as-paren (point))
+ (c-unmark-<->-as-paren pos))
+ t)))
+
+;; Set by c-common-init in cc-mode.el.
+(defvar c-new-BEG)
+(defvar c-new-END)
+
+(defun c-before-change-check-<>-operators (beg end)
+ ;; Unmark certain pairs of "< .... >" which are currently marked as
+ ;; template/generic delimiters. (This marking is via syntax-table
+ ;; text properties).
+ ;;
+ ;; These pairs are those which are in the current "statement" (i.e.,
+ ;; the region between the {, }, or ; before BEG and the one after
+ ;; END), and which enclose any part of the interval (BEG END).
+ ;;
+ ;; Note that in C++ (?and Java), template/generic parens cannot
+ ;; enclose a brace or semicolon, so we use these as bounds on the
+ ;; region we must work on.
+ ;;
+ ;; This function is called from before-change-functions (via
+ ;; c-get-state-before-change-functions). Thus the buffer is widened,
+ ;; and point is undefined, both at entry and exit.
+ ;;
+ ;; FIXME!!! This routine ignores the possibility of macros entirely.
+ ;; 2010-01-29.
+ (save-excursion
+ (let ((beg-lit-limits (progn (goto-char beg) (c-literal-limits)))
+ (end-lit-limits (progn (goto-char end) (c-literal-limits)))
+ new-beg new-end need-new-beg need-new-end)
+ ;; Locate the barrier before the changed region
+ (goto-char (if beg-lit-limits (car beg-lit-limits) beg))
+ (c-syntactic-skip-backward "^;{}" (max (- beg 2048) (point-min)))
+ (setq new-beg (point))
+
+ ;; Remove the syntax-table properties from each pertinent <...> pair.
+ ;; Firsly, the ones with the < before beg and > after beg.
+ (while (c-search-forward-char-property 'category 'c-<-as-paren-syntax beg)
+ (if (c-clear-<-pair-props-if-match-after beg (1- (point)))
+ (setq need-new-beg t)))
+
+ ;; Locate the barrier after END.
+ (goto-char (if end-lit-limits (cdr end-lit-limits) end))
+ (c-syntactic-re-search-forward "[;{}]"
+ (min (+ end 2048) (point-max)) 'end)
+ (setq new-end (point))
+
+ ;; Remove syntax-table properties from the remaining pertinent <...>
+ ;; pairs, those with a > after end and < before end.
+ (while (c-search-backward-char-property 'category 'c->-as-paren-syntax end)
+ (if (c-clear->-pair-props-if-match-before end)
+ (setq need-new-end t)))
+
+ ;; Extend the fontification region, if needed.
+ (when need-new-beg
+ (goto-char new-beg)
+ (c-forward-syntactic-ws)
+ (and (< (point) c-new-BEG) (setq c-new-BEG (point))))
+
+ (when need-new-end
+ (and (> new-end c-new-END) (setq c-new-END new-end))))))
+
+
(defun c-after-change-check-<>-operators (beg end)
;; This is called from `after-change-functions' when
@@ -4131,7 +5104,7 @@ comment at the start of cc-engine.el for more info."
(< beg (setq beg (match-end 0))))
(while (progn (skip-chars-forward "^<>" beg)
(< (point) beg))
- (c-clear-char-property (point) 'syntax-table)
+ (c-clear-<>-pair-props)
(forward-char))))
(when (< beg end)
@@ -4146,9 +5119,13 @@ comment at the start of cc-engine.el for more info."
(< end (setq end (match-end 0))))
(while (progn (skip-chars-forward "^<>" end)
(< (point) end))
- (c-clear-char-property (point) 'syntax-table)
+ (c-clear-<>-pair-props)
(forward-char)))))))
+
+
+;; Handling of small scale constructs like types and names.
+
;; Dynamically bound variable that instructs `c-forward-type' to also
;; treat possible types (i.e. those that it normally returns 'maybe or
;; 'found for) as actual types (and always return 'found for them).
@@ -4393,6 +5370,9 @@ comment at the start of cc-engine.el for more info."
(goto-char safe-pos)
t)))
+;; cc-mode requires cc-fonts.
+(declare-function c-fontify-recorded-types-and-refs "cc-fonts" ())
+
(defun c-forward-<>-arglist (all-types)
;; The point is assumed to be at a "<". Try to treat it as the open
;; paren of an angle bracket arglist and move forward to the
@@ -4428,6 +5408,7 @@ comment at the start of cc-engine.el for more info."
;; `nconc' doesn't mind that the tail of
;; `c-record-found-types' is t.
(nconc c-record-found-types c-record-type-identifiers)))
+ (if (c-major-mode-is 'java-mode) (c-fontify-recorded-types-and-refs))
t)
(goto-char start)
@@ -4447,7 +5428,6 @@ comment at the start of cc-engine.el for more info."
;; List that collects the positions after the argument
;; separating ',' in the arglist.
arg-start-pos)
-
;; If the '<' has paren open syntax then we've marked it as an angle
;; bracket arglist before, so skip to the end.
(if (and (not c-parse-and-markup-<>-arglists)
@@ -4458,7 +5438,6 @@ comment at the start of cc-engine.el for more info."
(if (and (c-go-up-list-forward)
(eq (char-before) ?>))
t
-
;; Got unmatched paren angle brackets. We don't clear the paren
;; syntax properties and retry, on the basis that it's very
;; unlikely that paren angle brackets become operators by code
@@ -4468,67 +5447,46 @@ comment at the start of cc-engine.el for more info."
nil))
(forward-char)
+
(unless (looking-at c-<-op-cont-regexp)
(while (and
(progn
-
- (when c-record-type-identifiers
- (if all-types
-
- ;; All encountered identifiers are types, so set the
- ;; promote flag and parse the type.
- (progn
- (c-forward-syntactic-ws)
+ (c-forward-syntactic-ws)
+ (let ((orig-record-found-types c-record-found-types))
+ (when (or (and c-record-type-identifiers all-types)
+ (c-major-mode-is 'java-mode))
+ ;; All encountered identifiers are types, so set the
+ ;; promote flag and parse the type.
+ (progn
+ (c-forward-syntactic-ws)
+ (if (looking-at "\\?")
+ (forward-char)
(when (looking-at c-identifier-start)
- (let ((c-promote-possible-types t))
+ (let ((c-promote-possible-types t)
+ (c-record-found-types t))
(c-forward-type))))
- ;; Check if this arglist argument is a sole type. If
- ;; it's known then it's recorded in
- ;; `c-record-type-identifiers'. If it only is found
- ;; then it's recorded in `c-record-found-types' which we
- ;; might roll back if it turns out that this isn't an
- ;; angle bracket arglist afterall.
- (when (memq (char-before) '(?, ?<))
- (let ((orig-record-found-types c-record-found-types))
+ (c-forward-syntactic-ws)
+
+ (when (or (looking-at "extends")
+ (looking-at "super"))
+ (forward-word)
(c-forward-syntactic-ws)
- (and (memq (c-forward-type) '(known found))
- (not (looking-at "[,>]"))
- ;; A found type was recorded but it's not the
- ;; only thing in the arglist argument, so reset
- ;; `c-record-found-types'.
- (setq c-record-found-types
- orig-record-found-types))))))
+ (let ((c-promote-possible-types t)
+ (c-record-found-types t))
+ (c-forward-type)
+ (c-forward-syntactic-ws))))))
(setq pos (point))
- (or (when (eq (char-after) ?>)
- ;; Must check for '>' at the very start separately,
- ;; since the regexp below has to avoid ">>" without
- ;; using \\=.
- (forward-char)
- t)
-
- ;; Note: These regexps exploit the match order in \| so
- ;; that "<>" is matched by "<" rather than "[^>:-]>".
- (c-syntactic-re-search-forward
- (if c-restricted-<>-arglists
- ;; Stop on ',', '|', '&', '+' and '-' to catch
- ;; common binary operators that could be between
- ;; two comparison expressions "a<b" and "c>d".
- "[<;{},|&+-]\\|\\([^>:-]>\\)"
- ;; Otherwise we still stop on ',' to find the
- ;; argument start positions.
- "[<;{},]\\|\\([^>:-]>\\)")
- nil 'move t t 1)
-
- ;; If the arglist starter has lost its open paren
- ;; syntax but not the closer, we won't find the
- ;; closer above since we only search in the
- ;; balanced sexp. In that case we stop just short
- ;; of it so check if the following char is the closer.
- (when (eq (char-after) ?>)
- (forward-char)
- t)))
+
+ ;; Note: These regexps exploit the match order in \| so
+ ;; that "<>" is matched by "<" rather than "[^>:-]>".
+ (c-syntactic-re-search-forward
+ ;; Stop on ',', '|', '&', '+' and '-' to catch
+ ;; common binary operators that could be between
+ ;; two comparison expressions "a<b" and "c>d".
+ "[<;{},|+&-]\\|[>)]"
+ nil t t))
(cond
((eq (char-before) ?>)
@@ -4553,7 +5511,6 @@ comment at the start of cc-engine.el for more info."
((eq (char-before) ?<)
;; Either an operator starting with '<' or a nested arglist.
-
(setq pos (point))
(let (id-start id-end subres keyword-match)
(if (if (looking-at c-<-op-cont-regexp)
@@ -4576,8 +5533,8 @@ comment at the start of cc-engine.el for more info."
(setq id-start (point))))
(setq subres
- (let ((c-record-type-identifiers nil)
- (c-record-found-types nil))
+ (let ((c-promote-possible-types t)
+ (c-record-found-types t))
(c-forward-<>-arglist-recur
(and keyword-match
(c-keyword-member
@@ -4604,9 +5561,11 @@ comment at the start of cc-engine.el for more info."
(c-record-type-id (cons id-start id-end))))))
t)
- ((and (eq (char-before) ?,)
- (not c-restricted-<>-arglists))
- ;; Just another argument. Record the position. The
+ ((and (not c-restricted-<>-arglists)
+ (or (and (eq (char-before) ?&)
+ (not (eq (char-after) ?&)))
+ (eq (char-before) ?,)))
+ ;; Just another argument. Record the position. The
;; type check stuff that made us stop at it is at
;; the top of the loop.
(setq arg-start-pos (cons (point) arg-start-pos)))
@@ -4617,7 +5576,6 @@ comment at the start of cc-engine.el for more info."
;; it's useless to try to find a surrounding arglist
;; if we're nested.
(throw 'angle-bracket-arglist-escape nil))))))
-
(if res
(or c-record-found-types t)))))
@@ -4688,17 +5646,23 @@ comment at the start of cc-engine.el for more info."
(defun c-forward-name ()
;; Move forward over a complete name if at the beginning of one,
- ;; stopping at the next following token. If the point is not at
- ;; something that are recognized as name then it stays put. A name
- ;; could be something as simple as "foo" in C or something as
+ ;; stopping at the next following token. A keyword, as such,
+ ;; doesn't count as a name. If the point is not at something that
+ ;; is recognized as a name then it stays put.
+ ;;
+ ;; A name could be something as simple as "foo" in C or something as
;; complex as "X<Y<class A<int>::B, BIT_MAX >> b>, ::operator<> ::
;; Z<(a>b)> :: operator const X<&foo>::T Q::G<unsigned short
;; int>::*volatile const" in C++ (this function is actually little
;; more than a `looking-at' call in all modes except those that,
- ;; like C++, have `c-recognize-<>-arglists' set). Return nil if no
- ;; name is found, 'template if it's an identifier ending with an
- ;; angle bracket arglist, 'operator of it's an operator identifier,
- ;; or t if it's some other kind of name.
+ ;; like C++, have `c-recognize-<>-arglists' set).
+ ;;
+ ;; Return
+ ;; o - nil if no name is found;
+ ;; o - 'template if it's an identifier ending with an angle bracket
+ ;; arglist;
+ ;; o - 'operator of it's an operator identifier;
+ ;; o - t if it's some other kind of name.
;;
;; This function records identifier ranges on
;; `c-record-type-identifiers' and `c-record-ref-identifiers' if
@@ -4820,9 +5784,8 @@ comment at the start of cc-engine.el for more info."
((and c-recognize-<>-arglists
(eq (char-after) ?<))
;; Maybe an angle bracket arglist.
-
- (when (let (c-record-type-identifiers
- c-record-found-types)
+ (when (let ((c-record-type-identifiers t)
+ (c-record-found-types t))
(c-forward-<>-arglist nil))
(c-add-type start (1+ pos))
@@ -4851,16 +5814,28 @@ comment at the start of cc-engine.el for more info."
(goto-char pos)
res))
-(defun c-forward-type ()
+(defun c-forward-type (&optional brace-block-too)
;; Move forward over a type spec if at the beginning of one,
- ;; stopping at the next following token. Return t if it's a known
- ;; type that can't be a name or other expression, 'known if it's an
- ;; otherwise known type (according to `*-font-lock-extra-types'),
- ;; 'prefix if it's a known prefix of a type, 'found if it's a type
- ;; that matches one in `c-found-types', 'maybe if it's an identfier
- ;; that might be a type, or nil if it can't be a type (the point
- ;; isn't moved then). The point is assumed to be at the beginning
- ;; of a token.
+ ;; stopping at the next following token. The keyword "typedef"
+ ;; isn't part of a type spec here.
+ ;;
+ ;; BRACE-BLOCK-TOO, when non-nil, means move over the brace block in
+ ;; constructs like "struct foo {...} bar ;" or "struct {...} bar;".
+ ;; The current (2009-03-10) intention is to convert all uses of
+ ;; `c-forward-type' to call with this parameter set, then to
+ ;; eliminate it.
+ ;;
+ ;; Return
+ ;; o - t if it's a known type that can't be a name or other
+ ;; expression;
+ ;; o - 'known if it's an otherwise known type (according to
+ ;; `*-font-lock-extra-types');
+ ;; o - 'prefix if it's a known prefix of a type;
+ ;; o - 'found if it's a type that matches one in `c-found-types';
+ ;; o - 'maybe if it's an identfier that might be a type; or
+ ;; o - nil if it can't be a type (the point isn't moved then).
+ ;;
+ ;; The point is assumed to be at the beginning of a token.
;;
;; Note that this function doesn't skip past the brace definition
;; that might be considered part of the type, e.g.
@@ -4871,37 +5846,47 @@ comment at the start of cc-engine.el for more info."
;; `c-record-type-identifiers' is non-nil.
;;
;; This function might do hidden buffer changes.
+ (when (looking-at "<")
+ (c-forward-<>-arglist t)
+ (c-forward-syntactic-ws))
(let ((start (point)) pos res name-res id-start id-end id-range)
;; Skip leading type modifiers. If any are found we know it's a
;; prefix of a type.
- (when c-opt-type-modifier-key
+ (when c-opt-type-modifier-key ; e.g. "const" "volatile", but NOT "typedef"
(while (looking-at c-opt-type-modifier-key)
(goto-char (match-end 1))
(c-forward-syntactic-ws)
(setq res 'prefix)))
(cond
- ((looking-at c-type-prefix-key)
- ;; Looking at a keyword that prefixes a type identifier,
- ;; e.g. "class".
+ ((looking-at c-type-prefix-key) ; e.g. "struct", "class", but NOT
+ ; "typedef".
(goto-char (match-end 1))
(c-forward-syntactic-ws)
(setq pos (point))
- (if (memq (setq name-res (c-forward-name)) '(t template))
- (progn
- (when (eq name-res t)
- ;; In many languages the name can be used without the
- ;; prefix, so we add it to `c-found-types'.
- (c-add-type pos (point))
- (when (and c-record-type-identifiers
- c-last-identifier-range)
- (c-record-type-id c-last-identifier-range)))
- (setq res t))
- ;; Invalid syntax.
- (goto-char start)
- (setq res nil)))
+
+ (setq name-res (c-forward-name))
+ (setq res (not (null name-res)))
+ (when (eq name-res t)
+ ;; In many languages the name can be used without the
+ ;; prefix, so we add it to `c-found-types'.
+ (c-add-type pos (point))
+ (when (and c-record-type-identifiers
+ c-last-identifier-range)
+ (c-record-type-id c-last-identifier-range)))
+ (when (and brace-block-too
+ (memq res '(t nil))
+ (eq (char-after) ?\{)
+ (save-excursion
+ (c-safe
+ (progn (c-forward-sexp)
+ (c-forward-syntactic-ws)
+ (setq pos (point))))))
+ (goto-char pos)
+ (setq res t))
+ (unless res (goto-char start))) ; invalid syntax
((progn
(setq pos nil)
@@ -4991,14 +5976,13 @@ comment at the start of cc-engine.el for more info."
(setq res nil)))))
(when res
- ;; Skip trailing type modifiers. If any are found we know it's
+ ;; Skip trailing type modifiers. If any are found we know it's
;; a type.
(when c-opt-type-modifier-key
- (while (looking-at c-opt-type-modifier-key)
+ (while (looking-at c-opt-type-modifier-key) ; e.g. "const", "volatile"
(goto-char (match-end 1))
(c-forward-syntactic-ws)
(setq res t)))
-
;; Step over any type suffix operator. Do not let the existence
;; of these alter the classification of the found type, since
;; these operators typically are allowed in normal expressions
@@ -5008,7 +5992,7 @@ comment at the start of cc-engine.el for more info."
(goto-char (match-end 1))
(c-forward-syntactic-ws)))
- (when c-opt-type-concat-key
+ (when c-opt-type-concat-key ; Only/mainly for pike.
;; Look for a trailing operator that concatenates the type
;; with a following one, and if so step past that one through
;; a recursive call. Note that we don't record concatenated
@@ -5070,6 +6054,18 @@ comment at the start of cc-engine.el for more info."
res))
+(defun c-forward-annotation ()
+ ;; Used for Java code only at the moment. Assumes point is on the
+ ;; @, moves forward an annotation. returns nil if there is no
+ ;; annotation at point.
+ (and (looking-at "@")
+ (progn (forward-char) t)
+ (c-forward-type)
+ (progn (c-forward-syntactic-ws) t)
+ (if (looking-at "(")
+ (c-go-list-forward)
+ t)))
+
;; Handling of large scale constructs like statements and declarations.
@@ -5147,11 +6143,15 @@ comment at the start of cc-engine.el for more info."
;; car ^ ^ point
;; Foo::Foo (int b) : Base (b) {}
;; car ^ ^ point
- ;;
- ;; The cdr of the return value is non-nil iff a `c-typedef-decl-kwds'
- ;; specifier (e.g. class, struct, enum, typedef) is found in the
- ;; declaration, i.e. the declared identifier(s) are types.
- ;;
+ ;;
+ ;; The cdr of the return value is non-nil when a
+ ;; `c-typedef-decl-kwds' specifier is found in the declaration.
+ ;; Specifically it is a dotted pair (A . B) where B is t when a
+ ;; `c-typedef-kwds' ("typedef") is present, and A is t when some
+ ;; other `c-typedef-decl-kwds' (e.g. class, struct, enum)
+ ;; specifier is present. I.e., (some of) the declared
+ ;; identifier(s) are types.
+ ;;
;; If a cast is parsed:
;;
;; The point is left at the first token after the closing paren of
@@ -5209,9 +6209,11 @@ comment at the start of cc-engine.el for more info."
;; If `backup-at-type' is nil then the other variables have
;; undefined values.
backup-at-type backup-type-start backup-id-start
- ;; Set if we've found a specifier that makes the defined
- ;; identifier(s) types.
+ ;; Set if we've found a specifier (apart from "typedef") that makes
+ ;; the defined identifier(s) types.
at-type-decl
+ ;; Set if we've a "typedef" keyword.
+ at-typedef
;; Set if we've found a specifier that can start a declaration
;; where there's no type.
maybe-typeless
@@ -5239,6 +6241,9 @@ comment at the start of cc-engine.el for more info."
(save-rec-type-ids c-record-type-identifiers)
(save-rec-ref-ids c-record-ref-identifiers))
+ (while (c-forward-annotation)
+ (c-forward-syntactic-ws))
+
;; Check for a type. Unknown symbols are treated as possible
;; types, but they could also be specifiers disguised through
;; macros like __INLINE__, so we recognize both types and known
@@ -5248,12 +6253,14 @@ comment at the start of cc-engine.el for more info."
;; Look for a specifier keyword clause.
(when (looking-at c-prefix-spec-kwds-re)
+ (if (looking-at c-typedef-key)
+ (setq at-typedef t))
(setq kwd-sym (c-keyword-sym (match-string 1)))
(save-excursion
(c-forward-keyword-clause 1)
(setq kwd-clause-end (point))))
- (when (setq found-type (c-forward-type))
+ (when (setq found-type (c-forward-type t)) ; brace-block-too
;; Found a known or possible type or a prefix of a known type.
(when at-type
@@ -5318,6 +6325,8 @@ comment at the start of cc-engine.el for more info."
(setq backup-maybe-typeless t)))
(when (c-keyword-member kwd-sym 'c-typedef-decl-kwds)
+ ;; This test only happens after we've scanned a type.
+ ;; So, with valid syntax, kwd-sym can't be 'typedef.
(setq at-type-decl t))
(when (c-keyword-member kwd-sym 'c-typeless-decl-kwds)
(setq maybe-typeless t))
@@ -5572,13 +6581,14 @@ comment at the start of cc-engine.el for more info."
;; CASE 3
(when (= (point) start)
;; Got a plain list of identifiers. If a colon follows it's
- ;; a valid label. Otherwise the last one probably is the
- ;; declared identifier and we should back up to the previous
- ;; type, providing it isn't a cast.
- (if (eq (char-after) ?:)
- ;; If we've found a specifier keyword then it's a
- ;; declaration regardless.
- (throw 'at-decl-or-cast (eq at-decl-or-cast t))
+ ;; a valid label. Otherwise the last one probably is the
+ ;; declared identifier and we should back up to the previous
+ ;; type, providing it isn't a cast.
+ (if (and (eq (char-after) ?:)
+ (not (c-major-mode-is 'java-mode)))
+ ;; If we've found a specifier keyword then it's a
+ ;; declaration regardless.
+ (throw 'at-decl-or-cast (eq at-decl-or-cast t))
(setq backup-if-not-cast t)
(throw 'at-decl-or-cast t)))
@@ -5916,7 +6926,9 @@ comment at the start of cc-engine.el for more info."
(goto-char type-start)
(c-forward-type))))
- (cons id-start at-type-decl))
+ (cons id-start
+ (and (or at-type-decl at-typedef)
+ (cons at-type-decl at-typedef))))
(t
;; False alarm. Restore the recorded ranges.
@@ -7539,7 +8551,7 @@ comment at the start of cc-engine.el for more info."
;;
;; This function might do hidden buffer changes.
- (let (special-brace-list)
+ (let (special-brace-list placeholder)
(goto-char indent-point)
(skip-chars-forward " \t")
@@ -7646,6 +8658,22 @@ comment at the start of cc-engine.el for more info."
(c-add-stmt-syntax 'func-decl-cont nil t
containing-sexp paren-state))
+ ;;CASE F: continued statement and the only preceding items are
+ ;;annotations.
+ ((and (c-major-mode-is 'java-mode)
+ (setq placeholder (point))
+ (c-beginning-of-statement-1)
+ (progn
+ (while (and (c-forward-annotation)
+ (< (point) placeholder))
+ (c-forward-syntactic-ws))
+ t)
+ (prog1
+ (>= (point) placeholder)
+ (goto-char placeholder)))
+ (c-beginning-of-statement-1 containing-sexp)
+ (c-add-syntax 'annotation-var-cont (point)))
+
;; CASE D: continued statement.
(t
(c-beginning-of-statement-1 containing-sexp)
@@ -7745,7 +8773,6 @@ comment at the start of cc-engine.el for more info."
(when (and containing-sexp
(eq (char-after containing-sexp) ?\())
(setq c-stmt-delim-chars c-stmt-delim-chars-with-comma))
-
;; cache char before and after indent point, and move point to
;; the most likely position to perform the majority of tests
(goto-char indent-point)
@@ -8495,23 +9522,36 @@ comment at the start of cc-engine.el for more info."
(c-add-syntax 'objc-method-args-cont placeholder))
;; CASE 5L: we are at the first argument of a template
- ;; arglist that begins on the previous line.
- ((and c-recognize-<>-arglists
- (eq (char-before) ?<)
- (setq placeholder (1- (point)))
- (not (and c-overloadable-operators-regexp
- (c-after-special-operator-id lim))))
- (c-beginning-of-statement-1 (c-safe-position (point) paren-state))
- (c-add-syntax 'template-args-cont (c-point 'boi) placeholder))
-
- ;; CASE 5Q: we are at a statement within a macro.
- (macro-start
- (c-beginning-of-statement-1 containing-sexp)
- (c-add-stmt-syntax 'statement nil t containing-sexp paren-state))
-
- ;; CASE 5M: we are at a topmost continuation line
- (t
- (c-beginning-of-statement-1 (c-safe-position (point) paren-state))
+ ;; arglist that begins on the previous line.
+ ((and c-recognize-<>-arglists
+ (eq (char-before) ?<)
+ (not (and c-overloadable-operators-regexp
+ (c-after-special-operator-id lim))))
+ (c-beginning-of-statement-1 (c-safe-position (point) paren-state))
+ (c-add-syntax 'template-args-cont (c-point 'boi)))
+
+ ;; CASE 5Q: we are at a statement within a macro.
+ (macro-start
+ (c-beginning-of-statement-1 containing-sexp)
+ (c-add-stmt-syntax 'statement nil t containing-sexp paren-state))
+
+ ;;CASE 5N: We are at a tompmost continuation line and the only
+ ;;preceding items are annotations.
+ ((and (c-major-mode-is 'java-mode)
+ (setq placeholder (point))
+ (c-beginning-of-statement-1)
+ (progn
+ (while (and (c-forward-annotation))
+ (c-forward-syntactic-ws))
+ t)
+ (prog1
+ (>= (point) placeholder)
+ (goto-char placeholder)))
+ (c-add-syntax 'annotation-top-cont (c-point 'boi)))
+
+ ;; CASE 5M: we are at a topmost continuation line
+ (t
+ (c-beginning-of-statement-1 (c-safe-position (point) paren-state))
(when (c-major-mode-is 'objc-mode)
(setq placeholder (point))
(while (and (c-forward-objc-directive)
@@ -8522,43 +9562,20 @@ comment at the start of cc-engine.el for more info."
(c-add-syntax 'topmost-intro-cont (c-point 'boi)))
))
- ;; (CASE 6 has been removed.)
- ;; CASE 19: line is an expression, not a statement, and is directly
- ;; contained by a template delimiter. Most likely, we are in a
- ;; template arglist within a statement. This case is based on CASE
- ;; 7. At some point in the future, we may wish to create more
- ;; syntactic symbols such as `template-intro',
- ;; `template-cont-nonempty', etc., and distinguish between them as we
- ;; do for `arglist-intro' etc. (2009-12-07).
- ((and c-recognize-<>-arglists
- (setq containing-< (c-up-list-backward indent-point containing-sexp))
- (eq (char-after containing-<) ?\<))
- (setq placeholder (c-point 'boi containing-<))
- (goto-char containing-sexp) ; Most nested Lbrace/Lparen (but not
- ; '<') before indent-point.
- (if (>= (point) placeholder)
- (progn
- (forward-char)
- (skip-chars-forward " \t"))
- (goto-char placeholder))
- (c-add-stmt-syntax 'template-args-cont (list containing-<) t
- (c-most-enclosing-brace c-state-cache (point))
- paren-state))
-
+ ;; (CASE 6 has been removed.)
- ;; CASE 7: line is an expression, not a statement. Most
- ;; likely we are either in a function prototype or a function
- ;; call argument list, or a template argument list.
- ((not (or (and c-special-brace-lists
- (save-excursion
- (goto-char containing-sexp)
- (c-looking-at-special-brace-list)))
- (eq (char-after containing-sexp) ?{)
- (eq (char-after containing-sexp) ?<)))
- (cond
+ ;; CASE 7: line is an expression, not a statement. Most
+ ;; likely we are either in a function prototype or a function
+ ;; call argument list
+ ((not (or (and c-special-brace-lists
+ (save-excursion
+ (goto-char containing-sexp)
+ (c-looking-at-special-brace-list)))
+ (eq (char-after containing-sexp) ?{)))
+ (cond
- ;; CASE 7A: we are looking at the arglist closing paren.
+ ;; CASE 7A: we are looking at the arglist closing paren.
;; C.f. case 7F.
((memq char-after-ip '(?\) ?\]))
(goto-char containing-sexp)
@@ -8570,12 +9587,34 @@ comment at the start of cc-engine.el for more info."
(skip-chars-forward " \t"))
(goto-char placeholder))
(c-add-stmt-syntax 'arglist-close (list containing-sexp) t
- (c-most-enclosing-brace paren-state (point))
- paren-state))
+ (c-most-enclosing-brace paren-state (point))
+ paren-state))
- ;; CASE 7B: Looking at the opening brace of an
- ;; in-expression block or brace list. C.f. cases 4, 16A
- ;; and 17E.
+ ;; CASE 19: line is an expression, not a statement, and is directly
+ ;; contained by a template delimiter. Most likely, we are in a
+ ;; template arglist within a statement. This case is based on CASE
+ ;; 7. At some point in the future, we may wish to create more
+ ;; syntactic symbols such as `template-intro',
+ ;; `template-cont-nonempty', etc., and distinguish between them as we
+ ;; do for `arglist-intro' etc. (2009-12-07).
+ ((and c-recognize-<>-arglists
+ (setq containing-< (c-up-list-backward indent-point containing-sexp))
+ (eq (char-after containing-<) ?\<))
+ (setq placeholder (c-point 'boi containing-<))
+ (goto-char containing-sexp) ; Most nested Lbrace/Lparen (but not
+ ; '<') before indent-point.
+ (if (>= (point) placeholder)
+ (progn
+ (forward-char)
+ (skip-chars-forward " \t"))
+ (goto-char placeholder))
+ (c-add-stmt-syntax 'template-args-cont (list containing-<) t
+ (c-most-enclosing-brace c-state-cache (point))
+ paren-state))
+
+ ;; CASE 7B: Looking at the opening brace of an
+ ;; in-expression block or brace list. C.f. cases 4, 16A
+ ;; and 17E.
((and (eq char-after-ip ?{)
(progn
(setq placeholder (c-inside-bracelist-p (point)
diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el
index 80783670f66..d2e5657d34a 100644
--- a/lisp/progmodes/cc-fonts.el
+++ b/lisp/progmodes/cc-fonts.el
@@ -6,8 +6,8 @@
;; 2002- Martin Stjernholm
;; Maintainer: bug-cc-mode@gnu.org
;; Created: 07-Jan-2002
-;; Version: See cc-mode.el
-;; Keywords: c languages oop
+;; Keywords: c languages
+;; Package: cc-mode
;; This file is part of GNU Emacs.
@@ -194,6 +194,10 @@
(unless (face-property-instance oldface 'reverse)
(invert-face newface)))))
+(defvar c-annotation-face (make-face 'c-annotation-face)
+ "Face used to highlight annotations in java-mode and other modes that may wish to use it.")
+(set-face-foreground 'c-annotation-face "blue")
+
(eval-and-compile
;; We need the following functions during compilation since they're
;; called when the `c-lang-defconst' initializers are evaluated.
@@ -285,7 +289,7 @@
;; bit of the overhead compared to a real matcher. The main reason
;; is however to pass the real search limit to the anchored
;; matcher(s), since most (if not all) font-lock implementations
- ;; arbitrarily limits anchored matchers to the same line, and also
+ ;; arbitrarily limit anchored matchers to the same line, and also
;; to insulate against various other irritating differences between
;; the different (X)Emacs font-lock packages.
;;
@@ -306,7 +310,7 @@
;; covered by the font-lock context.)
;; Note: Replace `byte-compile' with `eval' to debug the generated
- ;; lambda easier.
+ ;; lambda more easily.
(byte-compile
`(lambda (limit)
(let (;; The font-lock package in Emacs is known to clobber
@@ -426,7 +430,8 @@ stuff. Used on level 1 and higher."
(progn
(c-mark-<-as-paren beg)
(c-mark->-as-paren end))
- (c-clear-char-property beg 'syntax-table)))
+ ;; (c-clear-char-property beg 'syntax-table)
+ (c-clear-char-property beg 'category)))
nil)))))))
;; #define.
@@ -716,16 +721,26 @@ casts and declarations are fontified. Used on level 2 and higher."
;; Clear the list of found types if we start from the start of the
;; buffer, to make it easier to get rid of misspelled types and
- ;; variables that has gotten recognized as types in malformed code.
+ ;; variables that have gotten recognized as types in malformed code.
(when (bobp)
(c-clear-found-types))
- ;; Clear the c-type char properties in the region to recalculate
- ;; them properly. This is necessary e.g. to handle constructs that
- ;; might been required as declarations temporarily during editing.
- ;; The interesting properties are anyway those put on the closest
- ;; token before the region.
- (c-clear-char-properties (point) limit 'c-type)
+ ;; Clear the c-type char properties which mark the region, to recalculate
+ ;; them properly. The most interesting properties are those put on the
+ ;; closest token before the region.
+ (save-excursion
+ (let ((pos (point)))
+ (c-backward-syntactic-ws)
+ (c-clear-char-properties
+ (if (and (not (bobp))
+ (memq (c-get-char-property (1- (point)) 'c-type)
+ '(c-decl-arg-start
+ c-decl-end
+ c-decl-id-start
+ c-decl-type-start)))
+ (1- (point))
+ pos)
+ limit 'c-type)))
;; Update `c-state-cache' to the beginning of the region. This will
;; make `c-beginning-of-syntax' go faster when it's used later on,
@@ -734,6 +749,8 @@ casts and declarations are fontified. Used on level 2 and higher."
;; Check if the fontified region starts inside a declarator list so
;; that `c-font-lock-declarators' should be called at the start.
+ ;; The declared identifiers are font-locked correctly as types, if
+ ;; that is what they are.
(let ((prop (save-excursion
(c-backward-syntactic-ws)
(unless (bobp)
@@ -826,12 +843,19 @@ casts and declarations are fontified. Used on level 2 and higher."
nil)
(defun c-font-lock-declarators (limit list types)
- ;; Assuming the point is at the start of a declarator in a
- ;; declaration, fontify it. If LIST is non-nil, fontify also all
- ;; following declarators in a comma separated list (e.g. "foo" and
- ;; "bar" in "int foo = 17, bar;"). Stop at LIMIT. If TYPES is
- ;; non-nil, fontify all identifiers as types. Nil is always
- ;; returned.
+ ;; Assuming the point is at the start of a declarator in a declaration,
+ ;; fontify the identifier it declares. (If TYPES is set, it does this via
+ ;; the macro `c-fontify-types-and-refs'.)
+ ;;
+ ;; If LIST is non-nil, also fontify the ids in any following declarators in
+ ;; a comma separated list (e.g. "foo" and "*bar" in "int foo = 17, *bar;");
+ ;; additionally, mark the commas with c-type property 'c-decl-id-start or
+ ;; 'c-decl-type-start (according to TYPES). Stop at LIMIT.
+ ;;
+ ;; If TYPES is non-nil, fontify all identifiers as types.
+ ;;
+ ;; Nil is always returned. The function leaves point at the delimiter after
+ ;; the last declarator it processes.
;;
;; This function might do hidden buffer changes.
@@ -843,18 +867,31 @@ casts and declarations are fontified. Used on level 2 and higher."
c-last-identifier-range
(separator-prop (if types 'c-decl-type-start 'c-decl-id-start)))
- (while (and
+ ;; The following `while' fontifies a single declarator id each time round.
+ ;; It loops only when LIST is non-nil.
+ (while
+ ;; Inside the following "condition form", we move forward over the
+ ;; declarator's identifier up as far as any opening bracket (for array
+ ;; size) or paren (for parameters of function-type) or brace (for
+ ;; array/struct initialisation) or "=" or terminating delimiter
+ ;; (e.g. "," or ";" or "}").
+ (and
pos
(< (point) limit)
+ ;; The following form moves forward over the declarator's
+ ;; identifier (and what precedes it), returning t. If there
+ ;; wasn't one, it returns nil, terminating the `while'.
(let (got-identifier)
(setq paren-depth 0)
- ;; Skip over type decl prefix operators. (Note similar
- ;; code in `c-forward-decl-or-cast-1'.)
+ ;; Skip over type decl prefix operators, one for each iteration
+ ;; of the while. These are, e.g. "*" in "int *foo" or "(" and
+ ;; "*" in "int (*foo) (void)" (Note similar code in
+ ;; `c-forward-decl-or-cast-1'.)
(while (and (looking-at c-type-decl-prefix-key)
(if (and (c-major-mode-is 'c++-mode)
- (match-beginning 2))
- ;; If the second submatch matches in C++ then
+ (match-beginning 3))
+ ;; If the third submatch matches in C++ then
;; we're looking at an identifier that's a
;; prefix only if it specifies a member pointer.
(progn
@@ -877,7 +914,7 @@ casts and declarations are fontified. Used on level 2 and higher."
(goto-char (match-end 1)))
(c-forward-syntactic-ws))
- ;; If we didn't pass the identifier above already, do it now.
+ ;; If we haven't passed the identifier already, do it now.
(unless got-identifier
(setq id-start (point))
(c-forward-name))
@@ -885,12 +922,14 @@ casts and declarations are fontified. Used on level 2 and higher."
(/= id-end pos))
- ;; Skip out of the parens surrounding the identifier.
+ ;; Skip out of the parens surrounding the identifier. If closing
+ ;; parens are missing, this form returns nil.
(or (= paren-depth 0)
(c-safe (goto-char (scan-lists (point) 1 paren-depth))))
(<= (point) limit)
+ ;; Skip over any trailing bit, such as "__attribute__".
(progn
(when (looking-at c-decl-hangon-key)
(c-forward-keyword-clause 1))
@@ -931,7 +970,7 @@ casts and declarations are fontified. Used on level 2 and higher."
id-face)))
(goto-char next-pos)
- (setq pos nil)
+ (setq pos nil) ; So as to terminate the enclosing `while' form.
(when list
;; Jump past any initializer or function prototype to see if
;; there's a ',' to continue at.
@@ -939,11 +978,11 @@ casts and declarations are fontified. Used on level 2 and higher."
(cond ((eq id-face 'font-lock-function-name-face)
;; Skip a parenthesized initializer (C++) or a function
;; prototype.
- (if (c-safe (c-forward-sexp 1) t)
+ (if (c-safe (c-forward-sexp 1) t) ; over the parameter list.
(c-forward-syntactic-ws limit)
- (goto-char limit)))
+ (goto-char limit))) ; unbalanced parens
- (got-init
+ (got-init ; "=" sign OR opening "(", "[", or "{"
;; Skip an initializer expression. If we're at a '='
;; then accept a brace list directly after it to cope
;; with array initializers. Otherwise stop at braces
@@ -951,7 +990,7 @@ casts and declarations are fontified. Used on level 2 and higher."
(and (if (and (eq got-init ?=)
(= (c-forward-token-2 1 nil limit) 0)
(looking-at "{"))
- (c-safe (c-forward-sexp) t)
+ (c-safe (c-forward-sexp) t) ; over { .... }
t)
;; FIXME: Should look for c-decl-end markers here;
;; we might go far into the following declarations
@@ -966,7 +1005,7 @@ casts and declarations are fontified. Used on level 2 and higher."
(c-put-char-property (point) 'c-type separator-prop)
(forward-char)
(c-forward-syntactic-ws limit)
- (setq pos (point))))))
+ (setq pos (point)))))) ; acts to make the `while' form continue.
nil)
(defconst c-font-lock-maybe-decl-faces
@@ -979,31 +1018,39 @@ casts and declarations are fontified. Used on level 2 and higher."
font-lock-keyword-face))
(defun c-font-lock-declarations (limit)
+ ;; Fontify all the declarations, casts and labels from the point to LIMIT.
+ ;; Assumes that strings and comments have been fontified already.
+ ;;
;; This function will be called from font-lock for a region bounded by POINT
;; and LIMIT, as though it were to identify a keyword for
;; font-lock-keyword-face. It always returns NIL to inhibit this and
;; prevent a repeat invocation. See elisp/lispref page "Search-based
;; Fontification".
;;
- ;; Fontify all the declarations, casts and labels from the point to LIMIT.
- ;; Assumes that strings and comments have been fontified already.
- ;;
;; This function might do hidden buffer changes.
;;(message "c-font-lock-declarations search from %s to %s" (point) limit)
(save-restriction
- (let (;; The position where `c-find-decl-spots' stopped.
+ (let (;; The position where `c-find-decl-spots' last stopped.
start-pos
- ;; 'decl if we're in an arglist containing declarations (but
- ;; if `c-recognize-paren-inits' is set it might also be an
- ;; initializer arglist), '<> if the arglist is of angle
- ;; bracket type, 'arglist if it's some other arglist, or nil
- ;; if not in an arglist at all.
+ ;; o - 'decl if we're in an arglist containing declarations
+ ;; (but if `c-recognize-paren-inits' is set it might also be
+ ;; an initializer arglist);
+ ;; o - '<> if the arglist is of angle bracket type;
+ ;; o - 'arglist if it's some other arglist;
+ ;; o - nil, if not in an arglist at all. This includes the
+ ;; parenthesised condition which follows "if", "while", etc.
context
;; The position of the next token after the closing paren of
;; the last detected cast.
last-cast-end
+ ;; Start of containing declaration (if any); limit for searching
+ ;; backwards for it.
+ decl-start decl-search-lim
+ ;; Start of containing declaration (if any); limit for searching
+ ;; backwards for it.
+ decl-start decl-search-lim
;; The result from `c-forward-decl-or-cast-1'.
decl-or-cast
;; The maximum of the end positions of all the checked type
@@ -1077,57 +1124,115 @@ casts and declarations are fontified. Used on level 2 and higher."
;; can't start a declaration.
t
- ;; Set `context'. Look for "<" for the sake of C++-style template
- ;; arglists.
- (if (memq (char-before match-pos) '(?\( ?, ?\[ ?<))
-
- ;; Find out the type of the arglist.
- (if (<= match-pos (point-min))
- (setq context 'arglist)
- (let ((type (c-get-char-property (1- match-pos) 'c-type)))
- (cond ((eq type 'c-decl-arg-start)
- ;; Got a cached hit in a declaration arglist.
- (setq context 'decl))
- ((or (eq type 'c-<>-arg-sep)
- (eq (char-before match-pos) ?<))
- ;; Inside an angle bracket arglist.
- (setq context '<>))
- (type
- ;; Got a cached hit in some other type of arglist.
- (setq context 'arglist))
- ((if inside-macro
- (< match-pos max-type-decl-end-before-token)
- (< match-pos max-type-decl-end))
- ;; The point is within the range of a previously
- ;; encountered type decl expression, so the arglist
- ;; is probably one that contains declarations.
- ;; However, if `c-recognize-paren-inits' is set it
- ;; might also be an initializer arglist.
- (setq context 'decl)
- ;; The result of this check is cached with a char
- ;; property on the match token, so that we can look
- ;; it up again when refontifying single lines in a
- ;; multiline declaration.
- (c-put-char-property (1- match-pos)
- 'c-type 'c-decl-arg-start))
- (t
- (setq context 'arglist)))))
-
- (setq context nil))
-
- ;; If we're in a normal arglist context we don't want to
- ;; recognize commas in nested angle bracket arglists since
- ;; those commas could be part of our own arglist.
- (setq c-restricted-<>-arglists (and c-recognize-<>-arglists
- (eq context 'arglist))
-
- ;; Now analyze the construct.
- decl-or-cast (c-forward-decl-or-cast-1
+ ;; Set `context' and `c-restricted-<>-arglists'. Look for
+ ;; "<" for the sake of C++-style template arglists.
+ ;; Ignore "(" when it's part of a control flow construct
+ ;; (e.g. "for (").
+ (let ((type (and (> match-pos (point-min))
+ (c-get-char-property (1- match-pos) 'c-type))))
+ (cond ((not (memq (char-before match-pos) '(?\( ?, ?\[ ?<)))
+ (setq context nil
+ c-restricted-<>-arglists nil))
+ ;; A control flow expression
+ ((and (eq (char-before match-pos) ?\()
+ (save-excursion
+ (goto-char match-pos)
+ (backward-char)
+ (c-backward-token-2)
+ (looking-at c-block-stmt-2-key)))
+ (setq context nil
+ c-restricted-<>-arglists t))
+ ;; Near BOB.
+ ((<= match-pos (point-min))
+ (setq context 'arglist
+ c-restricted-<>-arglists t))
+ ;; Got a cached hit in a declaration arglist.
+ ((eq type 'c-decl-arg-start)
+ (setq context 'decl
+ c-restricted-<>-arglists nil))
+ ;; Inside an angle bracket arglist.
+ ((or (eq type 'c-<>-arg-sep)
+ (eq (char-before match-pos) ?<))
+ (setq context '<>
+ c-restricted-<>-arglists nil))
+ ;; Got a cached hit in some other type of arglist.
+ (type
+ (setq context 'arglist
+ c-restricted-<>-arglists t))
+ ((if inside-macro
+ (< match-pos max-type-decl-end-before-token)
+ (< match-pos max-type-decl-end))
+ ;; The point is within the range of a previously
+ ;; encountered type decl expression, so the arglist
+ ;; is probably one that contains declarations.
+ ;; However, if `c-recognize-paren-inits' is set it
+ ;; might also be an initializer arglist.
+ (setq context 'decl
+ c-restricted-<>-arglists nil)
+ ;; The result of this check is cached with a char
+ ;; property on the match token, so that we can look
+ ;; it up again when refontifying single lines in a
+ ;; multiline declaration.
+ (c-put-char-property (1- match-pos)
+ 'c-type 'c-decl-arg-start))
+ (t (setq context 'arglist
+ c-restricted-<>-arglists t))))
+
+ ;; Check we haven't missed a preceding "typedef".
+ (when (not (looking-at c-typedef-key))
+ (c-backward-syntactic-ws)
+ (c-backward-token-2)
+ (or (looking-at c-typedef-key)
+ (goto-char start-pos)))
+
+ ;; Now analyze the construct.
+ (setq decl-or-cast (c-forward-decl-or-cast-1
match-pos context last-cast-end))
(if (not decl-or-cast)
- ;; False alarm. Return t to go on to the next check.
- t
+ ;; Are we at a declarator? Try to go back to the declaration
+ ;; to check this. Note that `c-beginning-of-decl-1' is slow,
+ ;; so we cache its result between calls.
+ (let (paren-state bod-res encl-pos is-typedef)
+ (goto-char start-pos)
+ (save-excursion
+ (unless (and decl-search-lim
+ (eq decl-search-lim
+ (save-excursion
+ (c-syntactic-skip-backward "^;" nil t)
+ (point))))
+ (setq decl-search-lim
+ (and (c-syntactic-skip-backward "^;" nil t) (point)))
+ (setq bod-res (car (c-beginning-of-decl-1 decl-search-lim)))
+ (if (and (eq bod-res 'same)
+ (progn
+ (c-backward-syntactic-ws)
+ (eq (char-before) ?\})))
+ (c-beginning-of-decl-1 decl-search-lim))
+ (setq decl-start (point))))
+
+ (save-excursion
+ (goto-char decl-start)
+ ;; We're now putatively at the declaration.
+ (setq paren-state (c-parse-state))
+ ;; At top level or inside a "{"?
+ (if (or (not (setq encl-pos
+ (c-most-enclosing-brace paren-state)))
+ (eq (char-after encl-pos) ?\{))
+ (progn
+ (when (looking-at c-typedef-key) ; "typedef"
+ (setq is-typedef t)
+ (goto-char (match-end 0))
+ (c-forward-syntactic-ws))
+ ;; At a real declaration?
+ (if (memq (c-forward-type t) '(t known found))
+ (progn
+ (c-font-lock-declarators limit t is-typedef)
+ nil)
+ ;; False alarm. Return t to go on to the next check.
+ (goto-char start-pos)
+ t))
+ t)))
(if (eq decl-or-cast 'cast)
;; Save the position after the previous cast so we can feed
@@ -1216,6 +1321,40 @@ casts and declarations are fontified. Used on level 2 and higher."
nil)))
+(defun c-font-lock-enum-tail (limit)
+ ;; Fontify an enum's identifiers when POINT is within the enum's brace
+ ;; block.
+ ;;
+ ;; This function will be called from font-lock for a region bounded by POINT
+ ;; and LIMIT, as though it were to identify a keyword for
+ ;; font-lock-keyword-face. It always returns NIL to inhibit this and
+ ;; prevent a repeat invocation. See elisp/lispref page "Search-based
+ ;; Fontification".
+ ;;
+ ;; Note that this function won't attempt to fontify beyond the end of the
+ ;; current enum block, if any.
+ (let* ((paren-state (c-parse-state))
+ (encl-pos (c-most-enclosing-brace paren-state))
+ (start (point))
+ )
+ (when (and
+ encl-pos
+ (eq (char-after encl-pos) ?\{)
+ (save-excursion
+ (goto-char encl-pos)
+ (c-backward-syntactic-ws)
+ (c-simple-skip-symbol-backward)
+ (or (looking-at c-brace-list-key) ; "enum"
+ (progn (c-backward-syntactic-ws)
+ (c-simple-skip-symbol-backward)
+ (looking-at c-brace-list-key)))))
+ (c-syntactic-skip-backward "^{," nil t)
+ (c-put-char-property (1- (point)) 'c-type 'c-decl-id-start)
+
+ (c-forward-syntactic-ws)
+ (c-font-lock-declarators limit t nil)))
+ nil)
+
(c-lang-defconst c-simple-decl-matchers
"Simple font lock matchers for types and declarations. These are used
on level 2 only and so aren't combined with `c-complex-decl-matchers'."
@@ -1291,7 +1430,7 @@ on level 2 only and so aren't combined with `c-complex-decl-matchers'."
"Complex font lock matchers for types and declarations. Used on level
3 and higher."
- ;; Note: This code in this form dumps a number of funtions into the
+ ;; Note: This code in this form dumps a number of functions into the
;; resulting constant, `c-matchers-3'. At run time, font lock will call
;; each of them as a "FUNCTION" (see Elisp page "Search-based
;; Fontification"). The font lock region is delimited by POINT and the
@@ -1343,7 +1482,7 @@ on level 2 only and so aren't combined with `c-complex-decl-matchers'."
`(,(concat "\\<\\(" re "\\)\\>")
1 'font-lock-type-face)))
- ;; Fontify types preceded by `c-type-prefix-kwds'.
+ ;; Fontify types preceded by `c-type-prefix-kwds' (e.g. "struct").
,@(when (c-lang-const c-type-prefix-kwds)
`((,(byte-compile
`(lambda (limit)
@@ -1391,23 +1530,25 @@ on level 2 only and so aren't combined with `c-complex-decl-matchers'."
;; override it if it turns out to be an new declaration, but
;; it will be wrong if it's an expression (see the test
;; decls-8.cc).
- ,@(when (c-lang-const c-opt-block-decls-with-vars-key)
- `((,(c-make-font-lock-search-function
- (concat "}"
- (c-lang-const c-single-line-syntactic-ws)
- "\\(" ; 1 + c-single-line-syntactic-ws-depth
- (c-lang-const c-type-decl-prefix-key)
- "\\|"
- (c-lang-const c-symbol-key)
- "\\)")
- `((c-font-lock-declarators limit t nil)
- (progn
- (c-put-char-property (match-beginning 0) 'c-type
- 'c-decl-id-start)
- (goto-char (match-beginning
- ,(1+ (c-lang-const
- c-single-line-syntactic-ws-depth)))))
- (goto-char (match-end 0)))))))
+;; ,@(when (c-lang-const c-opt-block-decls-with-vars-key)
+;; `((,(c-make-font-lock-search-function
+;; (concat "}"
+;; (c-lang-const c-single-line-syntactic-ws)
+;; "\\(" ; 1 + c-single-line-syntactic-ws-depth
+;; (c-lang-const c-type-decl-prefix-key)
+;; "\\|"
+;; (c-lang-const c-symbol-key)
+;; "\\)")
+;; `((c-font-lock-declarators limit t nil) ; That `nil' says use `font-lock-variable-name-face';
+;; ; `t' would mean `font-lock-function-name-face'.
+;; (progn
+;; (c-put-char-property (match-beginning 0) 'c-type
+;; 'c-decl-id-start)
+;; ; 'c-decl-type-start)
+;; (goto-char (match-beginning
+;; ,(1+ (c-lang-const
+;; c-single-line-syntactic-ws-depth)))))
+;; (goto-char (match-end 0)))))))
;; Fontify the type in C++ "new" expressions.
,@(when (c-major-mode-is 'c++-mode)
@@ -1478,11 +1619,14 @@ on level 2 only and so aren't combined with `c-complex-decl-matchers'."
generic casts and declarations are fontified. Used on level 2 and
higher."
- t `(;; Fontify the identifiers inside enum lists. (The enum type
+ t `(,@(when (c-lang-const c-brace-id-list-kwds)
+ ;; Fontify the remaining identifiers inside an enum list when we start
+ ;; inside it.
+ `(c-font-lock-enum-tail
+ ;; Fontify the identifiers inside enum lists. (The enum type
;; name is handled by `c-simple-decl-matchers' or
;; `c-complex-decl-matchers' below.
- ,@(when (c-lang-const c-brace-id-list-kwds)
- `((,(c-make-font-lock-search-function
+ (,(c-make-font-lock-search-function
(concat
"\\<\\("
(c-make-keywords-re nil (c-lang-const c-brace-id-list-kwds))
@@ -1537,6 +1681,9 @@ higher."
'((c-fontify-types-and-refs ((c-promote-possible-types t))
(c-forward-keyword-clause 1)
(if (> (point) limit) (goto-char limit))))))))
+
+ ,@(when (c-major-mode-is 'java-mode)
+ `((eval . (list "\\<\\(@[a-zA-Z0-9]+\\)\\>" 1 c-annotation-face))))
))
(c-lang-defconst c-matchers-1
@@ -1652,6 +1799,10 @@ need for `c-font-lock-extra-types'.")
;;; C++.
(defun c-font-lock-c++-new (limit)
+ ;; FIXME!!! Put in a comment about the context of this function's
+ ;; invocation. I think it's called as an ANCHORED-MATCHER within an
+ ;; ANCHORED-HIGHLIGHTER. (2007/2/10).
+ ;;
;; Assuming point is after a "new" word, check that it isn't inside
;; a string or comment, and if so try to fontify the type in the
;; allocation expression. Nil is always returned.
diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el
index ac6ff40b4c0..ad6b6787652 100644
--- a/lisp/progmodes/cc-langs.el
+++ b/lisp/progmodes/cc-langs.el
@@ -12,8 +12,8 @@
;; 1985 Richard M. Stallman
;; Maintainer: bug-cc-mode@gnu.org
;; Created: 22-Apr-1997 (split from cc-mode.el)
-;; Version: See cc-mode.el
-;; Keywords: c languages oop
+;; Keywords: c languages
+;; Package: cc-mode
;; This file is part of GNU Emacs.
@@ -359,7 +359,7 @@ The syntax tables aren't stored directly since they're quite large."
(let ((table (make-syntax-table)))
(c-populate-syntax-table table)
;; Mode specific syntaxes.
- ,(cond ((c-major-mode-is 'objc-mode)
+ ,(cond ((or (c-major-mode-is 'objc-mode) (c-major-mode-is 'java-mode))
;; Let '@' be part of symbols in ObjC to cope with
;; its compiler directives as single keyword tokens.
;; This is then necessary since it's assumed that
@@ -382,7 +382,7 @@ The syntax tables aren't stored directly since they're quite large."
;; '<' and '>' characters. Therefore this syntax table might go
;; away when CC Mode handles templates correctly everywhere.
t nil
- c++ `(lambda ()
+ (java c++) `(lambda ()
(let ((table (funcall ,(c-lang-const c-make-mode-syntax-table))))
(modify-syntax-entry ?< "(>" table)
(modify-syntax-entry ?> ")<" table)
@@ -391,6 +391,27 @@ The syntax tables aren't stored directly since they're quite large."
(and (c-lang-const c++-make-template-syntax-table)
(funcall (c-lang-const c++-make-template-syntax-table))))
+(c-lang-defconst c-no-parens-syntax-table
+ ;; A variant of the standard syntax table which is used to find matching
+ ;; "<"s and ">"s which have been marked as parens using syntax table
+ ;; properties. The other paren characters (e.g. "{", ")" "]") are given a
+ ;; non-paren syntax here. so that the list commands will work on "< ... >"
+ ;; even when there's unbalanced other parens inside them.
+ ;;
+ ;; This variable is nil for languages which don't have template stuff.
+ t `(lambda ()
+ (if (c-lang-const c-recognize-<>-arglists)
+ (let ((table (funcall ,(c-lang-const c-make-mode-syntax-table))))
+ (modify-syntax-entry ?\( "." table)
+ (modify-syntax-entry ?\) "." table)
+ (modify-syntax-entry ?\[ "." table)
+ (modify-syntax-entry ?\] "." table)
+ (modify-syntax-entry ?\{ "." table)
+ (modify-syntax-entry ?\} "." table)
+ table))))
+(c-lang-defvar c-no-parens-syntax-table
+ (funcall (c-lang-const c-no-parens-syntax-table)))
+
(c-lang-defconst c-identifier-syntax-modifications
"A list that describes the modifications that should be done to the
mode syntax table to get a syntax table that matches all identifiers
@@ -404,7 +425,7 @@ the new syntax, as accepted by `modify-syntax-entry'."
;; it as an indentifier character since it's often used in various
;; machine generated identifiers.
t '((?_ . "w") (?$ . "w"))
- objc (append '((?@ . "w"))
+ (objc java) (append '((?@ . "w"))
(c-lang-const c-identifier-syntax-modifications))
awk '((?_ . "w")))
(c-lang-defvar c-identifier-syntax-modifications
@@ -423,26 +444,36 @@ the new syntax, as accepted by `modify-syntax-entry'."
classifies symbol constituents like '_' and '$' as word constituents,
so that all identifiers are recognized as words.")
-(c-lang-defconst c-get-state-before-change-function
- "If non-nil, a function called from c-before-change-hook.
-Typically it will record enough state to allow
+(c-lang-defconst c-get-state-before-change-functions
+ ;; For documentation see the following c-lang-defvar of the same name.
+ ;; The value here may be a list of functions or a single function.
+ t nil
+ c++ '(c-extend-region-for-CPP c-before-change-check-<>-operators)
+ (c objc) 'c-extend-region-for-CPP
+ ;; java 'c-before-change-check-<>-operators
+ awk 'c-awk-record-region-clear-NL)
+(c-lang-defvar c-get-state-before-change-functions
+ (let ((fs (c-lang-const c-get-state-before-change-functions)))
+ (if (listp fs)
+ fs
+ (list fs)))
+ "If non-nil, a list of functions called from c-before-change-hook.
+Typically these will record enough state to allow
`c-before-font-lock-function' to extend the region to fontify,
and may do such things as removing text-properties which must be
recalculated.
-It takes 2 parameters, the BEG and END supplied to every
+These functions will be run in the order given. Each of them
+takes 2 parameters, the BEG and END supplied to every
before-change function; on entry, the buffer will have been
widened and match-data will have been saved; point is undefined
on both entry and exit; the return value is ignored.
-When the mode is initialized, this function is called with
-parameters \(point-min) and \(point-max)."
- t nil
- (c c++ objc) 'c-extend-region-for-CPP
- awk 'c-awk-record-region-clear-NL)
-(c-lang-defvar c-get-state-before-change-function
- (c-lang-const c-get-state-before-change-function))
-
+The functions are called even when font locking isn't enabled.
+
+When the mode is initialized, the functions are called with
+parameters \(point-min) and \(point-max).")
+
(c-lang-defconst c-before-font-lock-function
"If non-nil, a function called just before font locking.
Typically it will extend the region about to be fontified \(see
@@ -461,7 +492,7 @@ The function is called even when font locking is disabled.
When the mode is initialized, this function is called with
parameters \(point-min), \(point-max) and <buffer size>."
t nil
- (c c++ objc) 'c-extend-and-neutralize-syntax-in-CPP
+ (c c++ objc) 'c-neutralize-syntax-in-and-mark-CPP
awk 'c-awk-extend-and-syntax-tablify-region)
(c-lang-defvar c-before-font-lock-function
(c-lang-const c-before-font-lock-function))
@@ -471,9 +502,10 @@ parameters \(point-min), \(point-max) and <buffer size>."
(c-lang-defconst c-symbol-start
"Regexp that matches the start of a symbol, i.e. any identifier or
-keyword. It's unspecified how far it matches. Does not contain a \\|
+keyword. It's unspecified how far it matches. Does not contain a \\|
operator at the top level."
t (concat "[" c-alpha "_]")
+ java (concat "[" c-alpha "_@]")
objc (concat "[" c-alpha "@]")
pike (concat "[" c-alpha "_`]"))
(c-lang-defvar c-symbol-start (c-lang-const c-symbol-start))
@@ -828,7 +860,7 @@ since CC Mode treats every identifier as an expression."
;; Primary.
,@(c-lang-const c-identifier-ops)
- ,@(cond ((c-major-mode-is 'c++-mode)
+ ,@(cond ((or (c-major-mode-is 'c++-mode) (c-major-mode-is 'java-mode))
`((postfix-if-paren "<" ">"))) ; Templates.
((c-major-mode-is 'pike-mode)
`((prefix "global" "predef")))
@@ -1087,6 +1119,7 @@ operators."
t
"\\`<."
(lambda (op) (substring op 1)))))
+
(c-lang-defvar c-<-op-cont-regexp (c-lang-const c-<-op-cont-regexp))
(c-lang-defconst c->-op-cont-regexp
@@ -1096,7 +1129,13 @@ operators."
(c-filter-ops (c-lang-const c-all-op-syntax-tokens)
t
"\\`>."
- (lambda (op) (substring op 1)))))
+ (lambda (op) (substring op 1))))
+ java (c-make-keywords-re nil
+ (c-filter-ops (c-lang-const c-all-op-syntax-tokens)
+ t
+ "\\`>[^>]\\|\\`>>[^>]"
+ (lambda (op) (substring op 1)))))
+
(c-lang-defvar c->-op-cont-regexp (c-lang-const c->-op-cont-regexp))
(c-lang-defconst c-stmt-delim-chars
@@ -1526,6 +1565,17 @@ be a subset of `c-primitive-type-kwds'."
;; In CORBA PSDL:
"strong"))
+(c-lang-defconst c-typedef-kwds
+ "Prefix keyword\(s\) like \"typedef\" which make a type declaration out
+of a variable declaration."
+ t '("typedef")
+ (awk idl java) nil)
+
+(c-lang-defconst c-typedef-key
+ ;; Adorned regexp matching `c-typedef-kwds'.
+ t (c-make-keywords-re t (c-lang-const c-typedef-kwds)))
+(c-lang-defvar c-typedef-key (c-lang-const c-typedef-key))
+
(c-lang-defconst c-type-prefix-kwds
"Keywords where the following name - if any - is a type name, and
where the keyword together with the symbol works as a type in
@@ -1597,7 +1647,7 @@ following identifier as a type; the keyword must also be present on
c++ '("class" "struct" "union")
objc '("struct" "union"
"@interface" "@implementation" "@protocol")
- java '("class" "interface")
+ java '("class" "@interface" "interface")
idl '("component" "eventtype" "exception" "home" "interface" "struct"
"union" "valuetype"
;; In CORBA PSDL:
@@ -1620,7 +1670,7 @@ If any of these also are on `c-type-list-kwds', `c-ref-list-kwds',
`c-<>-type-kwds', or `c-<>-arglist-kwds' then the associated clauses
will be handled."
t '("enum")
- (java awk) nil)
+ (awk) nil)
(c-lang-defconst c-brace-list-key
;; Regexp matching the start of declarations where the following
@@ -1692,6 +1742,10 @@ will be handled."
;; types in IDL since they only can occur in "raises" specs.
idl (delete "exception" (append (c-lang-const c-typedef-decl-kwds) nil)))
+(c-lang-defconst c-typedef-decl-key
+ t (c-make-keywords-re t (c-lang-const c-typedef-decl-kwds)))
+(c-lang-defvar c-typedef-decl-key (c-lang-const c-typedef-decl-key))
+
(c-lang-defconst c-typeless-decl-kwds
"Keywords introducing declarations where the \(first) identifier
\(declarator) follows directly after the keyword, without any type.
@@ -1741,7 +1795,7 @@ will be handled."
"bindsTo" "delegatesTo" "implements" "proxy" "storedOn")
;; Note: "const" is not used in Java, but it's still a reserved keyword.
java '("abstract" "const" "final" "native" "private" "protected" "public"
- "static" "strictfp" "synchronized" "transient" "volatile")
+ "static" "strictfp" "synchronized" "transient" "volatile" "@[A-Za-z0-9]+")
pike '("final" "inline" "local" "nomask" "optional" "private" "protected"
"public" "static" "variant"))
@@ -1827,7 +1881,11 @@ one of `c-type-list-kwds', `c-ref-list-kwds',
(c-lang-defconst c-prefix-spec-kwds-re
;; Adorned regexp of `c-prefix-spec-kwds'.
- t (c-make-keywords-re t (c-lang-const c-prefix-spec-kwds)))
+ t (c-make-keywords-re t (c-lang-const c-prefix-spec-kwds))
+ java (replace-regexp-in-string
+ "\\\\\\[" "["
+ (replace-regexp-in-string "\\\\\\+" "+" (c-make-keywords-re t (c-lang-const c-prefix-spec-kwds)))))
+
(c-lang-defvar c-prefix-spec-kwds-re (c-lang-const c-prefix-spec-kwds-re))
(c-lang-defconst c-specifier-key
@@ -1919,7 +1977,7 @@ or variable identifier (that's being defined)."
t nil
c++ '("operator")
objc '("@class")
- java '("import" "new" "extends" "implements" "throws")
+ java '("import" "new" "extends" "super" "implements" "throws")
idl '("manages" "native" "primarykey" "supports"
;; In CORBA PSDL:
"as" "implements" "of" "scope")
@@ -2468,7 +2526,7 @@ more info."
;; in all languages except Java for when a cpp macro definition
;; begins with a declaration.
t "\\([\{\}\(\);,]+\\)"
- java "\\([\{\}\(;,]+\\)"
+ java "\\([\{\}\(;,<]+\\)"
;; Match "<" in C++ to get the first argument in a template arglist.
;; In that case there's an additional check in `c-find-decl-spots'
;; that it got open paren syntax.
@@ -2618,15 +2676,15 @@ Identifier syntax is in effect when this is matched \(see
c++ (concat "\\("
"[*\(&]"
"\\|"
- (concat "\\(" ; 2
+ (c-lang-const c-type-decl-prefix-key)
+ "\\|"
+ (concat "\\(" ; 3
;; If this matches there's special treatment in
;; `c-font-lock-declarators' and
;; `c-font-lock-declarations' that check for a
;; complete name followed by ":: *".
(c-lang-const c-identifier-start)
"\\)")
- "\\|"
- (c-lang-const c-type-decl-prefix-key)
"\\)"
"\\([^=]\\|$\\)")
pike "\\(\\*\\)\\([^=]\\|$\\)")
@@ -2728,7 +2786,7 @@ It's undefined whether identifier syntax (see `c-identifier-syntax-table')
is in effect or not."
t nil
(c c++ objc pike) "\\(\\.\\.\\.\\)"
- java (concat "\\(\\[" (c-lang-const c-simple-ws) "*\\]\\)"))
+ java (concat "\\(\\[" (c-lang-const c-simple-ws) "*\\]\\|\\.\\.\\.\\)"))
(c-lang-defvar c-opt-type-suffix-key (c-lang-const c-opt-type-suffix-key))
(c-lang-defvar c-known-type-key
diff --git a/lisp/progmodes/cc-menus.el b/lisp/progmodes/cc-menus.el
index ae346afa548..e27335e1f58 100644
--- a/lisp/progmodes/cc-menus.el
+++ b/lisp/progmodes/cc-menus.el
@@ -11,8 +11,8 @@
;; 1985 Richard M. Stallman
;; Maintainer: bug-cc-mode@gnu.org
;; Created: 22-Apr-1997 (split from cc-mode.el)
-;; Version: See cc-mode.el
-;; Keywords: c languages oop
+;; Keywords: c languages
+;; Package: cc-mode
;; This file is part of GNU Emacs.
diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el
index 6b0d3f8b423..9524ff27d24 100644
--- a/lisp/progmodes/cc-mode.el
+++ b/lisp/progmodes/cc-mode.el
@@ -1,8 +1,8 @@
;;; cc-mode.el --- major mode for editing C and similar languages
;; Copyright (C) 1985, 1987, 1992, 1993, 1994, 1995, 1996, 1997, 1998,
-;; 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+;; 2010 Free Software Foundation, Inc.
;; Authors: 2003- Alan Mackenzie
;; 1998- Martin Stjernholm
@@ -12,7 +12,7 @@
;; 1985 Richard M. Stallman
;; Maintainer: bug-cc-mode@gnu.org
;; Created: a long, long, time ago. adapted from the original c-mode.el
-;; Keywords: c languages oop
+;; Keywords: c languages
;; This file is part of GNU Emacs.
@@ -100,7 +100,6 @@
(cc-bytecomp-defvar adaptive-fill-first-line-regexp) ; Emacs
(cc-bytecomp-defun set-keymap-parents) ; XEmacs
(cc-bytecomp-defun run-mode-hooks) ; Emacs 21.1
-(cc-bytecomp-obsolete-fun make-local-hook) ; Marked obsolete in Emacs 21.1.
;; We set these variables during mode init, yet we don't require
;; font-lock.
@@ -410,7 +409,7 @@ preferably use the `c-mode-menu' language constant directly."
;; temporary changes in some font lock support modes, causing extra
;; unnecessary work and font lock glitches due to interactions between
;; various text properties.
-;;
+;;
;; (2007-02-12): The macro `combine-after-change-calls' ISN'T used any
;; more.
@@ -451,18 +450,18 @@ preferably use the `c-mode-menu' language constant directly."
end (point))))))))
;; c-maybe-stale-found-type records a place near the region being
-;; changed where an element of `found-types' might become stale. It
+;; changed where an element of `found-types' might become stale. It
;; is set in c-before-change and is either nil, or has the form:
;;
;; (c-decl-id-start "foo" 97 107 " (* ooka) " "o"), where
-;;
+;;
;; o - `c-decl-id-start' is the c-type text property value at buffer
;; pos 96.
-;;
+;;
;; o - 97 107 is the region potentially containing the stale type -
;; this is delimited by a non-nil c-type text property at 96 and
;; either another one or a ";", "{", or "}" at 107.
-;;
+;;
;; o - " (* ooka) " is the (before change) buffer portion containing
;; the suspect type (here "ooka").
;;
@@ -517,9 +516,12 @@ that requires a literal mode spec at compile time."
(make-local-variable 'fill-paragraph-function)
(setq fill-paragraph-function 'c-fill-paragraph)
+ ;; Initialise the cache of brace pairs, and opening braces/brackets/parens.
+ (c-state-cache-init)
+
(when (or c-recognize-<>-arglists
(c-major-mode-is 'awk-mode)
- (c-major-mode-is '(c-mode c++-mode objc-mode)))
+ (c-major-mode-is '(java-mode c-mode c++-mode objc-mode)))
;; We'll use the syntax-table text property to change the syntax
;; of some chars for this language, so do the necessary setup for
;; that.
@@ -597,9 +599,10 @@ that requires a literal mode spec at compile time."
;; Install the functions that ensure that various internal caches
;; don't become invalid due to buffer changes.
- (make-local-hook 'before-change-functions)
+ (when (featurep 'xemacs)
+ (make-local-hook 'before-change-functions)
+ (make-local-hook 'after-change-functions))
(add-hook 'before-change-functions 'c-before-change nil t)
- (make-local-hook 'after-change-functions)
(add-hook 'after-change-functions 'c-after-change nil t)
(set (make-local-variable 'font-lock-extend-after-change-region-function)
'c-extend-after-change-region)) ; Currently (2009-05) used by all
@@ -613,6 +616,15 @@ that requires a literal mode spec at compile time."
(font-lock-mode 0)
(font-lock-mode 1)))
+;; Buffer local variables defining the region to be fontified by a font lock
+;; after-change function. They are set in c-after-change to
+;; after-change-function's BEG and END, and may be modified by a
+;; `c-before-font-lock-function'.
+(defvar c-new-BEG 0)
+(make-variable-buffer-local 'c-new-BEG)
+(defvar c-new-END 0)
+(make-variable-buffer-local 'c-new-END)
+
(defun c-common-init (&optional mode)
"Common initialization for all CC Mode modes.
In addition to the work done by `c-basic-common-init' and
@@ -637,9 +649,13 @@ compatible with old code; callers should always specify it."
;; Starting a mode is a sort of "change". So call the change functions...
(save-restriction
(widen)
+ (setq c-new-BEG (point-min))
+ (setq c-new-END (point-max))
(save-excursion
- (if c-get-state-before-change-function
- (funcall c-get-state-before-change-function (point-min) (point-max)))
+ (if c-get-state-before-change-functions
+ (mapc (lambda (fn)
+ (funcall fn (point-min) (point-max)))
+ c-get-state-before-change-functions))
(if c-before-font-lock-function
(funcall c-before-font-lock-function (point-min) (point-max)
(- (point-max) (point-min))))))
@@ -655,6 +671,17 @@ compatible with old code; callers should always specify it."
(and (cdr rfn)
(setq require-final-newline mode-require-final-newline)))))
+(defun c-count-cfss (lv-alist)
+ ;; LV-ALIST is an alist like `file-local-variables-alist'. Count how many
+ ;; elements with the key `c-file-style' there are in it.
+ (let ((elt-ptr lv-alist) elt (cownt 0))
+ (while elt-ptr
+ (setq elt (car elt-ptr)
+ elt-ptr (cdr elt-ptr))
+ (when (eq (car elt) 'c-file-style)
+ (setq cownt (1+ cownt))))
+ cownt))
+
(defun c-before-hack-hook ()
"Set the CC Mode style and \"offsets\" when in the buffer's local variables.
They are set only when, respectively, the pseudo variables
@@ -671,7 +698,15 @@ This function is called from the hook `before-hack-local-variables-hook'."
(delq mode-cons file-local-variables-alist)))
(when stile
(or (stringp stile) (error "c-file-style is not a string"))
- (c-set-style stile))
+ (if (boundp 'dir-local-variables-alist)
+ ;; Determine whether `c-file-style' was set in the file's local
+ ;; variables or in a .dir-locals.el (a directory setting).
+ (let ((cfs-in-file-and-dir-count
+ (c-count-cfss file-local-variables-alist))
+ (cfs-in-dir-count (c-count-cfss dir-local-variables-alist)))
+ (c-set-style stile
+ (= cfs-in-file-and-dir-count cfs-in-dir-count)))
+ (c-set-style stile)))
(when offsets
(mapc
(lambda (langentry)
@@ -777,7 +812,7 @@ Note that the style variables are always made local to the buffer."
(defmacro c-run-mode-hooks (&rest hooks)
;; Emacs 21.1 has introduced a system with delayed mode hooks that
- ;; require the use of the new function `run-mode-hooks'.
+ ;; requires the use of the new function `run-mode-hooks'.
(if (cc-bytecomp-fboundp 'run-mode-hooks)
`(run-mode-hooks ,@hooks)
`(progn ,@(mapcar (lambda (hook) `(run-hooks ,hook)) hooks))))
@@ -785,15 +820,6 @@ Note that the style variables are always made local to the buffer."
;;; Change hooks, linking with Font Lock.
-;; Buffer local variables defining the region to be fontified by a font lock
-;; after-change function. They are set in c-after-change to
-;; after-change-function's BEG and END, and may be modified by a
-;; `c-before-font-lock-function'.
-(defvar c-new-BEG 0)
-(make-variable-buffer-local 'c-new-BEG)
-(defvar c-new-END 0)
-(make-variable-buffer-local 'c-new-END)
-
;; Buffer local variables recording Beginning/End-of-Macro position before a
;; change, when a macro straddles, respectively, the BEG or END (or both) of
;; the change region. Otherwise these have the values BEG/END.
@@ -810,16 +836,18 @@ Note that the style variables are always made local to the buffer."
;; has already been widened, and match-data saved. The return value is
;; meaningless.
;;
- ;; This function is the C/C++/ObjC value of
- ;; `c-get-state-before-change-function' and is called exclusively as a
+ ;; This function is in the C/C++/ObjC values of
+ ;; `c-get-state-before-change-functions' and is called exclusively as a
;; before change function.
(goto-char beg)
(c-beginning-of-macro)
(setq c-old-BOM (point))
(goto-char end)
- (if (c-beginning-of-macro)
- (c-end-of-macro))
+ (when (c-beginning-of-macro)
+ (c-end-of-macro)
+ (or (eobp) (forward-char))) ; Over the terminating NL which may be marked
+ ; with a c-cpp-delimiter category property
(setq c-old-EOM (point)))
(defun c-neutralize-CPP-line (beg end)
@@ -848,7 +876,7 @@ Note that the style variables are always made local to the buffer."
t)
(t nil)))))))
-(defun c-extend-and-neutralize-syntax-in-CPP (begg endd old-len)
+(defun c-neutralize-syntax-in-and-mark-CPP (begg endd old-len)
;; (i) Extend the font lock region to cover all changed preprocessor
;; regions; it does this by setting the variables `c-new-BEG' and
;; `c-new-END' to the new boundaries.
@@ -857,10 +885,15 @@ Note that the style variables are always made local to the buffer."
;; extended changed region. "Restore" lines which were CPP lines before the
;; change and are no longer so; these can be located from the Buffer local
;; variables `c-old-BOM' and `c-old-EOM'.
- ;;
+ ;;
+ ;; (iii) Mark every CPP construct by placing a `category' property value
+ ;; `c-cpp-delimiter' at its start and end. The marked characters are the
+ ;; opening # and usually the terminating EOL, but sometimes the character
+ ;; before a comment/string delimiter.
+ ;;
;; That is, set syntax-table properties on characters that would otherwise
;; interact syntactically with those outside the CPP line(s).
- ;;
+ ;;
;; This function is called from an after-change function, BEGG ENDD and
;; OLD-LEN being the standard parameters. It prepares the buffer for font
;; locking, hence must get called before `font-lock-after-change-function'.
@@ -871,32 +904,36 @@ Note that the style variables are always made local to the buffer."
;; This function is the C/C++/ObjC value of `c-before-font-lock-function'.
;;
;; Note: SPEED _MATTERS_ IN THIS FUNCTION!!!
- ;;
+ ;;
;; This function might make hidden buffer changes.
- (c-save-buffer-state (limits mbeg+1)
+ (c-save-buffer-state (limits)
;; First determine the region, (c-new-BEG c-new-END), which will get font
;; locked. It might need "neutralizing". This region may not start
;; inside a string, comment, or macro.
(goto-char c-old-BOM) ; already set to old start of macro or begg.
(setq c-new-BEG
- (if (setq limits (c-literal-limits))
- (cdr limits) ; go forward out of any string or comment.
- (point)))
+ (min c-new-BEG
+ (if (setq limits (c-state-literal-at (point)))
+ (cdr limits) ; go forward out of any string or comment.
+ (point))))
(goto-char endd)
- (if (setq limits (c-literal-limits))
+ (if (setq limits (c-state-literal-at (point)))
(goto-char (car limits))) ; go backward out of any string or comment.
(if (c-beginning-of-macro)
(c-end-of-macro))
- (setq c-new-END (max (+ (- c-old-EOM old-len) (- endd begg))
- (point)))
+ (setq c-new-END (max c-new-END
+ (+ (- c-old-EOM old-len) (- endd begg))
+ (point)))
- ;; Clear any existing punctuation properties.
+ ;; Clear all old relevant properties.
(c-clear-char-property-with-value c-new-BEG c-new-END 'syntax-table '(1))
+ (c-clear-char-property-with-value c-new-BEG c-new-END 'category 'c-cpp-delimiter)
+ ;; FIXME!!! What about the "<" and ">" category properties? 2009-11-16
;; Add needed properties to each CPP construct in the region.
(goto-char c-new-BEG)
- (let ((pps-position c-new-BEG) pps-state)
+ (let ((pps-position c-new-BEG) pps-state mbeg)
(while (and (< (point) c-new-END)
(search-forward-regexp c-anchored-cpp-prefix c-new-END t))
;; If we've found a "#" inside a string/comment, ignore it.
@@ -905,18 +942,24 @@ Note that the style variables are always made local to the buffer."
pps-position (point))
(unless (or (nth 3 pps-state) ; in a string?
(nth 4 pps-state)) ; in a comment?
- (setq mbeg+1 (point))
- (c-end-of-macro) ; Do we need to go forward 1 char here? No!
- (c-neutralize-CPP-line mbeg+1 (point))
- (setq pps-position (point))))))) ; no need to update pps-state.
+ (goto-char (match-beginning 0))
+ (setq mbeg (point))
+ (if (> (c-syntactic-end-of-macro) mbeg)
+ (progn
+ (c-neutralize-CPP-line mbeg (point))
+ (c-set-cpp-delimiters mbeg (point))
+ ;(setq pps-position (point))
+ )
+ (forward-line)) ; no infinite loop with, e.g., "#//"
+ )))))
(defun c-before-change (beg end)
- ;; Function to be put on `before-change-function'. Primarily, this calls
- ;; the language dependent `c-get-state-before-change-function'. It is
+ ;; Function to be put on `before-change-functions'. Primarily, this calls
+ ;; the language dependent `c-get-state-before-change-functions'. It is
;; otherwise used only to remove stale entries from the `c-found-types'
;; cache, and to record entries which a `c-after-change' function might
;; confirm as stale.
- ;;
+ ;;
;; Note that this function must be FAST rather than accurate. Note
;; also that it only has any effect when font locking is enabled.
;; We exploit this by checking for font-lock-*-face instead of doing
@@ -986,12 +1029,10 @@ Note that the style variables are always made local to the buffer."
(buffer-substring-no-properties type-pos term-pos)
(buffer-substring-no-properties beg end)))))))
- ;; (c-new-BEG c-new-END) will be the region to fontify. It may become
- ;; larger than (beg end).
- (setq c-new-BEG beg
- c-new-END end)
- (if c-get-state-before-change-function
- (funcall c-get-state-before-change-function beg end))
+ (if c-get-state-before-change-functions
+ (mapc (lambda (fn)
+ (funcall fn beg end))
+ c-get-state-before-change-functions))
))))
(defun c-after-change (beg end old-len)
@@ -1025,6 +1066,14 @@ Note that the style variables are always made local to the buffer."
(when (> beg end)
(setq beg end)))
+ ;; C-y is capable of spuriously converting category properties
+ ;; c-</>-as-paren-syntax into hard syntax-table properties. Remove
+ ;; these when it happens.
+ (c-clear-char-property-with-value beg end 'syntax-table
+ c-<-as-paren-syntax)
+ (c-clear-char-property-with-value beg end 'syntax-table
+ c->-as-paren-syntax)
+
(c-trim-found-types beg end old-len) ; maybe we don't need all of these.
(c-invalidate-sws-region-after beg end)
(c-invalidate-state-cache beg)
@@ -1033,6 +1082,10 @@ Note that the style variables are always made local to the buffer."
(when c-recognize-<>-arglists
(c-after-change-check-<>-operators beg end))
+ ;; (c-new-BEG c-new-END) will be the region to fontify. It may become
+ ;; larger than (beg end).
+ (setq c-new-BEG beg
+ c-new-END end)
(if c-before-font-lock-function
(save-excursion
(funcall c-before-font-lock-function beg end old-len)))))))
@@ -1060,8 +1113,8 @@ This does not load the font-lock package. Use after
c-beginning-of-syntax
(font-lock-mark-block-function
. c-mark-function)))
-
- (make-local-hook 'font-lock-mode-hook)
+ (if (featurep 'xemacs)
+ (make-local-hook 'font-lock-mode-hook))
(add-hook 'font-lock-mode-hook 'c-after-font-lock-init nil t))
(defun c-extend-after-change-region (beg end old-len)
diff --git a/lisp/progmodes/cc-styles.el b/lisp/progmodes/cc-styles.el
index ec9ffe34624..15d44f6538a 100644
--- a/lisp/progmodes/cc-styles.el
+++ b/lisp/progmodes/cc-styles.el
@@ -12,8 +12,8 @@
;; 1985 Richard M. Stallman
;; Maintainer: bug-cc-mode@gnu.org
;; Created: 22-Apr-1997 (split from cc-mode.el)
-;; Version: See cc-mode.el
-;; Keywords: c languages oop
+;; Keywords: c languages
+;; Package: cc-mode
;; This file is part of GNU Emacs.
@@ -50,7 +50,6 @@
;; Silence the compiler.
(cc-bytecomp-defvar adaptive-fill-first-line-regexp) ; Emacs
-(cc-bytecomp-obsolete-fun make-local-hook) ; Marked obsolete in Emacs 21.1.
(defvar c-style-alist
@@ -649,7 +648,7 @@ any reason to call this function directly."
(mapc func varsyms)
;; Hooks must be handled specially
(if this-buf-only-p
- (make-local-hook 'c-special-indent-hook)
+ (if (featurep 'xemacs) (make-local-hook 'c-special-indent-hook))
(with-no-warnings (make-variable-buffer-local 'c-special-indent-hook))
(setq c-style-variables-are-local-p t))
))
diff --git a/lisp/progmodes/cc-vars.el b/lisp/progmodes/cc-vars.el
index 82015687cb2..e965cc21928 100644
--- a/lisp/progmodes/cc-vars.el
+++ b/lisp/progmodes/cc-vars.el
@@ -12,8 +12,8 @@
;; 1985 Richard M. Stallman
;; Maintainer: bug-cc-mode@gnu.org
;; Created: 22-Apr-1997 (split from cc-mode.el)
-;; Version: See cc-mode.el
-;; Keywords: c languages oop
+;; Keywords: c languages
+;; Package: cc-mode
;; This file is part of GNU Emacs.
@@ -1056,9 +1056,13 @@ can always override the use of `c-default-style' by making calls to
;; Anchor pos: Boi at the topmost intro line.
(knr-argdecl . 0)
;; Anchor pos: At the beginning of the first K&R argdecl.
- (topmost-intro . 0)
+ (topmost-intro . 0)
;; Anchor pos: Bol at the last line of previous construct.
(topmost-intro-cont . c-lineup-topmost-intro-cont)
+ ;;Anchor pos: Bol at the topmost annotation line
+ (annotation-top-cont . 0)
+ ;;Anchor pos: Bol at the topmost annotation line
+ (annotation-var-cont . +)
;; Anchor pos: Boi at the topmost intro line.
(member-init-intro . +)
;; Anchor pos: Boi at the func decl arglist open.
@@ -1285,12 +1289,16 @@ Here is the current list of valid syntactic element symbols:
between them; in C++ and Java, throws declarations
and other things can appear in this context.
knr-argdecl-intro -- First line of a K&R C argument declaration.
- knr-argdecl -- Subsequent lines in a K&R C argument declaration.
- topmost-intro -- The first line in a topmost construct definition.
- topmost-intro-cont -- Topmost definition continuation lines.
- member-init-intro -- First line in a member initialization list.
- member-init-cont -- Subsequent member initialization list lines.
- inher-intro -- First line of a multiple inheritance list.
+ knr-argdecl -- Subsequent lines in a K&R C argument declaration.
+ topmost-intro -- The first line in a topmost construct definition.
+ topmost-intro-cont -- Topmost definition continuation lines.
+ annotation-top-cont -- Topmost definition continuation line where only
+ annotations are on previous lines.
+ annotation-var-cont -- A continuation of a C (or like) statement where
+ only annotations are on previous lines.
+ member-init-intro -- First line in a member initialization list.
+ member-init-cont -- Subsequent member initialization list lines.
+ inher-intro -- First line of a multiple inheritance list.
inher-cont -- Subsequent multiple inheritance lines.
block-open -- Statement block open brace.
block-close -- Statement block close brace.
@@ -1376,7 +1384,7 @@ Here is the current list of valid syntactic element symbols:
'(defun-block-intro block-open block-close statement statement-cont
statement-block-intro statement-case-intro statement-case-open
substatement substatement-open substatement-label case-label label
- do-while-closure else-clause catch-clause inlambda))
+ do-while-closure else-clause catch-clause inlambda annotation-var-cont))
(defcustom c-style-variables-are-local-p t
"*Whether style variables should be buffer local by default.
@@ -1577,7 +1585,7 @@ names)."))
:group 'c)
(defcustom java-font-lock-extra-types
- (list (concat "[" c-upper "]\\sw*[" c-lower "]\\sw*"))
+ (list (concat "[" c-upper "]\\sw*[" c-lower "]\\sw"))
(c-make-font-lock-extra-types-blurb "Java" "java-mode" (concat
"For example, a value of (\"[" c-upper "]\\\\sw*[" c-lower "]\\\\sw*\") means
capitalized words are treated as type names (the requirement for a
diff --git a/lisp/progmodes/cfengine.el b/lisp/progmodes/cfengine.el
index 86a6be40cc5..e074e92fbe5 100644
--- a/lisp/progmodes/cfengine.el
+++ b/lisp/progmodes/cfengine.el
@@ -83,12 +83,6 @@ This includes those for cfservd as well as cfagent."))
;; File, acl &c in group: { token ... }
("{[ \t]*\\([^ \t\n]+\\)" 1 font-lock-constant-face)))
-(defconst cfengine-font-lock-syntactic-keywords
- ;; In the main syntax-table, backslash is marked as a punctuation, because
- ;; of its use in DOS-style directory separators. Here we try to recognize
- ;; the cases where backslash is used as an escape inside strings.
- '(("\\(\\(?:\\\\\\)+\\)\"" 1 "\\")))
-
(defvar cfengine-imenu-expression
`((nil ,(concat "^[ \t]*" (eval-when-compile
(regexp-opt cfengine-actions t))
@@ -237,13 +231,15 @@ to the action header."
(set (make-local-variable 'fill-paragraph-function)
#'cfengine-fill-paragraph)
(define-abbrev-table 'cfengine-mode-abbrev-table cfengine-mode-abbrevs)
- ;; Fixme: Use `font-lock-syntactic-keywords' to set the args of
- ;; functions in evaluated classes to string syntax, and then obey
- ;; syntax properties.
(setq font-lock-defaults
- '(cfengine-font-lock-keywords nil nil nil beginning-of-line
- (font-lock-syntactic-keywords
- . cfengine-font-lock-syntactic-keywords)))
+ '(cfengine-font-lock-keywords nil nil nil beginning-of-line))
+ ;; Fixme: set the args of functions in evaluated classes to string
+ ;; syntax, and then obey syntax properties.
+ (set (make-local-variable 'syntax-propertize-function)
+ ;; In the main syntax-table, \ is marked as a punctuation, because
+ ;; of its use in DOS-style directory separators. Here we try to
+ ;; recognize the cases where \ is used as an escape inside strings.
+ (syntax-propertize-rules ("\\(\\(?:\\\\\\)+\\)\"" (1 "\\"))))
(setq imenu-generic-expression cfengine-imenu-expression)
(set (make-local-variable 'beginning-of-defun-function)
#'cfengine-beginning-of-defun)
diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el
index c8f9834cf64..dd30212085e 100644
--- a/lisp/progmodes/compile.el
+++ b/lisp/progmodes/compile.el
@@ -164,7 +164,7 @@ and a string describing how the process finished.")
(defvar compilation-num-errors-found)
-(defconst compilation-error-regexp-alist-alist
+(defvar compilation-error-regexp-alist-alist
'((absoft
"^\\(?:[Ee]rror on \\|[Ww]arning on\\( \\)\\)?[Ll]ine[ \t]+\\([0-9]+\\)[ \t]+\
of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1))
@@ -196,6 +196,10 @@ 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))
+ (cucumber
+ "\\(?:^cucumber\\(?: -p [^[:space:]]+\\)?\\|#\\)\
+\\(?: \\)\\([^\(].*\\):\\([1-9][0-9]*\\)" 1 2)
+
(edg-1
"^\\([^ \n]+\\)(\\([0-9]+\\)): \\(?:error\\|warnin\\(g\\)\\|remar\\(k\\)\\)"
1 2 nil (3 . 4))
@@ -233,6 +237,10 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1))
nil 1 nil 2 0
(2 (compilation-face '(3))))
+ (gcc-include
+ "^\\(?:In file included \\| \\|\t\\)from \
+\\(.+\\):\\([0-9]+\\)\\(?:\\(:\\)\\|\\(,\\|$\\)\\)?" 1 2 nil (3 . 4))
+
(gnu
;; The first line matches the program name for
@@ -255,9 +263,11 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1))
;; The core of the regexp is the one with *?. It says that a file name
;; can be composed of any non-newline char, but it also rules out some
;; valid but unlikely cases, such as a trailing space or a space
- ;; followed by a -.
- "^\\(?:[[:alpha:]][-[:alnum:].]+: ?\\)?\
-\\([0-9]*[^0-9\n]\\(?:[^\n ]\\| [^-/\n]\\)*?\\): ?\
+ ;; followed by a -, or a colon followed by a space.
+
+ ;; The "in \\|from " exception was added to handle messages from Ruby.
+ "^\\(?:[[:alpha:]][-[:alnum:].]+: ?\\|[ \t]+\\(?:in \\|from \\)\\)?\
+\\([0-9]*[^0-9\n]\\(?:[^\n :]\\| [^-/\n]\\|:[^ \n]\\)*?\\): ?\
\\([0-9]+\\)\\(?:\\([.:]\\)\\([0-9]+\\)\\)?\
\\(?:-\\([0-9]+\\)?\\(?:\\.\\([0-9]+\\)\\)?\\)?:\
\\(?: *\\(\\(?:Future\\|Runtime\\)?[Ww]arning\\|W:\\)\\|\
@@ -265,12 +275,6 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1))
\[0-9]?\\(?:[^0-9\n]\\|$\\)\\|[0-9][0-9][0-9]\\)"
1 (2 . 5) (4 . 6) (7 . 8))
- ;; The `gnu' style above can incorrectly match gcc's "In file
- ;; included from" message, so we process that first. -- cyd
- (gcc-include
- "^\\(?:In file included\\| \\) from \
-\\(.+\\):\\([0-9]+\\)\\(?:\\(:\\)\\|\\(,\\)\\)?" 1 2 nil (3 . 4))
-
(lcc
"^\\(?:E\\|\\(W\\)\\), \\([^(\n]+\\)(\\([0-9]+\\),[ \t]*\\([0-9]+\\)"
2 3 4 (1))
@@ -325,6 +329,9 @@ during global destruction\\.$\\)" 1 2)
"\\(?:Parse\\|Fatal\\) error: \\(.*\\) in \\(.*\\) on line \\([0-9]+\\)"
2 3 nil nil)
+ (ruby-Test::Unit
+ "[\t ]*\\[\\([^\(].*\\):\\([1-9][0-9]*\\)\\(\\]\\)?:$" 1 2)
+
(rxp
"^\\(?:Error\\|Warnin\\(g\\)\\):.*\n.* line \\([0-9]+\\) char\
\\([0-9]+\\) of file://\\(.+\\)"
@@ -536,7 +543,7 @@ you may also want to change `compilation-page-delimiter'.")
;; Command output lines. Recognize `make[n]:' lines too.
("^\\([[:alnum:]_/.+-]+\\)\\(\\[\\([0-9]+\\)\\]\\)?[ \t]*:"
(1 font-lock-function-name-face) (3 compilation-line-face nil t))
- (" --?o\\(?:utfile\\|utput\\)?[= ]?\\(\\S +\\)" . 1)
+ (" -\\(?:o[= ]?\\|-\\(?:outfile\\|output\\)[= ]\\)\\(\\S +\\)" . 1)
("^Compilation \\(finished\\).*"
(0 '(face nil message nil help-echo nil mouse-face nil) t)
(1 compilation-info-face))
@@ -583,6 +590,21 @@ Otherwise, it saves all modified buffers without asking."
:type 'boolean
:group 'compilation)
+(defcustom compilation-save-buffers-predicate nil
+ "The second argument (PRED) passed to `save-some-buffers' before compiling.
+E.g., one can set this to
+ (lambda ()
+ (string-prefix-p my-compilation-root (file-truename (buffer-file-name))))
+to limit saving to files located under `my-compilation-root'.
+Note, that, in general, `compilation-directory' cannot be used instead
+of `my-compilation-root' here."
+ :type '(choice
+ (const :tag "Default (save all file-visiting buffers)" nil)
+ (const :tag "Save all buffers" t)
+ function)
+ :group 'compilation
+ :version "24.1")
+
;;;###autoload
(defcustom compilation-search-path '(nil)
"List of directories to search for source files named in error messages.
@@ -733,6 +755,9 @@ Faces `compilation-error-face', `compilation-warning-face',
"If non-nil, automatically jump to the next error encountered.")
(make-variable-buffer-local 'compilation-auto-jump-to-next)
+(defvar compilation-buffer-modtime nil
+ "The buffer modification time, for buffers not associated with files.")
+(make-variable-buffer-local 'compilation-buffer-modtime)
(defvar compilation-skip-to-next-location t
"*If non-nil, skip multiple error messages for the same source location.")
@@ -743,12 +768,27 @@ The value can be either 2 -- skip anything less than error, 1 --
skip anything less than warning or 0 -- don't skip any messages.
Note that all messages not positively identified as warning or
info, are considered errors."
- :type '(choice (const :tag "Warnings and info" 2)
- (const :tag "Info" 1)
- (const :tag "None" 0))
+ :type '(choice (const :tag "Skip warnings and info" 2)
+ (const :tag "Skip info" 1)
+ (const :tag "No skip" 0))
:group 'compilation
:version "22.1")
+(defun compilation-set-skip-threshold (level)
+ "Switch the `compilation-skip-threshold' level."
+ (interactive
+ (list
+ (mod (if current-prefix-arg
+ (prefix-numeric-value current-prefix-arg)
+ (1+ compilation-skip-threshold))
+ 3)))
+ (setq compilation-skip-threshold level)
+ (message "Skipping %s"
+ (case compilation-skip-threshold
+ (0 "Nothing")
+ (1 "Info messages")
+ (2 "Warnings and info"))))
+
(defcustom compilation-skip-visited nil
"Compilation motion commands skip visited messages if this is t.
Visited messages are ones for which the file, line and column have been jumped
@@ -1094,7 +1134,8 @@ to a function that generates a unique name."
(consp current-prefix-arg)))
(unless (equal command (eval compile-command))
(setq compile-command command))
- (save-some-buffers (not compilation-ask-about-save) nil)
+ (save-some-buffers (not compilation-ask-about-save)
+ compilation-save-buffers-predicate)
(setq-default compilation-directory default-directory)
(compilation-start command comint))
@@ -1105,7 +1146,8 @@ If this is run in a Compilation mode buffer, re-use the arguments from the
original use. Otherwise, recompile using `compile-command'.
If the optional argument `edit-command' is non-nil, the command can be edited."
(interactive "P")
- (save-some-buffers (not compilation-ask-about-save) nil)
+ (save-some-buffers (not compilation-ask-about-save)
+ compilation-save-buffers-predicate)
(let ((default-directory (or compilation-directory default-directory)))
(when edit-command
(setcar compilation-arguments
@@ -1187,7 +1229,7 @@ Returns the compilation buffer created."
(let* ((name-of-mode
(if (eq mode t)
"compilation"
- (replace-regexp-in-string "-mode$" "" (symbol-name mode))))
+ (replace-regexp-in-string "-mode\\'" "" (symbol-name mode))))
(thisdir default-directory)
outwin outbuf)
(with-current-buffer
@@ -1217,7 +1259,8 @@ Returns the compilation buffer created."
;; Then evaluate a cd command if any, but don't perform it yet, else
;; start-command would do it again through the shell: (cd "..") AND
;; sh -c "cd ..; make"
- (cd (if (string-match "^\\s *cd\\(?:\\s +\\(\\S +?\\)\\)?\\s *[;&\n]" command)
+ (cd (if (string-match "\\`\\s *cd\\(?:\\s +\\(\\S +?\\)\\)?\\s *[;&\n]"
+ command)
(if (match-end 1)
(substitute-env-vars (match-string 1 command))
"~")
@@ -1244,7 +1287,8 @@ Returns the compilation buffer created."
(set (make-local-variable 'compilation-auto-jump-to-next) t))
;; Output a mode setter, for saving and later reloading this buffer.
(insert "-*- mode: " name-of-mode
- "; default-directory: " (prin1-to-string default-directory)
+ "; default-directory: "
+ (prin1-to-string (abbreviate-file-name default-directory))
" -*-\n"
(format "%s started at %s\n\n"
mode-name
@@ -1566,6 +1610,7 @@ Runs `compilation-mode-hook' with `run-mode-hooks' (which see).
mode-name (or name-of-mode "Compilation"))
(set (make-local-variable 'page-delimiter)
compilation-page-delimiter)
+ (set (make-local-variable 'compilation-buffer-modtime) nil)
(compilation-setup)
(setq buffer-read-only t)
(run-mode-hooks 'compilation-mode-hook))
@@ -1781,6 +1826,7 @@ and runs `compilation-filter-hook'."
(unless comint-inhibit-carriage-motion
(comint-carriage-motion (process-mark proc) (point)))
(set-marker (process-mark proc) (point))
+ (set (make-local-variable 'compilation-buffer-modtime) (current-time))
(run-hooks 'compilation-filter-hook))
(goto-char pos)
(narrow-to-region min max)
@@ -1950,16 +1996,11 @@ This is the value of `next-error-function' in Compilation buffers."
;; (`omake -P' polls filesystem for changes and recompiles when needed
;; in the same process and buffer).
;; So, recalculate all markers for that file.
- (unless (and (nth 3 loc) (marker-buffer (nth 3 loc))
- ;; There may be no timestamp info if the loc is a `fake-loc'.
- ;; So we skip the time-check here, although we should maybe
- ;; change `compilation-fake-loc' to add timestamp info.
- (or (null (nth 4 loc))
- (equal (nth 4 loc)
- (setq timestamp
- (with-current-buffer
- (marker-buffer (nth 3 loc))
- (visited-file-modtime))))))
+ (unless (and (nth 3 loc) (marker-buffer (nth 3 loc)) (nthcdr 4 loc)
+ ;; There may be no timestamp info if the loc is a `fake-loc',
+ ;; but we just checked that the file has been visited before!
+ (equal (nth 4 loc)
+ (setq timestamp compilation-buffer-modtime)))
(with-current-buffer (compilation-find-file marker (caar (nth 2 loc))
(cadr (car (nth 2 loc))))
(save-restriction
@@ -2064,7 +2105,7 @@ and overlay is highlighted between MK and END-MK."
pre-existing
(let ((display-buffer-reuse-frames t)
(pop-up-windows t))
- ;; Pop up a window.
+ ;; Pop up a window.
(display-buffer (marker-buffer msg)))))
(highlight-regexp (with-current-buffer (marker-buffer msg)
;; also do this while we change buffer
@@ -2353,7 +2394,7 @@ The file-structure looks like this:
(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))
+ (clrhash compilation-locs)
(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
@@ -2384,9 +2425,6 @@ The file-structure looks like this:
(or compilation-auto-jump-to-first-error
(eq compilation-scroll-output 'first-error))))
-;;;###autoload
-(add-to-list 'auto-mode-alist (cons (purecopy "\\.gcov\\'") 'compilation-mode))
-
(provide 'compile)
;; arch-tag: 12465727-7382-4f72-b234-79855a00dd8c
diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el
index 2f751f2a0dc..6f8c1261510 100644
--- a/lisp/progmodes/cperl-mode.el
+++ b/lisp/progmodes/cperl-mode.el
@@ -1,8 +1,8 @@
;;; cperl-mode.el --- Perl code editing commands for Emacs
-;; Copyright (C) 1985, 1986, 1987, 1991, 1992, 1993, 1994, 1995, 1996, 1997,
-;; 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1986, 1987, 1991, 1992, 1993, 1994, 1995, 1996,
+;; 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Ilya Zakharevich
;; Bob Olson
@@ -1802,13 +1802,12 @@ or as help on variables `cperl-tips', `cperl-problems',
(set 'vc-rcs-header cperl-vc-rcs-header)
(make-local-variable 'vc-sccs-header)
(set 'vc-sccs-header cperl-vc-sccs-header)
- ;; This one is obsolete...
- (make-local-variable 'vc-header-alist)
- (with-no-warnings
- (set 'vc-header-alist (or cperl-vc-header-alist ; Avoid warning
- `((SCCS ,(car cperl-vc-sccs-header))
- (RCS ,(car cperl-vc-rcs-header)))))
- )
+ (when (featurep 'xemacs)
+ ;; This one is obsolete...
+ (make-local-variable 'vc-header-alist)
+ (set 'vc-header-alist (or cperl-vc-header-alist ; Avoid warning
+ `((SCCS ,(car cperl-vc-sccs-header))
+ (RCS ,(car cperl-vc-rcs-header))))))
(cond ((boundp 'compilation-error-regexp-alist-alist);; xemacs 20.x
(make-local-variable 'compilation-error-regexp-alist-alist)
(set 'compilation-error-regexp-alist-alist
@@ -1840,7 +1839,13 @@ or as help on variables `cperl-tips', `cperl-problems',
(make-local-variable 'cperl-syntax-state)
(setq cperl-syntax-state nil) ; reset syntaxification cache
(if cperl-use-syntax-table-text-property
- (progn
+ (if (boundp 'syntax-propertize-function)
+ (progn
+ ;; Reset syntaxification cache.
+ (set (make-local-variable 'cperl-syntax-done-to) nil)
+ (set (make-local-variable 'syntax-propertize-function)
+ (lambda (start end)
+ (goto-char start) (cperl-fontify-syntaxically end))))
(make-local-variable 'parse-sexp-lookup-properties)
;; Do not introduce variable if not needed, we check it!
(set 'parse-sexp-lookup-properties t)
@@ -2140,7 +2145,7 @@ char is \"{\", insert extra newline before only if
"Insert an opening parenthesis or a matching pair of parentheses.
See `cperl-electric-parens'."
(interactive "P")
- (let ((beg (save-excursion (beginning-of-line) (point)))
+ (let ((beg (point-at-bol))
(other-end (if (and cperl-electric-parens-mark
(cperl-mark-active)
(> (mark) (point)))
@@ -2177,7 +2182,7 @@ See `cperl-electric-parens'."
If not, or if we are not at the end of marking range, would self-insert.
Affected by `cperl-electric-parens'."
(interactive "P")
- (let ((beg (save-excursion (beginning-of-line) (point)))
+ (let ((beg (point-at-bol))
(other-end (if (and cperl-electric-parens-mark
(cperl-val 'cperl-electric-parens)
(memq last-command-event
@@ -2210,7 +2215,7 @@ Affected by `cperl-electric-parens'."
"Insert a construction appropriate after a keyword.
Help message may be switched off by setting `cperl-message-electric-keyword'
to nil."
- (let ((beg (save-excursion (beginning-of-line) (point)))
+ (let ((beg (point-at-bol))
(dollar (and (eq last-command-event ?$)
(eq this-command 'self-insert-command)))
(delete (and (memq last-command-event '(?\s ?\n ?\t ?\f))
@@ -2353,7 +2358,7 @@ to nil."
"Insert a construction appropriate after a keyword.
Help message may be switched off by setting `cperl-message-electric-keyword'
to nil."
- (let ((beg (save-excursion (beginning-of-line) (point))))
+ (let ((beg (point-at-bol)))
(and (save-excursion
(backward-sexp 1)
(cperl-after-expr-p nil "{;:"))
@@ -2392,8 +2397,8 @@ to nil."
"Go to end of line, open a new line and indent appropriately.
If in POD, insert appropriate lines."
(interactive)
- (let ((beg (save-excursion (beginning-of-line) (point)))
- (end (save-excursion (end-of-line) (point)))
+ (let ((beg (point-at-bol))
+ (end (point-at-eol))
(pos (point)) start over cut res)
(if (and ; Check if we need to split:
; i.e., on a boundary and inside "{...}"
@@ -2471,12 +2476,8 @@ If in POD, insert appropriate lines."
(forward-paragraph -1)
(forward-word 1)
(setq pos (point))
- (setq cut (buffer-substring (point)
- (save-excursion
- (end-of-line)
- (point))))
- (delete-char (- (save-excursion (end-of-line) (point))
- (point)))
+ (setq cut (buffer-substring (point) (point-at-eol)))
+ (delete-char (- (point-at-eol) (point)))
(setq res (expand-abbrev))
(save-excursion
(goto-char pos)
@@ -2941,8 +2942,7 @@ Will not look before LIM."
(point-max)))) ; do not loop if no syntaxification
;; label:
(t
- (save-excursion (end-of-line)
- (setq colon-line-end (point)))
+ (setq colon-line-end (point-at-eol))
(search-forward ":"))))
;; We are at beginning of code (NOT label or comment)
;; First, the following code counts
@@ -2984,8 +2984,7 @@ Will not look before LIM."
(looking-at "sub\\>")))
(setq p (nth 1 ; start of innermost containing list
(parse-partial-sexp
- (save-excursion (beginning-of-line)
- (point))
+ (point-at-bol)
(point)))))
(progn
(goto-char (1+ p)) ; enclosing block on the same line
@@ -3215,7 +3214,7 @@ the current line is to be regarded as part of a block comment."
Returns true if comment is found. In POD will not move the point."
;; If the line is inside other syntax groups (qq-style strings, HERE-docs)
;; then looks for literal # or end-of-line.
- (let (state stop-in cpoint (lim (progn (end-of-line) (point))) pr e)
+ (let (state stop-in cpoint (lim (point-at-eol)) pr e)
(or cperl-font-locking
(cperl-update-syntaxification lim lim))
(beginning-of-line)
@@ -3804,12 +3803,13 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
indentable t))
;; Need to remove face as well...
(goto-char min)
- (and (eq system-type 'emx)
+ ;; 'emx not supported by Emacs since at least 21.1.
+ (and (featurep 'xemacs) (eq system-type 'emx)
(eq (point) 1)
(let ((case-fold-search t))
(looking-at "extproc[ \t]")) ; Analogue of #!
(cperl-commentify min
- (save-excursion (end-of-line) (point))
+ (point-at-eol)
nil))
(while (and
(< (point) max)
@@ -4048,10 +4048,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
"")
tb (match-beginning 0))
(setq argument nil)
- (put-text-property (save-excursion
- (beginning-of-line)
- (point))
- b 'first-format-line 't)
+ (put-text-property (point-at-bol) b 'first-format-line 't)
(if cperl-pod-here-fontify
(while (and (eq (forward-line) 0)
(not (looking-at "^[.;]$")))
@@ -4997,7 +4994,7 @@ If `cperl-indent-region-fix-constructs', will improve spacing on
conditional/loop constructs."
(interactive)
(save-excursion
- (let ((tmp-end (progn (end-of-line) (point))) top done)
+ (let ((tmp-end (point-at-eol)) top done)
(save-excursion
(beginning-of-line)
(while (null done)
@@ -5040,13 +5037,9 @@ conditional/loop constructs."
"\\<\\(else\\|elsif\|continue\\)\\>"))
(progn
(goto-char (match-end 0))
- (save-excursion
- (end-of-line)
- (setq tmp-end (point))))
+ (setq tmp-end (point-at-eol)))
(setq done t))))
- (save-excursion
- (end-of-line)
- (setq tmp-end (point))))
+ (setq tmp-end (point-at-eol)))
(goto-char tmp-end)
(setq tmp-end (point-marker)))
(if cperl-indent-region-fix-constructs
@@ -5059,7 +5052,7 @@ Returns some position at the last line."
(interactive)
(or end
(setq end (point-max)))
- (let ((ee (save-excursion (end-of-line) (point)))
+ (let ((ee (point-at-eol))
(cperl-indent-region-fix-constructs
(or cperl-indent-region-fix-constructs 1))
p pp ml have-brace ret)
@@ -5212,7 +5205,7 @@ Returns some position at the last line."
(if (cperl-indent-line parse-data)
(setq ret (cperl-fix-line-spacing end parse-data)))))))))))
(beginning-of-line)
- (setq p (point) pp (save-excursion (end-of-line) (point))) ; May be different from ee.
+ (setq p (point) pp (point-at-eol)) ; May be different from ee.
;; Now check whether there is a hanging `}'
;; Looking at:
;; } blah
@@ -7046,7 +7039,7 @@ Use as
(or topdir
(setq topdir default-directory))
(let ((tags-file-name "TAGS")
- (case-fold-search (eq system-type 'emx))
+ (case-fold-search (and (featurep 'xemacs) (eq system-type 'emx)))
xs rel tm)
(save-excursion
(cond (inbuffer nil) ; Already there
@@ -7474,7 +7467,7 @@ Currently it is tuned to C and Perl syntax."
;; Get to the something meaningful
(or (eobp) (eolp) (forward-char 1))
(re-search-backward "[-a-zA-Z0-9_:!&*+,-./<=>?\\\\^|~$%@]"
- (save-excursion (beginning-of-line) (point))
+ (point-at-bol)
'to-beg)
;; (cond
;; ((or (eobp) (looking-at "[][ \t\n{}();,]")) ; Not at a symbol
@@ -8980,7 +8973,18 @@ do extra unwind via `cperl-unwind-to-safe'."
(substring v (match-beginning 1) (match-end 1)))
"Version of IZ-supported CPerl package this file is based on.")
+(defun cperl-mode-unload-function ()
+ "Unload the Cperl mode library."
+ (let ((new-mode (if (eq (symbol-function 'perl-mode) 'cperl-mode)
+ 'fundamental-mode
+ 'perl-mode)))
+ (dolist (buf (buffer-list))
+ (with-current-buffer buf
+ (when (eq major-mode 'cperl-mode)
+ (funcall new-mode)))))
+ ;; continue standard unloading
+ nil)
+
(provide 'cperl-mode)
-;; arch-tag: 42e5b19b-e187-4537-929f-1a7408980ce6
;;; cperl-mode.el ends here
diff --git a/lisp/progmodes/cwarn.el b/lisp/progmodes/cwarn.el
index e4b380995d5..00c11086ce1 100644
--- a/lisp/progmodes/cwarn.el
+++ b/lisp/progmodes/cwarn.el
@@ -6,7 +6,7 @@
;; Author: Anders Lindgren <andersl@andersl.com>
;; Keywords: c, languages, faces
;; X-Url: http://www.andersl.com/emacs
-;; Version: 1.3.1 1999-12-13
+;; Version: 1.3.1
;; This file is part of GNU Emacs.
diff --git a/lisp/progmodes/dcl-mode.el b/lisp/progmodes/dcl-mode.el
index c3a68c3be99..dd7aa0eddfb 100644
--- a/lisp/progmodes/dcl-mode.el
+++ b/lisp/progmodes/dcl-mode.el
@@ -1,7 +1,7 @@
;;; dcl-mode.el --- major mode for editing DCL command files
-;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+;; 2009, 2010 Free Software Foundation, Inc.
;; Author: Odd Gripenstam <gripenstamol@decus.se>
;; Maintainer: Odd Gripenstam <gripenstamol@decus.se>
@@ -821,7 +821,7 @@ by the numbers in order 1-2-3-1-... :
;; text
;; 1
- (let* ((default-limit (save-excursion (end-of-line) (1+ (point))))
+ (let* ((default-limit (1+ (line-end-position)))
(limit (or limit default-limit))
(last-good-point (point))
(opoint (point)))
@@ -1549,13 +1549,11 @@ Also remove the continuation mark if easily detected."
(interactive "*P")
(delete-indentation arg)
(let ((type (dcl-get-line-type)))
- (if (and (or (equal type '$)
- (equal type '-)
- (equal type 'empty-$))
+ (if (and (member type '($ - empty-$))
(not (bobp))
- (= (char-after (1- (point))) ?-))
+ (= (char-before) ?-))
(progn
- (delete-backward-char 1)
+ (delete-char -1)
(fixup-whitespace)))))
@@ -1785,7 +1783,7 @@ Set or update the value of VAR in the current buffers
(skip-chars-forward " \t")
(or (eolp)
(setq suffix-string (buffer-substring (point)
- (progn (end-of-line) (point)))))
+ (line-end-position))))
(goto-char (match-beginning 0))
(or (bolp)
(setq prefix-string
@@ -2216,5 +2214,4 @@ otherwise return nil."
(run-hooks 'dcl-mode-load-hook) ; for your customizations
-;; arch-tag: e00d421b-f26c-483e-a8bd-af412ea7764a
;;; dcl-mode.el ends here
diff --git a/lisp/progmodes/delphi.el b/lisp/progmodes/delphi.el
index 1e5f1f506b3..2558456bc07 100644
--- a/lisp/progmodes/delphi.el
+++ b/lisp/progmodes/delphi.el
@@ -628,7 +628,9 @@ routine.")
(defun delphi-token-at (p)
;; Returns the token from parsing text at point p.
(when (and (<= (point-min) p) (<= p (point-max)))
- (cond ((delphi-literal-token-at p))
+ (cond ((delphi-char-token-at p ?\n 'newline))
+
+ ((delphi-literal-token-at p))
((delphi-space-token-at p))
@@ -638,7 +640,6 @@ routine.")
((delphi-char-token-at p ?\) 'close-group))
((delphi-char-token-at p ?\[ 'open-group))
((delphi-char-token-at p ?\] 'close-group))
- ((delphi-char-token-at p ?\n 'newline))
((delphi-char-token-at p ?\; 'semicolon))
((delphi-char-token-at p ?. 'dot))
((delphi-char-token-at p ?, 'comma))
@@ -888,7 +889,24 @@ non-delphi buffer. Set to nil in a delphi buffer. To override, just do:
(setq token (delphi-block-start token)))
;; Regular block start found.
- ((delphi-is token-kind delphi-block-statements) (throw 'done token))
+ ((delphi-is token-kind delphi-block-statements)
+ (throw 'done
+ ;; As a special case, when a "case" block appears
+ ;; within a record declaration (to denote a variant
+ ;; part), the record declaration should be considered
+ ;; the enclosing block.
+ (if (eq 'case token-kind)
+ (let ((enclosing-token
+ (delphi-block-start token
+ 'stop-on-class)))
+ (if
+ (eq 'record
+ (delphi-token-kind enclosing-token))
+ (if stop-on-class
+ enclosing-token
+ (delphi-previous-token enclosing-token))
+ token))
+ token)))
;; A class/record start also begins a block.
((delphi-composite-type-start token last-token)
@@ -1058,6 +1076,7 @@ non-delphi buffer. Set to nil in a delphi buffer. To override, just do:
(token-kind nil)
(from-kind (delphi-token-kind from-token))
(last-colon nil)
+ (last-of nil)
(last-token nil))
(catch 'done
(while token
@@ -1101,9 +1120,17 @@ non-delphi buffer. Set to nil in a delphi buffer. To override, just do:
;; Ignore whitespace.
((delphi-is token-kind delphi-whitespace))
- ;; Remember any ':' we encounter, since that affects how we indent to
- ;; a case statement.
- ((eq 'colon token-kind) (setq last-colon token))
+ ;; Remember any "of" we encounter, since that affects how we
+ ;; indent to a case statement within a record declaration
+ ;; (i.e. a variant part).
+ ((eq 'of token-kind)
+ (setq last-of token))
+
+ ;; Remember any ':' we encounter (until we reach an "of"),
+ ;; since that affects how we indent to case statements in
+ ;; general.
+ ((eq 'colon token-kind)
+ (unless last-of (setq last-colon token)))
;; A case statement delimits a previous statement. We indent labels
;; specially.
diff --git a/lisp/progmodes/ebnf-abn.el b/lisp/progmodes/ebnf-abn.el
index 17173bd0458..a8741a30cf2 100644
--- a/lisp/progmodes/ebnf-abn.el
+++ b/lisp/progmodes/ebnf-abn.el
@@ -7,6 +7,7 @@
;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, ebnf, PostScript
;; Version: 1.2
+;; Package: ebnf2ps
;; This file is part of GNU Emacs.
diff --git a/lisp/progmodes/ebnf-bnf.el b/lisp/progmodes/ebnf-bnf.el
index 3c71f29b236..45f2fe727e8 100644
--- a/lisp/progmodes/ebnf-bnf.el
+++ b/lisp/progmodes/ebnf-bnf.el
@@ -7,6 +7,7 @@
;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, ebnf, PostScript
;; Version: 1.10
+;; Package: ebnf2ps
;; This file is part of GNU Emacs.
diff --git a/lisp/progmodes/ebnf-dtd.el b/lisp/progmodes/ebnf-dtd.el
index 2bd527a0222..2ca38406d4f 100644
--- a/lisp/progmodes/ebnf-dtd.el
+++ b/lisp/progmodes/ebnf-dtd.el
@@ -7,6 +7,7 @@
;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, ebnf, PostScript
;; Version: 1.1
+;; Package: ebnf2ps
;; This file is part of GNU Emacs.
diff --git a/lisp/progmodes/ebnf-ebx.el b/lisp/progmodes/ebnf-ebx.el
index 901c80a7225..dd94f9e638a 100644
--- a/lisp/progmodes/ebnf-ebx.el
+++ b/lisp/progmodes/ebnf-ebx.el
@@ -7,6 +7,7 @@
;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, ebnf, PostScript
;; Version: 1.2
+;; Package: ebnf2ps
;; This file is part of GNU Emacs.
diff --git a/lisp/progmodes/ebnf-iso.el b/lisp/progmodes/ebnf-iso.el
index ad5683cb7f5..fa1592bb17f 100644
--- a/lisp/progmodes/ebnf-iso.el
+++ b/lisp/progmodes/ebnf-iso.el
@@ -7,6 +7,7 @@
;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, ebnf, PostScript
;; Version: 1.9
+;; Package: ebnf2ps
;; This file is part of GNU Emacs.
diff --git a/lisp/progmodes/ebnf-otz.el b/lisp/progmodes/ebnf-otz.el
index a9c4838d9e1..b005d95a806 100644
--- a/lisp/progmodes/ebnf-otz.el
+++ b/lisp/progmodes/ebnf-otz.el
@@ -7,6 +7,7 @@
;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, ebnf, PostScript
;; Version: 1.0
+;; Package: ebnf2ps
;; This file is part of GNU Emacs.
diff --git a/lisp/progmodes/ebnf-yac.el b/lisp/progmodes/ebnf-yac.el
index e2a35dbc943..a7f1851cffb 100644
--- a/lisp/progmodes/ebnf-yac.el
+++ b/lisp/progmodes/ebnf-yac.el
@@ -7,6 +7,7 @@
;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, ebnf, PostScript
;; Version: 1.4
+;; Package: ebnf2ps
;; This file is part of GNU Emacs.
diff --git a/lisp/progmodes/ebnf2ps.el b/lisp/progmodes/ebnf2ps.el
index 201a091cc26..a4d1fe85c30 100644
--- a/lisp/progmodes/ebnf2ps.el
+++ b/lisp/progmodes/ebnf2ps.el
@@ -1,7 +1,7 @@
;;; ebnf2ps.el --- translate an EBNF to a syntactic chart on PostScript
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
@@ -5279,7 +5279,7 @@ killed after process termination."
(goto-char (point-min))
(and (search-forward "%%Creator: " nil t)
(not (search-forward "& ebnf2ps v"
- (save-excursion (end-of-line) (point))
+ (line-end-position)
t))
(progn
;; adjust creator comment
@@ -6395,5 +6395,4 @@ killed after process termination."
(provide 'ebnf2ps)
-;; arch-tag: 148bc8af-5398-468b-b922-eeb7afef3e4f
;;; ebnf2ps.el ends here
diff --git a/lisp/progmodes/ebrowse.el b/lisp/progmodes/ebrowse.el
index e32c453b91f..7101bf21ade 100644
--- a/lisp/progmodes/ebrowse.el
+++ b/lisp/progmodes/ebrowse.el
@@ -1,8 +1,8 @@
;;; ebrowse.el --- Emacs C++ class browser & tags facility
-;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation Inc.
+;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation Inc.
;; Author: Gerd Moellmann <gerd@gnu.org>
;; Maintainer: FSF
@@ -1313,7 +1313,7 @@ With PREFIX, insert that many filenames."
(skip-chars-forward " \t*a-zA-Z0-9_")
(setq start (point)
file-name-existing (looking-at "("))
- (delete-region start (save-excursion (end-of-line) (point)))
+ (delete-region start (line-end-position))
(unless file-name-existing
(indent-to ebrowse-source-file-column)
(insert "(" (or (ebrowse-cs-file
@@ -4491,5 +4491,4 @@ EVENT is the mouse event."
;; eval:(put 'ebrowse-for-all-trees 'lisp-indent-hook 1)
;; End:
-;; arch-tag: 4fa3c8bf-1771-479b-bcd7-b029c7c9677b
;;; ebrowse.el ends here
diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el
index 23e175cbe7d..0d11fd6423d 100644
--- a/lisp/progmodes/etags.el
+++ b/lisp/progmodes/etags.el
@@ -1,8 +1,8 @@
;;; etags.el --- etags facility for Emacs
-;; Copyright (C) 1985, 1986, 1988, 1989, 1992, 1993, 1994, 1995, 1996, 1998,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1986, 1988, 1989, 1992, 1993, 1994, 1995, 1996,
+;; 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+;; 2010 Free Software Foundation, Inc.
;; Author: Roland McGrath <roland@gnu.org>
;; Maintainer: FSF
@@ -40,6 +40,7 @@ If you set this variable, do not also set `tags-table-list'.
Use the `etags' program to make a tags table file.")
;; Make M-x set-variable tags-file-name like M-x visit-tags-table.
;;;###autoload (put 'tags-file-name 'variable-interactive (purecopy "fVisit tags table: "))
+;;;###autoload (put 'tags-file-name 'safe-local-variable 'stringp)
(defgroup etags nil "Tags tables."
:group 'tools)
@@ -67,12 +68,14 @@ Use the `etags' program to make a tags table file."
:type '(repeat file))
;;;###autoload
-(defcustom tags-compression-info-list (purecopy '("" ".Z" ".bz2" ".gz" ".tgz"))
+(defcustom tags-compression-info-list
+ (purecopy '("" ".Z" ".bz2" ".gz" ".xz" ".tgz"))
"*List of extensions tried by etags when jka-compr is used.
An empty string means search the non-compressed file.
These extensions will be tried only if jka-compr was activated
\(i.e. via customize of `auto-compression-mode' or by calling the function
`auto-compression-mode')."
+ :version "24.1" ; added xz
:type '(repeat string)
:group 'etags)
@@ -423,9 +426,9 @@ Returns non-nil if it is a valid table."
(if (get-file-buffer file)
;; The file is already in a buffer. Check for the visited file
;; having changed since we last used it.
- (let (win)
+ (progn
(set-buffer (get-file-buffer file))
- (setq win (or verify-tags-table-function (tags-table-mode)))
+ (or verify-tags-table-function (tags-table-mode))
(if (or (verify-visited-file-modtime (current-buffer))
;; Decide whether to revert the file.
;; revert-without-query can say to revert
@@ -471,7 +474,7 @@ Subroutine of `visit-tags-table-buffer'.
Looks for a tags table that has such tags or that includes a table
that has them. Returns the name of the first such table.
Non-nil CORE-ONLY means check only tags tables that are already in
-buffers. Nil CORE-ONLY is ignored."
+buffers. If CORE-ONLY is nil, it is ignored."
(let ((tables tags-table-computed-list)
(found nil))
;; Loop over the list, looking for a table containing tags for THIS-FILE.
@@ -787,6 +790,30 @@ tags table and its (recursively) included tags tables."
(let ((enable-recursive-minibuffers t))
(visit-tags-table-buffer))
(complete-with-action action (tags-completion-table) string pred))))))
+
+;;;###autoload (defun tags-completion-at-point-function ()
+;;;###autoload (if (or tags-table-list tags-file-name)
+;;;###autoload (progn
+;;;###autoload (load "etags")
+;;;###autoload (tags-completion-at-point-function))))
+
+(defun tags-completion-at-point-function ()
+ "Using tags, return a completion table for the text around point.
+If no tags table is loaded, do nothing and return nil."
+ (when (or tags-table-list tags-file-name)
+ (let ((completion-ignore-case (if (memq tags-case-fold-search '(t nil))
+ tags-case-fold-search
+ case-fold-search))
+ (pattern (funcall (or find-tag-default-function
+ (get major-mode 'find-tag-default-function)
+ 'find-tag-default)))
+ beg)
+ (when pattern
+ (save-excursion
+ (search-backward pattern) ;FIXME: will fail if we're inside pattern.
+ (setq beg (point))
+ (forward-char (length pattern))
+ (list beg (point) (tags-lazy-completion-table)))))))
(defun find-tag-tag (string)
"Read a tag name, with defaulting and completion."
@@ -1106,9 +1133,7 @@ error message."
;; Naive match found. Qualify the match.
(and (funcall (car order) pattern)
;; Make sure it is not a previous qualified match.
- (not (member (set-marker match-marker (save-excursion
- (beginning-of-line)
- (point)))
+ (not (member (set-marker match-marker (point-at-bol))
tag-lines-already-matched))
(throw 'qualified-match-found nil))
(if next-line-after-failure-p
@@ -1286,13 +1311,11 @@ buffer-local values of tags table format variables."
;; Find the end of the tag and record the whole tag text.
(search-forward "\177")
- (setq tag-text (buffer-substring (1- (point))
- (save-excursion (beginning-of-line)
- (point))))
+ (setq tag-text (buffer-substring (1- (point)) (point-at-bol)))
;; If use-explicit is non nil and explicit tag is present, use it as part of
;; return value. Else just skip it.
(setq explicit-start (point))
- (when (and (search-forward "\001" (save-excursion (forward-line 1) (point)) t)
+ (when (and (search-forward "\001" (point-at-bol 2) t)
use-explicit)
(setq tag-text (buffer-substring explicit-start (1- (point)))))
@@ -1654,7 +1677,7 @@ Point should be just after a string that matches TAG."
(save-excursion
(beginning-of-line)
(let ((bol (point)))
- (and (search-forward "\177" (save-excursion (end-of-line) (point)) t)
+ (and (search-forward "\177" (line-end-position) t)
(re-search-backward re bol t)))))
(defcustom tags-loop-revert-buffers nil
@@ -2039,20 +2062,10 @@ for \\[find-tag] (which see)."
(error "%s"
(substitute-command-keys
"No tags table loaded; try \\[visit-tags-table]")))
- (let ((completion-ignore-case (if (memq tags-case-fold-search '(t nil))
- tags-case-fold-search
- case-fold-search))
- (pattern (funcall (or find-tag-default-function
- (get major-mode 'find-tag-default-function)
- 'find-tag-default)))
- (comp-table (tags-lazy-completion-table))
- beg)
- (or pattern
- (error "Nothing to complete"))
- (search-backward pattern)
- (setq beg (point))
- (forward-char (length pattern))
- (completion-in-region beg (point) comp-table)))
+ (let ((comp-data (tags-completion-at-point-function)))
+ (if (null comp-data)
+ (error "Nothing to complete")
+ (apply 'completion-in-region comp-data))))
(dolist (x '("^No tags table in use; use .* to select one$"
"^There is no default tag$"
@@ -2069,5 +2082,4 @@ for \\[find-tag] (which see)."
(provide 'etags)
-;; arch-tag: b897c2b5-08f3-4837-b2d3-0e7d6db1b63e
;;; etags.el ends here
diff --git a/lisp/progmodes/f90.el b/lisp/progmodes/f90.el
index 0a3c96d7894..b6c42d2c550 100644
--- a/lisp/progmodes/f90.el
+++ b/lisp/progmodes/f90.el
@@ -657,6 +657,7 @@ Can be overridden by the value of `font-lock-maximum-decoration'.")
(define-key map "\C-c\C-f" 'f90-fill-region)
(define-key map "\C-c\C-p" 'f90-previous-statement)
(define-key map "\C-c\C-n" 'f90-next-statement)
+ (define-key map "\C-c]" 'f90-insert-end)
(define-key map "\C-c\C-w" 'f90-insert-end)
;; Standard tab binding will call this, and also handle regions.
;;; (define-key map "\t" 'f90-indent-line)
@@ -1008,7 +1009,7 @@ Set subexpression 1 in the match-data to the name of the type."
:regexp "\\(?:[^[:word:]_`]\\|^\\)\\(`?[[:word:]_]+\\)[^[:word:]_]*")
;;;###autoload
-(defun f90-mode ()
+(define-derived-mode f90-mode prog-mode "F90"
"Major mode for editing Fortran 90,95 code in free format.
For fixed format code, use `fortran-mode'.
@@ -1065,13 +1066,9 @@ Variables controlling indentation style and extra features:
Turning on F90 mode calls the value of the variable `f90-mode-hook'
with no args, if that value is non-nil."
- (interactive)
- (kill-all-local-variables)
- (setq major-mode 'f90-mode
- mode-name "F90"
- local-abbrev-table f90-mode-abbrev-table)
- (set-syntax-table f90-mode-syntax-table)
- (use-local-map f90-mode-map)
+ :group 'f90
+ :syntax-table f90-mode-syntax-table
+ :abbrev-table f90-mode-abbrev-table
(set (make-local-variable 'indent-line-function) 'f90-indent-line)
(set (make-local-variable 'indent-region-function) 'f90-indent-region)
(set (make-local-variable 'require-final-newline) mode-require-final-newline)
@@ -1094,8 +1091,7 @@ with no args, if that value is non-nil."
'f90-beginning-of-subprogram)
(set (make-local-variable 'end-of-defun-function) 'f90-end-of-subprogram)
(set (make-local-variable 'add-log-current-defun-function)
- #'f90-current-defun)
- (run-mode-hooks 'f90-mode-hook))
+ #'f90-current-defun))
;; Inline-functions.
diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el
index 712af6fd288..6346ab50e96 100644
--- a/lisp/progmodes/flymake.el
+++ b/lisp/progmodes/flymake.el
@@ -106,16 +106,6 @@ Zero-length substrings at the beginning and end of the list are omitted."
'temp-directory
(lambda () temporary-file-directory)))
-(defalias 'flymake-line-beginning-position
- (if (fboundp 'line-beginning-position)
- 'line-beginning-position
- (lambda (&optional arg) (save-excursion (beginning-of-line arg) (point)))))
-
-(defalias 'flymake-line-end-position
- (if (fboundp 'line-end-position)
- 'line-end-position
- (lambda (&optional arg) (save-excursion (end-of-line arg) (point)))))
-
(defun flymake-posn-at-point-as-event (&optional position window dx dy)
"Return pixel position of top left corner of glyph at POSITION,
relative to top left corner of WINDOW, as a mouse-1 click
@@ -808,8 +798,8 @@ Return t if it has at least one flymake overlay, nil if no overlay."
Perhaps use text from LINE-ERR-INFO-LIST to enhance highlighting."
(goto-char (point-min))
(forward-line (1- line-no))
- (let* ((line-beg (flymake-line-beginning-position))
- (line-end (flymake-line-end-position))
+ (let* ((line-beg (point-at-bol))
+ (line-end (point-at-eol))
(beg line-beg)
(end line-end)
(tooltip-text (flymake-ler-text (nth 0 line-err-info-list)))
@@ -1764,5 +1754,4 @@ Use CREATE-TEMP-F for creating temp copy."
(provide 'flymake)
-;; arch-tag: 8f0d6090-061d-4cac-8862-7c151c4a02dd
;;; flymake.el ends here
diff --git a/lisp/progmodes/fortran.el b/lisp/progmodes/fortran.el
index 3784ba787c4..c8bbbf48343 100644
--- a/lisp/progmodes/fortran.el
+++ b/lisp/progmodes/fortran.el
@@ -488,13 +488,22 @@ Consists of level 3 plus all other intrinsics not already highlighted.")
;; (We can do so for F90-style). Therefore an unmatched quote in a
;; standard comment will throw fontification off on the wrong track.
;; So we do syntactic fontification with regexps.
-(defun fortran-font-lock-syntactic-keywords ()
- "Return a value for `font-lock-syntactic-keywords' in Fortran mode.
-This varies according to the value of `fortran-line-length'.
+(defun fortran-make-syntax-propertize-function (line-length)
+ "Return a value for `syntax-propertize-function' in Fortran mode.
+This varies according to the value of LINE-LENGTH.
This is used to fontify fixed-format Fortran comments."
- `(("^[cd\\*]" 0 (11))
- (,(format "^[^cd\\*\t\n].\\{%d\\}\\([^\n]+\\)" (1- fortran-line-length))
- 1 (11))))
+ ;; This results in a non-byte-compiled function. We could pass it through
+ ;; `byte-compile', but simple benchmarks indicate that it's probably not
+ ;; worth the trouble (about ½% of slow down).
+ (eval ;I hate `eval', but it's hard to avoid it here.
+ `(syntax-propertize-rules
+ ("^[cd\\*]" (0 "<"))
+ ;; We mark all chars after line-length as "comment-start", rather than
+ ;; just the first one. This is so that a closing ' that's past the
+ ;; line-length will indeed be ignored (and will result in a string that
+ ;; leaks into subsequent lines).
+ ((format "^[^cd\\*\t\n].\\{%d\\}\\(.+\\)" (1- line-length))
+ (1 "<")))))
(defvar fortran-font-lock-keywords fortran-font-lock-keywords-1
"Default expressions to highlight in Fortran mode.")
@@ -778,7 +787,7 @@ Used in the Fortran entry in `hs-special-modes-alist'.")
;;;###autoload
-(defun fortran-mode ()
+(define-derived-mode fortran-mode prog-mode "Fortran"
"Major mode for editing Fortran code in fixed format.
For free format code, use `f90-mode'.
@@ -848,13 +857,9 @@ Variables controlling indentation style and extra features:
Turning on Fortran mode calls the value of the variable `fortran-mode-hook'
with no args, if that value is non-nil."
- (interactive)
- (kill-all-local-variables)
- (setq major-mode 'fortran-mode
- mode-name "Fortran"
- local-abbrev-table fortran-mode-abbrev-table)
- (set-syntax-table fortran-mode-syntax-table)
- (use-local-map fortran-mode-map)
+ :group 'fortran
+ :syntax-table fortran-mode-syntax-table
+ :abbrev-table fortran-mode-abbrev-table
(set (make-local-variable 'indent-line-function) 'fortran-indent-line)
(set (make-local-variable 'indent-region-function)
(lambda (start end)
@@ -891,9 +896,9 @@ with no args, if that value is non-nil."
fortran-font-lock-keywords-3
fortran-font-lock-keywords-4)
nil t ((?/ . "$/") ("_$" . "w"))
- fortran-beginning-of-subprogram
- (font-lock-syntactic-keywords
- . fortran-font-lock-syntactic-keywords)))
+ fortran-beginning-of-subprogram))
+ (set (make-local-variable 'syntax-propertize-function)
+ (fortran-make-syntax-propertize-function fortran-line-length))
(set (make-local-variable 'imenu-case-fold-search) t)
(set (make-local-variable 'imenu-generic-expression)
fortran-imenu-generic-expression)
@@ -906,33 +911,37 @@ with no args, if that value is non-nil."
#'fortran-current-defun)
(set (make-local-variable 'dabbrev-case-fold-search) 'case-fold-search)
(set (make-local-variable 'gud-find-expr-function) 'fortran-gud-find-expr)
- (add-hook 'hack-local-variables-hook 'fortran-hack-local-variables nil t)
- (run-mode-hooks 'fortran-mode-hook))
+ (add-hook 'hack-local-variables-hook 'fortran-hack-local-variables nil t))
(defun fortran-line-length (nchars &optional global)
"Set the length of fixed-form Fortran lines to NCHARS.
This normally only affects the current buffer, which must be in
Fortran mode. If the optional argument GLOBAL is non-nil, it
-affects all Fortran buffers, and also the default."
- (interactive "p")
- (let (new)
- (mapc (lambda (buff)
- (with-current-buffer buff
- (when (eq major-mode 'fortran-mode)
- (setq fortran-line-length nchars
- fill-column fortran-line-length
- new (fortran-font-lock-syntactic-keywords))
- ;; Refontify only if necessary.
- (unless (equal new font-lock-syntactic-keywords)
- (setq font-lock-syntactic-keywords
- (fortran-font-lock-syntactic-keywords))
- (if font-lock-mode (font-lock-mode 1))))))
+affects all Fortran buffers, and also the default.
+If a numeric prefix argument is specified, it will be used as NCHARS,
+otherwise is a non-numeric prefix arg is specified, the length will be
+provided via the minibuffer, and otherwise the current column is used."
+ (interactive
+ (list (cond
+ ((numberp current-prefix-arg) current-prefix-arg)
+ (current-prefix-arg
+ (read-number "Line length: " (default-value 'fortran-line-length)))
+ (t (current-column)))))
+ (dolist (buff (if global
+ (buffer-list)
+ (list (current-buffer))))
+ (with-current-buffer buff
+ (when (derived-mode-p 'fortran-mode)
+ (unless (eq fortran-line-length nchars)
+ (setq fortran-line-length nchars
+ fill-column fortran-line-length
+ syntax-propertize-function
+ (fortran-make-syntax-propertize-function nchars))
+ (syntax-ppss-flush-cache (point-min))
+ (if font-lock-mode (font-lock-mode 1))))))
(if global
- (buffer-list)
- (list (current-buffer))))
- (if global
- (setq-default fortran-line-length nchars))))
+ (setq-default fortran-line-length nchars)))
(defun fortran-hack-local-variables ()
"Fortran mode adds this to `hack-local-variables-hook'."
@@ -1306,8 +1315,7 @@ Directive lines are treated as comments."
(if i
(save-excursion
(goto-char i)
- (beginning-of-line)
- (= (point) p)))))
+ (= (line-beginning-position) p)))))
;; Used in hs-special-modes-alist.
(defun fortran-end-of-block (&optional num)
@@ -2198,5 +2206,4 @@ arg DO-SPACE prevents stripping the whitespace."
(provide 'fortran)
-;; arch-tag: 74935096-21c4-4cab-8ee5-6ef16090dc04
;;; fortran.el ends here
diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el
new file mode 100644
index 00000000000..3019f8bbf04
--- /dev/null
+++ b/lisp/progmodes/gdb-mi.el
@@ -0,0 +1,4195 @@
+;;; gdb-mi.el --- User Interface for running GDB
+
+;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Nick Roberts <nickrob@gnu.org>
+;; Maintainer: FSF
+;; Keywords: unix, tools
+
+;; This file is part of GNU Emacs.
+
+;; Homepage: http://www.emacswiki.org/emacs/GDB-MI
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Credits:
+
+;; This file was written by by Nick Roberts following the general design
+;; used in gdb-ui.el for Emacs 22.1 - 23.1. It is currently being developed
+;; by Dmitry Dzhus <dima@sphinx.net.ru> as part of the Google Summer
+;; of Code 2009 Project "Emacs GDB/MI migration".
+
+;;; Commentary:
+
+;; This mode acts as a graphical user interface to GDB. You can interact with
+;; GDB through the GUD buffer in the usual way, but there are also further
+;; buffers which control the execution and describe the state of your program.
+;; It separates the input/output of your program from that of GDB and displays
+;; expressions and their current values in their own buffers. It also uses
+;; features of Emacs 21 such as the fringe/display margin for breakpoints, and
+;; the toolbar (see the GDB Graphical Interface section in the Emacs info
+;; manual).
+
+;; M-x gdb will start the debugger.
+
+;; This file 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 (as
+;; used in gdb-ui.el) to GDB/MI. It runs gdb with GDB/MI (-interp=mi) and
+;; access CLI using "-interpreter-exec console cli-command". This code works
+;; without gdb-ui.el and uses MI tokens instead of queues. Eventually MI
+;; should be asynchronous.
+
+;; This mode will PARTLY WORK WITH RECENT GDB RELEASES (status in modeline
+;; doesn't update properly when execution commands are issued from GUD buffer)
+;; and WORKS BEST when GDB runs asynchronously: maint set linux-async on.
+;;
+;; You need development version of GDB 7.0 for the thread buffer to work.
+
+;; This file replaces gdb-ui.el and is for development with GDB. Use the
+;; release branch of Emacs 22 for the latest version of gdb-ui.el.
+
+;; Windows Platforms:
+
+;; If you are using Emacs and GDB on Windows you will need to flush the buffer
+;; explicitly in your program if you want timely display of I/O in Emacs.
+;; Alternatively you can make the output stream unbuffered, for example, by
+;; using a macro:
+
+;; #ifdef UNBUFFERED
+;; setvbuf (stdout, (char *) NULL, _IONBF, 0);
+;; #endif
+
+;; and compiling with -DUNBUFFERED while debugging.
+
+;; If you are using Cygwin GDB and find that the source is not being displayed
+;; in Emacs when you step through it, possible solutions are to:
+
+;; 1) Use Cygwin X Windows and Cygwin Emacs.
+;; (Since 22.1 Emacs builds under Cygwin.)
+;; 2) Use MinGW GDB instead.
+;; 3) Use cygwin-mount.el
+
+;;; Mac OSX:
+
+;; GDB in Emacs on Mac OSX works best with FSF GDB as Apple have made
+;; some changes to the version that they include as part of Mac OSX.
+;; This requires GDB version 7.0 or later (estimated release date Aug 2009)
+;; as earlier versions don not compile on Mac OSX.
+
+;;; Known Bugs:
+
+;; 1) Stack buffer doesn't parse MI output if you stop in a routine without
+;; line information, e.g., a routine in libc (just a TODO item).
+
+;; TODO:
+;; 2) Watch windows to work with threads.
+;; 3) Use treebuffer.el instead of the speedbar for watch-expressions?
+;; 4) Mark breakpoint locations on scroll-bar of source buffer?
+
+;;; Code:
+
+(require 'gud)
+(require 'json)
+(require 'bindat)
+(eval-when-compile (require 'cl))
+
+(defvar tool-bar-map)
+(defvar speedbar-initial-expansion-list-name)
+(defvar speedbar-frame)
+
+(defvar gdb-memory-address "main")
+(defvar gdb-memory-last-address nil
+ "Last successfully accessed memory address.")
+(defvar gdb-memory-next-page nil
+ "Address of next memory page for program memory buffer.")
+(defvar gdb-memory-prev-page nil
+ "Address of previous memory page for program memory buffer.")
+
+(defvar gdb-thread-number nil
+ "Main current thread.
+
+Invalidation triggers use this variable to query GDB for
+information on the specified thread by wrapping GDB/MI commands
+in `gdb-current-context-command'.
+
+This variable may be updated implicitly by GDB via `gdb-stopped'
+or explicitly by `gdb-select-thread'.
+
+Only `gdb-setq-thread-number' should be used to change this
+value.")
+
+(defvar gdb-frame-number nil
+ "Selected frame level for main current thread.
+
+Updated according to the following rules:
+
+When a thread is selected or current thread stops, set to \"0\".
+
+When current thread goes running (and possibly exits eventually),
+set to nil.
+
+May be manually changed by user with `gdb-select-frame'.")
+
+(defvar gdb-frame-address nil "Identity of frame for watch expression.")
+
+;; Used to show overlay arrow in source buffer. All set in
+;; gdb-get-main-selected-frame. Disassembly buffer should not use
+;; these but rely on buffer-local thread information instead.
+(defvar gdb-selected-frame nil
+ "Name of selected function for main current thread.")
+(defvar gdb-selected-file nil
+ "Name of selected file for main current thread.")
+(defvar gdb-selected-line nil
+ "Number of selected line for main current thread.")
+
+(defvar gdb-threads-list nil
+ "Associative list of threads provided by \"-thread-info\" MI command.
+
+Keys are thread numbers (in strings) and values are structures as
+returned from -thread-info by `gdb-json-partial-output'. Updated in
+`gdb-thread-list-handler-custom'.")
+
+(defvar gdb-running-threads-count nil
+ "Number of currently running threads.
+
+If nil, no information is available.
+
+Updated in `gdb-thread-list-handler-custom'.")
+
+(defvar gdb-stopped-threads-count nil
+ "Number of currently stopped threads.
+
+See also `gdb-running-threads-count'.")
+
+(defvar gdb-breakpoints-list nil
+ "Associative list of breakpoints provided by \"-break-list\" MI command.
+
+Keys are breakpoint numbers (in string) and values are structures
+as returned from \"-break-list\" by `gdb-json-partial-output'
+\(\"body\" field is used). Updated in
+`gdb-breakpoints-list-handler-custom'.")
+
+(defvar gdb-current-language nil)
+(defvar gdb-var-list nil
+ "List of variables in watch window.
+Each element has the form (VARNUM EXPRESSION NUMCHILD TYPE VALUE STATUS HAS_MORE FP)
+where STATUS is nil (`unchanged'), `changed' or `out-of-scope', FP the frame
+address for root variables.")
+(defvar gdb-main-file nil "Source file from which program execution begins.")
+
+;; Overlay arrow markers
+(defvar gdb-stack-position nil)
+(defvar gdb-thread-position nil)
+(defvar gdb-disassembly-position nil)
+
+(defvar gdb-location-alist nil
+ "Alist of breakpoint numbers and full filenames. Only used for files that
+Emacs can't find.")
+(defvar gdb-active-process nil
+ "GUD tooltips display variable values when t, and macro definitions otherwise.")
+(defvar gdb-error "Non-nil when GDB is reporting an error.")
+(defvar gdb-macro-info nil
+ "Non-nil if GDB knows that the inferior includes preprocessor macro info.")
+(defvar gdb-register-names nil "List of register names.")
+(defvar gdb-changed-registers nil
+ "List of changed register numbers (strings).")
+(defvar gdb-buffer-fringe-width nil)
+(defvar gdb-last-command nil)
+(defvar gdb-prompt-name nil)
+(defvar gdb-token-number 0)
+(defvar gdb-handler-alist '())
+(defvar gdb-handler-number nil)
+(defvar gdb-source-file-list nil
+ "List of source files for the current executable.")
+(defvar gdb-first-done-or-error t)
+(defvar gdb-source-window nil)
+(defvar gdb-inferior-status nil)
+(defvar gdb-continuation nil)
+(defvar gdb-version nil)
+(defvar gdb-filter-output nil
+ "Message to be shown in GUD console.
+
+This variable is updated in `gdb-done-or-error' and returned by
+`gud-gdbmi-marker-filter'.")
+
+(defvar gdb-non-stop nil
+ "Indicates whether current GDB session is using non-stop mode.
+
+It is initialized to `gdb-non-stop-setting' at the beginning of
+every GDB session.")
+
+(defvar gdb-buffer-type nil
+ "One of the symbols bound in `gdb-buffer-rules'.")
+(make-variable-buffer-local 'gdb-buffer-type)
+
+(defvar gdb-output-sink 'nil
+ "The disposition of the output of the current gdb command.
+Possible values are these symbols:
+
+ `user' -- gdb output should be copied to the GUD buffer
+ for the user to see.
+
+ `emacs' -- output should be collected in the partial-output-buffer
+ for subsequent processing by a command. This is the
+ disposition of output generated by commands that
+ gdb mode sends to gdb on its own behalf.")
+
+;; Pending triggers prevent congestion: Emacs won't send two similar
+;; consecutive requests.
+
+(defvar gdb-pending-triggers '()
+ "A list of trigger functions which have not yet been handled.
+
+Elements are either function names or pairs (buffer . function)")
+
+(defmacro gdb-add-pending (item)
+ `(push ,item gdb-pending-triggers))
+(defmacro gdb-pending-p (item)
+ `(member ,item gdb-pending-triggers))
+(defmacro gdb-delete-pending (item)
+ `(setq gdb-pending-triggers
+ (delete ,item gdb-pending-triggers)))
+
+(defmacro gdb-wait-for-pending (&rest body)
+ "Wait until `gdb-pending-triggers' is empty and evaluate FORM.
+
+This function checks `gdb-pending-triggers' value every
+`gdb-wait-for-pending' seconds."
+ (run-with-timer
+ 0.5 nil
+ `(lambda ()
+ (if (not gdb-pending-triggers)
+ (progn ,@body)
+ (gdb-wait-for-pending ,@body)))))
+
+;; Publish-subscribe
+
+(defmacro gdb-add-subscriber (publisher subscriber)
+ "Register new PUBLISHER's SUBSCRIBER.
+
+SUBSCRIBER must be a pair, where cdr is a function of one
+argument (see `gdb-emit-signal')."
+ `(add-to-list ',publisher ,subscriber t))
+
+(defmacro gdb-delete-subscriber (publisher subscriber)
+ "Unregister SUBSCRIBER from PUBLISHER."
+ `(setq ,publisher (delete ,subscriber
+ ,publisher)))
+
+(defun gdb-get-subscribers (publisher)
+ publisher)
+
+(defun gdb-emit-signal (publisher &optional signal)
+ "Call cdr for each subscriber of PUBLISHER with SIGNAL as argument."
+ (dolist (subscriber (gdb-get-subscribers publisher))
+ (funcall (cdr subscriber) signal)))
+
+(defvar gdb-buf-publisher '()
+ "Used to invalidate GDB buffers by emitting a signal in
+`gdb-update'.
+
+Must be a list of pairs with cars being buffers and cdr's being
+valid signal handlers.")
+
+(defgroup gdb nil
+ "GDB graphical interface"
+ :group 'tools
+ :link '(info-link "(emacs)GDB Graphical Interface")
+ :version "23.2")
+
+(defgroup gdb-non-stop nil
+ "GDB non-stop debugging settings"
+ :group 'gdb
+ :version "23.2")
+
+(defgroup gdb-buffers nil
+ "GDB buffers"
+ :group 'gdb
+ :version "23.2")
+
+(defcustom gdb-debug-log-max 128
+ "Maximum size of `gdb-debug-log'. If nil, size is unlimited."
+ :group 'gdb
+ :type '(choice (integer :tag "Number of elements")
+ (const :tag "Unlimited" nil))
+ :version "22.1")
+
+(defcustom gdb-non-stop-setting t
+ "When in non-stop mode, stopped threads can be examined while
+other threads continue to execute.
+
+GDB session needs to be restarted for this setting to take
+effect."
+ :type 'boolean
+ :group 'gdb-non-stop
+ :version "23.2")
+
+;; TODO Some commands can't be called with --all (give a notice about
+;; it in setting doc)
+(defcustom gdb-gud-control-all-threads t
+ "When enabled, GUD execution commands affect all threads when
+in non-stop mode. Otherwise, only current thread is affected."
+ :type 'boolean
+ :group 'gdb-non-stop
+ :version "23.2")
+
+(defcustom gdb-switch-reasons t
+ "List of stop reasons which cause Emacs to switch to the thread
+which caused the stop. When t, switch to stopped thread no matter
+what the reason was. When nil, never switch to stopped thread
+automatically.
+
+This setting is used in non-stop mode only. In all-stop mode,
+Emacs always switches to the thread which caused the stop."
+ ;; exited, exited-normally and exited-signalled are not
+ ;; thread-specific stop reasons and therefore are not included in
+ ;; this list
+ :type '(choice
+ (const :tag "All reasons" t)
+ (set :tag "Selection of reasons..."
+ (const :tag "A breakpoint was reached." "breakpoint-hit")
+ (const :tag "A watchpoint was triggered." "watchpoint-trigger")
+ (const :tag "A read watchpoint was triggered." "read-watchpoint-trigger")
+ (const :tag "An access watchpoint was triggered." "access-watchpoint-trigger")
+ (const :tag "Function finished execution." "function-finished")
+ (const :tag "Location reached." "location-reached")
+ (const :tag "Watchpoint has gone out of scope" "watchpoint-scope")
+ (const :tag "End of stepping range reached." "end-stepping-range")
+ (const :tag "Signal received (like interruption)." "signal-received"))
+ (const :tag "None" nil))
+ :group 'gdb-non-stop
+ :version "23.2"
+ :link '(info-link "(gdb)GDB/MI Async Records"))
+
+(defcustom gdb-stopped-hooks nil
+ "This variable holds a list of functions to be called whenever
+GDB stops.
+
+Each function takes one argument, a parsed MI response, which
+contains fields of corresponding MI *stopped async record:
+
+ ((stopped-threads . \"all\")
+ (thread-id . \"1\")
+ (frame (line . \"38\")
+ (fullname . \"/home/sphinx/projects/gsoc/server.c\")
+ (file . \"server.c\")
+ (args ((value . \"0x804b038\")
+ (name . \"arg\")))
+ (func . \"hello\")
+ (addr . \"0x0804869e\"))
+ (reason . \"end-stepping-range\"))
+
+Note that \"reason\" is only present in non-stop debugging mode.
+
+`bindat-get-field' may be used to access the fields of response.
+
+Each function is called after the new current thread was selected
+and GDB buffers were updated in `gdb-stopped'."
+ :type '(repeat function)
+ :group 'gdb
+ :version "23.2"
+ :link '(info-link "(gdb)GDB/MI Async Records"))
+
+(defcustom gdb-switch-when-another-stopped t
+ "When nil, Emacs won't switch to stopped thread if some other
+stopped thread is already selected."
+ :type 'boolean
+ :group 'gdb-non-stop
+ :version "23.2")
+
+(defcustom gdb-stack-buffer-locations t
+ "Show file information or library names in stack buffers."
+ :type 'boolean
+ :group 'gdb-buffers
+ :version "23.2")
+
+(defcustom gdb-stack-buffer-addresses nil
+ "Show frame addresses in stack buffers."
+ :type 'boolean
+ :group 'gdb-buffers
+ :version "23.2")
+
+(defcustom gdb-thread-buffer-verbose-names t
+ "Show long thread names in threads buffer."
+ :type 'boolean
+ :group 'gdb-buffers
+ :version "23.2")
+
+(defcustom gdb-thread-buffer-arguments t
+ "Show function arguments in threads buffer."
+ :type 'boolean
+ :group 'gdb-buffers
+ :version "23.2")
+
+(defcustom gdb-thread-buffer-locations t
+ "Show file information or library names in threads buffer."
+ :type 'boolean
+ :group 'gdb-buffers
+ :version "23.2")
+
+(defcustom gdb-thread-buffer-addresses nil
+ "Show addresses for thread frames in threads buffer."
+ :type 'boolean
+ :group 'gdb-buffers
+ :version "23.2")
+
+(defcustom gdb-show-threads-by-default nil
+ "Show threads list buffer instead of breakpoints list by
+default."
+ :type 'boolean
+ :group 'gdb-buffers
+ :version "23.2")
+
+(defvar gdb-debug-log nil
+ "List of commands sent to and replies received from GDB.
+Most recent commands are listed first. This list stores only the last
+`gdb-debug-log-max' values. This variable is used to debug GDB-MI.")
+
+;;;###autoload
+(defcustom gdb-enable-debug nil
+ "Non-nil means record the process input and output in `gdb-debug-log'."
+ :type 'boolean
+ :group 'gdb
+ :version "22.1")
+
+(defcustom gdb-cpp-define-alist-program "gcc -E -dM -"
+ "Shell command for generating a list of defined macros in a source file.
+This list is used to display the #define directive associated
+with an identifier as a tooltip. It works in a debug session with
+GDB, when `gud-tooltip-mode' is t.
+
+Set `gdb-cpp-define-alist-flags' for any include paths or
+predefined macros."
+ :type 'string
+ :group 'gdb
+ :version "22.1")
+
+(defcustom gdb-cpp-define-alist-flags ""
+ "Preprocessor flags for `gdb-cpp-define-alist-program'."
+ :type 'string
+ :group 'gdb
+ :version "22.1")
+
+ (defcustom gdb-create-source-file-list t
+ "Non-nil means create a list of files from which the executable was built.
+ Set this to nil if the GUD buffer displays \"initializing...\" in the mode
+ line for a long time when starting, possibly because your executable was
+ built from a large number of files. This allows quicker initialization
+ but means that these files are not automatically enabled for debugging,
+ e.g., you won't be able to click in the fringe to set a breakpoint until
+ execution has already stopped there."
+ :type 'boolean
+ :group 'gdb
+ :version "23.1")
+
+(defcustom gdb-show-main nil
+ "Non-nil means display source file containing the main routine at startup.
+Also display the main routine in the disassembly buffer if present."
+ :type 'boolean
+ :group 'gdb
+ :version "22.1")
+
+(defun gdb-force-mode-line-update (status)
+ (let ((buffer gud-comint-buffer))
+ (if (and buffer (buffer-name buffer))
+ (with-current-buffer buffer
+ (setq mode-line-process
+ (format ":%s [%s]"
+ (process-status (get-buffer-process buffer)) status))
+ ;; Force mode line redisplay soon.
+ (force-mode-line-update)))))
+
+(defun gdb-enable-debug (arg)
+ "Toggle logging of transaction between Emacs and Gdb.
+The log is stored in `gdb-debug-log' as an alist with elements
+whose cons is send, send-item or recv and whose cdr is the string
+being transferred. This list may grow up to a size of
+`gdb-debug-log-max' after which the oldest element (at the end of
+the list) is deleted every time a new one is added (at the front)."
+ (interactive "P")
+ (setq gdb-enable-debug
+ (if (null arg)
+ (not gdb-enable-debug)
+ (> (prefix-numeric-value arg) 0)))
+ (message (format "Logging of transaction %sabled"
+ (if gdb-enable-debug "en" "dis"))))
+
+;; These two are used for menu and toolbar
+(defun gdb-control-all-threads ()
+ "Switch to non-stop/A mode."
+ (interactive)
+ (setq gdb-gud-control-all-threads t)
+ ;; Actually forcing the tool-bar to update.
+ (force-mode-line-update)
+ (message "Now in non-stop/A mode."))
+
+(defun gdb-control-current-thread ()
+ "Switch to non-stop/T mode."
+ (interactive)
+ (setq gdb-gud-control-all-threads nil)
+ ;; Actually forcing the tool-bar to update.
+ (force-mode-line-update)
+ (message "Now in non-stop/T mode."))
+
+(defun gdb-find-watch-expression ()
+ (let* ((var (nth (- (line-number-at-pos (point)) 2) gdb-var-list))
+ (varnum (car var)) expr array)
+ (string-match "\\(var[0-9]+\\)\\.\\(.*\\)" varnum)
+ (let ((var1 (assoc (match-string 1 varnum) gdb-var-list)) var2 varnumlet
+ (component-list (split-string (match-string 2 varnum) "\\." t)))
+ (setq expr (nth 1 var1))
+ (setq varnumlet (car var1))
+ (dolist (component component-list)
+ (setq var2 (assoc varnumlet gdb-var-list))
+ (setq expr (concat expr
+ (if (string-match ".*\\[[0-9]+\\]$" (nth 3 var2))
+ (concat "[" component "]")
+ (concat "." component))))
+ (setq varnumlet (concat varnumlet "." component)))
+ expr)))
+
+;; noall is used for commands which don't take --all, but only
+;; --thread.
+(defun gdb-gud-context-command (command &optional noall)
+ "When `gdb-non-stop' is t, add --thread option to COMMAND if
+`gdb-gud-control-all-threads' is nil and --all option otherwise.
+If NOALL is t, always add --thread option no matter what
+`gdb-gud-control-all-threads' value is.
+
+When `gdb-non-stop' is nil, return COMMAND unchanged."
+ (if gdb-non-stop
+ (if (and gdb-gud-control-all-threads
+ (not noall)
+ (string-equal gdb-version "7.0+"))
+ (concat command " --all ")
+ (gdb-current-context-command command))
+ command))
+
+(defmacro gdb-gud-context-call (cmd1 &optional cmd2 noall noarg)
+ "`gud-call' wrapper which adds --thread/--all options between
+CMD1 and CMD2. NOALL is the same as in `gdb-gud-context-command'.
+
+NOARG must be t when this macro is used outside `gud-def'"
+ `(gud-call
+ (concat (gdb-gud-context-command ,cmd1 ,noall) " " ,cmd2)
+ ,(when (not noarg) 'arg)))
+
+;;;###autoload
+(defun gdb (command-line)
+ "Run gdb on program FILE in buffer *gud-FILE*.
+The directory containing FILE becomes the initial working directory
+and source-file directory for your debugger.
+
+If `gdb-many-windows' is nil (the default value) then gdb just
+pops up the GUD buffer unless `gdb-show-main' is t. In this case
+it starts with two windows: one displaying the GUD buffer and the
+other with the source file with the main routine of the inferior.
+
+If `gdb-many-windows' is t, regardless of the value of
+`gdb-show-main', the layout below will appear. Keybindings are
+shown in some of the buffers.
+
+Watch expressions appear in the speedbar/slowbar.
+
+The following commands 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 |
+| | |
+| | |
+| | |
++-----------------------------------+----------------------------------+
+| Source buffer | I/O buffer (of debugged program) |
+| | (comint-mode) |
+| | |
+| | |
+| | |
+| | |
+| | |
+| | |
++-----------------------------------+----------------------------------+
+| Stack buffer | Breakpoints buffer |
+| RET gdb-select-frame | SPC gdb-toggle-breakpoint |
+| | RET gdb-goto-breakpoint |
+| | D gdb-delete-breakpoint |
++-----------------------------------+----------------------------------+"
+ ;;
+ (interactive (list (gud-query-cmdline 'gdb)))
+
+ (when (and gud-comint-buffer
+ (buffer-name gud-comint-buffer)
+ (get-buffer-process gud-comint-buffer)
+ (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdba)))
+ (gdb-restore-windows)
+ (error
+ "Multiple debugging requires restarting in text command mode"))
+ ;;
+ (gud-common-init command-line nil 'gud-gdbmi-marker-filter)
+ (set (make-local-variable 'gud-minor-mode) 'gdbmi)
+ (setq comint-input-sender 'gdb-send)
+
+ (gud-def gud-tbreak "tbreak %f:%l" "\C-t"
+ "Set temporary breakpoint at current line.")
+ (gud-def gud-jump
+ (progn (gud-call "tbreak %f:%l") (gud-call "jump %f:%l"))
+ "\C-j" "Set execution address to current line.")
+
+ (gud-def gud-up "up %p" "<" "Up N stack frames (numeric arg).")
+ (gud-def gud-down "down %p" ">" "Down N stack frames (numeric arg).")
+ (gud-def gud-print "print %e" "\C-p" "Evaluate C expression at point.")
+ (gud-def gud-pstar "print* %e" nil
+ "Evaluate C dereferenced pointer expression at point.")
+
+ (gud-def gud-step (gdb-gud-context-call "-exec-step" "%p" t)
+ "\C-s"
+ "Step one source line with display.")
+ (gud-def gud-stepi (gdb-gud-context-call "-exec-step-instruction" "%p" t)
+ "\C-i"
+ "Step one instruction with display.")
+ (gud-def gud-next (gdb-gud-context-call "-exec-next" "%p" t)
+ "\C-n"
+ "Step one line (skip functions).")
+ (gud-def gud-nexti (gdb-gud-context-call "-exec-next-instruction" "%p" t)
+ nil
+ "Step one instruction (skip functions).")
+ (gud-def gud-cont (gdb-gud-context-call "-exec-continue")
+ "\C-r"
+ "Continue with display.")
+ (gud-def gud-finish (gdb-gud-context-call "-exec-finish" nil t)
+ "\C-f"
+ "Finish executing current function.")
+ (gud-def gud-run "-exec-run"
+ nil
+ "Run the program.")
+
+ (gud-def gud-break (if (not (string-match "Disassembly" mode-name))
+ (gud-call "break %f:%l" arg)
+ (save-excursion
+ (beginning-of-line)
+ (forward-char 2)
+ (gud-call "break *%a" arg)))
+ "\C-b" "Set breakpoint at current line or address.")
+
+ (gud-def gud-remove (if (not (string-match "Disassembly" mode-name))
+ (gud-call "clear %f:%l" arg)
+ (save-excursion
+ (beginning-of-line)
+ (forward-char 2)
+ (gud-call "clear *%a" arg)))
+ "\C-d" "Remove breakpoint at current line or address.")
+
+ ;; -exec-until doesn't support --all yet
+ (gud-def gud-until (if (not (string-match "Disassembly" mode-name))
+ (gud-call "-exec-until %f:%l" arg)
+ (save-excursion
+ (beginning-of-line)
+ (forward-char 2)
+ (gud-call "-exec-until *%a" arg)))
+ "\C-u" "Continue to current line or address.")
+ ;; TODO Why arg here?
+ (gud-def
+ gud-go (gud-call (if gdb-active-process
+ (gdb-gud-context-command "-exec-continue")
+ "-exec-run") arg)
+ nil "Start or continue execution.")
+
+ ;; For debugging Emacs only.
+ (gud-def gud-pp
+ (gud-call
+ (concat
+ "pp1 " (if (eq (buffer-local-value
+ 'major-mode (window-buffer)) 'speedbar-mode)
+ (gdb-find-watch-expression) "%e")) arg)
+ nil "Print the Emacs s-expression.")
+
+ (define-key gud-minor-mode-map [left-margin mouse-1]
+ 'gdb-mouse-set-clear-breakpoint)
+ (define-key gud-minor-mode-map [left-fringe mouse-1]
+ 'gdb-mouse-set-clear-breakpoint)
+ (define-key gud-minor-mode-map [left-margin C-mouse-1]
+ 'gdb-mouse-toggle-breakpoint-margin)
+ (define-key gud-minor-mode-map [left-fringe C-mouse-1]
+ 'gdb-mouse-toggle-breakpoint-fringe)
+
+ (define-key gud-minor-mode-map [left-margin drag-mouse-1]
+ 'gdb-mouse-until)
+ (define-key gud-minor-mode-map [left-fringe drag-mouse-1]
+ 'gdb-mouse-until)
+ (define-key gud-minor-mode-map [left-margin mouse-3]
+ 'gdb-mouse-until)
+ (define-key gud-minor-mode-map [left-fringe mouse-3]
+ 'gdb-mouse-until)
+
+ (define-key gud-minor-mode-map [left-margin C-drag-mouse-1]
+ 'gdb-mouse-jump)
+ (define-key gud-minor-mode-map [left-fringe C-drag-mouse-1]
+ 'gdb-mouse-jump)
+ (define-key gud-minor-mode-map [left-fringe C-mouse-3]
+ 'gdb-mouse-jump)
+ (define-key gud-minor-mode-map [left-margin C-mouse-3]
+ 'gdb-mouse-jump)
+
+ (local-set-key "\C-i" 'gud-gdb-complete-command)
+ (setq gdb-first-prompt t)
+ (setq gud-running nil)
+
+ (gdb-update)
+
+ (run-hooks 'gdb-mode-hook))
+
+(defun gdb-init-1 ()
+ ;; (re-)initialise
+ (setq gdb-selected-frame nil
+ gdb-frame-number nil
+ gdb-thread-number nil
+ gdb-var-list nil
+ gdb-pending-triggers nil
+ gdb-output-sink 'user
+ gdb-location-alist nil
+ gdb-source-file-list nil
+ gdb-last-command nil
+ gdb-token-number 0
+ gdb-handler-alist '()
+ gdb-handler-number nil
+ gdb-prompt-name nil
+ gdb-first-done-or-error t
+ gdb-buffer-fringe-width (car (window-fringes))
+ gdb-debug-log nil
+ gdb-source-window nil
+ gdb-inferior-status nil
+ gdb-continuation nil
+ gdb-buf-publisher '()
+ gdb-threads-list '()
+ gdb-breakpoints-list '()
+ gdb-register-names '()
+ gdb-non-stop gdb-non-stop-setting)
+ ;;
+ (setq gdb-buffer-type 'gdbmi)
+ ;;
+ (gdb-force-mode-line-update
+ (propertize "initializing..." 'face font-lock-variable-name-face))
+
+ (gdb-get-buffer-create 'gdb-inferior-io)
+ (gdb-clear-inferior-io)
+ (set-process-filter (get-process "gdb-inferior") 'gdb-inferior-filter)
+ (gdb-input
+ ;; Needs GDB 6.4 onwards
+ (list (concat "-inferior-tty-set "
+ (or
+ ;; The process can run on a remote host.
+ (process-get (get-process "gdb-inferior") 'remote-tty)
+ (process-tty-name (get-process "gdb-inferior"))))
+ 'ignore))
+ (if (eq window-system 'w32)
+ (gdb-input (list "-gdb-set new-console off" 'ignore)))
+ (gdb-input (list "-gdb-set height 0" 'ignore))
+
+ (when gdb-non-stop
+ (gdb-input (list "-gdb-set non-stop 1" 'gdb-non-stop-handler)))
+
+ ;; find source file and compilation directory here
+ (gdb-input
+ ; Needs GDB 6.2 onwards.
+ (list "-file-list-exec-source-files" 'gdb-get-source-file-list))
+ (if gdb-create-source-file-list
+ (gdb-input
+ ; Needs GDB 6.0 onwards.
+ (list "-file-list-exec-source-file" 'gdb-get-source-file)))
+ (gdb-input
+ (list "-gdb-show prompt" 'gdb-get-prompt)))
+
+(defun gdb-non-stop-handler ()
+ (goto-char (point-min))
+ (if (re-search-forward "No symbol" nil t)
+ (progn
+ (message "This version of GDB doesn't support non-stop mode. Turning it off.")
+ (setq gdb-non-stop nil)
+ (setq gdb-version "pre-7.0"))
+ (setq gdb-version "7.0+")
+ (gdb-input (list "-gdb-set target-async 1" 'ignore))
+ (gdb-input (list "-enable-pretty-printing" 'ignore))))
+
+(defvar gdb-define-alist nil "Alist of #define directives for GUD tooltips.")
+
+(defun gdb-create-define-alist ()
+ "Create an alist of #define directives for GUD tooltips."
+ (let* ((file (buffer-file-name))
+ (output
+ (with-output-to-string
+ (with-current-buffer standard-output
+ (and file
+ (file-exists-p file)
+ ;; call-process doesn't work with remote file names.
+ (not (file-remote-p default-directory))
+ (call-process shell-file-name file
+ (list t nil) nil "-c"
+ (concat gdb-cpp-define-alist-program " "
+ gdb-cpp-define-alist-flags))))))
+ (define-list (split-string output "\n" t))
+ (name))
+ (setq gdb-define-alist nil)
+ (dolist (define define-list)
+ (setq name (nth 1 (split-string define "[( ]")))
+ (push (cons name define) gdb-define-alist))))
+
+(declare-function tooltip-show "tooltip" (text &optional use-echo-area))
+(defvar tooltip-use-echo-area)
+
+(defun gdb-tooltip-print (expr)
+ (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer)
+ (goto-char (point-min))
+ (if (re-search-forward ".*value=\\(\".*\"\\)" nil t)
+ (tooltip-show
+ (concat expr " = " (read (match-string 1)))
+ (or gud-tooltip-echo-area tooltip-use-echo-area
+ (not (display-graphic-p)))))))
+
+;; If expr is a macro for a function don't print because of possible dangerous
+;; side-effects. Also printing a function within a tooltip generates an
+;; unexpected starting annotation (phase error).
+(defun gdb-tooltip-print-1 (expr)
+ (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer)
+ (goto-char (point-min))
+ (if (search-forward "expands to: " nil t)
+ (unless (looking-at "\\S-+.*(.*).*")
+ (gdb-input
+ (list (concat "-data-evaluate-expression " expr)
+ `(lambda () (gdb-tooltip-print ,expr))))))))
+
+(defun gdb-init-buffer ()
+ (set (make-local-variable 'gud-minor-mode) 'gdbmi)
+ (set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
+ (when gud-tooltip-mode
+ (make-local-variable 'gdb-define-alist)
+ (gdb-create-define-alist)
+ (add-hook 'after-save-hook 'gdb-create-define-alist nil t)))
+
+(defmacro gdb-if-arrow (arrow-position &rest body)
+ `(if ,arrow-position
+ (let ((buffer (marker-buffer ,arrow-position)) (line))
+ (if (equal buffer (window-buffer (posn-window end)))
+ (with-current-buffer buffer
+ (when (or (equal start end)
+ (equal (posn-point start)
+ (marker-position ,arrow-position)))
+ ,@body))))))
+
+(defun gdb-mouse-until (event)
+ "Continue running until a source line past the current line.
+The destination source line can be selected either by clicking
+with mouse-3 on the fringe/margin or dragging the arrow
+with mouse-1 (default bindings)."
+ (interactive "e")
+ (let ((start (event-start event))
+ (end (event-end event)))
+ (gdb-if-arrow gud-overlay-arrow-position
+ (setq line (line-number-at-pos (posn-point end)))
+ (gud-call (concat "until " (number-to-string line))))
+ (gdb-if-arrow gdb-disassembly-position
+ (save-excursion
+ (goto-char (point-min))
+ (forward-line (1- (line-number-at-pos (posn-point end))))
+ (forward-char 2)
+ (gud-call (concat "until *%a"))))))
+
+(defun gdb-mouse-jump (event)
+ "Set execution address/line.
+The destination source line can be selected either by clicking with C-mouse-3
+on the fringe/margin or dragging the arrow with C-mouse-1 (default bindings).
+Unlike `gdb-mouse-until' the destination address can be before the current
+line, and no execution takes place."
+ (interactive "e")
+ (let ((start (event-start event))
+ (end (event-end event)))
+ (gdb-if-arrow gud-overlay-arrow-position
+ (setq line (line-number-at-pos (posn-point end)))
+ (progn
+ (gud-call (concat "tbreak " (number-to-string line)))
+ (gud-call (concat "jump " (number-to-string line)))))
+ (gdb-if-arrow gdb-disassembly-position
+ (save-excursion
+ (goto-char (point-min))
+ (forward-line (1- (line-number-at-pos (posn-point end))))
+ (forward-char 2)
+ (progn
+ (gud-call (concat "tbreak *%a"))
+ (gud-call (concat "jump *%a")))))))
+
+(defcustom gdb-show-changed-values t
+ "If non-nil change the face of out of scope variables and changed values.
+Out of scope variables are suppressed with `shadow' face.
+Changed values are highlighted with the face `font-lock-warning-face'."
+ :type 'boolean
+ :group 'gdb
+ :version "22.1")
+
+(defcustom gdb-max-children 40
+ "Maximum number of children before expansion requires confirmation."
+ :type 'integer
+ :group 'gdb
+ :version "22.1")
+
+(defcustom gdb-delete-out-of-scope t
+ "If non-nil delete watch expressions automatically when they go out of scope."
+ :type 'boolean
+ :group 'gdb
+ :version "22.2")
+
+(defcustom gdb-speedbar-auto-raise nil
+ "If non-nil raise speedbar every time display of watch expressions is\
+ updated."
+ :type 'boolean
+ :group 'gdb
+ :version "22.1")
+
+(defcustom gdb-use-colon-colon-notation nil
+ "If non-nil use FUN::VAR format to display variables in the speedbar."
+ :type 'boolean
+ :group 'gdb
+ :version "22.1")
+
+(defun gdb-speedbar-auto-raise (arg)
+ "Toggle automatic raising of the speedbar for watch expressions.
+With prefix argument ARG, automatically raise speedbar if ARG is
+positive, otherwise don't automatically raise it."
+ (interactive "P")
+ (setq gdb-speedbar-auto-raise
+ (if (null arg)
+ (not gdb-speedbar-auto-raise)
+ (> (prefix-numeric-value arg) 0)))
+ (message (format "Auto raising %sabled"
+ (if gdb-speedbar-auto-raise "en" "dis"))))
+
+(define-key gud-minor-mode-map "\C-c\C-w" 'gud-watch)
+(define-key global-map (concat gud-key-prefix "\C-w") 'gud-watch)
+
+(declare-function tooltip-identifier-from-point "tooltip" (point))
+
+(defun gud-watch (&optional arg event)
+ "Watch expression at point.
+With arg, enter name of variable to be watched in the minibuffer."
+ (interactive (list current-prefix-arg last-input-event))
+ (let ((minor-mode (buffer-local-value 'gud-minor-mode gud-comint-buffer)))
+ (if (eq minor-mode 'gdbmi)
+ (progn
+ (if event (posn-set-point (event-end event)))
+ (require 'tooltip)
+ (save-selected-window
+ (let ((expr
+ (if arg
+ (completing-read "Name of variable: "
+ 'gud-gdb-complete-command)
+ (if (and transient-mark-mode mark-active)
+ (buffer-substring (region-beginning) (region-end))
+ (concat (if (eq major-mode 'gdb-registers-mode) "$")
+ (tooltip-identifier-from-point (point)))))))
+ (set-text-properties 0 (length expr) nil expr)
+ (gdb-input
+ (list (concat"-var-create - * " expr "")
+ `(lambda () (gdb-var-create-handler ,expr)))))))
+ (message "gud-watch is a no-op in this mode."))))
+
+(defun gdb-var-create-handler (expr)
+ (let* ((result (gdb-json-partial-output)))
+ (if (not (bindat-get-field result 'msg))
+ (let ((var
+ (list (bindat-get-field result 'name)
+ (if (and (string-equal gdb-current-language "c")
+ gdb-use-colon-colon-notation gdb-selected-frame)
+ (setq expr (concat gdb-selected-frame "::" expr))
+ expr)
+ (bindat-get-field result 'numchild)
+ (bindat-get-field result 'type)
+ (bindat-get-field result 'value)
+ nil
+ (bindat-get-field result 'has_more)
+ gdb-frame-address)))
+ (push var gdb-var-list)
+ (speedbar 1)
+ (unless (string-equal
+ speedbar-initial-expansion-list-name "GUD")
+ (speedbar-change-initial-expansion-list "GUD")))
+ (message-box "No symbol \"%s\" in current context." expr))))
+
+(defun gdb-speedbar-update ()
+ (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame)
+ (not (gdb-pending-p 'gdb-speedbar-timer)))
+ ;; Dummy command to update speedbar even when idle.
+ (gdb-input (list "-environment-pwd" 'gdb-speedbar-timer-fn))
+ ;; Keep gdb-pending-triggers non-nil till end.
+ (gdb-add-pending 'gdb-speedbar-timer)))
+
+(defun gdb-speedbar-timer-fn ()
+ (if gdb-speedbar-auto-raise
+ (raise-frame speedbar-frame))
+ (gdb-delete-pending 'gdb-speedbar-timer)
+ (speedbar-timer-fn))
+
+(defun gdb-var-evaluate-expression-handler (varnum changed)
+ (goto-char (point-min))
+ (re-search-forward ".*value=\\(\".*\"\\)" nil t)
+ (let ((var (assoc varnum gdb-var-list)))
+ (when var
+ (if changed (setcar (nthcdr 5 var) 'changed))
+ (setcar (nthcdr 4 var) (read (match-string 1)))))
+ (gdb-speedbar-update))
+
+; Uses "-var-list-children --all-values". Needs GDB 6.1 onwards.
+(defun gdb-var-list-children (varnum)
+ (gdb-input
+ (list (concat "-var-update " varnum) 'ignore))
+ (gdb-input
+ (list (concat "-var-list-children --all-values "
+ varnum)
+ `(lambda () (gdb-var-list-children-handler ,varnum)))))
+
+(defun gdb-var-list-children-handler (varnum)
+ (let* ((var-list nil)
+ (output (bindat-get-field (gdb-json-partial-output "child")))
+ (children (bindat-get-field output 'children)))
+ (catch 'child-already-watched
+ (dolist (var gdb-var-list)
+ (if (string-equal varnum (car var))
+ (progn
+ ;; With dynamic varobjs numchild may have increased.
+ (setcar (nthcdr 2 var) (bindat-get-field output 'numchild))
+ (push var var-list)
+ (dolist (child children)
+ (let ((varchild (list (bindat-get-field child 'name)
+ (bindat-get-field child 'exp)
+ (bindat-get-field child 'numchild)
+ (bindat-get-field child 'type)
+ (bindat-get-field child 'value)
+ nil
+ (bindat-get-field child 'has_more))))
+ (if (assoc (car varchild) gdb-var-list)
+ (throw 'child-already-watched nil))
+ (push varchild var-list))))
+ (push var var-list)))
+ (setq gdb-var-list (nreverse var-list))))
+ (gdb-speedbar-update))
+
+(defun gdb-var-set-format (format)
+ "Set the output format for a variable displayed in the speedbar."
+ (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list))
+ (varnum (car var)))
+ (gdb-input
+ (list (concat "-var-set-format " varnum " " format) 'ignore))
+ (gdb-var-update)))
+
+(defun gdb-var-delete-1 (var varnum)
+ (gdb-input
+ (list (concat "-var-delete " varnum) 'ignore))
+ (setq gdb-var-list (delq var gdb-var-list))
+ (dolist (varchild gdb-var-list)
+ (if (string-match (concat (car var) "\\.") (car varchild))
+ (setq gdb-var-list (delq varchild gdb-var-list)))))
+
+(defun gdb-var-delete ()
+ "Delete watch expression at point from the speedbar."
+ (interactive)
+ (let ((text (speedbar-line-text)))
+ (string-match "\\(\\S-+\\)" text)
+ (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list))
+ (varnum (car var)))
+ (if (string-match "\\." (car var))
+ (message-box "Can only delete a root expression")
+ (gdb-var-delete-1 var varnum)))))
+
+(defun gdb-var-delete-children (varnum)
+ "Delete children of variable object at point from the speedbar."
+ (gdb-input
+ (list (concat "-var-delete -c " varnum) 'ignore)))
+
+(defun gdb-edit-value (text token indent)
+ "Assign a value to a variable displayed in the speedbar."
+ (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list))
+ (varnum (car var)) (value))
+ (setq value (read-string "New value: "))
+ (gdb-input
+ (list (concat "-var-assign " varnum " " value)
+ `(lambda () (gdb-edit-value-handler ,value))))))
+
+(defconst gdb-error-regexp "\\^error,msg=\\(\".+\"\\)")
+
+(defun gdb-edit-value-handler (value)
+ (goto-char (point-min))
+ (if (re-search-forward gdb-error-regexp nil t)
+ (message-box "Invalid number or expression (%s)" value)))
+
+; Uses "-var-update --all-values". Needs GDB 6.4 onwards.
+(defun gdb-var-update ()
+ (if (not (gdb-pending-p 'gdb-var-update))
+ (gdb-input
+ (list "-var-update --all-values *" 'gdb-var-update-handler)))
+ (gdb-add-pending 'gdb-var-update))
+
+(defun gdb-var-update-handler ()
+ (let ((changelist (bindat-get-field (gdb-json-partial-output) 'changelist)))
+ (dolist (var gdb-var-list)
+ (setcar (nthcdr 5 var) nil))
+ (let ((temp-var-list gdb-var-list))
+ (dolist (change changelist)
+ (let* ((varnum (bindat-get-field change 'name))
+ (var (assoc varnum gdb-var-list))
+ (new-num (bindat-get-field change 'new_num_children)))
+ (when var
+ (let ((scope (bindat-get-field change 'in_scope))
+ (has-more (bindat-get-field change 'has_more)))
+ (cond ((string-equal scope "false")
+ (if gdb-delete-out-of-scope
+ (gdb-var-delete-1 var varnum)
+ (setcar (nthcdr 5 var) 'out-of-scope)))
+ ((string-equal scope "true")
+ (setcar (nthcdr 6 var) has-more)
+ (when (and (or (not has-more)
+ (string-equal has-more "0"))
+ (not new-num)
+ (string-equal (nth 2 var) "0"))
+ (setcar (nthcdr 4 var)
+ (bindat-get-field change 'value))
+ (setcar (nthcdr 5 var) 'changed)))
+ ((string-equal scope "invalid")
+ (gdb-var-delete-1 var varnum)))))
+ (let ((var-list nil) var1
+ (children (bindat-get-field change 'new_children)))
+ (if new-num
+ (progn
+ (setq var1 (pop temp-var-list))
+ (while var1
+ (if (string-equal varnum (car var1))
+ (let ((new (string-to-number new-num))
+ (previous (string-to-number (nth 2 var1))))
+ (setcar (nthcdr 2 var1) new-num)
+ (push var1 var-list)
+ (cond ((> new previous)
+ ;; Add new children to list.
+ (dotimes (dummy previous)
+ (push (pop temp-var-list) var-list))
+ (dolist (child children)
+ (let ((varchild
+ (list (bindat-get-field child 'name)
+ (bindat-get-field child 'exp)
+ (bindat-get-field child 'numchild)
+ (bindat-get-field child 'type)
+ (bindat-get-field child 'value)
+ 'changed
+ (bindat-get-field child 'has_more))))
+ (push varchild var-list))))
+ ;; Remove deleted children from list.
+ ((< new previous)
+ (dotimes (dummy new)
+ (push (pop temp-var-list) var-list))
+ (dotimes (dummy (- previous new))
+ (pop temp-var-list)))))
+ (push var1 var-list))
+ (setq var1 (pop temp-var-list)))
+ (setq gdb-var-list (nreverse var-list)))))))))
+ (setq gdb-pending-triggers
+ (delq 'gdb-var-update gdb-pending-triggers))
+ (gdb-speedbar-update))
+
+(defun gdb-speedbar-expand-node (text token indent)
+ "Expand the node the user clicked on.
+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
+ (let* ((var (assoc token gdb-var-list))
+ (expr (nth 1 var)) (children (nth 2 var)))
+ (if (or (<= (string-to-number children) gdb-max-children)
+ (y-or-n-p
+ (format "%s has %s children. Continue? " expr children)))
+ (gdb-var-list-children token))))
+ ((string-match "-" text) ;contract this node
+ (dolist (var gdb-var-list)
+ (if (string-match (concat token "\\.") (car var))
+ (setq gdb-var-list (delq var gdb-var-list))))
+ (gdb-var-delete-children token)
+ (speedbar-change-expand-button-char ?+)
+ (speedbar-delete-subblock indent))
+ (t (error "Ooops... not sure what to do")))
+ (speedbar-center-buffer-smartly))
+
+(defun gdb-get-target-string ()
+ (with-current-buffer gud-comint-buffer
+ gud-target-name))
+
+
+;;
+;; gdb buffers.
+;;
+;; Each buffer has a TYPE -- a symbol that identifies the function
+;; of that particular buffer.
+;;
+;; The usual gdb interaction buffer is given the type `gdbmi' and
+;; is constructed specially.
+;;
+;; Others are constructed by gdb-get-buffer-create and
+;; named according to the rules set forth in the gdb-buffer-rules
+
+(defvar gdb-buffer-rules '())
+
+(defun gdb-rules-name-maker (rules-entry)
+ (cadr rules-entry))
+(defun gdb-rules-buffer-mode (rules-entry)
+ (nth 2 rules-entry))
+(defun gdb-rules-update-trigger (rules-entry)
+ (nth 3 rules-entry))
+
+(defun gdb-update-buffer-name ()
+ "Rename current buffer according to name-maker associated with
+it in `gdb-buffer-rules'."
+ (let ((f (gdb-rules-name-maker (assoc gdb-buffer-type
+ gdb-buffer-rules))))
+ (when f (rename-buffer (funcall f)))))
+
+(defun gdb-current-buffer-rules ()
+ "Get `gdb-buffer-rules' entry for current buffer type."
+ (assoc gdb-buffer-type gdb-buffer-rules))
+
+(defun gdb-current-buffer-thread ()
+ "Get thread object of current buffer from `gdb-threads-list'.
+
+When current buffer is not bound to any thread, return main
+thread."
+ (cdr (assoc gdb-thread-number gdb-threads-list)))
+
+(defun gdb-current-buffer-frame ()
+ "Get current stack frame object for thread of current buffer."
+ (bindat-get-field (gdb-current-buffer-thread) 'frame))
+
+(defun gdb-buffer-type (buffer)
+ "Get value of `gdb-buffer-type' for BUFFER."
+ (with-current-buffer buffer
+ gdb-buffer-type))
+
+(defun gdb-buffer-shows-main-thread-p ()
+ "Return t if current GDB buffer shows main selected thread and
+is not bound to it."
+ (current-buffer)
+ (not (local-variable-p 'gdb-thread-number)))
+
+(defun gdb-get-buffer (buffer-type &optional thread)
+ "Get a specific GDB buffer.
+
+In that buffer, `gdb-buffer-type' must be equal to BUFFER-TYPE
+and `gdb-thread-number' (if provided) must be equal to THREAD."
+ (catch 'found
+ (dolist (buffer (buffer-list) nil)
+ (with-current-buffer buffer
+ (when (and (eq gdb-buffer-type buffer-type)
+ (or (not thread)
+ (equal gdb-thread-number thread)))
+ (throw 'found buffer))))))
+
+(defun gdb-get-buffer-create (buffer-type &optional thread)
+ "Create a new GDB buffer of the type specified by BUFFER-TYPE.
+The buffer-type should be one of the cars in `gdb-buffer-rules'.
+
+If THREAD is non-nil, it is assigned to `gdb-thread-number'
+buffer-local variable of the new buffer.
+
+Buffer mode and name are selected according to buffer type.
+
+If buffer has trigger associated with it in `gdb-buffer-rules',
+this trigger is subscribed to `gdb-buf-publisher' and called with
+'update argument."
+ (or (gdb-get-buffer buffer-type thread)
+ (let ((rules (assoc buffer-type gdb-buffer-rules))
+ (new (generate-new-buffer "limbo")))
+ (with-current-buffer new
+ (let ((mode (gdb-rules-buffer-mode rules))
+ (trigger (gdb-rules-update-trigger rules)))
+ (when mode (funcall mode))
+ (setq gdb-buffer-type buffer-type)
+ (when thread
+ (set (make-local-variable 'gdb-thread-number) thread))
+ (set (make-local-variable 'gud-minor-mode)
+ (buffer-local-value 'gud-minor-mode gud-comint-buffer))
+ (set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
+ (rename-buffer (funcall (gdb-rules-name-maker rules)))
+ (when trigger
+ (gdb-add-subscriber gdb-buf-publisher
+ (cons (current-buffer)
+ (gdb-bind-function-to-buffer trigger (current-buffer))))
+ (funcall trigger 'start))
+ (current-buffer))))))
+
+(defun gdb-bind-function-to-buffer (expr buffer)
+ "Return a function which will evaluate EXPR in BUFFER."
+ `(lambda (&rest args)
+ (with-current-buffer ,buffer
+ (apply ',expr args))))
+
+;; Used to define all gdb-frame-*-buffer functions except
+;; `gdb-frame-io-buffer'
+(defmacro def-gdb-frame-for-buffer (name buffer &optional doc)
+ "Define a function NAME which shows gdb BUFFER in a separate frame.
+
+DOC is an optional documentation string."
+ `(defun ,name (&optional thread)
+ ,(when doc doc)
+ (interactive)
+ (let ((special-display-regexps (append special-display-regexps '(".*")))
+ (special-display-frame-alist gdb-frame-parameters))
+ (display-buffer (gdb-get-buffer-create ,buffer thread)))))
+
+(defmacro def-gdb-display-buffer (name buffer &optional doc)
+ "Define a function NAME which shows gdb BUFFER.
+
+DOC is an optional documentation string."
+ `(defun ,name (&optional thread)
+ ,(when doc doc)
+ (interactive)
+ (gdb-display-buffer
+ (gdb-get-buffer-create ,buffer thread) t)))
+
+;; Used to display windows with thread-bound buffers
+(defmacro def-gdb-preempt-display-buffer (name buffer &optional doc
+ split-horizontal)
+ `(defun ,name (&optional thread)
+ ,(when doc doc)
+ (message thread)
+ (gdb-preempt-existing-or-display-buffer
+ (gdb-get-buffer-create ,buffer thread)
+ ,split-horizontal)))
+
+;; This assoc maps buffer type symbols to rules. Each rule is a list of
+;; at least one and possible more functions. The functions have these
+;; roles in defining a buffer type:
+;;
+;; NAME - Return a name for this buffer type.
+;;
+;; The remaining function(s) are optional:
+;;
+;; MODE - called in a new buffer with no arguments, should establish
+;; the proper mode for the buffer.
+;;
+
+(defun gdb-set-buffer-rules (buffer-type &rest rules)
+ (let ((binding (assoc buffer-type gdb-buffer-rules)))
+ (if binding
+ (setcdr binding rules)
+ (push (cons buffer-type rules)
+ gdb-buffer-rules))))
+
+(defun gdb-parent-mode ()
+ "Generic mode to derive all other GDB buffer modes from."
+ (kill-all-local-variables)
+ (setq buffer-read-only t)
+ (buffer-disable-undo)
+ ;; Delete buffer from gdb-buf-publisher when it's killed
+ ;; (if it has an associated update trigger)
+ (add-hook
+ 'kill-buffer-hook
+ (function
+ (lambda ()
+ (let ((trigger (gdb-rules-update-trigger
+ (gdb-current-buffer-rules))))
+ (when trigger
+ (gdb-delete-subscriber
+ gdb-buf-publisher
+ ;; This should match gdb-add-subscriber done in
+ ;; gdb-get-buffer-create
+ (cons (current-buffer)
+ (gdb-bind-function-to-buffer trigger (current-buffer))))))))
+ nil t))
+
+;; Partial-output buffer : This accumulates output from a command executed on
+;; behalf of emacs (rather than the user).
+;;
+(gdb-set-buffer-rules 'gdb-partial-output-buffer
+ 'gdb-partial-output-name)
+
+(defun gdb-partial-output-name ()
+ (concat " *partial-output-"
+ (gdb-get-target-string)
+ "*"))
+
+
+(gdb-set-buffer-rules 'gdb-inferior-io
+ 'gdb-inferior-io-name
+ 'gdb-inferior-io-mode)
+
+(defun gdb-inferior-io-name ()
+ (concat "*input/output of "
+ (gdb-get-target-string)
+ "*"))
+
+(defun gdb-display-io-buffer ()
+ "Display IO of debugged program in a separate window."
+ (interactive)
+ (gdb-display-buffer
+ (gdb-get-buffer-create 'gdb-inferior-io) t))
+
+(defconst gdb-frame-parameters
+ '((height . 14) (width . 80)
+ (unsplittable . t)
+ (tool-bar-lines . nil)
+ (menu-bar-lines . nil)
+ (minibuffer . nil)))
+
+(defun gdb-frame-io-buffer ()
+ "Display IO of debugged program in a new frame."
+ (interactive)
+ (let ((special-display-regexps (append special-display-regexps '(".*")))
+ (special-display-frame-alist gdb-frame-parameters))
+ (display-buffer (gdb-get-buffer-create 'gdb-inferior-io))))
+
+(defvar gdb-inferior-io-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\C-c\C-c" 'gdb-io-interrupt)
+ (define-key map "\C-c\C-z" 'gdb-io-stop)
+ (define-key map "\C-c\C-\\" 'gdb-io-quit)
+ (define-key map "\C-c\C-d" 'gdb-io-eof)
+ (define-key map "\C-d" 'gdb-io-eof)
+ map))
+
+;; We want to use comint because it has various nifty and familiar features.
+(define-derived-mode gdb-inferior-io-mode comint-mode "Inferior I/O"
+ "Major mode for gdb inferior-io.
+
+The following commands are available:
+\\{gdb-inferior-io-mode-map}"
+
+ :syntax-table nil :abbrev-table nil
+
+(make-comint-in-buffer "gdb-inferior" (current-buffer) nil))
+
+(defun gdb-inferior-filter (proc string)
+ (unless (string-equal string "")
+ (gdb-display-buffer (gdb-get-buffer-create 'gdb-inferior-io) t))
+ (with-current-buffer (gdb-get-buffer-create 'gdb-inferior-io)
+ (comint-output-filter proc string)))
+
+(defun gdb-io-interrupt ()
+ "Interrupt the program being debugged."
+ (interactive)
+ (interrupt-process
+ (get-buffer-process gud-comint-buffer) comint-ptyp))
+
+(defun gdb-io-quit ()
+ "Send quit signal to the program being debugged."
+ (interactive)
+ (quit-process
+ (get-buffer-process gud-comint-buffer) comint-ptyp))
+
+(defun gdb-io-stop ()
+ "Stop the program being debugged."
+ (interactive)
+ (stop-process
+ (get-buffer-process gud-comint-buffer) comint-ptyp))
+
+(defun gdb-io-eof ()
+ "Send end-of-file to the program being debugged."
+ (interactive)
+ (process-send-eof
+ (get-buffer-process gud-comint-buffer)))
+
+(defun gdb-clear-inferior-io ()
+ (with-current-buffer (gdb-get-buffer-create 'gdb-inferior-io)
+ (erase-buffer)))
+
+
+(defconst breakpoint-xpm-data
+ "/* XPM */
+static char *magick[] = {
+/* columns rows colors chars-per-pixel */
+\"10 10 2 1\",
+\" c red\",
+\"+ c None\",
+/* pixels */
+\"+++ +++\",
+\"++ ++\",
+\"+ +\",
+\" \",
+\" \",
+\" \",
+\" \",
+\"+ +\",
+\"++ ++\",
+\"+++ +++\",
+};"
+ "XPM data used for breakpoint icon.")
+
+(defconst breakpoint-enabled-pbm-data
+ "P1
+10 10\",
+0 0 0 0 1 1 1 1 0 0 0 0
+0 0 0 1 1 1 1 1 1 0 0 0
+0 0 1 1 1 1 1 1 1 1 0 0
+0 1 1 1 1 1 1 1 1 1 1 0
+0 1 1 1 1 1 1 1 1 1 1 0
+0 1 1 1 1 1 1 1 1 1 1 0
+0 1 1 1 1 1 1 1 1 1 1 0
+0 0 1 1 1 1 1 1 1 1 0 0
+0 0 0 1 1 1 1 1 1 0 0 0
+0 0 0 0 1 1 1 1 0 0 0 0"
+ "PBM data used for enabled breakpoint icon.")
+
+(defconst breakpoint-disabled-pbm-data
+ "P1
+10 10\",
+0 0 1 0 1 0 1 0 0 0
+0 1 0 1 0 1 0 1 0 0
+1 0 1 0 1 0 1 0 1 0
+0 1 0 1 0 1 0 1 0 1
+1 0 1 0 1 0 1 0 1 0
+0 1 0 1 0 1 0 1 0 1
+1 0 1 0 1 0 1 0 1 0
+0 1 0 1 0 1 0 1 0 1
+0 0 1 0 1 0 1 0 1 0
+0 0 0 1 0 1 0 1 0 0"
+ "PBM data used for disabled breakpoint icon.")
+
+(defvar breakpoint-enabled-icon nil
+ "Icon for enabled breakpoint in display margin.")
+
+(defvar breakpoint-disabled-icon nil
+ "Icon for disabled breakpoint in display margin.")
+
+(declare-function define-fringe-bitmap "fringe.c"
+ (bitmap bits &optional height width align))
+
+(and (display-images-p)
+ ;; Bitmap for breakpoint in fringe
+ (define-fringe-bitmap 'breakpoint
+ "\x3c\x7e\xff\xff\xff\xff\x7e\x3c")
+ ;; Bitmap for gud-overlay-arrow in fringe
+ (define-fringe-bitmap 'hollow-right-triangle
+ "\xe0\x90\x88\x84\x84\x88\x90\xe0"))
+
+(defface breakpoint-enabled
+ '((t
+ :foreground "red1"
+ :weight bold))
+ "Face for enabled breakpoint icon in fringe."
+ :group 'gdb)
+
+(defface breakpoint-disabled
+ '((((class color) (min-colors 88)) :foreground "grey70")
+ ;; Ensure that on low-color displays that we end up something visible.
+ (((class color) (min-colors 8) (background light))
+ :foreground "black")
+ (((class color) (min-colors 8) (background dark))
+ :foreground "white")
+ (((type tty) (class mono))
+ :inverse-video t)
+ (t :background "gray"))
+ "Face for disabled breakpoint icon in fringe."
+ :group 'gdb)
+
+
+(defun gdb-send (proc string)
+ "A comint send filter for gdb."
+ (with-current-buffer gud-comint-buffer
+ (let ((inhibit-read-only t))
+ (remove-text-properties (point-min) (point-max) '(face))))
+ ;; mimic <RET> key to repeat previous command in GDB
+ (if (not (string= "" string))
+ (setq gdb-last-command string)
+ (if gdb-last-command (setq string gdb-last-command)))
+ (if gdb-enable-debug
+ (push (cons 'mi-send (concat string "\n")) gdb-debug-log))
+ (if (string-match "^-" string)
+ ;; MI command
+ (progn
+ (setq gdb-first-done-or-error t)
+ (process-send-string proc (concat string "\n")))
+ ;; CLI command
+ (if (string-match "\\\\$" string)
+ (setq gdb-continuation (concat gdb-continuation string "\n"))
+ (setq gdb-first-done-or-error t)
+ (process-send-string proc (concat "-interpreter-exec console \""
+ gdb-continuation string "\"\n"))
+ (setq gdb-continuation nil))))
+
+(defun gdb-input (item)
+ (if gdb-enable-debug (push (cons 'send-item item) gdb-debug-log))
+ (setq gdb-token-number (1+ gdb-token-number))
+ (setcar item (concat (number-to-string gdb-token-number) (car item)))
+ (push (cons gdb-token-number (car (cdr item))) gdb-handler-alist)
+ (process-send-string (get-buffer-process gud-comint-buffer)
+ (concat (car item) "\n")))
+
+;; NOFRAME is used for gud execution control commands
+(defun gdb-current-context-command (command)
+ "Add --thread to gdb COMMAND when needed."
+ (if (and gdb-thread-number
+ (string-equal gdb-version "7.0+"))
+ (concat command " --thread " gdb-thread-number)
+ command))
+
+(defun gdb-current-context-buffer-name (name)
+ "Add thread information and asterisks to string NAME.
+
+If `gdb-thread-number' is nil, just wrap NAME in asterisks."
+ (concat "*" name
+ (if (local-variable-p 'gdb-thread-number)
+ (format " (bound to thread %s)" gdb-thread-number)
+ "")
+ "*"))
+
+(defun gdb-current-context-mode-name (mode)
+ "Add thread information to MODE which is to be used as
+`mode-name'."
+ (concat mode
+ (if gdb-thread-number
+ (format " [thread %s]" gdb-thread-number)
+ "")))
+
+
+(defcustom gud-gdb-command-name "gdb -i=mi"
+ "Default command to execute an executable under the GDB debugger."
+ :type 'string
+ :group 'gdb)
+
+(defun gdb-resync()
+ (setq gud-running nil)
+ (setq gdb-output-sink 'user)
+ (setq gdb-pending-triggers nil))
+
+(defun gdb-update ()
+ "Update buffers showing status of debug session."
+ (when gdb-first-prompt
+ (gdb-force-mode-line-update
+ (propertize "initializing..." 'face font-lock-variable-name-face))
+ (gdb-init-1)
+ (setq gdb-first-prompt nil))
+
+ (gdb-get-main-selected-frame)
+ ;; We may need to update gdb-threads-list so we can use
+ (gdb-get-buffer-create 'gdb-threads-buffer)
+ ;; gdb-break-list is maintained in breakpoints handler
+ (gdb-get-buffer-create 'gdb-breakpoints-buffer)
+
+ (gdb-emit-signal gdb-buf-publisher 'update)
+
+ (gdb-get-changed-registers)
+
+ (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame))
+ (dolist (var gdb-var-list)
+ (setcar (nthcdr 5 var) nil))
+ (gdb-var-update)))
+
+;; gdb-setq-thread-number and gdb-update-gud-running are decoupled
+;; because we may need to update current gud-running value without
+;; changing current thread (see gdb-running)
+(defun gdb-setq-thread-number (number)
+ "Only this function must be used to change `gdb-thread-number'
+value to NUMBER, because `gud-running' and `gdb-frame-number'
+need to be updated appropriately when current thread changes."
+ ;; GDB 6.8 and earlier always output thread-id="0" when stopping.
+ (unless (string-equal number "0") (setq gdb-thread-number number))
+ (setq gdb-frame-number "0")
+ (gdb-update-gud-running))
+
+(defun gdb-update-gud-running ()
+ "Set `gud-running' according to the state of current thread.
+
+`gdb-frame-number' is set to 0 if current thread is now stopped.
+
+Note that when `gdb-gud-control-all-threads' is t, `gud-running'
+cannot be reliably used to determine whether or not execution
+control buttons should be shown in menu or toolbar. Use
+`gdb-running-threads-count' and `gdb-stopped-threads-count'
+instead.
+
+For all-stop mode, thread information is unavailable while target
+is running."
+ (let ((old-value gud-running))
+ (setq gud-running
+ (string= (bindat-get-field (gdb-current-buffer-thread) 'state)
+ "running"))
+ ;; Set frame number to "0" when _current_ threads stops
+ (when (and (gdb-current-buffer-thread)
+ (not (eq gud-running old-value)))
+ (setq gdb-frame-number "0"))))
+
+(defun gdb-show-run-p ()
+ "Return t if \"Run/continue\" should be shown on the toolbar."
+ (or (not gdb-active-process)
+ (and (or
+ (not gdb-gud-control-all-threads)
+ (not gdb-non-stop))
+ (not gud-running))
+ (and gdb-gud-control-all-threads
+ (> gdb-stopped-threads-count 0))))
+
+(defun gdb-show-stop-p ()
+ "Return t if \"Stop\" should be shown on the toolbar."
+ (or (and (or
+ (not gdb-gud-control-all-threads)
+ (not gdb-non-stop))
+ gud-running)
+ (and gdb-gud-control-all-threads
+ (> gdb-running-threads-count 0))))
+
+;; GUD displays the selected GDB frame. This might might not be the current
+;; GDB frame (after up, down etc). If no GDB frame is visible but the last
+;; visited breakpoint is, use that window.
+(defun gdb-display-source-buffer (buffer)
+ (let* ((last-window (if gud-last-last-frame
+ (get-buffer-window
+ (gud-find-file (car gud-last-last-frame)))))
+ (source-window (or last-window
+ (if (and gdb-source-window
+ (window-live-p gdb-source-window))
+ gdb-source-window))))
+ (when source-window
+ (setq gdb-source-window source-window)
+ (set-window-buffer source-window buffer))
+ source-window))
+
+(defun gdb-car< (a b)
+ (< (car a) (car b)))
+
+(defvar gdbmi-record-list
+ '((gdb-gdb . "(gdb) \n")
+ (gdb-done . "\\([0-9]*\\)\\^done,?\\(.*?\\)\n")
+ (gdb-starting . "\\([0-9]*\\)\\^running\n")
+ (gdb-error . "\\([0-9]*\\)\\^error,\\(.*?\\)\n")
+ (gdb-console . "~\\(\".*?\"\\)\n")
+ (gdb-internals . "&\\(\".*?\"\\)\n")
+ (gdb-stopped . "\\*stopped,?\\(.*?\\)\n")
+ (gdb-running . "\\*running,\\(.*?\n\\)")
+ (gdb-thread-created . "=thread-created,\\(.*?\n\\)")
+ (gdb-thread-selected . "=thread-selected,\\(.*?\\)\n")
+ (gdb-thread-exited . "=thread-exited,\\(.*?\n\\)")
+ (gdb-ignored-notification . "=[-[:alpha:]]+,?\\(.*?\\)\n")
+ (gdb-shell . "\\(\\(?:^.+\n\\)+\\)")))
+
+(defun gud-gdbmi-marker-filter (string)
+ "Filter GDB/MI output."
+
+ ;; Record transactions if logging is enabled.
+ (when gdb-enable-debug
+ (push (cons 'recv string) gdb-debug-log)
+ (if (and gdb-debug-log-max
+ (> (length gdb-debug-log) gdb-debug-log-max))
+ (setcdr (nthcdr (1- gdb-debug-log-max) gdb-debug-log) nil)))
+
+ ;; Recall the left over gud-marker-acc from last time
+ (setq gud-marker-acc (concat gud-marker-acc string))
+
+ ;; Start accumulating output for the GUD buffer
+ (setq gdb-filter-output "")
+ (let ((output-record) (output-record-list))
+
+ ;; Process all the complete markers in this chunk.
+ (dolist (gdbmi-record gdbmi-record-list)
+ (while (string-match (cdr gdbmi-record) gud-marker-acc)
+ (push (list (match-beginning 0)
+ (car gdbmi-record)
+ (match-string 1 gud-marker-acc)
+ (match-string 2 gud-marker-acc)
+ (match-end 0))
+ output-record-list)
+ (setq gud-marker-acc
+ (concat (substring gud-marker-acc 0 (match-beginning 0))
+ ;; Pad with spaces to preserve position.
+ (make-string (length (match-string 0 gud-marker-acc)) 32)
+ (substring gud-marker-acc (match-end 0))))))
+
+ (setq output-record-list (sort output-record-list 'gdb-car<))
+
+ (dolist (output-record output-record-list)
+ (let ((record-type (cadr output-record))
+ (arg1 (nth 2 output-record))
+ (arg2 (nth 3 output-record)))
+ (if (eq record-type 'gdb-error)
+ (gdb-done-or-error arg2 arg1 'error)
+ (if (eq record-type 'gdb-done)
+ (gdb-done-or-error arg2 arg1 'done)
+ ;; Suppress "No registers." since GDB 6.8 and earlier duplicates MI
+ ;; error message on internal stream. Don't print to GUD buffer.
+ (unless (and (eq record-type 'gdb-internals)
+ (string-equal (read arg1) "No registers.\n"))
+ (funcall record-type arg1))))))
+
+ (setq gdb-output-sink 'user)
+ ;; Remove padding.
+ (string-match "^ *" gud-marker-acc)
+ (setq gud-marker-acc (substring gud-marker-acc (match-end 0)))
+
+ gdb-filter-output))
+
+(defun gdb-gdb (output-field))
+
+(defun gdb-shell (output-field)
+ (let ((gdb-output-sink gdb-output-sink))
+ (setq gdb-filter-output
+ (concat output-field gdb-filter-output))))
+
+(defun gdb-ignored-notification (output-field))
+
+;; gdb-invalidate-threads is defined to accept 'update-threads signal
+(defun gdb-thread-created (output-field))
+(defun gdb-thread-exited (output-field)
+ "Handle =thread-exited async record: unset `gdb-thread-number'
+ if current thread exited and update threads list."
+ (let* ((thread-id (bindat-get-field (gdb-json-string output-field) 'id)))
+ (if (string= gdb-thread-number thread-id)
+ (gdb-setq-thread-number nil))
+ ;; When we continue current thread and it quickly exits,
+ ;; gdb-pending-triggers left after gdb-running disallow us to
+ ;; properly call -thread-info without --thread option. Thus we
+ ;; need to use gdb-wait-for-pending.
+ (gdb-wait-for-pending
+ (gdb-emit-signal gdb-buf-publisher 'update-threads))))
+
+(defun gdb-thread-selected (output-field)
+ "Handler for =thread-selected MI output record.
+
+Sets `gdb-thread-number' to new id."
+ (let* ((result (gdb-json-string output-field))
+ (thread-id (bindat-get-field result 'id)))
+ (gdb-setq-thread-number thread-id)
+ ;; Typing `thread N` in GUD buffer makes GDB emit `^done` followed
+ ;; by `=thread-selected` notification. `^done` causes `gdb-update`
+ ;; as usually. Things happen to fast and second call (from
+ ;; gdb-thread-selected handler) gets cut off by our beloved
+ ;; gdb-pending-triggers.
+ ;; Solution is `gdb-wait-for-pending` macro: it guarantees that its
+ ;; body will get executed when `gdb-pending-triggers` is empty.
+ (gdb-wait-for-pending
+ (gdb-update))))
+
+(defun gdb-running (output-field)
+ (let* ((thread-id (bindat-get-field (gdb-json-string output-field) 'thread-id)))
+ ;; We reset gdb-frame-number to nil if current thread has gone
+ ;; running. This can't be done in gdb-thread-list-handler-custom
+ ;; because we need correct gdb-frame-number by the time
+ ;; -thread-info command is sent.
+ (when (or (string-equal thread-id "all")
+ (string-equal thread-id gdb-thread-number))
+ (setq gdb-frame-number nil)))
+ (setq gdb-inferior-status "running")
+ (gdb-force-mode-line-update
+ (propertize gdb-inferior-status 'face font-lock-type-face))
+ (when (not gdb-non-stop)
+ (setq gud-running t))
+ (setq gdb-active-process t)
+ (gdb-emit-signal gdb-buf-publisher 'update-threads))
+
+(defun gdb-starting (output-field)
+ ;; CLI commands don't emit ^running at the moment so use gdb-running too.
+ (setq gdb-inferior-status "running")
+ (gdb-force-mode-line-update
+ (propertize gdb-inferior-status 'face font-lock-type-face))
+ (setq gdb-active-process t)
+ (setq gud-running t)
+ ;; GDB doesn't seem to respond to -thread-info before first stop or
+ ;; thread exit (even in non-stop mode), so this is useless.
+ ;; Behaviour may change in the future.
+ (gdb-emit-signal gdb-buf-publisher 'update-threads))
+
+;; -break-insert -t didn't give a reason before gdb 6.9
+
+(defun gdb-stopped (output-field)
+ "Given the contents of *stopped MI async record, select new
+current thread and update GDB buffers."
+ ;; Reason is available with target-async only
+ (let* ((result (gdb-json-string output-field))
+ (reason (bindat-get-field result 'reason))
+ (thread-id (bindat-get-field result 'thread-id)))
+
+ ;; -data-list-register-names needs to be issued for any stopped
+ ;; thread
+ (when (not gdb-register-names)
+ (gdb-input
+ (list (concat "-data-list-register-names"
+ (if (string-equal gdb-version "7.0+")
+ (concat" --thread " thread-id)))
+ 'gdb-register-names-handler)))
+
+;;; Don't set gud-last-frame here as it's currently done in gdb-frame-handler
+;;; because synchronous GDB doesn't give these fields with CLI.
+;;; (when file
+;;; (setq
+;;; ;; Extract the frame position from the marker.
+;;; gud-last-frame (cons file
+;;; (string-to-number
+;;; (match-string 6 gud-marker-acc)))))
+
+ (setq gdb-inferior-status (or reason "unknown"))
+ (gdb-force-mode-line-update
+ (propertize gdb-inferior-status 'face font-lock-warning-face))
+ (if (string-equal reason "exited-normally")
+ (setq gdb-active-process nil))
+
+ ;; Select new current thread.
+
+ ;; Don't switch if we have no reasons selected
+ (when gdb-switch-reasons
+ ;; Switch from another stopped thread only if we have
+ ;; gdb-switch-when-another-stopped:
+ (when (or gdb-switch-when-another-stopped
+ (not (string= "stopped"
+ (bindat-get-field (gdb-current-buffer-thread) 'state))))
+ ;; Switch if current reason has been selected or we have no
+ ;; reasons
+ (if (or (eq gdb-switch-reasons t)
+ (member reason gdb-switch-reasons))
+ (when (not (string-equal gdb-thread-number thread-id))
+ (message (concat "Switched to thread " thread-id))
+ (gdb-setq-thread-number thread-id))
+ (message (format "Thread %s stopped" thread-id)))))
+
+ ;; Print "(gdb)" to GUD console
+ (when gdb-first-done-or-error
+ (setq gdb-filter-output (concat gdb-filter-output gdb-prompt-name)))
+
+ ;; In non-stop, we update information as soon as another thread gets
+ ;; stopped
+ (when (or gdb-first-done-or-error
+ gdb-non-stop)
+ ;; In all-stop this updates gud-running properly as well.
+ (gdb-update)
+ (setq gdb-first-done-or-error nil))
+ (run-hook-with-args 'gdb-stopped-hooks result)))
+
+;; Remove the trimmings from log stream containing debugging messages
+;; being produced by GDB's internals, use warning face and send to GUD
+;; buffer.
+(defun gdb-internals (output-field)
+ (setq gdb-filter-output
+ (gdb-concat-output
+ gdb-filter-output
+ (let ((error-message
+ (read output-field)))
+ (put-text-property
+ 0 (length error-message)
+ 'face font-lock-warning-face
+ error-message)
+ error-message))))
+
+;; Remove the trimmings from the console stream and send to GUD buffer
+;; (frontend MI commands should not print to this stream)
+(defun gdb-console (output-field)
+ (setq gdb-filter-output
+ (gdb-concat-output
+ gdb-filter-output
+ (read output-field))))
+
+(defun gdb-done-or-error (output-field token-number type)
+ (if (string-equal token-number "")
+ ;; Output from command entered by user
+ (progn
+ (setq gdb-output-sink 'user)
+ (setq token-number nil)
+ ;; MI error - send to minibuffer
+ (when (eq type 'error)
+ ;; Skip "msg=" from `output-field'
+ (message (read (substring output-field 4)))
+ ;; Don't send to the console twice. (If it is a console error
+ ;; it is also in the console stream.)
+ (setq output-field nil)))
+ ;; Output from command from frontend.
+ (setq gdb-output-sink 'emacs))
+
+ (gdb-clear-partial-output)
+ (when gdb-first-done-or-error
+ (unless (or token-number gud-running)
+ (setq gdb-filter-output (concat gdb-filter-output gdb-prompt-name)))
+ (gdb-update)
+ (setq gdb-first-done-or-error nil))
+
+ (setq gdb-filter-output
+ (gdb-concat-output gdb-filter-output output-field))
+
+ (if token-number
+ (progn
+ (with-current-buffer
+ (gdb-get-buffer-create 'gdb-partial-output-buffer)
+ (funcall
+ (cdr (assoc (string-to-number token-number) gdb-handler-alist))))
+ (setq gdb-handler-alist
+ (assq-delete-all token-number gdb-handler-alist)))))
+
+(defun gdb-concat-output (so-far new)
+ (let ((sink gdb-output-sink))
+ (cond
+ ((eq sink 'user) (concat so-far new))
+ ((eq sink 'emacs)
+ (gdb-append-to-partial-output new)
+ so-far))))
+
+(defun gdb-append-to-partial-output (string)
+ (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer)
+ (goto-char (point-max))
+ (insert string)))
+
+(defun gdb-clear-partial-output ()
+ (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer)
+ (erase-buffer)))
+
+(defun gdb-jsonify-buffer (&optional fix-key fix-list)
+ "Prepare GDB/MI output in current buffer for parsing with `json-read'.
+
+Field names are wrapped in double quotes and equal signs are
+replaced with semicolons.
+
+If FIX-KEY is non-nil, strip all \"FIX-KEY=\" occurrences from
+partial output. This is used to get rid of useless keys in lists
+in MI messages, e.g.: [key=.., key=..]. -stack-list-frames and
+-break-info are examples of MI commands which issue such
+responses.
+
+If FIX-LIST is non-nil, \"FIX-LIST={..}\" is replaced with
+\"FIX-LIST=[..]\" prior to parsing. This is used to fix broken
+-break-info output when it contains breakpoint script field
+incompatible with GDB/MI output syntax."
+ (save-excursion
+ (goto-char (point-min))
+ (when fix-key
+ (save-excursion
+ (while (re-search-forward (concat "[\\[,]\\(" fix-key "=\\)") nil t)
+ (replace-match "" nil nil nil 1))))
+ (when fix-list
+ (save-excursion
+ ;; Find positions of braces which enclose broken list
+ (while (re-search-forward (concat fix-list "={\"") nil t)
+ (let ((p1 (goto-char (- (point) 2)))
+ (p2 (progn (forward-sexp)
+ (1- (point)))))
+ ;; Replace braces with brackets
+ (save-excursion
+ (goto-char p1)
+ (delete-char 1)
+ (insert "[")
+ (goto-char p2)
+ (delete-char 1)
+ (insert "]"))))))
+ (goto-char (point-min))
+ (insert "{")
+ (while (re-search-forward
+ "\\([[:alnum:]-_]+\\)=\\({\\|\\[\\|\"\"\\|\".*?[^\\]\"\\)" nil t)
+ (replace-match "\"\\1\":\\2" nil nil))
+ (goto-char (point-max))
+ (insert "}")))
+
+(defun gdb-json-read-buffer (&optional fix-key fix-list)
+ "Prepare and parse GDB/MI output in current buffer with `json-read'.
+
+FIX-KEY and FIX-LIST work as in `gdb-jsonify-buffer'."
+ (gdb-jsonify-buffer fix-key fix-list)
+ (save-excursion
+ (goto-char (point-min))
+ (let ((json-array-type 'list))
+ (json-read))))
+
+(defun gdb-json-string (string &optional fix-key fix-list)
+ "Prepare and parse STRING containing GDB/MI output with `json-read'.
+
+FIX-KEY and FIX-LIST work as in `gdb-jsonify-buffer'."
+ (with-temp-buffer
+ (insert string)
+ (gdb-json-read-buffer fix-key fix-list)))
+
+(defun gdb-json-partial-output (&optional fix-key fix-list)
+ "Prepare and parse gdb-partial-output-buffer with `json-read'.
+
+FIX-KEY and FIX-KEY work as in `gdb-jsonify-buffer'."
+ (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer)
+ (gdb-json-read-buffer fix-key fix-list)))
+
+(defun gdb-line-posns (line)
+ "Return a pair of LINE beginning and end positions."
+ (let ((offset (1+ (- line (line-number-at-pos)))))
+ (cons
+ (line-beginning-position offset)
+ (line-end-position offset))))
+
+(defmacro gdb-mark-line (line variable)
+ "Set VARIABLE marker to point at beginning of LINE.
+
+If current window has no fringes, inverse colors on LINE.
+
+Return position where LINE begins."
+ `(save-excursion
+ (let* ((posns (gdb-line-posns ,line))
+ (start-posn (car posns))
+ (end-posn (cdr posns)))
+ (set-marker ,variable (copy-marker start-posn))
+ (when (not (> (car (window-fringes)) 0))
+ (put-text-property start-posn end-posn
+ 'font-lock-face '(:inverse-video t)))
+ start-posn)))
+
+(defun gdb-pad-string (string padding)
+ (format (concat "%" (number-to-string padding) "s") string))
+
+;; gdb-table struct is a way to programmatically construct simple
+;; tables. It help to reliably align columns of data in GDB buffers
+;; and provides
+(defstruct
+ gdb-table
+ (column-sizes nil)
+ (rows nil)
+ (row-properties nil)
+ (right-align nil))
+
+(defun gdb-mapcar* (function &rest seqs)
+ "Apply FUNCTION to each element of SEQS, and make a list of the results.
+If there are several SEQS, FUNCTION is called with that many
+arugments, and mapping stops as sson as the shortest list runs
+out."
+ (let ((shortest (apply #'min (mapcar #'length seqs))))
+ (mapcar (lambda (i)
+ (apply function
+ (mapcar
+ (lambda (seq)
+ (nth i seq))
+ seqs)))
+ (number-sequence 0 (1- shortest)))))
+
+(defun gdb-table-add-row (table row &optional properties)
+ "Add ROW of string to TABLE and recalculate column sizes.
+
+When non-nil, PROPERTIES will be added to the whole row when
+calling `gdb-table-string'."
+ (let ((rows (gdb-table-rows table))
+ (row-properties (gdb-table-row-properties table))
+ (column-sizes (gdb-table-column-sizes table))
+ (right-align (gdb-table-right-align table)))
+ (when (not column-sizes)
+ (setf (gdb-table-column-sizes table)
+ (make-list (length row) 0)))
+ (setf (gdb-table-rows table)
+ (append rows (list row)))
+ (setf (gdb-table-row-properties table)
+ (append row-properties (list properties)))
+ (setf (gdb-table-column-sizes table)
+ (gdb-mapcar* (lambda (x s)
+ (let ((new-x
+ (max (abs x) (string-width (or s "")))))
+ (if right-align new-x (- new-x))))
+ (gdb-table-column-sizes table)
+ row))
+ ;; Avoid trailing whitespace at eol
+ (if (not (gdb-table-right-align table))
+ (setcar (last (gdb-table-column-sizes table)) 0))))
+
+(defun gdb-table-string (table &optional sep)
+ "Return TABLE as a string with columns separated with SEP."
+ (let ((column-sizes (gdb-table-column-sizes table))
+ (res ""))
+ (mapconcat
+ 'identity
+ (gdb-mapcar*
+ (lambda (row properties)
+ (apply 'propertize
+ (mapconcat 'identity
+ (gdb-mapcar* (lambda (s x) (gdb-pad-string s x))
+ row column-sizes)
+ sep)
+ properties))
+ (gdb-table-rows table)
+ (gdb-table-row-properties table))
+ "\n")))
+
+;; bindat-get-field goes deep, gdb-get-many-fields goes wide
+(defun gdb-get-many-fields (struct &rest fields)
+ "Return a list of FIELDS values from STRUCT."
+ (let ((values))
+ (dolist (field fields values)
+ (setq values (append values (list (bindat-get-field struct field)))))))
+
+(defmacro def-gdb-auto-update-trigger (trigger-name gdb-command
+ handler-name
+ &optional signal-list)
+ "Define a trigger TRIGGER-NAME which sends GDB-COMMAND and sets
+HANDLER-NAME as its handler. HANDLER-NAME is bound to current
+buffer with `gdb-bind-function-to-buffer'.
+
+If SIGNAL-LIST is non-nil, GDB-COMMAND is sent only when the
+defined trigger is called with an argument from SIGNAL-LIST. It's
+not recommended to define triggers with empty SIGNAL-LIST.
+Normally triggers should respond at least to 'update signal.
+
+Normally the trigger defined by this command must be called from
+the buffer where HANDLER-NAME must work. This should be done so
+that buffer-local thread number may be used in GDB-COMMAND (by
+calling `gdb-current-context-command').
+`gdb-bind-function-to-buffer' is used to achieve this, see
+`gdb-get-buffer-create'.
+
+Triggers defined by this command are meant to be used as a
+trigger argument when describing buffer types with
+`gdb-set-buffer-rules'."
+ `(defun ,trigger-name (&optional signal)
+ (when
+ (or (not ,signal-list)
+ (memq signal ,signal-list))
+ (when (not (gdb-pending-p
+ (cons (current-buffer) ',trigger-name)))
+ (gdb-input
+ (list ,gdb-command
+ (gdb-bind-function-to-buffer ',handler-name (current-buffer))))
+ (gdb-add-pending (cons (current-buffer) ',trigger-name))))))
+
+;; Used by disassembly buffer only, the rest use
+;; def-gdb-trigger-and-handler
+(defmacro def-gdb-auto-update-handler (handler-name trigger-name custom-defun
+ &optional nopreserve)
+ "Define a handler HANDLER-NAME for TRIGGER-NAME with CUSTOM-DEFUN.
+
+Handlers are normally called from the buffers they put output in.
+
+Delete ((current-buffer) . TRIGGER-NAME) from
+`gdb-pending-triggers', erase current buffer and evaluate
+CUSTOM-DEFUN. Then `gdb-update-buffer-name' is called.
+
+If NOPRESERVE is non-nil, window point is not restored after CUSTOM-DEFUN."
+ `(defun ,handler-name ()
+ (gdb-delete-pending (cons (current-buffer) ',trigger-name))
+ (let* ((buffer-read-only nil)
+ (window (get-buffer-window (current-buffer) 0))
+ (start (window-start window))
+ (p (window-point window)))
+ (erase-buffer)
+ (,custom-defun)
+ (gdb-update-buffer-name)
+ ,(when (not nopreserve)
+ '(set-window-start window start)
+ '(set-window-point window p)))))
+
+(defmacro def-gdb-trigger-and-handler (trigger-name gdb-command
+ handler-name custom-defun
+ &optional signal-list)
+ "Define trigger and handler.
+
+TRIGGER-NAME trigger is defined to send GDB-COMMAND. See
+`def-gdb-auto-update-trigger'.
+
+HANDLER-NAME handler uses customization of CUSTOM-DEFUN. See
+`def-gdb-auto-update-handler'."
+ `(progn
+ (def-gdb-auto-update-trigger ,trigger-name
+ ,gdb-command
+ ,handler-name ,signal-list)
+ (def-gdb-auto-update-handler ,handler-name
+ ,trigger-name ,custom-defun)))
+
+
+
+;; Breakpoint buffer : This displays the output of `-break-list'.
+(def-gdb-trigger-and-handler
+ gdb-invalidate-breakpoints "-break-list"
+ gdb-breakpoints-list-handler gdb-breakpoints-list-handler-custom
+ '(start update))
+
+(gdb-set-buffer-rules
+ 'gdb-breakpoints-buffer
+ 'gdb-breakpoints-buffer-name
+ 'gdb-breakpoints-mode
+ 'gdb-invalidate-breakpoints)
+
+(defun gdb-breakpoints-list-handler-custom ()
+ (let ((breakpoints-list (bindat-get-field
+ (gdb-json-partial-output "bkpt" "script")
+ 'BreakpointTable 'body))
+ (table (make-gdb-table)))
+ (setq gdb-breakpoints-list nil)
+ (gdb-table-add-row table '("Num" "Type" "Disp" "Enb" "Addr" "Hits" "What"))
+ (dolist (breakpoint breakpoints-list)
+ (add-to-list 'gdb-breakpoints-list
+ (cons (bindat-get-field breakpoint 'number)
+ breakpoint))
+ (let ((at (bindat-get-field breakpoint 'at))
+ (pending (bindat-get-field breakpoint 'pending))
+ (func (bindat-get-field breakpoint 'func))
+ (type (bindat-get-field breakpoint 'type)))
+ (gdb-table-add-row table
+ (list
+ (bindat-get-field breakpoint 'number)
+ type
+ (bindat-get-field breakpoint 'disp)
+ (let ((flag (bindat-get-field breakpoint 'enabled)))
+ (if (string-equal flag "y")
+ (propertize "y" 'font-lock-face font-lock-warning-face)
+ (propertize "n" 'font-lock-face font-lock-comment-face)))
+ (bindat-get-field breakpoint 'addr)
+ (bindat-get-field breakpoint 'times)
+ (if (string-match ".*watchpoint" type)
+ (bindat-get-field breakpoint 'what)
+ (or pending at
+ (concat "in "
+ (propertize func 'font-lock-face font-lock-function-name-face)
+ (gdb-frame-location breakpoint)))))
+ ;; Add clickable properties only for breakpoints with file:line
+ ;; information
+ (append (list 'gdb-breakpoint breakpoint)
+ (when func '(help-echo "mouse-2, RET: visit breakpoint"
+ mouse-face highlight))))))
+ (insert (gdb-table-string table " "))
+ (gdb-place-breakpoints)))
+
+;; Put breakpoint icons in relevant margins (even those set in the GUD buffer).
+(defun gdb-place-breakpoints ()
+ (let ((flag) (bptno))
+ ;; Remove all breakpoint-icons in source buffers but not assembler buffer.
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (if (and (eq gud-minor-mode 'gdbmi)
+ (not (string-match "\\` ?\\*.+\\*\\'" (buffer-name))))
+ (gdb-remove-breakpoint-icons (point-min) (point-max)))))
+ (dolist (breakpoint gdb-breakpoints-list)
+ (let* ((breakpoint (cdr breakpoint)) ; gdb-breakpoints-list is
+ ; an associative list
+ (line (bindat-get-field breakpoint 'line)))
+ (when line
+ (let ((file (bindat-get-field breakpoint 'fullname))
+ (flag (bindat-get-field breakpoint 'enabled))
+ (bptno (bindat-get-field breakpoint 'number)))
+ (unless (file-exists-p file)
+ (setq file (cdr (assoc bptno gdb-location-alist))))
+ (if (and file
+ (not (string-equal file "File not found")))
+ (with-current-buffer
+ (find-file-noselect file 'nowarn)
+ (gdb-init-buffer)
+ ;; Only want one breakpoint icon at each location.
+ (gdb-put-breakpoint-icon (string-equal flag "y") bptno
+ (string-to-number line)))
+ (gdb-input
+ (list (concat "list " file ":1")
+ 'ignore))
+ (gdb-input
+ (list "-file-list-exec-source-file"
+ `(lambda () (gdb-get-location
+ ,bptno ,line ,flag)))))))))))
+
+(defvar gdb-source-file-regexp "fullname=\"\\(.*?\\)\"")
+
+(defun gdb-get-location (bptno line flag)
+ "Find the directory containing the relevant source file.
+Put in buffer and place breakpoint icon."
+ (goto-char (point-min))
+ (catch 'file-not-found
+ (if (re-search-forward gdb-source-file-regexp nil t)
+ (delete (cons bptno "File not found") gdb-location-alist)
+ (push (cons bptno (match-string 1)) gdb-location-alist)
+ (gdb-resync)
+ (unless (assoc bptno gdb-location-alist)
+ (push (cons bptno "File not found") gdb-location-alist)
+ (message-box "Cannot find source file for breakpoint location.
+Add directory to search path for source files using the GDB command, dir."))
+ (throw 'file-not-found nil))
+ (with-current-buffer (find-file-noselect (match-string 1))
+ (gdb-init-buffer)
+ ;; only want one breakpoint icon at each location
+ (gdb-put-breakpoint-icon (eq flag ?y) bptno (string-to-number line)))))
+
+(add-hook 'find-file-hook 'gdb-find-file-hook)
+
+(defun gdb-find-file-hook ()
+ "Set up buffer for debugging if file is part of the source code
+of the current session."
+ (if (and (buffer-name gud-comint-buffer)
+ ;; in case gud or gdb-ui is just loaded
+ gud-comint-buffer
+ (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
+ 'gdbmi))
+ (if (member buffer-file-name gdb-source-file-list)
+ (with-current-buffer (find-buffer-visiting buffer-file-name)
+ (gdb-init-buffer)))))
+
+(declare-function gud-remove "gdb-mi" t t) ; gud-def
+(declare-function gud-break "gdb-mi" t t) ; gud-def
+(declare-function fringe-bitmaps-at-pos "fringe.c" (&optional pos window))
+
+(defun gdb-mouse-set-clear-breakpoint (event)
+ "Set/clear breakpoint in left fringe/margin at mouse click.
+If not in a source or disassembly buffer just set point."
+ (interactive "e")
+ (mouse-minibuffer-check event)
+ (let ((posn (event-end event)))
+ (with-selected-window (posn-window posn)
+ (if (or (buffer-file-name) (eq major-mode 'gdb-disassembly-mode))
+ (if (numberp (posn-point posn))
+ (save-excursion
+ (goto-char (posn-point posn))
+ (if (or (posn-object posn)
+ (eq (car (fringe-bitmaps-at-pos (posn-point posn)))
+ 'breakpoint))
+ (gud-remove nil)
+ (gud-break nil)))))
+ (posn-set-point posn))))
+
+(defun gdb-mouse-toggle-breakpoint-margin (event)
+ "Enable/disable breakpoint in left margin with mouse click."
+ (interactive "e")
+ (mouse-minibuffer-check event)
+ (let ((posn (event-end event)))
+ (if (numberp (posn-point posn))
+ (with-selected-window (posn-window posn)
+ (save-excursion
+ (goto-char (posn-point posn))
+ (if (posn-object posn)
+ (gud-basic-call
+ (let ((bptno (get-text-property
+ 0 'gdb-bptno (car (posn-string posn)))))
+ (concat
+ (if (get-text-property
+ 0 'gdb-enabled (car (posn-string posn)))
+ "-break-disable "
+ "-break-enable ")
+ bptno)))))))))
+
+(defun gdb-mouse-toggle-breakpoint-fringe (event)
+ "Enable/disable breakpoint in left fringe with mouse click."
+ (interactive "e")
+ (mouse-minibuffer-check event)
+ (let* ((posn (event-end event))
+ (pos (posn-point posn))
+ obj)
+ (when (numberp pos)
+ (with-selected-window (posn-window posn)
+ (with-current-buffer (window-buffer (selected-window))
+ (goto-char pos)
+ (dolist (overlay (overlays-in pos pos))
+ (when (overlay-get overlay 'put-break)
+ (setq obj (overlay-get overlay 'before-string))))
+ (when (stringp obj)
+ (gud-basic-call
+ (concat
+ (if (get-text-property 0 'gdb-enabled obj)
+ "-break-disable "
+ "-break-enable ")
+ (get-text-property 0 'gdb-bptno obj)))))))))
+
+(defun gdb-breakpoints-buffer-name ()
+ (concat "*breakpoints of " (gdb-get-target-string) "*"))
+
+(def-gdb-display-buffer
+ gdb-display-breakpoints-buffer
+ 'gdb-breakpoints-buffer
+ "Display status of user-settable breakpoints.")
+
+(def-gdb-frame-for-buffer
+ gdb-frame-breakpoints-buffer
+ 'gdb-breakpoints-buffer
+ "Display status of user-settable breakpoints in a new frame.")
+
+(defvar gdb-breakpoints-mode-map
+ (let ((map (make-sparse-keymap))
+ (menu (make-sparse-keymap "Breakpoints")))
+ (define-key menu [quit] '("Quit" . gdb-delete-frame-or-window))
+ (define-key menu [goto] '("Goto" . gdb-goto-breakpoint))
+ (define-key menu [delete] '("Delete" . gdb-delete-breakpoint))
+ (define-key menu [toggle] '("Toggle" . gdb-toggle-breakpoint))
+ (suppress-keymap map)
+ (define-key map [menu-bar breakpoints] (cons "Breakpoints" menu))
+ (define-key map " " 'gdb-toggle-breakpoint)
+ (define-key map "D" 'gdb-delete-breakpoint)
+ ;; Don't bind "q" to kill-this-buffer as we need it for breakpoint icons.
+ (define-key map "q" 'gdb-delete-frame-or-window)
+ (define-key map "\r" 'gdb-goto-breakpoint)
+ (define-key map "\t" '(lambda ()
+ (interactive)
+ (gdb-set-window-buffer
+ (gdb-get-buffer-create 'gdb-threads-buffer) t)))
+ (define-key map [mouse-2] 'gdb-goto-breakpoint)
+ (define-key map [follow-link] 'mouse-face)
+ map))
+
+(defun gdb-delete-frame-or-window ()
+ "Delete frame if there is only one window. Otherwise delete the window."
+ (interactive)
+ (if (one-window-p) (delete-frame)
+ (delete-window)))
+
+;;from make-mode-line-mouse-map
+(defun gdb-make-header-line-mouse-map (mouse function) "\
+Return a keymap with single entry for mouse key MOUSE on the header line.
+MOUSE is defined to run function FUNCTION with no args in the buffer
+corresponding to the mode line clicked."
+ (let ((map (make-sparse-keymap)))
+ (define-key map (vector 'header-line mouse) function)
+ (define-key map (vector 'header-line 'down-mouse-1) 'ignore)
+ map))
+
+(defmacro gdb-propertize-header (name buffer help-echo mouse-face face)
+ `(propertize ,name
+ 'help-echo ,help-echo
+ 'mouse-face ',mouse-face
+ 'face ',face
+ 'local-map
+ (gdb-make-header-line-mouse-map
+ 'mouse-1
+ (lambda (event) (interactive "e")
+ (save-selected-window
+ (select-window (posn-window (event-start event)))
+ (gdb-set-window-buffer
+ (gdb-get-buffer-create ',buffer) t) )))))
+
+
+;; uses "-thread-info". Needs GDB 7.0 onwards.
+;;; Threads view
+
+(defun gdb-threads-buffer-name ()
+ (concat "*threads of " (gdb-get-target-string) "*"))
+
+(def-gdb-display-buffer
+ gdb-display-threads-buffer
+ 'gdb-threads-buffer
+ "Display GDB threads.")
+
+(def-gdb-frame-for-buffer
+ gdb-frame-threads-buffer
+ 'gdb-threads-buffer
+ "Display GDB threads in a new frame.")
+
+(def-gdb-trigger-and-handler
+ gdb-invalidate-threads (gdb-current-context-command "-thread-info")
+ gdb-thread-list-handler gdb-thread-list-handler-custom
+ '(start update update-threads))
+
+(gdb-set-buffer-rules
+ 'gdb-threads-buffer
+ 'gdb-threads-buffer-name
+ 'gdb-threads-mode
+ 'gdb-invalidate-threads)
+
+(defvar gdb-threads-font-lock-keywords
+ '(("in \\([^ ]+\\)" (1 font-lock-function-name-face))
+ (" \\(stopped\\)" (1 font-lock-warning-face))
+ (" \\(running\\)" (1 font-lock-string-face))
+ ("\\(\\(\\sw\\|[_.]\\)+\\)=" (1 font-lock-variable-name-face)))
+ "Font lock keywords used in `gdb-threads-mode'.")
+
+(defvar gdb-threads-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\r" 'gdb-select-thread)
+ (define-key map "f" 'gdb-display-stack-for-thread)
+ (define-key map "F" 'gdb-frame-stack-for-thread)
+ (define-key map "l" 'gdb-display-locals-for-thread)
+ (define-key map "L" 'gdb-frame-locals-for-thread)
+ (define-key map "r" 'gdb-display-registers-for-thread)
+ (define-key map "R" 'gdb-frame-registers-for-thread)
+ (define-key map "d" 'gdb-display-disassembly-for-thread)
+ (define-key map "D" 'gdb-frame-disassembly-for-thread)
+ (define-key map "i" 'gdb-interrupt-thread)
+ (define-key map "c" 'gdb-continue-thread)
+ (define-key map "s" 'gdb-step-thread)
+ (define-key map "\t" '(lambda ()
+ (interactive)
+ (gdb-set-window-buffer
+ (gdb-get-buffer-create 'gdb-breakpoints-buffer) t)))
+ (define-key map [mouse-2] 'gdb-select-thread)
+ (define-key map [follow-link] 'mouse-face)
+ map))
+
+(defvar gdb-threads-header
+ (list
+ (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer
+ "mouse-1: select" mode-line-highlight mode-line-inactive)
+ " "
+ (gdb-propertize-header "Threads" gdb-threads-buffer
+ nil nil mode-line)))
+
+(define-derived-mode gdb-threads-mode gdb-parent-mode "Threads"
+ "Major mode for GDB threads.
+
+\\{gdb-threads-mode-map}"
+ (setq gdb-thread-position (make-marker))
+ (add-to-list 'overlay-arrow-variable-list 'gdb-thread-position)
+ (setq header-line-format gdb-threads-header)
+ (set (make-local-variable 'font-lock-defaults)
+ '(gdb-threads-font-lock-keywords))
+ (run-mode-hooks 'gdb-threads-mode-hook)
+ 'gdb-invalidate-threads)
+
+(defun gdb-thread-list-handler-custom ()
+ (let ((threads-list (bindat-get-field (gdb-json-partial-output) 'threads))
+ (table (make-gdb-table))
+ (marked-line nil))
+ (setq gdb-threads-list nil)
+ (setq gdb-running-threads-count 0)
+ (setq gdb-stopped-threads-count 0)
+ (set-marker gdb-thread-position nil)
+
+ (dolist (thread (reverse threads-list))
+ (let ((running (string-equal (bindat-get-field thread 'state) "running")))
+ (add-to-list 'gdb-threads-list
+ (cons (bindat-get-field thread 'id)
+ thread))
+ (if running
+ (incf gdb-running-threads-count)
+ (incf gdb-stopped-threads-count))
+
+ (gdb-table-add-row table
+ (list
+ (bindat-get-field thread 'id)
+ (concat
+ (if gdb-thread-buffer-verbose-names
+ (concat (bindat-get-field thread 'target-id) " ") "")
+ (bindat-get-field thread 'state)
+ ;; Include frame information for stopped threads
+ (if (not running)
+ (concat
+ " in " (bindat-get-field thread 'frame 'func)
+ (if gdb-thread-buffer-arguments
+ (concat
+ " ("
+ (let ((args (bindat-get-field thread 'frame 'args)))
+ (mapconcat
+ (lambda (arg)
+ (apply 'format `("%s=%s" ,@(gdb-get-many-fields arg 'name 'value))))
+ args ","))
+ ")")
+ "")
+ (if gdb-thread-buffer-locations
+ (gdb-frame-location (bindat-get-field thread 'frame)) "")
+ (if gdb-thread-buffer-addresses
+ (concat " at " (bindat-get-field thread 'frame 'addr)) ""))
+ "")))
+ (list
+ 'gdb-thread thread
+ 'mouse-face 'highlight
+ 'help-echo "mouse-2, RET: select thread")))
+ (when (string-equal gdb-thread-number
+ (bindat-get-field thread 'id))
+ (setq marked-line (length gdb-threads-list))))
+ (insert (gdb-table-string table " "))
+ (when marked-line
+ (gdb-mark-line marked-line gdb-thread-position)))
+ ;; We update gud-running here because we need to make sure that
+ ;; gdb-threads-list is up-to-date
+ (gdb-update-gud-running)
+ (gdb-emit-signal gdb-buf-publisher 'update-disassembly))
+
+(defmacro def-gdb-thread-buffer-command (name custom-defun &optional doc)
+ "Define a NAME command which will act upon thread on the current line.
+
+CUSTOM-DEFUN may use locally bound `thread' variable, which will
+be the value of 'gdb-thread property of the current line. If
+'gdb-thread is nil, error is signaled."
+ `(defun ,name (&optional event)
+ ,(when doc doc)
+ (interactive (list last-input-event))
+ (if event (posn-set-point (event-end event)))
+ (save-excursion
+ (beginning-of-line)
+ (let ((thread (get-text-property (point) 'gdb-thread)))
+ (if thread
+ ,custom-defun
+ (error "Not recognized as thread line"))))))
+
+(defmacro def-gdb-thread-buffer-simple-command (name buffer-command &optional doc)
+ "Define a NAME which will call BUFFER-COMMAND with id of thread
+on the current line."
+ `(def-gdb-thread-buffer-command ,name
+ (,buffer-command (bindat-get-field thread 'id))
+ ,doc))
+
+(def-gdb-thread-buffer-command gdb-select-thread
+ (let ((new-id (bindat-get-field thread 'id)))
+ (gdb-setq-thread-number new-id)
+ (gdb-input (list (concat "-thread-select " new-id) 'ignore))
+ (gdb-update))
+ "Select the thread at current line of threads buffer.")
+
+(def-gdb-thread-buffer-simple-command
+ gdb-display-stack-for-thread
+ gdb-preemptively-display-stack-buffer
+ "Display stack buffer for the thread at current line.")
+
+(def-gdb-thread-buffer-simple-command
+ gdb-display-locals-for-thread
+ gdb-preemptively-display-locals-buffer
+ "Display locals buffer for the thread at current line.")
+
+(def-gdb-thread-buffer-simple-command
+ gdb-display-registers-for-thread
+ gdb-preemptively-display-registers-buffer
+ "Display registers buffer for the thread at current line.")
+
+(def-gdb-thread-buffer-simple-command
+ gdb-display-disassembly-for-thread
+ gdb-preemptively-display-disassembly-buffer
+ "Display disassembly buffer for the thread at current line.")
+
+(def-gdb-thread-buffer-simple-command
+ gdb-frame-stack-for-thread
+ gdb-frame-stack-buffer
+ "Display a new frame with stack buffer for the thread at
+current line.")
+
+(def-gdb-thread-buffer-simple-command
+ gdb-frame-locals-for-thread
+ gdb-frame-locals-buffer
+ "Display a new frame with locals buffer for the thread at
+current line.")
+
+(def-gdb-thread-buffer-simple-command
+ gdb-frame-registers-for-thread
+ gdb-frame-registers-buffer
+ "Display a new frame with registers buffer for the thread at
+current line.")
+
+(def-gdb-thread-buffer-simple-command
+ gdb-frame-disassembly-for-thread
+ gdb-frame-disassembly-buffer
+ "Display a new frame with disassembly buffer for the thread at
+current line.")
+
+(defmacro def-gdb-thread-buffer-gud-command (name gud-command &optional doc)
+ "Define a NAME which will execute GUD-COMMAND with
+`gdb-thread-number' locally bound to id of thread on the current
+line."
+ `(def-gdb-thread-buffer-command ,name
+ (if gdb-non-stop
+ (let ((gdb-thread-number (bindat-get-field thread 'id))
+ (gdb-gud-control-all-threads nil))
+ (call-interactively #',gud-command))
+ (error "Available in non-stop mode only, customize `gdb-non-stop-setting'"))
+ ,doc))
+
+(def-gdb-thread-buffer-gud-command
+ gdb-interrupt-thread
+ gud-stop-subjob
+ "Interrupt thread at current line.")
+
+(def-gdb-thread-buffer-gud-command
+ gdb-continue-thread
+ gud-cont
+ "Continue thread at current line.")
+
+(def-gdb-thread-buffer-gud-command
+ gdb-step-thread
+ gud-step
+ "Step thread at current line.")
+
+
+;;; Memory view
+
+(defcustom gdb-memory-rows 8
+ "Number of data rows in memory window."
+ :type 'integer
+ :group 'gud
+ :version "23.2")
+
+(defcustom gdb-memory-columns 4
+ "Number of data columns in memory window."
+ :type 'integer
+ :group 'gud
+ :version "23.2")
+
+(defcustom gdb-memory-format "x"
+ "Display format of data items in memory window."
+ :type '(choice (const :tag "Hexadecimal" "x")
+ (const :tag "Signed decimal" "d")
+ (const :tag "Unsigned decimal" "u")
+ (const :tag "Octal" "o")
+ (const :tag "Binary" "t"))
+ :group 'gud
+ :version "22.1")
+
+(defcustom gdb-memory-unit 4
+ "Unit size of data items in memory window."
+ :type '(choice (const :tag "Byte" 1)
+ (const :tag "Halfword" 2)
+ (const :tag "Word" 4)
+ (const :tag "Giant word" 8))
+ :group 'gud
+ :version "23.2")
+
+(def-gdb-trigger-and-handler
+ gdb-invalidate-memory
+ (format "-data-read-memory %s %s %d %d %d"
+ gdb-memory-address
+ gdb-memory-format
+ gdb-memory-unit
+ gdb-memory-rows
+ gdb-memory-columns)
+ gdb-read-memory-handler
+ gdb-read-memory-custom
+ '(start update))
+
+(gdb-set-buffer-rules
+ 'gdb-memory-buffer
+ 'gdb-memory-buffer-name
+ 'gdb-memory-mode
+ 'gdb-invalidate-memory)
+
+(defun gdb-memory-column-width (size format)
+ "Return length of string with memory unit of SIZE in FORMAT.
+
+SIZE is in bytes, as in `gdb-memory-unit'. FORMAT is a string as
+in `gdb-memory-format'."
+ (let ((format-base (cdr (assoc format
+ '(("x" . 16)
+ ("d" . 10) ("u" . 10)
+ ("o" . 8)
+ ("t" . 2))))))
+ (if format-base
+ (let ((res (ceiling (log (expt 2.0 (* size 8)) format-base))))
+ (cond ((string-equal format "x")
+ (+ 2 res)) ; hexadecimal numbers have 0x in front
+ ((or (string-equal format "d")
+ (string-equal format "o"))
+ (1+ res))
+ (t res)))
+ (error "Unknown format"))))
+
+(defun gdb-read-memory-custom ()
+ (let* ((res (gdb-json-partial-output))
+ (err-msg (bindat-get-field res 'msg)))
+ (if (not err-msg)
+ (let ((memory (bindat-get-field res 'memory)))
+ (setq gdb-memory-address (bindat-get-field res 'addr))
+ (setq gdb-memory-next-page (bindat-get-field res 'next-page))
+ (setq gdb-memory-prev-page (bindat-get-field res 'prev-page))
+ (setq gdb-memory-last-address gdb-memory-address)
+ (dolist (row memory)
+ (insert (concat (bindat-get-field row 'addr) ":"))
+ (dolist (column (bindat-get-field row 'data))
+ (insert (gdb-pad-string column
+ (+ 2 (gdb-memory-column-width
+ gdb-memory-unit
+ gdb-memory-format)))))
+ (newline)))
+ ;; Show last page instead of empty buffer when out of bounds
+ (progn
+ (let ((gdb-memory-address gdb-memory-last-address))
+ (gdb-invalidate-memory 'update)
+ (error err-msg))))))
+
+(defvar gdb-memory-mode-map
+ (let ((map (make-sparse-keymap)))
+ (suppress-keymap map t)
+ (define-key map "q" 'kill-this-buffer)
+ (define-key map "n" 'gdb-memory-show-next-page)
+ (define-key map "p" 'gdb-memory-show-previous-page)
+ (define-key map "a" 'gdb-memory-set-address)
+ (define-key map "t" 'gdb-memory-format-binary)
+ (define-key map "o" 'gdb-memory-format-octal)
+ (define-key map "u" 'gdb-memory-format-unsigned)
+ (define-key map "d" 'gdb-memory-format-signed)
+ (define-key map "x" 'gdb-memory-format-hexadecimal)
+ (define-key map "b" 'gdb-memory-unit-byte)
+ (define-key map "h" 'gdb-memory-unit-halfword)
+ (define-key map "w" 'gdb-memory-unit-word)
+ (define-key map "g" 'gdb-memory-unit-giant)
+ (define-key map "R" 'gdb-memory-set-rows)
+ (define-key map "C" 'gdb-memory-set-columns)
+ map))
+
+(defun gdb-memory-set-address-event (event)
+ "Handle a click on address field in memory buffer header."
+ (interactive "e")
+ (save-selected-window
+ (select-window (posn-window (event-start event)))
+ (gdb-memory-set-address)))
+
+;; Non-event version for use within keymap
+(defun gdb-memory-set-address ()
+ "Set the start memory address."
+ (interactive)
+ (let ((arg (read-from-minibuffer "Memory address: ")))
+ (setq gdb-memory-address arg))
+ (gdb-invalidate-memory 'update))
+
+(defmacro def-gdb-set-positive-number (name variable echo-string &optional doc)
+ "Define a function NAME which reads new VAR value from minibuffer."
+ `(defun ,name (event)
+ ,(when doc doc)
+ (interactive "e")
+ (save-selected-window
+ (select-window (posn-window (event-start event)))
+ (let* ((arg (read-from-minibuffer ,echo-string))
+ (count (string-to-number arg)))
+ (if (<= count 0)
+ (error "Positive number only")
+ (customize-set-variable ',variable count)
+ (gdb-invalidate-memory 'update))))))
+
+(def-gdb-set-positive-number
+ gdb-memory-set-rows
+ gdb-memory-rows
+ "Rows: "
+ "Set the number of data rows in memory window.")
+
+(def-gdb-set-positive-number
+ gdb-memory-set-columns
+ gdb-memory-columns
+ "Columns: "
+ "Set the number of data columns in memory window.")
+
+(defmacro def-gdb-memory-format (name format doc)
+ "Define a function NAME to switch memory buffer to use FORMAT.
+
+DOC is an optional documentation string."
+ `(defun ,name () ,(when doc doc)
+ (interactive)
+ (customize-set-variable 'gdb-memory-format ,format)
+ (gdb-invalidate-memory 'update)))
+
+(def-gdb-memory-format
+ gdb-memory-format-binary "t"
+ "Set the display format to binary.")
+
+(def-gdb-memory-format
+ gdb-memory-format-octal "o"
+ "Set the display format to octal.")
+
+(def-gdb-memory-format
+ gdb-memory-format-unsigned "u"
+ "Set the display format to unsigned decimal.")
+
+(def-gdb-memory-format
+ gdb-memory-format-signed "d"
+ "Set the display format to decimal.")
+
+(def-gdb-memory-format
+ gdb-memory-format-hexadecimal "x"
+ "Set the display format to hexadecimal.")
+
+(defvar gdb-memory-format-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [header-line down-mouse-3] 'gdb-memory-format-menu-1)
+ map)
+ "Keymap to select format in the header line.")
+
+(defvar gdb-memory-format-menu (make-sparse-keymap "Format")
+ "Menu of display formats in the header line.")
+
+(define-key gdb-memory-format-menu [binary]
+ '(menu-item "Binary" gdb-memory-format-binary
+ :button (:radio . (equal gdb-memory-format "t"))))
+(define-key gdb-memory-format-menu [octal]
+ '(menu-item "Octal" gdb-memory-format-octal
+ :button (:radio . (equal gdb-memory-format "o"))))
+(define-key gdb-memory-format-menu [unsigned]
+ '(menu-item "Unsigned Decimal" gdb-memory-format-unsigned
+ :button (:radio . (equal gdb-memory-format "u"))))
+(define-key gdb-memory-format-menu [signed]
+ '(menu-item "Signed Decimal" gdb-memory-format-signed
+ :button (:radio . (equal gdb-memory-format "d"))))
+(define-key gdb-memory-format-menu [hexadecimal]
+ '(menu-item "Hexadecimal" gdb-memory-format-hexadecimal
+ :button (:radio . (equal gdb-memory-format "x"))))
+
+(defun gdb-memory-format-menu (event)
+ (interactive "@e")
+ (x-popup-menu event gdb-memory-format-menu))
+
+(defun gdb-memory-format-menu-1 (event)
+ (interactive "e")
+ (save-selected-window
+ (select-window (posn-window (event-start event)))
+ (let* ((selection (gdb-memory-format-menu event))
+ (binding (and selection (lookup-key gdb-memory-format-menu
+ (vector (car selection))))))
+ (if binding (call-interactively binding)))))
+
+(defmacro def-gdb-memory-unit (name unit-size doc)
+ "Define a function NAME to switch memory unit size to UNIT-SIZE.
+
+DOC is an optional documentation string."
+ `(defun ,name () ,(when doc doc)
+ (interactive)
+ (customize-set-variable 'gdb-memory-unit ,unit-size)
+ (gdb-invalidate-memory 'update)))
+
+(def-gdb-memory-unit gdb-memory-unit-giant 8
+ "Set the unit size to giant words (eight bytes).")
+
+(def-gdb-memory-unit gdb-memory-unit-word 4
+ "Set the unit size to words (four bytes).")
+
+(def-gdb-memory-unit gdb-memory-unit-halfword 2
+ "Set the unit size to halfwords (two bytes).")
+
+(def-gdb-memory-unit gdb-memory-unit-byte 1
+ "Set the unit size to bytes.")
+
+(defmacro def-gdb-memory-show-page (name address-var &optional doc)
+ "Define a function NAME which show new address in memory buffer.
+
+The defined function switches Memory buffer to show address
+stored in ADDRESS-VAR variable.
+
+DOC is an optional documentation string."
+ `(defun ,name
+ ,(when doc doc)
+ (interactive)
+ (let ((gdb-memory-address ,address-var))
+ (gdb-invalidate-memory))))
+
+(def-gdb-memory-show-page gdb-memory-show-previous-page
+ gdb-memory-prev-page)
+
+(def-gdb-memory-show-page gdb-memory-show-next-page
+ gdb-memory-next-page)
+
+(defvar gdb-memory-unit-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [header-line down-mouse-3] 'gdb-memory-unit-menu-1)
+ map)
+ "Keymap to select units in the header line.")
+
+(defvar gdb-memory-unit-menu (make-sparse-keymap "Unit")
+ "Menu of units in the header line.")
+
+(define-key gdb-memory-unit-menu [giantwords]
+ '(menu-item "Giant words" gdb-memory-unit-giant
+ :button (:radio . (equal gdb-memory-unit 8))))
+(define-key gdb-memory-unit-menu [words]
+ '(menu-item "Words" gdb-memory-unit-word
+ :button (:radio . (equal gdb-memory-unit 4))))
+(define-key gdb-memory-unit-menu [halfwords]
+ '(menu-item "Halfwords" gdb-memory-unit-halfword
+ :button (:radio . (equal gdb-memory-unit 2))))
+(define-key gdb-memory-unit-menu [bytes]
+ '(menu-item "Bytes" gdb-memory-unit-byte
+ :button (:radio . (equal gdb-memory-unit 1))))
+
+(defun gdb-memory-unit-menu (event)
+ (interactive "@e")
+ (x-popup-menu event gdb-memory-unit-menu))
+
+(defun gdb-memory-unit-menu-1 (event)
+ (interactive "e")
+ (save-selected-window
+ (select-window (posn-window (event-start event)))
+ (let* ((selection (gdb-memory-unit-menu event))
+ (binding (and selection (lookup-key gdb-memory-unit-menu
+ (vector (car selection))))))
+ (if binding (call-interactively binding)))))
+
+(defvar gdb-memory-font-lock-keywords
+ '(;; <__function.name+n>
+ ("<\\(\\(\\sw\\|[_.]\\)+\\)\\(\\+[0-9]+\\)?>" (1 font-lock-function-name-face))
+ )
+ "Font lock keywords used in `gdb-memory-mode'.")
+
+(defvar gdb-memory-header
+ '(:eval
+ (concat
+ "Start address["
+ (propertize "-"
+ 'face font-lock-warning-face
+ 'help-echo "mouse-1: decrement address"
+ 'mouse-face 'mode-line-highlight
+ 'local-map (gdb-make-header-line-mouse-map
+ 'mouse-1
+ #'gdb-memory-show-previous-page))
+ "|"
+ (propertize "+"
+ 'face font-lock-warning-face
+ 'help-echo "mouse-1: increment address"
+ 'mouse-face 'mode-line-highlight
+ 'local-map (gdb-make-header-line-mouse-map
+ 'mouse-1
+ #'gdb-memory-show-next-page))
+ "]: "
+ (propertize gdb-memory-address
+ 'face font-lock-warning-face
+ 'help-echo "mouse-1: set start address"
+ 'mouse-face 'mode-line-highlight
+ 'local-map (gdb-make-header-line-mouse-map
+ 'mouse-1
+ #'gdb-memory-set-address-event))
+ " Rows: "
+ (propertize (number-to-string gdb-memory-rows)
+ 'face font-lock-warning-face
+ 'help-echo "mouse-1: set number of columns"
+ 'mouse-face 'mode-line-highlight
+ 'local-map (gdb-make-header-line-mouse-map
+ 'mouse-1
+ #'gdb-memory-set-rows))
+ " Columns: "
+ (propertize (number-to-string gdb-memory-columns)
+ 'face font-lock-warning-face
+ 'help-echo "mouse-1: set number of columns"
+ 'mouse-face 'mode-line-highlight
+ 'local-map (gdb-make-header-line-mouse-map
+ 'mouse-1
+ #'gdb-memory-set-columns))
+ " Display Format: "
+ (propertize gdb-memory-format
+ 'face font-lock-warning-face
+ 'help-echo "mouse-3: select display format"
+ 'mouse-face 'mode-line-highlight
+ 'local-map gdb-memory-format-map)
+ " Unit Size: "
+ (propertize (number-to-string gdb-memory-unit)
+ 'face font-lock-warning-face
+ 'help-echo "mouse-3: select unit size"
+ 'mouse-face 'mode-line-highlight
+ 'local-map gdb-memory-unit-map)))
+ "Header line used in `gdb-memory-mode'.")
+
+(define-derived-mode gdb-memory-mode gdb-parent-mode "Memory"
+ "Major mode for examining memory.
+
+\\{gdb-memory-mode-map}"
+ (setq header-line-format gdb-memory-header)
+ (set (make-local-variable 'font-lock-defaults)
+ '(gdb-memory-font-lock-keywords))
+ (run-mode-hooks 'gdb-memory-mode-hook)
+ 'gdb-invalidate-memory)
+
+(defun gdb-memory-buffer-name ()
+ (concat "*memory of " (gdb-get-target-string) "*"))
+
+(def-gdb-display-buffer
+ gdb-display-memory-buffer
+ 'gdb-memory-buffer
+ "Display memory contents.")
+
+(defun gdb-frame-memory-buffer ()
+ "Display memory contents in a new frame."
+ (interactive)
+ (let* ((special-display-regexps (append special-display-regexps '(".*")))
+ (special-display-frame-alist
+ `((left-fringe . 0)
+ (right-fringe . 0)
+ (width . 83)
+ ,@gdb-frame-parameters)))
+ (display-buffer (gdb-get-buffer-create 'gdb-memory-buffer))))
+
+
+;;; Disassembly view
+
+(defun gdb-disassembly-buffer-name ()
+ (gdb-current-context-buffer-name
+ (concat "disassembly of " (gdb-get-target-string))))
+
+(def-gdb-display-buffer
+ gdb-display-disassembly-buffer
+ 'gdb-disassembly-buffer
+ "Display disassembly for current stack frame.")
+
+(def-gdb-preempt-display-buffer
+ gdb-preemptively-display-disassembly-buffer
+ 'gdb-disassembly-buffer)
+
+(def-gdb-frame-for-buffer
+ gdb-frame-disassembly-buffer
+ 'gdb-disassembly-buffer
+ "Display disassembly in a new frame.")
+
+(def-gdb-auto-update-trigger gdb-invalidate-disassembly
+ (let* ((frame (gdb-current-buffer-frame))
+ (file (bindat-get-field frame 'fullname))
+ (line (bindat-get-field frame 'line)))
+ (when file
+ (format "-data-disassemble -f %s -l %s -n -1 -- 0" file line)))
+ gdb-disassembly-handler
+ ;; We update disassembly only after we have actual frame information
+ ;; about all threads, so no there's `update' signal in this list
+ '(start update-disassembly))
+
+(def-gdb-auto-update-handler
+ gdb-disassembly-handler
+ gdb-invalidate-disassembly
+ gdb-disassembly-handler-custom
+ t)
+
+(gdb-set-buffer-rules
+ 'gdb-disassembly-buffer
+ 'gdb-disassembly-buffer-name
+ 'gdb-disassembly-mode
+ 'gdb-invalidate-disassembly)
+
+(defvar gdb-disassembly-font-lock-keywords
+ '(;; <__function.name+n>
+ ("<\\(\\(\\sw\\|[_.]\\)+\\)\\(\\+[0-9]+\\)?>"
+ (1 font-lock-function-name-face))
+ ;; 0xNNNNNNNN <__function.name+n>: opcode
+ ("^0x[0-9a-f]+ \\(<\\(\\(\\sw\\|[_.]\\)+\\)\\+[0-9]+>\\)?:[ \t]+\\(\\sw+\\)"
+ (4 font-lock-keyword-face))
+ ;; %register(at least i386)
+ ("%\\sw+" . font-lock-variable-name-face)
+ ("^\\(Dump of assembler code for function\\) \\(.+\\):"
+ (1 font-lock-comment-face)
+ (2 font-lock-function-name-face))
+ ("^\\(End of assembler dump\\.\\)" . font-lock-comment-face))
+ "Font lock keywords used in `gdb-disassembly-mode'.")
+
+(defvar gdb-disassembly-mode-map
+ ;; TODO
+ (let ((map (make-sparse-keymap)))
+ (suppress-keymap map)
+ (define-key map "q" 'kill-this-buffer)
+ map))
+
+(define-derived-mode gdb-disassembly-mode gdb-parent-mode "Disassembly"
+ "Major mode for GDB disassembly information.
+
+\\{gdb-disassembly-mode-map}"
+ ;; TODO Rename overlay variable for disassembly mode
+ (add-to-list 'overlay-arrow-variable-list 'gdb-disassembly-position)
+ (setq fringes-outside-margins t)
+ (set (make-local-variable 'gdb-disassembly-position) (make-marker))
+ (set (make-local-variable 'font-lock-defaults)
+ '(gdb-disassembly-font-lock-keywords))
+ (run-mode-hooks 'gdb-disassembly-mode-hook)
+ 'gdb-invalidate-disassembly)
+
+(defun gdb-disassembly-handler-custom ()
+ (let* ((instructions (bindat-get-field (gdb-json-partial-output) 'asm_insns))
+ (address (bindat-get-field (gdb-current-buffer-frame) 'addr))
+ (pos 1)
+ (table (make-gdb-table))
+ (marked-line nil))
+ (dolist (instr instructions)
+ (gdb-table-add-row table
+ (list
+ (bindat-get-field instr 'address)
+ (apply 'format `("<%s+%s>:" ,@(gdb-get-many-fields instr 'func-name 'offset)))
+ (bindat-get-field instr 'inst)))
+ (when (string-equal (bindat-get-field instr 'address)
+ address)
+ (progn
+ (setq marked-line (length (gdb-table-rows table)))
+ (setq fringe-indicator-alist
+ (if (string-equal gdb-frame-number "0")
+ nil
+ '((overlay-arrow . hollow-right-triangle)))))))
+ (insert (gdb-table-string table " "))
+ (gdb-disassembly-place-breakpoints)
+ ;; Mark current position with overlay arrow and scroll window to
+ ;; that point
+ (when marked-line
+ (let ((window (get-buffer-window (current-buffer) 0)))
+ (set-window-point window (gdb-mark-line marked-line gdb-disassembly-position))))
+ (setq mode-name
+ (gdb-current-context-mode-name
+ (concat "Disassembly: "
+ (bindat-get-field (gdb-current-buffer-frame) 'func))))))
+
+(defun gdb-disassembly-place-breakpoints ()
+ (gdb-remove-breakpoint-icons (point-min) (point-max))
+ (dolist (breakpoint gdb-breakpoints-list)
+ (let* ((breakpoint (cdr breakpoint))
+ (bptno (bindat-get-field breakpoint 'number))
+ (flag (bindat-get-field breakpoint 'enabled))
+ (address (bindat-get-field breakpoint 'addr)))
+ (save-excursion
+ (goto-char (point-min))
+ (if (re-search-forward (concat "^" address) nil t)
+ (gdb-put-breakpoint-icon (string-equal flag "y") bptno))))))
+
+
+(defvar gdb-breakpoints-header
+ (list
+ (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer
+ nil nil mode-line)
+ " "
+ (gdb-propertize-header "Threads" gdb-threads-buffer
+ "mouse-1: select" mode-line-highlight mode-line-inactive)))
+
+;;; Breakpoints view
+(define-derived-mode gdb-breakpoints-mode gdb-parent-mode "Breakpoints"
+ "Major mode for gdb breakpoints.
+
+\\{gdb-breakpoints-mode-map}"
+ (setq header-line-format gdb-breakpoints-header)
+ (run-mode-hooks 'gdb-breakpoints-mode-hook)
+ 'gdb-invalidate-breakpoints)
+
+(defun gdb-toggle-breakpoint ()
+ "Enable/disable breakpoint at current line of breakpoints buffer."
+ (interactive)
+ (save-excursion
+ (beginning-of-line)
+ (let ((breakpoint (get-text-property (point) 'gdb-breakpoint)))
+ (if breakpoint
+ (gud-basic-call
+ (concat (if (string-equal "y" (bindat-get-field breakpoint 'enabled))
+ "-break-disable "
+ "-break-enable ")
+ (bindat-get-field breakpoint 'number)))
+ (error "Not recognized as break/watchpoint line")))))
+
+(defun gdb-delete-breakpoint ()
+ "Delete the breakpoint at current line of breakpoints buffer."
+ (interactive)
+ (save-excursion
+ (beginning-of-line)
+ (let ((breakpoint (get-text-property (point) 'gdb-breakpoint)))
+ (if breakpoint
+ (gud-basic-call (concat "-break-delete " (bindat-get-field breakpoint 'number)))
+ (error "Not recognized as break/watchpoint line")))))
+
+(defun gdb-goto-breakpoint (&optional event)
+ "Go to the location of breakpoint at current line of
+breakpoints buffer."
+ (interactive (list last-input-event))
+ (if event (posn-set-point (event-end event)))
+ ;; Hack to stop gdb-goto-breakpoint displaying in GUD buffer.
+ (let ((window (get-buffer-window gud-comint-buffer)))
+ (if window (save-selected-window (select-window window))))
+ (save-excursion
+ (beginning-of-line)
+ (let ((breakpoint (get-text-property (point) 'gdb-breakpoint)))
+ (if breakpoint
+ (let ((bptno (bindat-get-field breakpoint 'number))
+ (file (bindat-get-field breakpoint 'fullname))
+ (line (bindat-get-field breakpoint 'line)))
+ (save-selected-window
+ (let* ((buffer (find-file-noselect
+ (if (file-exists-p file) file
+ (cdr (assoc bptno gdb-location-alist)))))
+ (window (or (gdb-display-source-buffer buffer)
+ (display-buffer buffer))))
+ (setq gdb-source-window window)
+ (with-current-buffer buffer
+ (goto-char (point-min))
+ (forward-line (1- (string-to-number line)))
+ (set-window-point window (point))))))
+ (error "Not recognized as break/watchpoint line")))))
+
+
+;; Frames buffer. This displays a perpetually correct bactrack trace.
+;;
+(def-gdb-trigger-and-handler
+ gdb-invalidate-frames (gdb-current-context-command "-stack-list-frames")
+ gdb-stack-list-frames-handler gdb-stack-list-frames-custom
+ '(start update))
+
+(gdb-set-buffer-rules
+ 'gdb-stack-buffer
+ 'gdb-stack-buffer-name
+ 'gdb-frames-mode
+ 'gdb-invalidate-frames)
+
+(defun gdb-frame-location (frame)
+ "Return \" of file:line\" or \" of library\" for structure FRAME.
+
+FRAME must have either \"file\" and \"line\" members or \"from\"
+member."
+ (let ((file (bindat-get-field frame 'file))
+ (line (bindat-get-field frame 'line))
+ (from (bindat-get-field frame 'from)))
+ (let ((res (or (and file line (concat file ":" line))
+ from)))
+ (if res (concat " of " res) ""))))
+
+(defun gdb-stack-list-frames-custom ()
+ (let ((stack (bindat-get-field (gdb-json-partial-output "frame") 'stack))
+ (table (make-gdb-table)))
+ (set-marker gdb-stack-position nil)
+ (dolist (frame stack)
+ (gdb-table-add-row table
+ (list
+ (bindat-get-field frame 'level)
+ "in"
+ (concat
+ (bindat-get-field frame 'func)
+ (if gdb-stack-buffer-locations
+ (gdb-frame-location frame) "")
+ (if gdb-stack-buffer-addresses
+ (concat " at " (bindat-get-field frame 'addr)) "")))
+ `(mouse-face highlight
+ help-echo "mouse-2, RET: Select frame"
+ gdb-frame ,frame)))
+ (insert (gdb-table-string table " ")))
+ (when (and gdb-frame-number
+ (gdb-buffer-shows-main-thread-p))
+ (gdb-mark-line (1+ (string-to-number gdb-frame-number))
+ gdb-stack-position))
+ (setq mode-name
+ (gdb-current-context-mode-name "Frames")))
+
+(defun gdb-stack-buffer-name ()
+ (gdb-current-context-buffer-name
+ (concat "stack frames of " (gdb-get-target-string))))
+
+(def-gdb-display-buffer
+ gdb-display-stack-buffer
+ 'gdb-stack-buffer
+ "Display backtrace of current stack.")
+
+(def-gdb-preempt-display-buffer
+ gdb-preemptively-display-stack-buffer
+ 'gdb-stack-buffer nil t)
+
+(def-gdb-frame-for-buffer
+ gdb-frame-stack-buffer
+ 'gdb-stack-buffer
+ "Display backtrace of current stack in a new frame.")
+
+(defvar gdb-frames-mode-map
+ (let ((map (make-sparse-keymap)))
+ (suppress-keymap map)
+ (define-key map "q" 'kill-this-buffer)
+ (define-key map "\r" 'gdb-select-frame)
+ (define-key map [mouse-2] 'gdb-select-frame)
+ (define-key map [follow-link] 'mouse-face)
+ map))
+
+(defvar gdb-frames-font-lock-keywords
+ '(("in \\([^ ]+\\)" (1 font-lock-function-name-face)))
+ "Font lock keywords used in `gdb-frames-mode'.")
+
+(define-derived-mode gdb-frames-mode gdb-parent-mode "Frames"
+ "Major mode for gdb call stack.
+
+\\{gdb-frames-mode-map}"
+ (setq gdb-stack-position (make-marker))
+ (add-to-list 'overlay-arrow-variable-list 'gdb-stack-position)
+ (setq truncate-lines t) ;; Make it easier to see overlay arrow.
+ (set (make-local-variable 'font-lock-defaults)
+ '(gdb-frames-font-lock-keywords))
+ (run-mode-hooks 'gdb-frames-mode-hook)
+ 'gdb-invalidate-frames)
+
+(defun gdb-select-frame (&optional event)
+ "Select the frame and display the relevant source."
+ (interactive (list last-input-event))
+ (if event (posn-set-point (event-end event)))
+ (let ((frame (get-text-property (point) 'gdb-frame)))
+ (if frame
+ (if (gdb-buffer-shows-main-thread-p)
+ (let ((new-level (bindat-get-field frame 'level)))
+ (setq gdb-frame-number new-level)
+ (gdb-input (list (concat "-stack-select-frame " new-level) 'ignore))
+ (gdb-update))
+ (error "Could not select frame for non-current thread"))
+ (error "Not recognized as frame line"))))
+
+
+;; Locals buffer.
+;; uses "-stack-list-locals --simple-values". Needs GDB 6.1 onwards.
+(def-gdb-trigger-and-handler
+ gdb-invalidate-locals
+ (concat (gdb-current-context-command "-stack-list-locals") " --simple-values")
+ gdb-locals-handler gdb-locals-handler-custom
+ '(start update))
+
+(gdb-set-buffer-rules
+ 'gdb-locals-buffer
+ 'gdb-locals-buffer-name
+ 'gdb-locals-mode
+ 'gdb-invalidate-locals)
+
+(defvar gdb-locals-watch-map
+ (let ((map (make-sparse-keymap)))
+ (suppress-keymap map)
+ (define-key map "\r" 'gud-watch)
+ (define-key map [mouse-2] 'gud-watch)
+ map)
+ "Keymap to create watch expression of a complex data type local variable.")
+
+(defvar gdb-edit-locals-map-1
+ (let ((map (make-sparse-keymap)))
+ (suppress-keymap map)
+ (define-key map "\r" 'gdb-edit-locals-value)
+ (define-key map [mouse-2] 'gdb-edit-locals-value)
+ map)
+ "Keymap to edit value of a simple data type local variable.")
+
+(defun gdb-edit-locals-value (&optional event)
+ "Assign a value to a variable displayed in the locals buffer."
+ (interactive (list last-input-event))
+ (save-excursion
+ (if event (posn-set-point (event-end event)))
+ (beginning-of-line)
+ (let* ((var (bindat-get-field
+ (get-text-property (point) 'gdb-local-variable) 'name))
+ (value (read-string (format "New value (%s): " var))))
+ (gud-basic-call
+ (concat "-gdb-set variable " var " = " value)))))
+
+;; Dont display values of arrays or structures.
+;; These can be expanded using gud-watch.
+(defun gdb-locals-handler-custom ()
+ (let ((locals-list (bindat-get-field (gdb-json-partial-output) 'locals))
+ (table (make-gdb-table)))
+ (dolist (local locals-list)
+ (let ((name (bindat-get-field local 'name))
+ (value (bindat-get-field local 'value))
+ (type (bindat-get-field local 'type)))
+ (if (or (not value)
+ (string-match "\\0x" value))
+ (add-text-properties 0 (length name)
+ `(mouse-face highlight
+ help-echo "mouse-2: create watch expression"
+ local-map ,gdb-locals-watch-map)
+ name)
+ (add-text-properties 0 (length value)
+ `(mouse-face highlight
+ help-echo "mouse-2: edit value"
+ local-map ,gdb-edit-locals-map-1)
+ value))
+ (gdb-table-add-row
+ table
+ (list
+ (propertize type 'font-lock-face font-lock-type-face)
+ (propertize name 'font-lock-face font-lock-variable-name-face)
+ value)
+ `(gdb-local-variable ,local))))
+ (insert (gdb-table-string table " "))
+ (setq mode-name
+ (gdb-current-context-mode-name
+ (concat "Locals: " (bindat-get-field (gdb-current-buffer-frame) 'func))))))
+
+(defvar gdb-locals-header
+ (list
+ (gdb-propertize-header "Locals" gdb-locals-buffer
+ nil nil mode-line)
+ " "
+ (gdb-propertize-header "Registers" gdb-registers-buffer
+ "mouse-1: select" mode-line-highlight mode-line-inactive)))
+
+(defvar gdb-locals-mode-map
+ (let ((map (make-sparse-keymap)))
+ (suppress-keymap map)
+ (define-key map "q" 'kill-this-buffer)
+ (define-key map "\t" '(lambda ()
+ (interactive)
+ (gdb-set-window-buffer
+ (gdb-get-buffer-create
+ 'gdb-registers-buffer
+ gdb-thread-number) t)))
+ map))
+
+(define-derived-mode gdb-locals-mode gdb-parent-mode "Locals"
+ "Major mode for gdb locals.
+
+\\{gdb-locals-mode-map}"
+ (setq header-line-format gdb-locals-header)
+ (run-mode-hooks 'gdb-locals-mode-hook)
+ 'gdb-invalidate-locals)
+
+(defun gdb-locals-buffer-name ()
+ (gdb-current-context-buffer-name
+ (concat "locals of " (gdb-get-target-string))))
+
+(def-gdb-display-buffer
+ gdb-display-locals-buffer
+ 'gdb-locals-buffer
+ "Display local variables of current stack and their values.")
+
+(def-gdb-preempt-display-buffer
+ gdb-preemptively-display-locals-buffer
+ 'gdb-locals-buffer nil t)
+
+(def-gdb-frame-for-buffer
+ gdb-frame-locals-buffer
+ 'gdb-locals-buffer
+ "Display local variables of current stack and their values in a new frame.")
+
+
+;; Registers buffer.
+
+(def-gdb-trigger-and-handler
+ gdb-invalidate-registers
+ (concat (gdb-current-context-command "-data-list-register-values") " x")
+ gdb-registers-handler
+ gdb-registers-handler-custom
+ '(start update))
+
+(gdb-set-buffer-rules
+ 'gdb-registers-buffer
+ 'gdb-registers-buffer-name
+ 'gdb-registers-mode
+ 'gdb-invalidate-registers)
+
+(defun gdb-registers-handler-custom ()
+ (when gdb-register-names
+ (let ((register-values (bindat-get-field (gdb-json-partial-output) 'register-values))
+ (table (make-gdb-table)))
+ (dolist (register register-values)
+ (let* ((register-number (bindat-get-field register 'number))
+ (value (bindat-get-field register 'value))
+ (register-name (nth (string-to-number register-number)
+ gdb-register-names)))
+ (gdb-table-add-row
+ table
+ (list
+ (propertize register-name 'font-lock-face font-lock-variable-name-face)
+ (if (member register-number gdb-changed-registers)
+ (propertize value 'font-lock-face font-lock-warning-face)
+ value))
+ `(mouse-face highlight
+ help-echo "mouse-2: edit value"
+ gdb-register-name ,register-name))))
+ (insert (gdb-table-string table " ")))
+ (setq mode-name
+ (gdb-current-context-mode-name "Registers"))))
+
+(defun gdb-edit-register-value (&optional event)
+ "Assign a value to a register displayed in the registers buffer."
+ (interactive (list last-input-event))
+ (save-excursion
+ (if event (posn-set-point (event-end event)))
+ (beginning-of-line)
+ (let* ((var (bindat-get-field
+ (get-text-property (point) 'gdb-register-name)))
+ (value (read-string (format "New value (%s): " var))))
+ (gud-basic-call
+ (concat "-gdb-set variable $" var " = " value)))))
+
+(defvar gdb-registers-mode-map
+ (let ((map (make-sparse-keymap)))
+ (suppress-keymap map)
+ (define-key map "\r" 'gdb-edit-register-value)
+ (define-key map [mouse-2] 'gdb-edit-register-value)
+ (define-key map "q" 'kill-this-buffer)
+ (define-key map "\t" '(lambda ()
+ (interactive)
+ (gdb-set-window-buffer
+ (gdb-get-buffer-create
+ 'gdb-locals-buffer
+ gdb-thread-number) t)))
+ map))
+
+(defvar gdb-registers-header
+ (list
+ (gdb-propertize-header "Locals" gdb-locals-buffer
+ "mouse-1: select" mode-line-highlight mode-line-inactive)
+ " "
+ (gdb-propertize-header "Registers" gdb-registers-buffer
+ nil nil mode-line)))
+
+(define-derived-mode gdb-registers-mode gdb-parent-mode "Registers"
+ "Major mode for gdb registers.
+
+\\{gdb-registers-mode-map}"
+ (setq header-line-format gdb-registers-header)
+ (run-mode-hooks 'gdb-registers-mode-hook)
+ 'gdb-invalidate-registers)
+
+(defun gdb-registers-buffer-name ()
+ (gdb-current-context-buffer-name
+ (concat "registers of " (gdb-get-target-string))))
+
+(def-gdb-display-buffer
+ gdb-display-registers-buffer
+ 'gdb-registers-buffer
+ "Display integer register contents.")
+
+(def-gdb-preempt-display-buffer
+ gdb-preemptively-display-registers-buffer
+ 'gdb-registers-buffer nil t)
+
+(def-gdb-frame-for-buffer
+ gdb-frame-registers-buffer
+ 'gdb-registers-buffer
+ "Display integer register contents in a new frame.")
+
+;; Needs GDB 6.4 onwards (used to fail with no stack).
+(defun gdb-get-changed-registers ()
+ (if (and (gdb-get-buffer 'gdb-registers-buffer)
+ (not (gdb-pending-p 'gdb-get-changed-registers)))
+ (progn
+ (gdb-input
+ (list
+ "-data-list-changed-registers"
+ 'gdb-changed-registers-handler))
+ (gdb-add-pending 'gdb-get-changed-registers))))
+
+(defun gdb-changed-registers-handler ()
+ (gdb-delete-pending 'gdb-get-changed-registers)
+ (setq gdb-changed-registers nil)
+ (dolist (register-number (bindat-get-field (gdb-json-partial-output) 'changed-registers))
+ (push register-number gdb-changed-registers)))
+
+(defun gdb-register-names-handler ()
+ ;; Don't use gdb-pending-triggers because this handler is called
+ ;; only once (in gdb-init-1)
+ (setq gdb-register-names nil)
+ (dolist (register-name (bindat-get-field (gdb-json-partial-output) 'register-names))
+ (push register-name gdb-register-names))
+ (setq gdb-register-names (reverse gdb-register-names)))
+
+
+(defun gdb-get-source-file-list ()
+ "Create list of source files for current GDB session.
+If buffers already exist for any of these files, gud-minor-mode
+is set in them."
+ (goto-char (point-min))
+ (while (re-search-forward gdb-source-file-regexp nil t)
+ (push (match-string 1) gdb-source-file-list))
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (when (member buffer-file-name gdb-source-file-list)
+ (gdb-init-buffer))))
+ (gdb-force-mode-line-update
+ (propertize "ready" 'face font-lock-variable-name-face)))
+
+(defun gdb-get-main-selected-frame ()
+ "Trigger for `gdb-frame-handler' which uses main current
+thread. Called from `gdb-update'."
+ (if (not (gdb-pending-p 'gdb-get-main-selected-frame))
+ (progn
+ (gdb-input
+ (list (gdb-current-context-command "-stack-info-frame") 'gdb-frame-handler))
+ (gdb-add-pending 'gdb-get-main-selected-frame))))
+
+(defun gdb-frame-handler ()
+ "Sets `gdb-selected-frame' and `gdb-selected-file' to show
+overlay arrow in source buffer."
+ (gdb-delete-pending 'gdb-get-main-selected-frame)
+ (let ((frame (bindat-get-field (gdb-json-partial-output) 'frame)))
+ (when frame
+ (setq gdb-selected-frame (bindat-get-field frame 'func))
+ (setq gdb-selected-file (bindat-get-field frame 'fullname))
+ (setq gdb-frame-number (bindat-get-field frame 'level))
+ (setq gdb-frame-address (bindat-get-field frame 'addr))
+ (let ((line (bindat-get-field frame 'line)))
+ (setq gdb-selected-line (and line (string-to-number line)))
+ (when (and gdb-selected-file gdb-selected-line)
+ (setq gud-last-frame (cons gdb-selected-file gdb-selected-line))
+ (gud-display-frame)))
+ (if gud-overlay-arrow-position
+ (let ((buffer (marker-buffer gud-overlay-arrow-position))
+ (position (marker-position gud-overlay-arrow-position)))
+ (when buffer
+ (with-current-buffer buffer
+ (setq fringe-indicator-alist
+ (if (string-equal gdb-frame-number "0")
+ nil
+ '((overlay-arrow . hollow-right-triangle))))
+ (setq gud-overlay-arrow-position (make-marker))
+ (set-marker gud-overlay-arrow-position position))))))))
+
+(defvar gdb-prompt-name-regexp "value=\"\\(.*?\\)\"")
+
+(defun gdb-get-prompt ()
+ "Find prompt for GDB session."
+ (goto-char (point-min))
+ (setq gdb-prompt-name nil)
+ (re-search-forward gdb-prompt-name-regexp nil t)
+ (setq gdb-prompt-name (match-string 1))
+ ;; Insert first prompt.
+ (setq gdb-filter-output (concat gdb-filter-output gdb-prompt-name)))
+
+;;;; Window management
+(defun gdb-display-buffer (buf dedicated &optional frame)
+ "Show buffer BUF.
+
+If BUF is already displayed in some window, show it, deiconifying
+the frame if necessary. Otherwise, find least recently used
+window and show BUF there, if the window is not used for GDB
+already, in which case that window is splitted first."
+ (let ((answer (get-buffer-window buf (or frame 0))))
+ (if answer
+ (display-buffer buf nil (or frame 0)) ;Deiconify the frame if necessary.
+ (let ((window (get-lru-window)))
+ (if (eq (buffer-local-value 'gud-minor-mode (window-buffer window))
+ 'gdbmi)
+ (let* ((largest (get-largest-window))
+ (cur-size (window-height largest)))
+ (setq answer (split-window largest))
+ (set-window-buffer answer buf)
+ (set-window-dedicated-p answer dedicated)
+ answer)
+ (set-window-buffer window buf)
+ window)))))
+
+(defun gdb-preempt-existing-or-display-buffer (buf &optional split-horizontal)
+ "Find window displaying a buffer with the same
+`gdb-buffer-type' as BUF and show BUF there. If no such window
+exists, just call `gdb-display-buffer' for BUF. If the window
+found is already dedicated, split window according to
+SPLIT-HORIZONTAL and show BUF in the new window."
+ (if buf
+ (when (not (get-buffer-window buf))
+ (let* ((buf-type (gdb-buffer-type buf))
+ (existing-window
+ (get-window-with-predicate
+ #'(lambda (w)
+ (and (eq buf-type
+ (gdb-buffer-type (window-buffer w)))
+ (not (window-dedicated-p w)))))))
+ (if existing-window
+ (set-window-buffer existing-window buf)
+ (let ((dedicated-window
+ (get-window-with-predicate
+ #'(lambda (w)
+ (eq buf-type
+ (gdb-buffer-type (window-buffer w)))))))
+ (if dedicated-window
+ (set-window-buffer
+ (split-window dedicated-window nil split-horizontal) buf)
+ (gdb-display-buffer buf t))))))
+ (error "Null buffer")))
+
+;;; Shared keymap initialization:
+
+(let ((menu (make-sparse-keymap "GDB-Windows")))
+ (define-key gud-menu-map [displays]
+ `(menu-item "GDB-Windows" ,menu
+ :visible (eq gud-minor-mode 'gdbmi)))
+ (define-key menu [gdb] '("Gdb" . gdb-display-gdb-buffer))
+ (define-key menu [threads] '("Threads" . gdb-display-threads-buffer))
+ (define-key menu [memory] '("Memory" . gdb-display-memory-buffer))
+ (define-key menu [disassembly]
+ '("Disassembly" . gdb-display-disassembly-buffer))
+ (define-key menu [registers] '("Registers" . gdb-display-registers-buffer))
+ (define-key menu [inferior]
+ '("IO" . gdb-display-io-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)))
+
+(let ((menu (make-sparse-keymap "GDB-Frames")))
+ (define-key gud-menu-map [frames]
+ `(menu-item "GDB-Frames" ,menu
+ :visible (eq gud-minor-mode 'gdbmi)))
+ (define-key menu [gdb] '("Gdb" . gdb-frame-gdb-buffer))
+ (define-key menu [threads] '("Threads" . gdb-frame-threads-buffer))
+ (define-key menu [memory] '("Memory" . gdb-frame-memory-buffer))
+ (define-key menu [disassembly] '("Disassembly" . gdb-frame-disassembly-buffer))
+ (define-key menu [registers] '("Registers" . gdb-frame-registers-buffer))
+ (define-key menu [inferior]
+ '("IO" . gdb-frame-io-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)))
+
+(let ((menu (make-sparse-keymap "GDB-MI")))
+ (define-key menu [gdb-customize]
+ '(menu-item "Customize" (lambda () (interactive) (customize-group 'gdb))
+ :help "Customize Gdb Graphical Mode options."))
+ (define-key menu [gdb-many-windows]
+ '(menu-item "Display Other Windows" gdb-many-windows
+ :help "Toggle display of locals, stack and breakpoint information"
+ :button (:toggle . gdb-many-windows)))
+ (define-key menu [gdb-restore-windows]
+ '(menu-item "Restore Window Layout" gdb-restore-windows
+ :help "Restore standard layout for debug session."))
+ (define-key menu [sep1]
+ '(menu-item "--"))
+ (define-key menu [all-threads]
+ '(menu-item "GUD controls all threads"
+ (lambda ()
+ (interactive)
+ (setq gdb-gud-control-all-threads t))
+ :help "GUD start/stop commands apply to all threads"
+ :button (:radio . gdb-gud-control-all-threads)))
+ (define-key menu [current-thread]
+ '(menu-item "GUD controls current thread"
+ (lambda ()
+ (interactive)
+ (setq gdb-gud-control-all-threads nil))
+ :help "GUD start/stop commands apply to current thread only"
+ :button (:radio . (not gdb-gud-control-all-threads))))
+ (define-key menu [sep2]
+ '(menu-item "--"))
+ (define-key menu [gdb-customize-reasons]
+ '(menu-item "Customize switching..."
+ (lambda ()
+ (interactive)
+ (customize-option 'gdb-switch-reasons))))
+ (define-key menu [gdb-switch-when-another-stopped]
+ (menu-bar-make-toggle gdb-toggle-switch-when-another-stopped gdb-switch-when-another-stopped
+ "Automatically switch to stopped thread"
+ "GDB thread switching %s"
+ "Switch to stopped thread"))
+ (define-key gud-menu-map [mi]
+ `(menu-item "GDB-MI" ,menu :visible (eq gud-minor-mode 'gdbmi))))
+
+;; TODO Fit these into tool-bar-local-item-from-menu call in gud.el.
+;; GDB-MI menu will need to be moved to gud.el. We can't use
+;; tool-bar-local-item-from-menu here because it appends new buttons
+;; to toolbar from right to left while we want our A/T throttle to
+;; show up right before Run button.
+(define-key-after gud-tool-bar-map [all-threads]
+ '(menu-item "Switch to non-stop/A mode" gdb-control-all-threads
+ :image (find-image '((:type xpm :file "gud/thread.xpm")))
+ :visible (and (eq gud-minor-mode 'gdbmi)
+ gdb-non-stop
+ (not gdb-gud-control-all-threads)))
+ 'run)
+
+(define-key-after gud-tool-bar-map [current-thread]
+ '(menu-item "Switch to non-stop/T mode" gdb-control-current-thread
+ :image (find-image '((:type xpm :file "gud/all.xpm")))
+ :visible (and (eq gud-minor-mode 'gdbmi)
+ gdb-non-stop
+ gdb-gud-control-all-threads))
+ 'all-threads)
+
+(defun gdb-frame-gdb-buffer ()
+ "Display GUD buffer in a new frame."
+ (interactive)
+ (let ((special-display-regexps (append special-display-regexps '(".*")))
+ (special-display-frame-alist
+ (remove '(menu-bar-lines) (remove '(tool-bar-lines)
+ gdb-frame-parameters)))
+ (same-window-regexps nil))
+ (display-buffer gud-comint-buffer)))
+
+(defun gdb-display-gdb-buffer ()
+ "Display GUD buffer."
+ (interactive)
+ (let ((same-window-regexps nil))
+ (select-window (display-buffer gud-comint-buffer nil 0))))
+
+(defun gdb-set-window-buffer (name &optional ignore-dedicated)
+ "Set buffer of selected window to NAME and dedicate window.
+
+When IGNORE-DEDICATED is non-nil, buffer is set even if selected
+window is dedicated."
+ (when ignore-dedicated
+ (set-window-dedicated-p (selected-window) nil))
+ (set-window-buffer (selected-window) (get-buffer name))
+ (set-window-dedicated-p (selected-window) t))
+
+(defun gdb-setup-windows ()
+ "Layout the window pattern for `gdb-many-windows'."
+ (gdb-display-locals-buffer)
+ (gdb-display-stack-buffer)
+ (delete-other-windows)
+ (gdb-display-breakpoints-buffer)
+ (delete-other-windows)
+ ; Don't dedicate.
+ (pop-to-buffer gud-comint-buffer)
+ (split-window nil ( / ( * (window-height) 3) 4))
+ (split-window nil ( / (window-height) 3))
+ (split-window-horizontally)
+ (other-window 1)
+ (gdb-set-window-buffer (gdb-locals-buffer-name))
+ (other-window 1)
+ (switch-to-buffer
+ (if gud-last-last-frame
+ (gud-find-file (car gud-last-last-frame))
+ (if gdb-main-file
+ (gud-find-file gdb-main-file)
+ ;; Put buffer list in window if we
+ ;; can't find a source file.
+ (list-buffers-noselect))))
+ (setq gdb-source-window (selected-window))
+ (split-window-horizontally)
+ (other-window 1)
+ (gdb-set-window-buffer
+ (gdb-get-buffer-create 'gdb-inferior-io))
+ (other-window 1)
+ (gdb-set-window-buffer (gdb-stack-buffer-name))
+ (split-window-horizontally)
+ (other-window 1)
+ (gdb-set-window-buffer (if gdb-show-threads-by-default
+ (gdb-threads-buffer-name)
+ (gdb-breakpoints-buffer-name)))
+ (other-window 1))
+
+(defcustom gdb-many-windows nil
+ "If nil 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 debugged program. Non-nil means display the layout shown for
+`gdb'."
+ :type 'boolean
+ :group 'gdb
+ :version "22.1")
+
+(defun gdb-many-windows (arg)
+ "Toggle the number of windows in the basic arrangement.
+With arg, display additional buffers iff arg is positive."
+ (interactive "P")
+ (setq gdb-many-windows
+ (if (null arg)
+ (not gdb-many-windows)
+ (> (prefix-numeric-value arg) 0)))
+ (message (format "Display of other windows %sabled"
+ (if gdb-many-windows "en" "dis")))
+ (if (and gud-comint-buffer
+ (buffer-name gud-comint-buffer))
+ (condition-case nil
+ (gdb-restore-windows)
+ (error nil))))
+
+(defun gdb-restore-windows ()
+ "Restore the basic arrangement of windows used by gdb.
+This arrangement depends on the value of `gdb-many-windows'."
+ (interactive)
+ (pop-to-buffer gud-comint-buffer) ;Select the right window and frame.
+ (delete-other-windows)
+ (if gdb-many-windows
+ (gdb-setup-windows)
+ (when (or gud-last-last-frame gdb-show-main)
+ (split-window)
+ (other-window 1)
+ (switch-to-buffer
+ (if gud-last-last-frame
+ (gud-find-file (car gud-last-last-frame))
+ (gud-find-file gdb-main-file)))
+ (setq gdb-source-window (selected-window))
+ (other-window 1))))
+
+(defun gdb-reset ()
+ "Exit a debugging session cleanly.
+Kills the gdb buffers, and resets variables and the source buffers."
+ (dolist (buffer (buffer-list))
+ (unless (eq buffer gud-comint-buffer)
+ (with-current-buffer buffer
+ (if (eq gud-minor-mode 'gdbmi)
+ (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)
+ (kill-local-variable 'gdb-define-alist))))))
+ (setq gdb-disassembly-position nil)
+ (setq overlay-arrow-variable-list
+ (delq 'gdb-disassembly-position overlay-arrow-variable-list))
+ (setq fringe-indicator-alist '((overlay-arrow . right-triangle)))
+ (setq gdb-stack-position nil)
+ (setq overlay-arrow-variable-list
+ (delq 'gdb-stack-position overlay-arrow-variable-list))
+ (setq gdb-thread-position nil)
+ (setq overlay-arrow-variable-list
+ (delq 'gdb-thread-position overlay-arrow-variable-list))
+ (if (boundp 'speedbar-frame) (speedbar-timer-fn))
+ (setq gud-running nil)
+ (setq gdb-active-process nil)
+ (remove-hook 'after-save-hook 'gdb-create-define-alist t))
+
+(defun gdb-get-source-file ()
+ "Find the source file where the program starts and display it with related
+buffers, if required."
+ (goto-char (point-min))
+ (if (re-search-forward gdb-source-file-regexp nil t)
+ (setq gdb-main-file (match-string 1)))
+ (if gdb-many-windows
+ (gdb-setup-windows)
+ (gdb-get-buffer-create 'gdb-breakpoints-buffer)
+ (if gdb-show-main
+ (let ((pop-up-windows t))
+ (display-buffer (gud-find-file gdb-main-file))))))
+
+;;from put-image
+(defun gdb-put-string (putstring pos &optional dprop &rest sprops)
+ "Put string PUTSTRING in front of POS in the current buffer.
+PUTSTRING is displayed by putting an overlay into the current buffer with a
+`before-string' string that has a `display' property whose value is
+PUTSTRING."
+ (let ((string (make-string 1 ?x))
+ (buffer (current-buffer)))
+ (setq putstring (copy-sequence putstring))
+ (let ((overlay (make-overlay pos pos buffer))
+ (prop (or dprop
+ (list (list 'margin 'left-margin) putstring))))
+ (put-text-property 0 1 'display prop string)
+ (if sprops
+ (add-text-properties 0 1 sprops string))
+ (overlay-put overlay 'put-break t)
+ (overlay-put overlay 'before-string string))))
+
+;;from remove-images
+(defun gdb-remove-strings (start end &optional buffer)
+ "Remove strings between START and END in BUFFER.
+Remove only strings that were put in BUFFER with calls to `gdb-put-string'.
+BUFFER nil or omitted means use the current buffer."
+ (unless buffer
+ (setq buffer (current-buffer)))
+ (dolist (overlay (overlays-in start end))
+ (when (overlay-get overlay 'put-break)
+ (delete-overlay overlay))))
+
+(defun gdb-put-breakpoint-icon (enabled bptno &optional line)
+ (let* ((posns (gdb-line-posns (or line (line-number-at-pos))))
+ (start (- (car posns) 1))
+ (end (+ (cdr posns) 1))
+ (putstring (if enabled "B" "b"))
+ (source-window (get-buffer-window (current-buffer) 0)))
+ (add-text-properties
+ 0 1 '(help-echo "mouse-1: clear bkpt, mouse-3: enable/disable bkpt")
+ putstring)
+ (if enabled
+ (add-text-properties
+ 0 1 `(gdb-bptno ,bptno gdb-enabled t) putstring)
+ (add-text-properties
+ 0 1 `(gdb-bptno ,bptno gdb-enabled nil) putstring))
+ (gdb-remove-breakpoint-icons start end)
+ (if (display-images-p)
+ (if (>= (or left-fringe-width
+ (if source-window (car (window-fringes source-window)))
+ gdb-buffer-fringe-width) 8)
+ (gdb-put-string
+ nil (1+ start)
+ `(left-fringe breakpoint
+ ,(if enabled
+ 'breakpoint-enabled
+ 'breakpoint-disabled))
+ 'gdb-bptno bptno
+ 'gdb-enabled enabled)
+ (when (< left-margin-width 2)
+ (save-current-buffer
+ (setq left-margin-width 2)
+ (if source-window
+ (set-window-margins
+ source-window
+ left-margin-width right-margin-width))))
+ (put-image
+ (if enabled
+ (or breakpoint-enabled-icon
+ (setq breakpoint-enabled-icon
+ (find-image `((:type xpm :data
+ ,breakpoint-xpm-data
+ :ascent 100 :pointer hand)
+ (:type pbm :data
+ ,breakpoint-enabled-pbm-data
+ :ascent 100 :pointer hand)))))
+ (or breakpoint-disabled-icon
+ (setq breakpoint-disabled-icon
+ (find-image `((:type xpm :data
+ ,breakpoint-xpm-data
+ :conversion disabled
+ :ascent 100 :pointer hand)
+ (:type pbm :data
+ ,breakpoint-disabled-pbm-data
+ :ascent 100 :pointer hand))))))
+ (+ start 1)
+ putstring
+ 'left-margin))
+ (when (< left-margin-width 2)
+ (save-current-buffer
+ (setq left-margin-width 2)
+ (let ((window (get-buffer-window (current-buffer) 0)))
+ (if window
+ (set-window-margins
+ window left-margin-width right-margin-width)))))
+ (gdb-put-string
+ (propertize putstring
+ 'face (if enabled 'breakpoint-enabled 'breakpoint-disabled))
+ (1+ start)))))
+
+(defun gdb-remove-breakpoint-icons (start end &optional remove-margin)
+ (gdb-remove-strings start end)
+ (if (display-images-p)
+ (remove-images start end))
+ (when remove-margin
+ (setq left-margin-width 0)
+ (let ((window (get-buffer-window (current-buffer) 0)))
+ (if window
+ (set-window-margins
+ window left-margin-width right-margin-width)))))
+
+(provide 'gdb-mi)
+
+;; arch-tag: 1b41ea2b-f364-4cec-8f35-e02e4fe01912
+;;; gdb-mi.el ends here
diff --git a/lisp/progmodes/gdb-ui.el b/lisp/progmodes/gdb-ui.el
deleted file mode 100644
index b2a354c5410..00000000000
--- a/lisp/progmodes/gdb-ui.el
+++ /dev/null
@@ -1,4158 +0,0 @@
-;;; gdb-ui.el --- User Interface for running GDB
-
-;; Author: Nick Roberts <nickrob@gnu.org>
-;; Maintainer: FSF
-;; Keywords: unix, tools
-
-;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; 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 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This mode acts as a graphical user interface to GDB. You can interact with
-;; GDB through the GUD buffer in the usual way, but there are also further
-;; buffers which control the execution and describe the state of your program.
-;; It separates the input/output of your program from that of GDB, if
-;; required, and watches expressions in the speedbar. It also uses features of
-;; Emacs 21 such as the fringe/display margin for breakpoints, and the toolbar
-;; (see the GDB Graphical Interface section in the Emacs info manual).
-
-;; By default, M-x gdb will start the debugger.
-
-;; This file has evolved from gdba.el that was included with GDB 5.0 and
-;; written by Tom Lord and Jim Kingdon. It 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, see the Annotations
-;; section in the GDB info manual.
-
-;; GDB developers plan to make the annotation interface obsolete. A new
-;; interface called GDB/MI (machine interface) has been designed to replace it.
-;; Some GDB/MI commands are used in this file through the CLI command
-;; 'interpreter mi <mi-command>'. To help with the process of fully migrating
-;; Emacs from annotations to GDB/MI, there is an experimental package called
-;; gdb-mi in the Emacs Lisp Package Archive ("http://tromey.com/elpa/"). It
-;; comprises of modified gud.el and a file called gdb-mi.el which replaces
-;; gdb-ui.el. When installed, this overrides the current files and invoking
-;; M-x gdb will use GDB/MI directly (starts with "gdb -i=mi"). When deleted
-;; ('d' followed by 'x' in Package Menu mode), the files are deleted and old
-;; functionality restored. This provides a convenient way to review the
-;; current status/contribute to its improvement. For someone who just wants to
-;; use GDB, however, the current mode in Emacs 22 is a much better option.
-;; There is also a file, also called gdb-mi.el, a version of which is included
-;; the GDB distribution. This will probably only work with versions
-;; distributed with GDB 6.5 or later. Unlike the version in ELPA it works on
-;; top of gdb-ui.el and you can only start it with M-x gdbmi.
-
-;; This mode SHOULD WORK WITH GDB 5.0 or later but you will NEED AT LEAST
-;; GDB 6.0 to use watch expressions. It works best with GDB 6.4 or later
-;; where watch expressions will update more quickly.
-
-;;; Windows Platforms:
-
-;; If you are using Emacs and GDB on Windows you will need to flush the buffer
-;; explicitly in your program if you want timely display of I/O in Emacs.
-;; Alternatively you can make the output stream unbuffered, for example, by
-;; using a macro:
-
-;; #ifdef UNBUFFERED
-;; setvbuf (stdout, (char *) NULL, _IONBF, 0);
-;; #endif
-
-;; and compiling with -DUNBUFFERED while debugging.
-
-;; If you are using Cygwin GDB and find that the source is not being displayed
-;; in Emacs when you step through it, possible solutions are to:
-
-;; 1) Use Cygwin X Windows and Cygwin Emacs.
-;; (Since 22.1 Emacs builds under Cygwin.)
-;; 2) Use MinGW GDB instead.
-;; 3) Use cygwin-mount.el
-
-;;; Mac OSX:
-
-;; GDB in Emacs on Mac OSX works best with FSF GDB as Apple have made
-;; some changes to the version that they include as part of Mac OSX.
-;; This requires GDB version 7.0 or later (estimated release date June 2009)
-;; as earlier versions don not compile on Mac OSX.
-
-;;; Known Bugs:
-
-;; 1) Cannot handle multiple debug sessions.
-;; 2) If you wish to call procedures from your program in GDB
-;; e.g "call myproc ()", "p mysquare (5)" then use level 2 annotations
-;; "gdb --annotate=2 myprog" to keep source buffer/selected frame fixed.
-;; 3) After detaching from a process, clicking on the "GO" icon on toolbar
-;; (gud-go) sends "continue" to GDB (should be "run").
-
-;;; TODO:
-
-;; 1) Use MI command -data-read-memory for memory window.
-;; 2) Use tree-buffer.el (from ECB) instead of the speedbar for
-;; watch-expressions? Handling of watch-expressions needs to be
-;; overhauled to work for large arrays/structures by creating variable
-;; objects for visible watch-expressions only.
-;; 3) Mark breakpoint locations on scroll-bar of source buffer?
-
-;;; Code:
-
-(require 'gud)
-(require 'json)
-(require 'bindat)
-
-(defvar tool-bar-map)
-(defvar speedbar-initial-expansion-list-name)
-(defvar speedbar-frame)
-
-(defvar gdb-pc-address nil "Initialization for Assembler buffer.
-Set to \"main\" at start if `gdb-show-main' is t.")
-(defvar gdb-frame-address nil "Identity of frame for watch expression.")
-(defvar gdb-previous-frame-pc-address nil)
-(defvar gdb-memory-address "main")
-(defvar gdb-previous-frame nil)
-(defvar gdb-selected-frame nil)
-(defvar gdb-frame-number nil)
-(defvar gdb-current-language nil)
-(defvar gdb-var-list nil
- "List of variables in watch window.
-Each element has the form (VARNUM EXPRESSION NUMCHILD TYPE VALUE STATUS HAS_MORE FP)
-where STATUS is nil (`unchanged'), `changed' or `out-of-scope', FP the frame
-address for root variables.")
-(defvar gdb-main-file nil "Source file from which program execution begins.")
-(defvar gud-old-arrow nil)
-(defvar gdb-thread-indicator nil)
-(defvar gdb-overlay-arrow-position nil)
-(defvar gdb-stack-position nil)
-(defvar gdb-server-prefix nil)
-(defvar gdb-flush-pending-output nil)
-(defvar gdb-location-alist nil
- "Alist of breakpoint numbers and full filenames.
-Only used for files that Emacs can't find.")
-(defvar gdb-active-process nil
- "GUD tooltips display variable values when t, and macro definitions otherwise.")
-(defvar gdb-recording nil
- "If t, then record session for playback and reverse execution")
-(defvar gdb-error "Non-nil when GDB is reporting an error.")
-(defvar gdb-macro-info nil
- "Non-nil if GDB knows that the inferior includes preprocessor macro info.")
-(defvar gdb-buffer-fringe-width nil)
-(defvar gdb-signalled nil)
-(defvar gdb-source-window nil)
-(defvar gdb-inferior-status nil)
-(defvar gdb-continuation nil)
-(defvar gdb-look-up-stack nil)
-(defvar gdb-frame-begin nil
- "Non-nil when GDB generates frame-begin annotation.")
-(defvar gdb-printing t)
-(defvar gdb-parent-bptno-enabled nil)
-(defvar gdb-ready nil)
-(defvar gdb-stack-update nil)
-(defvar gdb-early-user-input nil)
-
-(defvar gdb-buffer-type nil
- "One of the symbols bound in `gdb-buffer-rules'.")
-(make-variable-buffer-local 'gdb-buffer-type)
-
-(defvar gdb-input-queue ()
- "A list of gdb command objects.")
-
-(defvar gdb-prompting nil
- "True when gdb is idle with no pending input.")
-
-(defvar gdb-output-sink nil
- "The disposition of the output of the current gdb command.
-Possible values are these symbols:
-
- `user' -- gdb output should be copied to the GUD buffer
- for the user to see.
-
- `inferior' -- gdb output should be copied to the inferior-io buffer.
-
- `pre-emacs' -- output should be ignored util the post-prompt
- annotation is received. Then the output-sink
- becomes:...
- `emacs' -- output should be collected in the partial-output-buffer
- for subsequent processing by a command. This is the
- disposition of output generated by commands that
- gdb mode sends to gdb on its own behalf.
- `post-emacs' -- ignore output until the prompt annotation is
- received, then go to USER disposition.
-
-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.")
-
-(defvar gdb-pending-triggers '()
- "A list of trigger functions that have run later than their output handlers.")
-
-(defvar gdb-first-post-prompt nil)
-(defvar gdb-version nil)
-(defvar gdb-locals-font-lock-keywords nil)
-(defvar gdb-source-file-list nil
- "List of source files for the current executable.")
-(defconst gdb-error-regexp "\\^error,msg=\"\\(.+\\)\"")
-
-(defvar gdb-locals-font-lock-keywords-1
- '(;; var = (struct struct_tag) value
- ( "\\(^\\(\\sw\\|[_.]\\)+\\) += +(\\(struct\\) \\(\\(\\sw\\|[_.]\\)+\\)"
- (1 font-lock-variable-name-face)
- (3 font-lock-keyword-face)
- (4 font-lock-type-face))
- ;; var = (type) value
- ( "\\(^\\(\\sw\\|[_.]\\)+\\) += +(\\(\\(\\sw\\|[_.]\\)+\\)"
- (1 font-lock-variable-name-face)
- (3 font-lock-type-face))
- ;; var = val
- ( "\\(^\\(\\sw\\|[_.]\\)+\\) += +[^(]"
- (1 font-lock-variable-name-face)))
- "Font lock keywords used in `gdb-local-mode'.")
-
-(defvar gdb-locals-font-lock-keywords-2
- '(;; var = type value
- ( "\\(^\\(\\sw\\|[_.]\\)+\\)\t+\\(\\(\\sw\\|[_.]\\)+\\)"
- (1 font-lock-variable-name-face)
- (3 font-lock-type-face)))
- "Font lock keywords used in `gdb-local-mode'.")
-
-;; Variables for GDB 6.4+
-(defvar gdb-register-names nil "List of register names.")
-(defvar gdb-changed-registers nil
- "List of changed register numbers (strings).")
-
-;;;###autoload
-(defun gdb (command-line)
- "Run gdb on program FILE in buffer *gud-FILE*.
-The directory containing FILE becomes the initial working
-directory and source-file directory for your debugger.
-
-If `gdb-many-windows' is nil (the default value) then gdb just
-pops up the GUD buffer unless `gdb-show-main' is t. In this case
-it starts with two windows: one displaying the GUD buffer and the
-other with the source file with the main routine of the inferior.
-
-If `gdb-many-windows' is t, regardless of the value of
-`gdb-show-main', the layout below will appear unless
-`gdb-use-separate-io-buffer' is nil when the source buffer
-occupies the full width of the frame. Keybindings are shown in
-some of the buffers.
-
-Watch expressions appear in the speedbar/slowbar.
-
-The following commands 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 |
-|-----------------------------------+----------------------------------+
-| | |
-| Source buffer | I/O buffer for debugged program |
-| | |
-|-----------------------------------+----------------------------------+
-| Stack buffer | Breakpoints/threads buffer |
-+-----------------------------------+----------------------------------+
-
-The option \"--annotate=3\" must be included in this value. To
-run GDB in text command mode, use `gud-gdb'. You need to use
-text command mode to debug multiple programs within one Emacs
-session."
- (interactive (list (gud-query-cmdline 'gdb)))
-
- (when (and gud-comint-buffer
- (buffer-name gud-comint-buffer)
- (get-buffer-process gud-comint-buffer)
- (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdba)))
- (gdb-restore-windows)
- (error
- "Multiple debugging requires restarting in text command mode"))
-
- (gud-common-init command-line nil 'gud-gdba-marker-filter)
- (set (make-local-variable 'gud-minor-mode) 'gdba)
- (setq comint-input-sender 'gdb-send)
-
- (gud-def gud-break "break %f:%l" "\C-b" "Set breakpoint at current line.")
- (gud-def gud-tbreak "tbreak %f:%l" "\C-t"
- "Set temporary breakpoint at current line.")
- (gud-def gud-remove "clear %f:%l" "\C-d" "Remove breakpoint at current line.")
- (gud-def gud-step "step %p" "\C-s" "Step one source line with display.")
- (gud-def gud-stepi "stepi %p" "\C-i" "Step one instruction with display.")
- (gud-def gud-next "next %p" "\C-n" "Step one line (skip functions).")
- (gud-def gud-nexti "nexti %p" nil "Step one instruction (skip functions).")
- (gud-def gud-cont "continue" "\C-r" "Continue with display.")
- (gud-def gud-finish "finish" "\C-f" "Finish executing current function.")
- (gud-def gud-jump
- (progn (gud-call "tbreak %f:%l") (gud-call "jump %f:%l"))
- "\C-j" "Set execution address to current line.")
-
- (gud-def gud-rstep "reverse-step %p" nil "Reverse step one source line with display.")
- (gud-def gud-rstepi "reverse-stepi %p" nil "Reverse step one instruction with display.")
- (gud-def gud-rnext "reverse-next %p" nil "Reverse step one line (skip functions).")
- (gud-def gud-rnexti "reverse-nexti %p" nil "Reverse step one instruction (skip functions).")
- (gud-def gud-rcont "reverse-continue" nil "Reverse continue with display.")
- (gud-def gud-rfinish "reverse-finish" nil "Reverse finish executing current function.")
-
- (gud-def gud-up "up %p" "<" "Up N stack frames (numeric arg).")
- (gud-def gud-down "down %p" ">" "Down N stack frames (numeric arg).")
- (gud-def gud-print "print %e" "\C-p" "Evaluate C expression at point.")
- (gud-def gud-pstar "print* %e" nil
- "Evaluate C dereferenced pointer expression at point.")
-
- ;; For debugging Emacs only.
- (gud-def gud-pv "pv1 %e" "\C-v" "Print the value of the lisp variable.")
-
- (gud-def gud-until "until %l" "\C-u" "Continue to current line.")
- (gud-def gud-run "run" nil "Run the program.")
-
- (local-set-key "\C-i" 'gud-gdb-complete-command)
- (setq comint-prompt-regexp "^(.*gdb[+]?) *")
- (setq paragraph-start comint-prompt-regexp)
- (setq gdb-output-sink 'user)
- (setq gdb-first-prompt t)
- (setq gud-running nil)
- (setq gdb-ready nil)
- (setq gdb-stack-update nil)
- (setq gdb-flush-pending-output nil)
- (setq gdb-early-user-input nil)
- (setq gud-filter-pending-text nil)
- (gdb-thread-identification)
- (run-hooks 'gdb-mode-hook))
-
-;; Keep as an alias for compatibility with Emacs 22.1.
-;;;###autoload
-(defalias 'gdba 'gdb)
-
-(defgroup gdb nil
- "Gdb Graphical Mode options specifically for running Gdb in Emacs."
- :group 'processes
- :group 'tools)
-
-(defcustom gdb-debug-log-max 128
- "Maximum size of `gdb-debug-log'. If nil, size is unlimited."
- :group 'gdb
- :type '(choice (integer :tag "Number of elements")
- (const :tag "Unlimited" nil))
- :version "22.1")
-
-(defvar gdb-debug-log nil
- "List of commands sent to and replies received from GDB.
-Most recent commands are listed first. This list stores only the last
-`gdb-debug-log-max' values. This variable is used to debug GDB-UI.")
-
-;;;###autoload
-(defcustom gdb-enable-debug nil
- "Non-nil means record the process input and output in `gdb-debug-log'."
- :type 'boolean
- :group 'gdb
- :version "22.1")
-
-(defcustom gdb-cpp-define-alist-program "gcc -E -dM -"
- "Shell command for generating a list of defined macros in a source file.
-This list is used to display the #define directive associated
-with an identifier as a tooltip. It works in a debug session with
-GDB, when `gud-tooltip-mode' is t.
-
-Set `gdb-cpp-define-alist-flags' for any include paths or
-predefined macros."
- :type 'string
- :group 'gdb
- :version "22.1")
-
-(defcustom gdb-cpp-define-alist-flags ""
- "Preprocessor flags for `gdb-cpp-define-alist-program'."
- :type 'string
- :group 'gdb
- :version "22.1")
-
-(defcustom gdb-create-source-file-list t
- "Non-nil means create a list of files from which the executable was built.
-Set this to nil if the GUD buffer displays \"initializing...\" in the mode
-line for a long time when starting, possibly because your executable was
-built from a large number of files. This allows quicker initialization
-but means that these files are not automatically enabled for debugging,
-e.g., you won't be able to click in the fringe to set a breakpoint until
-execution has already stopped there."
- :type 'boolean
- :group 'gdb
- :version "23.1")
-
-(defcustom gdb-show-main nil
- "Non-nil means display source file containing the main routine at startup.
-Also display the main routine in the disassembly buffer if present."
- :type 'boolean
- :group 'gdb
- :version "22.1")
-
-(defcustom gdb-many-windows nil
- "If nil, just pop up the GUD buffer unless `gdb-show-main' is t.
-In this case start with two windows: one displaying the GUD
-buffer and the other with the source file with the main routine
-of the debugged program. Non-nil means display the layout shown
-for `gdba'."
- :type 'boolean
- :group 'gdb
- :version "22.1")
-
-(defcustom gdb-use-separate-io-buffer nil
- "Non-nil means display output from the debugged program in a separate buffer."
- :type 'boolean
- :group 'gdb
- :version "22.1")
-
-(defun gdb-force-mode-line-update (status)
- (let ((buffer gud-comint-buffer))
- (if (and buffer (buffer-name buffer))
- (with-current-buffer buffer
- (setq mode-line-process
- (format ":%s [%s]"
- (process-status (get-buffer-process buffer)) status))
- ;; Force mode line redisplay soon.
- (force-mode-line-update)))))
-
-(defun gdb-enable-debug (arg)
- "Toggle logging of transaction between Emacs and Gdb.
-The log is stored in `gdb-debug-log' as an alist with elements
-whose cons is send, send-item or recv and whose cdr is the string
-being transferred. This list may grow up to a size of
-`gdb-debug-log-max' after which the oldest element (at the end of
-the list) is deleted every time a new one is added (at the front)."
- (interactive "P")
- (setq gdb-enable-debug
- (if (null arg)
- (not gdb-enable-debug)
- (> (prefix-numeric-value arg) 0)))
- (message (format "Logging of transaction %sabled"
- (if gdb-enable-debug "en" "dis"))))
-
-(defun gdb-many-windows (arg)
- "Toggle the number of windows in the basic arrangement.
-With prefix argument ARG, display additional buffers if ARG is positive,
-otherwise use a single window."
- (interactive "P")
- (setq gdb-many-windows
- (if (null arg)
- (not gdb-many-windows)
- (> (prefix-numeric-value arg) 0)))
- (message (format "Display of other windows %sabled"
- (if gdb-many-windows "en" "dis")))
- (if (and gud-comint-buffer
- (buffer-name gud-comint-buffer))
- (condition-case nil
- (gdb-restore-windows)
- (error nil))))
-
-(defun gdb-use-separate-io-buffer (arg)
- "Toggle separate IO for debugged program.
-With prefix argument ARG, use separate IO if ARG is positive,
-otherwise do not."
- (interactive "P")
- (setq gdb-use-separate-io-buffer
- (if (null arg)
- (not gdb-use-separate-io-buffer)
- (> (prefix-numeric-value arg) 0)))
- (message (format "Separate IO %sabled"
- (if gdb-use-separate-io-buffer "en" "dis")))
- (if (and gud-comint-buffer
- (buffer-name gud-comint-buffer))
- (condition-case nil
- (if gdb-use-separate-io-buffer
- (if gdb-many-windows (gdb-restore-windows))
- (kill-buffer (gdb-inferior-io-name)))
- (error nil))))
-
-(defvar gdb-define-alist nil "Alist of #define directives for GUD tooltips.")
-
-(defun gdb-create-define-alist ()
- "Create an alist of #define directives for GUD tooltips."
- (let* ((file (buffer-file-name))
- (output
- (with-output-to-string
- (with-current-buffer standard-output
- (and file
- (file-exists-p file)
- ;; call-process doesn't work with remote file names.
- (not (file-remote-p default-directory))
- (call-process shell-file-name file
- (list t nil) nil "-c"
- (concat gdb-cpp-define-alist-program " "
- gdb-cpp-define-alist-flags))))))
- (define-list (split-string output "\n" t)) (name))
- (setq gdb-define-alist nil)
- (dolist (define define-list)
- (setq name (nth 1 (split-string define "[( ]")))
- (push (cons name define) gdb-define-alist))))
-
-(declare-function tooltip-show "tooltip" (text &optional use-echo-area))
-(defvar tooltip-use-echo-area)
-
-(defun gdb-tooltip-print (expr)
- (tooltip-show
- (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer)
- (goto-char (point-min))
- (let ((string
- (if (search-forward "=" nil t)
- (concat expr (buffer-substring (- (point) 2) (point-max)))
- (buffer-string))))
- ;; remove newline for gud-tooltip-echo-area
- (substring string 0 (- (length string) 1))))
- (or gud-tooltip-echo-area tooltip-use-echo-area
- (not (display-graphic-p)))))
-
-;; If expr is a macro for a function don't print because of possible dangerous
-;; side-effects. Also printing a function within a tooltip generates an
-;; unexpected starting annotation (phase error).
-(defun gdb-tooltip-print-1 (expr)
- (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer)
- (goto-char (point-min))
- (if (search-forward "expands to: " nil t)
- (unless (looking-at "\\S-+.*(.*).*")
- (gdb-enqueue-input
- (list (concat gdb-server-prefix "print " expr "\n")
- `(lambda () (gdb-tooltip-print ,expr))))))))
-
-(defconst gdb-source-file-regexp "\\(.+?\\), \\|\\([^, \n].*$\\)")
-
-(defun gdb-init-buffer ()
- (set (make-local-variable 'gud-minor-mode)
- (buffer-local-value 'gud-minor-mode gud-comint-buffer))
- (set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
- (when gud-tooltip-mode
- (make-local-variable 'gdb-define-alist)
- (gdb-create-define-alist)
- (add-hook 'after-save-hook 'gdb-create-define-alist nil t)))
-
-(defun gdb-set-gud-minor-mode-existing-buffers ()
- "Create list of source files for current GDB session."
- (goto-char (point-min))
- (when (search-forward "read in on demand:" nil t)
- (while (re-search-forward gdb-source-file-regexp nil t)
- (push (file-name-nondirectory (or (match-string 1) (match-string 2)))
- gdb-source-file-list))
- (dolist (buffer (buffer-list))
- (with-current-buffer buffer
- (when (and buffer-file-name
- (member (file-name-nondirectory buffer-file-name)
- gdb-source-file-list))
- (gdb-init-buffer)))))
- (gdb-force-mode-line-update
- (propertize "ready" 'face font-lock-variable-name-face)))
-
-(defun gdb-find-watch-expression ()
- (let* ((var (nth (- (line-number-at-pos (point)) 2) gdb-var-list))
- (varnum (car var)) expr array)
- (string-match "\\(var[0-9]+\\)\\.\\(.*\\)" varnum)
- (let ((var1 (assoc (match-string 1 varnum) gdb-var-list)) var2 varnumlet
- (component-list (split-string (match-string 2 varnum) "\\." t)))
- (setq expr (nth 1 var1))
- (setq varnumlet (car var1))
- (dolist (component component-list)
- (setq var2 (assoc varnumlet gdb-var-list))
- (setq expr (concat expr
- (if (string-match ".*\\[[0-9]+\\]$" (nth 3 var2))
- (concat "[" component "]")
- (concat "." component))))
- (setq varnumlet (concat varnumlet "." component)))
- expr)))
-
-(defun gdb-toggle-recording ()
-"Start/stop recording of debug session."
- (interactive)
- (if gud-running
- (message-box "Recording cannot be started or stopped while your program is still running")
- (gdb-enqueue-input
- (list (concat gdb-server-prefix
- (if gdb-recording "record stop\n" "target record\n"))
- 'gdb-recording-handler))))
-
-;; Convenience function for tool bar.
-(defalias 'gdb-toggle-recording-1 'gdb-toggle-recording)
-
-(defun gdb-recording-handler ()
- (goto-char (point-min))
- (if (re-search-forward "current architecture doesn't support record function" nil t)
- (message-box "Not enabled. The current architecture doesn't support the process record function.")
- (goto-char (point-min))
- (if (re-search-forward "Undefined target command" nil t)
- (message-box "Not enabled. Process record requires GDB 7.0 onwards.")
- (goto-char (point-min))
- (if (re-search-forward "the program is not being run" nil t)
- (message-box "Not enabled. Starting process recording requires an active target (running process).")
- (setq gdb-recording (not gdb-recording))
- ;; Actually forcing the tool-bar to update.
- (force-mode-line-update)))))
-
-(defun gdb-init-1 ()
- (gud-def gud-break (if (not (string-match "Machine" mode-name))
- (gud-call "break %f:%l" arg)
- (save-excursion
- (beginning-of-line)
- (forward-char 2)
- (gud-call "break *%a" arg)))
- "\C-b" "Set breakpoint at current line or address.")
- ;;
- (gud-def gud-remove (if (not (string-match "Machine" mode-name))
- (gud-call "clear %f:%l" arg)
- (save-excursion
- (beginning-of-line)
- (forward-char 2)
- (gud-call "clear *%a" arg)))
- "\C-d" "Remove breakpoint at current line or address.")
- ;;
- (gud-def gud-until (if (not (string-match "Machine" mode-name))
- (gud-call "until %f:%l" arg)
- (save-excursion
- (beginning-of-line)
- (forward-char 2)
- (gud-call "until *%a" arg)))
- "\C-u" "Continue to current line or address.")
- ;;
- (gud-def gud-go (gud-call (if gdb-active-process "continue" "run") arg)
- nil "Start or continue execution.")
-
- ;; For debugging Emacs only.
- (gud-def gud-pp
- (gud-call
- (concat
- "pp1 " (if (eq (buffer-local-value
- 'major-mode (window-buffer)) 'speedbar-mode)
- (gdb-find-watch-expression) "%e")) arg)
- nil "Print the Emacs s-expression.")
-
- (define-key gud-minor-mode-map [left-margin mouse-1]
- 'gdb-mouse-set-clear-breakpoint)
- (define-key gud-minor-mode-map [left-fringe mouse-1]
- 'gdb-mouse-set-clear-breakpoint)
- (define-key gud-minor-mode-map [left-margin C-mouse-1]
- 'gdb-mouse-toggle-breakpoint-margin)
- (define-key gud-minor-mode-map [left-fringe C-mouse-1]
- 'gdb-mouse-toggle-breakpoint-fringe)
-
- (define-key gud-minor-mode-map [left-margin drag-mouse-1]
- 'gdb-mouse-until)
- (define-key gud-minor-mode-map [left-fringe drag-mouse-1]
- 'gdb-mouse-until)
- (define-key gud-minor-mode-map [left-margin mouse-3]
- 'gdb-mouse-until)
- (define-key gud-minor-mode-map [left-fringe mouse-3]
- 'gdb-mouse-until)
-
- (define-key gud-minor-mode-map [left-margin C-drag-mouse-1]
- 'gdb-mouse-jump)
- (define-key gud-minor-mode-map [left-fringe C-drag-mouse-1]
- 'gdb-mouse-jump)
- (define-key gud-minor-mode-map [left-fringe C-mouse-3]
- 'gdb-mouse-jump)
- (define-key gud-minor-mode-map [left-margin C-mouse-3]
- 'gdb-mouse-jump)
-
- ;; (re-)initialize
- (setq gdb-pc-address (if gdb-show-main "main" nil))
- (setq gdb-previous-frame-pc-address nil
- gdb-memory-address "main"
- gdb-previous-frame nil
- gdb-selected-frame nil
- gdb-current-language nil
- gdb-frame-number nil
- gdb-var-list nil
- gdb-main-file nil
- gdb-first-post-prompt t
- gdb-prompting nil
- gdb-input-queue nil
- gdb-current-item nil
- gdb-pending-triggers nil
- gdb-output-sink 'user
- gdb-server-prefix "server "
- gdb-location-alist nil
- gdb-source-file-list nil
- gdb-error nil
- gdb-macro-info nil
- gdb-buffer-fringe-width (car (window-fringes))
- gdb-debug-log nil
- gdb-signalled nil
- gdb-source-window nil
- gdb-inferior-status nil
- gdb-continuation nil
- gdb-look-up-stack nil
- gdb-frame-begin nil
- gdb-printing t
- gud-old-arrow nil
- gdb-thread-indicator nil
- gdb-register-names nil
- gdb-recording nil)
-
- (setq gdb-buffer-type 'gdba)
-
- (if gdb-use-separate-io-buffer (gdb-clear-inferior-io))
-
- (if (eq system-type 'darwin)
- (gdb-enqueue-input (list "server show version\n" 'gdb-apple-test)))
-
- ;; Hack to see test for GDB 6.4+ (-stack-info-frame was implemented in 6.4)
- (gdb-enqueue-input (list "server interpreter mi -stack-info-frame\n"
- 'gdb-get-version)))
-
-(defun gdb-init-2 ()
- (if (eq window-system 'w32)
- (gdb-enqueue-input (list "set new-console off\n" 'ignore)))
- (gdb-enqueue-input (list "set height 0\n" 'ignore))
- (gdb-enqueue-input (list "set width 0\n" 'ignore))
-
- (if (string-equal gdb-version "pre-6.4")
- (if gdb-create-source-file-list
- (gdb-enqueue-input (list (concat gdb-server-prefix "info sources\n")
- 'gdb-set-gud-minor-mode-existing-buffers))
- (setq gdb-locals-font-lock-keywords gdb-locals-font-lock-keywords-1))
- ; Needs GDB 6.2 onwards.
- (if gdb-create-source-file-list
- (gdb-enqueue-input
- (list "server interpreter mi \"-file-list-exec-source-files\"\n"
- 'gdb-set-gud-minor-mode-existing-buffers-1)))
- (setq gdb-locals-font-lock-keywords gdb-locals-font-lock-keywords-2)
- ; Needs GDB 7.0 onwards.
- (gdb-enqueue-input
- (list "server interpreter mi -enable-pretty-printing\n" 'ignore)))
-
- ;; Find source file and compilation directory here.
- ;; Works for C, C++, Fortran and Ada but not Java (GDB 6.4)
- (gdb-enqueue-input (list "server list\n" 'ignore))
- (gdb-enqueue-input (list "server list MAIN__\n" 'ignore))
- (gdb-enqueue-input (list "server info source\n" 'gdb-source-info)))
-
-;; Workaround for some Apple versions of GDB that add ^M at EOL
-;; after the command "server interpreter mi -stack-info-frame".
-(defun gdb-apple-test ()
- (goto-char (point-min))
- (if (re-search-forward "(Apple version " nil t)
- (let* ((process (get-buffer-process gud-comint-buffer))
- (coding-systems (process-coding-system process)))
- (set-process-coding-system process
- (coding-system-change-eol-conversion
- (car coding-systems) 'dos)
- (cdr coding-systems)))))
-
-(defun gdb-get-version ()
- (goto-char (point-min))
- (if (re-search-forward "Undefined\\( mi\\)* command:" nil t)
- (setq gdb-version "pre-6.4")
- (setq gdb-version "6.4+"))
- (gdb-init-2))
-
-(defmacro gdb-if-arrow (arrow-position &rest body)
- `(if ,arrow-position
- (let ((buffer (marker-buffer ,arrow-position)) (line))
- (if (equal buffer (window-buffer (posn-window end)))
- (with-current-buffer buffer
- (when (or (equal start end)
- (equal (posn-point start)
- (marker-position ,arrow-position)))
- ,@body))))))
-
-(defun gdb-mouse-until (event)
- "Continue running until a source line past the current line.
-The destination source line can be selected either by clicking
-with mouse-3 on the fringe/margin or dragging the arrow
-with mouse-1 (default bindings)."
- (interactive "e")
- (let ((start (event-start event))
- (end (event-end event)))
- (gdb-if-arrow gud-overlay-arrow-position
- (setq line (line-number-at-pos (posn-point end)))
- (gud-call (concat "until " (number-to-string line))))
- (gdb-if-arrow gdb-overlay-arrow-position
- (save-excursion
- (goto-char (point-min))
- (forward-line (1- (line-number-at-pos (posn-point end))))
- (forward-char 2)
- (gud-call (concat "until *%a"))))))
-
-(defun gdb-mouse-jump (event)
- "Set execution address/line.
-The destination source line can be selected either by clicking with C-mouse-3
-on the fringe/margin or dragging the arrow with C-mouse-1 (default bindings).
-Unlike `gdb-mouse-until' the destination address can be before the current
-line, and no execution takes place."
- (interactive "e")
- (let ((start (event-start event))
- (end (event-end event)))
- (gdb-if-arrow gud-overlay-arrow-position
- (setq line (line-number-at-pos (posn-point end)))
- (progn
- (gud-call (concat "tbreak " (number-to-string line)))
- (gud-call (concat "jump " (number-to-string line)))))
- (gdb-if-arrow gdb-overlay-arrow-position
- (save-excursion
- (goto-char (point-min))
- (forward-line (1- (line-number-at-pos (posn-point end))))
- (forward-char 2)
- (progn
- (gud-call (concat "tbreak *%a"))
- (gud-call (concat "jump *%a")))))))
-
-(defcustom gdb-speedbar-auto-raise nil
- "If non-nil raise speedbar every time display of watch expressions is\
- updated."
- :type 'boolean
- :group 'gdb
- :version "22.1")
-
-(defun gdb-speedbar-auto-raise (arg)
- "Toggle automatic raising of the speedbar for watch expressions.
-With prefix argument ARG, automatically raise speedbar if ARG is
-positive, otherwise don't automatically raise it."
- (interactive "P")
- (setq gdb-speedbar-auto-raise
- (if (null arg)
- (not gdb-speedbar-auto-raise)
- (> (prefix-numeric-value arg) 0)))
- (message (format "Auto raising %sabled"
- (if gdb-speedbar-auto-raise "en" "dis"))))
-
-(defcustom gdb-use-colon-colon-notation nil
- "If non-nil use FUN::VAR format to display variables in the speedbar."
- :type 'boolean
- :group 'gdb
- :version "22.1")
-
-(define-key gud-minor-mode-map "\C-c\C-w" 'gud-watch)
-(define-key global-map (concat gud-key-prefix "\C-w") 'gud-watch)
-
-(declare-function tooltip-identifier-from-point "tooltip" (point))
-
-(defun gud-watch (&optional arg event)
- "Watch expression at point.
-With arg, enter name of variable to be watched in the minibuffer."
- (interactive (list current-prefix-arg last-input-event))
- (let ((minor-mode (buffer-local-value 'gud-minor-mode gud-comint-buffer)))
- (if (memq minor-mode '(gdbmi gdba))
- (progn
- (if event (posn-set-point (event-end event)))
- (require 'tooltip)
- (save-selected-window
- (let ((expr
- (if arg
- (completing-read "Name of variable: "
- 'gud-gdb-complete-command)
- (if (and transient-mark-mode mark-active)
- (buffer-substring (region-beginning) (region-end))
- (concat (if (eq major-mode 'gdb-registers-mode) "$")
- (tooltip-identifier-from-point (point)))))))
- (set-text-properties 0 (length expr) nil expr)
- (gdb-enqueue-input
- (list
- (if (eq minor-mode 'gdba)
- (concat
- "server interpreter mi \"-var-create - * " expr "\"\n")
- (concat"-var-create - * " expr "\n"))
- `(lambda () (gdb-var-create-handler ,expr)))))))
- (message "gud-watch is a no-op in this mode."))))
-
-(declare-function speedbar-change-initial-expansion-list "speedbar" (new-default))
-
-(defun gdb-var-create-handler (expr)
- (let* ((result (gdb-json-partial-output)))
- (if (not (bindat-get-field result 'msg))
- (let ((var
- (list (bindat-get-field result 'name)
- (if (and (string-equal gdb-current-language "c")
- gdb-use-colon-colon-notation gdb-selected-frame)
- (setq expr (concat gdb-selected-frame "::" expr))
- expr)
- (bindat-get-field result 'numchild)
- (bindat-get-field result 'type)
- (bindat-get-field result 'value)
- nil
- (bindat-get-field result 'has_more)
- gdb-frame-address)))
- (push var gdb-var-list)
- (speedbar 1)
- (unless (string-equal
- speedbar-initial-expansion-list-name "GUD")
- (speedbar-change-initial-expansion-list "GUD")))
- (message-box "No symbol \"%s\" in current context." expr))))
-
-(declare-function speedbar-timer-fn "speedbar" ())
-
-(defun gdb-speedbar-update ()
- (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame)
- (not (member 'gdb-speedbar-timer gdb-pending-triggers)))
- ;; Dummy command to update speedbar even when idle.
- (gdb-enqueue-input (list "server pwd\n" 'gdb-speedbar-timer-fn))
- ;; Keep gdb-pending-triggers non-nil till end.
- (push 'gdb-speedbar-timer gdb-pending-triggers)))
-
-(defun gdb-speedbar-timer-fn ()
- (if gdb-speedbar-auto-raise
- (raise-frame speedbar-frame))
- (setq gdb-pending-triggers
- (delq 'gdb-speedbar-timer gdb-pending-triggers))
- (speedbar-timer-fn))
-
-(defun gdb-var-evaluate-expression-handler (varnum changed)
- (goto-char (point-min))
- (re-search-forward "\\(.+\\)\\^done,value=\\(\".*\"\\)" nil t)
- (setq gdb-pending-triggers
- (delq (string-to-number (match-string 1)) gdb-pending-triggers))
- (let ((var (assoc varnum gdb-var-list)))
- (when var
- (if changed (setcar (nthcdr 5 var) 'changed))
- (setcar (nthcdr 4 var) (read (match-string 2)))))
- (gdb-speedbar-update))
-
-(defun gdb-var-list-children (varnum)
- (gdb-enqueue-input
- (list (concat "server interpreter mi \"-var-list-children " varnum "\"\n")
- `(lambda () (gdb-var-list-children-handler ,varnum)))))
-
-(defconst gdb-var-list-children-regexp
- "child={.*?name=\"\\(.*?\\)\".*?,exp=\"\\(.*?\\)\".*?,\
-numchild=\"\\(.*?\\)\"\\(}\\|.*?,\\(type=\"\\(.*?\\)\"\\)?.*?}\\)")
-
-(defun gdb-var-list-children-handler (varnum)
- (goto-char (point-min))
- (let ((var-list nil))
- (catch 'child-already-watched
- (dolist (var gdb-var-list)
- (if (string-equal varnum (car var))
- (progn
- (push var var-list)
- (while (re-search-forward gdb-var-list-children-regexp nil t)
- (let ((varchild (list (match-string 1)
- (match-string 2)
- (match-string 3)
- (match-string 6)
- nil nil)))
- (if (assoc (car varchild) gdb-var-list)
- (throw 'child-already-watched nil))
- (push varchild var-list)
- (gdb-enqueue-input
- (list
- (concat
- "server interpreter mi \"0-var-evaluate-expression "
- (car varchild) "\"\n")
- `(lambda () (gdb-var-evaluate-expression-handler
- ,(car varchild) nil)))))))
- (push var var-list)))
- (setq gdb-var-list (nreverse var-list)))))
-
-(defun gdb-var-update ()
- (when (not (member 'gdb-var-update gdb-pending-triggers))
- (gdb-enqueue-input
- (list "server interpreter mi \"-var-update *\"\n"
- 'gdb-var-update-handler))
- (push 'gdb-var-update gdb-pending-triggers)))
-
-(defconst gdb-var-update-regexp
- "{.*?name=\"\\(.*?\\)\".*?,in_scope=\"\\(.*?\\)\".*?,\
-type_changed=\".*?\".*?}")
-
-(defun gdb-var-update-handler ()
- (dolist (var gdb-var-list)
- (setcar (nthcdr 5 var) nil))
- (goto-char (point-min))
- (let ((n 0))
- (while (re-search-forward gdb-var-update-regexp nil t)
- (let ((varnum (match-string 1)))
- (if (string-equal (match-string 2) "false")
- (let ((var (assoc varnum gdb-var-list)))
- (if var (setcar (nthcdr 5 var) 'out-of-scope)))
- (setq n (1+ n))
- (push n gdb-pending-triggers)
- (gdb-enqueue-input
- (list
- (concat "server interpreter mi \"" (number-to-string n)
- "-var-evaluate-expression " varnum "\"\n")
- `(lambda () (gdb-var-evaluate-expression-handler ,varnum t))))))))
- (setq gdb-pending-triggers
- (delq 'gdb-var-update gdb-pending-triggers)))
-
-(defun gdb-var-set-format (format)
- "Set the output format for a variable displayed in the speedbar."
- (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list))
- (varnum (car var)))
- (gdb-enqueue-input
- (list
- (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
- (concat "server interpreter mi \"-var-set-format "
- varnum " " format "\"\n")
- (concat "-var-set-format " varnum " " format "\n"))
- `(lambda () (gdb-var-set-format-handler ,varnum))))))
-
-(defconst gdb-var-set-format-regexp
- "format=\"\\(.*?\\)\",.*value=\"\\(.*?\\)\"")
-
-(defun gdb-var-set-format-handler (varnum)
- (goto-char (point-min))
- (if (re-search-forward gdb-var-set-format-regexp nil t)
- (let ((var (assoc varnum gdb-var-list)))
- (setcar (nthcdr 4 var) (match-string 2))
- (gdb-var-update-1))))
-
-(defun gdb-var-delete-1 (var varnum)
- (gdb-enqueue-input
- (list
- (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) '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)
- (if (string-match (concat (car var) "\\.") (car varchild))
- (setq gdb-var-list (delq varchild gdb-var-list)))))
-
-(defun gdb-var-delete ()
- "Delete watch expression at point from the speedbar."
- (interactive)
- (if (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
- '(gdbmi gdba))
- (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list))
- (varnum (car var)))
- (if (string-match "\\." (car var))
- (message-box "Can only delete a root expression")
- (gdb-var-delete-1 var varnum)))))
-
-(defun gdb-var-delete-children (varnum)
- "Delete children of variable object at point from the speedbar."
- (gdb-enqueue-input
- (list
- (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
- (concat "server interpreter mi \"-var-delete -c " varnum "\"\n")
- (concat "-var-delete -c " varnum "\n")) 'ignore)))
-
-(defun gdb-edit-value (text token indent)
- "Assign a value to a variable displayed in the speedbar."
- (let* ((var (nth (- (count-lines (point-min) (point)) 2) gdb-var-list))
- (varnum (car var)) (value))
- (setq value (read-string "New value: "))
- (gdb-enqueue-input
- (list
- (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
- (concat "server interpreter mi \"-var-assign "
- varnum " " value "\"\n")
- (concat "-var-assign " varnum " " value "\n"))
- `(lambda () (gdb-edit-value-handler ,value))))))
-
-(defun gdb-edit-value-handler (value)
- (goto-char (point-min))
- (if (re-search-forward gdb-error-regexp nil t)
- (message-box "Invalid number or expression (%s)" value)))
-
-(defcustom gdb-show-changed-values t
- "If non-nil change the face of out of scope variables and changed values.
-Out of scope variables are suppressed with `shadow' face.
-Changed values are highlighted with the face `font-lock-warning-face'."
- :type 'boolean
- :group 'gdb
- :version "22.1")
-
-(defcustom gdb-max-children 40
- "Maximum number of children before expansion requires confirmation."
- :type 'integer
- :group 'gdb
- :version "22.1")
-
-(defcustom gdb-delete-out-of-scope t
- "If non-nil delete watch expressions automatically when they go out of scope."
- :type 'boolean
- :group 'gdb
- :version "22.2")
-
-(declare-function speedbar-change-expand-button-char "speedbar" (char))
-(declare-function speedbar-delete-subblock "speedbar" (indent))
-(declare-function speedbar-center-buffer-smartly "speedbar" ())
-
-(defun gdb-speedbar-expand-node (text token indent)
- "Expand the node the user clicked on.
-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."
- (if (and gud-comint-buffer (buffer-name gud-comint-buffer))
- (progn
- (cond ((string-match "+" text) ;expand this node
- (let* ((var (assoc token gdb-var-list))
- (expr (nth 1 var)) (children (nth 2 var)))
- (if (or (<= (string-to-number children) gdb-max-children)
- (y-or-n-p
- (format
- "%s has %s children. Continue? " expr children)))
- (if (and (eq (buffer-local-value
- 'gud-minor-mode gud-comint-buffer) 'gdba)
- (string-equal gdb-version "pre-6.4"))
- (gdb-var-list-children token)
- (gdb-var-list-children-1 token)))))
- ((string-match "-" text) ;contract this node
- (dolist (var gdb-var-list)
- (if (string-match (concat token "\\.") (car var))
- (setq gdb-var-list (delq var gdb-var-list))))
- (gdb-var-delete-children token)
- (speedbar-change-expand-button-char ?+)
- (speedbar-delete-subblock indent))
- (t (error "Ooops... not sure what to do")))
- (speedbar-center-buffer-smartly))
- (message-box "GUD session has been killed")))
-
-(defun gdb-get-target-string ()
- (with-current-buffer gud-comint-buffer
- gud-target-name))
-
-
-;;
-;; gdb buffers.
-;;
-;; Each buffer has a TYPE -- a symbol that identifies the function
-;; of that particular buffer.
-;;
-;; The usual gdb interaction buffer is given the type `gdba' and
-;; is constructed specially.
-;;
-;; Others are constructed by gdb-get-buffer-create and
-;; named according to the rules set forth in the gdb-buffer-rules-assoc
-
-(defvar gdb-buffer-rules-assoc '())
-
-(defun gdb-get-buffer (key)
- "Return the gdb buffer tagged with type KEY.
-The key should be one of the cars in `gdb-buffer-rules-assoc'."
- (save-excursion
- (gdb-look-for-tagged-buffer key (buffer-list))))
-
-(defun gdb-get-buffer-create (key)
- "Create a new gdb buffer of the type specified by KEY.
-The key should be one of the cars in `gdb-buffer-rules-assoc'."
- (or (gdb-get-buffer key)
- (let* ((rules (assoc key gdb-buffer-rules-assoc))
- (name (funcall (gdb-rules-name-maker rules)))
- (new (get-buffer-create name)))
- (with-current-buffer new
- (let ((trigger))
- (if (cdr (cdr rules))
- (setq trigger (funcall (car (cdr (cdr rules))))))
- (setq gdb-buffer-type key)
- (set (make-local-variable 'gud-minor-mode)
- (buffer-local-value 'gud-minor-mode gud-comint-buffer))
- (set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
- (if trigger (funcall trigger)))
- new))))
-
-(defun gdb-rules-name-maker (rules) (car (cdr rules)))
-
-(defun gdb-look-for-tagged-buffer (key bufs)
- (let ((retval nil))
- (while (and (not retval) bufs)
- (set-buffer (car bufs))
- (if (eq gdb-buffer-type key)
- (setq retval (car bufs)))
- (setq bufs (cdr bufs)))
- retval))
-
-;;
-;; This assoc maps buffer type symbols to rules. Each rule is a list of
-;; at least one and possible more functions. The functions have these
-;; roles in defining a buffer type:
-;;
-;; NAME - Return a name for this buffer type.
-;;
-;; The remaining function(s) are optional:
-;;
-;; MODE - called in a new buffer with no arguments, should establish
-;; the proper mode for the buffer.
-;;
-
-(defun gdb-set-buffer-rules (buffer-type &rest rules)
- (let ((binding (assoc buffer-type gdb-buffer-rules-assoc)))
- (if binding
- (setcdr binding rules)
- (push (cons buffer-type rules)
- gdb-buffer-rules-assoc))))
-
-;; GUD buffers are an exception to the rules
-(gdb-set-buffer-rules 'gdba 'error)
-
-;; Partial-output buffer : This accumulates output from a command executed on
-;; behalf of emacs (rather than the user).
-;;
-(gdb-set-buffer-rules 'gdb-partial-output-buffer
- 'gdb-partial-output-name)
-
-(defun gdb-partial-output-name ()
- (concat " *partial-output-"
- (gdb-get-target-string)
- "*"))
-
-
-(gdb-set-buffer-rules 'gdb-inferior-io
- 'gdb-inferior-io-name
- 'gdb-inferior-io-mode)
-
-(defun gdb-inferior-io-name ()
- (concat "*input/output of "
- (gdb-get-target-string)
- "*"))
-
-(defun gdb-display-separate-io-buffer ()
- "Display IO of debugged program in a separate window."
- (interactive)
- (if gdb-use-separate-io-buffer
- (gdb-display-buffer
- (gdb-get-buffer-create 'gdb-inferior-io) t)))
-
-(defconst gdb-frame-parameters
- '((height . 14) (width . 80)
- (unsplittable . t)
- (tool-bar-lines . nil)
- (menu-bar-lines . nil)
- (minibuffer . nil)))
-
-(defun gdb-frame-separate-io-buffer ()
- "Display IO of debugged program in a new frame."
- (interactive)
- (if gdb-use-separate-io-buffer
- (let ((special-display-regexps (append special-display-regexps '(".*")))
- (special-display-frame-alist gdb-frame-parameters))
- (display-buffer (gdb-get-buffer-create 'gdb-inferior-io)))))
-
-(defvar gdb-inferior-io-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map "\C-c\C-c" 'gdb-separate-io-interrupt)
- (define-key map "\C-c\C-z" 'gdb-separate-io-stop)
- (define-key map "\C-c\C-\\" 'gdb-separate-io-quit)
- (define-key map "\C-c\C-d" 'gdb-separate-io-eof)
- (define-key map "\C-d" 'gdb-separate-io-eof)
- map))
-
-(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
- ;; features. We don't need a process, but comint wants one, so create
- ;; a dummy one.
- (make-comint-in-buffer
- (substring (buffer-name) 1 (- (length (buffer-name)) 1))
- (current-buffer) "hexl")
- (setq comint-input-sender 'gdb-inferior-io-sender))
-
-(defun gdb-inferior-io-sender (proc string)
- ;; PROC is the pseudo-process created to satisfy comint.
- (with-current-buffer (process-buffer proc)
- (setq proc (get-buffer-process gud-comint-buffer))
- (process-send-string proc string)
- (process-send-string proc "\n")))
-
-(defun gdb-separate-io-interrupt ()
- "Interrupt the program being debugged."
- (interactive)
- (interrupt-process
- (get-buffer-process gud-comint-buffer) comint-ptyp))
-
-(defun gdb-separate-io-quit ()
- "Send quit signal to the program being debugged."
- (interactive)
- (quit-process
- (get-buffer-process gud-comint-buffer) comint-ptyp))
-
-(defun gdb-separate-io-stop ()
- "Stop the program being debugged."
- (interactive)
- (stop-process
- (get-buffer-process gud-comint-buffer) comint-ptyp))
-
-(defun gdb-separate-io-eof ()
- "Send end-of-file to the program being debugged."
- (interactive)
- (process-send-eof
- (get-buffer-process gud-comint-buffer)))
-
-
-;; gdb communications
-;;
-
-;; INPUT: things sent to gdb
-;;
-;; The queues are lists. Each element is either a string (indicating user or
-;; user-like input) or a list of the form:
-;;
-;; (INPUT-STRING HANDLER-FN)
-;;
-;; The handler function will be called from the partial-output buffer when the
-;; command completes. This is the way to write commands which invoke gdb
-;; commands autonomously.
-;;
-;; These lists are consumed tail first.
-;;
-
-(defun gdb-send (proc string)
- "A comint send filter for gdb.
-This filter may simply queue input for a later time."
- (if gdb-ready
- (progn
- (with-current-buffer gud-comint-buffer
- (let ((inhibit-read-only t))
- (remove-text-properties (point-min) (point-max) '(face))))
- (if gud-running
- (progn
- (let ((item (concat string "\n")))
- (if gdb-enable-debug (push (cons 'send item) gdb-debug-log))
- (process-send-string proc item)))
- (if (string-match "\\\\\\'" string)
- (setq gdb-continuation (concat gdb-continuation string "\n"))
- (let ((item (concat
- gdb-continuation string
- (if (not comint-input-sender-no-newline) "\n"))))
- (gdb-enqueue-input item)
- (setq gdb-continuation nil)))))
- (push (concat string "\n") gdb-early-user-input)))
-
-;; Note: Stuff enqueued here will be sent to the next prompt, even if it
-;; is a query, or other non-top-level prompt.
-
-(defun gdb-enqueue-input (item)
- (if (not gud-running)
- (if gdb-prompting
- (progn
- (gdb-send-item item)
- (setq gdb-prompting nil))
- (push item gdb-input-queue))))
-
-(defun gdb-dequeue-input ()
- (let ((queue gdb-input-queue))
- (if queue
- (let ((last (car (last queue))))
- (unless (nbutlast queue) (setq gdb-input-queue '()))
- last)
- ;; This should be nil here anyway but set it just to make sure.
- (setq gdb-pending-triggers nil))))
-
-(defun gdb-send-item (item)
- (setq gdb-flush-pending-output nil)
- (if gdb-enable-debug (push (cons 'send-item item) gdb-debug-log))
- (setq gdb-current-item item)
- (let ((process (get-buffer-process gud-comint-buffer)))
- (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
- (if (stringp item)
- (progn
- (setq gdb-output-sink 'user)
- (process-send-string process item))
- (progn
- (gdb-clear-partial-output)
- (setq gdb-output-sink 'pre-emacs)
- (process-send-string process
- (car item))))
- ;; case: eq gud-minor-mode 'gdbmi
- (gdb-clear-partial-output)
- (setq gdb-output-sink 'emacs)
- (process-send-string process (car item)))))
-
-;;
-;; output -- things gdb prints to emacs
-;;
-;; GDB output is a stream interrupted by annotations.
-;; Annotations can be recognized by their beginning
-;; with \C-j\C-z\C-z<tag><opt>\C-j
-;;
-;; The tag is a string obeying symbol syntax.
-;;
-;; The optional part `<opt>' can be either the empty string
-;; or a space followed by more data relating to the annotation.
-;; For example, the SOURCE annotation is followed by a filename,
-;; line number and various useless goo. This data must not include
-;; any newlines.
-;;
-
-(defcustom gud-gdb-command-name "gdb --annotate=3"
- "Default command to execute an executable under the GDB debugger.
-The option \"--annotate=3\" must be included in this value if you
-want the GDB Graphical Interface."
- :type 'string
- :group 'gud
- :version "22.1")
-
-(defvar gdb-annotation-rules
- '(("pre-prompt" gdb-pre-prompt)
- ("prompt" gdb-prompt)
- ("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)
- ("starting" gdb-starting)
- ("exited" gdb-exited)
- ("signalled" gdb-signalled)
- ("signal" gdb-signal)
- ("breakpoint" gdb-stopping)
- ("watchpoint" gdb-stopping)
- ("frame-begin" gdb-frame-begin)
- ("stopped" gdb-stopped)
- ("error-begin" gdb-error)
- ("error" gdb-error)
- ("new-thread" (lambda (ignored)
- (gdb-get-buffer-create 'gdb-threads-buffer)))
- ("thread-changed" gdb-thread-changed))
- "An assoc mapping annotation tags to functions which process them.")
-
-(defun gdb-resync()
- (setq gdb-flush-pending-output t)
- (setq gud-running nil)
- (gdb-force-mode-line-update
- (propertize "stopped" 'face font-lock-warning-face))
- (setq gdb-output-sink 'user)
- (setq gdb-input-queue nil)
- (setq gdb-pending-triggers nil)
- (setq gdb-prompting t))
-
-(defconst gdb-source-spec-regexp
- "\\(.*\\):\\([0-9]*\\):[0-9]*:[a-z]*:0x0*\\([a-f0-9]*\\)")
-
-;; Do not use this except as an annotation handler.
-(defun gdb-source (args)
- (string-match gdb-source-spec-regexp args)
- ;; Extract the frame position from the marker.
- (setq gud-last-frame
- (cons
- (match-string 1 args)
- (string-to-number (match-string 2 args))))
- (setq gdb-pc-address (match-string 3 args))
- ;; cover for auto-display output which comes *before*
- ;; stopped annotation
- (if (eq gdb-output-sink 'inferior) (setq gdb-output-sink 'user)))
-
-(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."
- (setq gdb-error nil)
- (let ((sink gdb-output-sink))
- (cond
- ((eq sink 'user) t)
- ((eq sink 'emacs)
- (setq gdb-output-sink 'post-emacs))
- (t
- (gdb-resync)
- (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-force-mode-line-update
- (propertize "initializing..." 'face font-lock-variable-name-face))
- (gdb-init-1)
- (setq gdb-first-prompt nil))
- (let ((sink gdb-output-sink))
- (cond
- ((eq sink 'user) t)
- ((eq sink 'post-emacs)
- (setq gdb-output-sink 'user)
- (let ((handler
- (car (cdr gdb-current-item))))
- (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer)
- (funcall handler))))
- (t
- (gdb-resync)
- (error "Phase error in gdb-prompt (got %s)" sink))))
- (let ((input (gdb-dequeue-input)))
- (if input
- (gdb-send-item input)
- (progn
- (setq gdb-prompting t)
- (gud-display-frame)
- (setq gdb-early-user-input (nreverse gdb-early-user-input))
- (while gdb-early-user-input
- (gdb-enqueue-input (car gdb-early-user-input))
- (setq gdb-early-user-input (cdr gdb-early-user-input)))))))
-
-(defun gdb-subprompt (ignored)
- "An annotation handler for non-top-level prompts."
- (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."
- (setq gdb-active-process t)
- (setq gdb-printing t)
- (let ((sink gdb-output-sink))
- (cond
- ((eq sink 'user)
- (progn
- (setq gud-running t)
- (setq gdb-stack-update t)
- ;; Temporarily set gud-running to nil to force "info stack" onto queue.
- (let ((gud-running nil))
- (gdb-invalidate-frames)
- (unless (or gdb-register-names
- (string-equal gdb-version "pre-6.4"))
- (gdb-enqueue-input
- (list "server interpreter mi -data-list-register-names\n"
- 'gdb-get-register-names))))
- (setq gdb-inferior-status "running")
- (setq gdb-signalled nil)
- (gdb-force-mode-line-update
- (propertize gdb-inferior-status 'face font-lock-type-face))
- (gdb-remove-text-properties)
- (setq gud-old-arrow gud-overlay-arrow-position)
- (setq gud-overlay-arrow-position nil)
- (setq gdb-overlay-arrow-position nil)
- (setq gdb-stack-position nil)
- (if gdb-use-separate-io-buffer
- (setq gdb-output-sink 'inferior))))
- (t
- (gdb-resync)
- (error "Unexpected `starting' annotation")))))
-
-(defun gdb-signal (ignored)
- (setq gdb-inferior-status "signal")
- (gdb-force-mode-line-update
- (propertize gdb-inferior-status 'face font-lock-warning-face))
- (gdb-stopping ignored))
-
-(defun gdb-stopping (ignored)
- "An annotation handler for `breakpoint' and other annotations.
-They say that I/O for the subprocess is now GDB, not the program
-being debugged."
- (if gdb-use-separate-io-buffer
- (let ((sink gdb-output-sink))
- (cond
- ((eq sink 'inferior)
- (setq gdb-output-sink 'user))
- (t
- (gdb-resync)
- (error "Unexpected stopping annotation"))))))
-
-(defun gdb-exited (ignored)
- "An annotation handler for `exited' and `signalled'.
-They say that I/O for the subprocess is now GDB, not the program
-being debugged and that the program is no longer running. This
-function is used to change the focus of GUD tooltips to #define
-directives."
- (setq gdb-active-process nil)
- (setq gud-overlay-arrow-position nil)
- (setq gdb-overlay-arrow-position nil)
- (setq gdb-stack-position nil)
- (setq gud-old-arrow nil)
- (setq gdb-inferior-status "exited")
- (gdb-force-mode-line-update
- (propertize gdb-inferior-status 'face font-lock-warning-face))
- (gdb-stopping ignored))
-
-(defun gdb-signalled (ignored)
- (setq gdb-signalled t))
-
-(defun gdb-frame-begin (ignored)
- (setq gdb-frame-begin t)
- (setq gdb-printing nil)
- (let ((sink gdb-output-sink))
- (cond
- ((eq sink 'inferior)
- (setq gdb-output-sink 'user))
- ((eq sink 'user) t)
- ((eq sink 'emacs) t)
- (t
- (gdb-resync)
- (error "Unexpected frame-begin annotation (%S)" sink)))))
-
-(defcustom gdb-same-frame (not focus-follows-mouse)
- "Non-nil means pop up GUD buffer in same frame."
- :group 'gdb
- :type 'boolean
- :version "22.1")
-
-(defcustom gdb-find-source-frame nil
- "Non-nil means try to find a source frame further up stack e.g after signal."
- :group 'gdb
- :type 'boolean
- :version "22.1")
-
-(defun gdb-find-source-frame (arg)
- "Toggle looking for a source frame further up call stack.
-The code associated with current (innermost) frame may not have
-been compiled with debug information, e.g., C library routine.
-With prefix argument ARG, look for a source frame further up
-stack to display in the source buffer if ARG is positive,
-otherwise don't look further up."
- (interactive "P")
- (setq gdb-find-source-frame
- (if (null arg)
- (not gdb-find-source-frame)
- (> (prefix-numeric-value arg) 0)))
- (message (format "Looking for source frame %sabled"
- (if gdb-find-source-frame "en" "dis"))))
-
-(defun gdb-stopped (ignored)
- "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)
- (unless (or gud-overlay-arrow-position gud-last-frame)
- (if (and gdb-frame-begin gdb-printing)
- (setq gud-overlay-arrow-position gud-old-arrow)
- ;;Pop up GUD buffer to display current frame when it doesn't have source
- ;;information i.e if not compiled with -g as with libc routines generally.
- (if gdb-same-frame
- (gdb-display-gdb-buffer)
- (gdb-frame-gdb-buffer))
- (if gdb-find-source-frame
- ;;Try to find source further up stack e.g after signal.
- (setq gdb-look-up-stack
- (if (gdb-get-buffer 'gdb-stack-buffer)
- 'keep
- (progn
- (gdb-get-buffer-create 'gdb-stack-buffer)
- (gdb-invalidate-frames)
- 'delete))))))
- (unless (member gdb-inferior-status '("exited" "signal"))
- (setq gdb-active-process t) ;Just for attaching case.
- (setq gdb-inferior-status "stopped")
- (gdb-force-mode-line-update
- (propertize gdb-inferior-status 'face font-lock-warning-face)))
- (let ((sink gdb-output-sink))
- (cond
- ((eq sink 'inferior)
- (setq gdb-output-sink 'user))
- ((eq sink 'user) t)
- (t
- (gdb-resync)
- (error "Unexpected stopped annotation"))))
- (if gdb-signalled (gdb-exited ignored)))
-
-(defun gdb-error (ignored)
- (setq gdb-error (not gdb-error)))
-
-(defun gdb-thread-changed (ignored)
- (gdb-frames-force-update))
-
-(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."
- ;; Don't add to queue if there outstanding items or gdb-version is not known
- ;; yet.
- (unless (or gdb-pending-triggers gdb-first-post-prompt)
- (gdb-get-selected-frame)
- (gdb-invalidate-frames)
- ;; Regenerate breakpoints buffer in case it has been inadvertantly deleted.
- (gdb-get-buffer-create 'gdb-breakpoints-buffer)
- (gdb-invalidate-breakpoints)
- ;; Do this through gdb-get-selected-frame -> gdb-frame-handler
- ;; so gdb-pc-address is updated.
- ;; (gdb-invalidate-assembler)
-
- (if (string-equal gdb-version "pre-6.4")
- (gdb-invalidate-registers)
- (gdb-get-changed-registers)
- (gdb-invalidate-registers-1))
-
- (gdb-invalidate-memory)
- (if (string-equal gdb-version "pre-6.4")
- (gdb-invalidate-locals)
- (gdb-invalidate-locals-1))
-
- (gdb-invalidate-threads)
- (unless (or (null gdb-var-list)
- (eq system-type 'darwin)) ;Breaks on Darwin's GDB-5.3.
- ;; FIXME: with GDB-6 on Darwin, this might very well work.
- ;; Only needed/used with speedbar/watch expressions.
- (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame))
- (if (string-equal gdb-version "pre-6.4")
- (gdb-var-update)
- (gdb-var-update-1)))))
- (setq gdb-first-post-prompt nil)
- (let ((sink gdb-output-sink))
- (cond
- ((eq sink 'user) t)
- ((eq sink 'pre-emacs)
- (setq gdb-output-sink 'emacs))
- (t
- (gdb-resync)
- (error "Phase error in gdb-post-prompt (got %s)" sink)))))
-
-(defconst gdb-buffer-list
-'(gdb-stack-buffer gdb-locals-buffer gdb-registers-buffer gdb-threads-buffer))
-
-(defun gdb-remove-text-properties ()
- (dolist (buffertype gdb-buffer-list)
- (let ((buffer (gdb-get-buffer buffertype)))
- (if buffer
- (with-current-buffer buffer
- (let ((inhibit-read-only t))
- (remove-text-properties
- (point-min) (point-max) '(mouse-face nil help-echo nil))))))))
-
-;; GUD displays the selected GDB frame. This might might not be the current
-;; GDB frame (after up, down etc). If no GDB frame is visible but the last
-;; visited breakpoint is, use that window.
-(defun gdb-display-source-buffer (buffer)
- (let* ((last-window (if gud-last-last-frame
- (get-buffer-window
- (gud-find-file (car gud-last-last-frame)))))
- (source-window (or last-window
- (if (and gdb-source-window
- (window-live-p gdb-source-window))
- gdb-source-window))))
- (when source-window
- (setq gdb-source-window source-window)
- (set-window-buffer source-window buffer))
- source-window))
-
-;; Derived from gud-gdb-marker-regexp
-(defvar gdb-fullname-regexp
- (concat "\\(.:?[^" ":" "\n]*\\)" ":" "\\([0-9]*\\)" ":" ".*"))
-
-(defun gud-gdba-marker-filter (string)
- "A gud marker filter for gdb. Handle a burst of output from GDB."
- (if gdb-flush-pending-output
- nil
- (when gdb-enable-debug
- (push (cons 'recv string) gdb-debug-log)
- (if (and gdb-debug-log-max
- (> (length gdb-debug-log) gdb-debug-log-max))
- (setcdr (nthcdr (1- gdb-debug-log-max) gdb-debug-log) nil)))
- ;; Recall the left over gud-marker-acc from last time.
- (setq gud-marker-acc (concat gud-marker-acc string))
- ;; Start accumulating output for the GUD buffer.
- (let ((output ""))
- ;;
- ;; Process all the complete markers in this chunk.
- (while (string-match "\n\032\032\\(.*\\)\n" gud-marker-acc)
- (let ((annotation (match-string 1 gud-marker-acc))
- (before (substring gud-marker-acc 0 (match-beginning 0)))
- (after (substring gud-marker-acc (match-end 0))))
- ;;
- ;; Parse the tag from the annotation, and maybe its arguments.
- (string-match "\\(\\S-*\\) ?\\(.*\\)" annotation)
- (let* ((annotation-type (match-string 1 annotation))
- (annotation-arguments (match-string 2 annotation))
- (annotation-rule (assoc annotation-type
- gdb-annotation-rules)))
-
- ;; Stuff prior to the match is just ordinary output.
- ;; It is either concatenated to OUTPUT or directed
- ;; elsewhere.
- (setq output (gdb-concat-output output before))
-
- ;; Take that stuff off the gud-marker-acc.
- (setq gud-marker-acc after)
-
- ;; Call the handler for this annotation.
- (if annotation-rule
- (funcall (car (cdr annotation-rule))
- annotation-arguments))
-
- ;; Else the annotation is not recognized. Ignore it silently,
- ;; so that GDB can add new annotations without causing
- ;; us to blow up.
- )))
-
- ;; Does the remaining text end in a partial line?
- ;; If it does, then keep part of the gud-marker-acc until we get more.
- (if (string-match "\n\\'\\|\n\032\\'\\|\n\032\032.*\\'"
- gud-marker-acc)
- (progn
- ;; Everything before the potential marker start can be output.
- (setq output
- (gdb-concat-output output
- (substring gud-marker-acc 0
- (match-beginning 0))))
- ;;
- ;; Everything after, we save, to combine with later input.
- (setq gud-marker-acc (substring gud-marker-acc
- (match-beginning 0))))
- ;;
- ;; In case we know the gud-marker-acc contains no partial annotations:
- (progn
- (setq output (gdb-concat-output output gud-marker-acc))
- (setq gud-marker-acc "")))
- output)))
-
-(defun gdb-concat-output (so-far new)
- (if gdb-error
- (put-text-property 0 (length new) 'face font-lock-warning-face new))
- (let ((sink gdb-output-sink))
- (cond
- ((eq sink 'user) (concat so-far new))
- ((or (eq sink 'pre-emacs) (eq sink 'post-emacs)) so-far)
- ((eq sink 'emacs)
- (gdb-append-to-partial-output new)
- so-far)
- ((eq sink 'inferior)
- (gdb-append-to-inferior-io new)
- so-far)
- (t
- (gdb-resync)
- (error "Bogon output sink %S" sink)))))
-
-(defun gdb-append-to-partial-output (string)
- (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer)
- (goto-char (point-max))
- (insert string)))
-
-(defun gdb-clear-partial-output ()
- (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer)
- (erase-buffer)))
-
-(defun gdb-append-to-inferior-io (string)
- (with-current-buffer (gdb-get-buffer-create 'gdb-inferior-io)
- (goto-char (point-max))
- (insert-before-markers string))
- (if (not (string-equal string ""))
- (gdb-display-buffer (gdb-get-buffer-create 'gdb-inferior-io) t)))
-
-(defun gdb-clear-inferior-io ()
- (with-current-buffer (gdb-get-buffer-create 'gdb-inferior-io)
- (erase-buffer)))
-
-(defun gdb-jsonify-buffer (&optional fix-key fix-list)
- "Prepare GDB/MI output in current buffer for parsing with `json-read'.
-
-Field names are wrapped in double quotes and equal signs are
-replaced with semicolons.
-
-If FIX-KEY is non-nil, strip all \"FIX-KEY=\" occurrences from
-partial output. This is used to get rid of useless keys in lists
-in MI messages, e.g.: [key=.., key=..]. -stack-list-frames and
--break-info are examples of MI commands which issue such
-responses.
-
-If FIX-LIST is non-nil, \"FIX-LIST={..}\" is replaced with
-\"FIX-LIST=[..]\" prior to parsing. This is used to fix broken
--break-info output when it contains breakpoint script field
-incompatible with GDB/MI output syntax."
- (save-excursion
- (goto-char (point-min))
- ;; Sometimes missing symbol information precedes "^done" record.
- (re-search-forward "[[:ascii:]]*?\\^done," nil t)
- (replace-match "")
- (re-search-forward "(gdb) \n" nil t)
- (replace-match "")
- (goto-char (point-min))
- (when fix-key
- (save-excursion
- (while (re-search-forward (concat "[\\[,]\\(" fix-key "=\\)") nil t)
- (replace-match "" nil nil nil 1))))
- (when fix-list
- (save-excursion
- ;; Find positions of braces which enclose broken list
- (while (re-search-forward (concat fix-list "={\"") nil t)
- (let ((p1 (goto-char (- (point) 2)))
- (p2 (progn (forward-sexp)
- (1- (point)))))
- ;; Replace braces with brackets
- (save-excursion
- (goto-char p1)
- (delete-char 1)
- (insert "[")
- (goto-char p2)
- (delete-char 1)
- (insert "]"))))))
- (goto-char (point-min))
- (insert "{")
- (while (re-search-forward
- "\\([[:alnum:]-_]+\\)=\\({\\|\\[\\|\"\"\\|\".*?[^\\]\"\\)" nil t)
- (replace-match "\"\\1\":\\2" nil nil))
- (goto-char (point-max))
- (insert "}")))
-
-(defun gdb-json-read-buffer (&optional fix-key fix-list)
- "Prepare and parse GDB/MI output in current buffer with `json-read'.
-
-FIX-KEY and FIX-LIST work as in `gdb-jsonify-buffer'."
- (gdb-jsonify-buffer fix-key fix-list)
- (save-excursion
- (goto-char (point-min))
- (let ((json-array-type 'list))
- (json-read))))
-
-(defun gdb-json-partial-output (&optional fix-key fix-list)
- "Prepare and parse gdb-partial-output-buffer with `json-read'.
-
-FIX-KEY and FIX-KEY work as in `gdb-jsonify-buffer'."
- (with-current-buffer (gdb-get-buffer-create 'gdb-partial-output-buffer)
- (gdb-json-read-buffer fix-key fix-list)))
-
-
-;; One trick is to have a command who's output is always available in a buffer
-;; of it's own, and is always up to date. We build several buffers of this
-;; type.
-;;
-;; There are two aspects to this: gdb has to tell us when the output for that
-;; command might have changed, and we have to be able to run the command
-;; behind the user's back.
-;;
-;; The output phasing associated with the variable gdb-output-sink
-;; help us to run commands behind the user's back.
-;;
-;; Below is the code for specificly managing buffers of output from one
-;; command.
-;;
-
-;; The trigger function is suitable for use in the assoc GDB-ANNOTATION-RULES
-;; It adds an input for the command we are tracking. It should be the
-;; annotation rule binding of whatever gdb sends to tell us this command
-;; might have changed it's output.
-;;
-;; NAME is the function name. DEMAND-PREDICATE tests if output is really needed.
-;; GDB-COMMAND is a string of such. OUTPUT-HANDLER is the function bound to the
-;; input in the input queue (see comment about ``gdb communications'' above).
-
-(defmacro def-gdb-auto-update-trigger (name demand-predicate gdb-command
- output-handler)
- `(defun ,name (&optional ignored)
- (if (and ,demand-predicate
- (not (member ',name
- gdb-pending-triggers)))
- (progn
- (gdb-enqueue-input
- (list ,gdb-command ',output-handler))
- (push ',name gdb-pending-triggers)))))
-
-(defmacro def-gdb-auto-update-handler (name trigger buf-key custom-defun)
- `(defun ,name ()
- (setq gdb-pending-triggers
- (delq ',trigger
- gdb-pending-triggers))
- (let ((buf (gdb-get-buffer ',buf-key)))
- (and buf
- (with-current-buffer buf
- (let* ((window (get-buffer-window buf 0))
- (start (window-start window))
- (p (if window (window-point window) (point)))
- (buffer-read-only nil))
- (erase-buffer)
- (insert-buffer-substring (gdb-get-buffer-create
- 'gdb-partial-output-buffer))
- (if window
- (progn
- (set-window-start window start)
- (set-window-point window p))
- (goto-char p))))))
- ;; put customisation here
- (,custom-defun)))
-
-(defmacro def-gdb-auto-updated-buffer (buffer-key
- trigger-name gdb-command
- output-handler-name custom-defun)
- `(progn
- (def-gdb-auto-update-trigger ,trigger-name
- ;; The demand predicate:
- (gdb-get-buffer ',buffer-key)
- ,gdb-command
- ,output-handler-name)
- (def-gdb-auto-update-handler ,output-handler-name
- ,trigger-name ,buffer-key ,custom-defun)))
-
-
-;;
-;; Breakpoint buffer : This displays the output of `info breakpoints'.
-;;
-(gdb-set-buffer-rules 'gdb-breakpoints-buffer
- 'gdb-breakpoints-buffer-name
- 'gdb-breakpoints-mode)
-
-(def-gdb-auto-updated-buffer gdb-breakpoints-buffer
- ;; This defines the auto update rule for buffers of type
- ;; `gdb-breakpoints-buffer'.
- ;;
- ;; It defines a function to serve as the annotation handler that
- ;; handles the `foo-invalidated' message. That function is called:
- gdb-invalidate-breakpoints
- ;;
- ;; To update the buffer, this command is sent to gdb.
- "server info breakpoints\n"
- ;;
- ;; This also defines a function to be the handler for the output
- ;; from the command above. That function will copy the output into
- ;; the appropriately typed buffer. That function will be called:
- gdb-info-breakpoints-handler
- ;; buffer specific functions
- gdb-info-breakpoints-custom)
-
-(defconst breakpoint-xpm-data
- "/* XPM */
-static char *magick[] = {
-/* columns rows colors chars-per-pixel */
-\"10 10 2 1\",
-\" c red\",
-\"+ c None\",
-/* pixels */
-\"+++ +++\",
-\"++ ++\",
-\"+ +\",
-\" \",
-\" \",
-\" \",
-\" \",
-\"+ +\",
-\"++ ++\",
-\"+++ +++\",
-};"
- "XPM data used for breakpoint icon.")
-
-(defconst breakpoint-enabled-pbm-data
- "P1
-10 10\",
-0 0 0 0 1 1 1 1 0 0 0 0
-0 0 0 1 1 1 1 1 1 0 0 0
-0 0 1 1 1 1 1 1 1 1 0 0
-0 1 1 1 1 1 1 1 1 1 1 0
-0 1 1 1 1 1 1 1 1 1 1 0
-0 1 1 1 1 1 1 1 1 1 1 0
-0 1 1 1 1 1 1 1 1 1 1 0
-0 0 1 1 1 1 1 1 1 1 0 0
-0 0 0 1 1 1 1 1 1 0 0 0
-0 0 0 0 1 1 1 1 0 0 0 0"
- "PBM data used for enabled breakpoint icon.")
-
-(defconst breakpoint-disabled-pbm-data
- "P1
-10 10\",
-0 0 1 0 1 0 1 0 0 0
-0 1 0 1 0 1 0 1 0 0
-1 0 1 0 1 0 1 0 1 0
-0 1 0 1 0 1 0 1 0 1
-1 0 1 0 1 0 1 0 1 0
-0 1 0 1 0 1 0 1 0 1
-1 0 1 0 1 0 1 0 1 0
-0 1 0 1 0 1 0 1 0 1
-0 0 1 0 1 0 1 0 1 0
-0 0 0 1 0 1 0 1 0 0"
- "PBM data used for disabled breakpoint icon.")
-
-(defvar breakpoint-enabled-icon nil
- "Icon for enabled breakpoint in display margin.")
-
-(defvar breakpoint-disabled-icon nil
- "Icon for disabled breakpoint in display margin.")
-
-(declare-function define-fringe-bitmap "fringe.c"
- (bitmap bits &optional height width align))
-
-(and (display-images-p)
- ;; Bitmap for breakpoint in fringe
- (define-fringe-bitmap 'breakpoint
- "\x3c\x7e\xff\xff\xff\xff\x7e\x3c")
- ;; Bitmap for gud-overlay-arrow in fringe
- (define-fringe-bitmap 'hollow-right-triangle
- "\xe0\x90\x88\x84\x84\x88\x90\xe0"))
-
-(defface breakpoint-enabled
- '((t
- :foreground "red1"
- :weight bold))
- "Face for enabled breakpoint icon in fringe."
- :group 'gdb)
-
-(defface breakpoint-disabled
- '((((class color) (min-colors 88)) :foreground "grey70")
- ;; Ensure that on low-color displays that we end up something visible.
- (((class color) (min-colors 8) (background light))
- :foreground "black")
- (((class color) (min-colors 8) (background dark))
- :foreground "white")
- (((type tty) (class mono))
- :inverse-video t)
- (t :background "gray"))
- "Face for disabled breakpoint icon in fringe."
- :group 'gdb)
-
-(defconst gdb-breakpoint-regexp
- "\\(?:\\([0-9]+\\).*?\\(?:point\\|catch\\s-+\\S-+\\)\\s-+\\S-+\\|\\([0-9]+\\.[0-9]+\\)\\)\\s-+\\(.\\)\\s-+")
-
-;; Put breakpoint icons in relevant margins (even those set in the GUD buffer).
-(defun gdb-info-breakpoints-custom ()
- (let ((flag) (bptno))
- ;; Remove all breakpoint-icons in source buffers but not assembler buffer.
- (dolist (buffer (buffer-list))
- (with-current-buffer buffer
- (if (and (memq gud-minor-mode '(gdba gdbmi))
- (not (string-match "\\` ?\\*.+\\*\\'" (buffer-name))))
- (gdb-remove-breakpoint-icons (point-min) (point-max)))))
- (with-current-buffer (gdb-get-buffer 'gdb-breakpoints-buffer)
- (save-excursion
- (let ((buffer-read-only nil))
- (goto-char (point-min))
- (while (< (point) (- (point-max) 1))
- (forward-line 1)
- (if (looking-at gdb-breakpoint-regexp)
- (progn
- (setq bptno (or (match-string 1) (match-string 2)))
- (setq flag (char-after (match-beginning 3)))
- (if (match-string 1)
- (setq gdb-parent-bptno-enabled (eq flag ?y)))
- (add-text-properties
- (match-beginning 3) (match-end 3)
- (if (eq flag ?y)
- '(face font-lock-warning-face)
- '(face font-lock-type-face)))
- (let ((bl (point))
- (el (line-end-position)))
- (when (re-search-forward " in \\(.*\\) at" el t)
- (add-text-properties
- (match-beginning 1) (match-end 1)
- '(face font-lock-function-name-face)))
- (if (re-search-forward
- ".*\\s-+\\(\\S-+\\):\\([0-9]+\\)$" el t)
- (let ((line (match-string 2))
- (file (match-string 1)))
- (add-text-properties bl el
- '(mouse-face highlight
- help-echo "mouse-2, RET: visit breakpoint"))
- (unless (file-exists-p file)
- (setq file (cdr (assoc bptno gdb-location-alist))))
- (if (and file
- (not (string-equal file "File not found")))
- (with-current-buffer
- (find-file-noselect file 'nowarn)
- (gdb-init-buffer)
- ;; Only want one breakpoint icon at each
- ;; location.
- (save-excursion
- (goto-char (point-min))
- (forward-line (1- (string-to-number line)))
- (gdb-put-breakpoint-icon (eq flag ?y) bptno)))
- (gdb-enqueue-input
- (list
- (concat gdb-server-prefix "list "
- (match-string-no-properties 1) ":1\n")
- 'ignore))
- (gdb-enqueue-input
- (list (concat gdb-server-prefix "info source\n")
- `(lambda () (gdb-get-location
- ,bptno ,line ,flag))))))
- (if (re-search-forward
- "<\\(\\(\\sw\\|[_.]\\)+\\)\\(\\+[0-9]+\\)?>"
- el t)
- (add-text-properties
- (match-beginning 1) (match-end 1)
- '(face font-lock-function-name-face))
- (end-of-line)
- (re-search-backward "\\s-\\(\\S-*\\)"
- bl t)
- (add-text-properties
- (match-beginning 1) (match-end 1)
- '(face font-lock-variable-name-face)))))))
- (end-of-line))))))
- (if (gdb-get-buffer 'gdb-assembler-buffer) (gdb-assembler-custom))
-
- ;; Breakpoints buffer is always present. Hack to just update
- ;; current frame if there's been no execution.
- (if gdb-stack-update
- (setq gdb-stack-update nil)
- (if (gdb-get-buffer 'gdb-stack-buffer) (gdb-info-stack-custom))))
-
-(declare-function gud-remove "gdb-ui" t t) ; gud-def
-(declare-function gud-break "gdb-ui" t t) ; gud-def
-(declare-function fringe-bitmaps-at-pos "fringe.c" (&optional pos window))
-
-(defun gdb-mouse-set-clear-breakpoint (event)
- "Set/clear breakpoint in left fringe/margin at mouse click.
-If not in a source or disassembly buffer just set point."
- (interactive "e")
- (mouse-minibuffer-check event)
- (let ((posn (event-end event)))
- (with-selected-window (posn-window posn)
- (if (or (buffer-file-name) (eq major-mode 'gdb-assembler-mode))
- (if (numberp (posn-point posn))
- (save-excursion
- (goto-char (posn-point posn))
- (if (or (posn-object posn)
- (eq (car (fringe-bitmaps-at-pos (posn-point posn)))
- 'breakpoint))
- (gud-remove nil)
- (gud-break nil)))))
- (posn-set-point posn))))
-
-(defun gdb-mouse-toggle-breakpoint-margin (event)
- "Enable/disable breakpoint in left margin with mouse click."
- (interactive "e")
- (mouse-minibuffer-check event)
- (let ((posn (event-end event)))
- (if (numberp (posn-point posn))
- (with-selected-window (posn-window posn)
- (save-excursion
- (goto-char (posn-point posn))
- (if (posn-object posn)
- (let* ((bptno (get-text-property
- 0 'gdb-bptno (car (posn-string posn)))))
- (string-match "\\([0-9]+\\)*" bptno)
- (gdb-enqueue-input
- (list
- (concat gdb-server-prefix
- (if (get-text-property
- 0 'gdb-enabled (car (posn-string posn)))
- "disable "
- "enable ")
- (match-string 1 bptno) "\n")
- 'ignore)))))))))
-
-(defun gdb-mouse-toggle-breakpoint-fringe (event)
- "Enable/disable breakpoint in left fringe with mouse click."
- (interactive "e")
- (mouse-minibuffer-check event)
- (let* ((posn (event-end event))
- (pos (posn-point posn))
- obj)
- (when (numberp pos)
- (with-selected-window (posn-window posn)
- (with-current-buffer (window-buffer (selected-window))
- (goto-char pos)
- (dolist (overlay (overlays-in pos pos))
- (when (overlay-get overlay 'put-break)
- (setq obj (overlay-get overlay 'before-string))))
- (when (stringp obj)
- (let* ((bptno (get-text-property 0 'gdb-bptno obj)))
- (string-match "\\([0-9]+\\)*" bptno)
- (gdb-enqueue-input
- (list
- (concat gdb-server-prefix
- (if (get-text-property 0 'gdb-enabled obj)
- "disable "
- "enable ")
- (match-string 1 bptno) "\n")
- 'ignore)))))))))
-
-(defun gdb-breakpoints-buffer-name ()
- (with-current-buffer gud-comint-buffer
- (concat "*breakpoints of " (gdb-get-target-string) "*")))
-
-(defun gdb-display-breakpoints-buffer ()
- "Display status of user-settable breakpoints."
- (interactive)
- (gdb-display-buffer
- (gdb-get-buffer-create 'gdb-breakpoints-buffer) t))
-
-(defun gdb-frame-breakpoints-buffer ()
- "Display status of user-settable breakpoints in a new frame."
- (interactive)
- (let ((special-display-regexps (append special-display-regexps '(".*")))
- (special-display-frame-alist gdb-frame-parameters))
- (display-buffer (gdb-get-buffer-create 'gdb-breakpoints-buffer))))
-
-(defvar gdb-breakpoints-mode-map
- (let ((map (make-sparse-keymap))
- (menu (make-sparse-keymap "Breakpoints")))
- (define-key menu [quit] '("Quit" . gdb-delete-frame-or-window))
- (define-key menu [goto] '("Goto" . gdb-goto-breakpoint))
- (define-key menu [delete] '("Delete" . gdb-delete-breakpoint))
- (define-key menu [toggle] '("Toggle" . gdb-toggle-breakpoint))
- (suppress-keymap map)
- (define-key map [menu-bar breakpoints] (cons "Breakpoints" menu))
- (define-key map " " 'gdb-toggle-breakpoint)
- (define-key map "D" 'gdb-delete-breakpoint)
- ;; Don't bind "q" to kill-this-buffer as we need it for breakpoint icons.
- (define-key map "q" 'gdb-delete-frame-or-window)
- (define-key map "\r" 'gdb-goto-breakpoint)
- (define-key map [mouse-2] 'gdb-goto-breakpoint)
- (define-key map [follow-link] 'mouse-face)
- map))
-
-(defun gdb-delete-frame-or-window ()
- "Delete frame if there is only one window. Otherwise delete the window."
- (interactive)
- (if (one-window-p) (delete-frame)
- (delete-window)))
-
-;;from make-mode-line-mouse-map
-(defun gdb-make-header-line-mouse-map (mouse function) "\
-Return a keymap with single entry for mouse key MOUSE on the header line.
-MOUSE is defined to run function FUNCTION with no args in the buffer
-corresponding to the mode line clicked."
- (let ((map (make-sparse-keymap)))
- (define-key map (vector 'header-line mouse) function)
- (define-key map (vector 'header-line 'down-mouse-1) 'ignore)
- map))
-
-(defmacro gdb-propertize-header (name buffer help-echo mouse-face face)
- `(propertize ,name
- 'help-echo ,help-echo
- 'mouse-face ',mouse-face
- 'face ',face
- 'local-map
- (gdb-make-header-line-mouse-map
- 'mouse-1
- (lambda (event) (interactive "e")
- (save-selected-window
- (select-window (posn-window (event-start event)))
- (set-window-dedicated-p (selected-window) nil)
- (switch-to-buffer
- (gdb-get-buffer-create ',buffer))
- (setq header-line-format(gdb-set-header ',buffer))
- (set-window-dedicated-p (selected-window) t))))))
-
-(defun gdb-set-header (buffer)
- (cond ((eq buffer 'gdb-locals-buffer)
- (list
- (gdb-propertize-header "Locals" gdb-locals-buffer
- nil nil mode-line)
- " "
- (gdb-propertize-header "Registers" gdb-registers-buffer
- "mouse-1: select" mode-line-highlight mode-line-inactive)))
- ((eq buffer 'gdb-registers-buffer)
- (list
- (gdb-propertize-header "Locals" gdb-locals-buffer
- "mouse-1: select" mode-line-highlight mode-line-inactive)
- " "
- (gdb-propertize-header "Registers" gdb-registers-buffer
- nil nil mode-line)))
- ((eq buffer 'gdb-breakpoints-buffer)
- (list
- (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer
- nil nil mode-line)
- " "
- (gdb-propertize-header "Threads" gdb-threads-buffer
- "mouse-1: select" mode-line-highlight mode-line-inactive)))
- ((eq buffer 'gdb-threads-buffer)
- (list
- (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer
- "mouse-1: select" mode-line-highlight mode-line-inactive)
- " "
- (gdb-propertize-header "Threads" gdb-threads-buffer
- nil nil mode-line)))))
-
-(defvar gdb-breakpoints-header
- (list
- (gdb-propertize-header "Breakpoints" gdb-breakpoints-buffer
- nil nil mode-line)
- " "
- (gdb-propertize-header "Threads" gdb-threads-buffer
- "mouse-1: select" mode-line-highlight mode-line-inactive)))
-
-(defun gdb-breakpoints-mode ()
- "Major mode for gdb breakpoints.
-
-\\{gdb-breakpoints-mode-map}"
- (kill-all-local-variables)
- (setq major-mode 'gdb-breakpoints-mode)
- (setq mode-name "Breakpoints")
- (use-local-map gdb-breakpoints-mode-map)
- (setq buffer-read-only t)
- (buffer-disable-undo)
- (setq header-line-format gdb-breakpoints-header)
- (run-mode-hooks 'gdb-breakpoints-mode-hook)
- (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
- 'gdb-invalidate-breakpoints
- 'gdbmi-invalidate-breakpoints))
-
-(defun gdb-toggle-breakpoint ()
- "Enable/disable breakpoint at current line."
- (interactive)
- (save-excursion
- (beginning-of-line 1)
- (if (looking-at gdb-breakpoint-regexp)
- (gdb-enqueue-input
- (list
- (concat gdb-server-prefix
- (if (eq ?y (char-after (match-beginning 3)))
- "disable "
- "enable ")
- (or (match-string 1) (match-string 2)) "\n") 'ignore))
- (error "Not recognized as break/watchpoint line"))))
-
-(defun gdb-delete-breakpoint ()
- "Delete the breakpoint at current line."
- (interactive)
- (save-excursion
- (beginning-of-line 1)
- (if (looking-at gdb-breakpoint-regexp)
- (if (match-string 1)
- (gdb-enqueue-input
- (list
- (concat gdb-server-prefix "delete " (match-string 1) "\n")
- 'ignore))
- (message-box "This breakpoint cannot be deleted on its own."))
- (error "Not recognized as break/watchpoint line"))))
-
-(defun gdb-goto-breakpoint (&optional event)
- "Display the breakpoint location specified at current line."
- (interactive (list last-input-event))
- (if event (posn-set-point (event-end event)))
- (save-excursion
- (beginning-of-line 1)
- (if (looking-at "\\([0-9]+\\.?[0-9]*\\) .*\\s-+\\(\\S-+\\):\\([0-9]+\\)$")
- (let ((bptno (match-string 1))
- (file (match-string 2))
- (line (match-string 3)))
- (save-selected-window
- (let* ((buffer (find-file-noselect
- (if (file-exists-p file) file
- (cdr (assoc bptno gdb-location-alist)))))
- (window (or (gdb-display-source-buffer buffer)
- (display-buffer buffer))))
- (setq gdb-source-window window)
- (with-current-buffer buffer
- (goto-char (point-min))
- (forward-line (1- (string-to-number line)))
- (set-window-point window (point))))))
- (error "No location specified"))))
-
-
-;; Frames buffer. This displays a perpetually correct backtrace
-;; (from the command `where').
-;;
-;; Alas, if your stack is deep, it is costly.
-;;
-(defcustom gdb-max-frames 40
- "Maximum number of frames displayed in call stack."
- :type 'integer
- :group 'gdb
- :version "22.1")
-
-(gdb-set-buffer-rules 'gdb-stack-buffer
- 'gdb-stack-buffer-name
- 'gdb-frames-mode)
-
-(def-gdb-auto-updated-buffer gdb-stack-buffer
- gdb-invalidate-frames
- (concat "server info stack " (number-to-string gdb-max-frames) "\n")
- gdb-info-stack-handler
- gdb-info-stack-custom)
-
-;; This may be more important for embedded targets where unwinding the
-;; stack may take a long time.
-(defadvice gdb-invalidate-frames (around gdb-invalidate-frames-advice
- (&optional ignored) activate compile)
- "Only queue \"info stack\" if execution has occurred."
- (if gdb-stack-update ad-do-it))
-
-(defun gdb-info-stack-custom ()
- (with-current-buffer (gdb-get-buffer 'gdb-stack-buffer)
- (let (move-to)
- (save-excursion
- (unless (eq gdb-look-up-stack 'delete)
- (let ((buffer-read-only nil)
- bl el)
- (goto-char (point-min))
- (while (< (point) (point-max))
- (setq bl (line-beginning-position)
- el (line-end-position))
- (when (looking-at "#")
- (add-text-properties bl el
- '(mouse-face highlight
- help-echo "mouse-2, RET: Select frame")))
- (goto-char bl)
- (when (looking-at "^#\\([0-9]+\\)")
- (when (string-equal (match-string 1) gdb-frame-number)
- (if (gud-tool-bar-item-visible-no-fringe)
- (progn
- (put-text-property bl (+ bl 4)
- 'face '(:inverse-video t))
- (setq move-to bl))
- (or gdb-stack-position
- (setq gdb-stack-position (make-marker)))
- (set-marker gdb-stack-position (point))
- (setq move-to gdb-stack-position)))
- (when (re-search-forward "\\([^ ]+\\) (" el t)
- (put-text-property (match-beginning 1) (match-end 1)
- 'face font-lock-function-name-face)
- (setq bl (match-end 0))
- (while (re-search-forward "<\\([^>]+\\)>" el t)
- (put-text-property (match-beginning 1) (match-end 1)
- 'face font-lock-function-name-face))
- (goto-char bl)
- (while (re-search-forward "\\(\\(\\sw\\|[_.]\\)+\\)=" el t)
- (put-text-property (match-beginning 1) (match-end 1)
- 'face font-lock-variable-name-face))))
- (forward-line 1))
- (forward-line -1)
- (when (looking-at "(More stack frames follow...)")
- (add-text-properties
- (match-beginning 0) (match-end 0)
- '(mouse-face highlight
- gdb-max-frames t
- help-echo
- "mouse-2, RET: customize gdb-max-frames to see more frames"
- )))))
- (when gdb-look-up-stack
- (goto-char (point-min))
- (when (re-search-forward "\\(\\S-+?\\):\\([0-9]+\\)" nil t)
- (let ((start (line-beginning-position))
- (file (match-string 1))
- (line (match-string 2)))
- (re-search-backward "^#*\\([0-9]+\\)" start t)
- (gdb-enqueue-input
- (list (concat gdb-server-prefix "frame "
- (match-string 1) "\n") 'gdb-set-hollow))
- (gdb-enqueue-input
- (list (concat gdb-server-prefix "frame 0\n") 'ignore))))))
- (when move-to
- (let ((window (get-buffer-window (current-buffer) 0)))
- (when window
- (with-selected-window window
- (goto-char move-to)
- (unless (pos-visible-in-window-p)
- (recenter '(center)))))))))
- (if (eq gdb-look-up-stack 'delete)
- (kill-buffer (gdb-get-buffer 'gdb-stack-buffer)))
- (setq gdb-look-up-stack nil))
-
-(defun gdb-set-hollow ()
- (if gud-last-last-frame
- (with-current-buffer (gud-find-file (car gud-last-last-frame))
- (setq fringe-indicator-alist
- '((overlay-arrow . hollow-right-triangle))))))
-
-(defun gdb-stack-buffer-name ()
- (with-current-buffer gud-comint-buffer
- (concat "*stack frames of " (gdb-get-target-string) "*")))
-
-(defun gdb-display-stack-buffer ()
- "Display backtrace of current stack."
- (interactive)
- (gdb-display-buffer
- (gdb-get-buffer-create 'gdb-stack-buffer) t))
-
-(defun gdb-frame-stack-buffer ()
- "Display backtrace of current stack in a new frame."
- (interactive)
- (let ((special-display-regexps (append special-display-regexps '(".*")))
- (special-display-frame-alist gdb-frame-parameters))
- (display-buffer (gdb-get-buffer-create 'gdb-stack-buffer))))
-
-(defvar gdb-frames-mode-map
- (let ((map (make-sparse-keymap)))
- (suppress-keymap map)
- (define-key map "q" 'kill-this-buffer)
- (define-key map "\r" 'gdb-frames-select)
- (define-key map "F" 'gdb-frames-force-update)
- (define-key map [mouse-2] 'gdb-frames-select)
- (define-key map [follow-link] 'mouse-face)
- map))
-
-(declare-function gdbmi-invalidate-frames "ext:gdb-mi" nil t)
-
-(defun gdb-frames-force-update ()
- "Force update of call stack.
-Use when the displayed call stack gets out of sync with the
-actual one, e.g after using the Gdb command \"return\" or setting
-$pc directly from the GUD buffer. This command isn't normally needed."
- (interactive)
- (setq gdb-stack-update t)
- (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
- (gdb-invalidate-frames)
- (gdbmi-invalidate-frames)))
-
-(defun gdb-frames-mode ()
- "Major mode for gdb call stack.
-
-\\{gdb-frames-mode-map}"
- (kill-all-local-variables)
- (setq major-mode 'gdb-frames-mode)
- (setq mode-name "Frames")
- (setq gdb-stack-position nil)
- (add-to-list 'overlay-arrow-variable-list 'gdb-stack-position)
- (setq truncate-lines t) ;; Make it easier to see overlay arrow.
- (setq buffer-read-only t)
- (buffer-disable-undo)
- (gdb-thread-identification)
- (use-local-map gdb-frames-mode-map)
- (run-mode-hooks 'gdb-frames-mode-hook)
- (setq gdb-stack-update t)
- (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
- 'gdb-invalidate-frames
- 'gdbmi-invalidate-frames))
-
-(defun gdb-get-frame-number ()
- (save-excursion
- (end-of-line)
- (let* ((start (line-beginning-position))
- (pos (re-search-backward "^#*\\([0-9]+\\)" start t))
- (n (or (and pos (match-string 1)) "0")))
- n)))
-
-(defun gdb-frames-select (&optional event)
- "Select the frame and display the relevant source."
- (interactive (list last-input-event))
- (if event (posn-set-point (event-end event)))
- (if (get-text-property (point) 'gdb-max-frames)
- (progn
- (message-box "After setting gdb-max-frames, you need to enter\n\
-another GDB command e.g pwd, to see new frames")
- (customize-variable-other-window 'gdb-max-frames))
- (gdb-enqueue-input
- (list (concat gdb-server-prefix "frame "
- (gdb-get-frame-number) "\n") 'ignore))))
-
-
-;; Threads buffer. This displays a selectable thread list.
-;;
-(gdb-set-buffer-rules 'gdb-threads-buffer
- 'gdb-threads-buffer-name
- 'gdb-threads-mode)
-
-(def-gdb-auto-updated-buffer gdb-threads-buffer
- gdb-invalidate-threads
- (concat gdb-server-prefix "info threads\n")
- gdb-info-threads-handler
- gdb-info-threads-custom)
-
-(defun gdb-info-threads-custom ()
- (with-current-buffer (gdb-get-buffer 'gdb-threads-buffer)
- (let ((buffer-read-only nil))
- (save-excursion
- (goto-char (point-min))
- (if (re-search-forward "\\* \\([0-9]+\\)" nil t)
- (setq gdb-thread-indicator
- (propertize (concat " [" (match-string 1) "]")
- ; FIXME: this help-echo doesn't work
- 'help-echo "thread id")))
- (goto-char (point-min))
- (while (< (point) (point-max))
- (unless (looking-at "No ")
- (add-text-properties (line-beginning-position) (line-end-position)
- '(mouse-face highlight
- help-echo "mouse-2, RET: select thread")))
- (forward-line 1))))))
-
-(defun gdb-threads-buffer-name ()
- (with-current-buffer gud-comint-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-buffer-create 'gdb-threads-buffer) t))
-
-(defun gdb-frame-threads-buffer ()
- "Display IDs of currently known threads in a new frame."
- (interactive)
- (let ((special-display-regexps (append special-display-regexps '(".*")))
- (special-display-frame-alist gdb-frame-parameters))
- (display-buffer (gdb-get-buffer-create 'gdb-threads-buffer))))
-
-(defvar gdb-threads-mode-map
- (let ((map (make-sparse-keymap)))
- (suppress-keymap map)
- (define-key map "q" 'kill-this-buffer)
- (define-key map "\r" 'gdb-threads-select)
- (define-key map [mouse-2] 'gdb-threads-select)
- (define-key map [follow-link] 'mouse-face)
- map))
-
-(defvar gdb-threads-font-lock-keywords
- '((") +\\([^ ]+\\) (" (1 font-lock-function-name-face))
- ("in \\([^ ]+\\) (" (1 font-lock-function-name-face))
- ("\\(\\(\\sw\\|[_.]\\)+\\)=" (1 font-lock-variable-name-face)))
- "Font lock keywords used in `gdb-threads-mode'.")
-
-(defun gdb-threads-mode ()
- "Major mode for gdb threads.
-
-\\{gdb-threads-mode-map}"
- (kill-all-local-variables)
- (setq major-mode 'gdb-threads-mode)
- (setq mode-name "Threads")
- (setq buffer-read-only t)
- (buffer-disable-undo)
- (setq header-line-format gdb-breakpoints-header)
- (use-local-map gdb-threads-mode-map)
- (set (make-local-variable 'font-lock-defaults)
- '(gdb-threads-font-lock-keywords))
- (run-mode-hooks 'gdb-threads-mode-hook)
- ;; Force "info threads" onto queue.
- (lambda () (let ((gud-running nil)) (gdb-invalidate-threads))))
-
-(defun gdb-get-thread-number ()
- (save-excursion
- (re-search-backward "^\\s-*\\([0-9]*\\)" nil t)
- (match-string-no-properties 1)))
-
-(defun gdb-threads-select (&optional event)
- "Select the thread and display the relevant source."
- (interactive (list last-input-event))
- (if event (posn-set-point (event-end event)))
- (setq gdb-stack-update t)
- (gdb-enqueue-input
- (list (concat gdb-server-prefix "thread "
- (gdb-get-thread-number) "\n") 'ignore))
- (gud-display-frame))
-
-(defun gdb-thread-identification ()
- (setq mode-line-buffer-identification
- (list (car mode-line-buffer-identification)
- '(gdb-thread-indicator gdb-thread-indicator))))
-
-;; Registers buffer.
-;;
-(defcustom gdb-all-registers nil
- "Non-nil means include floating-point registers."
- :type 'boolean
- :group 'gdb
- :version "22.1")
-
-(gdb-set-buffer-rules 'gdb-registers-buffer
- 'gdb-registers-buffer-name
- 'gdb-registers-mode)
-
-(def-gdb-auto-updated-buffer gdb-registers-buffer
- gdb-invalidate-registers
- (concat
- gdb-server-prefix "info " (if gdb-all-registers "all-") "registers\n")
- gdb-info-registers-handler
- gdb-info-registers-custom)
-
-(defun gdb-info-registers-custom ()
- (with-current-buffer (gdb-get-buffer 'gdb-registers-buffer)
- (save-excursion
- (let ((buffer-read-only nil)
- start end)
- (goto-char (point-min))
- (while (< (point) (point-max))
- (setq start (line-beginning-position))
- (setq end (line-end-position))
- (when (looking-at "^[^ ]+")
- (unless (string-equal (match-string 0) "The")
- (put-text-property start (match-end 0)
- 'face font-lock-variable-name-face)
- (add-text-properties start end
- '(help-echo "mouse-2: edit value"
- mouse-face highlight))))
- (forward-line 1))))))
-
-(defun gdb-edit-register-value (&optional event)
- (interactive (list last-input-event))
- (save-excursion
- (if event (posn-set-point (event-end event)))
- (beginning-of-line)
- (let* ((register (current-word))
- (value (read-string (format "New value (%s): " register))))
- (gdb-enqueue-input
- (list (concat gdb-server-prefix "set $" register "=" value "\n")
- 'ignore)))))
-
-(defvar gdb-registers-mode-map
- (let ((map (make-sparse-keymap)))
- (suppress-keymap map)
- (define-key map "\r" 'gdb-edit-register-value)
- (define-key map [mouse-2] 'gdb-edit-register-value)
- (define-key map " " 'gdb-all-registers)
- (define-key map "q" 'kill-this-buffer)
- map))
-
-(defvar gdb-locals-header
- (list
- (gdb-propertize-header "Locals" gdb-locals-buffer
- nil nil mode-line)
- " "
- (gdb-propertize-header "Registers" gdb-registers-buffer
- "mouse-1: select" mode-line-highlight mode-line-inactive)))
-
-
-(defun gdb-registers-mode ()
- "Major mode for gdb registers.
-
-\\{gdb-registers-mode-map}"
- (kill-all-local-variables)
- (setq major-mode 'gdb-registers-mode)
- (setq mode-name "Registers")
- (setq header-line-format gdb-locals-header)
- (setq buffer-read-only t)
- (buffer-disable-undo)
- (gdb-thread-identification)
- (use-local-map gdb-registers-mode-map)
- (run-mode-hooks 'gdb-registers-mode-hook)
- (if (string-equal gdb-version "pre-6.4")
- (progn
- (if gdb-all-registers (setq mode-name "Registers:All"))
- 'gdb-invalidate-registers)
- 'gdb-invalidate-registers-1))
-
-(defun gdb-registers-buffer-name ()
- (with-current-buffer gud-comint-buffer
- (concat "*registers of " (gdb-get-target-string) "*")))
-
-(defun gdb-display-registers-buffer ()
- "Display integer register contents."
- (interactive)
- (gdb-display-buffer
- (gdb-get-buffer-create 'gdb-registers-buffer) t))
-
-(defun gdb-frame-registers-buffer ()
- "Display integer register contents in a new frame."
- (interactive)
- (let ((special-display-regexps (append special-display-regexps '(".*")))
- (special-display-frame-alist gdb-frame-parameters))
- (display-buffer (gdb-get-buffer-create 'gdb-registers-buffer))))
-
-(defun gdb-all-registers ()
- "Toggle the display of floating-point registers (pre GDB 6.4 only)."
- (interactive)
- (when (string-equal gdb-version "pre-6.4")
- (if gdb-all-registers
- (progn
- (setq gdb-all-registers nil)
- (with-current-buffer (gdb-get-buffer-create 'gdb-registers-buffer)
- (setq mode-name "Registers")))
- (setq gdb-all-registers t)
- (with-current-buffer (gdb-get-buffer-create 'gdb-registers-buffer)
- (setq mode-name "Registers:All")))
- (message (format "Display of floating-point registers %sabled"
- (if gdb-all-registers "en" "dis")))
- (gdb-invalidate-registers)))
-
-
-;; Memory buffer.
-;;
-(defcustom gdb-memory-repeat-count 32
- "Number of data items in memory window."
- :type 'integer
- :group 'gdb
- :version "22.1")
-
-(defcustom gdb-memory-format "x"
- "Display format of data items in memory window."
- :type '(choice (const :tag "Hexadecimal" "x")
- (const :tag "Signed decimal" "d")
- (const :tag "Unsigned decimal" "u")
- (const :tag "Octal" "o")
- (const :tag "Binary" "t"))
- :group 'gdb
- :version "22.1")
-
-(defcustom gdb-memory-unit "w"
- "Unit size of data items in memory window."
- :type '(choice (const :tag "Byte" "b")
- (const :tag "Halfword" "h")
- (const :tag "Word" "w")
- (const :tag "Giant word" "g"))
- :group 'gdb
- :version "22.1")
-
-(gdb-set-buffer-rules 'gdb-memory-buffer
- 'gdb-memory-buffer-name
- 'gdb-memory-mode)
-
-(def-gdb-auto-updated-buffer gdb-memory-buffer
- gdb-invalidate-memory
- (concat gdb-server-prefix "x/" (number-to-string gdb-memory-repeat-count)
- gdb-memory-format gdb-memory-unit " " gdb-memory-address "\n")
- gdb-read-memory-handler
- gdb-read-memory-custom)
-
-(defun gdb-read-memory-custom ()
- (save-excursion
- (goto-char (point-min))
- (if (looking-at "0x[[:xdigit:]]+")
- (setq gdb-memory-address (match-string 0)))))
-
-(defvar gdb-memory-mode-map
- (let ((map (make-sparse-keymap)))
- (suppress-keymap map)
- (define-key map "S" 'gdb-memory-set-address)
- (define-key map "N" 'gdb-memory-set-repeat-count)
- (define-key map "q" 'kill-this-buffer)
- map))
-
-(defun gdb-memory-set-address (&optional event)
- "Set the start memory address."
- (interactive)
- (let ((arg (read-from-minibuffer "Start address: ")))
- (setq gdb-memory-address arg))
- (gdb-invalidate-memory))
-
-(defun gdb-memory-set-repeat-count (&optional event)
- "Set the number of data items in memory window."
- (interactive)
- (let* ((arg (read-from-minibuffer "Repeat count: "))
- (count (string-to-number arg)))
- (if (<= count 0)
- (error "Positive numbers only")
- (customize-set-variable 'gdb-memory-repeat-count count)
- (gdb-invalidate-memory))))
-
-(defun gdb-memory-format-binary ()
- "Set the display format to binary."
- (interactive)
- (customize-set-variable 'gdb-memory-format "t")
- (gdb-invalidate-memory))
-
-(defun gdb-memory-format-octal ()
- "Set the display format to octal."
- (interactive)
- (customize-set-variable 'gdb-memory-format "o")
- (gdb-invalidate-memory))
-
-(defun gdb-memory-format-unsigned ()
- "Set the display format to unsigned decimal."
- (interactive)
- (customize-set-variable 'gdb-memory-format "u")
- (gdb-invalidate-memory))
-
-(defun gdb-memory-format-signed ()
- "Set the display format to decimal."
- (interactive)
- (customize-set-variable 'gdb-memory-format "d")
- (gdb-invalidate-memory))
-
-(defun gdb-memory-format-hexadecimal ()
- "Set the display format to hexadecimal."
- (interactive)
- (customize-set-variable 'gdb-memory-format "x")
- (gdb-invalidate-memory))
-
-(defvar gdb-memory-format-map
- (let ((map (make-sparse-keymap)))
- (define-key map [header-line down-mouse-3] 'gdb-memory-format-menu-1)
- map)
- "Keymap to select format in the header line.")
-
-(defvar gdb-memory-format-menu (make-sparse-keymap "Format")
- "Menu of display formats in the header line.")
-
-(define-key gdb-memory-format-menu [binary]
- '(menu-item "Binary" gdb-memory-format-binary
- :button (:radio . (equal gdb-memory-format "t"))))
-(define-key gdb-memory-format-menu [octal]
- '(menu-item "Octal" gdb-memory-format-octal
- :button (:radio . (equal gdb-memory-format "o"))))
-(define-key gdb-memory-format-menu [unsigned]
- '(menu-item "Unsigned Decimal" gdb-memory-format-unsigned
- :button (:radio . (equal gdb-memory-format "u"))))
-(define-key gdb-memory-format-menu [signed]
- '(menu-item "Signed Decimal" gdb-memory-format-signed
- :button (:radio . (equal gdb-memory-format "d"))))
-(define-key gdb-memory-format-menu [hexadecimal]
- '(menu-item "Hexadecimal" gdb-memory-format-hexadecimal
- :button (:radio . (equal gdb-memory-format "x"))))
-
-(defun gdb-memory-format-menu (event)
- (interactive "@e")
- (x-popup-menu event gdb-memory-format-menu))
-
-(defun gdb-memory-format-menu-1 (event)
- (interactive "e")
- (save-selected-window
- (select-window (posn-window (event-start event)))
- (let* ((selection (gdb-memory-format-menu event))
- (binding (and selection (lookup-key gdb-memory-format-menu
- (vector (car selection))))))
- (if binding (call-interactively binding)))))
-
-(defun gdb-memory-unit-giant ()
- "Set the unit size to giant words (eight bytes)."
- (interactive)
- (customize-set-variable 'gdb-memory-unit "g")
- (gdb-invalidate-memory))
-
-(defun gdb-memory-unit-word ()
- "Set the unit size to words (four bytes)."
- (interactive)
- (customize-set-variable 'gdb-memory-unit "w")
- (gdb-invalidate-memory))
-
-(defun gdb-memory-unit-halfword ()
- "Set the unit size to halfwords (two bytes)."
- (interactive)
- (customize-set-variable 'gdb-memory-unit "h")
- (gdb-invalidate-memory))
-
-(defun gdb-memory-unit-byte ()
- "Set the unit size to bytes."
- (interactive)
- (customize-set-variable 'gdb-memory-unit "b")
- (gdb-invalidate-memory))
-
-(defvar gdb-memory-unit-map
- (let ((map (make-sparse-keymap)))
- (define-key map [header-line down-mouse-3] 'gdb-memory-unit-menu-1)
- map)
- "Keymap to select units in the header line.")
-
-(defvar gdb-memory-unit-menu (make-sparse-keymap "Unit")
- "Menu of units in the header line.")
-
-(define-key gdb-memory-unit-menu [giantwords]
- '(menu-item "Giant words" gdb-memory-unit-giant
- :button (:radio . (equal gdb-memory-unit "g"))))
-(define-key gdb-memory-unit-menu [words]
- '(menu-item "Words" gdb-memory-unit-word
- :button (:radio . (equal gdb-memory-unit "w"))))
-(define-key gdb-memory-unit-menu [halfwords]
- '(menu-item "Halfwords" gdb-memory-unit-halfword
- :button (:radio . (equal gdb-memory-unit "h"))))
-(define-key gdb-memory-unit-menu [bytes]
- '(menu-item "Bytes" gdb-memory-unit-byte
- :button (:radio . (equal gdb-memory-unit "b"))))
-
-(defun gdb-memory-unit-menu (event)
- (interactive "@e")
- (x-popup-menu event gdb-memory-unit-menu))
-
-(defun gdb-memory-unit-menu-1 (event)
- (interactive "e")
- (save-selected-window
- (select-window (posn-window (event-start event)))
- (let* ((selection (gdb-memory-unit-menu event))
- (binding (and selection (lookup-key gdb-memory-unit-menu
- (vector (car selection))))))
- (if binding (call-interactively binding)))))
-
-(defvar gdb-memory-font-lock-keywords
- '(;; <__function.name+n>
- ("<\\(\\(\\sw\\|[_.]\\)+\\)\\(\\+[0-9]+\\)?>" (1 font-lock-function-name-face))
- )
- "Font lock keywords used in `gdb-memory-mode'.")
-
-(defun gdb-memory-mode ()
- "Major mode for examining memory.
-
-\\{gdb-memory-mode-map}"
- (kill-all-local-variables)
- (setq major-mode 'gdb-memory-mode)
- (setq mode-name "Memory")
- (setq buffer-read-only t)
- (buffer-disable-undo)
- (use-local-map gdb-memory-mode-map)
- (setq header-line-format
- '(:eval
- (concat
- "Start address["
- (propertize
- "-"
- 'face font-lock-warning-face
- 'help-echo "mouse-1: decrement address"
- 'mouse-face 'mode-line-highlight
- 'local-map
- (gdb-make-header-line-mouse-map
- 'mouse-1
- (lambda () (interactive)
- (let ((gdb-memory-address
- ;; Let GDB do the arithmetic.
- (concat
- gdb-memory-address " - "
- (number-to-string
- (* gdb-memory-repeat-count
- (cond ((string= gdb-memory-unit "b") 1)
- ((string= gdb-memory-unit "h") 2)
- ((string= gdb-memory-unit "w") 4)
- ((string= gdb-memory-unit "g") 8)))))))
- (gdb-invalidate-memory)))))
- "|"
- (propertize "+"
- 'face font-lock-warning-face
- 'help-echo "mouse-1: increment address"
- 'mouse-face 'mode-line-highlight
- 'local-map (gdb-make-header-line-mouse-map
- 'mouse-1
- (lambda () (interactive)
- (let ((gdb-memory-address nil))
- (gdb-invalidate-memory)))))
- "]: "
- (propertize gdb-memory-address
- 'face font-lock-warning-face
- 'help-echo "mouse-1: set start address"
- 'mouse-face 'mode-line-highlight
- 'local-map (gdb-make-header-line-mouse-map
- 'mouse-1
- #'gdb-memory-set-address))
- " Repeat Count: "
- (propertize (number-to-string gdb-memory-repeat-count)
- 'face font-lock-warning-face
- 'help-echo "mouse-1: set repeat count"
- 'mouse-face 'mode-line-highlight
- 'local-map (gdb-make-header-line-mouse-map
- 'mouse-1
- #'gdb-memory-set-repeat-count))
- " Display Format: "
- (propertize gdb-memory-format
- 'face font-lock-warning-face
- 'help-echo "mouse-3: select display format"
- 'mouse-face 'mode-line-highlight
- 'local-map gdb-memory-format-map)
- " Unit Size: "
- (propertize gdb-memory-unit
- 'face font-lock-warning-face
- 'help-echo "mouse-3: select unit size"
- 'mouse-face 'mode-line-highlight
- 'local-map gdb-memory-unit-map))))
- (set (make-local-variable 'font-lock-defaults)
- '(gdb-memory-font-lock-keywords))
- (run-mode-hooks 'gdb-memory-mode-hook)
- 'gdb-invalidate-memory)
-
-(defun gdb-memory-buffer-name ()
- (with-current-buffer gud-comint-buffer
- (concat "*memory of " (gdb-get-target-string) "*")))
-
-(defun gdb-display-memory-buffer ()
- "Display memory contents."
- (interactive)
- (gdb-display-buffer
- (gdb-get-buffer-create 'gdb-memory-buffer) t))
-
-(defun gdb-frame-memory-buffer ()
- "Display memory contents in a new frame."
- (interactive)
- (let* ((special-display-regexps (append special-display-regexps '(".*")))
- (special-display-frame-alist
- (cons '(left-fringe . 0)
- (cons '(right-fringe . 0)
- (cons '(width . 83) gdb-frame-parameters)))))
- (display-buffer (gdb-get-buffer-create 'gdb-memory-buffer))))
-
-
-;; Locals buffer.
-;;
-(gdb-set-buffer-rules 'gdb-locals-buffer
- 'gdb-locals-buffer-name
- 'gdb-locals-mode)
-
-(def-gdb-auto-update-trigger gdb-invalidate-locals
- (gdb-get-buffer 'gdb-locals-buffer)
- "server info locals\n"
- gdb-info-locals-handler)
-
-(defvar gdb-locals-watch-map
- (let ((map (make-sparse-keymap)))
- (suppress-keymap map)
- (define-key map "\r" (lambda () (interactive)
- (beginning-of-line)
- (gud-watch)))
- (define-key map [mouse-2] (lambda (event) (interactive "e")
- (mouse-set-point event)
- (beginning-of-line)
- (gud-watch)))
- map)
- "Keymap to create watch expression of a complex data type local variable.")
-
-(defconst gdb-struct-string
- (concat (propertize "[struct/union]"
- 'mouse-face 'highlight
- 'help-echo "mouse-2: create watch expression"
- 'local-map gdb-locals-watch-map) "\n"))
-
-(defconst gdb-array-string
- (concat " " (propertize "[array]"
- 'mouse-face 'highlight
- 'help-echo "mouse-2: create watch expression"
- 'local-map gdb-locals-watch-map) "\n"))
-
-;; Abbreviate for arrays and structures.
-;; These can be expanded using gud-display.
-(defun gdb-info-locals-handler ()
- (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))
- ;; Need this in case "set print pretty" is on.
- (while (re-search-forward "^[ }].*\n" nil t)
- (replace-match "" nil nil))
- (goto-char (point-min))
- (while (re-search-forward "{\\(.*=.*\n\\|\n\\)" nil t)
- (replace-match gdb-struct-string nil nil))
- (goto-char (point-min))
- (while (re-search-forward "\\s-*{[^.].*\n" nil t)
- (replace-match gdb-array-string nil nil))))
- (let ((buf (gdb-get-buffer 'gdb-locals-buffer)))
- (and buf
- (with-current-buffer buf
- (let* ((window (get-buffer-window buf 0))
- (start (window-start window))
- (p (window-point window))
- (buffer-read-only nil))
- (erase-buffer)
- (insert-buffer-substring (gdb-get-buffer-create
- 'gdb-partial-output-buffer))
- (set-window-start window start)
- (set-window-point window p)))))
- (run-hooks 'gdb-info-locals-hook))
-
-(defvar gdb-locals-mode-map
- (let ((map (make-sparse-keymap)))
- (suppress-keymap map)
- (define-key map "q" 'kill-this-buffer)
- map))
-
-(defun gdb-locals-mode ()
- "Major mode for gdb locals.
-
-\\{gdb-locals-mode-map}"
- (kill-all-local-variables)
- (setq major-mode 'gdb-locals-mode)
- (setq mode-name (concat "Locals:" gdb-selected-frame))
- (use-local-map gdb-locals-mode-map)
- (setq buffer-read-only t)
- (buffer-disable-undo)
- (setq header-line-format gdb-locals-header)
- (gdb-thread-identification)
- (set (make-local-variable 'font-lock-defaults)
- '(gdb-locals-font-lock-keywords))
- (run-mode-hooks 'gdb-locals-mode-hook)
- (if (and (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
- (string-equal gdb-version "pre-6.4"))
- 'gdb-invalidate-locals
- 'gdb-invalidate-locals-1))
-
-(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-buffer-create 'gdb-locals-buffer) t))
-
-(defun gdb-frame-locals-buffer ()
- "Display local variables of current stack and their values in a new frame."
- (interactive)
- (let ((special-display-regexps (append special-display-regexps '(".*")))
- (special-display-frame-alist gdb-frame-parameters))
- (display-buffer (gdb-get-buffer-create 'gdb-locals-buffer))))
-
-
-;;;; Window management
-(defun gdb-display-buffer (buf dedicated &optional frame)
- (let ((answer (get-buffer-window buf (or frame 0))))
- (if answer
- (display-buffer buf nil (or frame 0)) ;Deiconify the frame if necessary.
- (let ((window (get-lru-window)))
- (if (memq (buffer-local-value 'gud-minor-mode (window-buffer window))
- '(gdba gdbmi))
- (let* ((largest (get-largest-window))
- (cur-size (window-height largest)))
- (setq answer (split-window largest))
- (set-window-buffer answer buf)
- (set-window-dedicated-p answer dedicated)
- answer)
- (set-window-buffer window buf)
- window)))))
-
-
-;;; Shared keymap initialization:
-
-(let ((menu (make-sparse-keymap "GDB-Windows")))
- (define-key gud-menu-map [displays]
- `(menu-item "GDB-Windows" ,menu
- :help "Open a GDB-UI buffer in a new window."
- :visible (memq gud-minor-mode '(gdbmi gdba))))
- (define-key menu [gdb] '("Gdb" . gdb-display-gdb-buffer))
- (define-key menu [threads] '("Threads" . gdb-display-threads-buffer))
- (define-key menu [inferior]
- '(menu-item "Separate IO" gdb-display-separate-io-buffer
- :enable gdb-use-separate-io-buffer))
- (define-key menu [memory] '("Memory" . gdb-display-memory-buffer))
- (define-key menu [registers] '("Registers" . gdb-display-registers-buffer))
- (define-key menu [disassembly]
- '("Disassembly" . gdb-display-assembler-buffer))
- (define-key menu [breakpoints]
- '("Breakpoints" . gdb-display-breakpoints-buffer))
- (define-key menu [locals] '("Locals" . gdb-display-locals-buffer))
- (define-key menu [frames] '("Stack" . gdb-display-stack-buffer)))
-
-(let ((menu (make-sparse-keymap "GDB-Frames")))
- (define-key gud-menu-map [frames]
- `(menu-item "GDB-Frames" ,menu
- :help "Open a GDB-UI buffer in a new frame."
- :visible (memq gud-minor-mode '(gdbmi gdba))))
- (define-key menu [gdb] '("Gdb" . gdb-frame-gdb-buffer))
- (define-key menu [threads] '("Threads" . gdb-frame-threads-buffer))
- (define-key menu [memory] '("Memory" . gdb-frame-memory-buffer))
- (define-key menu [inferior]
- '(menu-item "Separate IO" gdb-frame-separate-io-buffer
- :enable gdb-use-separate-io-buffer))
- (define-key menu [registers] '("Registers" . gdb-frame-registers-buffer))
- (define-key menu [disassembly] '("Disassembly" . gdb-frame-assembler-buffer))
- (define-key menu [breakpoints]
- '("Breakpoints" . gdb-frame-breakpoints-buffer))
- (define-key menu [locals] '("Locals" . gdb-frame-locals-buffer))
- (define-key menu [frames] '("Stack" . gdb-frame-stack-buffer)))
-
-(let ((menu (make-sparse-keymap "GDB-UI/MI")))
- (define-key gud-menu-map [ui]
- `(menu-item (if (eq gud-minor-mode 'gdba) "GDB-UI" "GDB-MI")
- ,menu :visible (memq gud-minor-mode '(gdbmi gdba))))
- (define-key menu [gdb-customize]
- '(menu-item "Customize" (lambda () (interactive) (customize-group 'gdb))
- :help "Customize Gdb Graphical Mode options."))
- (define-key menu [gdb-find-source-frame]
- '(menu-item "Look For Source Frame" gdb-find-source-frame
- :visible (eq gud-minor-mode 'gdba)
- :help "Toggle looking for source frame further up call stack."
- :button (:toggle . gdb-find-source-frame)))
- (define-key menu [gdb-use-separate-io]
- '(menu-item "Separate IO" gdb-use-separate-io-buffer
- :visible (eq gud-minor-mode 'gdba)
- :help "Toggle separate IO for debugged program."
- :button (:toggle . gdb-use-separate-io-buffer)))
- (define-key menu [gdb-many-windows]
- '(menu-item "Display Other Windows" gdb-many-windows
- :help "Toggle display of locals, stack and breakpoint information."
- :button (:toggle . gdb-many-windows)))
- (define-key menu [gdb-restore-windows]
- '(menu-item "Restore Window Layout" gdb-restore-windows
- :help "Restore standard layout for debug session.")))
-
-(defun gdb-frame-gdb-buffer ()
- "Display GUD buffer in a new frame."
- (interactive)
- (let ((special-display-regexps (append special-display-regexps '(".*")))
- (special-display-frame-alist
- (remove '(menu-bar-lines) (remove '(tool-bar-lines)
- gdb-frame-parameters)))
- (same-window-regexps nil))
- (display-buffer gud-comint-buffer)))
-
-(defun gdb-display-gdb-buffer ()
- "Display GUD buffer."
- (interactive)
- (let ((same-window-regexps nil))
- (select-window (display-buffer gud-comint-buffer nil 0))))
-
-(defun gdb-set-window-buffer (name)
- (set-window-buffer (selected-window) (get-buffer name))
- (set-window-dedicated-p (selected-window) t))
-
-(defun gdb-setup-windows ()
- "Layout the window pattern for `gdb-many-windows'."
- (gdb-display-locals-buffer)
- (gdb-display-stack-buffer)
- (delete-other-windows)
- (gdb-display-breakpoints-buffer)
- (delete-other-windows)
- ; Don't dedicate.
- (pop-to-buffer gud-comint-buffer)
- (split-window nil ( / ( * (window-height) 3) 4))
- (split-window nil ( / (window-height) 3))
- (split-window-horizontally)
- (other-window 1)
- (gdb-set-window-buffer (gdb-locals-buffer-name))
- (other-window 1)
- (switch-to-buffer
- (if gud-last-last-frame
- (gud-find-file (car gud-last-last-frame))
- (if gdb-main-file
- (gud-find-file gdb-main-file)
- ;; Put buffer list in window if we
- ;; can't find a source file.
- (list-buffers-noselect))))
- (setq gdb-source-window (selected-window))
- (when gdb-use-separate-io-buffer
- (split-window-horizontally)
- (other-window 1)
- (gdb-set-window-buffer
- (gdb-get-buffer-create 'gdb-inferior-io)))
- (other-window 1)
- (gdb-set-window-buffer (gdb-stack-buffer-name))
- (split-window-horizontally)
- (other-window 1)
- (gdb-set-window-buffer (gdb-breakpoints-buffer-name))
- (other-window 1))
-
-(defun gdb-restore-windows ()
- "Restore the basic arrangement of windows used by gdba.
-This arrangement depends on the value of `gdb-many-windows'."
- (interactive)
- (pop-to-buffer gud-comint-buffer) ;Select the right window and frame.
- (delete-other-windows)
- (if gdb-many-windows
- (gdb-setup-windows)
- (when (or gud-last-last-frame gdb-show-main)
- (split-window)
- (other-window 1)
- (switch-to-buffer
- (if gud-last-last-frame
- (gud-find-file (car gud-last-last-frame))
- (gud-find-file gdb-main-file)))
- (setq gdb-source-window (selected-window))
- (other-window 1))))
-
-(defun gdb-reset ()
- "Exit a debugging session cleanly.
-Kills the gdb buffers, and resets variables and the source buffers."
- (dolist (buffer (buffer-list))
- (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)
- (kill-local-variable 'gdb-define-alist))))))
- (setq gdb-overlay-arrow-position nil)
- (setq overlay-arrow-variable-list
- (delq 'gdb-overlay-arrow-position overlay-arrow-variable-list))
- (setq fringe-indicator-alist '((overlay-arrow . right-triangle)))
- (setq gdb-stack-position nil)
- (setq overlay-arrow-variable-list
- (delq 'gdb-stack-position overlay-arrow-variable-list))
- (if (boundp 'speedbar-frame) (speedbar-timer-fn))
- (setq gud-running nil)
- (setq gdb-active-process nil)
- (setq gdb-var-list nil)
- (remove-hook 'after-save-hook 'gdb-create-define-alist t))
-
-(defun gdb-source-info ()
- "Find the source file where the program starts and display it with related
-buffers."
- (goto-char (point-min))
- (if (and (search-forward "Located in " nil t)
- (looking-at "\\S-+"))
- (setq gdb-main-file (match-string 0)))
- (goto-char (point-min))
- (if (search-forward "Includes preprocessor macro info." nil t)
- (setq gdb-macro-info t))
- (if gdb-many-windows
- (gdb-setup-windows)
- (gdb-get-buffer-create 'gdb-breakpoints-buffer)
- (if (and gdb-show-main gdb-main-file)
- (let ((pop-up-windows t))
- (display-buffer (gud-find-file gdb-main-file)))))
- (setq gdb-ready t))
-
-(defun gdb-get-location (bptno line flag)
- "Find the directory containing the relevant source file.
-Put in buffer and place breakpoint icon."
- (goto-char (point-min))
- (catch 'file-not-found
- (if (search-forward "Located in " nil t)
- (when (looking-at "\\S-+")
- (delete (cons bptno "File not found") gdb-location-alist)
- (push (cons bptno (match-string 0)) gdb-location-alist))
- (gdb-resync)
- (unless (assoc bptno gdb-location-alist)
- (push (cons bptno "File not found") gdb-location-alist)
- (message-box "Cannot find source file for breakpoint location.\n\
-Add directory to search path for source files using the GDB command, dir."))
- (throw 'file-not-found nil))
- (with-current-buffer
- (find-file-noselect (match-string 0))
- (gdb-init-buffer)
- ;; only want one breakpoint icon at each location
- (save-excursion
- (goto-char (point-min))
- (forward-line (1- (string-to-number line)))
- (gdb-put-breakpoint-icon (eq flag ?y) bptno)))))
-
-(add-hook 'find-file-hook 'gdb-find-file-hook)
-
-(defun gdb-find-file-hook ()
- "Set up buffer for debugging if file is part of the source code
-of the current session."
- (if (and (buffer-name gud-comint-buffer)
- ;; in case gud or gdb-ui is just loaded
- gud-comint-buffer
- (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
- '(gdba gdbmi)))
- ;;Pre GDB 6.3 "info sources" doesn't give absolute file name.
- (if (member (if (string-equal gdb-version "pre-6.4")
- (file-name-nondirectory buffer-file-name)
- buffer-file-name)
- gdb-source-file-list)
- (with-current-buffer (find-buffer-visiting buffer-file-name)
- (gdb-init-buffer)))))
-
-;;from put-image
-(defun gdb-put-string (putstring pos &optional dprop &rest sprops)
- "Put string PUTSTRING in front of POS in the current buffer.
-PUTSTRING is displayed by putting an overlay into the current buffer with a
-`before-string' string that has a `display' property whose value is
-PUTSTRING."
- (let ((string (make-string 1 ?x))
- (buffer (current-buffer)))
- (setq putstring (copy-sequence putstring))
- (let ((overlay (make-overlay pos pos buffer))
- (prop (or dprop
- (list (list 'margin 'left-margin) putstring))))
- (put-text-property 0 1 'display prop string)
- (if sprops
- (add-text-properties 0 1 sprops string))
- (overlay-put overlay 'put-break t)
- (overlay-put overlay 'before-string string))))
-
-;;from remove-images
-(defun gdb-remove-strings (start end &optional buffer)
- "Remove strings between START and END in BUFFER.
-Remove only strings that were put in BUFFER with calls to `gdb-put-string'.
-BUFFER nil or omitted means use the current buffer."
- (unless buffer
- (setq buffer (current-buffer)))
- (dolist (overlay (overlays-in start end))
- (when (overlay-get overlay 'put-break)
- (delete-overlay overlay))))
-
-(defun gdb-put-breakpoint-icon (enabled bptno)
- (if (string-match "[0-9+]+\\." bptno)
- (setq enabled gdb-parent-bptno-enabled))
- (let ((start (- (line-beginning-position) 1))
- (end (+ (line-end-position) 1))
- (putstring (if enabled "B" "b"))
- (source-window (get-buffer-window (current-buffer) 0)))
- (add-text-properties
- 0 1 '(help-echo "mouse-1: clear bkpt, mouse-3: enable/disable bkpt")
- putstring)
- (if enabled
- (add-text-properties
- 0 1 `(gdb-bptno ,bptno gdb-enabled t) putstring)
- (add-text-properties
- 0 1 `(gdb-bptno ,bptno gdb-enabled nil) putstring))
- (gdb-remove-breakpoint-icons start end)
- (if (display-images-p)
- (if (>= (or left-fringe-width
- (if source-window (car (window-fringes source-window)))
- gdb-buffer-fringe-width) 8)
- (gdb-put-string
- nil (1+ start)
- `(left-fringe breakpoint
- ,(if enabled
- 'breakpoint-enabled
- 'breakpoint-disabled))
- 'gdb-bptno bptno
- 'gdb-enabled enabled)
- (when (< left-margin-width 2)
- (save-current-buffer
- (setq left-margin-width 2)
- (if source-window
- (set-window-margins
- source-window
- left-margin-width right-margin-width))))
- (put-image
- (if enabled
- (or breakpoint-enabled-icon
- (setq breakpoint-enabled-icon
- (find-image `((:type xpm :data
- ,breakpoint-xpm-data
- :ascent 100 :pointer hand)
- (:type pbm :data
- ,breakpoint-enabled-pbm-data
- :ascent 100 :pointer hand)))))
- (or breakpoint-disabled-icon
- (setq breakpoint-disabled-icon
- (find-image `((:type xpm :data
- ,breakpoint-xpm-data
- :conversion disabled
- :ascent 100 :pointer hand)
- (:type pbm :data
- ,breakpoint-disabled-pbm-data
- :ascent 100 :pointer hand))))))
- (+ start 1)
- putstring
- 'left-margin))
- (when (< left-margin-width 2)
- (save-current-buffer
- (setq left-margin-width 2)
- (let ((window (get-buffer-window (current-buffer) 0)))
- (if window
- (set-window-margins
- window left-margin-width right-margin-width)))))
- (gdb-put-string
- (propertize putstring
- 'face (if enabled 'breakpoint-enabled 'breakpoint-disabled))
- (1+ start)))))
-
-(defun gdb-remove-breakpoint-icons (start end &optional remove-margin)
- (gdb-remove-strings start end)
- (if (display-images-p)
- (remove-images start end))
- (when remove-margin
- (setq left-margin-width 0)
- (let ((window (get-buffer-window (current-buffer) 0)))
- (if window
- (set-window-margins
- window left-margin-width right-margin-width)))))
-
-
-;;
-;; Assembler buffer.
-;;
-(gdb-set-buffer-rules 'gdb-assembler-buffer
- 'gdb-assembler-buffer-name
- 'gdb-assembler-mode)
-
-;; We can't use def-gdb-auto-update-handler because we don't want to use
-;; window-start but keep the overlay arrow/current line visible.
-(defun gdb-assembler-handler ()
- (setq gdb-pending-triggers
- (delq 'gdb-invalidate-assembler
- gdb-pending-triggers))
- (let ((buf (gdb-get-buffer 'gdb-partial-output-buffer)))
- (with-current-buffer buf
- (goto-char (point-min))
- ;; The disassemble command in GDB 7.1 onwards displays an overlay arrow.
- (while (re-search-forward "\\(^ 0x\\|=> 0x\\)" nil t)
- (replace-match "0x" nil nil))))
- (let ((buf (gdb-get-buffer 'gdb-assembler-buffer)))
- (and buf
- (with-current-buffer buf
- (let* ((window (get-buffer-window buf 0))
- (p (window-point window))
- (buffer-read-only nil))
- (erase-buffer)
- (insert-buffer-substring (gdb-get-buffer-create
- 'gdb-partial-output-buffer))
- (set-window-point window p)))))
- ;; put customisation here
- (gdb-assembler-custom))
-
-(defun gdb-assembler-custom ()
- (let ((buffer (gdb-get-buffer 'gdb-assembler-buffer))
- (pos 1) (address) (flag) (bptno))
- (with-current-buffer buffer
- (save-excursion
- (if (not (equal gdb-pc-address "main"))
- (progn
- (goto-char (point-min))
- (if (and gdb-pc-address
- (search-forward gdb-pc-address nil t))
- (progn
- (setq pos (point))
- (beginning-of-line)
- (setq fringe-indicator-alist
- (if (string-equal gdb-frame-number "0")
- nil
- '((overlay-arrow . hollow-right-triangle))))
- (or gdb-overlay-arrow-position
- (setq gdb-overlay-arrow-position (make-marker)))
- (set-marker gdb-overlay-arrow-position (point))))))
- ;; remove all breakpoint-icons in assembler buffer before updating.
- (gdb-remove-breakpoint-icons (point-min) (point-max))))
- (with-current-buffer (gdb-get-buffer 'gdb-breakpoints-buffer)
- (goto-char (point-min))
- (while (< (point) (- (point-max) 1))
- (forward-line 1)
- (when (looking-at
- "\\([0-9]+\\.?[0-9]*\\).*?\\s-+\\(.\\)\\s-+0x0*\\(\\S-+\\)")
- (setq bptno (match-string 1))
- (setq flag (char-after (match-beginning 2)))
- (setq address (match-string 3))
- (with-current-buffer buffer
- (save-excursion
- (goto-char (point-min))
- (if (re-search-forward (concat "^0x0*" address) nil t)
- (gdb-put-breakpoint-icon (eq flag ?y) bptno)))))))
- (if (not (equal gdb-pc-address "main"))
- (with-current-buffer buffer
- (set-window-point (get-buffer-window buffer 0) pos)))))
-
-(defvar gdb-assembler-mode-map
- (let ((map (make-sparse-keymap)))
- (suppress-keymap map)
- (define-key map "q" 'kill-this-buffer)
- map))
-
-(defvar gdb-assembler-font-lock-keywords
- '(;; <__function.name+n>
- ("<\\(\\(\\sw\\|[_.]\\)+\\)\\(\\+[0-9]+\\)?>"
- (1 font-lock-function-name-face))
- ;; 0xNNNNNNNN <__function.name+n>: opcode
- ("^0x[0-9a-f]+ \\(<\\(\\(\\sw\\|[_.]\\)+\\)\\+[0-9]+>\\)?:[ \t]+\\(\\sw+\\)"
- (4 font-lock-keyword-face))
- ;; %register(at least i386)
- ("%\\sw+" . font-lock-variable-name-face)
- ("^\\(Dump of assembler code for function\\) \\(.+\\):"
- (1 font-lock-comment-face)
- (2 font-lock-function-name-face))
- ("^\\(End of assembler dump\\.\\)" . font-lock-comment-face))
- "Font lock keywords used in `gdb-assembler-mode'.")
-
-(defun gdb-assembler-mode ()
- "Major mode for viewing code assembler.
-
-\\{gdb-assembler-mode-map}"
- (kill-all-local-variables)
- (setq major-mode 'gdb-assembler-mode)
- (setq mode-name (concat "Machine:" gdb-selected-frame))
- (setq gdb-overlay-arrow-position nil)
- (add-to-list 'overlay-arrow-variable-list 'gdb-overlay-arrow-position)
- (setq fringes-outside-margins t)
- (setq buffer-read-only t)
- (buffer-disable-undo)
- (gdb-thread-identification)
- (use-local-map gdb-assembler-mode-map)
- (gdb-invalidate-assembler)
- (set (make-local-variable 'font-lock-defaults)
- '(gdb-assembler-font-lock-keywords))
- (run-mode-hooks 'gdb-assembler-mode-hook)
- 'gdb-invalidate-assembler)
-
-(defun gdb-assembler-buffer-name ()
- (with-current-buffer gud-comint-buffer
- (concat "*disassembly of " (gdb-get-target-string) "*")))
-
-(defun gdb-display-assembler-buffer ()
- "Display disassembly view."
- (interactive)
- (setq gdb-previous-frame nil)
- (gdb-display-buffer
- (gdb-get-buffer-create 'gdb-assembler-buffer) t))
-
-(defun gdb-frame-assembler-buffer ()
- "Display disassembly view in a new frame."
- (interactive)
- (setq gdb-previous-frame nil)
- (let ((special-display-regexps (append special-display-regexps '(".*")))
- (special-display-frame-alist gdb-frame-parameters))
- (display-buffer (gdb-get-buffer-create 'gdb-assembler-buffer))))
-
-;; modified because if gdb-pc-address has changed value a new command
-;; must be enqueued to update the buffer with the new output
-(defun gdb-invalidate-assembler (&optional ignored)
- (if (gdb-get-buffer 'gdb-assembler-buffer)
- (progn
- (unless (and gdb-selected-frame
- (string-equal gdb-selected-frame gdb-previous-frame))
- (if (or (not (member 'gdb-invalidate-assembler
- gdb-pending-triggers))
- (not (equal (string-to-number gdb-pc-address)
- (string-to-number
- gdb-previous-frame-pc-address))))
- (progn
- ;; take previous disassemble command, if any, off the queue
- (with-current-buffer gud-comint-buffer
- (let ((queue gdb-input-queue))
- (dolist (item queue)
- (if (equal (cdr item) '(gdb-assembler-handler))
- (setq gdb-input-queue
- (delete item gdb-input-queue))))))
- (gdb-enqueue-input
- (list
- (concat gdb-server-prefix "disassemble " gdb-pc-address "\n")
- 'gdb-assembler-handler))
- (push 'gdb-invalidate-assembler gdb-pending-triggers)
- (setq gdb-previous-frame-pc-address gdb-pc-address)
- (setq gdb-previous-frame gdb-selected-frame)))))))
-
-(defun gdb-get-selected-frame ()
- (if (not (member 'gdb-get-selected-frame gdb-pending-triggers))
- (progn
- (if (string-equal gdb-version "pre-6.4")
- (gdb-enqueue-input
- (list (concat gdb-server-prefix "info frame\n")
- 'gdb-frame-handler))
- (gdb-enqueue-input
- (list "server interpreter mi -stack-info-frame\n"
- 'gdb-frame-handler-1)))
- (push 'gdb-get-selected-frame gdb-pending-triggers))))
-
-(defun gdb-frame-handler ()
- (setq gdb-pending-triggers
- (delq 'gdb-get-selected-frame gdb-pending-triggers))
- (goto-char (point-min))
- (when (re-search-forward
- "Stack level \\([0-9]+\\), frame at \\(0x[[:xdigit:]]+\\)" nil t)
- (setq gdb-frame-number (match-string 1))
- (setq gdb-frame-address (match-string 2)))
- (goto-char (point-min))
- (when (re-search-forward ".*=\\s-+\\(\\S-*\\)\\s-+in\\s-+\\(.*?\\)\
-\\(?: (\\(\\S-+?\\):[0-9]+?)\\)*; "
- nil t)
- (setq gdb-selected-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-selected-frame))))
- (if (gdb-get-buffer 'gdb-assembler-buffer)
- (with-current-buffer (gdb-get-buffer 'gdb-assembler-buffer)
- (setq mode-name (concat "Machine:" gdb-selected-frame))))
- (setq gdb-pc-address (match-string 1))
- (if (and (match-string 3) gud-overlay-arrow-position)
- (let ((buffer (marker-buffer gud-overlay-arrow-position))
- (position (marker-position gud-overlay-arrow-position)))
- (when (and buffer
- (string-equal (file-name-nondirectory
- (buffer-file-name buffer))
- (file-name-nondirectory (match-string 3))))
- (with-current-buffer buffer
- (setq fringe-indicator-alist
- (if (string-equal gdb-frame-number "0")
- nil
- '((overlay-arrow . hollow-right-triangle))))
- (set-marker gud-overlay-arrow-position position))))))
- (goto-char (point-min))
- (if (re-search-forward " source language \\(\\S-+\\)\." nil t)
- (setq gdb-current-language (match-string 1)))
- (gdb-invalidate-assembler))
-
-
-;; Code specific to GDB 6.4
-(defconst gdb-source-file-regexp-1 "fullname=\"\\(.*?\\)\"")
-
-(defun gdb-set-gud-minor-mode-existing-buffers-1 ()
- "Create list of source files for current GDB session.
-If buffers already exist for any of these files, `gud-minor-mode'
-is set in them."
- (goto-char (point-min))
- (while (re-search-forward gdb-source-file-regexp-1 nil t)
- (push (match-string 1) gdb-source-file-list))
- (dolist (buffer (buffer-list))
- (with-current-buffer buffer
- (when (member buffer-file-name gdb-source-file-list)
- (gdb-init-buffer))))
- (gdb-force-mode-line-update
- (propertize "ready" 'face font-lock-variable-name-face)))
-
-;; Used for -stack-info-frame but could be used for -stack-list-frames too.
-(defconst gdb-stack-list-frames-regexp
-".*?level=\"\\(.*?\\)\".*?,addr=\"\\(.*?\\)\".*?,func=\"\\(.*?\\)\",\
-\\(?:.*?file=\".*?\".*?,fullname=\"\\(.*?\\)\".*?,line=\"\\(.*?\\)\".*?}\\|\
-from=\"\\(.*?\\)\"\\)")
-
-(defun gdb-frame-handler-1 ()
- (setq gdb-pending-triggers
- (delq 'gdb-get-selected-frame gdb-pending-triggers))
- (goto-char (point-min))
- (when (re-search-forward gdb-stack-list-frames-regexp nil t)
- (setq gdb-frame-number (match-string 1))
- (setq gdb-pc-address (match-string 2))
- (setq gdb-selected-frame (match-string 3))
- (if (gdb-get-buffer 'gdb-locals-buffer)
- (with-current-buffer (gdb-get-buffer 'gdb-locals-buffer)
- (setq mode-name (concat "Locals:" gdb-selected-frame))))
- (if (gdb-get-buffer 'gdb-assembler-buffer)
- (with-current-buffer (gdb-get-buffer 'gdb-assembler-buffer)
- (setq mode-name (concat "Machine:" gdb-selected-frame)))))
- (if (and (match-string 4) (match-string 5) gud-overlay-arrow-position)
- (let ((buffer (marker-buffer gud-overlay-arrow-position))
- (position (marker-position gud-overlay-arrow-position)))
- (when (and buffer
- (string-equal (file-name-nondirectory
- (buffer-file-name buffer))
- (file-name-nondirectory (match-string 4))))
- (with-current-buffer buffer
- (setq fringe-indicator-alist
- (if (string-equal gdb-frame-number "0")
- nil
- '((overlay-arrow . hollow-right-triangle))))
- (set-marker gud-overlay-arrow-position position)))))
- (gdb-invalidate-assembler))
-
-; Uses "-var-list-children --all-values". Needs GDB 6.4 onwards.
-(defun gdb-var-list-children-1 (varnum)
- (gdb-enqueue-input
- (list
- (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
- (concat "server interpreter mi \"-var-list-children --all-values \\\""
- varnum "\\\"\"\n")
- (concat "-var-list-children --all-values \"" varnum "\"\n"))
- `(lambda () (gdb-var-list-children-handler-1 ,varnum)))))
-
-(defun gdb-var-list-children-handler-1 (varnum)
- (let* ((var-list nil)
- (output (bindat-get-field (gdb-json-partial-output "child")))
- (children (bindat-get-field output 'children)))
- (catch 'child-already-watched
- (dolist (var gdb-var-list)
- (if (string-equal varnum (car var))
- (progn
- ;; With dynamic varobjs numchild may have increased.
- (setcar (nthcdr 2 var) (bindat-get-field output 'numchild))
- (push var var-list)
- (dolist (child children)
- (let ((varchild (list (bindat-get-field child 'name)
- (bindat-get-field child 'exp)
- (bindat-get-field child 'numchild)
- (bindat-get-field child 'type)
- (bindat-get-field child 'value)
- nil
- (bindat-get-field child 'has_more))))
- (if (assoc (car varchild) gdb-var-list)
- (throw 'child-already-watched nil))
- (push varchild var-list))))
- (push var var-list)))
- (setq gdb-var-list (nreverse var-list))))
- (gdb-speedbar-update))
-
-; Uses "-var-update --all-values". Needs GDB 6.4 onwards.
-(defun gdb-var-update-1 ()
- (if (not (member 'gdb-var-update gdb-pending-triggers))
- (progn
- (gdb-enqueue-input
- (list
- (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
- "server interpreter mi \"-var-update --all-values *\"\n"
- "-var-update --all-values *\n")
- 'gdb-var-update-handler-1))
- (push 'gdb-var-update gdb-pending-triggers))))
-
-(defun gdb-var-update-handler-1 ()
- (let ((changelist (bindat-get-field (gdb-json-partial-output) 'changelist)))
- (dolist (var gdb-var-list)
- (setcar (nthcdr 5 var) nil))
- (let ((temp-var-list gdb-var-list))
- (dolist (change changelist)
- (let* ((varnum (bindat-get-field change 'name))
- (var (assoc varnum gdb-var-list))
- (new-num (bindat-get-field change 'new_num_children)))
- (when var
- (let ((scope (bindat-get-field change 'in_scope))
- (has-more (bindat-get-field change 'has_more)))
- (cond ((string-equal scope "false")
- (if gdb-delete-out-of-scope
- (gdb-var-delete-1 var varnum)
- (setcar (nthcdr 5 var) 'out-of-scope)))
- ((string-equal scope "true")
- (setcar (nthcdr 6 var) has-more)
- (when (and (or (not has-more)
- (string-equal has-more "0"))
- (not new-num)
- (string-equal (nth 2 var) "0"))
- (setcar (nthcdr 4 var)
- (bindat-get-field change 'value))
- (setcar (nthcdr 5 var) 'changed)))
- ((string-equal scope "invalid")
- (gdb-var-delete-1 var varnum)))))
- (let ((var-list nil) var1
- (children (bindat-get-field change 'new_children)))
- (if new-num
- (progn
- (setq var1 (pop temp-var-list))
- (while var1
- (if (string-equal varnum (car var1))
- (let ((new (string-to-number new-num))
- (previous (string-to-number (nth 2 var1))))
- (setcar (nthcdr 2 var1) new-num)
- (push var1 var-list)
- (cond ((> new previous)
- ;; Add new children to list.
- (dotimes (dummy previous)
- (push (pop temp-var-list) var-list))
- (dolist (child children)
- (let ((varchild
- (list (bindat-get-field child 'name)
- (bindat-get-field child 'exp)
- (bindat-get-field child 'numchild)
- (bindat-get-field child 'type)
- (bindat-get-field child 'value)
- 'changed
- (bindat-get-field child 'has_more))))
- (push varchild var-list))))
- ;; Remove deleted children from list.
- ((< new previous)
- (dotimes (dummy new)
- (push (pop temp-var-list) var-list))
- (dotimes (dummy (- previous new))
- (pop temp-var-list)))))
- (push var1 var-list))
- (setq var1 (pop temp-var-list)))
- (setq gdb-var-list (nreverse var-list)))))))))
- (setq gdb-pending-triggers
- (delq 'gdb-var-update gdb-pending-triggers))
- (gdb-speedbar-update))
-
-;; Registers buffer.
-;;
-(gdb-set-buffer-rules 'gdb-registers-buffer
- 'gdb-registers-buffer-name
- 'gdb-registers-mode)
-
-(def-gdb-auto-update-trigger gdb-invalidate-registers-1
- (gdb-get-buffer 'gdb-registers-buffer)
- (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
- "server interpreter mi \"-data-list-register-values x\"\n"
- "-data-list-register-values x\n")
- gdb-data-list-register-values-handler)
-
-(defconst gdb-data-list-register-values-regexp
- "{.*?number=\"\\(.*?\\)\".*?,value=\"\\(.*?\\)\".*?}")
-
-(defun gdb-data-list-register-values-handler ()
- (setq gdb-pending-triggers (delq 'gdb-invalidate-registers-1
- gdb-pending-triggers))
- (goto-char (point-min))
- (if (re-search-forward gdb-error-regexp nil t)
- (let ((err (match-string 1)))
- (with-current-buffer (gdb-get-buffer 'gdb-registers-buffer)
- (let ((buffer-read-only nil))
- (erase-buffer)
- (put-text-property 0 (length err) 'face font-lock-warning-face err)
- (insert err)
- (goto-char (point-min)))))
- (let ((register-list (reverse gdb-register-names))
- (register nil) (register-string nil) (register-values nil))
- (goto-char (point-min))
- (while (re-search-forward gdb-data-list-register-values-regexp nil t)
- (setq register (pop register-list))
- (setq register-string (concat register "\t" (match-string 2) "\n"))
- (if (member (match-string 1) gdb-changed-registers)
- (put-text-property 0 (length register-string)
- 'face 'font-lock-warning-face
- register-string))
- (setq register-values
- (concat register-values register-string)))
- (let ((buf (gdb-get-buffer 'gdb-registers-buffer)))
- (with-current-buffer buf
- (let* ((window (get-buffer-window buf 0))
- (start (window-start window))
- (p (if window (window-point window) (point)))
- (buffer-read-only nil))
- (erase-buffer)
- (insert register-values)
- (if window
- (progn
- (set-window-start window start)
- (set-window-point window p))
- (goto-char p)))))))
- (gdb-data-list-register-values-custom))
-
-(defun gdb-data-list-register-values-custom ()
- (with-current-buffer (gdb-get-buffer 'gdb-registers-buffer)
- (save-excursion
- (let ((buffer-read-only nil)
- start end)
- (goto-char (point-min))
- (while (< (point) (point-max))
- (setq start (line-beginning-position))
- (setq end (line-end-position))
- (when (looking-at "^[^\t]+")
- (unless (string-equal (match-string 0) "No registers.")
- (put-text-property start (match-end 0)
- 'face font-lock-variable-name-face)
- (add-text-properties start end
- '(help-echo "mouse-2: edit value"
- mouse-face highlight))))
- (forward-line 1))))))
-
-;; Needs GDB 6.4 onwards (used to fail with no stack).
-(defun gdb-get-changed-registers ()
- (if (and (gdb-get-buffer 'gdb-registers-buffer)
- (not (member 'gdb-get-changed-registers gdb-pending-triggers)))
- (progn
- (gdb-enqueue-input
- (list
- (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
- "server interpreter mi -data-list-changed-registers\n"
- "-data-list-changed-registers\n")
- 'gdb-get-changed-registers-handler))
- (push 'gdb-get-changed-registers gdb-pending-triggers))))
-
-(defconst gdb-data-list-register-names-regexp "\"\\(.*?\\)\"")
-
-(defun gdb-get-changed-registers-handler ()
- (setq gdb-pending-triggers
- (delq 'gdb-get-changed-registers gdb-pending-triggers))
- (setq gdb-changed-registers nil)
- (goto-char (point-min))
- (while (re-search-forward gdb-data-list-register-names-regexp nil t)
- (push (match-string 1) gdb-changed-registers)))
-
-
-;; Locals buffer.
-;;
-;; uses "-stack-list-locals --simple-values". Needs GDB 6.1 onwards.
-(gdb-set-buffer-rules 'gdb-locals-buffer
- 'gdb-locals-buffer-name
- 'gdb-locals-mode)
-
-(def-gdb-auto-update-trigger gdb-invalidate-locals-1
- (gdb-get-buffer 'gdb-locals-buffer)
- (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdba)
- "server interpreter mi -\"stack-list-locals --simple-values\"\n"
- "-stack-list-locals --simple-values\n")
- gdb-stack-list-locals-handler)
-
-(defconst gdb-stack-list-locals-regexp
- "{.*?name=\"\\(.*?\\)\".*?,type=\"\\(.*?\\)\"")
-
-(defvar gdb-locals-watch-map-1
- (let ((map (make-sparse-keymap)))
- (suppress-keymap map)
- (define-key map "\r" 'gud-watch)
- (define-key map [mouse-2] 'gud-watch)
- map)
- "Keymap to create watch expression of a complex data type local variable.")
-
-(defvar gdb-edit-locals-map-1
- (let ((map (make-sparse-keymap)))
- (suppress-keymap map)
- (define-key map "\r" 'gdb-edit-locals-value)
- (define-key map [mouse-2] 'gdb-edit-locals-value)
- map)
- "Keymap to edit value of a simple data type local variable.")
-
-(defun gdb-edit-locals-value (&optional event)
- "Assign a value to a variable displayed in the locals buffer."
- (interactive (list last-input-event))
- (save-excursion
- (if event (posn-set-point (event-end event)))
- (beginning-of-line)
- (let* ((var (current-word))
- (value (read-string (format "New value (%s): " var))))
- (gdb-enqueue-input
- (list (concat gdb-server-prefix "set variable " var " = " value "\n")
- 'ignore)))))
-
-;; Dont display values of arrays or structures.
-;; These can be expanded using gud-watch.
-(defun gdb-stack-list-locals-handler ()
- (setq gdb-pending-triggers (delq 'gdb-invalidate-locals-1
- gdb-pending-triggers))
- (goto-char (point-min))
- (if (re-search-forward gdb-error-regexp nil t)
- (let ((err (match-string 1)))
- (with-current-buffer (gdb-get-buffer 'gdb-locals-buffer)
- (let ((buffer-read-only nil))
- (erase-buffer)
- (insert err)
- (goto-char (point-min)))))
- (let (local locals-list)
- (goto-char (point-min))
- (while (re-search-forward gdb-stack-list-locals-regexp nil t)
- (let ((local (list (match-string 1)
- (match-string 2)
- nil)))
- (if (looking-at ",value=\\(\".*\"\\).*?}")
- (setcar (nthcdr 2 local) (read (match-string 1))))
- (push local locals-list)))
- (let ((buf (gdb-get-buffer 'gdb-locals-buffer)))
- (and buf (with-current-buffer buf
- (let* ((window (get-buffer-window buf 0))
- (start (window-start window))
- (p (if window (window-point window) (point)))
- (buffer-read-only nil) (name) (value))
- (erase-buffer)
- (dolist (local locals-list)
- (setq name (car local))
- (setq value (nth 2 local))
- (if (or (not value)
- (string-match "^\\0x" value))
- (add-text-properties 0 (length name)
- `(mouse-face highlight
- help-echo "mouse-2: create watch expression"
- local-map ,gdb-locals-watch-map-1)
- name)
- (add-text-properties 0 (length value)
- `(mouse-face highlight
- help-echo "mouse-2: edit value"
- local-map ,gdb-edit-locals-map-1)
- value))
- (insert
- (concat name "\t" (nth 1 local)
- "\t" value "\n")))
- (if window
- (progn
- (set-window-start window start)
- (set-window-point window p))
- (goto-char p)))))))))
-
-(defun gdb-get-register-names ()
- "Create a list of register names."
- (goto-char (point-min))
- (while (re-search-forward gdb-data-list-register-names-regexp nil t)
- (push (match-string 1) gdb-register-names)))
-
-(provide 'gdb-ui)
-
-;; 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 de94620c737..06ab8c389d4 100644
--- a/lisp/progmodes/grep.el
+++ b/lisp/progmodes/grep.el
@@ -348,7 +348,11 @@ Notice that using \\[next-error] or \\[compile-goto-error] modifies
;; produces them
;; ("^\\(.+?\\)\\(:[ \t]*\\)\\([0-9]+\\)\\2\\(?:\\([0-9]+\\)\\(?:-\\([0-9]+\\)\\)?\\2\\)?"
;; 1 3 (4 . 5))
- ("^\\(\\(.+?\\):\\([0-9]+\\):\\).*?\
+ ;; Note that we want to use as tight a regexp as we can to try and
+ ;; handle weird file names (with colons in them) as well as possible.
+ ;; E.g. we use [1-9][0-9]* rather than [0-9]+ so as to accept ":034:" in
+ ;; file names.
+ ("^\\(\\(.+?\\):\\([1-9][0-9]*\\):\\).*?\
\\(\033\\[01;31m\\(?:\033\\[K\\)?\\)\\(.*?\\)\\(\033\\[[0-9]*m\\)"
2 3
;; Calculate column positions (beg . end) of first grep match on a line
@@ -357,7 +361,7 @@ Notice that using \\[next-error] or \\[compile-goto-error] modifies
(- (match-beginning 4) (match-end 1)))
.
(lambda () (- (match-end 5) (match-end 1)
- (- (match-end 4) (match-beginning 4)))))
+ (- (match-end 4) (match-beginning 4)))))
nil 1)
("^Binary file \\(.+\\) matches$" 1 nil nil 0 1))
"Regexp used to match grep hits. See `compilation-error-regexp-alist'.")
@@ -781,12 +785,17 @@ substitution string. Note dynamic scoping of variables.")
(file-name-nondirectory bn)))
(default-alias
(and fn
- (let ((aliases grep-files-aliases)
+ (let ((aliases (remove (assoc "all" grep-files-aliases)
+ grep-files-aliases))
alias)
(while aliases
(setq alias (car aliases)
aliases (cdr aliases))
- (if (string-match (wildcard-to-regexp (cdr alias)) fn)
+ (if (string-match (mapconcat
+ 'wildcard-to-regexp
+ (split-string (cdr alias) nil t)
+ "\\|")
+ fn)
(setq aliases nil)
(setq alias nil)))
(cdr alias))))
diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el
index bee7a062f64..8c35a13ac53 100644
--- a/lisp/progmodes/gud.el
+++ b/lisp/progmodes/gud.el
@@ -43,10 +43,8 @@
(require 'comint)
(defvar gdb-active-process)
-(defvar gdb-recording)
(defvar gdb-define-alist)
(defvar gdb-macro-info)
-(defvar gdb-server-prefix)
(defvar gdb-show-changed-values)
(defvar gdb-source-window)
(defvar gdb-var-list)
@@ -126,77 +124,52 @@ Used to grey out relevant toolbar icons.")
(throw 'info-found nil))))
nil 0)
(select-frame (make-frame)))
- (if (memq gud-minor-mode '(gdbmi gdba))
+ (if (eq gud-minor-mode 'gdbmi)
(info "(emacs)GDB Graphical Interface")
(info "(emacs)Debuggers"))))
(defun gud-tool-bar-item-visible-no-fringe ()
(not (or (eq (buffer-local-value 'major-mode (window-buffer)) 'speedbar-mode)
- (and (memq gud-minor-mode '(gdbmi gdba))
+ (eq (buffer-local-value 'major-mode (window-buffer)) 'gdb-memory-mode)
+ (and (eq gud-minor-mode 'gdbmi)
(> (car (window-fringes)) 0)))))
+(declare-function gdb-gud-context-command "gdb-mi.el")
+
(defun gud-stop-subjob ()
(interactive)
(with-current-buffer gud-comint-buffer
- (if (string-equal gud-target-name "emacs")
- (comint-stop-subjob)
- (if (eq gud-minor-mode 'jdb)
- (gud-call "suspend")
- (comint-interrupt-subjob)))))
+ (cond ((string-equal gud-target-name "emacs")
+ (comint-stop-subjob))
+ ((eq gud-minor-mode 'jdb)
+ (gud-call "suspend"))
+ ((eq gud-minor-mode 'gdbmi)
+ (gud-call (gdb-gud-context-command "-exec-interrupt")))
+ (t
+ (comint-interrupt-subjob)))))
(easy-mmode-defmap gud-menu-map
'(([help] "Info (debugger)" . gud-goto-info)
- ([rfinish] menu-item "Reverse Finish Function" gud-rfinish
- :enable (not gud-running)
- :visible (and gdb-recording
- (eq gud-minor-mode 'gdba)))
- ([rstepi] menu-item "Reverse Step Instruction" gud-rstepi
- :enable (not gud-running)
- :visible (and gdb-recording
- (eq gud-minor-mode 'gdba)))
- ([rnexti] menu-item "Reverse Next Instruction" gud-rnexti
- :enable (not gud-running)
- :visible (and gdb-recording
- (eq gud-minor-mode 'gdba)))
- ([rstep] menu-item "Reverse Step Line" gud-rstep
- :enable (not gud-running)
- :visible (and gdb-recording
- (eq gud-minor-mode 'gdba)))
- ([rnext] menu-item "Reverse Next Line" gud-rnext
- :enable (not gud-running)
- :visible (and gdb-recording
- (eq gud-minor-mode 'gdba)))
- ([rcont] menu-item "Reverse Continue" gud-rcont
- :enable (not gud-running)
- :visible (and gdb-recording
- (eq gud-minor-mode 'gdba)))
- ([recstart] menu-item "Start Recording" gdb-toggle-recording-1
- :visible (and (not gdb-recording)
- (eq gud-minor-mode 'gdba)))
- ([recstop] menu-item "Stop Recording" gdb-toggle-recording
- :visible (and gdb-recording
- (eq gud-minor-mode 'gdba)))
([tooltips] menu-item "Show GUD tooltips" gud-tooltip-mode
:enable (and (not emacs-basic-display)
(display-graphic-p)
(fboundp 'x-show-tip))
:visible (memq gud-minor-mode
- '(gdbmi gdba dbx sdb xdb pdb))
+ '(gdbmi dbx sdb xdb pdb))
:button (:toggle . gud-tooltip-mode))
([refresh] "Refresh" . gud-refresh)
([run] menu-item "Run" gud-run
:enable (not gud-running)
:visible (memq gud-minor-mode '(gdbmi gdb dbx jdb)))
([go] menu-item (if gdb-active-process "Continue" "Run") gud-go
- :visible (and (not gud-running)
- (eq gud-minor-mode 'gdba)))
+ :visible (and (eq gud-minor-mode 'gdbmi)
+ (gdb-show-run-p)))
([stop] menu-item "Stop" gud-stop-subjob
- :visible (or (not (memq gud-minor-mode '(gdba pdb)))
- (and gud-running
- (eq gud-minor-mode 'gdba))))
+ :visible (or (not (memq gud-minor-mode '(gdbmi pdb)))
+ (gdb-show-stop-p)))
([until] menu-item "Continue to selection" gud-until
:enable (not gud-running)
- :visible (and (memq gud-minor-mode '(gdbmi gdba gdb perldb))
+ :visible (and (memq gud-minor-mode '(gdbmi gdb perldb))
(gud-tool-bar-item-visible-no-fringe)))
([remove] menu-item "Remove Breakpoint" gud-remove
:enable (not gud-running)
@@ -204,50 +177,52 @@ Used to grey out relevant toolbar icons.")
([tbreak] menu-item "Temporary Breakpoint" gud-tbreak
:enable (not gud-running)
:visible (memq gud-minor-mode
- '(gdbmi gdba gdb sdb xdb)))
+ '(gdbmi gdb sdb xdb)))
([break] menu-item "Set Breakpoint" gud-break
:enable (not gud-running)
:visible (gud-tool-bar-item-visible-no-fringe))
([up] menu-item "Up Stack" gud-up
:enable (not gud-running)
:visible (memq gud-minor-mode
- '(gdbmi gdba gdb dbx xdb jdb pdb)))
+ '(gdbmi gdb dbx xdb jdb pdb)))
([down] menu-item "Down Stack" gud-down
:enable (not gud-running)
:visible (memq gud-minor-mode
- '(gdbmi gdba gdb dbx xdb jdb pdb)))
+ '(gdbmi gdb dbx xdb jdb pdb)))
([pp] menu-item "Print S-expression" gud-pp
:enable (and (not gud-running)
gdb-active-process)
:visible (and (string-equal
(buffer-local-value
'gud-target-name gud-comint-buffer) "emacs")
- (eq gud-minor-mode 'gdba)))
- ([print*] menu-item "Print Dereference" gud-pstar
+ (eq gud-minor-mode 'gdbmi)))
+ ([print*] menu-item (if (eq gud-minor-mode 'jdb)
+ "Dump object"
+ "Print Dereference") gud-pstar
:enable (not gud-running)
- :visible (memq gud-minor-mode '(gdbmi gdba gdb)))
+ :visible (memq gud-minor-mode '(gdbmi gdb jdb)))
([print] menu-item "Print Expression" gud-print
:enable (not gud-running))
([watch] menu-item "Watch Expression" gud-watch
:enable (not gud-running)
- :visible (memq gud-minor-mode '(gdbmi gdba)))
+ :visible (eq gud-minor-mode 'gdbmi))
([finish] menu-item "Finish Function" gud-finish
:enable (not gud-running)
:visible (memq gud-minor-mode
- '(gdbmi gdba gdb xdb jdb pdb)))
+ '(gdbmi gdb xdb jdb pdb)))
([stepi] menu-item "Step Instruction" gud-stepi
:enable (not gud-running)
- :visible (memq gud-minor-mode '(gdbmi gdba gdb dbx)))
+ :visible (memq gud-minor-mode '(gdbmi gdb dbx)))
([nexti] menu-item "Next Instruction" gud-nexti
:enable (not gud-running)
- :visible (memq gud-minor-mode '(gdbmi gdba gdb dbx)))
+ :visible (memq gud-minor-mode '(gdbmi gdb dbx)))
([step] menu-item "Step Line" gud-step
:enable (not gud-running))
([next] menu-item "Next Line" gud-next
:enable (not gud-running))
([cont] menu-item "Continue" gud-cont
:enable (not gud-running)
- :visible (not (eq gud-minor-mode 'gdba))))
+ :visible (not (eq gud-minor-mode 'gdbmi))))
"Menu for `gud-mode'."
:name "Gud")
@@ -269,21 +244,22 @@ Used to grey out relevant toolbar icons.")
. (,(propertize "next" 'face 'font-lock-doc-face) . gud-next))
([menu-bar until] menu-item
,(propertize "until" 'face 'font-lock-doc-face) gud-until
- :visible (memq gud-minor-mode '(gdbmi gdba gdb perldb)))
+ :visible (memq gud-minor-mode '(gdbmi gdb perldb)))
([menu-bar cont] menu-item
,(propertize "cont" 'face 'font-lock-doc-face) gud-cont
- :visible (not (eq gud-minor-mode 'gdba)))
+ :visible (not (eq gud-minor-mode 'gdbmi)))
([menu-bar run] menu-item
,(propertize "run" 'face 'font-lock-doc-face) gud-run
:visible (memq gud-minor-mode '(gdbmi gdb dbx jdb)))
([menu-bar go] menu-item
,(propertize " go " 'face 'font-lock-doc-face) gud-go
- :visible (and (not gud-running)
- (eq gud-minor-mode 'gdba)))
+ :visible (and (eq gud-minor-mode 'gdbmi)
+ (gdb-show-run-p)))
([menu-bar stop] menu-item
,(propertize "stop" 'face 'font-lock-doc-face) gud-stop-subjob
- :visible (and gud-running
- (eq gud-minor-mode 'gdba)))
+ :visible (or (and (eq gud-minor-mode 'gdbmi)
+ (gdb-show-stop-p))
+ (not (eq gud-minor-mode 'gdbmi))))
([menu-bar print]
. (,(propertize "print" 'face 'font-lock-doc-face) . gud-print))
([menu-bar tools] . undefined)
@@ -322,14 +298,6 @@ Used to grey out relevant toolbar icons.")
(gud-stepi . "gud/stepi")
(gud-up . "gud/up")
(gud-down . "gud/down")
- (gdb-toggle-recording-1 . "gud/recstart")
- (gdb-toggle-recording . "gud/recstop")
- (gud-rcont . "gud/rcont")
- (gud-rnext . "gud/rnext")
- (gud-rstep . "gud/rstep")
- (gud-rfinish . "gud/rfinish")
- (gud-rnexti . "gud/rnexti")
- (gud-rstepi . "gud/rstepi")
(gud-goto-info . "info"))
map)
(tool-bar-local-item-from-menu
@@ -354,7 +322,7 @@ Uses `gud-<MINOR-MODE>-directories' to find the source files."
(setq directories (cdr directories)))
result)))
-(declare-function gdb-create-define-alist "gdb-ui" ())
+(declare-function gdb-create-define-alist "gdb-mi" ())
(defun gud-find-file (file)
;; Don't get confused by double slashes in the name that comes from GDB.
@@ -370,7 +338,7 @@ Uses `gud-<MINOR-MODE>-directories' to find the source files."
(set (make-local-variable 'gud-minor-mode) minor-mode)
(set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
(when (and gud-tooltip-mode
- (memq gud-minor-mode '(gdbmi gdba)))
+ (eq gud-minor-mode 'gdbmi))
(make-local-variable 'gdb-define-alist)
(unless gdb-define-alist (gdb-create-define-alist))
(add-hook 'after-save-hook 'gdb-create-define-alist nil t))
@@ -499,21 +467,21 @@ The value t means that there is no stack, and we are in display-file mode.")
(defvar gud-speedbar-menu-items
'(["Jump to stack frame" speedbar-edit-line
- :visible (not (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
- '(gdbmi gdba)))]
+ :visible (not (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
+ 'gdbmi))]
["Edit value" speedbar-edit-line
- :visible (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
- '(gdbmi gdba))]
+ :visible (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
+ 'gdbmi)]
["Delete expression" gdb-var-delete
- :visible (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
- '(gdbmi gdba))]
+ :visible (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
+ 'gdbmi)]
["Auto raise frame" gdb-speedbar-auto-raise
:style toggle :selected gdb-speedbar-auto-raise
- :visible (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
- '(gdbmi gdba))]
+ :visible (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
+ 'gdbmi)]
("Output Format"
- :visible (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
- '(gdbmi gdba))
+ :visible (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
+ 'gdbmi)
["Binary" (gdb-var-set-format "binary") t]
["Natural" (gdb-var-set-format "natural") t]
["Hexadecimal" (gdb-var-set-format "hexadecimal") t]))
@@ -542,7 +510,7 @@ required by the caller."
(start (window-start window))
(p (window-point window)))
(cond
- ((memq minor-mode '(gdbmi gdba))
+ ((eq minor-mode 'gdbmi)
(erase-buffer)
(insert "Watch Expressions:\n")
(let ((var-list gdb-var-list) parent)
@@ -632,7 +600,7 @@ required by the caller."
(car frame)
'speedbar-file-face
'speedbar-highlight-face
- (cond ((memq minor-mode '(gdbmi gdba gdb))
+ (cond ((memq minor-mode '(gdbmi gdb))
'gud-gdb-goto-stackframe)
(t (error "Should never be here")))
frame t))))
@@ -689,8 +657,6 @@ The option \"--fullname\" must be included in this value."
;; Set the accumulator to the remaining text.
gud-marker-acc (substring gud-marker-acc (match-end 0))))
- ;; Check for annotations and change gud-minor-mode to 'gdba if
- ;; they are found.
(while (string-match "\n\032\032\\(.*\\)\n" gud-marker-acc)
(let ((match (match-string 1 gud-marker-acc)))
@@ -754,10 +720,10 @@ The option \"--fullname\" must be included in this value."
(defvar gud-filter-pending-text nil
"Non-nil means this is text that has been saved for later in `gud-filter'.")
-;; If in gdba mode, gdb-ui is loaded.
-(declare-function gdb-restore-windows "gdb-ui" ())
+;; If in gdb mode, gdb-mi is loaded.
+(declare-function gdb-restore-windows "gdb-mi" ())
-;; The old gdb command (text command mode). The new one is in gdb-ui.el.
+;; The old gdb command (text command mode). The new one is in gdb-mi.el.
;;;###autoload
(defun gud-gdb (command-line)
"Run gdb on program FILE in buffer *gud-FILE*.
@@ -768,10 +734,10 @@ directory and source-file directory for your debugger."
(when (and gud-comint-buffer
(buffer-name gud-comint-buffer)
(get-buffer-process gud-comint-buffer)
- (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdba)))
- (gdb-restore-windows)
- (error
- "Multiple debugging requires restarting in text command mode"))
+ (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdbmi)))
+ (gdb-restore-windows)
+ (error
+ "Multiple debugging requires restarting in text command mode"))
(gud-common-init command-line nil 'gud-gdb-marker-filter)
(set (make-local-variable 'gud-minor-mode) 'gdb)
@@ -2547,7 +2513,7 @@ comint mode, which see."
(setq w (cdr w)))
(if w
(setcar w
- (if (file-remote-p default-directory)
+ (if (file-remote-p file)
;; Tramp has already been loaded if we are here.
(setq file (tramp-file-name-localname
(tramp-dissect-file-name file)))
@@ -2642,7 +2608,7 @@ It is saved for when this flag is not set.")
(defvar gud-overlay-arrow-position nil)
(add-to-list 'overlay-arrow-variable-list 'gud-overlay-arrow-position)
-(declare-function gdb-reset "gdb-ui" ())
+(declare-function gdb-reset "gdb-mi" ())
(defun gud-sentinel (proc msg)
(cond ((null (buffer-name (process-buffer proc)))
@@ -2654,14 +2620,14 @@ It is saved for when this flag is not set.")
(string-equal speedbar-initial-expansion-list-name "GUD"))
(speedbar-change-initial-expansion-list
speedbar-previously-used-expansion-list-name))
- (if (memq gud-minor-mode-type '(gdbmi gdba))
+ (if (eq gud-minor-mode-type 'gdbmi)
(gdb-reset)
(gud-reset)))
((memq (process-status proc) '(signal exit))
;; Stop displaying an arrow in a source file.
(setq gud-overlay-arrow-position nil)
- (if (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
- '(gdba gdbmi))
+ (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
+ 'gdbmi)
(gdb-reset)
(gud-reset))
(let* ((obuf (current-buffer)))
@@ -2692,7 +2658,9 @@ It is saved for when this flag is not set.")
(defun gud-kill-buffer-hook ()
(setq gud-minor-mode-type gud-minor-mode)
(condition-case nil
- (kill-process (get-buffer-process (current-buffer)))
+ (progn
+ (kill-process (get-buffer-process (current-buffer)))
+ (delete-process (get-process "gdb-inferior")))
(error nil)))
(defun gud-reset ()
@@ -2715,8 +2683,8 @@ Obeying it means displaying in another window the specified file and line."
(declare-function global-hl-line-highlight "hl-line" ())
(declare-function hl-line-highlight "hl-line" ())
-(declare-function gdb-display-source-buffer "gdb-ui" (buffer))
-(declare-function gdb-display-buffer "gdb-ui" (buf dedicated &optional size))
+(declare-function gdb-display-source-buffer "gdb-mi" (buffer))
+(declare-function gdb-display-buffer "gdb-mi" (buf dedicated &optional size))
;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen
;; and that its line LINE is visible.
@@ -2732,7 +2700,7 @@ Obeying it means displaying in another window the specified file and line."
(gud-find-file true-file)))
(window (and buffer
(or (get-buffer-window buffer)
- (if (memq gud-minor-mode '(gdbmi gdba))
+ (if (eq gud-minor-mode 'gdbmi)
(or (if (get-buffer-window buffer 'visible)
(display-buffer buffer nil 'visible))
(unless (gdb-display-source-buffer buffer)
@@ -2769,7 +2737,7 @@ Obeying it means displaying in another window the specified file and line."
(goto-char pos))))
(when window
(set-window-point window gud-overlay-arrow-position)
- (if (memq gud-minor-mode '(gdbmi gdba))
+ (if (eq gud-minor-mode 'gdbmi)
(setq gdb-source-window window)))))))
;; The gud-call function must do the right thing whether its invoking
@@ -2875,7 +2843,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 (memq gud-minor-mode '(gdbmi gdba))
+ (if (eq gud-minor-mode 'gdbmi)
(apply comint-input-sender (list proc command))
(process-send-string proc (concat command "\n"))))))))
@@ -3155,10 +3123,12 @@ class of the file (using s to separate nested class ids)."
("\\$\\(\\w+\\)" (1 font-lock-variable-name-face))
("^\\s-*\\(\\w\\(\\w\\|\\s_\\)*\\)" (1 font-lock-keyword-face))))
-(defvar gdb-script-font-lock-syntactic-keywords
- '(("^document\\s-.*\\(\n\\)" (1 "< b"))
- ("^end\\>"
- (0 (unless (eq (match-beginning 0) (point-min))
+(defconst gdb-script-syntax-propertize-function
+ (syntax-propertize-rules
+ ("^document\\s-.*\\(\n\\)" (1 "< b"))
+ ("^end\\(\\>\\)"
+ (1 (ignore
+ (unless (eq (match-beginning 0) (point-min))
;; We change the \n in front, which is more difficult, but results
;; in better highlighting. If the doc is empty, the single \n is
;; both the beginning and the end of the docstring, which can't be
@@ -3170,10 +3140,9 @@ class of the file (using s to separate nested class ids)."
'syntax-table (eval-when-compile
(string-to-syntax "> b")))
;; Make sure that rehighlighting the previous line won't erase our
- ;; syntax-table property.
+ ;; syntax-table property and that modifying `end' will.
(put-text-property (1- (match-beginning 0)) (match-end 0)
- 'font-lock-multiline t)
- nil)))))
+ 'syntax-multiline t)))))))
(defun gdb-script-font-lock-syntactic-face (state)
(cond
@@ -3249,13 +3218,6 @@ Treats actions as defuns."
(goto-char (point-max)))
t)
-;; Besides .gdbinit, gdb documents other names to be usable for init
-;; files, cross-debuggers can use something like
-;; .PROCESSORNAME-gdbinit so that the host and target gdbinit files
-;; don't interfere with each other.
-;;;###autoload
-(add-to-list 'auto-mode-alist (cons (purecopy "/\\.[a-z0-9-]*gdbinit") 'gdb-script-mode))
-
;;;###autoload
(define-derived-mode gdb-script-mode nil "GDB-Script"
"Major mode for editing GDB scripts."
@@ -3271,10 +3233,13 @@ Treats actions as defuns."
#'gdb-script-end-of-defun)
(set (make-local-variable 'font-lock-defaults)
'(gdb-script-font-lock-keywords nil nil ((?_ . "w")) nil
- (font-lock-syntactic-keywords
- . gdb-script-font-lock-syntactic-keywords)
(font-lock-syntactic-face-function
- . gdb-script-font-lock-syntactic-face))))
+ . gdb-script-font-lock-syntactic-face)))
+ ;; Recognize docstrings.
+ (set (make-local-variable 'syntax-propertize-function)
+ gdb-script-syntax-propertize-function)
+ (add-hook 'syntax-propertize-extend-region-functions
+ #'syntax-propertize-multiline 'append 'local))
;;; tooltips for GUD
@@ -3301,14 +3266,14 @@ Treats actions as defuns."
(gud-tooltip-activate-mouse-motions-if-enabled)
(if (and gud-comint-buffer
(buffer-name gud-comint-buffer); gud-comint-buffer might be killed
- (memq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
- '(gdbmi gdba)))
+ (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
+ 'gdbmi))
(if gud-tooltip-mode
(progn
(dolist (buffer (buffer-list))
(unless (eq buffer gud-comint-buffer)
(with-current-buffer buffer
- (when (and (memq gud-minor-mode '(gdbmi gdba))
+ (when (and (eq gud-minor-mode 'gdbmi)
(not (string-match "\\`\\*.+\\*\\'"
(buffer-name))))
(make-local-variable 'gdb-define-alist)
@@ -3433,8 +3398,8 @@ With arg, dereference expr if ARG is positive, otherwise do not derereference."
; Larger arrays (say 400 elements) are displayed in
; the tooltip incompletely and spill over into the gud buffer.
; Switching the process-filter creates timing problems and
-; it may be difficult to do better. Using annotations as in
-; gdb-ui.el gets round this problem.
+; it may be difficult to do better. Using GDB/MI as in
+; gdb-mi.el gets round this problem.
(defun gud-tooltip-process-output (process output)
"Process debugger output and show it in a tooltip window."
(set-process-filter process gud-tooltip-original-filter)
@@ -3444,12 +3409,12 @@ With arg, dereference expr if ARG is positive, otherwise do not derereference."
(defun gud-tooltip-print-command (expr)
"Return a suitable command to print the expression EXPR."
(case gud-minor-mode
- (gdba (concat "server print " expr))
- ((dbx gdbmi) (concat "print " expr))
+ (gdbmi (concat "-data-evaluate-expression " expr))
+ (dbx (concat "print " expr))
((xdb pdb) (concat "p " expr))
(sdb (concat expr "/"))))
-(declare-function gdb-enqueue-input "gdb-ui" (item))
+(declare-function gdb-input "gdb-mi" (item))
(declare-function tooltip-expr-to-print "tooltip" (event))
(declare-function tooltip-event-buffer "tooltip" (event))
@@ -3469,12 +3434,12 @@ This function must return nil if it doesn't handle EVENT."
(buffer-name gud-comint-buffer); might be killed
(setq process (get-buffer-process gud-comint-buffer))
(posn-point (event-end event))
- (or (and (eq gud-minor-mode 'gdba) (not gdb-active-process))
+ (or (and (eq gud-minor-mode 'gdbmi) (not gdb-active-process))
(progn (setq gud-tooltip-event event)
(eval (cons 'and gud-tooltip-display)))))
(let ((expr (tooltip-expr-to-print event)))
(when expr
- (if (and (eq gud-minor-mode 'gdba)
+ (if (and (eq gud-minor-mode 'gdbmi)
(not gdb-active-process))
(progn
(with-current-buffer (tooltip-event-buffer event)
@@ -3492,13 +3457,13 @@ This function must return nil if it doesn't handle EVENT."
(message-box "Using GUD tooltips in this mode is unsafe\n\
so they have been disabled."))
(unless (null cmd) ; CMD can be nil if unknown debugger
- (if (memq gud-minor-mode '(gdba gdbmi))
+ (if (eq gud-minor-mode 'gdbmi)
(if gdb-macro-info
- (gdb-enqueue-input
+ (gdb-input
(list (concat
- gdb-server-prefix "macro expand " expr "\n")
+ "server macro expand " expr "\n")
`(lambda () (gdb-tooltip-print-1 ,expr))))
- (gdb-enqueue-input
+ (gdb-input
(list (concat cmd "\n")
`(lambda () (gdb-tooltip-print ,expr)))))
(setq gud-tooltip-original-filter (process-filter process))
diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el
index 04ec915f3d3..b21cd9c89ef 100644
--- a/lisp/progmodes/hideif.el
+++ b/lisp/progmodes/hideif.el
@@ -760,7 +760,7 @@ Point is left unchanged."
(cond ((hif-looking-at-else)
(setq else (point)))
(t
- (setq end (point)))) ; (save-excursion (end-of-line) (point))
+ (setq end (point)))) ; (line-end-position)
;; If found #else, look for #endif.
(when else
(while (progn
@@ -769,7 +769,7 @@ Point is left unchanged."
(hif-ifdef-to-endif))
(if (hif-looking-at-else)
(error "Found two elses in a row? Broken!"))
- (setq end (point))) ; (save-excursion (end-of-line) (point))
+ (setq end (point))) ; (line-end-position)
(hif-make-range start end else))))
@@ -1025,5 +1025,4 @@ Return as (TOP . BOTTOM) the extent of ifdef block."
(provide 'hideif)
-;; arch-tag: c6381d17-a59a-483a-b945-658f22277981
;;; hideif.el ends here
diff --git a/lisp/progmodes/icon.el b/lisp/progmodes/icon.el
index 9182b319b57..f0287c90188 100644
--- a/lisp/progmodes/icon.el
+++ b/lisp/progmodes/icon.el
@@ -1,7 +1,7 @@
;;; icon.el --- mode for editing Icon code
-;; Copyright (C) 1989, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1989, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+;; 2009, 2010 Free Software Foundation, Inc.
;; Author: Chris Smith <csmith@convex.com>
;; Created: 15 Feb 89
@@ -601,7 +601,7 @@ Returns nil if line starts inside a string, t if in a comment."
(indent-to this-indent)))
;; Indent any comment following the text.
(or (looking-at comment-start-skip)
- (if (re-search-forward comment-start-skip (save-excursion (end-of-line) (point)) t)
+ (if (re-search-forward comment-start-skip (line-end-position) t)
(progn (indent-for-comment) (beginning-of-line))))))))))
(defconst icon-font-lock-keywords-1
@@ -687,5 +687,4 @@ Returns nil if line starts inside a string, t if in a comment."
(provide 'icon)
-;; arch-tag: 8abf8c99-e7df-44af-a58f-ef5ed2ee52cb
;;; icon.el ends here
diff --git a/lisp/progmodes/idlw-complete-structtag.el b/lisp/progmodes/idlw-complete-structtag.el
index 696853e0929..56b41541ee3 100644
--- a/lisp/progmodes/idlw-complete-structtag.el
+++ b/lisp/progmodes/idlw-complete-structtag.el
@@ -1,12 +1,13 @@
;;; idlw-complete-structtag.el --- Completion of structure tags.
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+;; 2010 Free Software Foundation, Inc.
;; Author: Carsten Dominik <dominik@astro.uva.nl>
;; Maintainer: J.D. Smith <jdsmith@as.arizona.edu>
;; Version: 1.2
;; Keywords: languages
+;; Package: idlwave
;; This file is part of GNU Emacs.
@@ -224,9 +225,8 @@ an up-to-date completion list."
;; Fake help in the source buffer for structure tags.
-;; kwd and name are global-variables here.
-(defvar name)
-(defvar kwd)
+;; idlw-help-kwd is a global-variable (from idlwave-do-mouse-completion-help).
+(defvar idlw-help-kwd)
(defvar idlwave-help-do-struct-tag)
(defun idlwave-complete-structure-tag-help (mode word)
(cond
@@ -235,13 +235,10 @@ an up-to-date completion list."
(not (equal idlwave-current-tags-buffer
(get-buffer (idlwave-shell-buffer)))))
((eq mode 'set)
- (setq kwd word
+ (setq idlw-help-kwd word
idlwave-help-do-struct-tag idlwave-structtag-struct-location))
(t (error "This should not happen"))))
(provide 'idlw-complete-structtag)
;;; idlw-complete-structtag.el ends here
-
-
-;; arch-tag: d1f9e55c-e504-4187-9c31-3c3651fa4bfa
diff --git a/lisp/progmodes/idlw-help.el b/lisp/progmodes/idlw-help.el
index f6eff9c3cff..d7c14ccd4a8 100644
--- a/lisp/progmodes/idlw-help.el
+++ b/lisp/progmodes/idlw-help.el
@@ -1,12 +1,13 @@
;;; idlw-help.el --- HTML Help code for IDLWAVE
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+;; 2009, 2010 Free Software Foundation, Inc.
;;
;; Authors: J.D. Smith <jdsmith@as.arizona.edu>
;; Carsten Dominik <dominik@science.uva.nl>
;; Maintainer: J.D. Smith <jdsmith@as.arizona.edu>
-;; Version: 6.1_em22
+;; Version: 6.1.22
+;; Package: idlwave
;; This file is part of GNU Emacs.
@@ -575,13 +576,13 @@ Needs additional info stored in global `idlwave-completion-help-info'."
(let* ((cw (selected-window))
(info idlwave-completion-help-info) ; global passed in
(what (nth 0 info))
- (name (nth 1 info))
+ (idlw-help-name (nth 1 info))
(type (nth 2 info))
(class (nth 3 info))
(need-class class)
- (kwd (nth 4 info))
+ (idlw-help-kwd (nth 4 info))
(sclasses (nth 5 info))
- word link)
+ word idlw-help-link)
(mouse-set-point ev)
@@ -589,18 +590,18 @@ Needs additional info stored in global `idlwave-completion-help-info'."
(setq word (idlwave-this-word))
(if (string= word "")
(error "No help item selected"))
- (setq link (get-text-property 0 'link word))
+ (setq idlw-help-link (get-text-property 0 'link word))
(select-window cw)
(cond
;; Routine name
((memq what '(procedure function routine))
- (setq name word)
+ (setq idlw-help-name word)
(if (or (eq class t)
(and (stringp class) sclasses))
(let* ((classes (idlwave-all-method-classes
- (idlwave-sintern-method name)
+ (idlwave-sintern-method idlw-help-name)
type)))
- (setq link t) ; No specific link valid yet
+ (setq idlw-help-link t) ; No specific link valid yet
(if sclasses
(setq classes (idlwave-members-only
classes (cons class sclasses))))
@@ -610,19 +611,19 @@ Needs additional info stored in global `idlwave-completion-help-info'."
;; XXX is this necessary, given all-method-classes?
(if (stringp class)
(setq class (idlwave-find-inherited-class
- (idlwave-sintern-routine-or-method name class)
+ (idlwave-sintern-routine-or-method idlw-help-name class)
type (idlwave-sintern-class class)))))
;; Keyword
((eq what 'keyword)
- (setq kwd word)
+ (setq idlw-help-kwd word)
(if (or (eq class t)
(and (stringp class) sclasses))
(let ((classes (idlwave-all-method-keyword-classes
- (idlwave-sintern-method name)
- (idlwave-sintern-keyword kwd)
+ (idlwave-sintern-method idlw-help-name)
+ (idlwave-sintern-keyword idlw-help-kwd)
type)))
- (setq link t) ; Link can't be correct yet
+ (setq idlw-help-link t) ; Link can't be correct yet
(if sclasses
(setq classes (idlwave-members-only
classes (cons class sclasses))))
@@ -631,11 +632,12 @@ Needs additional info stored in global `idlwave-completion-help-info'."
;; XXX is this necessary, given all-method-keyword-classes?
(if (stringp class)
(setq class (idlwave-find-inherited-class
- (idlwave-sintern-routine-or-method name class)
+ (idlwave-sintern-routine-or-method
+ idlw-help-name class)
type (idlwave-sintern-class class)))))
- (if (string= (downcase name) "obj_new")
+ (if (string= (downcase idlw-help-name) "obj_new")
(setq class idlwave-current-obj_new-class
- name "Init"))))
+ idlw-help-name "Init"))))
;; Class name
((eq what 'class)
@@ -648,9 +650,11 @@ Needs additional info stored in global `idlwave-completion-help-info'."
(funcall what 'set word))
(t (error "Cannot help with this item")))
- (if (and need-class (not class) (not (and link (not (eq link t)))))
+ (if (and need-class (not class)
+ (not (and idlw-help-link (not (eq idlw-help-link t)))))
(error "Cannot help with this item"))
- (idlwave-online-help link (or name word) type class kwd)))
+ (idlwave-online-help idlw-help-link (or idlw-help-name word)
+ type class idlw-help-kwd)))
(defvar idlwave-highlight-help-links-in-completion)
(defvar idlwave-completion-help-links)
@@ -1382,5 +1386,4 @@ IDL assistant.")
(provide 'idlw-help)
(provide 'idlwave-help)
-;; arch-tag: d27b5505-59de-497f-ba3f-f199fd4fb911
;;; idlw-help.el ends here
diff --git a/lisp/progmodes/idlw-shell.el b/lisp/progmodes/idlw-shell.el
index dbe6f179e5b..02eb0324cd8 100644
--- a/lisp/progmodes/idlw-shell.el
+++ b/lisp/progmodes/idlw-shell.el
@@ -7,8 +7,9 @@
;; Carsten Dominik <dominik@astro.uva.nl>
;; Chris Chase <chase@att.com>
;; Maintainer: J.D. Smith <jdsmith@as.arizona.edu>
-;; Version: 6.1_em22
+;; Version: 6.1.22
;; Keywords: processes
+;; Package: idlwave
;; This file is part of GNU Emacs.
@@ -1457,7 +1458,7 @@ Otherwise just move the line. Move down unless UP is non-nil."
(arg (if up arg (- arg))))
(if (eq t idlwave-shell-arrows-do-history) (goto-char proc-pos))
(if (and idlwave-shell-arrows-do-history
- (>= (1+ (save-excursion (end-of-line) (point))) proc-pos))
+ (>= (1+ (point-at-eol)) proc-pos))
(comint-previous-input arg)
(forward-line (- arg)))))
@@ -2179,8 +2180,8 @@ keywords."
;; Default completion of modules and keywords
(idlwave-complete arg)))))
-;; Get rid of opaque dynamic variable passing of link?
-(defvar link) ;dynamic variable
+;; Get rid of opaque dynamic variable passing of idlw-help-link?
+(defvar idlw-help-link) ; dynamic variable from idlwave-do-mouse-completion-help
(defun idlwave-shell-complete-execcomm-help (mode word)
(let ((word (or (nth 1 idlwave-completion-help-info) word))
(entry (assoc-string word idlwave-executive-commands-alist t)))
@@ -2188,7 +2189,7 @@ keywords."
((eq mode 'test)
(and (stringp word) entry (cdr entry)))
((eq mode 'set)
- (if entry (setq link (cdr entry)))) ;; setting dynamic variable!!!
+ (if entry (setq idlw-help-link (cdr entry)))) ; setting dynamic variable!
(t (error "This should not happen")))))
(defun idlwave-shell-complete-filename (&optional arg)
@@ -2210,7 +2211,7 @@ args of an executive .run, .rnew or .compile."
(defun idlwave-shell-filename-string ()
"Return t if in a string and after what could be a file name."
- (let ((limit (save-excursion (beginning-of-line) (point))))
+ (let ((limit (point-at-bol)))
(save-excursion
;; Skip backwards over file name chars
(skip-chars-backward idlwave-shell-file-name-chars limit)
@@ -2219,7 +2220,7 @@ args of an executive .run, .rnew or .compile."
(defun idlwave-shell-batch-command ()
"Return t if we're in a batch command statement like @foo"
- (let ((limit (save-excursion (beginning-of-line) (point))))
+ (let ((limit (point-at-bol)))
(save-excursion
;; Skip backwards over filename
(skip-chars-backward idlwave-shell-file-name-chars limit)
@@ -2397,7 +2398,7 @@ matter what the settings of that variable."
idlwave-shell-electric-stop-line-face
idlwave-shell-stop-line-face))
(move-overlay idlwave-shell-stop-line-overlay
- (point) (save-excursion (end-of-line) (point))
+ (point) (point-at-eol)
(current-buffer)))
;; use the arrow instead, but only if marking is wanted.
(if idlwave-shell-mark-stop-line
@@ -2590,9 +2591,7 @@ If in the IDL shell buffer, returns `idlwave-shell-pc-frame'."
(list (idlwave-shell-file-name (buffer-file-name))
(save-restriction
(widen)
- (save-excursion
- (beginning-of-line)
- (1+ (count-lines 1 (point))))))))
+ (1+ (count-lines 1 (point-at-bol)))))))
(defun idlwave-shell-current-module ()
"Return the name of the module for the current file.
@@ -3644,7 +3643,7 @@ Existing overlays are recycled, in order to minimize consumption."
(while (setq bp (pop bp-list))
(save-excursion
(idlwave-shell-goto-frame (car bp))
- (let* ((end (progn (end-of-line 1) (point)))
+ (let* ((end (point-at-eol))
(beg (progn (beginning-of-line 1) (point)))
(condition (idlwave-shell-bp-get bp 'condition))
(count (idlwave-shell-bp-get bp 'count))
@@ -3998,8 +3997,7 @@ of the form:
(append
;; compiled procedures
(progn
- (beginning-of-line)
- (narrow-to-region cpro (point))
+ (narrow-to-region cpro (point-at-bol))
(goto-char (point-min))
(idlwave-shell-sources-grep))
;; compiled functions
@@ -4692,5 +4690,4 @@ static char * file[] = {
(if idlwave-shell-use-toolbar
(add-hook 'idlwave-shell-mode-hook 'idlwave-toolbar-add-everywhere))
-;; arch-tag: 20c2e8ce-0709-41d8-a5b6-bb039148440a
;;; idlw-shell.el ends here
diff --git a/lisp/progmodes/idlw-toolbar.el b/lisp/progmodes/idlw-toolbar.el
index 395cfd54045..474065451d7 100644
--- a/lisp/progmodes/idlw-toolbar.el
+++ b/lisp/progmodes/idlw-toolbar.el
@@ -5,8 +5,9 @@
;; Author: Carsten Dominik <dominik@astro.uva.nl>
;; Maintainer: J.D. Smith <jdsmith@as.arizona.edu>
-;; Version: 6.1_em22
+;; Version: 6.1.22
;; Keywords: processes
+;; Package: idlwave
;; This file is part of GNU Emacs.
diff --git a/lisp/progmodes/idlwave.el b/lisp/progmodes/idlwave.el
index b2858f1479d..e05ea855636 100644
--- a/lisp/progmodes/idlwave.el
+++ b/lisp/progmodes/idlwave.el
@@ -7,7 +7,7 @@
;; Carsten Dominik <dominik@science.uva.nl>
;; Chris Chase <chase@att.com>
;; Maintainer: J.D. Smith <jdsmith@as.arizona.edu>
-;; Version: 6.1_em22
+;; Version: 6.1.22
;; Keywords: languages
;; This file is part of GNU Emacs.
@@ -1370,6 +1370,7 @@ list order matters since matching an assignment statement exactly is
not possible without parsing. Thus assignment statement become just
the leftover unidentified statements containing an equal sign.")
+;; FIXME: This var seems to only ever be set, but never actually used!
(defvar idlwave-fill-function 'auto-fill-function
"IDL mode auto fill function.")
@@ -2096,7 +2097,7 @@ Returns non-nil if abbrev is left expanded."
Moves to end of line if there is no comment delimiter.
Ignores comment delimiters in strings.
Returns point if comment found and nil otherwise."
- (let ((eos (progn (end-of-line) (point)))
+ (let ((eos (point-at-eol))
(data (match-data))
found)
;; Look for first comment delimiter not in a string
@@ -2151,7 +2152,7 @@ Also checks if the correct END statement has been used."
;;(backward-char 1)
(let* ((pos (point-marker))
(last-abbrev-marker (copy-marker last-abbrev-location))
- (eol-pos (save-excursion (end-of-line) (point)))
+ (eol-pos (point-at-eol))
begin-pos end-pos end end1 )
(if idlwave-reindent-end (idlwave-indent-line))
(setq last-abbrev-location (marker-position last-abbrev-marker))
@@ -3300,10 +3301,8 @@ ignored."
(setq here (point))
(beginning-of-line)
(setq bcl (point))
- (re-search-forward
- (concat "^[ \t]*" comment-start "+")
- (save-excursion (end-of-line) (point))
- t)
+ (re-search-forward (concat "^[ \t]*" comment-start "+")
+ (point-at-eol) t)
;; Get the comment leader on the line and its length
(setq pre (current-column))
;; the comment leader is the indentation plus exactly the
@@ -3311,10 +3310,7 @@ ignored."
(setq fill-prefix-reg
(concat
(setq fill-prefix
- (regexp-quote
- (buffer-substring (save-excursion
- (beginning-of-line) (point))
- (point))))
+ (regexp-quote (buffer-substring (point-at-bol) (point))))
"[^;]"))
;; Mark the beginning and end of the paragraph
@@ -3368,9 +3364,7 @@ ignored."
(setq indent hang)
(beginning-of-line)
(while (> (point) start)
- (re-search-forward comment-start-skip
- (save-excursion (end-of-line) (point))
- t)
+ (re-search-forward comment-start-skip (point-at-eol) t)
(if (> (setq diff (- indent (current-column))) 0)
(progn
(if (>= here (point))
@@ -3392,13 +3386,9 @@ ignored."
(setq indent
(min indent
(progn
- (re-search-forward
- comment-start-skip
- (save-excursion (end-of-line) (point))
- t)
+ (re-search-forward comment-start-skip (point-at-eol) t)
(current-column))))
- (forward-line -1))
- )
+ (forward-line -1)))
(setq fill-prefix (concat fill-prefix
(make-string (- indent pre)
?\ )))
@@ -3406,10 +3396,7 @@ ignored."
(setq first-indent
(max
(progn
- (re-search-forward
- comment-start-skip
- (save-excursion (end-of-line) (point))
- t)
+ (re-search-forward comment-start-skip (point-at-eol) t)
(current-column))
indent))
@@ -3447,17 +3434,11 @@ If not found returns nil."
(if idlwave-use-last-hang-indent
(save-excursion
(end-of-line)
- (if (re-search-backward
- idlwave-hang-indent-regexp
- (save-excursion (beginning-of-line) (point))
- t)
+ (if (re-search-backward idlwave-hang-indent-regexp (point-at-bol) t)
(+ (current-column) (length idlwave-hang-indent-regexp))))
(save-excursion
(beginning-of-line)
- (if (re-search-forward
- idlwave-hang-indent-regexp
- (save-excursion (end-of-line) (point))
- t)
+ (if (re-search-forward idlwave-hang-indent-regexp (point-at-eol) t)
(current-column)))))
(defun idlwave-auto-fill ()
@@ -3501,18 +3482,14 @@ if `idlwave-auto-fill-split-string' is non-nil."
(save-excursion
(forward-line -1)
(idlwave-calc-hanging-indent))))
- (if indent
- (progn
- ;; Remove whitespace between comment delimiter and
- ;; text, insert spaces for appropriate indentation.
- (beginning-of-line)
- (re-search-forward
- comment-start-skip
- (save-excursion (end-of-line) (point)) t)
- (delete-horizontal-space)
- (idlwave-indent-to indent)
- (goto-char (- (point-max) here)))
- )))
+ (when indent
+ ;; Remove whitespace between comment delimiter and
+ ;; text, insert spaces for appropriate indentation.
+ (beginning-of-line)
+ (re-search-forward comment-start-skip (point-at-eol) t)
+ (delete-horizontal-space)
+ (idlwave-indent-to indent)
+ (goto-char (- (point-max) here)))))
;; Split code or comment?
(if (save-excursion
(end-of-line 0)
@@ -3688,7 +3665,7 @@ constants - a double quote followed by an octal digit."
;; Because single and double quotes can quote each other we must
;; search for the string start from the beginning of line.
(let* ((start (point))
- (eol (progn (end-of-line) (point)))
+ (eol (point-at-eol))
(bq (progn (beginning-of-line) (point)))
(endq (point))
(data (match-data))
@@ -3766,7 +3743,7 @@ unless the optional second argument NOINDENT is non-nil."
(setq s1 (downcase s1) s2 (downcase s2)))
(idlwave-abbrev-change-case
(setq s1 (upcase s1) s2 (upcase s2))))
- (let ((beg (save-excursion (beginning-of-line) (point)))
+ (let ((beg (point-at-bol))
end)
(if (not (looking-at "\\s-*\n"))
(open-line 1))
@@ -6910,9 +6887,10 @@ accumulate information on matching completions."
;;----------------------------------------------------------------------
;;----------------------------------------------------------------------
;;----------------------------------------------------------------------
-(defvar rtn)
-(defun idlwave-pset (item)
- (set 'rtn item))
+(when (featurep 'xemacs)
+ (defvar rtn)
+ (defun idlwave-pset (item)
+ (set 'rtn item)))
(defun idlwave-popup-select (ev list title &optional sort)
"Select an item in LIST with a popup menu.
@@ -7681,8 +7659,7 @@ property indicating the link is added."
t)) ; return t to skip other completions
(t nil))))
-(defvar link) ;dynamic variables set by help callback
-(defvar props)
+(defvar idlw-help-link) ;dynamic variables set by help callback
(defun idlwave-complete-sysvar-help (mode word)
(let ((word (or (nth 1 idlwave-completion-help-info) word))
(entry (assoc word idlwave-system-variables-alist)))
@@ -7690,7 +7667,8 @@ property indicating the link is added."
((eq mode 'test)
(and (stringp word) entry (nth 1 (assq 'link entry))))
((eq mode 'set)
- (if entry (setq link (nth 1 (assq 'link entry))))) ;; setting dynamic!!!
+ ;; Setting dynamic!!!
+ (if entry (setq idlw-help-link (nth 1 (assq 'link entry)))))
(t (error "This should not happen")))))
(defun idlwave-complete-sysvar-tag-help (mode word)
@@ -7704,10 +7682,10 @@ property indicating the link is added."
(and (stringp word) entry main))
((eq mode 'set)
(if entry
- (setq link
+ (setq idlw-help-link
(if (setq target (cdr (assoc-string word tags t)))
- (idlwave-substitute-link-target main target)
- main)))) ;; setting dynamic!!!
+ (idlwave-substitute-link-target main target)
+ main)))) ;; setting dynamic!!!
(t (error "This should not happen")))))
(defun idlwave-split-link-target (link)
@@ -7727,9 +7705,10 @@ property indicating the link is added."
link)))
;; Fake help in the source buffer for class structure tags.
-;; KWD AND NAME ARE GLOBAL-VARIABLES HERE.
-(defvar name)
-(defvar kwd)
+;; IDLW-HELP-LINK AND IDLW-HELP-NAME ARE GLOBAL-VARIABLES HERE.
+;; (from idlwave-do-mouse-completion-help)
+(defvar idlw-help-name)
+(defvar idlw-help-link)
(defvar idlwave-help-do-class-struct-tag nil)
(defun idlwave-complete-class-structure-tag-help (mode word)
(cond
@@ -7745,9 +7724,9 @@ property indicating the link is added."
idlwave-system-class-info)
(error "No help available for system class tags"))
(if (setq found-in (idlwave-class-found-in class-with))
- (setq name (cons (concat found-in "__define") class-with))
- (setq name (concat class-with "__define")))))
- (setq kwd word
+ (setq idlw-help-name (cons (concat found-in "__define") class-with))
+ (setq idlw-help-name (concat class-with "__define")))))
+ (setq idlw-help-link word
idlwave-help-do-class-struct-tag t))
(t (error "This should not happen"))))
@@ -8825,9 +8804,9 @@ the `idlwave-system-routines' list, we omit the latter as
non-dangerous because many IDL routines are implemented as library
routines, and may have been scanned."
(let* ((entry (car entries))
- (name (car entry)) ;
+ (idlwave-twin-name (car entry)) ;
(type (nth 1 entry)) ; Must be bound for
- (class (nth 2 entry)) ; idlwave-routine-twin-compare
+ (idlwave-twin-class (nth 2 entry)) ; idlwave-routine-twin-compare
(cnt 0)
source type type-cons file alist syslibp key)
(while (setq entry (pop entries))
@@ -8869,7 +8848,6 @@ routines, and may have been scanned."
;; FIXME: Dynamically scoped vars need to use the `idlwave-' prefix.
;; (defvar type)
-;; (defvar class)
(defmacro idlwave-xor (a b)
`(and (or ,a ,b)
(not (and ,a ,b))))
@@ -8902,7 +8880,9 @@ names and path locations."
(defun idlwave-routine-entry-compare-twins (a b)
"Compare two routine entries, under the assumption that they are twins.
This basically calls `idlwave-routine-twin-compare' with the correct args."
- (let* ((name (car a)) (type (nth 1 a)) (class (nth 2 a)) ; needed outside
+ (let* ((idlwave-twin-name (car a))
+ (type (nth 1 a))
+ (idlwave-twin-class (nth 2 a)) ; used in idlwave-routine-twin-compare
(asrc (nth 3 a))
(atype (car asrc))
(bsrc (nth 3 b))
@@ -8915,18 +8895,17 @@ This basically calls `idlwave-routine-twin-compare' with the correct args."
(list atype afile (list atype)))
(if (stringp bfile)
(list (file-truename bfile) bfile (list btype))
- (list btype bfile (list btype))))
- ))
+ (list btype bfile (list btype))))))
;; Bound in idlwave-study-twins,idlwave-routine-entry-compare-twins.
-;; FIXME: Dynamically scoped vars need to use the `idlwave-' prefix.
-(defvar class)
+(defvar idlwave-twin-class)
+(defvar idlwave-twin-name)
(defun idlwave-routine-twin-compare (a b)
"Compare two routine twin entries for sorting.
In here, A and B are not normal routine info entries, but special
lists (KEY FILENAME (TYPES...)).
-This expects NAME TYPE CLASS to be bound to the right values."
+This expects NAME TYPE IDLWAVE-TWIN-CLASS to be bound to the right values."
(let* (;; Dis-assemble entries
(akey (car a)) (bkey (car b))
(afile (nth 1 a)) (bfile (nth 1 b))
@@ -8958,16 +8937,19 @@ This expects NAME TYPE CLASS to be bound to the right values."
;; Look at file names
(aname (if (stringp afile) (downcase (file-name-nondirectory afile)) ""))
(bname (if (stringp bfile) (downcase (file-name-nondirectory bfile)) ""))
- (fname-re (if class (format "\\`%s__\\(%s\\|define\\)\\.pro\\'"
- (regexp-quote (downcase class))
- (regexp-quote (downcase name)))
- (format "\\`%s\\.pro" (regexp-quote (downcase name)))))
+ (fname-re (if idlwave-twin-class
+ (format "\\`%s__\\(%s\\|define\\)\\.pro\\'"
+ (regexp-quote (downcase idlwave-twin-class))
+ (regexp-quote (downcase idlwave-twin-name)))
+ (format "\\`%s\\.pro" (regexp-quote (downcase idlwave-twin-name)))))
;; Is file name derived from the routine name?
;; Method file or class definition file?
(anamep (string-match fname-re aname))
- (adefp (and class anamep (string= "define" (match-string 1 aname))))
+ (adefp (and idlwave-twin-class anamep
+ (string= "define" (match-string 1 aname))))
(bnamep (string-match fname-re bname))
- (bdefp (and class bnamep (string= "define" (match-string 1 bname)))))
+ (bdefp (and idlwave-twin-class bnamep
+ (string= "define" (match-string 1 bname)))))
;; Now: follow JD's ideas about sorting. Looks really simple now,
;; doesn't it? The difficult stuff is hidden above...
@@ -8979,7 +8961,7 @@ This expects NAME TYPE CLASS to be bound to the right values."
((idlwave-xor acompp bcompp) acompp) ; Compiled entries
((idlwave-xor apathp bpathp) apathp) ; Library before non-library
((idlwave-xor anamep bnamep) anamep) ; Correct file names first
- ((and class anamep bnamep ; both file names match ->
+ ((and idlwave-twin-class anamep bnamep ; both file names match ->
(idlwave-xor adefp bdefp)) bdefp) ; __define after __method
((> anpath bnpath) t) ; Who is first on path?
(t nil)))) ; Default
@@ -9363,5 +9345,4 @@ This function was written since `list-abbrevs' looks terrible for IDLWAVE mode."
(provide 'idlwave)
-;; arch-tag: f77f3b0c-c37c-424f-a328-0886fd42b6fb
;;; idlwave.el ends here
diff --git a/lisp/progmodes/inf-lisp.el b/lisp/progmodes/inf-lisp.el
index ee5e2a49ead..41ce378e966 100644
--- a/lisp/progmodes/inf-lisp.el
+++ b/lisp/progmodes/inf-lisp.el
@@ -80,19 +80,17 @@ mode. Default is whitespace followed by 0 or 1 single-letter colon-keyword
:type 'regexp
:group 'inferior-lisp)
-(defvar inferior-lisp-mode-map nil)
-(unless inferior-lisp-mode-map
- (setq inferior-lisp-mode-map (copy-keymap comint-mode-map))
- (set-keymap-parent inferior-lisp-mode-map lisp-mode-shared-map)
- (define-key inferior-lisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp)
- (define-key inferior-lisp-mode-map "\C-c\C-l" 'lisp-load-file)
- (define-key inferior-lisp-mode-map "\C-c\C-k" 'lisp-compile-file)
- (define-key inferior-lisp-mode-map "\C-c\C-a" 'lisp-show-arglist)
- (define-key inferior-lisp-mode-map "\C-c\C-d" 'lisp-describe-sym)
- (define-key inferior-lisp-mode-map "\C-c\C-f"
- 'lisp-show-function-documentation)
- (define-key inferior-lisp-mode-map "\C-c\C-v"
- 'lisp-show-variable-documentation))
+(defvar inferior-lisp-mode-map
+ (let ((map (copy-keymap comint-mode-map)))
+ (set-keymap-parent map lisp-mode-shared-map)
+ (define-key map "\C-x\C-e" 'lisp-eval-last-sexp)
+ (define-key map "\C-c\C-l" 'lisp-load-file)
+ (define-key map "\C-c\C-k" 'lisp-compile-file)
+ (define-key map "\C-c\C-a" 'lisp-show-arglist)
+ (define-key map "\C-c\C-d" 'lisp-describe-sym)
+ (define-key map "\C-c\C-f" 'lisp-show-function-documentation)
+ (define-key map "\C-c\C-v" 'lisp-show-variable-documentation)
+ map))
;;; These commands augment Lisp mode, so you can process Lisp code in
;;; the source files.
diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el
index 60ed14afbac..6114a0e15b2 100644
--- a/lisp/progmodes/js.el
+++ b/lisp/progmodes/js.el
@@ -7,7 +7,7 @@
;; Maintainer: Daniel Colascione <dan.colascione@gmail.com>
;; Version: 9
;; Date: 2009-07-25
-;; Keywords: languages, oop, javascript
+;; Keywords: languages, javascript
;; This file is part of GNU Emacs.
@@ -45,16 +45,16 @@
;;; Code:
-(eval-and-compile
- (require 'cc-mode)
- (require 'font-lock)
- (require 'newcomment)
- (require 'imenu)
- (require 'etags)
- (require 'thingatpt)
- (require 'easymenu)
- (require 'moz nil t)
- (require 'json nil t))
+
+(require 'cc-mode)
+(require 'font-lock)
+(require 'newcomment)
+(require 'imenu)
+(require 'etags)
+(require 'thingatpt)
+(require 'easymenu)
+(require 'moz nil t)
+(require 'json nil t)
(eval-when-compile
(require 'cl)
@@ -431,11 +431,32 @@ Match group 1 is the name of the macro.")
:group 'js)
(defcustom js-expr-indent-offset 0
- "Number of additional spaces used for indentation of continued expressions.
+ "Number of additional spaces for indenting continued expressions.
The value must be no less than minus `js-indent-level'."
:type 'integer
:group 'js)
+(defcustom js-paren-indent-offset 0
+ "Number of additional spaces for indenting expressions in parentheses.
+The value must be no less than minus `js-indent-level'."
+ :type 'integer
+ :group 'js
+ :version "24.1")
+
+(defcustom js-square-indent-offset 0
+ "Number of additional spaces for indenting expressions in square braces.
+The value must be no less than minus `js-indent-level'."
+ :type 'integer
+ :group 'js
+ :version "24.1")
+
+(defcustom js-curly-indent-offset 0
+ "Number of additional spaces for indenting expressions in curly braces.
+The value must be no less than minus `js-indent-level'."
+ :type 'integer
+ :group 'js
+ :version "24.1")
+
(defcustom js-auto-indent-flag t
"Whether to automatically indent when typing punctuation characters.
If non-nil, the characters {}();,: also indent the current line
@@ -682,7 +703,7 @@ point at BOB."
(setq str-terminator ?/))
(re-search-forward
(concat "\\([^\\]\\|^\\)" (string str-terminator))
- (save-excursion (end-of-line) (point)) t))
+ (point-at-eol) t))
((nth 7 parse)
(forward-line))
((or (nth 4 parse)
@@ -704,20 +725,19 @@ as if strings, cpp macros, and comments have been removed.
If invoked while inside a macro, it treats the contents of the
macro as normal text."
+ (unless count (setq count 1))
(let ((saved-point (point))
- (search-expr
- (cond ((null count)
- '(js--re-search-forward-inner regexp bound 1))
- ((< count 0)
- '(js--re-search-backward-inner regexp bound (- count)))
- ((> count 0)
- '(js--re-search-forward-inner regexp bound count)))))
+ (search-fun
+ (cond ((< count 0) (setq count (- count))
+ #'js--re-search-backward-inner)
+ ((> count 0) #'js--re-search-forward-inner)
+ (t #'ignore))))
(condition-case err
- (eval search-expr)
+ (funcall search-fun regexp bound count)
(search-failed
(goto-char saved-point)
(unless noerror
- (error (error-message-string err)))))))
+ (signal (car err) (cdr err)))))))
(defun js--re-search-backward-inner (regexp &optional bound count)
@@ -739,7 +759,7 @@ macro as normal text."
(setq str-terminator ?/))
(re-search-backward
(concat "\\([^\\]\\|^\\)" (string str-terminator))
- (save-excursion (beginning-of-line) (point)) t))
+ (point-at-bol) t))
((nth 7 parse)
(goto-char (nth 8 parse)))
((or (nth 4 parse)
@@ -761,20 +781,7 @@ as if strings, preprocessor macros, and comments have been
removed.
If invoked while inside a macro, treat the macro as normal text."
- (let ((saved-point (point))
- (search-expr
- (cond ((null count)
- '(js--re-search-backward-inner regexp bound 1))
- ((< count 0)
- '(js--re-search-forward-inner regexp bound (- count)))
- ((> count 0)
- '(js--re-search-backward-inner regexp bound count)))))
- (condition-case err
- (eval search-expr)
- (search-failed
- (goto-char saved-point)
- (unless noerror
- (error (error-message-string err)))))))
+ (js--re-search-forward regexp bound noerror (if count (- count) -1)))
(defun js--forward-expression ()
"Move forward over a whole JavaScript expression.
@@ -1653,18 +1660,19 @@ This performs fontification according to `js--class-styles'."
;; XXX: Javascript can continue a regexp literal across lines so long
;; as the newline is escaped with \. Account for that in the regexp
;; below.
-(defconst js--regexp-literal
+(eval-and-compile
+ (defconst js--regexp-literal
"[=(,:]\\(?:\\s-\\|\n\\)*\\(/\\)\\(?:\\\\/\\|[^/*]\\)\\(?:\\\\/\\|[^/]\\)*\\(/\\)"
"Regexp matching a JavaScript regular expression literal.
Match groups 1 and 2 are the characters forming the beginning and
-end of the literal.")
+end of the literal."))
-;; we want to match regular expressions only at the beginning of
-;; expressions
-(defconst js-font-lock-syntactic-keywords
- `((,js--regexp-literal (1 "|") (2 "|")))
- "Syntactic font lock keywords matching regexps in JavaScript.
-See `font-lock-keywords'.")
+
+(defconst js-syntax-propertize-function
+ (syntax-propertize-rules
+ ;; We want to match regular expressions only at the beginning of
+ ;; expressions.
+ (js--regexp-literal (1 "\"") (2 "\""))))
;;; Indentation
@@ -1769,14 +1777,17 @@ nil."
((eq (char-after) ?#) 0)
((save-excursion (js--beginning-of-macro)) 4)
((nth 1 parse-status)
+ ;; A single closing paren/bracket should be indented at the
+ ;; same level as the opening statement. Same goes for
+ ;; "case" and "default".
(let ((same-indent-p (looking-at
"[]})]\\|\\_<case\\_>\\|\\_<default\\_>"))
(continued-expr-p (js--continued-expression-p)))
- (goto-char (nth 1 parse-status))
+ (goto-char (nth 1 parse-status)) ; go to the opening char
(if (looking-at "[({[]\\s-*\\(/[/*]\\|$\\)")
- (progn
+ (progn ; nothing following the opening paren/bracket
(skip-syntax-backward " ")
- (when (eq (char-before) ?\)) (backward-list))
+ (when (eq (char-before) ?\)) (backward-list))
(back-to-indentation)
(cond (same-indent-p
(current-column))
@@ -1784,7 +1795,14 @@ nil."
(+ (current-column) (* 2 js-indent-level)
js-expr-indent-offset))
(t
- (+ (current-column) js-indent-level))))
+ (+ (current-column) js-indent-level
+ (case (char-after (nth 1 parse-status))
+ (?\( js-paren-indent-offset)
+ (?\[ js-square-indent-offset)
+ (?\{ js-curly-indent-offset))))))
+ ;; If there is something following the opening
+ ;; paren/bracket, everything else should be indented at
+ ;; the same level.
(unless same-indent-p
(forward-char)
(skip-chars-forward " \t"))
@@ -3268,7 +3286,7 @@ If one hasn't been set, or if it's stale, prompt for a new one."
;;; Main Function
;;;###autoload
-(define-derived-mode js-mode nil "js"
+(define-derived-mode js-mode prog-mode "js"
"Major mode for editing JavaScript.
Key bindings:
@@ -3286,10 +3304,9 @@ Key bindings:
(set (make-local-variable 'open-paren-in-column-0-is-defun-start) nil)
(set (make-local-variable 'font-lock-defaults)
- (list js--font-lock-keywords
- nil nil nil nil
- '(font-lock-syntactic-keywords
- . js-font-lock-syntactic-keywords)))
+ (list js--font-lock-keywords))
+ (set (make-local-variable 'syntax-propertize-function)
+ js-syntax-propertize-function)
(set (make-local-variable 'parse-sexp-ignore-comments) t)
(set (make-local-variable 'parse-sexp-lookup-properties) t)
@@ -3360,5 +3377,4 @@ Key bindings:
(provide 'js)
-;; arch-tag: 1a0d0409-e87f-4fc7-a58c-3731c66ddaac
;; js.el ends here
diff --git a/lisp/progmodes/ld-script.el b/lisp/progmodes/ld-script.el
index 3d07ed226b2..318456e9534 100644
--- a/lisp/progmodes/ld-script.el
+++ b/lisp/progmodes/ld-script.el
@@ -1,7 +1,7 @@
;;; ld-script.el --- GNU linker script editing mode for Emacs
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+;; 2010 Free Software Foundation, Inc.
;; Author: Masatake YAMATO<jet@gyve.org>
;; Keywords: languages, faces
@@ -76,20 +76,20 @@
(defvar ld-script-keywords
'(
;; 3.4.1 Setting the Entry Point
- "ENTRY"
+ "ENTRY"
;; 3.4.2 Commands Dealing with Files
"INCLUDE" "INPUT" "GROUP" "AS_NEEDED" "OUTPUT" "SEARCH_DIR" "STARTUP"
;; 3.4.3 Commands Dealing with Object File Formats
"OUTPUT_FORMAT" "TARGET"
;; 3.4.3 Other Linker Script Commands
- "ASSERT" "EXTERN" "FORCE_COMMON_ALLOCATION"
+ "ASSERT" "EXTERN" "FORCE_COMMON_ALLOCATION"
"INHIBIT_COMMON_ALLOCATION" "NOCROSSREFS" "OUTPUT_ARCH"
;; 3.5.2 PROVIDE
"PROVIDE"
;; 3.5.3 PROVIDE_HIDDEN
"PROVIDE_HIDDEN"
;; 3.6 SECTIONS Command
- "SECTIONS"
+ "SECTIONS"
;; 3.6.4.2 Input Section Wildcard Patterns
"SORT" "SORT_BY_NAME" "SORT_BY_ALIGNMENT"
;; 3.6.4.3 Input Section for Common Symbols
@@ -157,18 +157,6 @@
cpp-font-lock-keywords)
"Default font-lock-keywords for `ld-script-mode'.")
-;; Linux-2.6.9 uses some different suffix for linker scripts:
-;; "ld", "lds", "lds.S", "lds.in", "ld.script", and "ld.script.balo".
-;; eCos uses "ld" and "ldi".
-;; Netbsd uses "ldscript.*".
-;;;###autoload
-(add-to-list 'auto-mode-alist (purecopy '("\\.ld[si]?\\>" . ld-script-mode)))
-;;;###autoload
-(add-to-list 'auto-mode-alist (purecopy '("ld\\.?script\\>" . ld-script-mode)))
-
-;;;###autoload
-(add-to-list 'auto-mode-alist (purecopy '("\\.x[bdsru]?[cn]?\\'" . ld-script-mode)))
-
;;;###autoload
(define-derived-mode ld-script-mode nil "LD-Script"
"A major mode to edit GNU ld script files"
diff --git a/lisp/progmodes/make-mode.el b/lisp/progmodes/make-mode.el
index d45ecd47907..187c838382b 100644
--- a/lisp/progmodes/make-mode.el
+++ b/lisp/progmodes/make-mode.el
@@ -281,8 +281,7 @@ not be enclosed in { } or ( )."
"Regex used to highlight makepp rule action lines in font lock mode.")
(defconst makefile-bsdmake-rule-action-regex
- (progn (string-match "-@" makefile-rule-action-regex)
- (replace-match "-+@" t t makefile-rule-action-regex))
+ (replace-regexp-in-string "-@" "-+@" makefile-rule-action-regex)
"Regex used to highlight BSD rule action lines in font lock mode.")
;; Note that the first and second subexpression is used by font lock. Note
@@ -506,40 +505,41 @@ not be enclosed in { } or ( )."
cpp-font-lock-keywords))
-(defconst makefile-font-lock-syntactic-keywords
- ;; From sh-script.el.
- ;; A `#' begins a comment in sh when it is unquoted and at the beginning
- ;; of a word. In the shell, words are separated by metacharacters.
- ;; The list of special chars is taken from the single-unix spec of the
- ;; shell command language (under `quoting') but with `$' removed.
- '(("[^|&;<>()`\\\"' \t\n]\\(#+\\)" 1 "_")
- ;; Change the syntax of a quoted newline so that it does not end a comment.
- ("\\\\\n" 0 ".")))
+(defconst makefile-syntax-propertize-function
+ (syntax-propertize-rules
+ ;; From sh-script.el.
+ ;; A `#' begins a comment in sh when it is unquoted and at the beginning
+ ;; of a word. In the shell, words are separated by metacharacters.
+ ;; The list of special chars is taken from the single-unix spec of the
+ ;; shell command language (under `quoting') but with `$' removed.
+ ("[^|&;<>()`\\\"' \t\n]\\(#+\\)" (1 "_"))
+ ;; Change the syntax of a quoted newline so that it does not end a comment.
+ ("\\\\\n" (0 "."))))
(defvar makefile-imenu-generic-expression
`(("Dependencies" makefile-previous-dependency 1)
("Macro Assignment" ,makefile-macroassign-regex 1))
"Imenu generic expression for Makefile mode. See `imenu-generic-expression'.")
-;;; ------------------------------------------------------------
-;;; The following configurable variables are used in the
-;;; up-to-date overview .
-;;; The standard configuration assumes that your `make' program
-;;; can be run in question/query mode using the `-q' option, this
-;;; means that the command
-;;;
-;;; make -q foo
-;;;
-;;; should return an exit status of zero if the target `foo' is
-;;; up to date and a nonzero exit status otherwise.
-;;; Many makes can do this although the docs/manpages do not mention
-;;; it. Try it with your favourite one. GNU make, System V make, and
-;;; Dennis Vadura's DMake have no problems.
-;;; Set the variable `makefile-brave-make' to the name of the
-;;; make utility that does this on your system.
-;;; To understand what this is all about see the function definition
-;;; of `makefile-query-by-make-minus-q' .
-;;; ------------------------------------------------------------
+;; ------------------------------------------------------------
+;; The following configurable variables are used in the
+;; up-to-date overview .
+;; The standard configuration assumes that your `make' program
+;; can be run in question/query mode using the `-q' option, this
+;; means that the command
+;;
+;; make -q foo
+;;
+;; should return an exit status of zero if the target `foo' is
+;; up to date and a nonzero exit status otherwise.
+;; Many makes can do this although the docs/manpages do not mention
+;; it. Try it with your favourite one. GNU make, System V make, and
+;; Dennis Vadura's DMake have no problems.
+;; Set the variable `makefile-brave-make' to the name of the
+;; make utility that does this on your system.
+;; To understand what this is all about see the function definition
+;; of `makefile-query-by-make-minus-q' .
+;; ------------------------------------------------------------
(defcustom makefile-brave-make "make"
"*How to invoke make, for `makefile-query-targets'.
@@ -574,11 +574,8 @@ The function must satisfy this calling convention:
;;; --- end of up-to-date-overview configuration ------------------
-(defvar makefile-mode-abbrev-table nil
+(define-abbrev-table 'makefile-mode-abbrev-table ()
"Abbrev table in use in Makefile buffers.")
-(if makefile-mode-abbrev-table
- ()
- (define-abbrev-table 'makefile-mode-abbrev-table ()))
(defvar makefile-mode-map
(let ((map (make-sparse-keymap))
@@ -706,15 +703,13 @@ The function must satisfy this calling convention:
(modify-syntax-entry ?\n "> " st)
st))
-(defvar makefile-imake-mode-syntax-table (copy-syntax-table
- makefile-mode-syntax-table))
-(if makefile-imake-mode-syntax-table
- ()
- (modify-syntax-entry ?/ ". 14" makefile-imake-mode-syntax-table)
- (modify-syntax-entry ?* ". 23" makefile-imake-mode-syntax-table)
- (modify-syntax-entry ?# "'" makefile-imake-mode-syntax-table)
- (modify-syntax-entry ?\n ". b" makefile-imake-mode-syntax-table))
-
+(defvar makefile-imake-mode-syntax-table
+ (let ((st (make-syntax-table makefile-mode-syntax-table)))
+ (modify-syntax-entry ?/ ". 14" st)
+ (modify-syntax-entry ?* ". 23" st)
+ (modify-syntax-entry ?# "'" st)
+ (modify-syntax-entry ?\n ". b" st)
+ st))
;;; ------------------------------------------------------------
;;; Internal variables.
@@ -774,7 +769,7 @@ The function must satisfy this calling convention:
;;; ------------------------------------------------------------
;;;###autoload
-(defun makefile-mode ()
+(define-derived-mode makefile-mode prog-mode "Makefile"
"Major mode for editing standard Makefiles.
If you are editing a file for a different make, try one of the
@@ -858,9 +853,6 @@ Makefile mode can be configured by modifying the following variables:
List of special targets. You will be offered to complete
on one of those in the minibuffer whenever you enter a `.'.
at the beginning of a line in Makefile mode."
-
- (interactive)
- (kill-all-local-variables)
(add-hook 'write-file-functions
'makefile-warn-suspicious-lines nil t)
(add-hook 'write-file-functions
@@ -874,59 +866,44 @@ Makefile mode can be configured by modifying the following variables:
(make-local-variable 'makefile-need-macro-pickup)
;; Font lock.
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults
- ;; SYNTAX-BEGIN set to backward-paragraph to avoid slow-down
- ;; near the end of a large buffer, due to parse-partial-sexp's
- ;; trying to parse all the way till the beginning of buffer.
- '(makefile-font-lock-keywords
- nil nil
- ((?$ . "."))
- backward-paragraph
- (font-lock-syntactic-keywords
- . makefile-font-lock-syntactic-keywords)))
+ (set (make-local-variable 'font-lock-defaults)
+ ;; SYNTAX-BEGIN set to backward-paragraph to avoid slow-down
+ ;; near the end of a large buffer, due to parse-partial-sexp's
+ ;; trying to parse all the way till the beginning of buffer.
+ '(makefile-font-lock-keywords
+ nil nil
+ ((?$ . "."))
+ backward-paragraph))
+ (set (make-local-variable 'syntax-propertize-function)
+ makefile-syntax-propertize-function)
;; Add-log.
- (make-local-variable 'add-log-current-defun-function)
- (setq add-log-current-defun-function 'makefile-add-log-defun)
+ (set (make-local-variable 'add-log-current-defun-function)
+ 'makefile-add-log-defun)
;; Imenu.
- (make-local-variable 'imenu-generic-expression)
- (setq imenu-generic-expression makefile-imenu-generic-expression)
+ (set (make-local-variable 'imenu-generic-expression)
+ makefile-imenu-generic-expression)
;; Dabbrev.
- (make-local-variable 'dabbrev-abbrev-skip-leading-regexp)
- (setq dabbrev-abbrev-skip-leading-regexp "\\$")
+ (set (make-local-variable 'dabbrev-abbrev-skip-leading-regexp) "\\$")
;; Other abbrevs.
(setq local-abbrev-table makefile-mode-abbrev-table)
;; Filling.
- (make-local-variable 'fill-paragraph-function)
- (setq fill-paragraph-function 'makefile-fill-paragraph)
+ (set (make-local-variable 'fill-paragraph-function) 'makefile-fill-paragraph)
;; Comment stuff.
- (make-local-variable 'comment-start)
- (setq comment-start "#")
- (make-local-variable 'comment-end)
- (setq comment-end "")
- (make-local-variable 'comment-start-skip)
- (setq comment-start-skip "#+[ \t]*")
+ (set (make-local-variable 'comment-start) "#")
+ (set (make-local-variable 'comment-end) "")
+ (set (make-local-variable 'comment-start-skip) "#+[ \t]*")
;; Make sure TAB really inserts \t.
(set (make-local-variable 'indent-line-function) 'indent-to-left-margin)
- ;; become the current major mode
- (setq major-mode 'makefile-mode)
- (setq mode-name "Makefile")
-
- ;; Activate keymap and syntax table.
- (use-local-map makefile-mode-map)
- (set-syntax-table makefile-mode-syntax-table)
-
;; Real TABs are important in makefiles
- (setq indent-tabs-mode t)
- (run-mode-hooks 'makefile-mode-hook))
+ (setq indent-tabs-mode t))
;; These should do more than just differentiate font-lock.
;;;###autoload
@@ -967,15 +944,9 @@ Makefile mode can be configured by modifying the following variables:
(define-derived-mode makefile-imake-mode makefile-mode "Imakefile"
"An adapted `makefile-mode' that knows about imake."
:syntax-table makefile-imake-mode-syntax-table
- (let ((base `(makefile-imake-font-lock-keywords ,@(cdr font-lock-defaults)))
- new)
- ;; Remove `font-lock-syntactic-keywords' entry from font-lock-defaults.
- (mapc (lambda (elt)
- (unless (and (consp elt)
- (eq (car elt) 'font-lock-syntactic-keywords))
- (setq new (cons elt new))))
- base)
- (setq font-lock-defaults (nreverse new))))
+ (set (make-local-variable 'syntax-propertize-function) nil)
+ (setq font-lock-defaults
+ `(makefile-imake-font-lock-keywords ,@(cdr font-lock-defaults))))
diff --git a/lisp/progmodes/meta-mode.el b/lisp/progmodes/meta-mode.el
index 70b38dc3999..294c75c9ccf 100644
--- a/lisp/progmodes/meta-mode.el
+++ b/lisp/progmodes/meta-mode.el
@@ -1,7 +1,7 @@
;;; meta-mode.el --- major mode for editing Metafont or MetaPost sources
-;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+;; 2009, 2010 Free Software Foundation, Inc.
;; Author: Ulrik Vieth <vieth@thphy.uni-duesseldorf.de>
;; Version: 1.0
@@ -517,24 +517,24 @@ If the list was changed, sort the list and remove duplicates first."
;;; Indentation.
(defcustom meta-indent-level 2
- "*Indentation of begin-end blocks in Metafont or MetaPost mode."
+ "Indentation of begin-end blocks in Metafont or MetaPost mode."
:type 'integer
:group 'meta-font)
(defcustom meta-left-comment-regexp "%%+"
- "*Regexp matching comments that should be placed on the left margin."
+ "Regexp matching comments that should be placed on the left margin."
:type 'regexp
:group 'meta-font)
(defcustom meta-right-comment-regexp nil
- "*Regexp matching comments that should be placed to the right margin."
+ "Regexp matching comments that should be placed to the right margin."
:type '(choice regexp
(const :tag "None" nil))
:group 'meta-font)
(defcustom meta-ignore-comment-regexp "%[^%]"
- "*Regexp matching comments that whose indentation should not be touched."
+ "Regexp matching comments that whose indentation should not be touched."
:type 'regexp
:group 'meta-font)
@@ -543,21 +543,21 @@ If the list was changed, sort the list and remove duplicates first."
(concat "\\(begin\\(char\\|fig\\|gr\\(aph\\|oup\\)\\|logochar\\)\\|"
"def\\|for\\(\\|ever\\|suffixes\\)\\|if\\|mode_def\\|"
"primarydef\\|secondarydef\\|tertiarydef\\|vardef\\)")
- "*Regexp matching the beginning of environments to be indented."
+ "Regexp matching the beginning of environments to be indented."
:type 'regexp
:group 'meta-font)
(defcustom meta-end-environment-regexp
(concat "\\(end\\(char\\|def\\|f\\(ig\\|or\\)\\|gr\\(aph\\|oup\\)\\)"
"\\|fi\\)")
- "*Regexp matching the end of environments to be indented."
+ "Regexp matching the end of environments to be indented."
:type 'regexp
:group 'meta-font)
(defcustom meta-within-environment-regexp
; (concat "\\(e\\(lse\\(\\|if\\)\\|xit\\(if\\|unless\\)\\)\\)")
(concat "\\(else\\(\\|if\\)\\)")
- "*Regexp matching keywords within environments not to be indented."
+ "Regexp matching keywords within environments not to be indented."
:type 'regexp
:group 'meta-font)
@@ -575,12 +575,11 @@ If the list was changed, sort the list and remove duplicates first."
"Indent the line containing point as Metafont or MetaPost source."
(interactive)
(let ((indent (meta-indent-calculate)))
- (save-excursion
- (if (/= (current-indentation) indent)
- (let ((beg (progn (beginning-of-line) (point)))
- (end (progn (back-to-indentation) (point))))
- (delete-region beg end)
- (indent-to indent))))
+ (if (/= (current-indentation) indent)
+ (save-excursion
+ (delete-region (line-beginning-position)
+ (progn (back-to-indentation) (point)))
+ (indent-to indent)))
(if (< (current-column) indent)
(back-to-indentation))))
@@ -744,13 +743,13 @@ If the list was changed, sort the list and remove duplicates first."
(defcustom meta-begin-defun-regexp
(concat "\\(begin\\(char\\|fig\\|logochar\\)\\|def\\|mode_def\\|"
"primarydef\\|secondarydef\\|tertiarydef\\|vardef\\)")
- "*Regexp matching beginning of defuns in Metafont or MetaPost mode."
+ "Regexp matching beginning of defuns in Metafont or MetaPost mode."
:type 'regexp
:group 'meta-font)
(defcustom meta-end-defun-regexp
(concat "\\(end\\(char\\|def\\|fig\\)\\)")
- "*Regexp matching the end of defuns in Metafont or MetaPost mode."
+ "Regexp matching the end of defuns in Metafont or MetaPost mode."
:type 'regexp
:group 'meta-font)
@@ -955,21 +954,21 @@ The environment marked is the one that contains point or follows point."
;;; Hook variables.
(defcustom meta-mode-load-hook nil
- "*Hook evaluated when first loading Metafont or MetaPost mode."
+ "Hook evaluated when first loading Metafont or MetaPost mode."
:type 'hook
:group 'meta-font)
(defcustom meta-common-mode-hook nil
- "*Hook evaluated by both `metafont-mode' and `metapost-mode'."
+ "Hook evaluated by both `metafont-mode' and `metapost-mode'."
:type 'hook
:group 'meta-font)
(defcustom metafont-mode-hook nil
- "*Hook evaluated by `metafont-mode' after `meta-common-mode-hook'."
+ "Hook evaluated by `metafont-mode' after `meta-common-mode-hook'."
:type 'hook
:group 'meta-font)
(defcustom metapost-mode-hook nil
- "*Hook evaluated by `metapost-mode' after `meta-common-mode-hook'."
+ "Hook evaluated by `metapost-mode' after `meta-common-mode-hook'."
:type 'hook
:group 'meta-font)
@@ -1084,5 +1083,4 @@ Turning on MetaPost mode calls the value of the variable
(provide 'meta-mode)
(run-hooks 'meta-mode-load-hook)
-;; arch-tag: ec2916b2-3a83-4cf7-962d-d8019370c006
;;; meta-mode.el ends here
diff --git a/lisp/progmodes/mixal-mode.el b/lisp/progmodes/mixal-mode.el
index 5b1fc712477..f2a7aa045e4 100644
--- a/lisp/progmodes/mixal-mode.el
+++ b/lisp/progmodes/mixal-mode.el
@@ -7,7 +7,7 @@
;; Maintainer: Pieter E.J. Pareit <pieter.pareit@gmail.com>
;; Created: 09 Nov 2002
;; Version: 0.1
-;; Keywords: languages Knuth mix mixal asm mixvm "The Art Of Computer Programming"
+;; Keywords: languages, Knuth, mix, mixal, asm, mixvm, The Art Of Computer Programming
;; This file is part of GNU Emacs.
@@ -89,7 +89,7 @@
(defvar mixal-mode-syntax-table
(let ((st (make-syntax-table)))
;; We need to do a bit more to make fontlocking for comments work.
- ;; See mixal-font-lock-syntactic-keywords.
+ ;; See use of syntax-propertize-function.
;; (modify-syntax-entry ?* "<" st)
(modify-syntax-entry ?\n ">" st)
st)
@@ -125,7 +125,7 @@ value.")
(defvar mixal-operation-codes-alist
;; FIXME: the codes FADD, FSUB, FMUL, FDIV, JRAD, and FCMP were in
;; mixal-operation-codes but not here. They should probably be added here.
- ;;
+ ;;
;; We used to define this with a backquote and subexps like ,(+ 8 3) for
;; better clarity, but the resulting code was too big and caused the
;; byte-compiler to eat up all the stack space. Even using
@@ -1028,13 +1028,14 @@ EXECUTION-TIME holds info about the time it takes, number or string.")
;;; Font-locking:
-(defvar mixal-font-lock-syntactic-keywords
- ;; Normal comments start with a * in column 0 and end at end of line.
- '(("^\\*" (0 '(11))) ;(string-to-syntax "<") == '(11)
- ;; Every line can end with a comment which is placed after the operand.
- ;; I assume here that mnemonics without operands can not have a comment.
- ("^[[:alnum:]]*[ \t]+[[:alnum:]]+[ \t]+[^ \n\t]+[ \t]*\\([ \t]\\)[^\n \t]"
- (1 '(11)))))
+(defconst mixal-syntax-propertize-function
+ (syntax-propertize-rules
+ ;; Normal comments start with a * in column 0 and end at end of line.
+ ("^\\*" (0 "<"))
+ ;; Every line can end with a comment which is placed after the operand.
+ ;; I assume here that mnemonics without operands can not have a comment.
+ ("^[[:alnum:]]*[ \t]+[[:alnum:]]+[ \t]+[^ \n\t]+[ \t]*\\([ \t]\\)[^\n \t]"
+ (1 "<"))))
(defvar mixal-font-lock-keywords
`(("^\\([A-Z0-9a-z]+\\)"
@@ -1110,9 +1111,9 @@ Assumes that file has been compiled with debugging support."
(set (make-local-variable 'comment-start) "*")
(set (make-local-variable 'comment-start-skip) "^\\*[ \t]*")
(set (make-local-variable 'font-lock-defaults)
- `(mixal-font-lock-keywords nil nil nil nil
- (font-lock-syntactic-keywords . ,mixal-font-lock-syntactic-keywords)
- (parse-sexp-lookup-properties . t)))
+ `(mixal-font-lock-keywords))
+ (set (make-local-variable 'syntax-propertize-function)
+ mixal-syntax-propertize-function)
;; might add an indent function in the future
;; (set (make-local-variable 'indent-line-function) 'mixal-indent-line)
(set (make-local-variable 'compile-command) (concat "mixasm "
@@ -1122,9 +1123,6 @@ Assumes that file has been compiled with debugging support."
(set (make-local-variable 'require-final-newline)
mode-require-final-newline))
-;;;###autoload
-(add-to-list 'auto-mode-alist '("\\.mixal\\'" . mixal-mode))
-
(provide 'mixal-mode)
;; arch-tag: be7c128a-bf61-4951-a90e-9398267ce3f3
diff --git a/lisp/progmodes/modula2.el b/lisp/progmodes/modula2.el
index 9d226cefbd4..c6ab5347065 100644
--- a/lisp/progmodes/modula2.el
+++ b/lisp/progmodes/modula2.el
@@ -22,6 +22,8 @@
;;; Code:
+(require 'smie)
+
(defgroup modula2 nil
"Major mode for editing Modula-2 code."
:link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces)
@@ -29,7 +31,22 @@
:group 'languages)
;;; Added by Tom Perrine (TEP)
-(defvar m2-mode-syntax-table nil
+(defvar m2-mode-syntax-table
+ (let ((table (make-syntax-table)))
+ (modify-syntax-entry ?\\ "\\" table)
+ (modify-syntax-entry ?/ ". 12" table)
+ (modify-syntax-entry ?\n ">" table)
+ (modify-syntax-entry ?\( "()1" table)
+ (modify-syntax-entry ?\) ")(4" table)
+ (modify-syntax-entry ?* ". 23nb" table)
+ (modify-syntax-entry ?+ "." table)
+ (modify-syntax-entry ?- "." table)
+ (modify-syntax-entry ?= "." table)
+ (modify-syntax-entry ?% "." table)
+ (modify-syntax-entry ?< "." table)
+ (modify-syntax-entry ?> "." table)
+ (modify-syntax-entry ?\' "\"" table)
+ table)
"Syntax table in use in Modula-2 buffers.")
(defcustom m2-compile-command "m2c"
@@ -52,29 +69,10 @@
:type 'integer
:group 'modula2)
-(if m2-mode-syntax-table
- ()
- (let ((table (make-syntax-table)))
- (modify-syntax-entry ?\\ "\\" table)
- (modify-syntax-entry ?\( ". 1" table)
- (modify-syntax-entry ?\) ". 4" table)
- (modify-syntax-entry ?* ". 23" table)
- (modify-syntax-entry ?+ "." table)
- (modify-syntax-entry ?- "." table)
- (modify-syntax-entry ?= "." table)
- (modify-syntax-entry ?% "." table)
- (modify-syntax-entry ?< "." table)
- (modify-syntax-entry ?> "." table)
- (modify-syntax-entry ?\' "\"" table)
- (setq m2-mode-syntax-table table)))
-
;;; Added by TEP
-(defvar m2-mode-map nil
- "Keymap used in Modula-2 mode.")
-
-(if m2-mode-map ()
+(defvar m2-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "\^i" 'm2-tab)
+ ;; FIXME: Many of those bindings are contrary to coding conventions.
(define-key map "\C-cb" 'm2-begin)
(define-key map "\C-cc" 'm2-case)
(define-key map "\C-cd" 'm2-definition)
@@ -97,21 +95,197 @@
(define-key map "\C-cy" 'm2-import)
(define-key map "\C-c{" 'm2-begin-comment)
(define-key map "\C-c}" 'm2-end-comment)
- (define-key map "\C-j" 'm2-newline)
(define-key map "\C-c\C-z" 'suspend-emacs)
(define-key map "\C-c\C-v" 'm2-visit)
(define-key map "\C-c\C-t" 'm2-toggle)
(define-key map "\C-c\C-l" 'm2-link)
(define-key map "\C-c\C-c" 'm2-compile)
- (setq m2-mode-map map)))
+ map)
+ "Keymap used in Modula-2 mode.")
(defcustom m2-indent 5
"*This variable gives the indentation in Modula-2-Mode."
:type 'integer
:group 'modula2)
+(put 'm2-indent 'safe-local-variable
+ (lambda (v) (or (null v) (integerp v))))
+
+(defconst m2-smie-grammar
+ ;; An official definition can be found as "M2R10.pdf". This grammar does
+ ;; not really follow it, for lots of technical reasons, but it can still be
+ ;; useful to refer to it.
+ (smie-prec2->grammar
+ (smie-merge-prec2s
+ (smie-bnf->prec2
+ '((range) (id) (epsilon)
+ (fields (fields ";" fields) (ids ":" type))
+ (proctype (id ":" type))
+ (type ("RECORD" fields "END")
+ ("POINTER" "TO" type)
+ ;; The PROCEDURE type is indistinguishable from the beginning
+ ;; of a PROCEDURE definition, so we need a "PROCEDURE-type" to
+ ;; prevent SMIE from trying to find the matching END.
+ ("PROCEDURE-type" proctype)
+ ;; OF's right hand side should bind tighter than ; for array
+ ;; types, but should bind less tight than | which itself binds
+ ;; less tight than ;. So we use two distinct OFs.
+ ("SET" "OF-type" id)
+ ("ARRAY" range "OF-type" type))
+ (args ("(" fargs ")"))
+ ;; VAR has lower precedence than ";" in formal args, but not
+ ;; in declarations. So we use "VAR-arg" for the formal arg case.
+ (farg (ids ":" type) ("CONST-arg" farg) ("VAR-arg" farg))
+ (fargs (fargs ";" fargs) (farg))
+ ;; Handling of PROCEDURE in decls is problematic: we'd want
+ ;; TYPE/CONST/VAR/PROCEDURE's parent to be any previous
+ ;; CONST/TYPE/VAR/PROCEDURE, but we also want PROCEDURE to be an opener
+ ;; (so that its END has PROCEDURE as its parent). So instead, we treat
+ ;; the last ";" in those blocks as a separator (we call it ";-block").
+ ;; FIXME: This means that "TYPE \n VAR" is not indented properly
+ ;; because there's no ";-block" between the two.
+ (decls (decls ";-block" decls)
+ ("TYPE" typedecls) ("CONST" constdecls) ("VAR" vardecls)
+ ;; END is usually a closer, but not quite for PROCEDURE...END.
+ ;; We could use "END-proc" for the procedure case, but
+ ;; I preferred to just pretend PROCEDURE's END is the closer.
+ ("PROCEDURE" decls "BEGIN" insts "END") ;END-proc id
+ ("PROCEDURE" decls "BEGIN" insts "FINALLY" insts "END")
+ ("PROCEDURE" decls "FORWARD")
+ ;; ("IMPLEMENTATION" epsilon "MODULE" decls
+ ;; "BEGIN" insts "FINALLY" insts "END")
+ )
+ (typedecls (typedecls ";" typedecls) (id "=" type))
+ (ids (ids "," ids))
+ (vardecls (vardecls ";" vardecls) (ids ":" type))
+ (constdecls (constdecls ";" constdecls) (id "=" exp))
+ (exp (id "-anchor-" id) ("(" exp ")"))
+ (caselabel (caselabel ".." caselabel) (caselabel "," caselabel))
+ ;; : for types binds tighter than ;, but the : for case labels binds
+ ;; less tight, so have to use two different :.
+ (cases (cases "|" cases) (caselabel ":-case" insts))
+ (forspec (exp "TO" exp))
+ (insts (insts ";" insts)
+ (id ":=" exp)
+ ("CASE" exp "OF" cases "END")
+ ("CASE" exp "OF" cases "ELSE" insts "END")
+ ("LOOP" insts "END")
+ ("WITH" exp "DO" insts "END")
+ ("REPEAT" insts "UNTIL" exp)
+ ("WHILE" exp "DO" insts "END")
+ ("FOR" forspec "DO" insts "END")
+ ("IF" exp "THEN" insts "END")
+ ("IF" exp "THEN" insts "ELSE" insts "END")
+ ("IF" exp "THEN" insts
+ "ELSIF" exp "THEN" insts "ELSE" insts "END")
+ ("IF" exp "THEN" insts
+ "ELSIF" exp "THEN" insts
+ "ELSIF" exp "THEN" insts "ELSE" insts "END"))
+ ;; This category is not used anywhere, but it adds some constraints that
+ ;; try to reduce the harm when an OF-type is not properly recognized.
+ (error-OF ("ARRAY" range "OF" type) ("SET" "OF" id)))
+ '((assoc ";")) '((assoc ";-block")) '((assoc "|"))
+ ;; For case labels.
+ '((assoc ",") (assoc ".."))
+ ;; '((assoc "TYPE" "CONST" "VAR" "PROCEDURE"))
+ )
+ (smie-precs->prec2
+ '((nonassoc "-anchor-" "=")
+ (nonassoc "<" "<=" ">=" ">" "<>" "#" "IN")
+ (assoc "OR" "+" "-")
+ (assoc "AND" "MOD" "DIV" "REM" "*" "/" "&")
+ (nonassoc "NOT" "~")
+ (left "." "^")
+ ))
+ )))
+
+(defun m2-smie-refine-colon ()
+ (let ((res nil))
+ (while (not res)
+ (let ((tok (smie-default-backward-token)))
+ (cond
+ ((zerop (length tok))
+ (let ((forward-sexp-function nil))
+ (condition-case nil
+ (forward-sexp -1)
+ (scan-error (setq res ":")))))
+ ((member tok '("|" "OF" "..")) (setq res ":-case"))
+ ((member tok '(":" "END" ";" "BEGIN" "VAR" "RECORD" "PROCEDURE"))
+ (setq res ":")))))
+ res))
+
+(defun m2-smie-refine-of ()
+ (let ((tok (smie-default-backward-token)))
+ (when (zerop (length tok))
+ (let ((forward-sexp-function nil))
+ (condition-case nil
+ (backward-sexp 1)
+ (scan-error nil))
+ (setq tok (smie-default-backward-token))))
+ (if (member tok '("ARRAY" "SET"))
+ "OF-type" "OF")))
+
+(defun m2-smie-refine-semi ()
+ (forward-comment (point-max))
+ (if (looking-at (regexp-opt '("PROCEDURE" "TYPE" "VAR" "CONST" "BEGIN")))
+ ";-block" ";"))
+
+;; FIXME: "^." are two tokens, not one.
+(defun m2-smie-forward-token ()
+ (pcase (smie-default-forward-token)
+ (`"VAR" (if (zerop (car (syntax-ppss))) "VAR" "VAR-arg"))
+ (`"CONST" (if (zerop (car (syntax-ppss))) "CONST" "CONST-arg"))
+ (`";" (save-excursion (m2-smie-refine-semi)))
+ (`"OF" (save-excursion (forward-char -2) (m2-smie-refine-of)))
+ (`":" (save-excursion (forward-char -1) (m2-smie-refine-colon)))
+ ;; (`"END" (if (and (looking-at "[ \t\n]*\\(\\(?:\\sw\\|\\s_\\)+\\)")
+ ;; (not (assoc (match-string 1) m2-smie-grammar)))
+ ;; "END-proc" "END"))
+ (token token)))
+
+(defun m2-smie-backward-token ()
+ (pcase (smie-default-backward-token)
+ (`"VAR" (if (zerop (car (syntax-ppss))) "VAR" "VAR-arg"))
+ (`"CONST" (if (zerop (car (syntax-ppss))) "CONST" "CONST-arg"))
+ (`";" (save-excursion (forward-char 1) (m2-smie-refine-semi)))
+ (`"OF" (save-excursion (m2-smie-refine-of)))
+ (`":" (save-excursion (m2-smie-refine-colon)))
+ ;; (`"END" (if (and (looking-at "\\sw+[ \t\n]+\\(\\(?:\\sw\\|\\s_\\)+\\)")
+ ;; (not (assoc (match-string 1) m2-smie-grammar)))
+ ;; "END-proc" "END"))
+ (token token)))
+
+(defun m2-smie-rules (kind token)
+ ;; FIXME: Apparently, the usual indentation convention is something like:
+ ;;
+ ;; TYPE t1 = bar;
+ ;; VAR x : INTEGER;
+ ;; PROCEDURE f ();
+ ;; TYPE t2 = foo;
+ ;; PROCEDURE g ();
+ ;; BEGIN blabla END;
+ ;; VAR y : type;
+ ;; BEGIN blibli END
+ ;;
+ ;; This is inconsistent with the actual structure of the code in 2 ways:
+ ;; - The inner VAR/TYPE are indented just like the outer VAR/TYPE.
+ ;; - The inner PROCEDURE is not aligned with its VAR/TYPE siblings.
+ (pcase (cons kind token)
+ (`(:elem . basic) m2-indent)
+ (`(:after . ":=") (or m2-indent smie-indent-basic))
+ (`(:after . ,(or `"CONST" `"VAR" `"TYPE"))
+ (or m2-indent smie-indent-basic))
+ ;; (`(:before . ,(or `"VAR" `"TYPE" `"CONST"))
+ ;; (if (smie-rule-parent-p "PROCEDURE") 0))
+ (`(:after . ";-block")
+ (if (smie-rule-parent-p "PROCEDURE")
+ (smie-rule-parent (or m2-indent smie-indent-basic))))
+ (`(:before . "|") (smie-rule-separator kind))
+ ))
;;;###autoload
-(defun modula-2-mode ()
+(defalias 'modula-2-mode 'm2-mode)
+;;;###autoload
+(define-derived-mode m2-mode prog-mode "Modula-2"
"This is a mode intended to support program development in Modula-2.
All control constructs of Modula-2 can be reached by typing C-c
followed by the first character of the construct.
@@ -134,46 +308,23 @@ followed by the first character of the construct.
`m2-indent' controls the number of spaces for each indentation.
`m2-compile-command' holds the command to compile a Modula-2 program.
`m2-link-command' holds the command to link a Modula-2 program."
- (interactive)
- (kill-all-local-variables)
- (use-local-map m2-mode-map)
- (setq major-mode 'modula-2-mode)
- (setq mode-name "Modula-2")
- (make-local-variable 'comment-column)
- (setq comment-column 41)
(make-local-variable 'm2-end-comment-column)
- (set-syntax-table m2-mode-syntax-table)
- (make-local-variable 'paragraph-start)
- (setq paragraph-start (concat "$\\|" page-delimiter))
- (make-local-variable 'paragraph-separate)
- (setq paragraph-separate paragraph-start)
- (make-local-variable 'paragraph-ignore-fill-prefix)
- (setq paragraph-ignore-fill-prefix t)
-; (make-local-variable 'indent-line-function)
-; (setq indent-line-function 'c-indent-line)
- (make-local-variable 'require-final-newline)
- (setq require-final-newline mode-require-final-newline)
- (make-local-variable 'comment-start)
- (setq comment-start "(* ")
- (make-local-variable 'comment-end)
- (setq comment-end " *)")
- (make-local-variable 'comment-column)
- (setq comment-column 41)
- (make-local-variable 'comment-start-skip)
- (setq comment-start-skip "/\\*+ *")
- (make-local-variable 'comment-indent-function)
- (setq comment-indent-function 'c-comment-indent)
- (make-local-variable 'parse-sexp-ignore-comments)
- (setq parse-sexp-ignore-comments t)
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults
+
+ (set (make-local-variable 'paragraph-start) (concat "$\\|" page-delimiter))
+ (set (make-local-variable 'paragraph-separate) paragraph-start)
+ (set (make-local-variable 'paragraph-ignore-fill-prefix) t)
+ (set (make-local-variable 'comment-start) "(* ")
+ (set (make-local-variable 'comment-end) " *)")
+ (set (make-local-variable 'comment-start-skip) "\\(?:(\\*+\\|//+\\) *")
+ (set (make-local-variable 'parse-sexp-ignore-comments) t)
+ (set (make-local-variable 'font-lock-defaults)
'((m3-font-lock-keywords
m3-font-lock-keywords-1 m3-font-lock-keywords-2)
nil nil ((?_ . "w") (?. . "w") (?< . ". 1") (?> . ". 4")) nil
- ;; Obsoleted by Emacs 19.35 parse-partial-sexp's COMMENTSTOP.
- ;(font-lock-comment-start-regexp . "(\\*")
))
- (run-mode-hooks 'm2-mode-hook))
+ (smie-setup m2-smie-grammar #'m2-smie-rules
+ :forward-token #'m2-smie-forward-token
+ :backward-token #'m2-smie-backward-token))
;; Regexps written with help from Ron Forrester <ron@orcad.com>
;; and Spencer Allain <sallain@teknowledge.com>.
@@ -259,231 +410,131 @@ followed by the first character of the construct.
(defvar m2-font-lock-keywords m2-font-lock-keywords-1
"Default expressions to highlight in Modula-2 modes.")
-(defun m2-newline ()
- "Insert a newline and indent following line like previous line."
- (interactive)
- (let ((hpos (current-indentation)))
- (newline)
- (indent-to hpos)))
-
-(defun m2-tab ()
- "Indent to next tab stop."
- (interactive)
- (indent-to (* (1+ (/ (current-indentation) m2-indent)) m2-indent)))
-
-(defun m2-begin ()
+(define-skeleton m2-begin
"Insert a BEGIN keyword and indent for the next line."
- (interactive)
- (insert "BEGIN")
- (m2-newline)
- (m2-tab))
+ nil
+ \n "BEGIN" > \n)
-(defun m2-case ()
+(define-skeleton m2-case
"Build skeleton CASE statement, prompting for the <expression>."
- (interactive)
- (let ((name (read-string "Case-Expression: ")))
- (insert "CASE " name " OF")
- (m2-newline)
- (m2-newline)
- (insert "END (* case " name " *);"))
- (end-of-line 0)
- (m2-tab))
-
-(defun m2-definition ()
+ "Case-Expression: "
+ \n "CASE " str " OF" > \n _ \n "END (* " str " *);" > \n)
+
+(define-skeleton m2-definition
"Build skeleton DEFINITION MODULE, prompting for the <module name>."
- (interactive)
- (insert "DEFINITION MODULE ")
- (let ((name (read-string "Name: ")))
- (insert name ";\n\n\n\nEND " name ".\n"))
- (forward-line -3))
+ "Name: "
+ \n "DEFINITION MODULE " str ";" > \n \n _ \n \n "END " str "." > \n)
-(defun m2-else ()
+(define-skeleton m2-else
"Insert ELSE keyword and indent for next line."
- (interactive)
- (m2-newline)
- (backward-delete-char-untabify m2-indent ())
- (insert "ELSE")
- (m2-newline)
- (m2-tab))
+ nil
+ \n "ELSE" > \n)
-(defun m2-for ()
+(define-skeleton m2-for
"Build skeleton FOR loop statement, prompting for the loop parameters."
- (interactive)
- (insert "FOR ")
- (let ((name (read-string "Loop Initializer: ")) limit by)
- (insert name " TO ")
- (setq limit (read-string "Limit: "))
- (insert limit)
- (setq by (read-string "Step: "))
+ "Loop Initializer: "
+ ;; FIXME: this seems to be lacking a "<var> :=".
+ \n "FOR " str " TO "
+ (setq v1 (read-string "Limit: "))
+ (let ((by (read-string "Step: ")))
(if (not (string-equal by ""))
- (insert " BY " by))
- (insert " DO")
- (m2-newline)
- (m2-newline)
- (insert "END (* for " name " to " limit " *);"))
- (end-of-line 0)
- (m2-tab))
-
-(defun m2-header ()
- "Insert a comment block containing the module title, author, etc."
- (interactive)
- (insert "(*\n Title: \t")
- (insert (read-string "Title: "))
- (insert "\n Created:\t")
- (insert (current-time-string))
- (insert "\n Author: \t")
- (insert (user-full-name))
- (insert (concat "\n\t\t<" (user-login-name) "@" (system-name) ">\n"))
- (insert "*)\n\n"))
-
-(defun m2-if ()
- "Insert skeleton IF statement, prompting for <boolean-expression>."
- (interactive)
- (insert "IF ")
- (let ((thecondition (read-string "<boolean-expression>: ")))
- (insert thecondition " THEN")
- (m2-newline)
- (m2-newline)
- (insert "END (* if " thecondition " *);"))
- (end-of-line 0)
- (m2-tab))
-
-(defun m2-loop ()
- "Build skeleton LOOP (with END)."
- (interactive)
- (insert "LOOP")
- (m2-newline)
- (m2-newline)
- (insert "END (* loop *);")
- (end-of-line 0)
- (m2-tab))
-
-(defun m2-module ()
- "Build skeleton IMPLEMENTATION MODULE, prompting for <module-name>."
- (interactive)
- (insert "IMPLEMENTATION MODULE ")
- (let ((name (read-string "Name: ")))
- (insert name ";\n\n\n\nEND " name ".\n")
- (forward-line -3)
- (m2-header)
- (m2-type)
- (newline)
- (m2-var)
- (newline)
- (m2-begin)
- (m2-begin-comment)
- (insert " Module " name " Initialisation Code "))
- (m2-end-comment)
- (newline)
- (m2-tab))
-
-(defun m2-or ()
- (interactive)
- (m2-newline)
- (backward-delete-char-untabify m2-indent)
- (insert "|")
- (m2-newline)
- (m2-tab))
-
-(defun m2-procedure ()
- (interactive)
- (insert "PROCEDURE ")
- (let ((name (read-string "Name: " ))
- args)
- (insert name " (")
- (insert (read-string "Arguments: ") ")")
- (setq args (read-string "Result Type: "))
- (if (not (string-equal args ""))
- (insert " : " args))
- (insert ";")
- (m2-newline)
- (insert "BEGIN")
- (m2-newline)
- (m2-newline)
- (insert "END ")
- (insert name)
- (insert ";")
- (end-of-line 0)
- (m2-tab)))
-
-(defun m2-with ()
- (interactive)
- (insert "WITH ")
- (let ((name (read-string "Record-Type: ")))
- (insert name)
- (insert " DO")
- (m2-newline)
- (m2-newline)
- (insert "END (* with " name " *);"))
- (end-of-line 0)
- (m2-tab))
-
-(defun m2-record ()
- (interactive)
- (insert "RECORD")
- (m2-newline)
- (m2-newline)
- (insert "END (* record *);")
- (end-of-line 0)
- (m2-tab))
-
-(defun m2-stdio ()
- (interactive)
- (insert "
-FROM TextIO IMPORT
- WriteCHAR, ReadCHAR, WriteINTEGER, ReadINTEGER,
- WriteCARDINAL, ReadCARDINAL, WriteBOOLEAN, ReadBOOLEAN,
- WriteREAL, ReadREAL, WriteBITSET, ReadBITSET,
- WriteBasedCARDINAL, ReadBasedCARDINAL, WriteChars, ReadChars,
- WriteString, ReadString, WhiteSpace, EndOfLine;
-
-FROM SysStreams IMPORT sysIn, sysOut, sysErr;
+ (concat " BY " by)))
+ " DO" > \n _ \n "END (* for " str " to " v1 " *);" > \n)
-"))
-
-(defun m2-type ()
- (interactive)
- (insert "TYPE")
- (m2-newline)
- (m2-tab))
+(define-skeleton m2-header
+ "Insert a comment block containing the module title, author, etc."
+ "Title: "
+ "(*\n Title: \t" str
+ "\n Created: \t" (current-time-string)
+ "\n Author: \t" (user-full-name) " <" user-mail-address ">\n"
+ "*)" > \n)
-(defun m2-until ()
- (interactive)
- (insert "REPEAT")
- (m2-newline)
- (m2-newline)
- (insert "UNTIL ")
- (insert (read-string "<boolean-expression>: ") ";")
- (end-of-line 0)
- (m2-tab))
-
-(defun m2-var ()
- (interactive)
- (m2-newline)
- (insert "VAR")
- (m2-newline)
- (m2-tab))
+(define-skeleton m2-if
+ "Insert skeleton IF statement, prompting for <boolean-expression>."
+ "<boolean-expression>: "
+ \n "IF " str " THEN" > \n _ \n "END (* if " str " *);" > \n)
-(defun m2-while ()
- (interactive)
- (insert "WHILE ")
- (let ((name (read-string "<boolean-expression>: ")))
- (insert name " DO" )
- (m2-newline)
- (m2-newline)
- (insert "END (* while " name " *);"))
- (end-of-line 0)
- (m2-tab))
-
-(defun m2-export ()
- (interactive)
- (insert "EXPORT QUALIFIED "))
+(define-skeleton m2-loop
+ "Build skeleton LOOP (with END)."
+ nil
+ \n "LOOP" > \n _ \n "END (* loop *);" > \n)
-(defun m2-import ()
- (interactive)
- (insert "FROM ")
- (insert (read-string "Module: "))
- (insert " IMPORT "))
+(define-skeleton m2-module
+ "Build skeleton IMPLEMENTATION MODULE, prompting for <module-name>."
+ "Name: "
+ \n "IMPLEMENTATION MODULE " str ";" > \n \n
+ '(m2-header)
+ '(m2-type) \n
+ '(m2-var) \n _ \n \n
+ '(m2-begin)
+ '(m2-begin-comment)
+ " Module " str " Initialisation Code "
+ '(m2-end-comment)
+ \n \n "END " str "." > \n)
+
+(define-skeleton m2-or
+ "No doc."
+ nil
+ \n "|" > \n)
+
+(define-skeleton m2-procedure
+ "No doc."
+ "Name: "
+ \n "PROCEDURE " str " (" (read-string "Arguments: ") ")"
+ (let ((args (read-string "Result Type: ")))
+ (if (not (equal args "")) (concat " : " args)))
+ ";" > \n "BEGIN" > \n _ \n "END " str ";" > \n)
+
+(define-skeleton m2-with
+ "No doc."
+ "Record-Type: "
+ \n "WITH " str " DO" > \n _ \n "END (* with " str " *);" > \n)
+
+(define-skeleton m2-record
+ "No doc."
+ nil
+ \n "RECORD" > \n _ \n "END (* record *);" > \n)
+
+(define-skeleton m2-stdio
+ "No doc."
+ nil
+ \n "FROM TextIO IMPORT"
+ > \n "WriteCHAR, ReadCHAR, WriteINTEGER, ReadINTEGER,"
+ > \n "WriteCARDINAL, ReadCARDINAL, WriteBOOLEAN, ReadBOOLEAN,"
+ > \n "WriteREAL, ReadREAL, WriteBITSET, ReadBITSET,"
+ > \n "WriteBasedCARDINAL, ReadBasedCARDINAL, WriteChars, ReadChars,"
+ > \n "WriteString, ReadString, WhiteSpace, EndOfLine;"
+ > \n \n "FROM SysStreams IMPORT sysIn, sysOut, sysErr;" > \n \n)
+
+(define-skeleton m2-type
+ "No doc."
+ nil
+ \n "TYPE" > \n ";" > \n)
+
+(define-skeleton m2-until
+ "No doc."
+ "<boolean-expression>: "
+ \n "REPEAT" > \n _ \n "UNTIL " str ";" > \n)
+
+(define-skeleton m2-var
+ "No doc."
+ nil
+ \n "VAR" > \n ";" > \n)
+
+(define-skeleton m2-while
+ "No doc."
+ "<boolean-expression>: "
+ \n "WHILE " str " DO" > \n _ \n "END (* while " str " *);" > \n)
+
+(define-skeleton m2-export
+ "No doc."
+ nil
+ \n "EXPORT QUALIFIED " > _ \n)
+
+(define-skeleton m2-import
+ "No doc."
+ "Module: "
+ \n "FROM " str " IMPORT " > _ \n)
(defun m2-begin-comment ()
(interactive)
@@ -503,15 +554,15 @@ FROM SysStreams IMPORT sysIn, sysOut, sysErr;
(defun m2-link ()
(interactive)
- (if m2-link-name
- (compile (concat m2-link-command " " m2-link-name))
- (compile (concat m2-link-command " "
- (setq m2-link-name (read-string "Name of executable: "
- (buffer-name)))))))
+ (compile (concat m2-link-command " "
+ (or m2-link-name
+ (setq m2-link-name (read-string "Name of executable: "
+ (buffer-name)))))))
(defun m2-execute-monitor-command (command)
(let* ((shell shell-file-name)
- (csh (equal (file-name-nondirectory shell) "csh")))
+ ;; (csh (equal (file-name-nondirectory shell) "csh"))
+ )
(call-process shell nil t t "-cf" (concat "exec " command))))
(defun m2-visit ()
diff --git a/lisp/progmodes/octave-inf.el b/lisp/progmodes/octave-inf.el
index 8e64d5689d1..c526a634d86 100644
--- a/lisp/progmodes/octave-inf.el
+++ b/lisp/progmodes/octave-inf.el
@@ -7,6 +7,7 @@
;; Author: John Eaton <jwe@bevo.che.wisc.edu>
;; Maintainer: Kurt Hornik <Kurt.Hornik@wu-wien.ac.at>
;; Keywords: languages
+;; Package: octave-mod
;; This file is part of GNU Emacs.
diff --git a/lisp/progmodes/octave-mod.el b/lisp/progmodes/octave-mod.el
index eb84be601de..cd2957f6180 100644
--- a/lisp/progmodes/octave-mod.el
+++ b/lisp/progmodes/octave-mod.el
@@ -1,10 +1,10 @@
;;; octave-mod.el --- editing Octave source files under Emacs
-;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+;; 2009, 2010 Free Software Foundation, Inc.
;; Author: Kurt Hornik <Kurt.Hornik@wu-wien.ac.at>
-;; Author: John Eaton <jwe@bevo.che.wisc.edu>
+;; Author: John Eaton <jwe@octave.org>
;; Maintainer: Kurt Hornik <Kurt.Hornik@wu-wien.ac.at>
;; Keywords: languages
@@ -92,7 +92,7 @@ All Octave abbrevs start with a grave accent (`)."
(defvar octave-comment-char ?#
"Character to start an Octave comment.")
(defvar octave-comment-start
- (string octave-comment-char ?\ )
+ (string octave-comment-char ?\s)
"String to insert to start a new Octave in-line comment.")
(defvar octave-comment-start-skip "\\s<+\\s-*"
"Regexp to match the start of an Octave comment up to its body.")
@@ -161,8 +161,8 @@ parenthetical grouping.")
(list
;; Fontify all builtin keywords.
(cons (concat "\\<\\("
- (mapconcat 'identity octave-reserved-words "\\|")
- (mapconcat 'identity octave-text-functions "\\|")
+ (regexp-opt (append octave-reserved-words
+ octave-text-functions))
"\\)\\>")
'font-lock-keyword-face)
;; Fontify all builtin operators.
@@ -171,9 +171,7 @@ parenthetical grouping.")
'font-lock-builtin-face
'font-lock-preprocessor-face))
;; Fontify all builtin variables.
- (cons (concat "\\<\\("
- (mapconcat 'identity octave-variables "\\|")
- "\\)\\>")
+ (cons (concat "\\<" (regexp-opt octave-variables) "\\>")
'font-lock-variable-name-face)
;; Fontify all function declarations.
(list octave-function-header-regexp
@@ -181,6 +179,29 @@ parenthetical grouping.")
'(3 font-lock-function-name-face nil t)))
"Additional Octave expressions to highlight.")
+(defun octave-syntax-propertize-function (start end)
+ (goto-char start)
+ (octave-syntax-propertize-sqs end)
+ (funcall (syntax-propertize-rules
+ ;; Try to distinguish the string-quotes from the transpose-quotes.
+ ("[[({,; ]\\('\\)"
+ (1 (prog1 "\"'" (octave-syntax-propertize-sqs end)))))
+ (point) end))
+
+(defun octave-syntax-propertize-sqs (end)
+ "Propertize the content/end of single-quote strings."
+ (when (eq (nth 3 (syntax-ppss)) ?\')
+ ;; A '..' string.
+ (when (re-search-forward
+ "\\(?:\\=\\|[^']\\)\\(?:''\\)*\\('\\)\\($\\|[^']\\)" end 'move)
+ (goto-char (match-beginning 2))
+ (when (eq (char-before (match-beginning 1)) ?\\)
+ ;; Backslash cannot escape a single quote.
+ (put-text-property (1- (match-beginning 1)) (match-beginning 1)
+ 'syntax-table (string-to-syntax ".")))
+ (put-text-property (match-beginning 1) (match-end 1)
+ 'syntax-table (string-to-syntax "\"'")))))
+
(defcustom inferior-octave-buffer "*Inferior Octave*"
"Name of buffer for running an inferior Octave process."
:type 'string
@@ -191,29 +212,17 @@ parenthetical grouping.")
(defvar octave-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "`" 'octave-abbrev-start)
- (define-key map ";" 'octave-electric-semi)
- (define-key map " " 'octave-electric-space)
- (define-key map "\n" 'octave-reindent-then-newline-and-indent)
- (define-key map "\e;" 'octave-indent-for-comment)
(define-key map "\e\n" 'octave-indent-new-comment-line)
- (define-key map "\e\t" 'octave-complete-symbol)
- (define-key map "\M-\C-a" 'octave-beginning-of-defun)
- (define-key map "\M-\C-e" 'octave-end-of-defun)
- (define-key map "\M-\C-h" 'octave-mark-defun)
(define-key map "\M-\C-q" 'octave-indent-defun)
- (define-key map "\C-c;" 'octave-comment-region)
- (define-key map "\C-c:" 'octave-uncomment-region)
(define-key map "\C-c\C-b" 'octave-submit-bug-report)
(define-key map "\C-c\C-p" 'octave-previous-code-line)
(define-key map "\C-c\C-n" 'octave-next-code-line)
(define-key map "\C-c\C-a" 'octave-beginning-of-line)
(define-key map "\C-c\C-e" 'octave-end-of-line)
- (define-key map "\C-c\M-\C-n" 'octave-forward-block)
- (define-key map "\C-c\M-\C-p" 'octave-backward-block)
- (define-key map "\C-c\M-\C-u" 'octave-backward-up-block)
- (define-key map "\C-c\M-\C-d" 'octave-down-block)
+ (define-key map [remap down-list] 'smie-down-list)
(define-key map "\C-c\M-\C-h" 'octave-mark-block)
- (define-key map "\C-c]" 'octave-close-block)
+ (define-key map "\C-c]" 'smie-close-block)
+ (define-key map "\C-c/" 'smie-close-block)
(define-key map "\C-c\C-f" 'octave-insert-defun)
(define-key map "\C-c\C-h" 'octave-help)
(define-key map "\C-c\C-il" 'octave-send-line)
@@ -234,7 +243,9 @@ parenthetical grouping.")
"Keymap used in Octave mode.")
-(defvar octave-mode-menu
+
+(easy-menu-define octave-mode-menu octave-mode-map
+ "Menu for Octave mode."
'("Octave"
("Lines"
["Previous Code Line" octave-previous-code-line t]
@@ -243,16 +254,9 @@ parenthetical grouping.")
["End of Continuation" octave-end-of-line t]
["Split Line at Point" octave-indent-new-comment-line t])
("Blocks"
- ["Next Block" octave-forward-block t]
- ["Previous Block" octave-backward-block t]
- ["Down Block" octave-down-block t]
- ["Up Block" octave-backward-up-block t]
["Mark Block" octave-mark-block t]
- ["Close Block" octave-close-block t])
+ ["Close Block" smie-close-block t])
("Functions"
- ["Begin of Function" octave-beginning-of-defun t]
- ["End of Function" octave-end-of-defun t]
- ["Mark Function" octave-mark-defun t]
["Indent Function" octave-indent-defun t]
["Insert Function" octave-insert-defun t])
"-"
@@ -266,16 +270,17 @@ parenthetical grouping.")
["Kill Process" octave-kill-process t])
"-"
["Indent Line" indent-according-to-mode t]
- ["Complete Symbol" octave-complete-symbol t]
+ ["Complete Symbol" completion-at-point t]
"-"
- ["Toggle Abbrev Mode" abbrev-mode t]
- ["Toggle Auto-Fill Mode" auto-fill-mode t]
+ ["Toggle Abbrev Mode" abbrev-mode
+ :style toggle :selected abbrev-mode]
+ ["Toggle Auto-Fill Mode" auto-fill-mode
+ :style toggle :selected auto-fill-function]
"-"
["Submit Bug Report" octave-submit-bug-report t]
"-"
- ["Describe Octave Mode" octave-describe-major-mode t]
- ["Lookup Octave Index" octave-help t])
- "Menu for Octave mode.")
+ ["Describe Octave Mode" describe-mode t]
+ ["Lookup Octave Index" info-lookup-symbol t]))
(defvar octave-mode-syntax-table
(let ((table (make-syntax-table)))
@@ -297,62 +302,32 @@ parenthetical grouping.")
(modify-syntax-entry ?\" "\"" table)
(modify-syntax-entry ?. "w" table)
(modify-syntax-entry ?_ "w" table)
- (modify-syntax-entry ?\% "<" table)
- (modify-syntax-entry ?\# "<" table)
+ ;; The "b" flag only applies to the second letter of the comstart
+ ;; and the first letter of the comend, i.e. the "4b" below is ineffective.
+ ;; If we try to put `b' on the single-line comments, we get a similar
+ ;; problem where the % and # chars appear as first chars of the 2-char
+ ;; comend, so the multi-line ender is also turned into style-b.
+ ;; So we need the new "c" comment style.
+ (modify-syntax-entry ?\% "< 13" table)
+ (modify-syntax-entry ?\# "< 13" table)
+ (modify-syntax-entry ?\{ "(} 2c" table)
+ (modify-syntax-entry ?\} "){ 4c" table)
(modify-syntax-entry ?\n ">" table)
table)
"Syntax table in use in `octave-mode' buffers.")
-(defcustom octave-auto-indent nil
- "Non-nil means indent line after a semicolon or space in Octave mode."
- :type 'boolean
- :group 'octave)
-
-(defcustom octave-auto-newline nil
- "Non-nil means automatically newline after a semicolon in Octave mode."
- :type 'boolean
- :group 'octave)
-
(defcustom octave-blink-matching-block t
"Control the blinking of matching Octave block keywords.
Non-nil means show matching begin of block when inserting a space,
newline or semicolon after an else or end keyword."
:type 'boolean
:group 'octave)
+
(defcustom octave-block-offset 2
"Extra indentation applied to statements in Octave block structures."
:type 'integer
:group 'octave)
-(defvar octave-block-begin-regexp
- (concat "\\<\\("
- (mapconcat 'identity octave-begin-keywords "\\|")
- "\\)\\>"))
-(defvar octave-block-else-regexp
- (concat "\\<\\("
- (mapconcat 'identity octave-else-keywords "\\|")
- "\\)\\>"))
-(defvar octave-block-end-regexp
- (concat "\\<\\("
- (mapconcat 'identity octave-end-keywords "\\|")
- "\\)\\>"))
-(defvar octave-block-begin-or-end-regexp
- (concat octave-block-begin-regexp "\\|" octave-block-end-regexp))
-(defvar octave-block-else-or-end-regexp
- (concat octave-block-else-regexp "\\|" octave-block-end-regexp))
-(defvar octave-block-match-alist
- '(("do" . ("until"))
- ("for" . ("endfor" "end"))
- ("function" . ("endfunction"))
- ("if" . ("else" "elseif" "endif" "end"))
- ("switch" . ("case" "otherwise" "endswitch" "end"))
- ("try" . ("catch" "end_try_catch"))
- ("unwind_protect" . ("unwind_protect_cleanup" "end_unwind_protect"))
- ("while" . ("endwhile" "end")))
- "Alist with Octave's matching block keywords.
-Has Octave's begin keywords as keys and a list of the matching else or
-end keywords as associated values.")
-
(defvar octave-block-comment-start
(concat (make-string 2 octave-comment-char) " ")
"String to insert to start a new Octave comment on an empty line.")
@@ -361,8 +336,11 @@ end keywords as associated values.")
"Extra indentation applied to Octave continuation lines."
:type 'integer
:group 'octave)
+(eval-and-compile
+ (defconst octave-continuation-marker-regexp "\\\\\\|\\.\\.\\."))
(defvar octave-continuation-regexp
- "[^#%\n]*\\(\\\\\\|\\.\\.\\.\\)\\s-*\\(\\s<.*\\)?$")
+ (concat "[^#%\n]*\\(" octave-continuation-marker-regexp
+ "\\)\\s-*\\(\\s<.*\\)?$"))
(defcustom octave-continuation-string "\\"
"Character string used for Octave continuation lines. Normally \\."
:type 'string
@@ -400,8 +378,155 @@ Non-nil means always go to the next Octave code line after sending."
:group 'octave)
+;;; SMIE indentation
+
+(require 'smie)
+
+(defconst octave-operator-table
+ '((assoc ";" "\n") (assoc ",") ; The doc claims they have equal precedence!?
+ (right "=" "+=" "-=" "*=" "/=")
+ (assoc "&&") (assoc "||") ; The doc claims they have equal precedence!?
+ (assoc "&") (assoc "|") ; The doc claims they have equal precedence!?
+ (nonassoc "<" "<=" "==" ">=" ">" "!=" "~=")
+ (nonassoc ":") ;No idea what this is.
+ (assoc "+" "-")
+ (assoc "*" "/" "\\" ".\\" ".*" "./")
+ (nonassoc "'" ".'")
+ (nonassoc "++" "--" "!" "~") ;And unary "+" and "-".
+ (right "^" "**" ".^" ".**")
+ ;; It's not really an operator, but for indentation purposes it
+ ;; could be convenient to treat it as one.
+ (assoc "...")))
+
+(defconst octave-smie-bnf-table
+ '((atom)
+ ;; We can't distinguish the first element in a sequence with
+ ;; precedence grammars, so we can't distinguish the condition
+ ;; if the `if' from the subsequent body, for example.
+ ;; This has to be done later in the indentation rules.
+ (exp (exp "\n" exp)
+ ;; We need to mention at least one of the operators in this part
+ ;; of the grammar: if the BNF and the operator table have
+ ;; no overlap, SMIE can't know how they relate.
+ (exp ";" exp)
+ ("try" exp "catch" exp "end_try_catch")
+ ("try" exp "catch" exp "end")
+ ("unwind_protect" exp
+ "unwind_protect_cleanup" exp "end_unwind_protect")
+ ("unwind_protect" exp "unwind_protect_cleanup" exp "end")
+ ("for" exp "endfor")
+ ("for" exp "end")
+ ("do" exp "until" atom)
+ ("while" exp "endwhile")
+ ("while" exp "end")
+ ("if" exp "endif")
+ ("if" exp "else" exp "endif")
+ ("if" exp "elseif" exp "else" exp "endif")
+ ("if" exp "elseif" exp "elseif" exp "else" exp "endif")
+ ("if" exp "elseif" exp "elseif" exp "else" exp "end")
+ ("switch" exp "case" exp "endswitch")
+ ("switch" exp "case" exp "otherwise" exp "endswitch")
+ ("switch" exp "case" exp "case" exp "otherwise" exp "endswitch")
+ ("switch" exp "case" exp "case" exp "otherwise" exp "end")
+ ("function" exp "endfunction")
+ ("function" exp "end"))
+ ;; (fundesc (atom "=" atom))
+ ))
+
+(defconst octave-smie-grammar
+ (smie-prec2->grammar
+ (smie-merge-prec2s
+ (smie-bnf->prec2 octave-smie-bnf-table
+ '((assoc "\n" ";")))
+
+ (smie-precs->prec2 octave-operator-table))))
+
+;; Tokenizing needs to be refined so that ";;" is treated as two
+;; tokens and also so as to recognize the \n separator (and
+;; corresponding continuation lines).
+
+(defconst octave-operator-regexp
+ (regexp-opt (apply 'append (mapcar 'cdr octave-operator-table))))
+
+(defun octave-smie-backward-token ()
+ (let ((pos (point)))
+ (forward-comment (- (point)))
+ (cond
+ ((and (not (eq (char-before) ?\;)) ;Coalesce ";" and "\n".
+ (> pos (line-end-position))
+ (if (looking-back octave-continuation-marker-regexp (- (point) 3))
+ (progn
+ (goto-char (match-beginning 0))
+ (forward-comment (- (point)))
+ nil)
+ t)
+ ;; Ignore it if it's within parentheses.
+ (let ((ppss (syntax-ppss)))
+ (not (and (nth 1 ppss)
+ (eq ?\( (char-after (nth 1 ppss)))))))
+ (skip-chars-forward " \t")
+ ;; Why bother distinguishing \n and ;?
+ ";") ;;"\n"
+ ((and (looking-back octave-operator-regexp (- (point) 3) 'greedy)
+ ;; Don't mistake a string quote for a transpose.
+ (not (looking-back "\\s\"" (1- (point)))))
+ (goto-char (match-beginning 0))
+ (match-string-no-properties 0))
+ (t
+ (smie-default-backward-token)))))
+
+(defun octave-smie-forward-token ()
+ (skip-chars-forward " \t")
+ (when (looking-at (eval-when-compile
+ (concat "\\(" octave-continuation-marker-regexp
+ "\\)[ \t]*\\($\\|[%#]\\)")))
+ (goto-char (match-end 1))
+ (forward-comment 1))
+ (cond
+ ((and (looking-at "$\\|[%#]")
+ ;; Ignore it if it's within parentheses.
+ (prog1 (let ((ppss (syntax-ppss)))
+ (not (and (nth 1 ppss)
+ (eq ?\( (char-after (nth 1 ppss))))))
+ (forward-comment (point-max))))
+ ;; Why bother distinguishing \n and ;?
+ ";") ;;"\n"
+ ((looking-at ";[ \t]*\\($\\|[%#]\\)")
+ ;; Combine the ; with the subsequent \n.
+ (goto-char (match-beginning 1))
+ (forward-comment 1)
+ ";")
+ ((and (looking-at octave-operator-regexp)
+ ;; Don't mistake a string quote for a transpose.
+ (not (looking-at "\\s\"")))
+ (goto-char (match-end 0))
+ (match-string-no-properties 0))
+ (t
+ (smie-default-forward-token))))
+
+(defun octave-smie-rules (kind token)
+ (pcase (cons kind token)
+ ;; We could set smie-indent-basic instead, but that would have two
+ ;; disadvantages:
+ ;; - changes to octave-block-offset wouldn't take effect immediately.
+ ;; - edebug wouldn't show the use of this variable.
+ (`(:elem . basic) octave-block-offset)
+ ;; Since "case" is in the same BNF rules as switch..end, SMIE by default
+ ;; aligns it with "switch".
+ (`(:before . "case") (if (not (smie-rule-sibling-p)) octave-block-offset))
+ (`(:after . ";")
+ (if (smie-rule-parent-p "function" "if" "while" "else" "elseif" "for"
+ "otherwise" "case" "try" "catch" "unwind_protect"
+ "unwind_protect_cleanup")
+ (smie-rule-parent octave-block-offset)
+ ;; For (invalid) code between switch and case.
+ ;; (if (smie-parent-p "switch") 4)
+ 0))))
+
+(defvar electric-layout-rules)
+
;;;###autoload
-(defun octave-mode ()
+(define-derived-mode octave-mode prog-mode "Octave"
"Major mode for editing Octave code.
This mode makes it easier to write Octave code by helping with
@@ -429,14 +554,6 @@ Keybindings
Variables you can use to customize Octave mode
==============================================
-`octave-auto-indent'
- Non-nil means indent current line after a semicolon or space.
- Default is nil.
-
-`octave-auto-newline'
- Non-nil means auto-insert a newline and indent after a semicolon.
- Default is nil.
-
`octave-blink-matching-block'
Non-nil means show matching begin of block when inserting a space,
newline or semicolon after an else or end keyword. Default is t.
@@ -484,57 +601,65 @@ an Octave mode buffer.
This automatically sets up a mail buffer with version information
already added. You just need to add a description of the problem,
including a reproducible test case and send the message."
- (interactive)
- (kill-all-local-variables)
-
- (use-local-map octave-mode-map)
- (setq major-mode 'octave-mode)
- (setq mode-name "Octave")
(setq local-abbrev-table octave-abbrev-table)
- (set-syntax-table octave-mode-syntax-table)
-
- (make-local-variable 'indent-line-function)
- (setq indent-line-function 'octave-indent-line)
-
- (make-local-variable 'comment-start)
- (setq comment-start octave-comment-start)
- (make-local-variable 'comment-end)
- (setq comment-end "")
- (make-local-variable 'comment-column)
- (setq comment-column 32)
- (make-local-variable 'comment-start-skip)
- (setq comment-start-skip "\\s<+\\s-*")
- (make-local-variable 'comment-indent-function)
- (setq comment-indent-function 'octave-comment-indent)
-
- (make-local-variable 'parse-sexp-ignore-comments)
- (setq parse-sexp-ignore-comments t)
- (make-local-variable 'paragraph-start)
- (setq paragraph-start (concat "\\s-*$\\|" page-delimiter))
- (make-local-variable 'paragraph-separate)
- (setq paragraph-separate paragraph-start)
- (make-local-variable 'paragraph-ignore-fill-prefix)
- (setq paragraph-ignore-fill-prefix t)
- (make-local-variable 'fill-paragraph-function)
- (setq fill-paragraph-function 'octave-fill-paragraph)
- (make-local-variable 'adaptive-fill-regexp)
- (setq adaptive-fill-regexp nil)
- (make-local-variable 'fill-column)
- (setq fill-column 72)
- (make-local-variable 'normal-auto-fill-function)
- (setq normal-auto-fill-function 'octave-auto-fill)
-
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults '(octave-font-lock-keywords nil nil))
-
- (make-local-variable 'imenu-generic-expression)
- (setq imenu-generic-expression octave-mode-imenu-generic-expression
- imenu-case-fold-search nil)
-
- (octave-add-octave-menu)
+
+ (smie-setup octave-smie-grammar #'octave-smie-rules
+ :forward-token #'octave-smie-forward-token
+ :backward-token #'octave-smie-backward-token)
+ (set (make-local-variable 'smie-indent-basic) 'octave-block-offset)
+
+ (set (make-local-variable 'smie-blink-matching-triggers)
+ (cons ?\; smie-blink-matching-triggers))
+ (unless octave-blink-matching-block
+ (remove-hook 'post-self-insert-hook #'smie-blink-matching-open 'local))
+
+ (set (make-local-variable 'electric-indent-chars)
+ (cons ?\; electric-indent-chars))
+ ;; IIUC matlab-mode takes the opposite approach: it makes RET insert
+ ;; a ";" at those places where it's correct (i.e. outside of parens).
+ (set (make-local-variable 'electric-layout-rules) '((?\; . after)))
+
+ (set (make-local-variable 'comment-start) octave-comment-start)
+ (set (make-local-variable 'comment-end) "")
+ ;; Don't set it here: it's not really a property of the language,
+ ;; just a personal preference of the author.
+ ;; (set (make-local-variable 'comment-column) 32)
+ (set (make-local-variable 'comment-start-skip) "\\s<+\\s-*")
+ (set (make-local-variable 'comment-add) 1)
+
+ (set (make-local-variable 'parse-sexp-ignore-comments) t)
+ (set (make-local-variable 'paragraph-start)
+ (concat "\\s-*$\\|" page-delimiter))
+ (set (make-local-variable 'paragraph-separate) paragraph-start)
+ (set (make-local-variable 'paragraph-ignore-fill-prefix) t)
+ (set (make-local-variable 'fill-paragraph-function) 'octave-fill-paragraph)
+ ;; FIXME: Why disable it?
+ ;; (set (make-local-variable 'adaptive-fill-regexp) nil)
+ ;; Again, this is not a property of the language, don't set it here.
+ ;; (set (make-local-variable 'fill-column) 72)
+ (set (make-local-variable 'normal-auto-fill-function) 'octave-auto-fill)
+
+ (set (make-local-variable 'font-lock-defaults)
+ '(octave-font-lock-keywords))
+
+ (set (make-local-variable 'syntax-propertize-function)
+ #'octave-syntax-propertize-function)
+
+ (set (make-local-variable 'imenu-generic-expression)
+ octave-mode-imenu-generic-expression)
+ (set (make-local-variable 'imenu-case-fold-search) nil)
+
+ (add-hook 'completion-at-point-functions
+ 'octave-completion-at-point-function nil t)
+ (set (make-local-variable 'beginning-of-defun-function)
+ 'octave-beginning-of-defun)
+
+ (easy-menu-add octave-mode-menu)
(octave-initialize-completions)
(run-mode-hooks 'octave-mode-hook))
+(defvar info-lookup-mode)
+
(defun octave-help ()
"Get help on Octave symbols from the Octave info files.
Look up symbol in the function, operator and variable indices of the info files."
@@ -542,74 +667,31 @@ Look up symbol in the function, operator and variable indices of the info files.
(call-interactively 'info-lookup-symbol)))
;;; Miscellaneous useful functions
-(defun octave-describe-major-mode ()
- "Describe the current major mode."
- (interactive)
- (describe-function major-mode))
(defsubst octave-in-comment-p ()
"Return t if point is inside an Octave comment."
- (interactive)
(save-excursion
+ ;; FIXME: use syntax-ppss?
(nth 4 (parse-partial-sexp (line-beginning-position) (point)))))
(defsubst octave-in-string-p ()
"Return t if point is inside an Octave string."
- (interactive)
(save-excursion
+ ;; FIXME: use syntax-ppss?
(nth 3 (parse-partial-sexp (line-beginning-position) (point)))))
(defsubst octave-not-in-string-or-comment-p ()
"Return t if point is not inside an Octave string or comment."
+ ;; FIXME: Use syntax-ppss?
(let ((pps (parse-partial-sexp (line-beginning-position) (point))))
(not (or (nth 3 pps) (nth 4 pps)))))
-(defun octave-in-block-p ()
- "Return t if point is inside an Octave block.
-The block is taken to start at the first letter of the begin keyword and
-to end after the end keyword."
- (let ((pos (point)))
- (save-excursion
- (condition-case nil
- (progn
- (skip-syntax-forward "w")
- (octave-up-block -1)
- (octave-forward-block)
- t)
- (error nil))
- (< pos (point)))))
(defun octave-looking-at-kw (regexp)
"Like `looking-at', but sets `case-fold-search' nil."
(let ((case-fold-search nil))
(looking-at regexp)))
-(defun octave-re-search-forward-kw (regexp count)
- "Like `re-search-forward', but sets `case-fold-search' nil, and moves point."
- (let ((case-fold-search nil))
- (re-search-forward regexp nil 'move count)))
-
-(defun octave-re-search-backward-kw (regexp count)
- "Like `re-search-backward', but sets `case-fold-search' nil, and moves point."
- (let ((case-fold-search nil))
- (re-search-backward regexp nil 'move count)))
-
-(defun octave-in-defun-p ()
- "Return t if point is inside an Octave function declaration.
-The function is taken to start at the `f' of `function' and to end after
-the end keyword."
- (let ((pos (point)))
- (save-excursion
- (or (and (octave-looking-at-kw "\\<function\\>")
- (octave-not-in-string-or-comment-p))
- (and (octave-beginning-of-defun)
- (condition-case nil
- (progn
- (octave-forward-block)
- t)
- (error nil))
- (< pos (point)))))))
-
(defun octave-maybe-insert-continuation-string ()
(if (or (octave-in-comment-p)
(save-excursion
@@ -619,147 +701,8 @@ the end keyword."
(delete-horizontal-space)
(insert (concat " " octave-continuation-string))))
-;;; Comments
-(defun octave-comment-region (beg end &optional arg)
- "Comment or uncomment each line in the region as Octave code.
-See `comment-region'."
- (interactive "r\nP")
- (let ((comment-start (char-to-string octave-comment-char)))
- (comment-region beg end arg)))
-
-(defun octave-uncomment-region (beg end &optional arg)
- "Uncomment each line in the region as Octave code."
- (interactive "r\nP")
- (or arg (setq arg 1))
- (octave-comment-region beg end (- arg)))
-
;;; Indentation
-(defun calculate-octave-indent ()
- "Return appropriate indentation for current line as Octave code.
-Returns an integer (the column to indent to) unless the line is a
-comment line with fixed goal golumn. In that case, returns a list whose
-car is the column to indent to, and whose cdr is the current indentation
-level."
- (let ((is-continuation-line
- (save-excursion
- (if (zerop (octave-previous-code-line))
- (looking-at octave-continuation-regexp))))
- (icol 0))
- (save-excursion
- (beginning-of-line)
- ;; If we can move backward out one level of parentheses, take 1
- ;; plus the indentation of that parenthesis. Otherwise, go back
- ;; to the beginning of the previous code line, and compute the
- ;; offset this line gives.
- (if (condition-case nil
- (progn
- (up-list -1)
- t)
- (error nil))
- (setq icol (+ 1 (current-column)))
- (if (zerop (octave-previous-code-line))
- (progn
- (octave-beginning-of-line)
- (back-to-indentation)
- (setq icol (current-column))
- (let ((bot (point))
- (eol (line-end-position)))
- (while (< (point) eol)
- (if (octave-not-in-string-or-comment-p)
- (cond
- ((octave-looking-at-kw "\\<switch\\>")
- (setq icol (+ icol (* 2 octave-block-offset))))
- ((octave-looking-at-kw octave-block-begin-regexp)
- (setq icol (+ icol octave-block-offset)))
- ((octave-looking-at-kw octave-block-else-regexp)
- (if (= bot (point))
- (setq icol (+ icol octave-block-offset))))
- ((octave-looking-at-kw octave-block-end-regexp)
- (if (and (not (= bot (point)))
- ;; special case for `end' keyword,
- ;; applied to all keywords
- (not (octave-end-as-array-index-p)))
- (setq icol (- icol
- (octave-block-end-offset)))))))
- (forward-char)))
- (if is-continuation-line
- (setq icol (+ icol octave-continuation-offset)))))))
- (save-excursion
- (back-to-indentation)
- (cond
- ((and (octave-looking-at-kw octave-block-else-regexp)
- (octave-not-in-string-or-comment-p))
- (setq icol (- icol octave-block-offset)))
- ((and (octave-looking-at-kw octave-block-end-regexp)
- (octave-not-in-string-or-comment-p))
- (setq icol (- icol (octave-block-end-offset))))
- ((or (looking-at "\\s<\\s<\\s<\\S<")
- (octave-before-magic-comment-p))
- (setq icol (list 0 icol)))
- ((looking-at "\\s<\\S<")
- (setq icol (list comment-column icol)))))
- icol))
-
-;; FIXME: this should probably also make sure we are actually looking
-;; at the "end" keyword.
-(defun octave-end-as-array-index-p ()
- (save-excursion
- (condition-case nil
- ;; Check if point is between parens
- (progn (up-list 1) t)
- (error nil))))
-
-(defun octave-block-end-offset ()
- (save-excursion
- (octave-backward-up-block 1)
- (* octave-block-offset
- (if (string-match (match-string 0) "switch") 2 1))))
-
-(defun octave-before-magic-comment-p ()
- (save-excursion
- (beginning-of-line)
- (and (bobp) (looking-at "\\s-*#!"))))
-
-(defun octave-comment-indent ()
- (if (or (looking-at "\\s<\\s<\\s<")
- (octave-before-magic-comment-p))
- 0
- (if (looking-at "\\s<\\s<")
- (calculate-octave-indent)
- (skip-syntax-backward " ")
- (max (if (bolp) 0 (+ 1 (current-column)))
- comment-column))))
-
-(defun octave-indent-for-comment ()
- "Maybe insert and indent an Octave comment.
-If there is no comment already on this line, create a code-level comment
-\(started by two comment characters) if the line is empty, or an in-line
-comment (started by one comment character) otherwise.
-Point is left after the start of the comment which is properly aligned."
- (interactive)
- (beginning-of-line)
- (if (looking-at "^\\s-*$")
- (insert octave-block-comment-start)
- (indent-for-comment))
- (indent-according-to-mode))
-
-(defun octave-indent-line (&optional arg)
- "Indent current line as Octave code.
-With optional ARG, use this as offset unless this line is a comment with
-fixed goal column."
- (interactive)
- (or arg (setq arg 0))
- (let ((icol (calculate-octave-indent))
- (relpos (- (current-column) (current-indentation))))
- (if (listp icol)
- (setq icol (car icol))
- (setq icol (+ icol arg)))
- (if (< icol 0)
- (error "Unmatched end keyword")
- (indent-line-to icol)
- (if (> relpos 0)
- (move-to-column (+ icol relpos))))))
(defun octave-indent-new-comment-line ()
"Break Octave line at point, continuing comment if within one.
@@ -775,13 +718,13 @@ The new line is properly indented."
(error "Cannot split a code line inside a string"))
(t
(insert (concat " " octave-continuation-string))
- (octave-reindent-then-newline-and-indent))))
+ (reindent-then-newline-and-indent))))
(defun octave-indent-defun ()
"Properly indent the Octave function which contains point."
(interactive)
(save-excursion
- (octave-mark-defun)
+ (mark-defun)
(message "Indenting function...")
(indent-region (point) (mark) nil))
(message "Indenting function...done."))
@@ -861,193 +804,33 @@ does not end in `...' or `\\' or is inside an open parenthesis list."
(zerop (forward-line 1)))))
(end-of-line)))
-(defun octave-scan-blocks (count depth)
- "Scan from point by COUNT Octave begin-end blocks.
-Returns the character number of the position thus found.
-
-If DEPTH is nonzero, block depth begins counting from that value.
-Only places where the depth in blocks becomes zero are candidates for
-stopping; COUNT such places are counted.
-
-If the beginning or end of the buffer is reached and the depth is wrong,
-an error is signaled."
- (let ((min-depth (if (> depth 0) 0 depth))
- (inc (if (> count 0) 1 -1)))
- (save-excursion
- (while (/= count 0)
- (catch 'foo
- (while (or (octave-re-search-forward-kw
- octave-block-begin-or-end-regexp inc)
- (if (/= depth 0)
- (error "Unbalanced block")))
- (if (octave-not-in-string-or-comment-p)
- (progn
- (cond
- ((match-end 1)
- (setq depth (+ depth inc)))
- ((match-end 2)
- (setq depth (- depth inc))))
- (if (< depth min-depth)
- (error "Containing expression ends prematurely"))
- (if (= depth 0)
- (throw 'foo nil))))))
- (setq count (- count inc)))
- (point))))
-
-(defun octave-forward-block (&optional arg)
- "Move forward across one balanced Octave begin-end block.
-With argument, do it that many times.
-Negative arg -N means move backward across N blocks."
- (interactive "p")
- (or arg (setq arg 1))
- (goto-char (or (octave-scan-blocks arg 0) (buffer-end arg))))
-
-(defun octave-backward-block (&optional arg)
- "Move backward across one balanced Octave begin-end block.
-With argument, do it that many times.
-Negative arg -N means move forward across N blocks."
- (interactive "p")
- (or arg (setq arg 1))
- (octave-forward-block (- arg)))
-
-(defun octave-down-block (arg)
- "Move forward down one begin-end block level of Octave code.
-With argument, do this that many times.
-A negative argument means move backward but still go down a level.
-In Lisp programs, an argument is required."
- (interactive "p")
- (let ((inc (if (> arg 0) 1 -1)))
- (while (/= arg 0)
- (goto-char (or (octave-scan-blocks inc -1)
- (buffer-end arg)))
- (setq arg (- arg inc)))))
-
-(defun octave-backward-up-block (arg)
- "Move backward out of one begin-end block level of Octave code.
-With argument, do this that many times.
-A negative argument means move forward but still to a less deep spot.
-In Lisp programs, an argument is required."
- (interactive "p")
- (octave-up-block (- arg)))
-
-(defun octave-up-block (arg)
- "Move forward out of one begin-end block level of Octave code.
-With argument, do this that many times.
-A negative argument means move backward but still to a less deep spot.
-In Lisp programs, an argument is required."
- (interactive "p")
- (let ((inc (if (> arg 0) 1 -1)))
- (while (/= arg 0)
- (goto-char (or (octave-scan-blocks inc 1)
- (buffer-end arg)))
- (setq arg (- arg inc)))))
-
(defun octave-mark-block ()
"Put point at the beginning of this Octave block, mark at the end.
The block marked is the one that contains point or follows point."
(interactive)
- (let ((pos (point)))
- (if (or (and (octave-in-block-p)
- (skip-syntax-forward "w"))
- (condition-case nil
- (progn
- (octave-down-block 1)
- (octave-in-block-p))
- (error nil)))
- (progn
- (octave-up-block -1)
- (push-mark (point))
- (octave-forward-block)
- (exchange-point-and-mark))
- (goto-char pos)
- (message "No block to mark found"))))
-
-(defun octave-close-block ()
- "Close the current Octave block on a separate line.
-An error is signaled if no block to close is found."
- (interactive)
- (let (bb-keyword)
- (condition-case nil
- (progn
- (save-excursion
- (octave-backward-up-block 1)
- (setq bb-keyword (buffer-substring-no-properties
- (match-beginning 1) (match-end 1))))
- (if (save-excursion
- (beginning-of-line)
- (looking-at "^\\s-*$"))
- (indent-according-to-mode)
- (octave-reindent-then-newline-and-indent))
- (insert (car (reverse
- (assoc bb-keyword
- octave-block-match-alist))))
- (octave-reindent-then-newline-and-indent)
- t)
- (error (message "No block to close found")))))
-
-(defun octave-blink-matching-block-open ()
- "Blink the matching Octave begin block keyword.
-If point is right after an Octave else or end type block keyword, move
-cursor momentarily to the corresponding begin keyword.
-Signal an error if the keywords are incompatible."
- (interactive)
- (let (bb-keyword bb-arg eb-keyword pos eol)
- (if (and (octave-not-in-string-or-comment-p)
- (looking-at "\\>")
- (save-excursion
- (skip-syntax-backward "w")
- (octave-looking-at-kw octave-block-else-or-end-regexp)))
- (save-excursion
- (cond
- ((match-end 1)
- (setq eb-keyword
- (buffer-substring-no-properties
- (match-beginning 1) (match-end 1)))
- (octave-backward-up-block 1))
- ((match-end 2)
- (setq eb-keyword
- (buffer-substring-no-properties
- (match-beginning 2) (match-end 2)))
- (octave-backward-block)))
- (setq pos (match-end 0)
- bb-keyword
- (buffer-substring-no-properties
- (match-beginning 0) pos)
- pos (+ pos 1)
- eol (line-end-position)
- bb-arg
- (save-excursion
- (save-restriction
- (goto-char pos)
- (while (and (skip-syntax-forward "^<" eol)
- (octave-in-string-p)
- (not (forward-char 1))))
- (skip-syntax-backward " ")
- (buffer-substring-no-properties pos (point)))))
- (if (member eb-keyword
- (cdr (assoc bb-keyword octave-block-match-alist)))
- (progn
- (message "Matches `%s %s'" bb-keyword bb-arg)
- (if (pos-visible-in-window-p)
- (sit-for blink-matching-delay)))
- (error "Block keywords `%s' and `%s' do not match"
- bb-keyword eb-keyword))))))
+ (unless (or (looking-at "\\s(")
+ (save-excursion
+ (let* ((token (funcall smie-forward-token-function))
+ (level (assoc token smie-grammar)))
+ (and level (null (cadr level))))))
+ (backward-up-list 1))
+ (mark-sexp))
(defun octave-beginning-of-defun (&optional arg)
"Move backward to the beginning of an Octave function.
With positive ARG, do it that many times. Negative argument -N means
move forward to Nth following beginning of a function.
Returns t unless search stops at the beginning or end of the buffer."
- (interactive "p")
(let* ((arg (or arg 1))
(inc (if (> arg 0) 1 -1))
- (found))
+ (found nil)
+ (case-fold-search nil))
(and (not (eobp))
- (not (and (> arg 0) (octave-looking-at-kw "\\<function\\>")))
+ (not (and (> arg 0) (looking-at "\\<function\\>")))
(skip-syntax-forward "w"))
(while (and (/= arg 0)
(setq found
- (octave-re-search-backward-kw "\\<function\\>" inc)))
+ (re-search-backward "\\<function\\>" inc)))
(if (octave-not-in-string-or-comment-p)
(setq arg (- arg inc))))
(if found
@@ -1055,40 +838,6 @@ Returns t unless search stops at the beginning or end of the buffer."
(and (< inc 0) (goto-char (match-beginning 0)))
t))))
-(defun octave-end-of-defun (&optional arg)
- "Move forward to the end of an Octave function.
-With positive ARG, do it that many times. Negative argument -N means
-move back to Nth preceding end of a function.
-
-An end of a function occurs right after the end keyword matching the
-`function' keyword that starts the function."
- (interactive "p")
- (or arg (setq arg 1))
- (and (< arg 0) (skip-syntax-backward "w"))
- (and (> arg 0) (skip-syntax-forward "w"))
- (if (octave-in-defun-p)
- (setq arg (- arg 1)))
- (if (= arg 0) (setq arg -1))
- (if (octave-beginning-of-defun (- arg))
- (octave-forward-block)))
-
-(defun octave-mark-defun ()
- "Put point at the beginning of this Octave function, mark at its end.
-The function marked is the one containing point or following point."
- (interactive)
- (let ((pos (point)))
- (if (or (octave-in-defun-p)
- (and (octave-beginning-of-defun -1)
- (octave-in-defun-p)))
- (progn
- (skip-syntax-forward "w")
- (octave-beginning-of-defun)
- (push-mark (point))
- (octave-end-of-defun)
- (exchange-point-and-mark))
- (goto-char pos)
- (message "No function to mark found"))))
-
;;; Filling
(defun octave-auto-fill ()
@@ -1153,81 +902,73 @@ otherwise."
(not give-up))))
(defun octave-fill-paragraph (&optional arg)
- "Fill paragraph of Octave code, handling Octave comments."
- ;; FIXME: now that the default fill-paragraph takes care of similar issues,
- ;; this seems obsolete. --Stef
- (interactive "P")
- (save-excursion
- (let ((end (progn (forward-paragraph) (point)))
- (beg (progn
- (forward-paragraph -1)
- (skip-chars-forward " \t\n")
- (beginning-of-line)
- (point)))
- (cfc (current-fill-column))
- (ind (calculate-octave-indent))
- comment-prefix)
- (save-restriction
- (goto-char beg)
- (narrow-to-region beg end)
- (if (listp ind) (setq ind (nth 1 ind)))
- (while (not (eobp))
- (condition-case nil
- (octave-indent-line ind)
- (error nil))
- (if (and (> ind 0)
- (not
- (save-excursion
- (beginning-of-line)
- (looking-at "^\\s-*\\($\\|\\s<+\\)"))))
- (setq ind 0))
- (move-to-column cfc)
- ;; First check whether we need to combine non-empty comment lines
- (if (and (< (current-column) cfc)
- (octave-in-comment-p)
- (not (save-excursion
- (beginning-of-line)
- (looking-at "^\\s-*\\s<+\\s-*$"))))
- ;; This is a nonempty comment line which does not extend
- ;; past the fill column. If it is followed by a nonempty
- ;; comment line with the same comment prefix, try to
- ;; combine them, and repeat this until either we reach the
- ;; fill-column or there is nothing more to combine.
- (progn
- ;; Get the comment prefix
- (save-excursion
- (beginning-of-line)
- (while (and (re-search-forward "\\s<+")
- (not (octave-in-comment-p))))
- (setq comment-prefix (match-string 0)))
- ;; And keep combining ...
- (while (and (< (current-column) cfc)
- (save-excursion
- (forward-line 1)
- (and (looking-at
- (concat "^\\s-*"
- comment-prefix
- "\\S<"))
- (not (looking-at
- (concat "^\\s-*"
- comment-prefix
- "\\s-*$"))))))
- (delete-char 1)
- (re-search-forward comment-prefix)
- (delete-region (match-beginning 0) (match-end 0))
- (fixup-whitespace)
- (move-to-column cfc))))
- ;; We might also try to combine continued code lines> Perhaps
- ;; some other time ...
- (skip-chars-forward "^ \t\n")
- (delete-horizontal-space)
- (if (or (< (current-column) cfc)
- (and (= (current-column) cfc) (eolp)))
- (forward-line 1)
- (if (not (eolp)) (insert " "))
- (or (octave-auto-fill)
- (forward-line 1)))))
- t)))
+ "Fill paragraph of Octave code, handling Octave comments."
+ ;; FIXME: difference with generic fill-paragraph:
+ ;; - code lines are only split, never joined.
+ ;; - \n that end comments are never removed.
+ ;; - insert continuation marker when splitting code lines.
+ (interactive "P")
+ (save-excursion
+ (let ((end (progn (forward-paragraph) (copy-marker (point) t)))
+ (beg (progn
+ (forward-paragraph -1)
+ (skip-chars-forward " \t\n")
+ (beginning-of-line)
+ (point)))
+ (cfc (current-fill-column))
+ comment-prefix)
+ (goto-char beg)
+ (while (< (point) end)
+ (condition-case nil
+ (indent-according-to-mode)
+ (error nil))
+ (move-to-column cfc)
+ ;; First check whether we need to combine non-empty comment lines
+ (if (and (< (current-column) cfc)
+ (octave-in-comment-p)
+ (not (save-excursion
+ (beginning-of-line)
+ (looking-at "^\\s-*\\s<+\\s-*$"))))
+ ;; This is a nonempty comment line which does not extend
+ ;; past the fill column. If it is followed by a nonempty
+ ;; comment line with the same comment prefix, try to
+ ;; combine them, and repeat this until either we reach the
+ ;; fill-column or there is nothing more to combine.
+ (progn
+ ;; Get the comment prefix
+ (save-excursion
+ (beginning-of-line)
+ (while (and (re-search-forward "\\s<+")
+ (not (octave-in-comment-p))))
+ (setq comment-prefix (match-string 0)))
+ ;; And keep combining ...
+ (while (and (< (current-column) cfc)
+ (save-excursion
+ (forward-line 1)
+ (and (looking-at
+ (concat "^\\s-*"
+ comment-prefix
+ "\\S<"))
+ (not (looking-at
+ (concat "^\\s-*"
+ comment-prefix
+ "\\s-*$"))))))
+ (delete-char 1)
+ (re-search-forward comment-prefix)
+ (delete-region (match-beginning 0) (match-end 0))
+ (fixup-whitespace)
+ (move-to-column cfc))))
+ ;; We might also try to combine continued code lines> Perhaps
+ ;; some other time ...
+ (skip-chars-forward "^ \t\n")
+ (delete-horizontal-space)
+ (if (or (< (current-column) cfc)
+ (and (= (current-column) cfc) (eolp)))
+ (forward-line 1)
+ (if (not (eolp)) (insert " "))
+ (or (octave-auto-fill)
+ (forward-line 1))))
+ t)))
;;; Completions
@@ -1236,72 +977,28 @@ otherwise."
(if octave-completion-alist
()
(setq octave-completion-alist
- (mapcar '(lambda (var) (cons var var))
- (append octave-reserved-words
- octave-text-functions
- octave-variables)))))
+ (append octave-reserved-words
+ octave-text-functions
+ octave-variables))))
+
+(defun octave-completion-at-point-function ()
+ "Find the text to complete and the corresponding table."
+ (let* ((beg (save-excursion (backward-sexp 1) (point)))
+ (end (point)))
+ (if (< beg (point))
+ ;; Extend region past point, if applicable.
+ (save-excursion (goto-char beg) (forward-sexp 1)
+ (setq end (max end (point)))))
+ (list beg end octave-completion-alist)))
(defun octave-complete-symbol ()
"Perform completion on Octave symbol preceding point.
Compare that symbol against Octave's reserved words and builtin
variables."
(interactive)
- (let* ((end (point))
- (beg (save-excursion (backward-sexp 1) (point))))
- (completion-in-region beg end octave-completion-alist)))
-
+ (apply 'completion-in-region (octave-completion-at-point-function)))
;;; Electric characters && friends
-(defun octave-reindent-then-newline-and-indent ()
- "Reindent current Octave line, insert newline, and indent the new line.
-If Abbrev mode is on, expand abbrevs first."
- (interactive)
- (if abbrev-mode (expand-abbrev))
- (if octave-blink-matching-block
- (octave-blink-matching-block-open))
- (save-excursion
- (delete-region (point) (progn (skip-chars-backward " \t") (point)))
- (indent-according-to-mode))
- (insert "\n")
- (indent-according-to-mode))
-
-(defun octave-electric-semi ()
- "Insert a semicolon in Octave mode.
-Maybe expand abbrevs and blink matching block open keywords.
-Reindent the line if `octave-auto-indent' is non-nil.
-Insert a newline if `octave-auto-newline' is non-nil."
- (interactive)
- (if (not (octave-not-in-string-or-comment-p))
- (insert ";")
- (if abbrev-mode (expand-abbrev))
- (if octave-blink-matching-block
- (octave-blink-matching-block-open))
- (if octave-auto-indent
- (indent-according-to-mode))
- (insert ";")
- (if octave-auto-newline
- (newline-and-indent))))
-
-(defun octave-electric-space ()
- "Insert a space in Octave mode.
-Maybe expand abbrevs and blink matching block open keywords.
-Reindent the line if `octave-auto-indent' is non-nil."
- (interactive)
- (setq last-command-event ? )
- (if (and octave-auto-indent
- (not (octave-not-in-string-or-comment-p)))
- (progn
- (indent-according-to-mode)
- (self-insert-command 1))
- (if abbrev-mode (expand-abbrev))
- (if octave-blink-matching-block
- (octave-blink-matching-block-open))
- (if (and octave-auto-indent
- (save-excursion
- (skip-syntax-backward " ")
- (not (bolp))))
- (indent-according-to-mode))
- (self-insert-command 1)))
(defun octave-abbrev-start ()
"Start entering an Octave abbreviation.
@@ -1323,51 +1020,27 @@ Note that all Octave mode abbrevs start with a grave accent."
(list-abbrevs))
(setq unread-command-events (list c))))))
-(defun octave-insert-defun (name args vals)
+(define-skeleton octave-insert-defun
"Insert an Octave function skeleton.
Prompt for the function's name, arguments and return values (to be
entered without parens)."
- (interactive
- (list
- (read-from-minibuffer "Function name: "
- (substring (buffer-name) 0 -2))
- (read-from-minibuffer "Arguments: ")
- (read-from-minibuffer "Return values: ")))
- (let ((string (format "%s %s (%s)"
- (cond
- ((string-equal vals "")
- vals)
- ((string-match "[ ,]" vals)
- (concat " [" vals "] ="))
- (t
- (concat " " vals " =")))
- name
- args))
- (prefix octave-block-comment-start))
- (if (not (bobp)) (newline))
- (insert "function" string)
- (indent-according-to-mode)
- (newline 2)
- (insert prefix "usage: " string)
- (reindent-then-newline-and-indent)
- (insert prefix)
- (reindent-then-newline-and-indent)
- (insert prefix)
- (indent-according-to-mode)
- (save-excursion
- (newline 2)
- (insert "endfunction")
- (indent-according-to-mode))))
-
-
-;;; Menu
-(defun octave-add-octave-menu ()
- "Add the `Octave' menu to the menu bar in Octave mode."
- (require 'easymenu)
- (easy-menu-define octave-mode-menu-map octave-mode-map
- "Menu keymap for Octave mode." octave-mode-menu)
- (easy-menu-add octave-mode-menu-map octave-mode-map))
-
+ (let* ((defname (substring (buffer-name) 0 -2))
+ (name (read-string (format "Function name (default %s): " defname)
+ nil nil defname))
+ (args (read-string "Arguments: "))
+ (vals (read-string "Return values: ")))
+ (format "%s%s (%s)"
+ (cond
+ ((string-equal vals "") vals)
+ ((string-match "[ ,]" vals) (concat "[" vals "] = "))
+ (t (concat vals " = ")))
+ name
+ args))
+ \n "function " > str \n \n
+ octave-block-comment-start "usage: " str \n
+ octave-block-comment-start \n octave-block-comment-start
+ \n _ \n
+ "endfunction" > \n)
;;; Communication with the inferior Octave process
(defun octave-kill-process ()
@@ -1434,7 +1107,7 @@ entered without parens)."
"Send current Octave function to the inferior Octave process."
(interactive)
(save-excursion
- (octave-mark-defun)
+ (mark-defun)
(octave-send-region (point) (mark))))
(defun octave-send-line (&optional arg)
@@ -1483,8 +1156,6 @@ code line."
octave-maintainer-address
(concat "Emacs version " emacs-version)
(list
- 'octave-auto-indent
- 'octave-auto-newline
'octave-blink-matching-block
'octave-block-offset
'octave-comment-char
@@ -1498,5 +1169,4 @@ code line."
(provide 'octave-mod)
-;; arch-tag: 05f1ce09-be87-4c00-803e-4919ffa26c23
;;; octave-mod.el ends here
diff --git a/lisp/progmodes/pascal.el b/lisp/progmodes/pascal.el
index d19fa08bf6c..a93e97efed9 100644
--- a/lisp/progmodes/pascal.el
+++ b/lisp/progmodes/pascal.el
@@ -1,8 +1,8 @@
;;; pascal.el --- major mode for editing pascal source in Emacs
-;; Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
+;; 2002 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Espen Skoglund <esk@gnu.org>
;; Keywords: languages
@@ -223,7 +223,7 @@ The name of the function or case is included between the braces."
"*List of contexts where auto lineup of :'s or ='s should be done.
Elements can be of type: 'paramlist', 'declaration' or 'case', which will
do auto lineup in parameterlist, declarations or case-statements
-respectively. The word 'all' will do all lineups. '(case paramlist) for
+respectively. The word 'all' will do all lineups. '(case paramlist) for
instance will do lineup in case-statements and parameterlist, while '(all)
will do all lineups."
:type '(set :extra-offset 8
@@ -274,22 +274,12 @@ are handled in another way, and should not be added to this list."
;;; Macros
;;;
-(defsubst pascal-get-beg-of-line (&optional arg)
- (save-excursion
- (beginning-of-line arg)
- (point)))
-
-(defsubst pascal-get-end-of-line (&optional arg)
- (save-excursion
- (end-of-line arg)
- (point)))
-
(defun pascal-declaration-end ()
(let ((nest 1))
(while (and (> nest 0)
(re-search-forward
"[:=]\\|\\(\\<record\\>\\)\\|\\(\\<end\\>\\)"
- (save-excursion (end-of-line 2) (point)) t))
+ (point-at-eol 2) t))
(cond ((match-beginning 1) (setq nest (1+ nest)))
((match-beginning 2) (setq nest (1- nest)))
((looking-at "[^(\n]+)") (setq nest 0))))))
@@ -298,7 +288,7 @@ are handled in another way, and should not be added to this list."
(defun pascal-declaration-beg ()
(let ((nest 1))
(while (and (> nest 0)
- (re-search-backward "[:=]\\|\\<\\(type\\|var\\|label\\|const\\)\\>\\|\\(\\<record\\>\\)\\|\\(\\<end\\>\\)" (pascal-get-beg-of-line 0) t))
+ (re-search-backward "[:=]\\|\\<\\(type\\|var\\|label\\|const\\)\\>\\|\\(\\<record\\>\\)\\|\\(\\<end\\>\\)" (point-at-bol 0) t))
(cond ((match-beginning 1) (setq nest 0))
((match-beginning 2) (setq nest (1- nest)))
((match-beginning 3) (setq nest (1+ nest)))))
@@ -306,12 +296,11 @@ are handled in another way, and should not be added to this list."
(defsubst pascal-within-string ()
- (save-excursion
- (nth 3 (parse-partial-sexp (pascal-get-beg-of-line) (point)))))
+ (nth 3 (parse-partial-sexp (point-at-bol) (point))))
;;;###autoload
-(defun pascal-mode ()
+(define-derived-mode pascal-mode prog-mode "Pascal"
"Major mode for editing Pascal code. \\<pascal-mode-map>
TAB indents for Pascal code. Delete converts tabs to spaces as it moves back.
@@ -334,60 +323,47 @@ Other useful functions are:
Variables controlling indentation/edit style:
- pascal-indent-level (default 3)
+ `pascal-indent-level' (default 3)
Indentation of Pascal statements with respect to containing block.
- pascal-case-indent (default 2)
+ `pascal-case-indent' (default 2)
Indentation for case statements.
- pascal-auto-newline (default nil)
+ `pascal-auto-newline' (default nil)
Non-nil means automatically newline after semicolons and the punctuation
mark after an end.
- pascal-indent-nested-functions (default t)
+ `pascal-indent-nested-functions' (default t)
Non-nil means nested functions are indented.
- pascal-tab-always-indent (default t)
+ `pascal-tab-always-indent' (default t)
Non-nil means TAB in Pascal mode should always reindent the current line,
regardless of where in the line point is when the TAB command is used.
- pascal-auto-endcomments (default t)
+ `pascal-auto-endcomments' (default t)
Non-nil means a comment { ... } is set after the ends which ends cases and
functions. The name of the function or case will be set between the braces.
- pascal-auto-lineup (default t)
+ `pascal-auto-lineup' (default t)
List of contexts where auto lineup of :'s or ='s should be done.
-See also the user variables pascal-type-keywords, pascal-start-keywords and
-pascal-separator-keywords.
+See also the user variables `pascal-type-keywords', `pascal-start-keywords' and
+`pascal-separator-keywords'.
Turning on Pascal mode calls the value of the variable pascal-mode-hook with
no args, if that value is non-nil."
- (interactive)
- (kill-all-local-variables)
- (use-local-map pascal-mode-map)
- (setq major-mode 'pascal-mode)
- (setq mode-name "Pascal")
- (setq local-abbrev-table pascal-mode-abbrev-table)
- (set-syntax-table pascal-mode-syntax-table)
- (make-local-variable 'indent-line-function)
- (setq indent-line-function 'pascal-indent-line)
- (make-local-variable 'comment-indent-function)
- (setq comment-indent-function 'pascal-indent-comment)
- (make-local-variable 'parse-sexp-ignore-comments)
- (setq parse-sexp-ignore-comments nil)
- (make-local-variable 'blink-matching-paren-dont-ignore-comments)
- (setq blink-matching-paren-dont-ignore-comments t)
- (make-local-variable 'case-fold-search)
- (setq case-fold-search t)
- (make-local-variable 'comment-start)
- (setq comment-start "{")
- (make-local-variable 'comment-start-skip)
- (setq comment-start-skip "(\\*+ *\\|{ *")
- (make-local-variable 'comment-end)
- (setq comment-end "}")
+ (set (make-local-variable 'local-abbrev-table) pascal-mode-abbrev-table)
+ (set (make-local-variable 'indent-line-function) 'pascal-indent-line)
+ (set (make-local-variable 'comment-indent-function) 'pascal-indent-comment)
+ (set (make-local-variable 'parse-sexp-ignore-comments) nil)
+ (set (make-local-variable 'blink-matching-paren-dont-ignore-comments) t)
+ (set (make-local-variable 'case-fold-search) t)
+ (set (make-local-variable 'comment-start) "{")
+ (set (make-local-variable 'comment-start-skip) "(\\*+ *\\|{ *")
+ (set (make-local-variable 'comment-end) "}")
;; Font lock support
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults '(pascal-font-lock-keywords nil t))
+ (set (make-local-variable 'font-lock-defaults)
+ '(pascal-font-lock-keywords nil t))
;; Imenu support
- (make-local-variable 'imenu-generic-expression)
- (setq imenu-generic-expression pascal-imenu-generic-expression)
- (setq imenu-case-fold-search t)
- (run-mode-hooks 'pascal-mode-hook))
+ (set (make-local-variable 'imenu-generic-expression)
+ pascal-imenu-generic-expression)
+ (set (make-local-variable 'imenu-case-fold-search) t)
+ ;; Pascal-mode's own hide/show support.
+ (add-to-invisibility-spec '(pascal . t)))
@@ -420,8 +396,7 @@ no args, if that value is non-nil."
(forward-char 1)
(delete-horizontal-space))
((and (looking-at "(\\*\\|\\*[^)]")
- (not (save-excursion
- (search-forward "*)" (pascal-get-end-of-line) t))))
+ (not (save-excursion (search-forward "*)" (point-at-eol) t))))
(setq setstar t))))
;; If last line was a star comment line then this one shall be too.
(if (null setstar)
@@ -740,7 +715,7 @@ on the line which ends a function or procedure named NAME."
(if (and (looking-at "\\<end;")
(not (save-excursion
(end-of-line)
- (search-backward "{" (pascal-get-beg-of-line) t))))
+ (search-backward "{" (point-at-bol) t))))
(let ((type (car (pascal-calculate-indent))))
(if (eq type 'declaration)
()
@@ -1012,7 +987,7 @@ indent of the current line in parameterlist."
(stpos (progn (goto-char (scan-lists (point) -1 1)) (point)))
(stcol (1+ (current-column)))
(edpos (progn (pascal-declaration-end)
- (search-backward ")" (pascal-get-beg-of-line) t)
+ (search-backward ")" (point-at-bol) t)
(point)))
(usevar (re-search-backward "\\<var\\>" stpos t)))
(if arg (progn
@@ -1059,7 +1034,7 @@ indent of the current line in parameterlist."
(setq ind (pascal-get-lineup-indent stpos edpos lineup))
(goto-char stpos)
(while (and (<= (point) edpos) (not (eobp)))
- (if (search-forward lineup (pascal-get-end-of-line) 'move)
+ (if (search-forward lineup (point-at-eol) 'move)
(forward-char -1))
(delete-horizontal-space)
(indent-to ind)
@@ -1086,7 +1061,7 @@ indent of the current line in parameterlist."
(goto-char b)
;; Get rightmost position
(while (< (point) e)
- (and (re-search-forward reg (min e (pascal-get-end-of-line 2)) 'move)
+ (and (re-search-forward reg (min e (point-at-eol 2)) 'move)
(cond ((match-beginning 1)
;; Skip record blocks
(pascal-declaration-end))
@@ -1150,7 +1125,7 @@ indent of the current line in parameterlist."
;; Search through all reachable functions
(while (pascal-beg-of-defun)
- (if (re-search-forward pascal-str (pascal-get-end-of-line) t)
+ (if (re-search-forward pascal-str (point-at-eol) t)
(progn (setq match (buffer-substring (match-beginning 2)
(match-end 2)))
(push match pascal-all)))
@@ -1167,17 +1142,17 @@ indent of the current line in parameterlist."
match)
;; Traverse lines
(while (< (point) end)
- (if (re-search-forward "[:=]" (pascal-get-end-of-line) t)
+ (if (re-search-forward "[:=]" (point-at-eol) t)
;; Traverse current line
(while (and (re-search-backward
(concat "\\((\\|\\<\\(var\\|type\\|const\\)\\>\\)\\|"
pascal-symbol-re)
- (pascal-get-beg-of-line) t)
+ (point-at-bol) t)
(not (match-end 1)))
(setq match (buffer-substring (match-beginning 0) (match-end 0)))
(if (string-match (concat "\\<" pascal-str) match)
(push match pascal-all))))
- (if (re-search-forward "\\<record\\>" (pascal-get-end-of-line) t)
+ (if (re-search-forward "\\<record\\>" (point-at-eol) t)
(pascal-declaration-end)
(forward-line 1)))
@@ -1219,7 +1194,7 @@ indent of the current line in parameterlist."
(if (> start (prog1 (save-excursion (pascal-end-of-defun)
(point))))
() ; Declarations not reachable
- (if (search-forward "(" (pascal-get-end-of-line) t)
+ (if (search-forward "(" (point-at-eol) t)
;; Check parameterlist
;; FIXME: pascal-get-completion-decl doesn't understand
;; the var declarations in parameter lists :-(
@@ -1277,8 +1252,7 @@ indent of the current line in parameterlist."
(or (eq state 'declaration) (eq state 'paramlist)
(and (eq state 'defun)
(save-excursion
- (re-search-backward ")[ \t]*:"
- (pascal-get-beg-of-line) t))))
+ (re-search-backward ")[ \t]*:" (point-at-bol) t))))
(if (or (eq state 'paramlist) (eq state 'defun))
(pascal-beg-of-defun))
(nconc
@@ -1478,18 +1452,12 @@ Pascal Outline mode provides some additional commands.
(unless pascal-outline-mode
(pascal-show-all)))
-(defun pascal-outline-change (b e pascal-flag)
- (save-excursion
- ;; This used to use selective display so the boundaries used by the
- ;; callers didn't have to be precise, since it just looked for \n or \^M
- ;; and switched them.
- (goto-char b) (setq b (line-end-position))
- (goto-char e) (setq e (line-end-position)))
+(defun pascal-outline-change (b e hide)
(when (> e b)
;; We could try and optimize this in the case where the region is
;; already hidden. But I'm not sure it's worth the trouble.
(remove-overlays b e 'invisible 'pascal)
- (when (eq pascal-flag ?\^M)
+ (when hide
(let ((ol (make-overlay b e nil t nil)))
(overlay-put ol 'invisible 'pascal)
(overlay-put ol 'evaporate t)))))
@@ -1497,7 +1465,7 @@ Pascal Outline mode provides some additional commands.
(defun pascal-show-all ()
"Show all of the text in the buffer."
(interactive)
- (pascal-outline-change (point-min) (point-max) ?\n))
+ (pascal-outline-change (point-min) (point-max) nil))
(defun pascal-hide-other-defuns ()
"Show only the current defun."
@@ -1505,42 +1473,45 @@ Pascal Outline mode provides some additional commands.
(save-excursion
(let ((beg (progn (if (not (looking-at "\\(function\\|procedure\\)\\>"))
(pascal-beg-of-defun))
- (point)))
+ (line-beginning-position)))
(end (progn (pascal-end-of-defun)
(backward-sexp 1)
- (search-forward "\n\\|\^M" nil t)
- (point)))
+ (line-beginning-position 2)))
(opoint (point-min)))
+ ;; BEG at BOL.
+ ;; OPOINT at EOL.
+ ;; END at BOL.
(goto-char (point-min))
;; Hide all functions before current function
- (while (re-search-forward "^\\(function\\|procedure\\)\\>" beg 'move)
- (pascal-outline-change opoint (1- (match-beginning 0)) ?\^M)
- (setq opoint (point))
+ (while (re-search-forward "^[ \t]*\\(function\\|procedure\\)\\>"
+ beg 'move)
+ (pascal-outline-change opoint (line-end-position 0) t)
+ (setq opoint (line-end-position))
;; Functions may be nested
(if (> (progn (pascal-end-of-defun) (point)) beg)
(goto-char opoint)))
(if (> beg opoint)
- (pascal-outline-change opoint (1- beg) ?\^M))
+ (pascal-outline-change opoint (1- beg) t))
;; Show current function
- (pascal-outline-change beg end ?\n)
+ (pascal-outline-change (1- beg) end nil)
;; Hide nested functions
(forward-char 1)
(while (re-search-forward "^\\(function\\|procedure\\)\\>" end 'move)
- (setq opoint (point))
+ (setq opoint (line-end-position))
(pascal-end-of-defun)
- (pascal-outline-change opoint (point) ?\^M))
+ (pascal-outline-change opoint (line-end-position) t))
(goto-char end)
(setq opoint end)
;; Hide all function after current function
(while (re-search-forward "^\\(function\\|procedure\\)\\>" nil 'move)
- (pascal-outline-change opoint (1- (match-beginning 0)) ?\^M)
- (setq opoint (point))
+ (pascal-outline-change opoint (line-end-position 0) t)
+ (setq opoint (line-end-position))
(pascal-end-of-defun))
- (pascal-outline-change opoint (point-max) ?\^M)
+ (pascal-outline-change opoint (point-max) t)
;; Hide main program
(if (< (progn (forward-line -1) (point)) end)
@@ -1548,7 +1519,7 @@ Pascal Outline mode provides some additional commands.
(goto-char beg)
(pascal-end-of-defun)
(backward-sexp 1)
- (pascal-outline-change (point) (point-max) ?\^M))))))
+ (pascal-outline-change (line-end-position) (point-max) t))))))
(defun pascal-outline-next-defun ()
"Move to next function/procedure, hiding all others."
@@ -1570,5 +1541,4 @@ Pascal Outline mode provides some additional commands.
(provide 'pascal)
-;; arch-tag: 04535136-fd93-40b4-a505-c9bebdc051f5
;;; pascal.el ends here
diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el
index f8eba5accdb..97de1b35621 100644
--- a/lisp/progmodes/perl-mode.el
+++ b/lisp/progmodes/perl-mode.el
@@ -250,59 +250,81 @@ The expansion is entirely correct because it uses the C preprocessor."
;; y /.../.../
;;
;; <file*glob>
-(defvar perl-font-lock-syntactic-keywords
- ;; TODO: here-documents ("<<\\(\\sw\\|['\"]\\)")
- `(;; Turn POD into b-style comments
- ("^\\(=\\)\\sw" (1 "< b"))
- ("^=cut[ \t]*\\(\n\\)" (1 "> b"))
- ;; Catch ${ so that ${var} doesn't screw up indentation.
- ;; This also catches $' to handle 'foo$', although it should really
- ;; check that it occurs inside a '..' string.
- ("\\(\\$\\)[{']" (1 ". p"))
- ;; Handle funny names like $DB'stop.
- ("\\$ ?{?^?[_a-zA-Z][_a-zA-Z0-9]*\\('\\)[_a-zA-Z]" (1 "_"))
- ;; format statements
- ("^[ \t]*format.*=[ \t]*\\(\n\\)" (1 '(7)))
- ;; Funny things in `sub' arg-specs like `sub myfun ($)' or `sub ($)'.
- ;; Be careful not to match "sub { (...) ... }".
- ("\\<sub\\(?:[[:space:]]+[^{}[:punct:][:space:]]+\\)?[[:space:]]*(\\([^)]+\\))"
- 1 '(1))
- ;; Regexp and funny quotes. Distinguishing a / that starts a regexp
- ;; match from the division operator is ...interesting.
- ;; Basically, / is a regexp match if it's preceded by an infix operator
- ;; (or some similar separator), or by one of the special keywords
- ;; corresponding to builtin functions that can take their first arg
- ;; without parentheses. Of course, that presume we're looking at the
- ;; *opening* slash. We can afford to mis-match the closing ones
- ;; here, because they will be re-treated separately later in
- ;; perl-font-lock-special-syntactic-constructs.
- (,(concat "\\(?:\\(?:\\(?:^\\|[^$@&%[:word:]]\\)"
- (regexp-opt '("split" "if" "unless" "until" "while" "split"
- "grep" "map" "not" "or" "and"))
- "\\)\\|[?:.,;=!~({[]\\|\\(^\\)\\)[ \t\n]*\\(/\\)")
- (2 (if (and (match-end 1)
- (save-excursion
- (goto-char (match-end 1))
- ;; Not 100% correct since we haven't finished setting up
- ;; the syntax-table before point, but better than nothing.
- (forward-comment (- (point-max)))
- (put-text-property (point) (match-end 2)
- 'jit-lock-defer-multiline t)
- (not (memq (char-before)
- '(?? ?: ?. ?, ?\; ?= ?! ?~ ?\( ?\[)))))
- nil ;; A division sign instead of a regexp-match.
- '(7))))
- ("\\(^\\|[?:.,;=!~({[ \t]\\)\\([msy]\\|q[qxrw]?\\|tr\\)\\>\\s-*\\([^])}> \n\t]\\)"
- ;; Nasty cases:
- ;; /foo/m $a->m $#m $m @m %m
- ;; \s (appears often in regexps).
- ;; -s file
- (3 (if (assoc (char-after (match-beginning 3))
- perl-quote-like-pairs)
- '(15) '(7))))
- ;; Find and mark the end of funny quotes and format statements.
- (perl-font-lock-special-syntactic-constructs)
- ))
+(defun perl-syntax-propertize-function (start end)
+ (let ((case-fold-search nil))
+ (goto-char start)
+ (perl-syntax-propertize-special-constructs end)
+ ;; TODO: here-documents ("<<\\(\\sw\\|['\"]\\)")
+ (funcall
+ (syntax-propertize-rules
+ ;; Turn POD into b-style comments. Place the cut rule first since it's
+ ;; more specific.
+ ("^=cut\\>.*\\(\n\\)" (1 "> b"))
+ ("^\\(=\\)\\sw" (1 "< b"))
+ ;; Catch ${ so that ${var} doesn't screw up indentation.
+ ;; This also catches $' to handle 'foo$', although it should really
+ ;; check that it occurs inside a '..' string.
+ ("\\(\\$\\)[{']" (1 ". p"))
+ ;; Handle funny names like $DB'stop.
+ ("\\$ ?{?^?[_a-zA-Z][_a-zA-Z0-9]*\\('\\)[_a-zA-Z]" (1 "_"))
+ ;; format statements
+ ("^[ \t]*format.*=[ \t]*\\(\n\\)"
+ (1 (prog1 "\"" (perl-syntax-propertize-special-constructs end))))
+ ;; Funny things in `sub' arg-specs like `sub myfun ($)' or `sub ($)'.
+ ;; Be careful not to match "sub { (...) ... }".
+ ("\\<sub\\(?:[[:space:]]+[^{}[:punct:][:space:]]+\\)?[[:space:]]*(\\([^)]+\\))"
+ (1 "."))
+ ;; Turn __DATA__ trailer into a comment.
+ ("^\\(_\\)_\\(?:DATA\\|END\\)__[ \t]*\\(?:\\(\n\\)#.-\\*-.*perl.*-\\*-\\|\n.*\\)"
+ (1 "< c") (2 "> c")
+ (0 (ignore (put-text-property (match-beginning 0) (match-end 0)
+ 'syntax-multiline t))))
+ ;; Regexp and funny quotes. Distinguishing a / that starts a regexp
+ ;; match from the division operator is ...interesting.
+ ;; Basically, / is a regexp match if it's preceded by an infix operator
+ ;; (or some similar separator), or by one of the special keywords
+ ;; corresponding to builtin functions that can take their first arg
+ ;; without parentheses. Of course, that presume we're looking at the
+ ;; *opening* slash. We can afford to mis-match the closing ones
+ ;; here, because they will be re-treated separately later in
+ ;; perl-font-lock-special-syntactic-constructs.
+ ((concat "\\(?:\\(?:^\\|[^$@&%[:word:]]\\)"
+ (regexp-opt '("split" "if" "unless" "until" "while" "split"
+ "grep" "map" "not" "or" "and"))
+ "\\|[?:.,;=!~({[]\\|\\(^\\)\\)[ \t\n]*\\(/\\)")
+ (2 (ignore
+ (if (and (match-end 1) ; / at BOL.
+ (save-excursion
+ (goto-char (match-end 1))
+ (forward-comment (- (point-max)))
+ (put-text-property (point) (match-end 2)
+ 'syntax-multiline t)
+ (not (memq (char-before)
+ '(?? ?: ?. ?, ?\; ?= ?! ?~ ?\( ?\[)))))
+ nil ;; A division sign instead of a regexp-match.
+ (put-text-property (match-beginning 2) (match-end 2)
+ 'syntax-table (string-to-syntax "\""))
+ (perl-syntax-propertize-special-constructs end)))))
+ ("\\(^\\|[?:.,;=!~({[ \t]\\)\\([msy]\\|q[qxrw]?\\|tr\\)\\>\\s-*\\([^])}> \n\t]\\)"
+ ;; Nasty cases:
+ ;; /foo/m $a->m $#m $m @m %m
+ ;; \s (appears often in regexps).
+ ;; -s file
+ ;; sub tr {...}
+ (3 (ignore
+ (if (save-excursion (goto-char (match-beginning 0))
+ (forward-word -1)
+ (looking-at-p "sub[ \t\n]"))
+ ;; This is defining a function.
+ nil
+ (put-text-property (match-beginning 3) (match-end 3)
+ 'syntax-table
+ (if (assoc (char-after (match-beginning 3))
+ perl-quote-like-pairs)
+ (string-to-syntax "|")
+ (string-to-syntax "\"")))
+ (perl-syntax-propertize-special-constructs end))))))
+ (point) end)))
(defvar perl-empty-syntax-table
(let ((st (copy-syntax-table)))
@@ -321,95 +343,123 @@ The expansion is entirely correct because it uses the C preprocessor."
(modify-syntax-entry close ")" st))
st))
-(defun perl-font-lock-special-syntactic-constructs (limit)
- ;; We used to do all this in a font-lock-syntactic-face-function, which
- ;; did not work correctly because sometimes some parts of the buffer are
- ;; treated with font-lock-syntactic-keywords but not with
- ;; font-lock-syntactic-face-function (mostly because of
- ;; font-lock-syntactically-fontified). That meant that some syntax-table
- ;; properties were missing. So now we do the parse-partial-sexp loop
- ;; ourselves directly from font-lock-syntactic-keywords, so we're sure
- ;; it's done when necessary.
+(defun perl-syntax-propertize-special-constructs (limit)
+ "Propertize special constructs like regexps and formats."
(let ((state (syntax-ppss))
char)
- (while (< (point) limit)
- (cond
- ((or (null (setq char (nth 3 state)))
- (and (characterp char) (eq (char-syntax (nth 3 state)) ?\")))
- ;; Normal text, or comment, or docstring, or normal string.
- nil)
- ((eq (nth 3 state) ?\n)
- ;; A `format' command.
- (save-excursion
- (when (and (re-search-forward "^\\s *\\.\\s *$" nil t)
- (not (eobp)))
- (put-text-property (point) (1+ (point)) 'syntax-table '(7)))))
- (t
- ;; This is regexp like quote thingy.
- (setq char (char-after (nth 8 state)))
- (save-excursion
- (let ((twoargs (save-excursion
- (goto-char (nth 8 state))
- (skip-syntax-backward " ")
- (skip-syntax-backward "w")
- (member (buffer-substring
- (point) (progn (forward-word 1) (point)))
- '("tr" "s" "y"))))
- (close (cdr (assq char perl-quote-like-pairs)))
- (pos (point))
- (st (perl-quote-syntax-table char)))
- (if (not close)
- ;; The closing char is the same as the opening char.
- (with-syntax-table st
- (parse-partial-sexp (point) (point-max)
- nil nil state 'syntax-table)
- (when twoargs
- (parse-partial-sexp (point) (point-max)
- nil nil state 'syntax-table)))
- ;; The open/close chars are matched like () [] {} and <>.
- (let ((parse-sexp-lookup-properties nil))
- (condition-case err
- (progn
- (with-syntax-table st
- (goto-char (nth 8 state)) (forward-sexp 1))
- (when twoargs
- (save-excursion
- ;; Skip whitespace and make sure that font-lock will
- ;; refontify the second part in the proper context.
- (put-text-property
- (point) (progn (forward-comment (point-max)) (point))
- 'font-lock-multiline t)
- ;;
- (unless
- (or (eobp)
- (save-excursion
- (with-syntax-table
- (perl-quote-syntax-table (char-after))
- (forward-sexp 1))
- (put-text-property pos (line-end-position)
- 'jit-lock-defer-multiline t)
- (looking-at "\\s-*\\sw*e")))
- (put-text-property (point) (1+ (point))
- 'syntax-table
- (if (assoc (char-after)
- perl-quote-like-pairs)
- '(15) '(7)))))))
- ;; The arg(s) is not terminated, so it extends until EOB.
- (scan-error (goto-char (point-max))))))
- ;; Point is now right after the arg(s).
- ;; Erase any syntactic marks within the quoted text.
- (put-text-property pos (1- (point)) 'syntax-table nil)
- (when (eq (char-before (1- (point))) ?$)
- (put-text-property (- (point) 2) (1- (point))
- 'syntax-table '(1)))
- (put-text-property (1- (point)) (point)
- 'syntax-table (if close '(15) '(7)))))))
-
- (setq state (parse-partial-sexp (point) limit nil nil state
- 'syntax-table))))
- ;; Tell font-lock that this needs not further processing.
- nil)
-
+ (cond
+ ((or (null (setq char (nth 3 state)))
+ (and (characterp char) (eq (char-syntax (nth 3 state)) ?\")))
+ ;; Normal text, or comment, or docstring, or normal string.
+ nil)
+ ((eq (nth 3 state) ?\n)
+ ;; A `format' command.
+ (when (re-search-forward "^\\s *\\.\\s *\n" limit 'move)
+ (put-text-property (1- (point)) (point)
+ 'syntax-table (string-to-syntax "\""))))
+ (t
+ ;; This is regexp like quote thingy.
+ (setq char (char-after (nth 8 state)))
+ (let ((twoargs (save-excursion
+ (goto-char (nth 8 state))
+ (skip-syntax-backward " ")
+ (skip-syntax-backward "w")
+ (member (buffer-substring
+ (point) (progn (forward-word 1) (point)))
+ '("tr" "s" "y"))))
+ (close (cdr (assq char perl-quote-like-pairs)))
+ (st (perl-quote-syntax-table char)))
+ (when (with-syntax-table st
+ (if close
+ ;; For paired delimiters, Perl allows nesting them, but
+ ;; since we treat them as strings, Emacs does not count
+ ;; those delimiters in `state', so we don't know how deep
+ ;; we are: we have to go back to the beginning of this
+ ;; "string" and count from there.
+ (condition-case nil
+ (progn
+ ;; Start after the first char since it doesn't have
+ ;; paren-syntax (an alternative would be to let-bind
+ ;; parse-sexp-lookup-properties).
+ (goto-char (1+ (nth 8 state)))
+ (up-list 1)
+ t)
+ (scan-error nil))
+ (not (or (nth 8 (parse-partial-sexp
+ (point) limit nil nil state 'syntax-table))
+ ;; If we have a self-paired opener and a twoargs
+ ;; command, the form is s/../../ so we have to skip
+ ;; a second time.
+ ;; In the case of s{...}{...}, we only handle the
+ ;; first part here and the next below.
+ (when (and twoargs (not close))
+ (nth 8 (parse-partial-sexp
+ (point) limit
+ nil nil state 'syntax-table)))))))
+ ;; Point is now right after the arg(s).
+ (when (eq (char-before (1- (point))) ?$)
+ (put-text-property (- (point) 2) (1- (point))
+ 'syntax-table '(1)))
+ (put-text-property (1- (point)) (point)
+ 'syntax-table
+ (if close
+ (string-to-syntax "|")
+ (string-to-syntax "\"")))
+ ;; If we have two args with a non-self-paired starter (e.g.
+ ;; s{...}{...}) we're right after the first arg, so we still have to
+ ;; handle the second part.
+ (when (and twoargs close)
+ ;; Skip whitespace and make sure that font-lock will
+ ;; refontify the second part in the proper context.
+ (put-text-property
+ (point) (progn (forward-comment (point-max)) (point))
+ 'syntax-multiline t)
+ ;;
+ (when (< (point) limit)
+ (put-text-property (point) (1+ (point))
+ 'syntax-table
+ (if (assoc (char-after)
+ perl-quote-like-pairs)
+ ;; Put an `e' in the cdr to mark this
+ ;; char as "second arg starter".
+ (string-to-syntax "|e")
+ (string-to-syntax "\"e")))
+ (forward-char 1)
+ ;; Re-use perl-syntax-propertize-special-constructs to handle the
+ ;; second part (the first delimiter of second part can't be
+ ;; preceded by "s" or "tr" or "y", so it will not be considered
+ ;; as twoarg).
+ (perl-syntax-propertize-special-constructs limit)))))))))
+
+(defun perl-font-lock-syntactic-face-function (state)
+ (cond
+ ((and (nth 3 state)
+ (eq ?e (cdr-safe (get-text-property (nth 8 state) 'syntax-table)))
+ ;; This is a second-arg of s{..}{...} form; let's check if this second
+ ;; arg is executable code rather than a string. For that, we need to
+ ;; look for an "e" after this second arg, so we have to hunt for the
+ ;; end of the arg. Depending on whether the whole arg has already
+ ;; been syntax-propertized or not, the end-char will have different
+ ;; syntaxes, so let's ignore syntax-properties temporarily so we can
+ ;; pretend it has not been syntax-propertized yet.
+ (let* ((parse-sexp-lookup-properties nil)
+ (char (char-after (nth 8 state)))
+ (paired (assq char perl-quote-like-pairs)))
+ (with-syntax-table (perl-quote-syntax-table char)
+ (save-excursion
+ (if (not paired)
+ (parse-partial-sexp (point) (point-max)
+ nil nil state 'syntax-table)
+ (condition-case nil
+ (progn
+ (goto-char (1+ (nth 8 state)))
+ (up-list 1))
+ (scan-error (goto-char (point-max)))))
+ (put-text-property (nth 8 state) (point)
+ 'jit-lock-defer-multiline t)
+ (looking-at "[ \t]*\\sw*e")))))
+ nil)
+ (t (funcall (default-value 'font-lock-syntactic-face-function) state))))
(defcustom perl-indent-level 4
"*Indentation of Perl statements with respect to containing block."
@@ -574,9 +624,12 @@ Turning on Perl mode runs the normal hook `perl-mode-hook'."
perl-font-lock-keywords-1
perl-font-lock-keywords-2)
nil nil ((?\_ . "w")) nil
- (font-lock-syntactic-keywords
- . perl-font-lock-syntactic-keywords)
- (parse-sexp-lookup-properties . t)))
+ (font-lock-syntactic-face-function
+ . perl-font-lock-syntactic-face-function)))
+ (set (make-local-variable 'syntax-propertize-function)
+ #'perl-syntax-propertize-function)
+ (add-hook 'syntax-propertize-extend-region-functions
+ #'syntax-propertize-multiline 'append 'local)
;; Tell imenu how to handle Perl.
(set (make-local-variable 'imenu-generic-expression)
perl-imenu-generic-expression)
@@ -867,9 +920,7 @@ Optional argument PARSE-START should be the position of `beginning-of-defun'."
(cond ((looking-at ";?#")
(forward-line 1) t)
((looking-at "\\(\\w\\|\\s_\\)+:[^:]")
- (save-excursion
- (end-of-line)
- (setq colon-line-end (point)))
+ (setq colon-line-end (line-end-position))
(search-forward ":")))))
;; The first following code counts
;; if it is before the line we want to indent.
@@ -929,7 +980,7 @@ Optional argument PARSE-START should be the position of `beginning-of-defun'."
(if (= (char-after (marker-position bof-mark)) ?=)
(message "Can't indent a format statement")
(message "Indenting Perl expression...")
- (save-excursion (end-of-line) (setq eol (point)))
+ (setq eol (line-end-position))
(save-excursion ; locate matching close paren
(while (and (not (eobp)) (<= (point) eol))
(parse-partial-sexp (point) (point-max) 0))
@@ -1027,5 +1078,4 @@ With argument, repeat that many times; negative args move backward."
(provide 'perl-mode)
-;; arch-tag: 8c7ff68d-15f3-46a2-ade2-b7c41f176826
;;; perl-mode.el ends here
diff --git a/lisp/progmodes/prolog.el b/lisp/progmodes/prolog.el
index 197b41506bd..f2f80d0d81d 100644
--- a/lisp/progmodes/prolog.el
+++ b/lisp/progmodes/prolog.el
@@ -31,6 +31,7 @@
(defvar comint-prompt-regexp)
(defvar comint-process-echoes)
+(require 'smie)
(defgroup prolog nil
"Major mode for editing and running Prolog under Emacs."
@@ -98,6 +99,86 @@ When nil, send actual operating system end of file."
(defvar prolog-mode-abbrev-table nil)
(define-abbrev-table 'prolog-mode-abbrev-table ())
+(defun prolog-smie-forward-token ()
+ (forward-comment (point-max))
+ (buffer-substring-no-properties
+ (point)
+ (progn (cond
+ ((looking-at "[!;]") (forward-char 1))
+ ((not (zerop (skip-chars-forward "#&*+-./:<=>?@\\^`~"))))
+ ((not (zerop (skip-syntax-forward "w_'"))))
+ ;; In case of non-ASCII punctuation.
+ ((not (zerop (skip-syntax-forward ".")))))
+ (point))))
+
+(defun prolog-smie-backward-token ()
+ (forward-comment (- (point-max)))
+ (buffer-substring-no-properties
+ (point)
+ (progn (cond
+ ((memq (char-before) '(?! ?\;)) (forward-char -1))
+ ((not (zerop (skip-chars-backward "#&*+-./:<=>?@\\^`~"))))
+ ((not (zerop (skip-syntax-backward "w_'"))))
+ ;; In case of non-ASCII punctuation.
+ ((not (zerop (skip-syntax-backward ".")))))
+ (point))))
+
+(defconst prolog-smie-grammar
+ ;; Rather than construct the operator levels table from the BNF,
+ ;; we directly provide the operator precedences from GNU Prolog's
+ ;; manual (7.14.10 op/3). The only problem is that GNU Prolog's
+ ;; manual uses precedence levels in the opposite sense (higher
+ ;; numbers bind less tightly) than SMIE, so we use negative numbers.
+ '(("." -10000 -10000)
+ (":-" -1200 -1200)
+ ("-->" -1200 -1200)
+ (";" -1100 -1100)
+ ("->" -1050 -1050)
+ ("," -1000 -1000)
+ ("\\+" -900 -900)
+ ("=" -700 -700)
+ ("\\=" -700 -700)
+ ("=.." -700 -700)
+ ("==" -700 -700)
+ ("\\==" -700 -700)
+ ("@<" -700 -700)
+ ("@=<" -700 -700)
+ ("@>" -700 -700)
+ ("@>=" -700 -700)
+ ("is" -700 -700)
+ ("=:=" -700 -700)
+ ("=\\=" -700 -700)
+ ("<" -700 -700)
+ ("=<" -700 -700)
+ (">" -700 -700)
+ (">=" -700 -700)
+ (":" -600 -600)
+ ("+" -500 -500)
+ ("-" -500 -500)
+ ("/\\" -500 -500)
+ ("\\/" -500 -500)
+ ("*" -400 -400)
+ ("/" -400 -400)
+ ("//" -400 -400)
+ ("rem" -400 -400)
+ ("mod" -400 -400)
+ ("<<" -400 -400)
+ (">>" -400 -400)
+ ("**" -200 -200)
+ ("^" -200 -200)
+ ;; Prefix
+ ;; ("+" 200 200)
+ ;; ("-" 200 200)
+ ;; ("\\" 200 200)
+ )
+ "Precedence levels of infix operators.")
+
+(defun prolog-smie-rules (kind token)
+ (pcase (cons kind token)
+ (`(:elem . basic) prolog-indent-width)
+ (`(:after . ".") 0) ;; To work around smie-closer-alist.
+ (`(:after . ,(or `":-" `"->")) prolog-indent-width)))
+
(defun prolog-mode-variables ()
(make-local-variable 'paragraph-separate)
(setq paragraph-separate (concat "%%\\|$\\|" page-delimiter)) ;'%%..'
@@ -105,8 +186,17 @@ When nil, send actual operating system end of file."
(setq paragraph-ignore-fill-prefix t)
(make-local-variable 'imenu-generic-expression)
(setq imenu-generic-expression '((nil "^\\sw+" 0)))
- (make-local-variable 'indent-line-function)
- (setq indent-line-function 'prolog-indent-line)
+
+ ;; Setup SMIE.
+ (smie-setup prolog-smie-grammar #'prolog-smie-rules
+ :forward-token #'prolog-smie-forward-token
+ :backward-token #'prolog-smie-backward-token)
+ (set (make-local-variable 'smie-blink-matching-triggers) '(?.))
+ (set (make-local-variable 'smie-closer-alist) '((t . ".")))
+ (add-hook 'post-self-insert-hook #'smie-blink-matching-open 'append 'local)
+ ;; There's no real closer in Prolog anyway.
+ (set (make-local-variable 'smie-blink-matching-inners) t)
+
(make-local-variable 'comment-start)
(setq comment-start "%")
(make-local-variable 'comment-start-skip)
@@ -122,7 +212,7 @@ When nil, send actual operating system end of file."
(define-key map "\C-c\C-l" 'inferior-prolog-load-file)
(define-key map "\C-c\C-z" 'switch-to-prolog)
map))
-
+
(easy-menu-define prolog-mode-menu prolog-mode-map "Menu for Prolog mode."
;; Mostly copied from scheme-mode's menu.
;; Not tremendously useful, but it's a start.
@@ -136,90 +226,23 @@ When nil, send actual operating system end of file."
))
;;;###autoload
-(defun prolog-mode ()
+(define-derived-mode prolog-mode prog-mode "Prolog"
"Major mode for editing Prolog code for Prologs.
Blank lines and `%%...' separate paragraphs. `%'s start comments.
Commands:
\\{prolog-mode-map}
Entry to this mode calls the value of `prolog-mode-hook'
if that value is non-nil."
- (interactive)
- (kill-all-local-variables)
- (use-local-map prolog-mode-map)
- (set-syntax-table prolog-mode-syntax-table)
- (setq major-mode 'prolog-mode)
- (setq mode-name "Prolog")
(prolog-mode-variables)
(set (make-local-variable 'comment-add) 1)
- ;; font lock
(setq font-lock-defaults '(prolog-font-lock-keywords
nil nil nil
- beginning-of-line))
- (run-mode-hooks 'prolog-mode-hook))
-
-(defun prolog-indent-line ()
- "Indent current line as Prolog code.
-With argument, indent any additional lines of the same clause
-rigidly along with this one (not yet)."
- (interactive "p")
- (let ((indent (prolog-indent-level))
- (pos (- (point-max) (point))))
- (beginning-of-line)
- (indent-line-to indent)
- (if (> (- (point-max) pos) (point))
- (goto-char (- (point-max) pos)))))
-
-(defun prolog-indent-level ()
- "Compute Prolog indentation level."
- (save-excursion
- (beginning-of-line)
- (skip-chars-forward " \t")
- (cond
- ((looking-at "%%%") 0) ;Large comment starts
- ((looking-at "%[^%]") comment-column) ;Small comment starts
- ((bobp) 0) ;Beginning of buffer
- (t
- (let ((empty t) ind more less)
- (if (looking-at ")")
- (setq less t) ;Find close
- (setq less nil))
- ;; See previous indentation
- (while empty
- (forward-line -1)
- (beginning-of-line)
- (if (bobp)
- (setq empty nil)
- (skip-chars-forward " \t")
- (if (not (or (looking-at "%[^%]") (looking-at "\n")))
- (setq empty nil))))
- (if (bobp)
- (setq ind 0) ;Beginning of buffer
- (setq ind (current-column))) ;Beginning of clause
- ;; See its beginning
- (if (looking-at "%%[^%]")
- ind
- ;; Real prolog code
- (if (looking-at "(")
- (setq more t) ;Find open
- (setq more nil))
- ;; See its tail
- (end-of-prolog-clause)
- (or (bobp) (forward-char -1))
- (cond ((looking-at "[,(;>]")
- (if (and more (looking-at "[^,]"))
- (+ ind prolog-indent-width) ;More indentation
- (max tab-width ind))) ;Same indentation
- ((looking-at "-") tab-width) ;TAB
- ((or less (looking-at "[^.]"))
- (max (- ind prolog-indent-width) 0)) ;Less indentation
- (t 0)) ;No indentation
- )))
- )))
+ beginning-of-line)))
(defun end-of-prolog-clause ()
"Go to end of clause in this line."
(beginning-of-line 1)
- (let* ((eolpos (save-excursion (end-of-line) (point))))
+ (let* ((eolpos (line-end-position)))
(if (re-search-forward comment-start-skip eolpos 'move)
(goto-char (match-beginning 0)))
(skip-chars-backward " \t")))
@@ -411,5 +434,4 @@ If COMPILE (prefix arg) is not nil, use compile mode rather than consult mode."
(provide 'prolog)
-;; arch-tag: f3ec6748-1272-4ab6-8826-c50cb1607636
;;; prolog.el ends here
diff --git a/lisp/progmodes/ps-mode.el b/lisp/progmodes/ps-mode.el
index 93a559258fa..9b83f77d3b8 100644
--- a/lisp/progmodes/ps-mode.el
+++ b/lisp/progmodes/ps-mode.el
@@ -6,7 +6,7 @@
;; Author: Peter Kleiweg <p.c.j.kleiweg@rug.nl>
;; Maintainer: Peter Kleiweg <p.c.j.kleiweg@rug.nl>
;; Created: 20 Aug 1997
-;; Version: 1.1h, 16 Jun 2005
+;; Version: 1.1h
;; Keywords: PostScript, languages
;; Yoni Rabkin <yoni@rabkins.net> contacted the maintainer of this
@@ -39,6 +39,7 @@
(defconst ps-mode-version "1.1h, 16 Jun 2005")
(defconst ps-mode-maintainer-address "Peter Kleiweg <p.c.j.kleiweg@rug.nl>")
+(require 'comint)
(require 'easymenu)
;; Define core `PostScript' group.
@@ -431,12 +432,11 @@ If nil, use `temporary-file-directory'."
(unless ps-run-mode-map
(setq ps-run-mode-map (make-sparse-keymap))
+ (set-keymap-parent ps-run-mode-map comint-mode-map)
(define-key ps-run-mode-map "\C-c\C-q" 'ps-run-quit)
(define-key ps-run-mode-map "\C-c\C-k" 'ps-run-kill)
(define-key ps-run-mode-map "\C-c\C-e" 'ps-run-goto-error)
- (define-key ps-run-mode-map [mouse-2] 'ps-run-mouse-goto-error)
- (define-key ps-run-mode-map "\r" 'ps-run-newline)
- (define-key ps-run-mode-map [return] 'ps-run-newline))
+ (define-key ps-run-mode-map [mouse-2] 'ps-run-mouse-goto-error))
;; Syntax table.
@@ -681,7 +681,7 @@ defines the beginning of a group. These tokens are: { [ <<"
(if (or (not ps-mode-auto-indent)
(< ps-mode-tab 1)
(not (re-search-backward "^[ \t]+\\=" nil t)))
- (delete-backward-char 1)
+ (call-interactively 'delete-backward-char)
(setq target (ps-mode-target-column))
(while (> column target)
(setq target (+ target ps-mode-tab)))
@@ -718,12 +718,9 @@ defines the beginning of a group. These tokens are: { [ <<"
(blink-matching-open))
(defun ps-mode-other-newline ()
- "Perform newline in `*ps run*' buffer."
+ "Perform newline in `*ps-run*' buffer."
(interactive)
- (let ((buf (current-buffer)))
- (set-buffer "*ps run*")
- (ps-run-newline)
- (set-buffer buf)))
+ (ps-run-send-string ""))
;; Print PostScript.
@@ -980,7 +977,7 @@ plus the usually uncoded characters inserted on positions 1 through 28."
;; Interactive PostScript interpreter.
-(define-derived-mode ps-run-mode fundamental-mode "Interactive PS"
+(define-derived-mode ps-run-mode comint-mode "Interactive PS"
"Major mode in interactive PostScript window.
This mode is invoked from `ps-mode' and should not be called directly.
@@ -1014,20 +1011,23 @@ This mode is invoked from `ps-mode' and should not be called directly.
(setq init-file (ps-run-make-tmp-filename))
(write-region (concat ps-run-init "\n") 0 init-file)
(setq init-file (list init-file)))
- (pop-to-buffer "*ps run*")
+ (pop-to-buffer "*ps-run*")
(ps-run-mode)
(when (process-status "ps-run")
(delete-process "ps-run"))
(erase-buffer)
(setq command (append command init-file))
(insert (mapconcat 'identity command " ") "\n")
- (apply 'start-process "ps-run" "*ps run*" command)
+ (apply 'make-comint "ps-run" (car command) nil (cdr command))
+ (with-current-buffer "*ps-run*"
+ (use-local-map ps-run-mode-map)
+ (setq comint-prompt-regexp ps-run-prompt))
(select-window oldwin)))
(defun ps-run-quit ()
"Quit interactive PostScript."
(interactive)
- (ps-run-send-string "quit" t)
+ (ps-run-send-string "quit")
(ps-run-cleanup))
(defun ps-run-kill ()
@@ -1039,9 +1039,9 @@ This mode is invoked from `ps-mode' and should not be called directly.
(defun ps-run-clear ()
"Clear/reset PostScript graphics."
(interactive)
- (ps-run-send-string "showpage" t)
+ (ps-run-send-string "showpage")
(sit-for 1)
- (ps-run-send-string "" t))
+ (ps-run-send-string ""))
(defun ps-run-buffer ()
"Send buffer to PostScript interpreter."
@@ -1056,7 +1056,7 @@ This mode is invoked from `ps-mode' and should not be called directly.
(let ((f (ps-run-make-tmp-filename)))
(set-marker ps-run-mark begin)
(write-region begin end f)
- (ps-run-send-string (format "(%s) run" f) t)))
+ (ps-run-send-string (format "(%s) run" f))))
(defun ps-run-boundingbox ()
"View BoundingBox."
@@ -1104,17 +1104,15 @@ grestore
" x1 y1 x2 y1 x2 y2 x1 y2)
0
f)
- (ps-run-send-string (format "(%s) run" f) t)
+ (ps-run-send-string (format "(%s) run" f))
(set-buffer buf)))
-(defun ps-run-send-string (string &optional echo)
+(defun ps-run-send-string (string)
(let ((oldwin (selected-window)))
- (pop-to-buffer "*ps run*")
- (goto-char (point-max))
- (when echo
- (insert string "\n"))
- (set-marker (process-mark (get-process "ps-run")) (point))
- (process-send-string "ps-run" (concat string "\n"))
+ (pop-to-buffer "*ps-run*")
+ (comint-goto-process-mark)
+ (insert string)
+ (comint-send-input)
(select-window oldwin)))
(defun ps-run-make-tmp-filename ()
@@ -1140,18 +1138,6 @@ grestore
(mouse-set-point event)
(ps-run-goto-error))
-(defun ps-run-newline ()
- "Process newline in PostScript interpreter window."
- (interactive)
- (end-of-line)
- (insert "\n")
- (forward-line -1)
- (when (looking-at ps-run-prompt)
- (goto-char (match-end 0)))
- (looking-at ".*")
- (goto-char (1+ (match-end 0)))
- (ps-run-send-string (buffer-substring (match-beginning 0) (match-end 0))))
-
(defun ps-run-goto-error ()
"Jump to buffer position read as integer at point.
Use line numbers if `ps-run-error-line-numbers' is not nil"
diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el
index 6fdaa126b5b..0a641d0945f 100644
--- a/lisp/progmodes/python.el
+++ b/lisp/progmodes/python.el
@@ -110,7 +110,8 @@
(,(rx symbol-start (group "def") (1+ space) (group (1+ (or word ?_))))
(1 font-lock-keyword-face) (2 font-lock-function-name-face))
;; Top-level assignments are worth highlighting.
- (,(rx line-start (group (1+ (or word ?_))) (0+ space) "=")
+ (,(rx line-start (group (1+ (or word ?_))) (0+ space)
+ (opt (or "+" "-" "*" "**" "/" "//" "&" "%" "|" "^" "<<" ">>")) "=")
(1 font-lock-variable-name-face))
;; Decorators.
(,(rx line-start (* (any " \t")) (group "@" (1+ (or word ?_))
@@ -166,20 +167,20 @@
symbol-end)
. font-lock-builtin-face)))
-(defconst python-font-lock-syntactic-keywords
+(defconst python-syntax-propertize-function
;; Make outer chars of matching triple-quote sequences into generic
;; string delimiters. Fixme: Is there a better way?
;; First avoid a sequence preceded by an odd number of backslashes.
- `((,(concat "\\(?:\\([RUru]\\)[Rr]?\\|^\\|[^\\]\\(?:\\\\.\\)*\\)" ;Prefix.
+ (syntax-propertize-rules
+ (;; Backrefs don't work in syntax-propertize-rules!
+ (concat "\\(?:\\([RUru]\\)[Rr]?\\|^\\|[^\\]\\(?:\\\\.\\)*\\)" ;Prefix.
"\\(?:\\('\\)'\\('\\)\\|\\(?2:\"\\)\"\\(?3:\"\\)\\)")
- (1 (python-quote-syntax 1) nil lax)
- (2 (python-quote-syntax 2))
- (3 (python-quote-syntax 3)))
- ;; This doesn't really help.
-;;; (,(rx (and ?\\ (group ?\n))) (1 " "))
- ))
-
-(defun python-quote-syntax (n)
+ (3 (ignore (python-quote-syntax))))
+ ;; This doesn't really help.
+ ;;((rx (and ?\\ (group ?\n))) (1 " "))
+ ))
+
+(defun python-quote-syntax ()
"Put `syntax-table' property correctly on triple quote.
Used for syntactic keywords. N is the match number (1, 2 or 3)."
;; Given a triple quote, we have to check the context to know
@@ -197,28 +198,25 @@ Used for syntactic keywords. N is the match number (1, 2 or 3)."
;; x '"""' x """ \"""" x
(save-excursion
(goto-char (match-beginning 0))
- (cond
- ;; Consider property for the last char if in a fenced string.
- ((= n 3)
- (let* ((font-lock-syntactic-keywords nil)
- (syntax (syntax-ppss)))
- (when (eq t (nth 3 syntax)) ; after unclosed fence
- (goto-char (nth 8 syntax)) ; fence position
- (skip-chars-forward "uUrR") ; skip any prefix
- ;; Is it a matching sequence?
- (if (eq (char-after) (char-after (match-beginning 2)))
- (eval-when-compile (string-to-syntax "|"))))))
- ;; Consider property for initial char, accounting for prefixes.
- ((or (and (= n 2) ; leading quote (not prefix)
- (not (match-end 1))) ; prefix is null
- (and (= n 1) ; prefix
- (match-end 1))) ; non-empty
- (let ((font-lock-syntactic-keywords nil))
- (unless (eq 'string (syntax-ppss-context (syntax-ppss)))
- (eval-when-compile (string-to-syntax "|")))))
- ;; Otherwise (we're in a non-matching string) the property is
- ;; nil, which is OK.
- )))
+ (let ((syntax (save-match-data (syntax-ppss))))
+ (cond
+ ((eq t (nth 3 syntax)) ; after unclosed fence
+ ;; Consider property for the last char if in a fenced string.
+ (goto-char (nth 8 syntax)) ; fence position
+ (skip-chars-forward "uUrR") ; skip any prefix
+ ;; Is it a matching sequence?
+ (if (eq (char-after) (char-after (match-beginning 2)))
+ (put-text-property (match-beginning 3) (match-end 3)
+ 'syntax-table (string-to-syntax "|"))))
+ ((match-end 1)
+ ;; Consider property for initial char, accounting for prefixes.
+ (put-text-property (match-beginning 1) (match-end 1)
+ 'syntax-table (string-to-syntax "|")))
+ (t
+ ;; Consider property for initial char, accounting for prefixes.
+ (put-text-property (match-beginning 2) (match-end 2)
+ 'syntax-table (string-to-syntax "|"))))
+ )))
;; This isn't currently in `font-lock-defaults' as probably not worth
;; it -- we basically only mess with a few normally-symbol characters.
@@ -2291,6 +2289,7 @@ the if condition."
(eval-when-compile
;; Define a user-level skeleton and add it to the abbrev table.
(defmacro def-python-skeleton (name &rest elements)
+ (declare (indent 2))
(let* ((name (symbol-name name))
(function (intern (concat "python-insert-" name))))
`(progn
@@ -2303,7 +2302,6 @@ the if condition."
(define-skeleton ,function
,(format "Insert Python \"%s\" template." name)
,@elements)))))
-(put 'def-python-skeleton 'lisp-indent-function 2)
;; From `skeleton-further-elements' set below:
;; `<': outdent a level;
@@ -2501,12 +2499,12 @@ with skeleton expansions for compound statement templates.
:group 'python
(set (make-local-variable 'font-lock-defaults)
'(python-font-lock-keywords nil nil nil nil
- (font-lock-syntactic-keywords
- . python-font-lock-syntactic-keywords)
- ;; This probably isn't worth it.
- ;; (font-lock-syntactic-face-function
- ;; . python-font-lock-syntactic-face-function)
- ))
+ ;; This probably isn't worth it.
+ ;; (font-lock-syntactic-face-function
+ ;; . python-font-lock-syntactic-face-function)
+ ))
+ (set (make-local-variable 'syntax-propertize-function)
+ python-syntax-propertize-function)
(set (make-local-variable 'parse-sexp-lookup-properties) t)
(set (make-local-variable 'parse-sexp-ignore-comments) t)
(set (make-local-variable 'comment-start) "# ")
@@ -2611,7 +2609,7 @@ This function is appropriate for `comint-output-filter-functions'."
overlay-arrow-string "=>"
python-pdbtrack-is-tracking-p t)
(set-marker overlay-arrow-position
- (save-excursion (beginning-of-line) (point))
+ (line-beginning-position)
(current-buffer)))
(setq overlay-arrow-position nil
python-pdbtrack-is-tracking-p nil)))
diff --git a/lisp/progmodes/ruby-mode.el b/lisp/progmodes/ruby-mode.el
index 59d85e60eef..b6158a0e581 100644
--- a/lisp/progmodes/ruby-mode.el
+++ b/lisp/progmodes/ruby-mode.el
@@ -1,7 +1,7 @@
;;; ruby-mode.el --- Major mode for editing Ruby files
-;; Copyright (C) 1994, 1995, 1996 1997, 1998, 1999, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Copyright (C) 1994, 1995, 1996 1997, 1998, 1999, 2000, 2001, 2002,
+;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
;; Free Software Foundation, Inc.
;; Authors: Yukihiro Matsumoto
@@ -43,6 +43,11 @@
(eval-when-compile (require 'cl))
+(defgroup ruby nil
+ "Major mode for editing Ruby code."
+ :prefix "ruby-"
+ :group 'languages)
+
(defconst ruby-keyword-end-re
(if (string-match "\\_>" "ruby")
"\\_>"
@@ -95,17 +100,10 @@
(defconst ruby-block-end-re "\\<end\\>")
-(defconst ruby-here-doc-beg-re
+(eval-and-compile
+ (defconst ruby-here-doc-beg-re
"\\(<\\)<\\(-\\)?\\(\\([a-zA-Z0-9_]+\\)\\|[\"]\\([^\"]+\\)[\"]\\|[']\\([^']+\\)[']\\)"
- "Regexp to match the beginning of a heredoc.")
-
-(defconst ruby-here-doc-end-re
- "^\\([ \t]+\\)?\\(.*\\)\\(.\\)$"
- "Regexp to match the end of heredocs.
-
-This will actually match any line with one or more characters.
-It's useful in that it divides up the match string so that
-`ruby-here-doc-beg-match' can search for the beginning of the heredoc.")
+ "Regexp to match the beginning of a heredoc."))
(defun ruby-here-doc-end-match ()
"Return a regexp to find the end of a heredoc.
@@ -118,18 +116,6 @@ This should only be called after matching against `ruby-here-doc-beg-re'."
(match-string 5)
(match-string 6)))))
-(defun ruby-here-doc-beg-match ()
- "Return a regexp to find the beginning of a heredoc.
-
-This should only be called after matching against `ruby-here-doc-end-re'."
- (let ((contents (regexp-quote (concat (match-string 2) (match-string 3)))))
- (concat "<<"
- (let ((match (match-string 1)))
- (if (and match (> (length match) 0))
- (concat "\\(?:-\\([\"']?\\)\\|\\([\"']\\)" (match-string 1) "\\)"
- contents "\\b\\(\\1\\|\\2\\)")
- (concat "-?\\([\"']\\|\\)" contents "\\b\\1"))))))
-
(defconst ruby-delimiter
(concat "[?$/%(){}#\"'`.:]\\|<<\\|\\[\\|\\]\\|\\<\\("
ruby-block-beg-re
@@ -149,11 +135,9 @@ This should only be called after matching against `ruby-here-doc-end-re'."
(defconst ruby-symbol-re (concat "[" ruby-symbol-chars "]")
"Regexp to match symbols.")
-(defvar ruby-mode-abbrev-table nil
+(define-abbrev-table 'ruby-mode-abbrev-table ()
"Abbrev table in use in Ruby mode buffers.")
-(define-abbrev-table 'ruby-mode-abbrev-table ())
-
(defvar ruby-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "{" 'ruby-electric-brace)
@@ -166,7 +150,6 @@ This should only be called after matching against `ruby-here-doc-end-re'."
(define-key map (kbd "M-C-n") 'ruby-end-of-block)
(define-key map (kbd "M-C-h") 'ruby-mark-defun)
(define-key map (kbd "M-C-q") 'ruby-indent-exp)
- (define-key map (kbd "TAB") 'ruby-indent-line)
(define-key map (kbd "C-M-h") 'backward-kill-word)
(define-key map (kbd "C-j") 'reindent-then-newline-and-indent)
(define-key map (kbd "C-m") 'newline)
@@ -358,7 +341,7 @@ Also ignores spaces after parenthesis when 'space."
(back-to-indentation)
(current-column)))
-(defun ruby-indent-line (&optional flag)
+(defun ruby-indent-line (&optional ignored)
"Correct the indentation of the current Ruby line."
(interactive)
(ruby-indent-to (ruby-calculate-indent)))
@@ -401,8 +384,7 @@ and `\\' when preceded by `?'."
"TODO: document."
(save-excursion
(store-match-data nil)
- (let ((space (skip-chars-backward " \t"))
- (start (point)))
+ (let ((space (skip-chars-backward " \t")))
(cond
((bolp) t)
((progn
@@ -634,7 +616,7 @@ and `\\' when preceded by `?'."
(setq re (regexp-quote (or (match-string 4) (match-string 2))))
(if (match-beginning 1) (setq re (concat "\\s *" re)))
(let* ((id-end (goto-char (match-end 0)))
- (line-end-position (save-excursion (end-of-line) (point)))
+ (line-end-position (point-at-eol))
(state (list in-string nest depth pcol indent)))
;; parse the rest of the line
(while (and (> line-end-position (point))
@@ -696,7 +678,7 @@ and `\\' when preceded by `?'."
(beginning-of-line)
(let ((ruby-indent-point (point))
(case-fold-search nil)
- state bol eol begin op-end
+ state eol begin op-end
(paren (progn (skip-syntax-forward " ")
(and (char-after) (matching-paren (char-after)))))
(indent 0))
@@ -776,7 +758,6 @@ and `\\' when preceded by `?'."
(if (re-search-forward "^\\s *#" end t)
(beginning-of-line)
(setq done t))))
- (setq bol (point))
(end-of-line)
;; skip the comment at the end
(skip-chars-backward " \t")
@@ -1033,10 +1014,8 @@ With ARG, do it many times. Negative ARG means move forward."
(ruby-beginning-of-defun)
(re-search-backward "^\n" (- (point) 1) t))
-(defun ruby-indent-exp (&optional shutup-p)
- "Indent each line in the balanced expression following the point.
-If a prefix arg is given or SHUTUP-P is non-nil, no errors
-are signalled if a balanced expression isn't found."
+(defun ruby-indent-exp (&optional ignored)
+ "Indent each line in the balanced expression following the point."
(interactive "*P")
(let ((here (point-marker)) start top column (nest t))
(set-marker-insertion-type here t)
@@ -1129,58 +1108,210 @@ See `add-log-current-defun-function'."
(if mlist (concat mlist mname) mname)
mlist)))))
-(defconst ruby-font-lock-syntactic-keywords
- `(;; #{ }, #$hoge, #@foo are not comments
- ("\\(#\\)[{$@]" 1 (1 . nil))
- ;; the last $', $", $` in the respective string is not variable
- ;; the last ?', ?", ?` in the respective string is not ascii code
- ("\\(^\\|[\[ \t\n<+\(,=]\\)\\(['\"`]\\)\\(\\\\.\\|\\2\\|[^'\"`\n\\\\]\\)*?\\\\?[?$]\\(\\2\\)"
- (2 (7 . nil))
- (4 (7 . nil)))
- ;; $' $" $` .... are variables
- ;; ?' ?" ?` are ascii codes
- ("\\(^\\|[^\\\\]\\)\\(\\\\\\\\\\)*[?$]\\([#\"'`]\\)" 3 (1 . nil))
- ;; regexps
- ("\\(^\\|[=(,~?:;<>]\\|\\(^\\|\\s \\)\\(if\\|elsif\\|unless\\|while\\|until\\|when\\|and\\|or\\|&&\\|||\\)\\|g?sub!?\\|scan\\|split!?\\)\\s *\\(/\\)[^/\n\\\\]*\\(\\\\.[^/\n\\\\]*\\)*\\(/\\)"
- (4 (7 . ?/))
- (6 (7 . ?/)))
- ("^=en\\(d\\)\\_>" 1 "!")
- ("^\\(=\\)begin\\_>" 1 (ruby-comment-beg-syntax))
- ;; Currently, the following case is highlighted incorrectly:
- ;;
- ;; <<FOO
- ;; FOO
- ;; <<BAR
- ;; <<BAZ
- ;; BAZ
- ;; BAR
- ;;
- ;; This is because all here-doc beginnings are highlighted before any endings,
- ;; so although <<BAR is properly marked as a beginning, when we get to <<BAZ
- ;; it thinks <<BAR is part of a string so it's marked as well.
- ;;
- ;; This may be fixable by modifying ruby-in-here-doc-p to use
- ;; ruby-in-non-here-doc-string-p rather than syntax-ppss-context,
- ;; but I don't want to try that until we've got unit tests set up
- ;; to make sure I don't break anything else.
- (,(concat ruby-here-doc-beg-re ".*\\(\n\\)")
- ,(+ 1 (regexp-opt-depth ruby-here-doc-beg-re))
- (ruby-here-doc-beg-syntax))
- (,ruby-here-doc-end-re 3 (ruby-here-doc-end-syntax)))
- "Syntactic keywords for Ruby mode. See `font-lock-syntactic-keywords'.")
-
-(defun ruby-comment-beg-syntax ()
- "Return the syntax cell for a the first character of a =begin.
+(declare-function ruby-syntax-propertize-heredoc "ruby-mode" (limit))
+
+(if (eval-when-compile (fboundp #'syntax-propertize-rules))
+ ;; New code that works independently from font-lock.
+ (progn
+ (defun ruby-syntax-propertize-function (start end)
+ "Syntactic keywords for Ruby mode. See `syntax-propertize-function'."
+ (goto-char start)
+ (ruby-syntax-propertize-heredoc end)
+ (funcall
+ (syntax-propertize-rules
+ ;; #{ }, #$hoge, #@foo are not comments
+ ("\\(#\\)[{$@]" (1 "."))
+ ;; the last $', $", $` in the respective string is not variable
+ ;; the last ?', ?", ?` in the respective string is not ascii code
+ ("\\(^\\|[\[ \t\n<+\(,=]\\)\\(['\"`]\\)\\(\\\\.\\|\\2\\|[^'\"`\n\\\\]\\)*?\\\\?[?$]\\(\\2\\)"
+ (2 "\"")
+ (4 "\""))
+ ;; $' $" $` .... are variables
+ ;; ?' ?" ?` are ascii codes
+ ("\\(^\\|[^\\\\]\\)\\(\\\\\\\\\\)*[?$]\\([#\"'`]\\)" (3 "."))
+ ;; regexps
+ ("\\(^\\|[=(,~?:;<>]\\|\\(^\\|\\s \\)\\(if\\|elsif\\|unless\\|while\\|until\\|when\\|and\\|or\\|&&\\|||\\)\\|g?sub!?\\|scan\\|split!?\\)\\s *\\(/\\)[^/\n\\\\]*\\(\\\\.[^/\n\\\\]*\\)*\\(/\\)"
+ (4 "\"/")
+ (6 "\"/"))
+ ("^=en\\(d\\)\\_>" (1 "!"))
+ ("^\\(=\\)begin\\_>" (1 "!"))
+ ;; Handle here documents.
+ ((concat ruby-here-doc-beg-re ".*\\(\n\\)")
+ (7 (prog1 "\"" (ruby-syntax-propertize-heredoc end)))))
+ (point) end))
+
+ (defun ruby-syntax-propertize-heredoc (limit)
+ (let ((ppss (syntax-ppss))
+ (res '()))
+ (when (eq ?\n (nth 3 ppss))
+ (save-excursion
+ (goto-char (nth 8 ppss))
+ (beginning-of-line)
+ (while (re-search-forward ruby-here-doc-beg-re
+ (line-end-position) t)
+ (push (concat (ruby-here-doc-end-match) "\n") res)))
+ (let ((start (point)))
+ ;; With multiple openers on the same line, we don't know in which
+ ;; part `start' is, so we have to go back to the beginning.
+ (when (cdr res)
+ (goto-char (nth 8 ppss))
+ (setq res (nreverse res)))
+ (while (and res (re-search-forward (pop res) limit 'move))
+ (if (null res)
+ (put-text-property (1- (point)) (point)
+ 'syntax-table (string-to-syntax "\""))))
+ ;; Make extra sure we don't move back, lest we could fall into an
+ ;; inf-loop.
+ (if (< (point) start) (goto-char start))))))
+ )
+
+ ;; For Emacsen where syntax-propertize-rules is not (yet) available,
+ ;; fallback on the old font-lock-syntactic-keywords stuff.
+
+ (defconst ruby-here-doc-end-re
+ "^\\([ \t]+\\)?\\(.*\\)\\(\n\\)"
+ "Regexp to match the end of heredocs.
+
+This will actually match any line with one or more characters.
+It's useful in that it divides up the match string so that
+`ruby-here-doc-beg-match' can search for the beginning of the heredoc.")
+
+ (defun ruby-here-doc-beg-match ()
+ "Return a regexp to find the beginning of a heredoc.
+
+This should only be called after matching against `ruby-here-doc-end-re'."
+ (let ((contents (regexp-quote (match-string 2))))
+ (concat "<<"
+ (let ((match (match-string 1)))
+ (if (and match (> (length match) 0))
+ (concat "\\(?:-\\([\"']?\\)\\|\\([\"']\\)" match "\\)"
+ contents "\\b\\(\\1\\|\\2\\)")
+ (concat "-?\\([\"']\\|\\)" contents "\\b\\1"))))))
+
+ (defconst ruby-font-lock-syntactic-keywords
+ `( ;; #{ }, #$hoge, #@foo are not comments
+ ("\\(#\\)[{$@]" 1 (1 . nil))
+ ;; the last $', $", $` in the respective string is not variable
+ ;; the last ?', ?", ?` in the respective string is not ascii code
+ ("\\(^\\|[\[ \t\n<+\(,=]\\)\\(['\"`]\\)\\(\\\\.\\|\\2\\|[^'\"`\n\\\\]\\)*?\\\\?[?$]\\(\\2\\)"
+ (2 (7 . nil))
+ (4 (7 . nil)))
+ ;; $' $" $` .... are variables
+ ;; ?' ?" ?` are ascii codes
+ ("\\(^\\|[^\\\\]\\)\\(\\\\\\\\\\)*[?$]\\([#\"'`]\\)" 3 (1 . nil))
+ ;; regexps
+ ("\\(^\\|[=(,~?:;<>]\\|\\(^\\|\\s \\)\\(if\\|elsif\\|unless\\|while\\|until\\|when\\|and\\|or\\|&&\\|||\\)\\|g?sub!?\\|scan\\|split!?\\)\\s *\\(/\\)[^/\n\\\\]*\\(\\\\.[^/\n\\\\]*\\)*\\(/\\)"
+ (4 (7 . ?/))
+ (6 (7 . ?/)))
+ ("^=en\\(d\\)\\_>" 1 "!")
+ ("^\\(=\\)begin\\_>" 1 (ruby-comment-beg-syntax))
+ ;; Currently, the following case is highlighted incorrectly:
+ ;;
+ ;; <<FOO
+ ;; FOO
+ ;; <<BAR
+ ;; <<BAZ
+ ;; BAZ
+ ;; BAR
+ ;;
+ ;; This is because all here-doc beginnings are highlighted before any endings,
+ ;; so although <<BAR is properly marked as a beginning, when we get to <<BAZ
+ ;; it thinks <<BAR is part of a string so it's marked as well.
+ ;;
+ ;; This may be fixable by modifying ruby-in-here-doc-p to use
+ ;; ruby-in-non-here-doc-string-p rather than syntax-ppss-context,
+ ;; but I don't want to try that until we've got unit tests set up
+ ;; to make sure I don't break anything else.
+ (,(concat ruby-here-doc-beg-re ".*\\(\n\\)")
+ ,(+ 1 (regexp-opt-depth ruby-here-doc-beg-re))
+ (ruby-here-doc-beg-syntax))
+ (,ruby-here-doc-end-re 3 (ruby-here-doc-end-syntax)))
+ "Syntactic keywords for Ruby mode. See `font-lock-syntactic-keywords'.")
+
+ (defun ruby-comment-beg-syntax ()
+ "Return the syntax cell for a the first character of a =begin.
See the definition of `ruby-font-lock-syntactic-keywords'.
This returns a comment-delimiter cell as long as the =begin
isn't in a string or another comment."
- (when (not (nth 3 (syntax-ppss)))
- (string-to-syntax "!")))
+ (when (not (nth 3 (syntax-ppss)))
+ (string-to-syntax "!")))
+
+ (defun ruby-in-here-doc-p ()
+ "Return whether or not the point is in a heredoc."
+ (save-excursion
+ (let ((old-point (point)) (case-fold-search nil))
+ (beginning-of-line)
+ (catch 'found-beg
+ (while (re-search-backward ruby-here-doc-beg-re nil t)
+ (if (not (or (ruby-in-ppss-context-p 'anything)
+ (ruby-here-doc-find-end old-point)))
+ (throw 'found-beg t)))))))
+
+ (defun ruby-here-doc-find-end (&optional limit)
+ "Expects the point to be on a line with one or more heredoc openers.
+Returns the buffer position at which all heredocs on the line
+are terminated, or nil if they aren't terminated before the
+buffer position `limit' or the end of the buffer."
+ (save-excursion
+ (beginning-of-line)
+ (catch 'done
+ (let ((eol (point-at-eol))
+ (case-fold-search nil)
+ ;; Fake match data such that (match-end 0) is at eol
+ (end-match-data (progn (looking-at ".*$") (match-data)))
+ beg-match-data end-re)
+ (while (re-search-forward ruby-here-doc-beg-re eol t)
+ (setq beg-match-data (match-data))
+ (setq end-re (ruby-here-doc-end-match))
+
+ (set-match-data end-match-data)
+ (goto-char (match-end 0))
+ (unless (re-search-forward end-re limit t) (throw 'done nil))
+ (setq end-match-data (match-data))
+
+ (set-match-data beg-match-data)
+ (goto-char (match-end 0)))
+ (set-match-data end-match-data)
+ (goto-char (match-end 0))
+ (point)))))
-(unless (functionp 'syntax-ppss)
- (defun syntax-ppss (&optional pos)
- (parse-partial-sexp (point-min) (or pos (point)))))
+ (defun ruby-here-doc-beg-syntax ()
+ "Return the syntax cell for a line that may begin a heredoc.
+See the definition of `ruby-font-lock-syntactic-keywords'.
+
+This sets the syntax cell for the newline ending the line
+containing the heredoc beginning so that cases where multiple
+heredocs are started on one line are handled correctly."
+ (save-excursion
+ (goto-char (match-beginning 0))
+ (unless (or (ruby-in-ppss-context-p 'non-heredoc)
+ (ruby-in-here-doc-p))
+ (string-to-syntax "\""))))
+
+ (defun ruby-here-doc-end-syntax ()
+ "Return the syntax cell for a line that may end a heredoc.
+See the definition of `ruby-font-lock-syntactic-keywords'."
+ (let ((pss (syntax-ppss)) (case-fold-search nil))
+ ;; If we aren't in a string, we definitely aren't ending a heredoc,
+ ;; so we can just give up.
+ ;; This means we aren't doing a full-document search
+ ;; every time we enter a character.
+ (when (ruby-in-ppss-context-p 'heredoc pss)
+ (save-excursion
+ (goto-char (nth 8 pss)) ; Go to the beginning of heredoc.
+ (let ((eol (point)))
+ (beginning-of-line)
+ (if (and (re-search-forward (ruby-here-doc-beg-match) eol t) ; If there is a heredoc that matches this line...
+ (not (ruby-in-ppss-context-p 'anything)) ; And that's not inside a heredoc/string/comment...
+ (progn (goto-char (match-end 0)) ; And it's the last heredoc on its line...
+ (not (re-search-forward ruby-here-doc-beg-re eol t))))
+ (string-to-syntax "\"")))))))
+
+ (unless (functionp 'syntax-ppss)
+ (defun syntax-ppss (&optional pos)
+ (parse-partial-sexp (point-min) (or pos (point)))))
+ )
(defun ruby-in-ppss-context-p (context &optional ppss)
(let ((ppss (or ppss (syntax-ppss (point)))))
@@ -1191,10 +1322,7 @@ isn't in a string or another comment."
((eq context 'string)
(nth 3 ppss))
((eq context 'heredoc)
- (and (nth 3 ppss)
- ;; If it's generic string, it's a heredoc and we don't care
- ;; See `parse-partial-sexp'
- (not (numberp (nth 3 ppss)))))
+ (eq ?\n (nth 3 ppss)))
((eq context 'non-heredoc)
(and (ruby-in-ppss-context-p 'anything)
(not (ruby-in-ppss-context-p 'heredoc))))
@@ -1206,77 +1334,6 @@ isn't in a string or another comment."
"context name `" (symbol-name context) "' is unknown"))))
t)))
-(defun ruby-in-here-doc-p ()
- "Return whether or not the point is in a heredoc."
- (save-excursion
- (let ((old-point (point)) (case-fold-search nil))
- (beginning-of-line)
- (catch 'found-beg
- (while (re-search-backward ruby-here-doc-beg-re nil t)
- (if (not (or (ruby-in-ppss-context-p 'anything)
- (ruby-here-doc-find-end old-point)))
- (throw 'found-beg t)))))))
-
-(defun ruby-here-doc-find-end (&optional limit)
- "Expects the point to be on a line with one or more heredoc openers.
-Returns the buffer position at which all heredocs on the line
-are terminated, or nil if they aren't terminated before the
-buffer position `limit' or the end of the buffer."
- (save-excursion
- (beginning-of-line)
- (catch 'done
- (let ((eol (save-excursion (end-of-line) (point)))
- (case-fold-search nil)
- ;; Fake match data such that (match-end 0) is at eol
- (end-match-data (progn (looking-at ".*$") (match-data)))
- beg-match-data end-re)
- (while (re-search-forward ruby-here-doc-beg-re eol t)
- (setq beg-match-data (match-data))
- (setq end-re (ruby-here-doc-end-match))
-
- (set-match-data end-match-data)
- (goto-char (match-end 0))
- (unless (re-search-forward end-re limit t) (throw 'done nil))
- (setq end-match-data (match-data))
-
- (set-match-data beg-match-data)
- (goto-char (match-end 0)))
- (set-match-data end-match-data)
- (goto-char (match-end 0))
- (point)))))
-
-(defun ruby-here-doc-beg-syntax ()
- "Return the syntax cell for a line that may begin a heredoc.
-See the definition of `ruby-font-lock-syntactic-keywords'.
-
-This sets the syntax cell for the newline ending the line
-containing the heredoc beginning so that cases where multiple
-heredocs are started on one line are handled correctly."
- (save-excursion
- (goto-char (match-beginning 0))
- (unless (or (ruby-in-ppss-context-p 'non-heredoc)
- (ruby-in-here-doc-p))
- (string-to-syntax "|"))))
-
-(defun ruby-here-doc-end-syntax ()
- "Return the syntax cell for a line that may end a heredoc.
-See the definition of `ruby-font-lock-syntactic-keywords'."
- (let ((pss (syntax-ppss)) (case-fold-search nil))
- ;; If we aren't in a string, we definitely aren't ending a heredoc,
- ;; so we can just give up.
- ;; This means we aren't doing a full-document search
- ;; every time we enter a character.
- (when (ruby-in-ppss-context-p 'heredoc pss)
- (save-excursion
- (goto-char (nth 8 pss)) ; Go to the beginning of heredoc.
- (let ((eol (point)))
- (beginning-of-line)
- (if (and (re-search-forward (ruby-here-doc-beg-match) eol t) ; If there is a heredoc that matches this line...
- (not (ruby-in-ppss-context-p 'anything)) ; And that's not inside a heredoc/string/comment...
- (progn (goto-char (match-end 0)) ; And it's the last heredoc on its line...
- (not (re-search-forward ruby-here-doc-beg-re eol t))))
- (string-to-syntax "|")))))))
-
(if (featurep 'xemacs)
(put 'ruby-mode 'font-lock-defaults
'((ruby-font-lock-keywords)
@@ -1374,7 +1431,7 @@ See `font-lock-syntax-table'.")
"Additional expressions to highlight in Ruby mode.")
;;;###autoload
-(defun ruby-mode ()
+(define-derived-mode ruby-mode prog-mode "Ruby"
"Major mode for editing Ruby scripts.
\\[ruby-indent-line] properly indents subexpressions of multi-line
class, module, def, if, while, for, do, and case statements, taking
@@ -1383,11 +1440,6 @@ nesting into account.
The variable `ruby-indent-level' controls the amount of indentation.
\\{ruby-mode-map}"
- (interactive)
- (kill-all-local-variables)
- (use-local-map ruby-mode-map)
- (setq mode-name "Ruby")
- (setq major-mode 'ruby-mode)
(ruby-mode-variables)
(set (make-local-variable 'imenu-create-index-function)
@@ -1396,12 +1448,13 @@ The variable `ruby-indent-level' controls the amount of indentation.
'ruby-add-log-current-method)
(add-hook
- (cond ((boundp 'before-save-hook)
- (make-local-variable 'before-save-hook)
- 'before-save-hook)
+ (cond ((boundp 'before-save-hook) 'before-save-hook)
((boundp 'write-contents-functions) 'write-contents-functions)
((boundp 'write-contents-hooks) 'write-contents-hooks))
- 'ruby-mode-set-encoding)
+ 'ruby-mode-set-encoding nil 'local)
+
+ (set (make-local-variable 'electric-indent-chars)
+ (append '(?\{ ?\}) electric-indent-chars))
(set (make-local-variable 'font-lock-defaults)
'((ruby-font-lock-keywords) nil nil))
@@ -1409,12 +1462,12 @@ The variable `ruby-indent-level' controls the amount of indentation.
ruby-font-lock-keywords)
(set (make-local-variable 'font-lock-syntax-table)
ruby-font-lock-syntax-table)
- (set (make-local-variable 'font-lock-syntactic-keywords)
- ruby-font-lock-syntactic-keywords)
- (if (fboundp 'run-mode-hooks)
- (run-mode-hooks 'ruby-mode-hook)
- (run-hooks 'ruby-mode-hook)))
+ (if (eval-when-compile (fboundp 'syntax-propertize-rules))
+ (set (make-local-variable 'syntax-propertize-function)
+ #'ruby-syntax-propertize-function)
+ (set (make-local-variable 'font-lock-syntactic-keywords)
+ ruby-font-lock-syntactic-keywords)))
;;; Invoke ruby-mode when appropriate
@@ -1427,5 +1480,4 @@ The variable `ruby-indent-level' controls the amount of indentation.
(provide 'ruby-mode)
-;; arch-tag: e6ecc893-8005-420c-b7f9-34ab99a1fff9
;;; ruby-mode.el ends here
diff --git a/lisp/progmodes/scheme.el b/lisp/progmodes/scheme.el
index ce8a34220e4..da143db5ffb 100644
--- a/lisp/progmodes/scheme.el
+++ b/lisp/progmodes/scheme.el
@@ -107,7 +107,7 @@
;; Special characters
(modify-syntax-entry ?, "' " st)
(modify-syntax-entry ?@ "' " st)
- (modify-syntax-entry ?# "' 14b" st)
+ (modify-syntax-entry ?# "' 14" st)
(modify-syntax-entry ?\\ "\\ " st)
st))
diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el
index 610fa14489a..1f085045192 100644
--- a/lisp/progmodes/sh-script.el
+++ b/lisp/progmodes/sh-script.el
@@ -1,7 +1,8 @@
;;; sh-script.el --- shell-script editing commands for Emacs
;; Copyright (C) 1993, 1994, 1995, 1996, 1997, 1999, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Daniel Pfeiffer <occitan@esperanto.org>
;; Version: 2.0f
@@ -411,11 +412,7 @@ the car and cdr are the same symbol.")
(modify-syntax-entry (pop list) (pop list) table))
table)
-(defvar sh-mode-syntax-table nil
- "The syntax table to use for Shell-Script mode.
-This is buffer-local in every such buffer.")
-
-(defvar sh-mode-default-syntax-table
+(defvar sh-mode-syntax-table
(sh-mode-syntax-table ()
?\# "<"
?\n ">#"
@@ -436,7 +433,8 @@ This is buffer-local in every such buffer.")
?= "."
?< "."
?> ".")
- "Default syntax table for shell mode.")
+ "The syntax table to use for Shell-Script mode.
+This is buffer-local in every such buffer.")
(defvar sh-mode-syntax-table-input
'((sh . nil))
@@ -611,7 +609,7 @@ sign. See `sh-feature'."
(defvar sh-header-marker nil
"When non-nil is the end of header for prepending by \\[sh-execute-region].
That command is also used for setting this variable.")
-
+(make-variable-buffer-local 'sh-header-marker)
(defcustom sh-beginning-of-command
"\\([;({`|&]\\|\\`\\|[^\\]\n\\)[ \t]*\\([/~[:alnum:]:]\\)"
@@ -942,7 +940,6 @@ See `sh-feature'.")
;; These are used for the syntax table stuff (derived from cperl-mode).
;; Note: parse-sexp-lookup-properties must be set to t for it to work.
(defconst sh-st-punc (string-to-syntax "."))
-(defconst sh-st-symbol (string-to-syntax "_"))
(defconst sh-here-doc-syntax (string-to-syntax "|")) ;; generic string
(defconst sh-escaped-line-re
@@ -960,7 +957,7 @@ See `sh-feature'.")
(defvar sh-here-doc-re sh-here-doc-open-re)
(make-variable-buffer-local 'sh-here-doc-re)
-(defun sh-font-lock-close-heredoc (bol eof indented)
+(defun sh-font-lock-close-heredoc (bol eof indented eol)
"Determine the syntax of the \\n after an EOF.
If non-nil INDENTED indicates that the EOF was indented."
(let* ((eof-re (if eof (regexp-quote eof) ""))
@@ -974,6 +971,8 @@ If non-nil INDENTED indicates that the EOF was indented."
(ere (concat "^" (if indented "[ \t]*") eof-re "\n"))
(start (save-excursion
(goto-char bol)
+ ;; FIXME: will incorrectly find a <<EOF embedded inside
+ ;; the heredoc.
(re-search-backward (concat sre "\\|" ere) nil t))))
;; If subgroup 1 matched, we found an open-heredoc, otherwise we first
;; found a close-heredoc which makes the current close-heredoc inoperant.
@@ -993,7 +992,7 @@ If non-nil INDENTED indicates that the EOF was indented."
(sh-in-comment-or-string (point)))))
;; No <<EOF2 found after our <<.
(= (point) start)))
- sh-here-doc-syntax)
+ (put-text-property eol (1+ eol) 'syntax-table sh-here-doc-syntax))
((not (or start (save-excursion (re-search-forward sre nil t))))
;; There's no <<EOF either before or after us,
;; so we should remove ourselves from font-lock's keywords.
@@ -1003,7 +1002,7 @@ If non-nil INDENTED indicates that the EOF was indented."
(regexp-opt sh-here-doc-markers t) "\\(\n\\)"))
nil))))
-(defun sh-font-lock-open-heredoc (start string)
+(defun sh-font-lock-open-heredoc (start string eol)
"Determine the syntax of the \\n after a <<EOF.
START is the position of <<.
STRING is the actual word used as delimiter (e.g. \"EOF\").
@@ -1033,13 +1032,8 @@ Point is at the beginning of the next line."
;; Don't bother fixing it now, but place a multiline property so
;; that when jit-lock-context-* refontifies the rest of the
;; buffer, it also refontifies the current line with it.
- (put-text-property start (point) 'font-lock-multiline t)))
- sh-here-doc-syntax))
-
-(defun sh-font-lock-here-doc (limit)
- "Search for a heredoc marker."
- ;; This looks silly, but it's because `sh-here-doc-re' keeps changing.
- (re-search-forward sh-here-doc-re limit t))
+ (put-text-property start (point) 'syntax-multiline t)))
+ (put-text-property eol (1+ eol) 'syntax-table sh-here-doc-syntax)))
(defun sh-font-lock-quoted-subshell (limit)
"Search for a subshell embedded in a string.
@@ -1048,9 +1042,7 @@ subshells can nest."
;; FIXME: This can (and often does) match multiple lines, yet it makes no
;; effort to handle multiline cases correctly, so it ends up being
;; rather flakey.
- (when (and (re-search-forward "\"\\(?:\\(?:.\\|\n\\)*?[^\\]\\(?:\\\\\\\\\\)*\\)??\\(\\$(\\|`\\)" limit t)
- ;; Make sure the " we matched is an opening quote.
- (eq ?\" (nth 3 (syntax-ppss))))
+ (when (eq ?\" (nth 3 (syntax-ppss))) ; Check we matched an opening quote.
;; bingo we have a $( or a ` inside a ""
(let ((char (char-after (point)))
;; `state' can be: double-quote, backquote, code.
@@ -1085,8 +1077,7 @@ subshells can nest."
(double-quote nil)
(t (setq state (pop states)))))
(t (error "Internal error in sh-font-lock-quoted-subshell")))
- (forward-char 1)))
- t))
+ (forward-char 1)))))
(defun sh-is-quoted-p (pos)
@@ -1125,7 +1116,7 @@ subshells can nest."
(when (progn (backward-char 2)
(if (> start (line-end-position))
(put-text-property (point) (1+ start)
- 'font-lock-multiline t))
+ 'syntax-multiline t))
;; FIXME: The `in' may just be a random argument to
;; a normal command rather than the real `in' keyword.
;; I.e. we should look back to try and find the
@@ -1139,40 +1130,44 @@ subshells can nest."
sh-st-punc
nil))
-(defun sh-font-lock-flush-syntax-ppss-cache (limit)
- ;; This should probably be a standard function provided by font-lock.el
- ;; (or syntax.el).
- (syntax-ppss-flush-cache (point))
- (goto-char limit)
- nil)
-
-(defconst sh-font-lock-syntactic-keywords
- ;; A `#' begins a comment when it is unquoted and at the beginning of a
- ;; word. In the shell, words are separated by metacharacters.
- ;; The list of special chars is taken from the single-unix spec
- ;; of the shell command language (under `quoting') but with `$' removed.
- `(("[^|&;<>()`\\\"' \t\n]\\(#+\\)" 1 ,sh-st-symbol)
- ;; In a '...' the backslash is not escaping.
- ("\\(\\\\\\)'" (1 (sh-font-lock-backslash-quote)))
- ;; The previous rule uses syntax-ppss, but the subsequent rules may
- ;; change the syntax, so we have to tell syntax-ppss that the states it
- ;; has just computed will need to be recomputed.
- (sh-font-lock-flush-syntax-ppss-cache)
- ;; Make sure $@ and $? are correctly recognized as sexps.
- ("\\$\\([?@]\\)" 1 ,sh-st-symbol)
- ;; Find HEREDOC starters and add a corresponding rule for the ender.
- (sh-font-lock-here-doc
- (2 (sh-font-lock-open-heredoc
- (match-beginning 0) (match-string 1)) nil t)
- (5 (sh-font-lock-close-heredoc
- (match-beginning 0) (match-string 4)
- (and (match-beginning 3) (/= (match-beginning 3) (match-end 3))))
- nil t))
- ;; Distinguish the special close-paren in `case'.
- (")" 0 (sh-font-lock-paren (match-beginning 0)))
- ;; highlight (possibly nested) subshells inside "" quoted regions correctly.
- ;; This should be at the very end because it uses syntax-ppss.
- (sh-font-lock-quoted-subshell)))
+(defun sh-syntax-propertize-function (start end)
+ (goto-char start)
+ (while (prog1
+ (re-search-forward sh-here-doc-re end 'move)
+ (save-excursion
+ (save-match-data
+ (funcall
+ (syntax-propertize-rules
+ ;; A `#' begins a comment when it is unquoted and at the
+ ;; beginning of a word. In the shell, words are separated by
+ ;; metacharacters. The list of special chars is taken from
+ ;; the single-unix spec of the shell command language (under
+ ;; `quoting') but with `$' removed.
+ ("[^|&;<>()`\\\"' \t\n]\\(#+\\)" (1 "_"))
+ ;; In a '...' the backslash is not escaping.
+ ("\\(\\\\\\)'" (1 (sh-font-lock-backslash-quote)))
+ ;; Make sure $@ and $? are correctly recognized as sexps.
+ ("\\$\\([?@]\\)" (1 "_"))
+ ;; Distinguish the special close-paren in `case'.
+ (")" (0 (sh-font-lock-paren (match-beginning 0))))
+ ;; Highlight (possibly nested) subshells inside "" quoted
+ ;; regions correctly.
+ ("\"\\(?:\\(?:.\\|\n\\)*?[^\\]\\(?:\\\\\\\\\\)*\\)??\\(\\$(\\|`\\)"
+ (1 (ignore
+ ;; Save excursion because we want to also apply other
+ ;; syntax-propertize rules within the affected region.
+ (save-excursion
+ (sh-font-lock-quoted-subshell end))))))
+ (prog1 start (setq start (point))) (point)))))
+ (if (match-beginning 2)
+ ;; FIXME: actually, once we see an heredoc opener, we should just
+ ;; search for its ender without propertizing anything in it.
+ (sh-font-lock-open-heredoc
+ (match-beginning 0) (match-string 1) (match-beginning 2))
+ (sh-font-lock-close-heredoc
+ (match-beginning 0) (match-string 4)
+ (and (match-beginning 3) (/= (match-beginning 3) (match-end 3)))
+ (match-beginning 5)))))
(defun sh-font-lock-syntactic-face-function (state)
(let ((q (nth 3 state)))
@@ -1480,7 +1475,7 @@ frequently editing existing scripts with different styles.")
;; mode-command and utility functions
;;;###autoload
-(defun sh-mode ()
+(define-derived-mode sh-mode prog-mode "Shell-script"
"Major mode for editing shell scripts.
This mode works for many shells, since they all have roughly the same syntax,
as far as commands, arguments, variables, pipes, comments etc. are concerned.
@@ -1533,62 +1528,44 @@ indicate what shell it is use `sh-alias-alist' to translate.
If your shell gives error messages with line numbers, you can use \\[executable-interpret]
with your script for an edit-interpret-debug cycle."
- (interactive)
- (kill-all-local-variables)
- (setq major-mode 'sh-mode
- mode-name "Shell-script")
- (use-local-map sh-mode-map)
- (make-local-variable 'skeleton-end-hook)
- (make-local-variable 'paragraph-start)
- (make-local-variable 'paragraph-separate)
- (make-local-variable 'comment-start)
- (make-local-variable 'comment-start-skip)
- (make-local-variable 'require-final-newline)
- (make-local-variable 'sh-header-marker)
(make-local-variable 'sh-shell-file)
(make-local-variable 'sh-shell)
- (make-local-variable 'skeleton-pair-alist)
- (make-local-variable 'skeleton-pair-filter-function)
- (make-local-variable 'comint-dynamic-complete-functions)
- (make-local-variable 'comint-prompt-regexp)
- (make-local-variable 'font-lock-defaults)
- (make-local-variable 'skeleton-filter-function)
- (make-local-variable 'skeleton-newline-indent-rigidly)
- (make-local-variable 'sh-shell-variables)
- (make-local-variable 'sh-shell-variables-initialized)
- (make-local-variable 'imenu-generic-expression)
- (make-local-variable 'sh-indent-supported-here)
- (make-local-variable 'skeleton-pair-default-alist)
- (setq skeleton-pair-default-alist sh-skeleton-pair-default-alist)
- (setq skeleton-end-hook (lambda ()
- (or (eolp) (newline) (indent-relative)))
- paragraph-start (concat page-delimiter "\\|$")
- paragraph-separate paragraph-start
- comment-start "# "
- comment-start-skip "#+[\t ]*"
- local-abbrev-table sh-mode-abbrev-table
- comint-dynamic-complete-functions sh-dynamic-complete-functions
- ;; we can't look if previous line ended with `\'
- comint-prompt-regexp "^[ \t]*"
- imenu-case-fold-search nil
- font-lock-defaults
- `((sh-font-lock-keywords
- sh-font-lock-keywords-1 sh-font-lock-keywords-2)
- nil nil
- ((?/ . "w") (?~ . "w") (?. . "w") (?- . "w") (?_ . "w")) nil
- (font-lock-syntactic-keywords . sh-font-lock-syntactic-keywords)
- (font-lock-syntactic-face-function
- . sh-font-lock-syntactic-face-function))
- skeleton-pair-alist '((?` _ ?`))
- skeleton-pair-filter-function 'sh-quoted-p
- skeleton-further-elements '((< '(- (min sh-indentation
- (current-column)))))
- skeleton-filter-function 'sh-feature
- skeleton-newline-indent-rigidly t
- sh-indent-supported-here nil)
+
+ (set (make-local-variable 'skeleton-pair-default-alist)
+ sh-skeleton-pair-default-alist)
+ (set (make-local-variable 'skeleton-end-hook)
+ (lambda () (or (eolp) (newline) (indent-relative))))
+
+ (set (make-local-variable 'paragraph-start) (concat page-delimiter "\\|$"))
+ (set (make-local-variable 'paragraph-separate) paragraph-start)
+ (set (make-local-variable 'comment-start) "# ")
+ (set (make-local-variable 'comment-start-skip) "#+[\t ]*")
+ (set (make-local-variable 'local-abbrev-table) sh-mode-abbrev-table)
+ (set (make-local-variable 'comint-dynamic-complete-functions)
+ sh-dynamic-complete-functions)
+ ;; we can't look if previous line ended with `\'
+ (set (make-local-variable 'comint-prompt-regexp) "^[ \t]*")
+ (set (make-local-variable 'imenu-case-fold-search) nil)
+ (set (make-local-variable 'font-lock-defaults)
+ `((sh-font-lock-keywords
+ sh-font-lock-keywords-1 sh-font-lock-keywords-2)
+ nil nil
+ ((?/ . "w") (?~ . "w") (?. . "w") (?- . "w") (?_ . "w")) nil
+ (font-lock-syntactic-face-function
+ . sh-font-lock-syntactic-face-function)))
+ (set (make-local-variable 'syntax-propertize-function)
+ #'sh-syntax-propertize-function)
+ (add-hook 'syntax-propertize-extend-region-functions
+ #'syntax-propertize-multiline 'append 'local)
+ (set (make-local-variable 'skeleton-pair-alist) '((?` _ ?`)))
+ (set (make-local-variable 'skeleton-pair-filter-function) 'sh-quoted-p)
+ (set (make-local-variable 'skeleton-further-elements)
+ '((< '(- (min sh-indentation (current-column))))))
+ (set (make-local-variable 'skeleton-filter-function) 'sh-feature)
+ (set (make-local-variable 'skeleton-newline-indent-rigidly) t)
+ (set (make-local-variable 'sh-indent-supported-here) nil)
(set (make-local-variable 'defun-prompt-regexp)
(concat "^\\(function[ \t]\\|[[:alnum:]]+[ \t]+()[ \t]+\\)"))
- (set (make-local-variable 'parse-sexp-ignore-comments) t)
;; Parse or insert magic number for exec, and set all variables depending
;; on the shell thus determined.
(sh-set-shell
@@ -1613,8 +1590,7 @@ with your script for an edit-interpret-debug cycle."
"sh")
(t
sh-shell-file))
- nil nil)
- (run-mode-hooks 'sh-mode-hook))
+ nil nil))
;;;###autoload
(defalias 'shell-script-mode 'sh-mode)
@@ -1743,21 +1719,20 @@ Calls the value of `sh-set-shell-hook' if set."
no-query-flag insert-flag)))
(let ((tem (sh-feature sh-require-final-newline)))
(if (eq tem t)
- (setq require-final-newline mode-require-final-newline)))
- (setq
- mode-line-process (format "[%s]" sh-shell)
- sh-shell-variables nil
- sh-shell-variables-initialized nil
- imenu-generic-expression (sh-feature sh-imenu-generic-expression))
- (make-local-variable 'sh-mode-syntax-table)
+ (set (make-local-variable 'require-final-newline)
+ mode-require-final-newline)))
+ (setq mode-line-process (format "[%s]" sh-shell))
+ (set (make-local-variable 'sh-shell-variables) nil)
+ (set (make-local-variable 'sh-shell-variables-initialized) nil)
+ (set (make-local-variable 'imenu-generic-expression)
+ (sh-feature sh-imenu-generic-expression))
(let ((tem (sh-feature sh-mode-syntax-table-input)))
- (setq sh-mode-syntax-table
- (if tem (apply 'sh-mode-syntax-table tem)
- sh-mode-default-syntax-table)))
- (set-syntax-table sh-mode-syntax-table)
+ (when tem
+ (set (make-local-variable 'sh-mode-syntax-table)
+ (apply 'sh-mode-syntax-table tem))
+ (set-syntax-table sh-mode-syntax-table)))
(dolist (var (sh-feature sh-variables))
(sh-remember-variable var))
- (make-local-variable 'indent-line-function)
(if (setq sh-indent-supported-here (sh-feature sh-indent-supported))
(progn
(message "Setting up indent for shell type %s" sh-shell)
@@ -1770,7 +1745,7 @@ Calls the value of `sh-set-shell-hook' if set."
(message "setting up indent stuff")
;; sh-mode has already made indent-line-function local
;; but do it in case this is called before that.
- (setq indent-line-function 'sh-indent-line)
+ (set (make-local-variable 'indent-line-function) 'sh-indent-line)
(if sh-make-vars-local
(sh-make-vars-local))
(message "Indentation setup for shell type %s" sh-shell))
@@ -2162,11 +2137,7 @@ Return new point if successful, nil if an error occurred."
(defun sh-handle-prev-do ()
(cond
((save-restriction
- (narrow-to-region
- (point)
- (save-excursion
- (beginning-of-line)
- (point)))
+ (narrow-to-region (point) (line-beginning-position))
(sh-goto-match-for-done))
(sh-debug "match for done found on THIS line")
(list '(+ sh-indent-after-loop-construct)))
@@ -2233,10 +2204,9 @@ STRING This is ignored for the purposes of calculating
;; Note: setting result to t means we are done and will return nil.
;;(This function never returns just t.)
(cond
- ((or (and (boundp 'font-lock-string-face) (not (bobp))
- (eq (get-text-property (1- (point)) 'face)
- font-lock-string-face))
+ ((or (nth 3 (syntax-ppss (point)))
(eq (get-text-property (point) 'face) sh-heredoc-face))
+ ;; String continuation -- don't indent
(setq result t)
(setq have-result t))
((looking-at "\\s-*#") ; was (equal this-kw "#")
@@ -3469,20 +3439,15 @@ CODE can be nil, t or `lambda'.
nil means to return the best completion of STRING, or nil if there is none.
t means to return a list of all possible completions of STRING.
`lambda' means to return t if STRING is a valid completion as it stands."
- (let ((sh-shell-variables
+ (let ((vars
(with-current-buffer sh-add-buffer
(or sh-shell-variables-initialized
(sh-shell-initialize-variables))
(nconc (mapcar (lambda (var)
- (let ((name
- (substring var 0 (string-match "=" var))))
- (cons name name)))
+ (substring var 0 (string-match "=" var)))
process-environment)
sh-shell-variables))))
- (case code
- ((nil) (try-completion string sh-shell-variables predicate))
- (lambda (test-completion string sh-shell-variables predicate))
- (t (all-completions string sh-shell-variables predicate)))))
+ (complete-with-action code vars string predicate)))
(defun sh-add (var delta)
"Insert an addition of VAR and prefix DELTA for Bourne (type) shell."
@@ -3872,5 +3837,4 @@ shell command and conveniently use this command."
(provide 'sh-script)
-;; arch-tag: eccd8b72-f337-4fc2-ae86-18155a69d937
;;; sh-script.el ends here
diff --git a/lisp/progmodes/simula.el b/lisp/progmodes/simula.el
index 3f842903b0d..bfa921841e2 100644
--- a/lisp/progmodes/simula.el
+++ b/lisp/progmodes/simula.el
@@ -163,17 +163,18 @@ for SIMULA mode to function correctly."
(defvar simula-mode-syntax-table nil
"Syntax table in SIMULA mode buffers.")
-(defconst simula-font-lock-syntactic-keywords
- `(;; `comment' directive.
- ("\\<\\(c\\)omment\\>" 1 "<")
- ;; end comments
- (,(concat "\\<end\\>\\([^;\n]\\).*?\\(\n\\|\\(.\\)\\(;\\|"
- (regexp-opt '("end" "else" "when" "otherwise"))
- "\\)\\)")
- (1 "< b")
- (3 "> b" nil t))
- ;; non-quoted single-quote char.
- ("'\\('\\)'" 1 ".")))
+(defconst simula-syntax-propertize-function
+ (syntax-propertize-rules
+ ;; `comment' directive.
+ ("\\<\\(c\\)omment\\>" (1 "<"))
+ ;; end comments
+ ((concat "\\<end\\>\\([^;\n]\\).*?\\(\n\\|\\(.\\)\\(;\\|"
+ (regexp-opt '("end" "else" "when" "otherwise"))
+ "\\)\\)")
+ (1 "< b")
+ (3 "> b"))
+ ;; non-quoted single-quote char.
+ ("'\\('\\)'" (1 "."))))
;; Regexps written with help from Alf-Ivar Holm <alfh@ifi.uio.no>.
(defconst simula-font-lock-keywords-1
@@ -330,7 +331,7 @@ for SIMULA mode to function correctly."
(popup-menu (cons (concat mode-name " Mode Commands") simula-mode-menu)))
;;;###autoload
-(define-derived-mode simula-mode nil "Simula"
+(define-derived-mode simula-mode prog-mode "Simula"
"Major mode for editing SIMULA code.
\\{simula-mode-map}
Variables controlling indentation style:
@@ -396,8 +397,9 @@ with no arguments, if that value is non-nil."
(setq font-lock-defaults
'((simula-font-lock-keywords simula-font-lock-keywords-1
simula-font-lock-keywords-2 simula-font-lock-keywords-3)
- nil t ((?_ . "w")) nil
- (font-lock-syntactic-keywords . simula-font-lock-syntactic-keywords)))
+ nil t ((?_ . "w"))))
+ (set (make-local-variable 'syntax-propertize-function)
+ simula-syntax-propertize-function)
(abbrev-mode 1))
(defun simula-indent-exp ()
@@ -962,7 +964,7 @@ If COUNT is negative, move backward instead."
(simula-previous-statement 1)
(simula-skip-comment-backward)))
(setq start-line
- (save-excursion (beginning-of-line) (point))
+ (line-beginning-position)
;; - perhaps this is a continued statement
continued
(save-excursion
@@ -1021,7 +1023,7 @@ If COUNT is negative, move backward instead."
(car simula-continued-statement-offset)
simula-continued-statement-offset))))
(setq start-line
- (save-excursion (beginning-of-line) (point))
+ (line-beginning-position)
continued nil))
;; search failed .. point is at beginning of line
;; determine if we should continue searching
@@ -1062,7 +1064,7 @@ If COUNT is negative, move backward instead."
simula-continued-statement-offset))))
;; while ends if point is at beginning of line at loop test
(if (not temp)
- (setq start-line (save-excursion (beginning-of-line) (point)))
+ (setq start-line (line-beginning-position))
(beginning-of-line))))
;;
;; return indentation
@@ -1657,5 +1659,4 @@ If not nil and not t, move to limit of search and return nil."
(provide 'simula)
-;; arch-tag: 488c1bb0-eebf-4f06-93df-1df603f06255
;;; simula.el ends here
diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el
index 6bd0d45bbd9..acb34eacc2b 100644
--- a/lisp/progmodes/sql.el
+++ b/lisp/progmodes/sql.el
@@ -5,7 +5,7 @@
;; Author: Alex Schroeder <alex@gnu.org>
;; Maintainer: Michael Mauger <mmaug@yahoo.com>
-;; Version: 2.0.2
+;; Version: 2.8
;; Keywords: comm languages processes
;; URL: http://savannah.gnu.org/projects/emacs/
;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?SqlMode
@@ -103,83 +103,75 @@
;; identifiers; ms (Microsoft SQLServer) also supports identifiers
;; enclosed within brackets [].
-;; ChangeLog available on request.
-
;;; Product Support:
;; To add support for additional SQL products the following steps
;; must be followed ("xyz" is the name of the product in the examples
;; below):
-;; 1) Add the product to `sql-product' choice list.
+;; 1) Add the product to the list of known products.
-;; (const :tag "XyzDB" xyz)
+;; (sql-add-product 'xyz "XyzDB"
+;; '(:free-software t))
-;; 2) Add an entry to the `sql-product-alist' list.
+;; 2) Define font lock settings. All ANSI keywords will be
+;; highlighted automatically, so only product specific keywords
+;; need to be defined here.
-;; (xyz
-;; :font-lock sql-mode-xyz-font-lock-keywords
-;; :sqli-login (user password server database)
-;; :sqli-connect sql-connect-xyz
-;; :sqli-prompt-regexp "^xyzdb> "
-;; :sqli-prompt-length 7
-;; :sqli-input-sender nil
-;; :syntax-alist ((?# . "w")))
+;; (defvar my-sql-mode-xyz-font-lock-keywords
+;; '(("\\b\\(red\\|orange\\|yellow\\)\\b"
+;; . font-lock-keyword-face))
+;; "XyzDB SQL keywords used by font-lock.")
-;; 3) Add customizable values for the product interpreter and options.
+;; (sql-set-product-feature 'xyz
+;; :font-lock
+;; 'my-sql-mode-xyz-font-lock-keywords)
-;; ;; Customization for XyzDB
-;;
-;; (defcustom sql-xyz-program "ixyz"
-;; "*Command to start ixyz by XyzDB."
+;; 3) Define any special syntax characters including comments and
+;; identifier characters.
+
+;; (sql-set-product-feature 'xyz
+;; :syntax-alist ((?# . "w")))
+
+;; 4) Define the interactive command interpreter for the database
+;; product.
+
+;; (defcustom my-sql-xyz-program "ixyz"
+;; "Command to start ixyz by XyzDB."
;; :type 'file
;; :group 'SQL)
;;
-;; (defcustom sql-xyz-options '("-X" "-Y" "-Z")
-;; "*List of additional options for `sql-xyz-program'."
-;; :type '(repeat string)
+;; (sql-set-product-feature 'xyz
+;; :sqli-program 'my-sql-xyz-program)
+;; (sql-set-product-feature 'xyz
+;; :prompt-regexp "^xyzdb> ")
+;; (sql-set-product-feature 'xyz
+;; :prompt-length 7)
+
+;; 5) Define login parameters and command line formatting.
+
+;; (defcustom my-sql-xyz-login-params '(user password server database)
+;; "Login parameters to needed to connect to XyzDB."
+;; :type 'sql-login-params
;; :group 'SQL)
+;;
+;; (sql-set-product-feature 'xyz
+;; :sqli-login 'my-sql-xyz-login-params)
-;; 4) Add an entry to SQL->Product submenu.
-
-;; ["XyzDB" sql-highlight-xyz-keywords
-;; :style radio
-;; :selected (eq sql-product 'xyz)]
-
-;; 5) Add the font-lock specifications. At a minimum, default to
-;; using ANSI keywords. See sql-mode-oracle-font-lock-keywords for
-;; a more complex example.
-
-;; (defvar sql-mode-xyz-font-lock-keywords nil
-;; "XyzDB SQL keywords used by font-lock.")
-
-;; 6) Add a product highlighting function.
-
-;; (defun sql-highlight-xyz-keywords ()
-;; "Highlight XyzDB keywords."
-;; (interactive)
-;; (sql-set-product 'xyz))
-
-;; 7) Add an autoloaded SQLi function.
-
-;; ;;;###autoload
-;; (defun sql-xyz ()
-;; "Run ixyz by XyzDB as an inferior process."
-;; (interactive)
-;; (sql-product-interactive 'xyz))
-
-;; 8) Add a connect function which formats the command line arguments
-;; and starts the product interpreter in a comint buffer. See the
-;; existing connect functions for examples of the types of
-;; processing available.
+;; (defcustom my-sql-xyz-options '("-X" "-Y" "-Z")
+;; "List of additional options for `sql-xyz-program'."
+;; :type '(repeat string)
+;; :group 'SQL)
+;;
+;; (sql-set-product-feature 'xyz
+;; :sqli-options 'my-sql-xyz-options))
-;; (defun sql-connect-xyz ()
-;; "Create comint buffer and connect to XyzDB using the login
-;; parameters and command options."
+;; (defun my-sql-comint-xyz (product options)
+;; "Connect ti XyzDB in a comint buffer."
;;
;; ;; Do something with `sql-user', `sql-password',
;; ;; `sql-database', and `sql-server'.
-;; (let ((params sql-xyz-options))
+;; (let ((params options))
;; (if (not (string= "" sql-server))
;; (setq params (append (list "-S" sql-server) params)))
;; (if (not (string= "" sql-database))
@@ -188,25 +180,36 @@
;; (setq params (append (list "-P" sql-password) params)))
;; (if (not (string= "" sql-user))
;; (setq params (append (list "-U" sql-user) params)))
-;; (set-buffer (apply 'make-comint "SQL" sql-xyz-program
-;; nil params))))
+;; (sql-comint product params)))
+;;
+;; (sql-set-product-feature 'xyz
+;; :sqli-comint-func 'my-sql-comint-xyz)
+
+;; 6) Define a convienence function to invoke the SQL interpreter.
-;; 9) Save and compile sql.el.
+;; (defun my-sql-xyz (&optional buffer)
+;; "Run ixyz by XyzDB as an inferior process."
+;; (interactive "P")
+;; (sql-product-interactive 'xyz buffer))
;;; To Do:
-;; Add better hilight support for other brands; there is a bias towards
-;; Oracle because that's what I use at work. Anybody else just send in
-;; your lists of reserved words, keywords and builtin functions! As
-;; long as I don't receive any feedback, everything is hilighted with
-;; ANSI keywords only. I received the list of ANSI keywords from a
-;; user; if you know of any changes, let me know.
+;; Improve keyword highlighting for individual products. I have tried
+;; to update those database that I use. Feel free to send me updates,
+;; or direct me to the reference manuals for your favorite database.
-;; Add different hilighting levels.
+;; When there are no keywords defined, the ANSI keywords are
+;; highlighted. ANSI keywords are highlighted even if the keyword is
+;; not used for your current product. This should help identify
+;; portability concerns.
+
+;; Add different highlighting levels.
+
+;; Add support for listing available tables or the columns in a table.
;;; Thanks to all the people who helped me out:
-;; Alex Schroeder <alex@gnu.org>
+;; Alex Schroeder <alex@gnu.org> -- the original author
;; Kai Blauberg <kai.blauberg@metla.fi>
;; <ibalaban@dalet.com>
;; Yair Friedman <yfriedma@JohnBryce.Co.Il>
@@ -217,7 +220,7 @@
;; 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
+;; Stefan Monnier <monnier@iro.umontreal.ca> -- font-lock corrections; code polish
@@ -229,7 +232,7 @@
(require 'regexp-opt))
(require 'custom)
(eval-when-compile ;; needed in Emacs 19, 20
- (setq max-specpdl-size 2000))
+ (setq max-specpdl-size (max max-specpdl-size 2000)))
(defvar font-lock-keyword-face)
(defvar font-lock-set-defaults)
@@ -240,144 +243,275 @@
(defgroup SQL nil
"Running a SQL interpreter from within Emacs buffers."
:version "20.4"
+ :group 'languages
:group 'processes)
;; These four variables will be used as defaults, if set.
(defcustom sql-user ""
- "*Default username."
+ "Default username."
:type 'string
- :group 'SQL)
+ :group 'SQL
+ :safe 'stringp)
(defcustom sql-password ""
- "*Default password.
+ "Default password.
Storing your password in a textfile such as ~/.emacs could be dangerous.
Customizing your password will store it in your ~/.emacs file."
:type 'string
- :group 'SQL)
+ :group 'SQL
+ :risky t)
(defcustom sql-database ""
- "*Default database."
+ "Default database."
:type 'string
- :group 'SQL)
+ :group 'SQL
+ :safe 'stringp)
(defcustom sql-server ""
- "*Default server or host."
+ "Default server or host."
:type 'string
- :group 'SQL)
+ :group 'SQL
+ :safe 'stringp)
+
+(defcustom sql-port 0
+ "Default port."
+ :version "24.1"
+ :type 'number
+ :group 'SQL
+ :safe 'numberp)
+
+;; Login parameter type
+
+(define-widget 'sql-login-params 'lazy
+ "Widget definition of the login parameters list"
+ ;; FIXME: does not implement :default property for the user,
+ ;; database and server options. Anybody have some guidance on how to
+ ;; do this.
+ :tag "Login Parameters"
+ :type '(repeat (choice
+ (const user)
+ (const password)
+ (choice :tag "server"
+ (const server)
+ (list :tag "file"
+ (const :format "" server)
+ (const :format "" :file)
+ regexp)
+ (list :tag "completion"
+ (const :format "" server)
+ (const :format "" :completion)
+ (restricted-sexp
+ :match-alternatives (listp stringp))))
+ (choice :tag "database"
+ (const database)
+ (list :tag "file"
+ (const :format "" database)
+ (const :format "" :file)
+ regexp)
+ (list :tag "completion"
+ (const :format "" database)
+ (const :format "" :completion)
+ (restricted-sexp
+ :match-alternatives (listp stringp))))
+ (const port))))
;; SQL Product support
(defvar sql-interactive-product nil
"Product under `sql-interactive-mode'.")
+(defvar sql-connection nil
+ "Connection name if interactive session started by `sql-connect'.")
+
(defvar sql-product-alist
'((ansi
:name "ANSI"
:font-lock sql-mode-ansi-font-lock-keywords)
+
(db2
:name "DB2"
:font-lock sql-mode-db2-font-lock-keywords
- :sqli-login nil
- :sqli-connect sql-connect-db2
- :sqli-prompt-regexp "^db2 => "
- :sqli-prompt-length 7)
+ :sqli-program sql-db2-program
+ :sqli-options sql-db2-options
+ :sqli-login sql-db2-login-params
+ :sqli-comint-func sql-comint-db2
+ :prompt-regexp "^db2 => "
+ :prompt-length 7
+ :prompt-cont-regexp "^db2 (cont\.) => "
+ :input-filter sql-escape-newlines-filter)
+
(informix
+ :name "Informix"
:font-lock sql-mode-informix-font-lock-keywords
- :sqli-login (database)
- :sqli-connect sql-connect-informix
- :sqli-prompt-regexp "^SQL> "
- :sqli-prompt-length 5)
+ :sqli-program sql-informix-program
+ :sqli-options sql-informix-options
+ :sqli-login sql-informix-login-params
+ :sqli-comint-func sql-comint-informix
+ :prompt-regexp "^> "
+ :prompt-length 2
+ :syntax-alist ((?{ . "<") (?} . ">")))
+
(ingres
+ :name "Ingres"
:font-lock sql-mode-ingres-font-lock-keywords
- :sqli-login (database)
- :sqli-connect sql-connect-ingres
- :sqli-prompt-regexp "^\* "
- :sqli-prompt-length 2)
+ :sqli-program sql-ingres-program
+ :sqli-options sql-ingres-options
+ :sqli-login sql-ingres-login-params
+ :sqli-comint-func sql-comint-ingres
+ :prompt-regexp "^\* "
+ :prompt-length 2
+ :prompt-cont-regexp "^\* ")
+
(interbase
+ :name "Interbase"
:font-lock sql-mode-interbase-font-lock-keywords
- :sqli-login (user password database)
- :sqli-connect sql-connect-interbase
- :sqli-prompt-regexp "^SQL> "
- :sqli-prompt-length 5)
+ :sqli-program sql-interbase-program
+ :sqli-options sql-interbase-options
+ :sqli-login sql-interbase-login-params
+ :sqli-comint-func sql-comint-interbase
+ :prompt-regexp "^SQL> "
+ :prompt-length 5)
+
(linter
+ :name "Linter"
:font-lock sql-mode-linter-font-lock-keywords
- :sqli-login (user password database server)
- :sqli-connect sql-connect-linter
- :sqli-prompt-regexp "^SQL>"
- :sqli-prompt-length 4)
+ :sqli-program sql-linter-program
+ :sqli-options sql-linter-options
+ :sqli-login sql-linter-login-params
+ :sqli-comint-func sql-comint-linter
+ :prompt-regexp "^SQL>"
+ :prompt-length 4)
+
(ms
- :name "MS SQLServer"
+ :name "Microsoft"
:font-lock sql-mode-ms-font-lock-keywords
- :sqli-login (user password server database)
- :sqli-connect sql-connect-ms
- :sqli-prompt-regexp "^[0-9]*>"
- :sqli-prompt-length 5
- :syntax-alist ((?@ . "w")))
+ :sqli-program sql-ms-program
+ :sqli-options sql-ms-options
+ :sqli-login sql-ms-login-params
+ :sqli-comint-func sql-comint-ms
+ :prompt-regexp "^[0-9]*>"
+ :prompt-length 5
+ :syntax-alist ((?@ . "w"))
+ :terminator ("^go" . "go"))
+
(mysql
:name "MySQL"
+ :free-software t
:font-lock sql-mode-mysql-font-lock-keywords
- :sqli-login (user password database server)
- :sqli-connect sql-connect-mysql
- :sqli-prompt-regexp "^mysql> "
- :sqli-prompt-length 6)
+ :sqli-program sql-mysql-program
+ :sqli-options sql-mysql-options
+ :sqli-login sql-mysql-login-params
+ :sqli-comint-func sql-comint-mysql
+ :list-all "SHOW TABLES;"
+ :list-table "DESCRIBE %s;"
+ :prompt-regexp "^mysql> "
+ :prompt-length 6
+ :prompt-cont-regexp "^ -> "
+ :input-filter sql-remove-tabs-filter)
+
(oracle
+ :name "Oracle"
:font-lock sql-mode-oracle-font-lock-keywords
- :sqli-login (user password database)
- :sqli-connect sql-connect-oracle
- :sqli-prompt-regexp "^SQL> "
- :sqli-prompt-length 5
- :syntax-alist ((?$ . "w") (?# . "w")))
+ :sqli-program sql-oracle-program
+ :sqli-options sql-oracle-options
+ :sqli-login sql-oracle-login-params
+ :sqli-comint-func sql-comint-oracle
+ :prompt-regexp "^SQL> "
+ :prompt-length 5
+ :prompt-cont-regexp "^\\s-*\\d+> "
+ :syntax-alist ((?$ . "w") (?# . "w"))
+ :terminator ("\\(^/\\|;\\)" . "/")
+ :input-filter sql-placeholders-filter)
+
(postgres
+ :name "Postgres"
+ :free-software t
:font-lock sql-mode-postgres-font-lock-keywords
- :sqli-login (user database server)
- :sqli-connect sql-connect-postgres
- :sqli-prompt-regexp "^.*[#>] *"
- :sqli-prompt-length 5)
+ :sqli-program sql-postgres-program
+ :sqli-options sql-postgres-options
+ :sqli-login sql-postgres-login-params
+ :sqli-comint-func sql-comint-postgres
+ :list-all ("\\d+" . "\\dS+")
+ :list-table ("\\d+ %s" . "\\dS+ %s")
+ :prompt-regexp "^.*=[#>] "
+ :prompt-length 5
+ :prompt-cont-regexp "^.*[-(][#>] "
+ :input-filter sql-remove-tabs-filter
+ :terminator ("\\(^\\s-*\\\\g\\|;\\)" . ";"))
+
(solid
+ :name "Solid"
:font-lock sql-mode-solid-font-lock-keywords
- :sqli-login (user password server)
- :sqli-connect sql-connect-solid
- :sqli-prompt-regexp "^"
- :sqli-prompt-length 0)
+ :sqli-program sql-solid-program
+ :sqli-options sql-solid-options
+ :sqli-login sql-solid-login-params
+ :sqli-comint-func sql-comint-solid
+ :prompt-regexp "^"
+ :prompt-length 0)
+
(sqlite
:name "SQLite"
+ :free-software t
:font-lock sql-mode-sqlite-font-lock-keywords
- :sqli-login (database)
- :sqli-connect sql-connect-sqlite
- :sqli-prompt-regexp "^sqlite> "
- :sqli-prompt-length 8)
+ :sqli-program sql-sqlite-program
+ :sqli-options sql-sqlite-options
+ :sqli-login sql-sqlite-login-params
+ :sqli-comint-func sql-comint-sqlite
+ :list-all ".tables"
+ :list-table ".schema %s"
+ :prompt-regexp "^sqlite> "
+ :prompt-length 8
+ :prompt-cont-regexp "^ ...> "
+ :terminator ";")
+
(sybase
+ :name "Sybase"
:font-lock sql-mode-sybase-font-lock-keywords
- :sqli-login (server user password database)
- :sqli-connect sql-connect-sybase
- :sqli-prompt-regexp "^SQL> "
- :sqli-prompt-length 5
- :syntax-alist ((?@ . "w")))
+ :sqli-program sql-sybase-program
+ :sqli-options sql-sybase-options
+ :sqli-login sql-sybase-login-params
+ :sqli-comint-func sql-comint-sybase
+ :prompt-regexp "^SQL> "
+ :prompt-length 5
+ :syntax-alist ((?@ . "w"))
+ :terminator ("^go" . "go"))
)
- "This variable contains a list of product features for each of the
-SQL products handled by `sql-mode'. Without an entry in this list a
-product will not be properly highlighted and will not support
-`sql-interactive-mode'.
+ "An alist of product specific configuration settings.
+
+Without an entry in this list a product will not be properly
+highlighted and will not support `sql-interactive-mode'.
Each element in the list is in the following format:
\(PRODUCT FEATURE VALUE ...)
-where PRODUCT is the appropriate value of `sql-product'. The product
-name is then followed by FEATURE-VALUE pairs. If a FEATURE is not
-specified, its VALUE is treated as nil. FEATURE must be one of the
-following:
+where PRODUCT is the appropriate value of `sql-product'. The
+product name is then followed by FEATURE-VALUE pairs. If a
+FEATURE is not specified, its VALUE is treated as nil. FEATURE
+may be any one of the following:
+
+ :name string containing the displayable name of
+ the product.
+
+ :free-software is the product Free (as in Freedom) software?
:font-lock name of the variable containing the product
specific font lock highlighting patterns.
- :sqli-login a list of login parameters (i.e., user,
- password, database and server) needed to
- connect to the database.
+ :sqli-program name of the variable containing the product
+ specific interactive program name.
+
+ :sqli-options name of the variable containing the list
+ of product specific options.
- :sqli-connect the name of a function which accepts no
+ :sqli-login name of the variable containing the list of
+ login parameters (i.e., user, password,
+ database and server) needed to connect to
+ the database.
+
+ :sqli-comint-func name of a function which accepts no
parameters that will use the values of
`sql-user', `sql-password',
`sql-database' and `sql-server' to open a
@@ -385,19 +519,114 @@ following:
database. Do product specific
configuration of comint in this function.
- :sqli-prompt-regexp a regular expression string that matches
+ :list-all Command string or function which produces
+ a listing of all objects in the database.
+ If it's a cons cell, then the car
+ produces the standard list of objects and
+ the cdr produces an enhanced list of
+ objects. What \"enhanced\" means is
+ dependent on the SQL product and may not
+ exist. In general though, the
+ \"enhanced\" list should include visible
+ objects from other schemas.
+
+ :list-table Command string or function which produces
+ a detailed listing of a specific database
+ table. If its a cons cell, then the car
+ produces the standard list and the cdr
+ produces an enhanced list.
+
+ :prompt-regexp 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.(Not
- needed in 21.3+)
-
- :syntax-alist an alist of syntax table entries to enable
- special character treatment by font-lock and
- imenu. ")
+ interpreter.
+
+ :prompt-length length of the prompt on the line.
+
+ :prompt-cont-regexp regular expression string that matches
+ the continuation prompt issued by the
+ product interpreter.
+
+ :input-filter function which can filter strings sent to
+ the command interpreter. It is also used
+ by the `sql-send-string',
+ `sql-send-region', `sql-send-paragraph'
+ and `sql-send-buffer' functions. The
+ function is passed the string sent to the
+ command interpreter and must return the
+ filtered string. May also be a list of
+ such functions.
+
+ :terminator the terminator to be sent after a
+ `sql-send-string', `sql-send-region',
+ `sql-send-paragraph' and
+ `sql-send-buffer' command. May be the
+ literal string or a cons of a regexp to
+ match an existing terminator in the
+ string and the terminator to be used if
+ its absent. By default \";\".
+
+ :syntax-alist alist of syntax table entries to enable
+ special character treatment by font-lock
+ and imenu.
+
+Other features can be stored but they will be ignored. However,
+you can develop new functionality which is product independent by
+using `sql-get-product-feature' to lookup the product specific
+settings.")
+
+(defvar sql-indirect-features
+ '(:font-lock :sqli-program :sqli-options :sqli-login))
+
+(defcustom sql-connection-alist nil
+ "An alist of connection parameters for interacting with a SQL
+ product.
+
+Each element of the alist is as follows:
+
+ \(CONNECTION \(SQL-VARIABLE VALUE) ...)
+
+Where CONNECTION is a symbol identifying the connection, SQL-VARIABLE
+is the symbol name of a SQL mode variable, and VALUE is the value to
+be assigned to the variable.
+
+The most common SQL-VARIABLE settings associated with a connection
+are:
+
+ `sql-product'
+ `sql-user'
+ `sql-password'
+ `sql-port'
+ `sql-server'
+ `sql-database'
+
+If a SQL-VARIABLE is part of the connection, it will not be
+prompted for during login."
+
+ :type `(alist :key-type (string :tag "Connection")
+ :value-type
+ (set
+ (group (const :tag "Product" sql-product)
+ (choice
+ ,@(mapcar (lambda (prod-info)
+ `(const :tag
+ ,(or (plist-get (cdr prod-info) :name)
+ (capitalize (symbol-name (car prod-info))))
+ (quote ,(car prod-info))))
+ sql-product-alist)))
+ (group (const :tag "Username" sql-user) string)
+ (group (const :tag "Password" sql-password) string)
+ (group (const :tag "Server" sql-server) string)
+ (group (const :tag "Database" sql-database) string)
+ (group (const :tag "Port" sql-port) integer)
+ (repeat :inline t
+ (list :tab "Other"
+ (symbol :tag " Variable Symbol")
+ (sexp :tag "Value Expression")))))
+ :version "24.1"
+ :group 'SQL)
(defcustom sql-product 'ansi
- "*Select the SQL database product used so that buffers can be
+ "Select the SQL database product used so that buffers can be
highlighted properly when you open them."
:type `(choice
,@(mapcar (lambda (prod-info)
@@ -406,9 +635,11 @@ highlighted properly when you open them."
(capitalize (symbol-name (car prod-info))))
,(car prod-info)))
sql-product-alist))
- :group 'SQL)
+ :group 'SQL
+ :safe 'symbolp)
+(defvaralias 'sql-dialect 'sql-product)
-;; misc customization of sql.el behavior
+;; misc customization of sql.el behaviour
(defcustom sql-electric-stuff nil
"Treat some input as electric.
@@ -424,14 +655,44 @@ current input in the SQLi buffer to the process."
:version "20.8"
:group 'SQL)
-(defcustom sql-pop-to-buffer-after-send-region nil
- "*If t, pop to the buffer SQL statements are sent to.
+(defcustom sql-send-terminator nil
+ "When non-nil, add a terminator to text sent to the SQL interpreter.
+
+When text is sent to the SQL interpreter (via `sql-send-string',
+`sql-send-region', `sql-send-paragraph' or `sql-send-buffer'), a
+command terminator can be automatically sent as well. The
+terminator is not sent, if the string sent already ends with the
+terminator.
+
+If this value is t, then the default command terminator for the
+SQL interpreter is sent. If this value is a string, then the
+string is sent.
+
+If the value is a cons cell of the form (PAT . TERM), then PAT is
+a regexp used to match the terminator in the string and TERM is
+the terminator to be sent. This form is useful if the SQL
+interpreter has more than one way of submitting a SQL command.
+The PAT regexp can match any of them, and TERM is the way we do
+it automatically."
+
+ :type '(choice (const :tag "No Terminator" nil)
+ (const :tag "Default Terminator" t)
+ (string :tag "Terminator String")
+ (cons :tag "Terminator Pattern and String"
+ (string :tag "Terminator Pattern")
+ (string :tag "Terminator String")))
+ :version "22.2"
+ :group 'SQL)
-After a call to `sql-send-region' or `sql-send-buffer',
-the window is split and the SQLi buffer is shown. If this
-variable is not nil, that buffer's window will be selected
-by calling `pop-to-buffer'. If this variable is nil, that
-buffer is shown using `display-buffer'."
+(defcustom sql-pop-to-buffer-after-send-region nil
+ "When non-nil, pop to the buffer SQL statements are sent to.
+
+After a call to `sql-sent-string', `sql-send-region',
+`sql-send-paragraph' or `sql-send-buffer', the window is split
+and the SQLi buffer is shown. If this variable is not nil, that
+buffer's window will be selected by calling `pop-to-buffer'. If
+this variable is nil, that buffer is shown using
+`display-buffer'."
:type 'boolean
:group 'SQL)
@@ -445,6 +706,7 @@ buffer is shown using `display-buffer'."
("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)
+ ("Types" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*type\\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'.
@@ -457,7 +719,7 @@ a local variable.")
;; history file
(defcustom sql-input-ring-file-name nil
- "*If non-nil, name of the file to read/write input history.
+ "If non-nil, name of the file to read/write input history.
You have to set this variable if you want the history of your commands
saved from one Emacs session to the next. If this variable is set,
@@ -474,7 +736,7 @@ Note that the size of the input history is determined by the variable
:group 'SQL)
(defcustom sql-input-ring-separator "\n--\n"
- "*Separator between commands in the history file.
+ "Separator between commands in the history file.
If set to \"\\n\", each line in the history file will be interpreted as
one command. Multi-line commands are split into several commands when
@@ -492,17 +754,17 @@ commands when the input history is read, as if you had set
;; The usual hooks
(defcustom sql-interactive-mode-hook '()
- "*Hook for customizing `sql-interactive-mode'."
+ "Hook for customizing `sql-interactive-mode'."
:type 'hook
:group 'SQL)
(defcustom sql-mode-hook '()
- "*Hook for customizing `sql-mode'."
+ "Hook for customizing `sql-mode'."
:type 'hook
:group 'SQL)
(defcustom sql-set-sqli-hook '()
- "*Hook for reacting to changes of `sql-buffer'.
+ "Hook for reacting to changes of `sql-buffer'.
This is called by `sql-set-sqli-buffer' when the value of `sql-buffer'
is changed."
@@ -512,142 +774,189 @@ is changed."
;; Customization for Oracle
(defcustom sql-oracle-program "sqlplus"
- "*Command to start sqlplus by Oracle.
+ "Command to start sqlplus by Oracle.
Starts `sql-interactive-mode' after doing some setup.
-On Windows, \"sqlplus\" usually starts the sqlplus \"GUI\". In order to
-start the sqlplus console, use \"plus33\" or something similar. You
-will find the file in your Orant\\bin directory.
-
-The program can also specify a TCP connection. See `make-comint'."
+On Windows, \"sqlplus\" usually starts the sqlplus \"GUI\". In order
+to start the sqlplus console, use \"plus33\" or something similar.
+You will find the file in your Orant\\bin directory."
:type 'file
:group 'SQL)
(defcustom sql-oracle-options nil
- "*List of additional options for `sql-oracle-program'."
+ "List of additional options for `sql-oracle-program'."
:type '(repeat string)
:version "20.8"
:group 'SQL)
-;; Customization for SQLite
+(defcustom sql-oracle-login-params '(user password database)
+ "List of login parameters needed to connect to Oracle."
+ :type 'sql-login-params
+ :version "24.1"
+ :group 'SQL)
-(defcustom sql-sqlite-program "sqlite"
- "*Command to start SQLite.
+(defcustom sql-oracle-scan-on t
+ "Non-nil if placeholders should be replaced in Oracle SQLi.
-Starts `sql-interactive-mode' after doing some setup.
+When non-nil, Emacs will scan text sent to sqlplus and prompt
+for replacement text for & placeholders as sqlplus does. This
+is needed on Windows where sqlplus output is buffered and the
+prompts are not shown until after the text is entered.
+
+You will probably want to issue the following command in sqlplus
+to be safe:
+
+ SET SCAN OFF"
+ :type 'boolean
+ :group 'SQL)
+
+;; Customization for SQLite
-The program can also specify a TCP connection. See `make-comint'."
+(defcustom sql-sqlite-program (or (executable-find "sqlite3")
+ (executable-find "sqlite")
+ "sqlite")
+ "Command to start SQLite.
+
+Starts `sql-interactive-mode' after doing some setup."
:type 'file
:group 'SQL)
(defcustom sql-sqlite-options nil
- "*List of additional options for `sql-sqlite-program'."
+ "List of additional options for `sql-sqlite-program'."
:type '(repeat string)
:version "20.8"
:group 'SQL)
+(defcustom sql-sqlite-login-params '((database :file ".*\\.\\(db\\|sqlite[23]?\\)"))
+ "List of login parameters needed to connect to SQLite."
+ :type 'sql-login-params
+ :version "24.1"
+ :group 'SQL)
+
;; Customization for MySql
(defcustom sql-mysql-program "mysql"
- "*Command to start mysql by TcX.
-
-Starts `sql-interactive-mode' after doing some setup.
+ "Command to start mysql by TcX.
-The program can also specify a TCP connection. See `make-comint'."
+Starts `sql-interactive-mode' after doing some setup."
:type 'file
:group 'SQL)
(defcustom sql-mysql-options nil
- "*List of additional options for `sql-mysql-program'.
+ "List of additional options for `sql-mysql-program'.
The following list of options is reported to make things work
on Windows: \"-C\" \"-t\" \"-f\" \"-n\"."
:type '(repeat string)
:version "20.8"
:group 'SQL)
+(defcustom sql-mysql-login-params '(user password database server)
+ "List of login parameters needed to connect to MySql."
+ :type 'sql-login-params
+ :version "24.1"
+ :group 'SQL)
+
;; Customization for Solid
(defcustom sql-solid-program "solsql"
- "*Command to start SOLID SQL Editor.
-
-Starts `sql-interactive-mode' after doing some setup.
+ "Command to start SOLID SQL Editor.
-The program can also specify a TCP connection. See `make-comint'."
+Starts `sql-interactive-mode' after doing some setup."
:type 'file
:group 'SQL)
-;; Customization for SyBase
+(defcustom sql-solid-login-params '(user password server)
+ "List of login parameters needed to connect to Solid."
+ :type 'sql-login-params
+ :version "24.1"
+ :group 'SQL)
+
+;; Customization for Sybase
(defcustom sql-sybase-program "isql"
- "*Command to start isql by SyBase.
-
-Starts `sql-interactive-mode' after doing some setup.
+ "Command to start isql by Sybase.
-The program can also specify a TCP connection. See `make-comint'."
+Starts `sql-interactive-mode' after doing some setup."
:type 'file
:group 'SQL)
(defcustom sql-sybase-options nil
- "*List of additional options for `sql-sybase-program'.
+ "List of additional options for `sql-sybase-program'.
Some versions of isql might require the -n option in order to work."
:type '(repeat string)
:version "20.8"
:group 'SQL)
+(defcustom sql-sybase-login-params '(server user password database)
+ "List of login parameters needed to connect to Sybase."
+ :type 'sql-login-params
+ :version "24.1"
+ :group 'SQL)
+
;; Customization for Informix
(defcustom sql-informix-program "dbaccess"
- "*Command to start dbaccess by Informix.
-
-Starts `sql-interactive-mode' after doing some setup.
+ "Command to start dbaccess by Informix.
-The program can also specify a TCP connection. See `make-comint'."
+Starts `sql-interactive-mode' after doing some setup."
:type 'file
:group 'SQL)
+(defcustom sql-informix-login-params '(database)
+ "List of login parameters needed to connect to Informix."
+ :type 'sql-login-params
+ :version "24.1"
+ :group 'SQL)
+
;; Customization for Ingres
(defcustom sql-ingres-program "sql"
- "*Command to start sql by Ingres.
+ "Command to start sql by Ingres.
-Starts `sql-interactive-mode' after doing some setup.
-
-The program can also specify a TCP connection. See `make-comint'."
+Starts `sql-interactive-mode' after doing some setup."
:type 'file
:group 'SQL)
+(defcustom sql-ingres-login-params '(database)
+ "List of login parameters needed to connect to Ingres."
+ :type 'sql-login-params
+ :version "24.1"
+ :group 'SQL)
+
;; Customization for Microsoft
(defcustom sql-ms-program "osql"
- "*Command to start osql by Microsoft.
+ "Command to start osql by Microsoft.
-Starts `sql-interactive-mode' after doing some setup.
-
-The program can also specify a TCP connection. See `make-comint'."
+Starts `sql-interactive-mode' after doing some setup."
:type 'file
:group 'SQL)
(defcustom sql-ms-options '("-w" "300" "-n")
;; -w is the linesize
- "*List of additional options for `sql-ms-program'."
+ "List of additional options for `sql-ms-program'."
:type '(repeat string)
:version "22.1"
:group 'SQL)
+(defcustom sql-ms-login-params '(user password server database)
+ "List of login parameters needed to connect to Microsoft."
+ :type 'sql-login-params
+ :version "24.1"
+ :group 'SQL)
+
;; Customization for Postgres
(defcustom sql-postgres-program "psql"
"Command to start psql by Postgres.
-Starts `sql-interactive-mode' after doing some setup.
-
-The program can also specify a TCP connection. See `make-comint'."
+Starts `sql-interactive-mode' after doing some setup."
:type 'file
:group 'SQL)
(defcustom sql-postgres-options '("-P" "pager=off")
- "*List of additional options for `sql-postgres-program'.
+ "List of additional options for `sql-postgres-program'.
The default setting includes the -P option which breaks older versions
of the psql client (such as version 6.5.3). The -P option is equivalent
to the --pset option. If you want the psql to prompt you for a user
@@ -658,55 +967,77 @@ add your name with a \"-U\" prefix (such as \"-Umark\") to the list."
:version "20.8"
:group 'SQL)
+(defcustom sql-postgres-login-params `((user :default ,(user-login-name))
+ (database :default ,(user-login-name))
+ server)
+ "List of login parameters needed to connect to Postgres."
+ :type 'sql-login-params
+ :version "24.1"
+ :group 'SQL)
+
;; Customization for Interbase
(defcustom sql-interbase-program "isql"
- "*Command to start isql by Interbase.
+ "Command to start isql by Interbase.
-Starts `sql-interactive-mode' after doing some setup.
-
-The program can also specify a TCP connection. See `make-comint'."
+Starts `sql-interactive-mode' after doing some setup."
:type 'file
:group 'SQL)
(defcustom sql-interbase-options nil
- "*List of additional options for `sql-interbase-program'."
+ "List of additional options for `sql-interbase-program'."
:type '(repeat string)
:version "20.8"
:group 'SQL)
+(defcustom sql-interbase-login-params '(user password database)
+ "List of login parameters needed to connect to Interbase."
+ :type 'sql-login-params
+ :version "24.1"
+ :group 'SQL)
+
;; Customization for DB2
(defcustom sql-db2-program "db2"
- "*Command to start db2 by IBM.
+ "Command to start db2 by IBM.
-Starts `sql-interactive-mode' after doing some setup.
-
-The program can also specify a TCP connection. See `make-comint'."
+Starts `sql-interactive-mode' after doing some setup."
:type 'file
:group 'SQL)
(defcustom sql-db2-options nil
- "*List of additional options for `sql-db2-program'."
+ "List of additional options for `sql-db2-program'."
:type '(repeat string)
:version "20.8"
:group 'SQL)
+(defcustom sql-db2-login-params nil
+ "List of login parameters needed to connect to DB2."
+ :type 'sql-login-params
+ :version "24.1"
+ :group 'SQL)
+
;; Customization for Linter
(defcustom sql-linter-program "inl"
- "*Command to start inl by RELEX.
+ "Command to start inl by RELEX.
Starts `sql-interactive-mode' after doing some setup."
:type 'file
:group 'SQL)
(defcustom sql-linter-options nil
- "*List of additional options for `sql-linter-program'."
+ "List of additional options for `sql-linter-program'."
:type '(repeat string)
:version "21.3"
:group 'SQL)
+(defcustom sql-linter-login-params '(user password database server)
+ "Login parameters to needed to connect to Linter."
+ :type 'sql-login-params
+ :version "24.1"
+ :group 'SQL)
+
;;; Variables which do not need customization
@@ -722,6 +1053,12 @@ Starts `sql-interactive-mode' after doing some setup."
;; Passwords are not kept in a history.
+(defvar sql-product-history nil
+ "History of products used.")
+
+(defvar sql-connection-history nil
+ "History of connections used.")
+
(defvar sql-buffer nil
"Current SQLi buffer.
@@ -741,11 +1078,33 @@ You can change `sql-prompt-regexp' on `sql-interactive-mode-hook'.")
You can change `sql-prompt-length' on `sql-interactive-mode-hook'.")
+(defvar sql-prompt-cont-regexp nil
+ "Prompt pattern of statement continuation prompts.")
+
(defvar sql-alternate-buffer-name nil
"Buffer-local string used to possibly rename the SQLi buffer.
Used by `sql-rename-buffer'.")
+(defun sql-buffer-live-p (buffer &optional product)
+ "Returns non-nil if the process associated with buffer is live.
+
+BUFFER can be a buffer object or a buffer name. The buffer must
+be a live buffer, have an running process attached to it, be in
+`sql-interactive-mode', and, if PRODUCT is specified, it's
+`sql-product' must match."
+
+ (when buffer
+ (setq buffer (get-buffer buffer))
+ (and buffer
+ (buffer-live-p buffer)
+ (get-buffer-process buffer)
+ (comint-check-proc buffer)
+ (with-current-buffer buffer
+ (and (derived-mode-p 'sql-interactive-mode)
+ (or (not product)
+ (eq product sql-product)))))))
+
;; Keymap for sql-interactive-mode.
(defvar sql-interactive-mode-map
@@ -761,6 +1120,8 @@ Used by `sql-rename-buffer'.")
(define-key map (kbd "O") 'sql-magic-go)
(define-key map (kbd "o") 'sql-magic-go)
(define-key map (kbd ";") 'sql-magic-semicolon)
+ (define-key map (kbd "C-c C-l a") 'sql-list-all)
+ (define-key map (kbd "C-c C-l t") 'sql-list-table)
map)
"Mode map used for `sql-interactive-mode'.
Based on `comint-mode-map'.")
@@ -773,6 +1134,9 @@ Based on `comint-mode-map'.")
(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)
+ (define-key map (kbd "C-c C-i") 'sql-product-interactive)
+ (define-key map (kbd "C-c C-l a") 'sql-list-all)
+ (define-key map (kbd "C-c C-l t") 'sql-list-table)
map)
"Mode map used for `sql-mode'.")
@@ -782,18 +1146,25 @@ Based on `comint-mode-map'.")
sql-mode-menu sql-mode-map
"Menu for `sql-mode'."
`("SQL"
- ["Send Paragraph" sql-send-paragraph (and (buffer-live-p sql-buffer)
- (get-buffer-process sql-buffer))]
- ["Send Region" sql-send-region (and (or (and (boundp 'mark-active); Emacs
- mark-active)
- (mark t)); XEmacs
- (buffer-live-p sql-buffer)
- (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)]
+ ["Send Paragraph" sql-send-paragraph (sql-buffer-live-p sql-buffer)]
+ ["Send Region" sql-send-region (and mark-active
+ (sql-buffer-live-p sql-buffer))]
+ ["Send Buffer" sql-send-buffer (sql-buffer-live-p sql-buffer)]
+ ["Send String" sql-send-string (sql-buffer-live-p sql-buffer)]
+ "--"
+ ["List all objects" sql-list-all (sql-buffer-live-p sql-buffer)]
+ ["List table details" sql-list-table (sql-buffer-live-p sql-buffer)]
+ "--"
+ ["Start SQLi session" sql-product-interactive
+ :visible (not sql-connection-alist)
+ :enable (sql-get-product-feature sql-product :sqli-comint-func)]
+ ("Start..."
+ :visible sql-connection-alist
+ :filter sql-connection-menu-filter
+ "--"
+ ["New SQLi Session" sql-product-interactive (sql-get-product-feature sql-product :sqli-comint-func)])
+ ["--"
+ :visible sql-connection-alist]
["Show SQLi buffer" sql-show-sqli-buffer t]
["Set SQLi buffer" sql-set-sqli-buffer t]
["Pop to SQLi buffer after send"
@@ -821,7 +1192,11 @@ Based on `comint-mode-map'.")
sql-interactive-mode-menu sql-interactive-mode-map
"Menu for `sql-interactive-mode'."
'("SQL"
- ["Rename Buffer" sql-rename-buffer t]))
+ ["Rename Buffer" sql-rename-buffer t]
+ ["Save Connection" sql-save-connection (not sql-connection)]
+ "--"
+ ["List all objects" sql-list-all t]
+ ["List table details" sql-list-table t]))
;; Abbreviations -- if you want more of them, define them in your
;; ~/.emacs file. Abbrevs have to be enabled in your ~/.emacs, too.
@@ -886,25 +1261,64 @@ 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")))
+;; While there are international and American standards for SQL, they
+;; are not followed closely, and most vendors offer significant
+;; capabilities beyond those defined in the standard specifications.
+
+;; SQL mode provides support for hilighting based on the product. In
+;; addition to hilighting the product keywords, any ANSI keywords not
+;; used by the product are also hilighted. This will help identify
+;; keywords that could be restricted in future versions of the product
+;; or might be a problem if ported to another product.
+
+;; To reduce the complexity and size of the regular expressions
+;; generated to match keywords, ANSI keywords are filtered out of
+;; product keywords if they are equivalent. To do this, we define a
+;; function `sql-font-lock-keywords-builder' that removes any keywords
+;; that are matched by the ANSI patterns and results in the same face
+;; being applied. For this to work properly, we must play some games
+;; with the execution and compile time behavior. This code is a
+;; little tricky but works properly.
+
+;; When defining the keywords for individual products you should
+;; include all of the keywords that you want matched. The filtering
+;; against the ANSI keywords will be automatic if you use the
+;; `sql-font-lock-keywords-builder' function and follow the
+;; implementation pattern used for the other products in this file.
-(defvar sql-mode-ansi-font-lock-keywords
- (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"
-))
+(eval-when-compile
+ (defvar sql-mode-ansi-font-lock-keywords)
+ (setq sql-mode-ansi-font-lock-keywords nil))
+
+(eval-and-compile
+ (defun sql-font-lock-keywords-builder (face boundaries &rest keywords)
+ "Generation of regexp matching any one of KEYWORDS."
+
+ (let ((bdy (or boundaries '("\\b" . "\\b")))
+ kwd)
+
+ ;; Remove keywords that are defined in ANSI
+ (setq kwd keywords)
+ (dolist (k keywords)
+ (catch 'next
+ (dolist (a sql-mode-ansi-font-lock-keywords)
+ (when (and (eq face (cdr a))
+ (eq (string-match (car a) k 0) 0)
+ (eq (match-end 0) (length k)))
+ (setq kwd (delq k kwd))
+ (throw 'next nil)))))
+
+ ;; Create a properly formed font-lock-keywords item
+ (cons (concat (car bdy)
+ (regexp-opt kwd t)
+ (cdr bdy))
+ face))))
- (ansi-non-reserved (sql-keywords-re
+(eval-when-compile
+ (setq sql-mode-ansi-font-lock-keywords
+ (list
+ ;; ANSI Non Reserved keywords
+ (sql-font-lock-keywords-builder 'font-lock-keyword-face nil
"ada" "asensitive" "assignment" "asymmetric" "atomic" "between"
"bitvar" "called" "catalog_name" "chain" "character_set_catalog"
"character_set_name" "character_set_schema" "checked" "class_origin"
@@ -932,9 +1346,9 @@ statement. The format of variable should be a valid
"trigger_name" "trigger_schema" "type" "uncommitted" "unnamed"
"user_defined_type_catalog" "user_defined_type_name"
"user_defined_type_schema"
-))
-
- (ansi-reserved (sql-keywords-re
+)
+ ;; ANSI Reserved keywords
+ (sql-font-lock-keywords-builder 'font-lock-keyword-face nil
"absolute" "action" "add" "admin" "after" "aggregate" "alias" "all"
"allocate" "alter" "and" "any" "are" "as" "asc" "assertion" "at"
"authorization" "before" "begin" "both" "breadth" "by" "call"
@@ -970,21 +1384,29 @@ statement. The format of variable should be a valid
"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
+ ;; ANSI Functions
+ (sql-font-lock-keywords-builder 'font-lock-builtin-face nil
+"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 Data Types
+ (sql-font-lock-keywords-builder 'font-lock-type-face nil
"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)))
+))))
+(defvar sql-mode-ansi-font-lock-keywords
+ (eval-when-compile sql-mode-ansi-font-lock-keywords)
"ANSI SQL keywords used by font-lock.
This variable is used by `sql-mode' and `sql-interactive-mode'. The
@@ -994,7 +1416,54 @@ 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-functions (sql-keywords-re
+ (eval-when-compile
+ (list
+ ;; Oracle SQL*Plus Commands
+ (cons
+ (concat
+ "^\\s-*\\(?:\\(?:" (regexp-opt '(
+"@" "@@" "accept" "append" "archive" "attribute" "break"
+"btitle" "change" "clear" "column" "connect" "copy" "define"
+"del" "describe" "disconnect" "edit" "execute" "exit" "get" "help"
+"host" "input" "list" "password" "pause" "print" "prompt" "recover"
+"remark" "repfooter" "repheader" "run" "save" "show" "shutdown"
+"spool" "start" "startup" "store" "timing" "ttitle" "undefine"
+"variable" "whenever"
+) t)
+
+ "\\)\\|"
+ "\\(?:compute\\s-+\\(?:avg\\|cou\\|min\\|max\\|num\\|sum\\|std\\|var\\)\\)\\|"
+ "\\(?:set\\s-+\\("
+
+ (regexp-opt
+ '("appi" "appinfo" "array" "arraysize" "auto" "autocommit"
+ "autop" "autoprint" "autorecovery" "autot" "autotrace" "blo"
+ "blockterminator" "buffer" "closecursor" "cmds" "cmdsep"
+ "colsep" "com" "compatibility" "con" "concat" "constraint"
+ "constraints" "copyc" "copycommit" "copytypecheck" "database"
+ "def" "define" "document" "echo" "editf" "editfile" "emb"
+ "embedded" "esc" "escape" "feed" "feedback" "flagger" "flu"
+ "flush" "hea" "heading" "heads" "headsep" "instance" "lin"
+ "linesize" "lobof" "loboffset" "logsource" "long" "longc"
+ "longchunksize" "maxdata" "newp" "newpage" "null" "num"
+ "numf" "numformat" "numwidth" "pages" "pagesize" "pau"
+ "pause" "recsep" "recsepchar" "role" "scan" "serveroutput"
+ "shift" "shiftinout" "show" "showmode" "space" "sqlbl"
+ "sqlblanklines" "sqlc" "sqlcase" "sqlco" "sqlcontinue" "sqln"
+ "sqlnumber" "sqlp" "sqlpluscompat" "sqlpluscompatibility"
+ "sqlpre" "sqlprefix" "sqlprompt" "sqlt" "sqlterminator"
+ "statement_id" "suf" "suffix" "tab" "term" "termout" "ti"
+ "time" "timi" "timing" "transaction" "trim" "trimout" "trims"
+ "trimspool" "truncate" "und" "underline" "ver" "verify" "wra"
+ "wrap")) "\\)\\)"
+
+ "\\)\\b.*"
+ )
+ 'font-lock-doc-face)
+ '("^\\s-*rem\\(?:ark\\)?\\>.*" . font-lock-comment-face)
+
+ ;; Oracle Functions
+ (sql-font-lock-keywords-builder 'font-lock-builtin-face nil
"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"
@@ -1025,9 +1494,9 @@ to add functions and PL/SQL keywords.")
"userenv" "var_pop" "var_samp" "variance" "vsize" "width_bucket" "xml"
"xmlagg" "xmlattribute" "xmlcolattval" "xmlconcat" "xmlelement"
"xmlforest" "xmlsequence" "xmltransform"
-))
-
- (oracle-keywords (sql-keywords-re
+)
+ ;; Oracle Keywords
+ (sql-font-lock-keywords-builder 'font-lock-keyword-face nil
"abort" "access" "accessed" "account" "activate" "add" "admin"
"advise" "after" "agent" "aggregate" "all" "allocate" "allow" "alter"
"always" "analyze" "ancillary" "and" "any" "apply" "archive"
@@ -1113,22 +1582,29 @@ to add functions and PL/SQL keywords.")
"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
+)
+ ;; Oracle Data Types
+ (sql-font-lock-keywords-builder 'font-lock-type-face nil
"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
+ ;; Oracle PL/SQL Attributes
+ (sql-font-lock-keywords-builder 'font-lock-builtin-face '("" . "\\b")
"%bulk_rowcount" "%found" "%isopen" "%notfound" "%rowcount" "%rowtype"
-"%type" "extend" "prior"
-))
+"%type"
+)
+
+ ;; Oracle PL/SQL Functions
+ (sql-font-lock-keywords-builder 'font-lock-builtin-face nil
+"extend" "prior"
+)
- (plsql-keywords (sql-keywords-re
+ ;; Oracle PL/SQL Keywords
+ (sql-font-lock-keywords-builder 'font-lock-keyword-face nil
"autonomous_transaction" "bulk" "char_base" "collect" "constant"
"cursor" "declare" "do" "elsif" "exception_init" "execute" "exit"
"extends" "false" "fetch" "forall" "goto" "hour" "if" "interface"
@@ -1136,14 +1612,16 @@ to add functions and PL/SQL keywords.")
"separate" "serially_reusable" "sql" "sqlcode" "sqlerrm" "subtype"
"the" "timezone_abbr" "timezone_hour" "timezone_minute"
"timezone_region" "true" "varrying" "while"
-))
+)
- (plsql-type (sql-keywords-re
+ ;; Oracle PL/SQL Data Types
+ (sql-font-lock-keywords-builder 'font-lock-type-face nil
"binary_integer" "boolean" "naturaln" "pls_integer" "positive"
"positiven" "record" "signtype" "string"
-))
+)
- (plsql-warning (sql-keywords-re
+ ;; Oracle PL/SQL Exceptions
+ (sql-font-lock-keywords-builder 'font-lock-warning-face nil
"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"
@@ -1151,55 +1629,7 @@ to 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"
-))
-
- (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"
-"host" "input" "list" "password" "pause" "print" "prompt" "recover"
-"remark" "repfooter" "repheader" "run" "save" "show" "shutdown"
-"spool" "start" "startup" "store" "timing" "ttitle" "undefine"
-"variable" "whenever"
-
-) t)
-
- "\\)\\|"
- "\\(compute\\s-+\\(avg\\|cou\\|min\\|max\\|num\\|sum\\|std\\|var\\)\\)\\|"
- "\\(set\\s-+\\(appi\\(nfo\\)?\\|array\\(size\\)?\\|"
- "auto\\(commit\\)?\\|autop\\(rint\\)?\\|autorecovery\\|"
- "autot\\(race\\)?\\|blo\\(ckterminator\\)?\\|cmds\\(ep\\)?\\|"
- "colsep\\|com\\(patibility\\)?\\|con\\(cat\\)?\\|"
- "copyc\\(ommit\\)?\\|copytypecheck\\|def\\(ine\\)?\\|"
- "describe\\|echo\\|editf\\(ile\\)?\\|emb\\(edded\\)?\\|"
- "esc\\(ape\\)?\\|feed\\(back\\)?\\|flagger\\|"
- "flu\\(sh\\)?\\|hea\\(ding\\)?\\|heads\\(ep\\)?\\|"
- "instance\\|lin\\(esize\\)?\\|lobof\\(fset\\)?\\|"
- "logsource\\|long\\|longc\\(hunksize\\)?\\|mark\\(up\\)?\\|"
- "newp\\(age\\)?\\|null\\|numf\\(ormat\\)?\\|"
- "num\\(width\\)?\\|pages\\(ize\\)?\\|pau\\(se\\)?\\|"
- "recsep\\|recsepchar\\|serverout\\(put\\)?\\|"
- "shift\\(inout\\)?\\|show\\(mode\\)?\\|"
- "sqlbl\\(anklines\\)?\\|sqlc\\(ase\\)?\\|"
- "sqlco\\(ntinue\\)?\\|sqln\\(umber\\)?\\|"
- "sqlpluscompat\\(ibility\\)?\\|sqlpre\\(fix\\)?\\|"
- "sqlp\\(rompt\\)?\\|sqlt\\(erminator\\)?\\|"
- "suf\\(fix\\)?\\|tab\\|term\\(out\\)?\\|ti\\(me\\)?\\|"
- "timi\\(ng\\)?\\|trim\\(out\\)?\\|trims\\(pool\\)?\\|"
- "und\\(erline\\)?\\|ver\\(ify\\)?\\|wra\\(p\\)?\\)\\)\\)"
- "\\b.*$"
- ))))
-
- `((,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.
@@ -1210,85 +1640,157 @@ 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 ((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"
+ (eval-when-compile
+ (list
+ ;; Postgres psql commands
+ '("^\\s-*\\\\.*$" . font-lock-doc-face)
+
+ ;; Postgres unreserved words but may have meaning
+ (sql-font-lock-keywords-builder 'font-lock-builtin-face nil "a"
+"abs" "absent" "according" "ada" "alias" "allocate" "are" "array_agg"
+"asensitive" "atomic" "attribute" "attributes" "avg" "base64"
+"bernoulli" "bit_length" "bitvar" "blob" "blocked" "bom" "breadth" "c"
+"call" "cardinality" "catalog_name" "ceil" "ceiling" "char_length"
+"character_length" "character_set_catalog" "character_set_name"
+"character_set_schema" "characters" "checked" "class_origin" "clob"
+"cobol" "collation" "collation_catalog" "collation_name"
+"collation_schema" "collect" "column_name" "columns"
+"command_function" "command_function_code" "completion" "condition"
+"condition_number" "connect" "connection_name" "constraint_catalog"
+"constraint_name" "constraint_schema" "constructor" "contains"
+"control" "convert" "corr" "corresponding" "count" "covar_pop"
+"covar_samp" "cube" "cume_dist" "current_default_transform_group"
+"current_path" "current_transform_group_for_type" "cursor_name"
+"datalink" "datetime_interval_code" "datetime_interval_precision" "db"
+"defined" "degree" "dense_rank" "depth" "deref" "derived" "describe"
+"descriptor" "destroy" "destructor" "deterministic" "diagnostics"
+"disconnect" "dispatch" "dlnewcopy" "dlpreviouscopy" "dlurlcomplete"
+"dlurlcompleteonly" "dlurlcompletewrite" "dlurlpath" "dlurlpathonly"
+"dlurlpathwrite" "dlurlscheme" "dlurlserver" "dlvalue" "dynamic"
+"dynamic_function" "dynamic_function_code" "element" "empty"
+"end-exec" "equals" "every" "exception" "exec" "existing" "exp" "file"
+"filter" "final" "first_value" "flag" "floor" "fortran" "found" "free"
+"fs" "fusion" "g" "general" "generated" "get" "go" "goto" "grouping"
+"hex" "hierarchy" "host" "id" "ignore" "implementation" "import"
+"indent" "indicator" "infix" "initialize" "instance" "instantiable"
+"integrity" "intersection" "iterate" "k" "key_member" "key_type" "lag"
+"last_value" "lateral" "lead" "length" "less" "library" "like_regex"
+"link" "ln" "locator" "lower" "m" "map" "matched" "max"
+"max_cardinality" "member" "merge" "message_length"
+"message_octet_length" "message_text" "method" "min" "mod" "modifies"
+"modify" "module" "more" "multiset" "mumps" "namespace" "nclob"
+"nesting" "new" "nfc" "nfd" "nfkc" "nfkd" "nil" "normalize"
+"normalized" "nth_value" "ntile" "nullable" "number"
+"occurrences_regex" "octet_length" "octets" "old" "open" "operation"
+"ordering" "ordinality" "others" "output" "overriding" "p" "pad"
+"parameter" "parameter_mode" "parameter_name"
+"parameter_ordinal_position" "parameter_specific_catalog"
+"parameter_specific_name" "parameter_specific_schema" "parameters"
+"pascal" "passing" "passthrough" "percent_rank" "percentile_cont"
+"percentile_disc" "permission" "pli" "position_regex" "postfix"
+"power" "prefix" "preorder" "public" "rank" "reads" "recovery" "ref"
+"referencing" "regr_avgx" "regr_avgy" "regr_count" "regr_intercept"
+"regr_r2" "regr_slope" "regr_sxx" "regr_sxy" "regr_syy" "requiring"
+"respect" "restore" "result" "return" "returned_cardinality"
+"returned_length" "returned_octet_length" "returned_sqlstate" "rollup"
+"routine" "routine_catalog" "routine_name" "routine_schema"
+"row_count" "row_number" "scale" "schema_name" "scope" "scope_catalog"
+"scope_name" "scope_schema" "section" "selective" "self" "sensitive"
+"server_name" "sets" "size" "source" "space" "specific"
+"specific_name" "specifictype" "sql" "sqlcode" "sqlerror"
+"sqlexception" "sqlstate" "sqlwarning" "sqrt" "state" "static"
+"stddev_pop" "stddev_samp" "structure" "style" "subclass_origin"
+"sublist" "submultiset" "substring_regex" "sum" "system_user" "t"
+"table_name" "tablesample" "terminate" "than" "ties" "timezone_hour"
+"timezone_minute" "token" "top_level_count" "transaction_active"
+"transactions_committed" "transactions_rolled_back" "transform"
+"transforms" "translate" "translate_regex" "translation"
+"trigger_catalog" "trigger_name" "trigger_schema" "trim_array"
+"uescape" "under" "unlink" "unnamed" "unnest" "untyped" "upper" "uri"
+"usage" "user_defined_type_catalog" "user_defined_type_code"
+"user_defined_type_name" "user_defined_type_schema" "var_pop"
+"var_samp" "varbinary" "variable" "whenever" "width_bucket" "within"
+"xmlagg" "xmlbinary" "xmlcast" "xmlcomment" "xmldeclaration"
+"xmldocument" "xmlexists" "xmliterate" "xmlnamespaces" "xmlquery"
+"xmlschema" "xmltable" "xmltext" "xmlvalidate"
+)
+
+ ;; Postgres non-reserved words
+ (sql-font-lock-keywords-builder 'font-lock-builtin-face nil
+"abort" "absolute" "access" "action" "add" "admin" "after" "aggregate"
+"also" "alter" "always" "assertion" "assignment" "at" "backward"
+"before" "begin" "between" "by" "cache" "called" "cascade" "cascaded"
+"catalog" "chain" "characteristics" "checkpoint" "class" "close"
+"cluster" "coalesce" "comment" "comments" "commit" "committed"
+"configuration" "connection" "constraints" "content" "continue"
+"conversion" "copy" "cost" "createdb" "createrole" "createuser" "csv"
+"current" "cursor" "cycle" "data" "database" "day" "deallocate" "dec"
+"declare" "defaults" "deferred" "definer" "delete" "delimiter"
+"delimiters" "dictionary" "disable" "discard" "document" "domain"
+"drop" "each" "enable" "encoding" "encrypted" "enum" "escape"
+"exclude" "excluding" "exclusive" "execute" "exists" "explain"
+"external" "extract" "family" "first" "float" "following" "force"
+"forward" "function" "functions" "global" "granted" "greatest"
+"handler" "header" "hold" "hour" "identity" "if" "immediate"
+"immutable" "implicit" "including" "increment" "index" "indexes"
+"inherit" "inherits" "inline" "inout" "input" "insensitive" "insert"
+"instead" "invoker" "isolation" "key" "language" "large" "last"
+"lc_collate" "lc_ctype" "least" "level" "listen" "load" "local"
+"location" "lock" "login" "mapping" "match" "maxvalue" "minute"
+"minvalue" "mode" "month" "move" "name" "names" "national" "nchar"
+"next" "no" "nocreatedb" "nocreaterole" "nocreateuser" "noinherit"
+"nologin" "none" "nosuperuser" "nothing" "notify" "nowait" "nullif"
+"nulls" "object" "of" "oids" "operator" "option" "options" "out"
+"overlay" "owned" "owner" "parser" "partial" "partition" "password"
+"plans" "position" "preceding" "prepare" "prepared" "preserve" "prior"
+"privileges" "procedural" "procedure" "quote" "range" "read"
+"reassign" "recheck" "recursive" "reindex" "relative" "release"
+"rename" "repeatable" "replace" "replica" "reset" "restart" "restrict"
+"returns" "revoke" "role" "rollback" "row" "rows" "rule" "savepoint"
+"schema" "scroll" "search" "second" "security" "sequence" "sequences"
+"serializable" "server" "session" "set" "setof" "share" "show"
+"simple" "stable" "standalone" "start" "statement" "statistics"
+"stdin" "stdout" "storage" "strict" "strip" "substring" "superuser"
+"sysid" "system" "tables" "tablespace" "temp" "template" "temporary"
+"transaction" "treat" "trigger" "trim" "truncate" "trusted" "type"
+"unbounded" "uncommitted" "unencrypted" "unknown" "unlisten" "until"
+"update" "vacuum" "valid" "validator" "value" "values" "version"
+"view" "volatile" "whitespace" "work" "wrapper" "write"
+"xmlattributes" "xmlconcat" "xmlelement" "xmlforest" "xmlparse"
+"xmlpi" "xmlroot" "xmlserialize" "year" "yes"
+)
+
+ ;; Postgres Reserved
+ (sql-font-lock-keywords-builder 'font-lock-keyword-face nil
+"all" "analyse" "analyze" "and" "any" "array" "asc" "as" "asymmetric"
+"authorization" "binary" "both" "case" "cast" "check" "collate"
+"column" "concurrently" "constraint" "create" "cross"
+"current_catalog" "current_date" "current_role" "current_schema"
+"current_time" "current_timestamp" "current_user" "default"
+"deferrable" "desc" "distinct" "do" "else" "end" "except" "false"
+"fetch" "foreign" "for" "freeze" "from" "full" "grant" "group"
+"having" "ilike" "initially" "inner" "in" "intersect" "into" "isnull"
+"is" "join" "leading" "left" "like" "limit" "localtime"
+"localtimestamp" "natural" "notnull" "not" "null" "off" "offset"
+"only" "on" "order" "or" "outer" "overlaps" "over" "placing" "primary"
+"references" "returning" "right" "select" "session_user" "similar"
+"some" "symmetric" "table" "then" "to" "trailing" "true" "union"
+"unique" "user" "using" "variadic" "verbose" "when" "where" "window"
+"with"
+)
+
+ ;; Postgres Data Types
+ (sql-font-lock-keywords-builder 'font-lock-type-face nil
+"bigint" "bigserial" "bit" "bool" "boolean" "box" "bytea" "char"
+"character" "cidr" "circle" "date" "decimal" "double" "float4"
+"float8" "inet" "int" "int2" "int4" "int8" "integer" "interval" "line"
+"lseg" "macaddr" "money" "numeric" "path" "point" "polygon"
+"precision" "real" "serial" "serial4" "serial8" "smallint" "text"
+"time" "timestamp" "timestamptz" "timetz" "tsquery" "tsvector"
+"txid_snapshot" "uuid" "varbit" "varchar" "varying" "without"
+"xml" "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.
This variable is used by `sql-mode' and `sql-interactive-mode'. The
@@ -1297,7 +1799,10 @@ 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 (sql-keywords-re
+ (eval-when-compile
+ (list
+ ;; Linter Keywords
+ (sql-font-lock-keywords-builder 'font-lock-keyword-face nil
"autocommit" "autoinc" "autorowid" "cancel" "cascade" "channel"
"committed" "count" "countblob" "cross" "current" "data" "database"
"datafile" "datafiles" "datesplit" "dba" "dbname" "default" "deferred"
@@ -1322,9 +1827,10 @@ 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"
-))
+)
- (linter-reserved (sql-keywords-re
+ ;; Linter Reserved
+ (sql-font-lock-keywords-builder 'font-lock-keyword-face nil
"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"
@@ -1342,16 +1848,10 @@ 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"
-))
+)
- (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"
-))
-
- (linter-functions (sql-keywords-re
+ ;; Linter Functions
+ (sql-font-lock-keywords-builder 'font-lock-builtin-face nil
"abs" "acos" "asin" "atan" "atan2" "avg" "ceil" "cos" "cosh" "divtime"
"exp" "floor" "getbits" "getblob" "getbyte" "getlong" "getraw"
"getstr" "gettext" "getword" "hextoraw" "lenblob" "length" "log"
@@ -1362,12 +1862,15 @@ 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"
-)))
+)
- `((,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 Data Types
+ (sql-font-lock-keywords-builder 'font-lock-type-face nil
+"bigint" "bitmap" "blob" "boolean" "char" "character" "date"
+"datetime" "dec" "decimal" "double" "float" "int" "integer" "nchar"
+"number" "numeric" "real" "smallint" "varbyte" "varchar" "byte"
+"cursor" "long"
+)))
"Linter SQL keywords used by font-lock.
@@ -1376,7 +1879,29 @@ regular expressions are created during compilation by calling the
function `regexp-opt'.")
(defvar sql-mode-ms-font-lock-keywords
- (let ((ms-reserved (sql-keywords-re
+ (eval-when-compile
+ (list
+ ;; MS isql/osql Commands
+ (cons
+ (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"
+"offsets" "quoted_identifier" "arithabort" "arithignore" "fmtonly"
+"nocount" "noexec" "numeric_roundabort" "parseonly"
+"query_governor_cost_limit" "rowcount" "textsize" "ansi_defaults"
+"ansi_null_dflt_off" "ansi_null_dflt_on" "ansi_nulls" "ansi_padding"
+"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-+\\).*$")
+ 'font-lock-doc-face)
+
+ ;; MS Reserved
+ (sql-font-lock-keywords-builder 'font-lock-keyword-face nil
"absolute" "add" "all" "alter" "and" "any" "as" "asc" "authorization"
"avg" "backup" "begin" "between" "break" "browse" "bulk" "by"
"cascade" "case" "check" "checkpoint" "close" "clustered" "coalesce"
@@ -1409,19 +1934,10 @@ function `regexp-opt'.")
"updlock" "use" "user" "values" "view" "waitfor" "when" "where"
"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"
-))
-
- (ms-vars "\\b@[a-zA-Z0-9_]*\\b")
-
- (ms-functions (sql-keywords-re
+ ;; MS Functions
+ (sql-font-lock-keywords-builder 'font-lock-builtin-face nil
"@@connections" "@@cpu_busy" "@@cursor_rows" "@@datefirst" "@@dbts"
"@@error" "@@fetch_status" "@@identity" "@@idle" "@@io_busy"
"@@langid" "@@language" "@@lock_timeout" "@@max_connections"
@@ -1450,30 +1966,19 @@ 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"
-))
+)
- (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"
-"offsets" "quoted_identifier" "arithabort" "arithignore" "fmtonly"
-"nocount" "noexec" "numeric_roundabort" "parseonly"
-"query_governor_cost_limit" "rowcount" "textsize" "ansi_defaults"
-"ansi_null_dflt_off" "ansi_null_dflt_on" "ansi_nulls" "ansi_padding"
-"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-+\\).*$"))))
+ ;; MS Variables
+ '("\\b@[a-zA-Z0-9_]*\\b" . font-lock-variable-name-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)))
+ ;; MS Types
+ (sql-font-lock-keywords-builder 'font-lock-type-face nil
+"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"
+)))
"Microsoft SQLServer SQL keywords used by font-lock.
@@ -1523,7 +2028,10 @@ 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
- (let ((mysql-funcs (sql-keywords-re
+ (eval-when-compile
+ (list
+ ;; MySQL Functions
+ (sql-font-lock-keywords-builder 'font-lock-builtin-face nil
"ascii" "avg" "bdmpolyfromtext" "bdmpolyfromwkb" "bdpolyfromtext"
"bdpolyfromwkb" "benchmark" "bin" "bit_and" "bit_length" "bit_or"
"bit_xor" "both" "cast" "char_length" "character_length" "coalesce"
@@ -1546,9 +2054,10 @@ you define your own `sql-mode-solid-font-lock-keywords'.")
"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
+ ;; MySQL Keywords
+ (sql-font-lock-keywords-builder 'font-lock-keyword-face nil
"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"
@@ -1574,9 +2083,10 @@ you define your own `sql-mode-solid-font-lock-keywords'.")
"then" "to" "transaction" "truncate" "type" "uncommitted" "union"
"unique" "unlock" "update" "use" "using" "values" "when" "where"
"with" "write" "xor"
-))
+)
- (mysql-types (sql-keywords-re
+ ;; MySQL Data Types
+ (sql-font-lock-keywords-builder 'font-lock-type-face nil
"bigint" "binary" "bit" "blob" "bool" "boolean" "char" "curve" "date"
"datetime" "dec" "decimal" "double" "enum" "fixed" "float" "geometry"
"geometrycollection" "int" "integer" "line" "linearring" "linestring"
@@ -1588,10 +2098,6 @@ you define your own `sql-mode-solid-font-lock-keywords'.")
"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
@@ -1599,7 +2105,54 @@ 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 nil
+(defvar sql-mode-sqlite-font-lock-keywords
+ (eval-when-compile
+ (list
+ ;; SQLite commands
+ '("^[.].*$" . font-lock-doc-face)
+
+ ;; SQLite Keyword
+ (sql-font-lock-keywords-builder 'font-lock-keyword-face nil
+"abort" "action" "add" "after" "all" "alter" "analyze" "and" "as"
+"asc" "attach" "autoincrement" "before" "begin" "between" "by"
+"cascade" "case" "cast" "check" "collate" "column" "commit" "conflict"
+"constraint" "create" "cross" "database" "default" "deferrable"
+"deferred" "delete" "desc" "detach" "distinct" "drop" "each" "else"
+"end" "escape" "except" "exclusive" "exists" "explain" "fail" "for"
+"foreign" "from" "full" "glob" "group" "having" "if" "ignore"
+"immediate" "in" "index" "indexed" "initially" "inner" "insert"
+"instead" "intersect" "into" "is" "isnull" "join" "key" "left" "like"
+"limit" "match" "natural" "no" "not" "notnull" "null" "of" "offset"
+"on" "or" "order" "outer" "plan" "pragma" "primary" "query" "raise"
+"references" "regexp" "reindex" "release" "rename" "replace"
+"restrict" "right" "rollback" "row" "savepoint" "select" "set" "table"
+"temp" "temporary" "then" "to" "transaction" "trigger" "union"
+"unique" "update" "using" "vacuum" "values" "view" "virtual" "when"
+"where"
+)
+ ;; SQLite Data types
+ (sql-font-lock-keywords-builder 'font-lock-type-face nil
+"int" "integer" "tinyint" "smallint" "mediumint" "bigint" "unsigned"
+"big" "int2" "int8" "character" "varchar" "varying" "nchar" "native"
+"nvarchar" "text" "clob" "blob" "real" "double" "precision" "float"
+"numeric" "number" "decimal" "boolean" "date" "datetime"
+)
+ ;; SQLite Functions
+ (sql-font-lock-keywords-builder 'font-lock-builtin-face nil
+;; Core functions
+"abs" "changes" "coalesce" "glob" "ifnull" "hex" "last_insert_rowid"
+"length" "like" "load_extension" "lower" "ltrim" "max" "min" "nullif"
+"quote" "random" "randomblob" "replace" "round" "rtrim" "soundex"
+"sqlite_compileoption_get" "sqlite_compileoption_used"
+"sqlite_source_id" "sqlite_version" "substr" "total_changes" "trim"
+"typeof" "upper" "zeroblob"
+;; Date/time functions
+"time" "julianday" "strftime"
+"current_date" "current_time" "current_timestamp"
+;; Aggregate functions
+"avg" "count" "group_concat" "max" "min" "sum" "total"
+)))
+
"SQLite SQL keywords used by font-lock.
This variable is used by `sql-mode' and `sql-interactive-mode'. The
@@ -1626,45 +2179,149 @@ highlighting rules in SQL mode.")
;;; SQL Product support functions
-(defun sql-product-feature (feature &optional product)
- "Lookup `feature' needed to support the current SQL product.
+(defun sql-read-product (prompt &optional initial)
+ "Read a valid SQL product."
+ (let ((init (or (and initial (symbol-name initial)) "ansi")))
+ (intern (completing-read
+ prompt
+ (mapcar (lambda (info) (symbol-name (car info)))
+ sql-product-alist)
+ nil 'require-match
+ init 'sql-product-history init))))
+
+(defun sql-add-product (product display &rest plist)
+ "Add support for a database product in `sql-mode'.
+
+Add PRODUCT to `sql-product-alist' which enables `sql-mode' to
+properly support syntax highlighting and interactive interaction.
+DISPLAY is the name of the SQL product that will appear in the
+menu bar and in messages. PLIST initializes the product
+configuration."
+
+ ;; Don't do anything if the product is already supported
+ (if (assoc product sql-product-alist)
+ (message "Product `%s' is already defined" product)
+
+ ;; Add product to the alist
+ (add-to-list 'sql-product-alist `((,product :name ,display . ,plist)))
+ ;; Add a menu item to the SQL->Product menu
+ (easy-menu-add-item sql-mode-menu '("Product")
+ ;; Each product is represented by a radio
+ ;; button with it's display name.
+ `[,display
+ (sql-set-product ',product)
+ :style radio
+ :selected (eq sql-product ',product)]
+ ;; Maintain the product list in
+ ;; (case-insensitive) alphabetic order of the
+ ;; display names. Loop thru each keymap item
+ ;; looking for an item whose display name is
+ ;; after this product's name.
+ (let ((next-item)
+ (down-display (downcase display)))
+ (map-keymap (lambda (k b)
+ (when (and (not next-item)
+ (string-lessp down-display
+ (downcase (cadr b))))
+ (setq next-item k)))
+ (easy-menu-get-map sql-mode-menu '("Product")))
+ next-item))
+ product))
+
+(defun sql-del-product (product)
+ "Remove support for PRODUCT in `sql-mode'."
+
+ ;; Remove the menu item based on the display name
+ (easy-menu-remove-item sql-mode-menu '("Product") (sql-get-product-feature product :name))
+ ;; Remove the product alist item
+ (setq sql-product-alist (assq-delete-all product sql-product-alist))
+ nil)
+
+(defun sql-set-product-feature (product feature newvalue)
+ "Set FEATURE of database PRODUCT to NEWVALUE.
+
+The PRODUCT must be a symbol which identifies the database
+product. The product must have already exist on the product
+list. See `sql-add-product' to add new products. The FEATURE
+argument must be a plist keyword accepted by
+`sql-product-alist'."
+
+ (let* ((p (assoc product sql-product-alist))
+ (v (plist-get (cdr p) feature)))
+ (if p
+ (if (and
+ (member feature sql-indirect-features)
+ (symbolp v))
+ (set v newvalue)
+ (setcdr p (plist-put (cdr p) feature newvalue)))
+ (message "`%s' is not a known product; use `sql-add-product' to add it first." product))))
+
+(defun sql-get-product-feature (product feature &optional fallback not-indirect)
+ "Lookup FEATURE associated with a SQL PRODUCT.
+
+If the FEATURE is nil for PRODUCT, and FALLBACK is specified,
+then the FEATURE associated with the FALLBACK product is
+returned.
+
+If the FEATURE is in the list `sql-indirect-features', and the
+NOT-INDIRECT parameter is not set, then the value of the symbol
+stored in the connect alist is returned.
See `sql-product-alist' for a list of products and supported features."
- (plist-get
- (cdr (assoc (or product sql-product)
- sql-product-alist))
- feature))
+ (let* ((p (assoc product sql-product-alist))
+ (v (plist-get (cdr p) feature)))
+
+ (if p
+ ;; If no value and fallback, lookup feature for fallback
+ (if (and (not v)
+ fallback
+ (not (eq product fallback)))
+ (sql-get-product-feature fallback feature)
+
+ (if (and
+ (member feature sql-indirect-features)
+ (not not-indirect)
+ (symbolp v))
+ (symbol-value v)
+ v))
+ (message "`%s' is not a known product; use `sql-add-product' to add it first." product)
+ nil)))
(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-alist'."
+ "Configure font-lock and imenu with product-specific settings.
+
+The KEYWORDS-ONLY flag is passed to font-lock to specify whether
+only keywords should be hilighted and syntactic hilighting
+skipped. The IMENU flag indicates whether `imenu-mode' should
+also be configured."
+
(let
;; Get the product-specific syntax-alist.
((syntax-alist
(append
- (sql-product-feature :syntax-alist)
+ (sql-get-product-feature sql-product :syntax-alist)
'((?_ . "w") (?. . "w")))))
;; Get the product-specific keywords.
(setq sql-mode-font-lock-keywords
(append
(unless (eq sql-product 'ansi)
- (eval (sql-product-feature :font-lock)))
+ (sql-get-product-feature sql-product :font-lock))
;; Always highlight ANSI keywords
- (eval (sql-product-feature :font-lock 'ansi))
+ (sql-get-product-feature 'ansi :font-lock)
;; Fontify object names in CREATE, DROP and ALTER DDL
;; statements
(list sql-mode-font-lock-object-name)))
;; Setup font-lock. Force re-parsing of `font-lock-defaults'.
- (set (make-local-variable 'font-lock-set-defaults) nil)
+ (kill-local-variable 'font-lock-set-defaults)
(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)
+ (boundp 'font-lock-mode)
font-lock-mode)
(font-lock-mode-internal nil)
(font-lock-mode-internal t))
@@ -1681,13 +2338,13 @@ the product-specific keywords and syntax-alists defined in
;; Setup imenu; it needs the same syntax-alist.
(when imenu
- (setq imenu-syntax-alist syntax-alist))))
+ (setq imenu-syntax-alist syntax-alist))))
;;;###autoload
(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
+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
@@ -1703,36 +2360,48 @@ For example:
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
+ (let* ((sql-indirect-features nil)
+ (font-lock-var (sql-get-product-feature product :font-lock))
+ (old-val))
+
+ (setq old-val (symbol-value font-lock-var))
+ (set font-lock-var
(if (eq append 'set)
keywords
(if append
- (append old keywords)
- (append keywords old))))))
+ (append old-val keywords)
+ (append keywords old-val))))))
+
+(defun sql-for-each-login (login-params body)
+ "Iterates through login parameters and returns a list of results."
+
+ (delq nil
+ (mapcar
+ (lambda (param)
+ (let ((token (or (and (listp param) (car param)) param))
+ (plist (or (and (listp param) (cdr param)) nil)))
+
+ (funcall body token plist)))
+ login-params)))
;;; Functions to switch highlighting
(defun sql-highlight-product ()
- "Turn on the appropriate font highlighting for the SQL product selected."
+ "Turn on the font highlighting for the SQL product selected."
(when (derived-mode-p 'sql-mode)
;; Setup font-lock
(sql-product-font-lock nil t)
;; Set the mode name to include the product.
- (setq mode-name (concat "SQL[" (prin1-to-string sql-product) "]"))))
+ (setq mode-name (concat "SQL[" (or (sql-get-product-feature sql-product :name)
+ (symbol-name sql-product)) "]"))))
(defun sql-set-product (product)
- "Set `sql-product' to product and enable appropriate highlighting."
+ "Set `sql-product' to PRODUCT and enable appropriate highlighting."
(interactive
- (list (completing-read "Enter SQL product: "
- (mapcar (lambda (info) (symbol-name (car info)))
- sql-product-alist)
- nil 'require-match)))
+ (list (sql-read-product "SQL product: ")))
(if (stringp product) (setq product (intern product)))
(when (not (assoc product sql-product-alist))
(error "SQL product %s is not supported; treated as ANSI" product)
@@ -1784,6 +2453,30 @@ the regular expression `comint-prompt-regexp', a buffer local variable."
(newline))
(indent-according-to-mode))
+(defun sql-help-list-products (indent freep)
+ "Generate listing of products available for use under SQLi.
+
+List products with :free-softare attribute set to FREEP. Indent
+each line with INDENT."
+
+ (let (sqli-func doc)
+ (setq doc "")
+ (dolist (p sql-product-alist)
+ (setq sqli-func (intern (concat "sql-" (symbol-name (car p)))))
+
+ (if (and (fboundp sqli-func)
+ (eq (sql-get-product-feature (car p) :free-software) freep))
+ (setq doc
+ (concat doc
+ indent
+ (or (sql-get-product-feature (car p) :name)
+ (symbol-name (car p)))
+ ":\t"
+ "\\["
+ (symbol-name sqli-func)
+ "]\n"))))
+ doc))
+
;;;###autoload
(defun sql-help ()
"Show short help for the SQL modes.
@@ -1793,24 +2486,17 @@ usually named `*SQL*'. The name of the major mode is SQLi.
Use the following commands to start a specific SQL interpreter:
- PostGres: \\[sql-postgres]
- MySQL: \\[sql-mysql]
- SQLite: \\[sql-sqlite]
+ \\\\FREE
Other non-free SQL implementations are also supported:
- Solid: \\[sql-solid]
- Oracle: \\[sql-oracle]
- Informix: \\[sql-informix]
- Sybase: \\[sql-sybase]
- Ingres: \\[sql-ingres]
- Microsoft: \\[sql-ms]
- DB2: \\[sql-db2]
- Interbase: \\[sql-interbase]
- Linter: \\[sql-linter]
+ \\\\NONFREE
But we urge you to choose a free implementation instead of these.
+You can also use \\[sql-product-interactive] to invoke the
+interpreter for the current `sql-product'.
+
Once you have the SQLi buffer, you can enter SQL statements in the
buffer. The output generated is appended to the buffer and a new prompt
is generated. See the In/Out menu in the SQLi buffer for some functions
@@ -1825,12 +2511,84 @@ In this SQL buffer (SQL mode), you can send the region or the entire
buffer to the interactive SQL buffer (SQLi mode). The results are
appended to the SQLi buffer without disturbing your SQL buffer."
(interactive)
+
+ ;; Insert references to loaded products into the help buffer string
+ (let ((doc (documentation 'sql-help t))
+ changedp)
+ (setq changedp nil)
+
+ ;; Insert FREE software list
+ (when (string-match "^\\(\\s-*\\)[\\\\][\\\\]FREE\\s-*\n" doc 0)
+ (setq doc (replace-match (sql-help-list-products (match-string 1 doc) t)
+ t t doc 0)
+ changedp t))
+
+ ;; Insert non-FREE software list
+ (when (string-match "^\\(\\s-*\\)[\\\\][\\\\]NONFREE\\s-*\n" doc 0)
+ (setq doc (replace-match (sql-help-list-products (match-string 1 doc) nil)
+ t t doc 0)
+ changedp t))
+
+ ;; If we changed the help text, save the change so that the help
+ ;; sub-system will see it
+ (when changedp
+ (put 'sql-help 'function-documentation doc)))
+
+ ;; Call help on this function
(describe-function 'sql-help))
(defun sql-read-passwd (prompt &optional default)
"Read a password using PROMPT. Optional DEFAULT is password to start with."
(read-passwd prompt nil default))
+(defun sql-get-login-ext (prompt last-value history-var plist)
+ "Prompt user with extended login parameters.
+
+If PLIST is nil, then the user is simply prompted for a string
+value.
+
+The property `:default' specifies the default value. If the
+`:number' property is non-nil then ask for a number.
+
+The `:file' property prompts for a file name that must match the
+regexp pattern specified in its value.
+
+The `:completion' property prompts for a string specified by its
+value. (The property value is used as the PREDICATE argument to
+`completing-read'.)"
+ (let* ((default (plist-get plist :default))
+ (prompt-def
+ (if 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))
+ prompt))
+ (use-dialog-box nil))
+ (cond
+ ((plist-member plist :file)
+ (expand-file-name
+ (read-file-name prompt
+ (file-name-directory last-value) default t
+ (file-name-nondirectory last-value)
+ (when (plist-get plist :file)
+ `(lambda (f)
+ (string-match
+ (concat "\\<" ,(plist-get plist :file) "\\>")
+ (file-name-nondirectory f)))))))
+
+ ((plist-member plist :completion)
+ (completing-read prompt-def (plist-get plist :completion) nil t
+ last-value history-var default))
+
+ ((plist-get plist :number)
+ (read-number prompt (or default last-value 0)))
+
+ (t
+ (let ((r (read-from-minibuffer prompt-def last-value nil nil history-var nil)))
+ (if (string= "" r) (or default "") r))))))
+
(defun sql-get-login (&rest what)
"Get username, password and database from the user.
@@ -1840,55 +2598,77 @@ Usernames, servers and databases are stored in `sql-user-history',
`sql-server-history' and `database-history'. Passwords are not stored
in a history.
-Parameter WHAT is a list of the arguments passed to this function.
-The function asks for the username if WHAT contains symbol `user', for
-the password if it contains symbol `password', for the server if it
-contains symbol `server', and for the database if it contains symbol
-`database'. The members of WHAT are processed in the order in which
-they are provided.
+Parameter WHAT is a list of tokens passed as arguments in the
+function call. The function asks for the username if WHAT
+contains the symbol `user', for the password if it contains the
+symbol `password', for the server if it contains the symbol
+`server', and for the database if it contains the symbol
+`database'. The members of WHAT are processed in the order in
+which they are provided.
+
+Each token may also be a list with the token in the car and a
+plist of options as the cdr. The following properties are
+supported:
+
+ :file <filename-regexp>
+ :completion <list-of-strings-or-function>
+ :default <default-value>
+ :number t
In order to ask the user for username, password and database, call the
function like this: (sql-get-login 'user 'password 'database)."
(interactive)
- (while what
- (cond
- ((eq (car what) 'user) ; user
- (setq sql-user
- (read-from-minibuffer "User: " sql-user nil nil
- sql-user-history)))
- ((eq (car what) 'password) ; password
- (setq sql-password
- (sql-read-passwd "Password: " sql-password)))
- ((eq (car what) 'server) ; server
- (setq sql-server
- (read-from-minibuffer "Server: " sql-server nil nil
- sql-server-history)))
- ((eq (car what) 'database) ; database
- (setq sql-database
- (read-from-minibuffer "Database: " sql-database nil nil
- sql-database-history))))
- (setq what (cdr what))))
-
-(defun sql-find-sqli-buffer ()
- "Return the current default SQLi buffer or nil.
-In order to qualify, the SQLi buffer must be alive,
-be in `sql-interactive-mode' and have a process."
- (let ((default-buffer (default-value 'sql-buffer)))
- (if (and (buffer-live-p default-buffer)
- (get-buffer-process default-buffer))
- default-buffer
- (save-current-buffer
- (let ((buflist (buffer-list))
- (found))
- (while (not (or (null buflist)
- found))
- (let ((candidate (car buflist)))
- (set-buffer candidate)
- (if (and (derived-mode-p 'sql-interactive-mode)
- (get-buffer-process candidate))
- (setq found candidate))
- (setq buflist (cdr buflist))))
- found)))))
+ (mapcar
+ (lambda (w)
+ (let ((token (or (and (consp w) (car w)) w))
+ (plist (or (and (consp w) (cdr w)) nil)))
+
+ (cond
+ ((eq token 'user) ; user
+ (setq sql-user
+ (sql-get-login-ext "User: " sql-user
+ 'sql-user-history plist)))
+
+ ((eq token 'password) ; password
+ (setq sql-password
+ (sql-read-passwd "Password: " sql-password)))
+
+ ((eq token 'server) ; server
+ (setq sql-server
+ (sql-get-login-ext "Server: " sql-server
+ 'sql-server-history plist)))
+
+ ((eq token 'database) ; database
+ (setq sql-database
+ (sql-get-login-ext "Database: " sql-database
+ 'sql-database-history plist)))
+
+ ((eq token 'port) ; port
+ (setq sql-port
+ (sql-get-login-ext "Port: " sql-port
+ nil (append '(:number t) plist)))))))
+ what))
+
+(defun sql-find-sqli-buffer (&optional product)
+ "Returns the name of the current default SQLi buffer or nil.
+In order to qualify, the SQLi buffer must be alive, be in
+`sql-interactive-mode' and have a process."
+ (let ((buf sql-buffer)
+ (prod (or product sql-product)))
+ (or
+ ;; Current sql-buffer, if there is one.
+ (and (sql-buffer-live-p buf prod)
+ buf)
+ ;; Global sql-buffer
+ (and (setq buf (default-value 'sql-buffer))
+ (sql-buffer-live-p buf prod)
+ buf)
+ ;; Look thru each buffer
+ (car (apply 'append
+ (mapcar (lambda (b)
+ (and (sql-buffer-live-p b prod)
+ (list (buffer-name b))))
+ (buffer-list)))))))
(defun sql-set-sqli-buffer-generally ()
"Set SQLi buffer for all SQL buffers that have none.
@@ -1900,16 +2680,17 @@ using `sql-find-sqli-buffer'. If `sql-buffer' is set,
(interactive)
(save-excursion
(let ((buflist (buffer-list))
- (default-sqli-buffer (sql-find-sqli-buffer)))
- (setq-default sql-buffer default-sqli-buffer)
+ (default-buffer (sql-find-sqli-buffer)))
+ (setq-default sql-buffer default-buffer)
(while (not (null buflist))
(let ((candidate (car buflist)))
(set-buffer candidate)
(if (and (derived-mode-p 'sql-mode)
- (not (buffer-live-p sql-buffer)))
+ (not (sql-buffer-live-p sql-buffer)))
(progn
- (setq sql-buffer default-sqli-buffer)
- (run-hooks 'sql-set-sqli-hook))))
+ (setq sql-buffer default-buffer)
+ (when default-buffer
+ (run-hooks 'sql-set-sqli-hook)))))
(setq buflist (cdr buflist))))))
(defun sql-set-sqli-buffer ()
@@ -1927,19 +2708,13 @@ If you call it from anywhere else, it sets the global copy of
(interactive)
(let ((default-buffer (sql-find-sqli-buffer)))
(if (null default-buffer)
- (error "There is no suitable SQLi buffer"))
- (let ((new-buffer
- (get-buffer
- (read-buffer "New SQLi buffer: " default-buffer t))))
- (if (null (get-buffer-process new-buffer))
- (error "Buffer %s has no process" (buffer-name new-buffer)))
- (if (null (with-current-buffer new-buffer
- (equal major-mode 'sql-interactive-mode)))
- (error "Buffer %s is no SQLi buffer" (buffer-name new-buffer)))
- (if new-buffer
- (progn
- (setq sql-buffer new-buffer)
- (run-hooks 'sql-set-sqli-hook))))))
+ (error "There is no suitable SQLi buffer")
+ (let ((new-buffer (read-buffer "New SQLi buffer: " default-buffer t)))
+ (if (null (sql-buffer-live-p new-buffer))
+ (error "Buffer %s is not a working SQLi buffer" new-buffer)
+ (when new-buffer
+ (setq sql-buffer new-buffer)
+ (run-hooks 'sql-set-sqli-hook)))))))
(defun sql-show-sqli-buffer ()
"Show the name of current SQLi buffer.
@@ -1947,32 +2722,108 @@ If you call it from anywhere else, it sets the global copy of
This is the buffer SQL strings are sent to. It is stored in the
variable `sql-buffer'. See `sql-help' on how to create such a buffer."
(interactive)
- (if (null (buffer-live-p sql-buffer))
+ (if (null (buffer-live-p (get-buffer sql-buffer)))
(message "%s has no SQLi buffer set." (buffer-name (current-buffer)))
(if (null (get-buffer-process sql-buffer))
- (message "Buffer %s has no process." (buffer-name sql-buffer))
- (message "Current SQLi buffer is %s." (buffer-name sql-buffer)))))
+ (message "Buffer %s has no process." sql-buffer)
+ (message "Current SQLi buffer is %s." sql-buffer))))
(defun sql-make-alternate-buffer-name ()
"Return a string that can be used to rename a SQLi buffer.
This is used to set `sql-alternate-buffer-name' within
-`sql-interactive-mode'."
- (concat (if (string= "" sql-user)
- (if (string= "" (user-login-name))
- ()
- (concat (user-login-name) "/"))
- (concat sql-user "/"))
- (if (string= "" sql-database)
- (if (string= "" sql-server)
- (system-name)
- sql-server)
- sql-database)))
+`sql-interactive-mode'.
-(defun sql-rename-buffer ()
- "Rename a SQLi buffer."
- (interactive)
- (rename-buffer (format "*SQL: %s*" sql-alternate-buffer-name) t))
+If the session was started with `sql-connect' then the alternate
+name would be the name of the connection.
+
+Otherwise, it uses the parameters identified by the :sqlilogin
+parameter.
+
+If all else fails, the alternate name would be the user and
+server/database name."
+
+ (let ((name ""))
+
+ ;; Build a name using the :sqli-login setting
+ (setq name
+ (apply 'concat
+ (cdr
+ (apply 'append nil
+ (sql-for-each-login
+ (sql-get-product-feature sql-product :sqli-login)
+ (lambda (token plist)
+ (cond
+ ((eq token 'user)
+ (unless (string= "" sql-user)
+ (list "/" sql-user)))
+ ((eq token 'port)
+ (unless (or (not (numberp sql-port))
+ (= 0 sql-port))
+ (list ":" (number-to-string sql-port))))
+ ((eq token 'server)
+ (unless (string= "" sql-server)
+ (list "."
+ (if (plist-member plist :file)
+ (file-name-nondirectory sql-server)
+ sql-server))))
+ ((eq token 'database)
+ (unless (string= "" sql-database)
+ (list "@"
+ (if (plist-member plist :file)
+ (file-name-nondirectory sql-database)
+ sql-database))))
+
+ ((eq token 'password) nil)
+ (t nil))))))))
+
+ ;; If there's a connection, use it and the name thus far
+ (if sql-connection
+ (format "<%s>%s" sql-connection (or name ""))
+
+ ;; If there is no name, try to create something meaningful
+ (if (string= "" (or name ""))
+ (concat
+ (if (string= "" sql-user)
+ (if (string= "" (user-login-name))
+ ()
+ (concat (user-login-name) "/"))
+ (concat sql-user "/"))
+ (if (string= "" sql-database)
+ (if (string= "" sql-server)
+ (system-name)
+ sql-server)
+ sql-database))
+
+ ;; Use the name we've got
+ name))))
+
+(defun sql-rename-buffer (&optional new-name)
+ "Rename a SQL interactive buffer.
+
+Prompts for the new name if command is preceeded by
+\\[universal-argument]. If no buffer name is provided, then the
+`sql-alternate-buffer-name' is used.
+
+The actual buffer name set will be \"*SQL: NEW-NAME*\". If
+NEW-NAME is empty, then the buffer name will be \"*SQL*\"."
+ (interactive "P")
+
+ (if (not (derived-mode-p 'sql-interactive-mode))
+ (message "Current buffer is not a SQL interactive buffer")
+
+ (setq sql-alternate-buffer-name
+ (cond
+ ((stringp new-name) new-name)
+ ((consp new-name)
+ (read-string "Buffer name (\"*SQL: XXX*\"; enter `XXX'): "
+ sql-alternate-buffer-name))
+ (t sql-alternate-buffer-name)))
+
+ (rename-buffer (if (string= "" sql-alternate-buffer-name)
+ "*SQL*"
+ (format "*SQL: %s*" sql-alternate-buffer-name))
+ t)))
(defun sql-copy-column ()
"Copy current column to the end of buffer.
@@ -1980,7 +2831,7 @@ Inserts SELECT or commas if appropriate."
(interactive)
(let ((column))
(save-excursion
- (setq column (buffer-substring
+ (setq column (buffer-substring-no-properties
(progn (forward-char 1) (backward-sexp 1) (point))
(progn (forward-sexp 1) (point))))
(goto-char (point-max))
@@ -2011,62 +2862,143 @@ Inserts SELECT or commas if appropriate."
(defvar sql-placeholder-history nil
"History of placeholder values used.")
-(defun sql-query-placeholders-and-send (proc string)
- "Send to PROC input STRING, maybe replacing placeholders.
-Placeholders are words starting with an ampersand like &this.
-This function is used for `comint-input-sender' if using
-`sql-oracle' on Windows."
- (while (string-match "&\\(\\sw+\\)" string)
- (setq string (replace-match
- (read-from-minibuffer
- (format "Enter value for %s: " (match-string 1 string))
- nil nil nil sql-placeholder-history)
- t t string)))
- (comint-send-string proc string)
- (if comint-input-sender-no-newline
- (if (not (string-equal string ""))
- (process-send-eof))
- (comint-send-string proc "\n")))
+(defun sql-placeholders-filter (string)
+ "Replace placeholders in STRING.
+Placeholders are words starting with an ampersand like &this."
+
+ (when sql-oracle-scan-on
+ (while (string-match "&\\(\\sw+\\)" string)
+ (setq string (replace-match
+ (read-from-minibuffer
+ (format "Enter value for %s: " (match-string 1 string))
+ nil nil nil 'sql-placeholder-history)
+ t t string))))
+ string)
;; Using DB2 interactively, newlines must be escaped with " \".
;; The space before the backslash is relevant.
-(defun sql-escape-newlines-and-send (proc string)
- "Send to PROC input STRING, escaping newlines if necessary.
+(defun sql-escape-newlines-filter (string)
+ "Escape newlines in STRING.
Every newline in STRING will be preceded with a space and a backslash."
(let ((result "") (start 0) mb me)
(while (string-match "\n" string start)
(setq mb (match-beginning 0)
- me (match-end 0))
- (if (and (> mb 1)
- (string-equal " \\" (substring string (- mb 2) mb)))
- (setq result (concat result (substring string start me)))
- (setq result (concat result (substring string start mb) " \\\n")))
- (setq start me))
- (setq result (concat result (substring string start)))
- (comint-send-string proc result)
- (if comint-input-sender-no-newline
- (if (not (string-equal string ""))
- (process-send-eof))
- (comint-send-string proc "\n"))))
+ me (match-end 0)
+ result (concat result
+ (substring string start mb)
+ (if (and (> mb 1)
+ (string-equal " \\" (substring string (- mb 2) mb)))
+ "" " \\\n"))
+ start me))
+ (concat result (substring string start))))
+;;; Input sender for SQLi buffers
+
+(defvar sql-output-newline-count 0
+ "Number of newlines in the input string.
+
+Allows the suppression of continuation prompts.")
+
+(defvar sql-output-by-send nil
+ "Non-nil if the command in the input was generated by `sql-send-string'.")
+
+(defun sql-input-sender (proc string)
+ "Send STRING to PROC after applying filters."
+
+ (let* ((product (with-current-buffer (process-buffer proc) sql-product))
+ (filter (sql-get-product-feature product :input-filter)))
+
+ ;; Apply filter(s)
+ (cond
+ ((not filter)
+ nil)
+ ((functionp filter)
+ (setq string (funcall filter string)))
+ ((listp filter)
+ (mapc (lambda (f) (setq string (funcall f string))) filter))
+ (t nil))
+
+ ;; Count how many newlines in the string
+ (setq sql-output-newline-count 0)
+ (mapc (lambda (ch)
+ (when (eq ch ?\n)
+ (setq sql-output-newline-count (1+ sql-output-newline-count))))
+ string)
+
+ ;; Send the string
+ (comint-simple-send proc string)))
+
+;;; Strip out continuation prompts
+
+(defun sql-interactive-remove-continuation-prompt (oline)
+ "Strip out continuation prompts out of the OLINE.
+
+Added to the `comint-preoutput-filter-functions' hook in a SQL
+interactive buffer. If `sql-outut-newline-count' is greater than
+zero, then an output line matching the continuation prompt is filtered
+out. If the count is one, then the prompt is replaced with a newline
+to force the output from the query to appear on a new line."
+ (if (and sql-prompt-cont-regexp
+ sql-output-newline-count
+ (numberp sql-output-newline-count)
+ (>= sql-output-newline-count 1))
+ (progn
+ (while (and oline
+ sql-output-newline-count
+ (> sql-output-newline-count 0)
+ (string-match sql-prompt-cont-regexp oline))
+
+ (setq oline
+ (replace-match (if (and
+ (= 1 sql-output-newline-count)
+ sql-output-by-send)
+ "\n" "")
+ nil nil oline)
+ sql-output-newline-count
+ (1- sql-output-newline-count)))
+ (if (= sql-output-newline-count 0)
+ (setq sql-output-newline-count nil))
+ (setq sql-output-by-send nil))
+ (setq sql-output-newline-count nil))
+ oline)
+
;;; Sending the region to the SQLi buffer.
+(defun sql-send-string (str)
+ "Send the string STR to the SQL process."
+ (interactive "sSQL Text: ")
+
+ (let ((comint-input-sender-no-newline nil)
+ (s (replace-regexp-in-string "[[:space:]\n\r]+\\'" "" str)))
+ (if (sql-buffer-live-p sql-buffer)
+ (progn
+ ;; Ignore the hoping around...
+ (save-excursion
+ ;; Set product context
+ (with-current-buffer sql-buffer
+ ;; Send the string (trim the trailing whitespace)
+ (sql-input-sender (get-buffer-process sql-buffer) s)
+
+ ;; Send a command terminator if we must
+ (if sql-send-terminator
+ (sql-send-magic-terminator sql-buffer s sql-send-terminator))
+
+ (message "Sent string to buffer %s." sql-buffer)))
+
+ ;; Display the sql buffer
+ (if sql-pop-to-buffer-after-send-region
+ (pop-to-buffer sql-buffer)
+ (display-buffer sql-buffer)))
+
+ ;; We don't have no stinkin' sql
+ (message "No SQL process started."))))
+
(defun sql-send-region (start end)
"Send a region to the SQL process."
(interactive "r")
- (if (buffer-live-p sql-buffer)
- (save-excursion
- (comint-send-region sql-buffer start end)
- (if (string-match "\n$" (buffer-substring start end))
- ()
- (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.")))
+ (sql-send-string (buffer-substring-no-properties start end)))
(defun sql-send-paragraph ()
"Send the current paragraph to the SQL process."
@@ -2084,18 +3016,40 @@ 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-send-magic-terminator (buf str terminator)
+ "Send TERMINATOR to buffer BUF if its not present in STR."
+ (let (comint-input-sender-no-newline pat term)
+ ;; If flag is merely on(t), get product-specific terminator
+ (if (eq terminator t)
+ (setq terminator (sql-get-product-feature sql-product :terminator)))
+
+ ;; If there is no terminator specified, use default ";"
+ (unless terminator
+ (setq terminator ";"))
+
+ ;; Parse the setting into the pattern and the terminator string
+ (cond ((stringp terminator)
+ (setq pat (regexp-quote terminator)
+ term terminator))
+ ((consp terminator)
+ (setq pat (car terminator)
+ term (cdr terminator)))
+ (t
+ nil))
+
+ ;; Check to see if the pattern is present in the str already sent
+ (unless (and pat term
+ (string-match (concat pat "\\'") str))
+ (comint-simple-send (get-buffer-process buf) term)
+ (setq sql-output-newline-count
+ (if sql-output-newline-count
+ (1+ sql-output-newline-count)
+ 1)))
+ (setq sql-output-by-send t)))
+
+(defun sql-remove-tabs-filter (str)
+ "Replace tab characters with spaces."
+ (replace-regexp-in-string "\t" " " str nil t))
(defun sql-toggle-pop-to-buffer-after-send-region (&optional value)
"Toggle `sql-pop-to-buffer-after-send-region'.
@@ -2106,7 +3060,172 @@ If given the optional parameter VALUE, sets
(if value
(setq sql-pop-to-buffer-after-send-region value)
(setq sql-pop-to-buffer-after-send-region
- (null sql-pop-to-buffer-after-send-region ))))
+ (null sql-pop-to-buffer-after-send-region))))
+
+
+
+;;; Redirect output functions
+
+(defun sql-redirect (command combuf &optional outbuf save-prior)
+ "Execute the SQL command and send output to OUTBUF.
+
+COMBUF must be an active SQL interactive buffer. OUTBUF may be
+an existing buffer, or the name of a non-existing buffer. If
+omitted the output is sent to a temporary buffer which will be
+killed after the command completes. COMMAND should be a string
+of commands accepted by the SQLi program."
+
+ (with-current-buffer combuf
+ (let ((buf (get-buffer-create (or outbuf " *SQL-Redirect*")))
+ (proc (get-buffer-process (current-buffer)))
+ (comint-prompt-regexp (sql-get-product-feature sql-product
+ :prompt-regexp))
+ (start nil))
+ (with-current-buffer buf
+ (toggle-read-only -1)
+ (unless save-prior
+ (erase-buffer))
+ (goto-char (point-max))
+ (unless (zerop (buffer-size))
+ (insert "\n"))
+ (setq start (point)))
+
+ ;; Run the command
+ (message "Executing SQL command...")
+ (comint-redirect-send-command-to-process command buf proc nil t)
+ (while (null comint-redirect-completed)
+ (accept-process-output nil 1))
+ (message "Executing SQL command...done")
+
+ ;; Clean up the output results
+ (with-current-buffer buf
+ ;; Remove trailing whitespace
+ (goto-char (point-max))
+ (when (looking-back "[ \t\f\n\r]*" start)
+ (delete-region (match-beginning 0) (match-end 0)))
+ ;; Remove echo if there was one
+ (goto-char start)
+ (when (looking-at (concat "^" (regexp-quote command) "[\\n]"))
+ (delete-region (match-beginning 0) (match-end 0)))
+ (goto-char start)))))
+
+(defun sql-redirect-value (command combuf regexp &optional regexp-groups)
+ "Execute the SQL command and return part of result.
+
+COMBUF must be an active SQL interactive buffer. COMMAND should
+be a string of commands accepted by the SQLi program. From the
+output, the REGEXP is repeatedly matched and the list of
+REGEXP-GROUPS submatches is returned. This behaves much like
+\\[comint-redirect-results-list-from-process] but instead of
+returning a single submatch it returns a list of each submatch
+for each match."
+
+ (let ((outbuf " *SQL-Redirect-values*")
+ (results nil))
+ (sql-redirect command combuf outbuf nil)
+ (with-current-buffer outbuf
+ (while (re-search-forward regexp nil t)
+ (push
+ (cond
+ ;; no groups-return all of them
+ ((null regexp-groups)
+ (let ((i 1)
+ (r nil))
+ (while (match-beginning i)
+ (push (match-string i) r))
+ (nreverse r)))
+ ;; one group specified
+ ((numberp regexp-groups)
+ (match-string regexp-groups))
+ ;; list of numbers; return the specified matches only
+ ((consp regexp-groups)
+ (mapcar (lambda (c)
+ (cond
+ ((numberp c) (match-string c))
+ ((stringp c) (match-substitute-replacement c))
+ (t (error "sql-redirect-value: unknown REGEXP-GROUPS value - %s" c))))
+ regexp-groups))
+ ;; String is specified; return replacement string
+ ((stringp regexp-groups)
+ (match-substitute-replacement regexp-groups))
+ (t
+ (error "sql-redirect-value: unknown REGEXP-GROUPS value - %s"
+ regexp-groups)))
+ results)))
+ (nreverse results)))
+
+(defun sql-execute (sqlbuf outbuf command arg)
+ "Executes a command in a SQL interacive buffer and captures the output.
+
+The commands are run in SQLBUF and the output saved in OUTBUF.
+COMMAND must be a string, a function or a list of such elements.
+Functions are called with SQLBUF, OUTBUF and ARG as parameters;
+strings are formatted with ARG and executed.
+
+If the results are empty the OUTBUF is deleted, otherwise the
+buffer is popped into a view window. "
+ (mapc
+ (lambda (c)
+ (cond
+ ((stringp c)
+ (sql-redirect (if arg (format c arg) c) sqlbuf outbuf) t)
+ ((functionp c)
+ (apply c sqlbuf outbuf arg))
+ (t (error "Unknown sql-execute item %s" c))))
+ (if (consp command) command (cons command nil)))
+
+ (setq outbuf (get-buffer outbuf))
+ (if (zerop (buffer-size outbuf))
+ (kill-buffer outbuf)
+ (let ((one-win (eq (selected-window)
+ (get-lru-window))))
+ (with-current-buffer outbuf
+ (set-buffer-modified-p nil)
+ (toggle-read-only 1))
+ (view-buffer-other-window outbuf)
+ (when one-win
+ (shrink-window-if-larger-than-buffer)))))
+
+(defun sql-execute-feature (sqlbuf outbuf feature enhanced arg)
+ "List objects or details in a separate display buffer."
+ (let (command)
+ (with-current-buffer sqlbuf
+ (setq command (sql-get-product-feature sql-product feature)))
+ (unless command
+ (error "%s does not support %s" sql-product feature))
+ (when (consp command)
+ (setq command (if enhanced
+ (cdr command)
+ (car command))))
+ (sql-execute sqlbuf outbuf command arg)))
+
+(defun sql-read-table-name (prompt)
+ "Read the name of a database table."
+ ;; TODO: Fetch table/view names from database and provide completion.
+ ;; Also implement thing-at-point if the buffer has valid names in it
+ ;; (i.e. sql-mode, sql-interactive-mode, or sql-list-all buffers)
+ (read-from-minibuffer prompt))
+
+(defun sql-list-all (&optional enhanced)
+ "List all database objects."
+ (interactive "P")
+ (let ((sqlbuf (sql-find-sqli-buffer)))
+ (unless sqlbuf
+ (error "No SQL interactive buffer found"))
+ (sql-execute-feature sqlbuf "*List All*" :list-all enhanced nil)))
+
+(defun sql-list-table (name &optional enhanced)
+ "List the details of a database table. "
+ (interactive
+ (list (sql-read-table-name "Table name: ")
+ current-prefix-arg))
+ (let ((sqlbuf (sql-find-sqli-buffer)))
+ (unless sqlbuf
+ (error "No SQL interactive buffer found"))
+ (unless name
+ (error "No table name specified"))
+ (sql-execute-feature sqlbuf (format "*List %s*" name)
+ :list-table enhanced name)))
@@ -2249,24 +3368,29 @@ you entered, right above the output it created.
\(setq comint-output-filter-functions
\(function (lambda (STR) (comint-show-output))))"
(delay-mode-hooks (comint-mode))
+
;; Get the `sql-product' for this interactive session.
(set (make-local-variable 'sql-product)
(or sql-interactive-product
sql-product))
+
;; Setup the mode.
(setq major-mode 'sql-interactive-mode)
- (setq mode-name (concat "SQLi[" (prin1-to-string sql-product) "]"))
+ (setq mode-name (concat "SQLi[" (or (sql-get-product-feature sql-product :name)
+ (symbol-name sql-product)) "]"))
(use-local-map sql-interactive-mode-map)
(if sql-interactive-mode-menu
(easy-menu-add sql-interactive-mode-menu)) ; XEmacs
(set-syntax-table sql-mode-syntax-table)
(make-local-variable 'sql-mode-font-lock-keywords)
(make-local-variable 'font-lock-defaults)
+
;; Note that making KEYWORDS-ONLY nil will cause havoc if you try
;; SELECT 'x' FROM DUAL with SQL*Plus, because the title of the column
;; will have just one quote. Therefore syntactic hilighting is
;; disabled for interactive buffers. No imenu support.
(sql-product-font-lock t nil)
+
;; Enable commenting and uncommenting of the region.
(make-local-variable 'comment-start)
(setq comment-start "--")
@@ -2275,22 +3399,36 @@ you entered, right above the output it created.
(setq local-abbrev-table sql-mode-abbrev-table)
(setq abbrev-all-caps 1)
;; Exiting the process will call sql-stop.
- (set-process-sentinel (get-buffer-process sql-buffer) 'sql-stop)
+ (set-process-sentinel (get-buffer-process (current-buffer)) 'sql-stop)
+ ;; Save the connection name
+ (make-local-variable 'sql-connection)
;; Create a usefull name for renaming this buffer later.
(make-local-variable 'sql-alternate-buffer-name)
(setq sql-alternate-buffer-name (sql-make-alternate-buffer-name))
;; User stuff. Initialize before the hook.
(set (make-local-variable 'sql-prompt-regexp)
- (sql-product-feature :sqli-prompt-regexp))
+ (sql-get-product-feature sql-product :prompt-regexp))
(set (make-local-variable 'sql-prompt-length)
- (sql-product-feature :sqli-prompt-length))
+ (sql-get-product-feature sql-product :prompt-length))
+ (set (make-local-variable 'sql-prompt-cont-regexp)
+ (sql-get-product-feature sql-product :prompt-cont-regexp))
+ (make-local-variable 'sql-output-newline-count)
+ (make-local-variable 'sql-output-by-send)
+ (add-hook 'comint-preoutput-filter-functions
+ 'sql-interactive-remove-continuation-prompt nil t)
(make-local-variable 'sql-input-ring-separator)
(make-local-variable 'sql-input-ring-file-name)
- ;; Run hook.
+ ;; Run the mode hook (along with comint's hooks).
(run-mode-hooks 'sql-interactive-mode-hook)
;; Set comint based on user overrides.
- (setq comint-prompt-regexp sql-prompt-regexp)
+ (setq comint-prompt-regexp
+ (if sql-prompt-cont-regexp
+ (concat "\\(" sql-prompt-regexp
+ "\\|" sql-prompt-cont-regexp "\\)")
+ sql-prompt-regexp))
(setq left-margin sql-prompt-length)
+ ;; Install input sender
+ (set (make-local-variable 'comint-input-sender) 'sql-input-sender)
;; People wanting a different history file for each
;; buffer/process/client/whatever can change separator and file-name
;; on the sql-interactive-mode-hook.
@@ -2316,36 +3454,239 @@ Sentinels will always get the two parameters PROCESS and EVENT."
+;;; Connection handling
+
+(defun sql-read-connection (prompt &optional initial default)
+ "Read a connection name."
+ (let ((completion-ignore-case t))
+ (completing-read prompt
+ (mapcar (lambda (c) (car c))
+ sql-connection-alist)
+ nil t initial 'sql-connection-history default)))
+
+;;;###autoload
+(defun sql-connect (connection)
+ "Connect to an interactive session using CONNECTION settings.
+
+See `sql-connection-alist' to see how to define connections and
+their settings.
+
+The user will not be prompted for any login parameters if a value
+is specified in the connection settings."
+
+ ;; Prompt for the connection from those defined in the alist
+ (interactive
+ (if sql-connection-alist
+ (list (sql-read-connection "Connection: " nil '(nil)))
+ nil))
+
+ ;; Are there connections defined
+ (if sql-connection-alist
+ ;; Was one selected
+ (when connection
+ ;; Get connection settings
+ (let ((connect-set (assoc connection sql-connection-alist)))
+ ;; Settings are defined
+ (if connect-set
+ ;; Set the desired parameters
+ (eval `(let*
+ (,@(cdr connect-set)
+ ;; :sqli-login params variable
+ (param-var (sql-get-product-feature sql-product
+ :sqli-login nil t))
+ ;; :sqli-login params value
+ (login-params (sql-get-product-feature sql-product
+ :sqli-login))
+ ;; which params are in the connection
+ (set-params (mapcar
+ (lambda (v)
+ (cond
+ ((eq (car v) 'sql-user) 'user)
+ ((eq (car v) 'sql-password) 'password)
+ ((eq (car v) 'sql-server) 'server)
+ ((eq (car v) 'sql-database) 'database)
+ ((eq (car v) 'sql-port) 'port)
+ (t (car v))))
+ (cdr connect-set)))
+ ;; the remaining params (w/o the connection params)
+ (rem-params (sql-for-each-login
+ login-params
+ (lambda (token plist)
+ (unless (member token set-params)
+ (if plist
+ (cons token plist)
+ token)))))
+ ;; Remember the connection
+ (sql-connection connection))
+
+ ;; Set the remaining parameters and start the
+ ;; interactive session
+ (eval `(let ((,param-var ',rem-params))
+ (sql-product-interactive sql-product)))))
+ (message "SQL Connection <%s> does not exist" connection)
+ nil)))
+ (message "No SQL Connections defined")
+ nil))
+
+(defun sql-save-connection (name)
+ "Captures the connection information of the current SQLi session.
+
+The information is appended to `sql-connection-alist' and
+optionally is saved to the user's init file."
+
+ (interactive "sNew connection name: ")
+
+ (if sql-connection
+ (message "This session was started by a connection; it's already been saved.")
+
+ (let ((login (sql-get-product-feature sql-product :sqli-login))
+ (alist sql-connection-alist)
+ connect)
+
+ ;; Remove the existing connection if the user says so
+ (when (and (assoc name alist)
+ (yes-or-no-p (format "Replace connection definition <%s>? " name)))
+ (setq alist (assq-delete-all name alist)))
+
+ ;; Add the new connection if it doesn't exist
+ (if (assoc name alist)
+ (message "Connection <%s> already exists" name)
+ (setq connect
+ (append (list name)
+ (sql-for-each-login
+ `(product ,@login)
+ (lambda (token plist)
+ (cond
+ ((eq token 'product) `(sql-product ',sql-product))
+ ((eq token 'user) `(sql-user ,sql-user))
+ ((eq token 'database) `(sql-database ,sql-database))
+ ((eq token 'server) `(sql-server ,sql-server))
+ ((eq token 'port) `(sql-port ,sql-port)))))))
+
+ (setq alist (append alist (list connect)))
+
+ ;; confirm whether we want to save the connections
+ (if (yes-or-no-p "Save the connections for future sessions? ")
+ (customize-save-variable 'sql-connection-alist alist)
+ (customize-set-variable 'sql-connection-alist alist))))))
+
+(defun sql-connection-menu-filter (tail)
+ "Generates menu entries for using each connection."
+ (append
+ (mapcar
+ (lambda (conn)
+ (vector
+ (format "Connection <%s>" (car conn))
+ (list 'sql-connect (car conn))
+ t))
+ sql-connection-alist)
+ tail))
+
+
+
;;; Entry functions for different SQL interpreters.
;;;###autoload
-(defun sql-product-interactive (&optional product)
- "Run product interpreter as an inferior process.
+(defun sql-product-interactive (&optional product new-name)
+ "Run PRODUCT interpreter as an inferior process.
If buffer `*SQL*' exists but no process is running, make a new process.
If buffer exists and a process is running, just switch to buffer `*SQL*'.
+To specify the SQL product, prefix the call with
+\\[universal-argument]. To set the buffer name as well, prefix
+the call to \\[sql-product-interactive] with
+\\[universal-argument] \\[universal-argument].
+
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)"
- (interactive)
- (setq product (or product sql-product))
- (when (sql-product-feature :sqli-connect product)
- (if (comint-check-proc "*SQL*")
- (pop-to-buffer "*SQL*")
- ;; Get credentials.
- (apply 'sql-get-login (sql-product-feature :sqli-login product))
- ;; Connect to database.
- (message "Login...")
- (funcall (sql-product-feature :sqli-connect product))
- ;; Set SQLi mode.
- (setq sql-interactive-product product)
- (setq sql-buffer (current-buffer))
- (sql-interactive-mode)
- ;; All done.
- (message "Login...done")
- (pop-to-buffer sql-buffer))))
+ (interactive "P")
+
+ ;; Handle universal arguments if specified
+ (when (not (or executing-kbd-macro noninteractive))
+ (when (and (consp product)
+ (not (cdr product))
+ (numberp (car product)))
+ (when (>= (prefix-numeric-value product) 16)
+ (when (not new-name)
+ (setq new-name '(4)))
+ (setq product '(4)))))
+
+ ;; Get the value of product that we need
+ (setq product
+ (cond
+ ((and product ; Product specified
+ (symbolp product)) product)
+ ((= (prefix-numeric-value product) 4) ; C-u, prompt for product
+ (sql-read-product "SQL product: " sql-product))
+ (t sql-product))) ; Default to sql-product
+
+ ;; If we have a product and it has a interactive mode
+ (if product
+ (when (sql-get-product-feature product :sqli-comint-func)
+ ;; If no new name specified, try to pop to an active SQL
+ ;; interactive for the same product
+ (let ((buf (sql-find-sqli-buffer product)))
+ (if (and (not new-name) buf)
+ (pop-to-buffer buf)
+
+ ;; We have a new name or sql-buffer doesn't exist or match
+ ;; Start by remembering where we start
+ (let ((start-buffer (current-buffer))
+ new-sqli-buffer)
+
+ ;; Get credentials.
+ (apply 'sql-get-login (sql-get-product-feature product :sqli-login))
+
+ ;; Connect to database.
+ (message "Login...")
+ (funcall (sql-get-product-feature product :sqli-comint-func)
+ product
+ (sql-get-product-feature product :sqli-options))
+
+ ;; Set SQLi mode.
+ (setq new-sqli-buffer (current-buffer))
+ (let ((sql-interactive-product product))
+ (sql-interactive-mode))
+
+ ;; Set the new buffer name
+ (when new-name
+ (sql-rename-buffer new-name))
+
+ ;; Set `sql-buffer' in the new buffer and the start buffer
+ (setq sql-buffer (buffer-name new-sqli-buffer))
+ (with-current-buffer start-buffer
+ (setq sql-buffer (buffer-name new-sqli-buffer))
+ (run-hooks 'sql-set-sqli-hook))
+
+ ;; All done.
+ (message "Login...done")
+ (pop-to-buffer sql-buffer)))))
+ (message "No default SQL product defined. Set `sql-product'.")))
+
+(defun sql-comint (product params)
+ "Set up a comint buffer to run the SQL processor.
+
+PRODUCT is the SQL product. PARAMS is a list of strings which are
+passed as command line arguments."
+ (let ((program (sql-get-product-feature product :sqli-program))
+ (buf-name "SQL"))
+ ;; make sure we can find the program
+ (unless (executable-find program)
+ (error "Unable to locate SQL program \'%s\'" program))
+ ;; Make sure buffer name is unique
+ (when (sql-buffer-live-p (format "*%s*" buf-name))
+ (setq buf-name (format "SQL-%s" product))
+ (when (sql-buffer-live-p (format "*%s*" buf-name))
+ (let ((i 1))
+ (while (sql-buffer-live-p
+ (format "*%s*"
+ (setq buf-name (format "SQL-%s%d" product i))))
+ (setq i (1+ i))))))
+ (set-buffer
+ (apply 'make-comint buf-name program nil params))))
;;;###autoload
-(defun sql-oracle ()
+(defun sql-oracle (&optional buffer)
"Run sqlplus by Oracle as an inferior process.
If buffer `*SQL*' exists but no process is running, make a new process.
@@ -2360,6 +3701,11 @@ the list `sql-oracle-options'.
The buffer is put in SQL interactive mode, giving commands for sending
input. See `sql-interactive-mode'.
+To set the buffer name directly, use \\[universal-argument]
+before \\[sql-oracle]. Once session has started,
+\\[sql-rename-buffer] can be called separately to rename the
+buffer.
+
To specify a coding system for converting non-ASCII characters
in the input and output to the process, use \\[universal-coding-system-argument]
before \\[sql-oracle]. You can also specify this with \\[set-buffer-process-coding-system]
@@ -2368,36 +3714,32 @@ The default comes from `process-coding-system-alist' and
`default-process-coding-system'.
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)"
- (interactive)
- (sql-product-interactive 'oracle))
+ (interactive "P")
+ (sql-product-interactive 'oracle buffer))
-(defun sql-connect-oracle ()
- "Create comint buffer and connect to Oracle using the login
-parameters and command options."
+(defun sql-comint-oracle (product options)
+ "Create comint buffer and connect to Oracle."
;; Produce user/password@database construct. Password without user
;; is meaningless; database without user/password is meaningless,
;; because "@param" will ask sqlplus to interpret the script
;; "param".
- (let ((parameter
- (if (not (string= "" sql-user))
- (if (not (string= "" sql-password))
- (concat sql-user "/" sql-password)
- sql-user))))
+ (let ((parameter nil))
+ (if (not (string= "" sql-user))
+ (if (not (string= "" sql-password))
+ (setq parameter (concat sql-user "/" sql-password))
+ (setq parameter sql-user)))
(if (and parameter (not (string= "" sql-database)))
(setq parameter (concat parameter "@" sql-database)))
- (setq parameter (if parameter
- (nconc (list parameter) sql-oracle-options)
- sql-oracle-options))
- (set-buffer (apply 'make-comint "SQL" sql-oracle-program nil parameter))
- ;; SQL*Plus is buffered on Windows; this handles &placeholders.
- (if (eq window-system 'w32)
- (setq comint-input-sender 'sql-query-placeholders-and-send))))
+ (if parameter
+ (setq parameter (nconc (list parameter) options))
+ (setq parameter options))
+ (sql-comint product parameter)))
;;;###autoload
-(defun sql-sybase ()
- "Run isql by SyBase as an inferior process.
+(defun sql-sybase (&optional buffer)
+ "Run isql by Sybase as an inferior process.
If buffer `*SQL*' exists but no process is running, make a new process.
If buffer exists and a process is running, just switch to buffer
@@ -2411,6 +3753,11 @@ can be stored in the list `sql-sybase-options'.
The buffer is put in SQL interactive mode, giving commands for sending
input. See `sql-interactive-mode'.
+To set the buffer name directly, use \\[universal-argument]
+before \\[sql-sybase]. Once session has started,
+\\[sql-rename-buffer] can be called separately to rename the
+buffer.
+
To specify a coding system for converting non-ASCII characters
in the input and output to the process, use \\[universal-coding-system-argument]
before \\[sql-sybase]. You can also specify this with \\[set-buffer-process-coding-system]
@@ -2419,15 +3766,14 @@ The default comes from `process-coding-system-alist' and
`default-process-coding-system'.
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)"
- (interactive)
- (sql-product-interactive 'sybase))
+ (interactive "P")
+ (sql-product-interactive 'sybase buffer))
-(defun sql-connect-sybase ()
- "Create comint buffer and connect to Sybase using the login
-parameters and command options."
+(defun sql-comint-sybase (product options)
+ "Create comint buffer and connect to Sybase."
;; Put all parameters to the program (if defined) in a list and call
;; make-comint.
- (let ((params sql-sybase-options))
+ (let ((params options))
(if (not (string= "" sql-server))
(setq params (append (list "-S" sql-server) params)))
(if (not (string= "" sql-database))
@@ -2436,13 +3782,12 @@ parameters and command options."
(setq params (append (list "-P" sql-password) params)))
(if (not (string= "" sql-user))
(setq params (append (list "-U" sql-user) params)))
- (set-buffer (apply 'make-comint "SQL" sql-sybase-program
- nil params))))
+ (sql-comint product params)))
;;;###autoload
-(defun sql-informix ()
+(defun sql-informix (&optional buffer)
"Run dbaccess by Informix as an inferior process.
If buffer `*SQL*' exists but no process is running, make a new process.
@@ -2455,6 +3800,11 @@ the variable `sql-database' as default, if set.
The buffer is put in SQL interactive mode, giving commands for sending
input. See `sql-interactive-mode'.
+To set the buffer name directly, use \\[universal-argument]
+before \\[sql-informix]. Once session has started,
+\\[sql-rename-buffer] can be called separately to rename the
+buffer.
+
To specify a coding system for converting non-ASCII characters
in the input and output to the process, use \\[universal-coding-system-argument]
before \\[sql-informix]. You can also specify this with \\[set-buffer-process-coding-system]
@@ -2463,21 +3813,23 @@ The default comes from `process-coding-system-alist' and
`default-process-coding-system'.
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)"
- (interactive)
- (sql-product-interactive 'informix))
+ (interactive "P")
+ (sql-product-interactive 'informix buffer))
-(defun sql-connect-informix ()
- "Create comint buffer and connect to Informix using the login
-parameters and command options."
+(defun sql-comint-informix (product options)
+ "Create comint buffer and connect to Informix."
;; username and password are ignored.
- (set-buffer (if (string= "" sql-database)
- (make-comint "SQL" sql-informix-program nil)
- (make-comint "SQL" sql-informix-program nil sql-database "-"))))
+ (let ((db (if (string= "" sql-database)
+ "-"
+ (if (string= "" sql-server)
+ sql-database
+ (concat sql-database "@" sql-server)))))
+ (sql-comint product (append `(,db "-") options))))
;;;###autoload
-(defun sql-sqlite ()
+(defun sql-sqlite (&optional buffer)
"Run sqlite as an inferior process.
SQLite is free software.
@@ -2494,6 +3846,11 @@ can be stored in the list `sql-sqlite-options'.
The buffer is put in SQL interactive mode, giving commands for sending
input. See `sql-interactive-mode'.
+To set the buffer name directly, use \\[universal-argument]
+before \\[sql-sqlite]. Once session has started,
+\\[sql-rename-buffer] can be called separately to rename the
+buffer.
+
To specify a coding system for converting non-ASCII characters
in the input and output to the process, use \\[universal-coding-system-argument]
before \\[sql-sqlite]. You can also specify this with \\[set-buffer-process-coding-system]
@@ -2502,26 +3859,24 @@ The default comes from `process-coding-system-alist' and
`default-process-coding-system'.
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)"
- (interactive)
- (sql-product-interactive 'sqlite))
+ (interactive "P")
+ (sql-product-interactive 'sqlite buffer))
-(defun sql-connect-sqlite ()
- "Create comint buffer and connect to SQLite using the login
-parameters and command options."
+(defun sql-comint-sqlite (product options)
+ "Create comint buffer and connect to SQLite."
;; Put all parameters to the program (if defined) in a list and call
;; make-comint.
(let ((params))
(if (not (string= "" sql-database))
- (setq params (append (list sql-database) params)))
- (if (not (null sql-sqlite-options))
- (setq params (append sql-sqlite-options params)))
- (set-buffer (apply 'make-comint "SQL" sql-sqlite-program
- nil params))))
+ (setq params (append (list (expand-file-name sql-database))
+ params)))
+ (setq params (append options params))
+ (sql-comint product params)))
;;;###autoload
-(defun sql-mysql ()
+(defun sql-mysql (&optional buffer)
"Run mysql by TcX as an inferior process.
Mysql versions 3.23 and up are free software.
@@ -2538,6 +3893,11 @@ can be stored in the list `sql-mysql-options'.
The buffer is put in SQL interactive mode, giving commands for sending
input. See `sql-interactive-mode'.
+To set the buffer name directly, use \\[universal-argument]
+before \\[sql-mysql]. Once session has started,
+\\[sql-rename-buffer] can be called separately to rename the
+buffer.
+
To specify a coding system for converting non-ASCII characters
in the input and output to the process, use \\[universal-coding-system-argument]
before \\[sql-mysql]. You can also specify this with \\[set-buffer-process-coding-system]
@@ -2546,12 +3906,11 @@ The default comes from `process-coding-system-alist' and
`default-process-coding-system'.
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)"
- (interactive)
- (sql-product-interactive 'mysql))
+ (interactive "P")
+ (sql-product-interactive 'mysql buffer))
-(defun sql-connect-mysql ()
- "Create comint buffer and connect to MySQL using the login
-parameters and command options."
+(defun sql-comint-mysql (product options)
+ "Create comint buffer and connect to MySQL."
;; Put all parameters to the program (if defined) in a list and call
;; make-comint.
(let ((params))
@@ -2559,19 +3918,19 @@ parameters and command options."
(setq params (append (list sql-database) params)))
(if (not (string= "" sql-server))
(setq params (append (list (concat "--host=" sql-server)) params)))
+ (if (not (= 0 sql-port))
+ (setq params (append (list (concat "--port=" (number-to-string sql-port))) params)))
(if (not (string= "" sql-password))
(setq params (append (list (concat "--password=" sql-password)) params)))
(if (not (string= "" sql-user))
(setq params (append (list (concat "--user=" sql-user)) params)))
- (if (not (null sql-mysql-options))
- (setq params (append sql-mysql-options params)))
- (set-buffer (apply 'make-comint "SQL" sql-mysql-program
- nil params))))
+ (setq params (append options params))
+ (sql-comint product params)))
;;;###autoload
-(defun sql-solid ()
+(defun sql-solid (&optional buffer)
"Run solsql by Solid as an inferior process.
If buffer `*SQL*' exists but no process is running, make a new process.
@@ -2585,6 +3944,11 @@ defaults, if set.
The buffer is put in SQL interactive mode, giving commands for sending
input. See `sql-interactive-mode'.
+To set the buffer name directly, use \\[universal-argument]
+before \\[sql-solid]. Once session has started,
+\\[sql-rename-buffer] can be called separately to rename the
+buffer.
+
To specify a coding system for converting non-ASCII characters
in the input and output to the process, use \\[universal-coding-system-argument]
before \\[sql-solid]. You can also specify this with \\[set-buffer-process-coding-system]
@@ -2593,28 +3957,26 @@ The default comes from `process-coding-system-alist' and
`default-process-coding-system'.
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)"
- (interactive)
- (sql-product-interactive 'solid))
+ (interactive "P")
+ (sql-product-interactive 'solid buffer))
-(defun sql-connect-solid ()
- "Create comint buffer and connect to Solid using the login
-parameters and command options."
+(defun sql-comint-solid (product options)
+ "Create comint buffer and connect to Solid."
;; Put all parameters to the program (if defined) in a list and call
;; make-comint.
- (let ((params))
+ (let ((params options))
;; It only makes sense if both username and password are there.
(if (not (or (string= "" sql-user)
(string= "" sql-password)))
(setq params (append (list sql-user sql-password) params)))
(if (not (string= "" sql-server))
(setq params (append (list sql-server) params)))
- (set-buffer (apply 'make-comint "SQL" sql-solid-program
- nil params))))
+ (sql-comint product params)))
;;;###autoload
-(defun sql-ingres ()
+(defun sql-ingres (&optional buffer)
"Run sql by Ingres as an inferior process.
If buffer `*SQL*' exists but no process is running, make a new process.
@@ -2627,6 +3989,11 @@ the variable `sql-database' as default, if set.
The buffer is put in SQL interactive mode, giving commands for sending
input. See `sql-interactive-mode'.
+To set the buffer name directly, use \\[universal-argument]
+before \\[sql-ingres]. Once session has started,
+\\[sql-rename-buffer] can be called separately to rename the
+buffer.
+
To specify a coding system for converting non-ASCII characters
in the input and output to the process, use \\[universal-coding-system-argument]
before \\[sql-ingres]. You can also specify this with \\[set-buffer-process-coding-system]
@@ -2635,21 +4002,22 @@ The default comes from `process-coding-system-alist' and
`default-process-coding-system'.
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)"
- (interactive)
- (sql-product-interactive 'ingres))
+ (interactive "P")
+ (sql-product-interactive 'ingres buffer))
-(defun sql-connect-ingres ()
- "Create comint buffer and connect to Ingres using the login
-parameters and command options."
+(defun sql-comint-ingres (product options)
+ "Create comint buffer and connect to Ingres."
;; username and password are ignored.
- (set-buffer (if (string= "" sql-database)
- (make-comint "SQL" sql-ingres-program nil)
- (make-comint "SQL" sql-ingres-program nil sql-database))))
+ (sql-comint product
+ (append (if (string= "" sql-database)
+ nil
+ (list sql-database))
+ options)))
;;;###autoload
-(defun sql-ms ()
+(defun sql-ms (&optional buffer)
"Run osql by Microsoft as an inferior process.
If buffer `*SQL*' exists but no process is running, make a new process.
@@ -2664,6 +4032,11 @@ in the list `sql-ms-options'.
The buffer is put in SQL interactive mode, giving commands for sending
input. See `sql-interactive-mode'.
+To set the buffer name directly, use \\[universal-argument]
+before \\[sql-ms]. Once session has started,
+\\[sql-rename-buffer] can be called separately to rename the
+buffer.
+
To specify a coding system for converting non-ASCII characters
in the input and output to the process, use \\[universal-coding-system-argument]
before \\[sql-ms]. You can also specify this with \\[set-buffer-process-coding-system]
@@ -2672,15 +4045,14 @@ The default comes from `process-coding-system-alist' and
`default-process-coding-system'.
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)"
- (interactive)
- (sql-product-interactive 'ms))
+ (interactive "P")
+ (sql-product-interactive 'ms buffer))
-(defun sql-connect-ms ()
- "Create comint buffer and connect to Microsoft using the login
-parameters and command options."
+(defun sql-comint-ms (product options)
+ "Create comint buffer and connect to Microsoft SQL Server."
;; Put all parameters to the program (if defined) in a list and call
;; make-comint.
- (let ((params sql-ms-options))
+ (let ((params options))
(if (not (string= "" sql-server))
(setq params (append (list "-S" sql-server) params)))
(if (not (string= "" sql-database))
@@ -2696,13 +4068,12 @@ parameters and command options."
;; If -P is passed to ISQL as the last argument without a
;; password, it's considered null.
(setq params (append params (list "-P")))))
- (set-buffer (apply 'make-comint "SQL" sql-ms-program
- nil params))))
+ (sql-comint product params)))
;;;###autoload
-(defun sql-postgres ()
+(defun sql-postgres (&optional buffer)
"Run psql by Postgres as an inferior process.
If buffer `*SQL*' exists but no process is running, make a new process.
@@ -2717,6 +4088,11 @@ Additional command line parameters can be stored in the list
The buffer is put in SQL interactive mode, giving commands for sending
input. See `sql-interactive-mode'.
+To set the buffer name directly, use \\[universal-argument]
+before \\[sql-postgres]. Once session has started,
+\\[sql-rename-buffer] can be called separately to rename the
+buffer.
+
To specify a coding system for converting non-ASCII characters
in the input and output to the process, use \\[universal-coding-system-argument]
before \\[sql-postgres]. You can also specify this with \\[set-buffer-process-coding-system]
@@ -2730,31 +4106,31 @@ Try to set `comint-output-filter-functions' like this:
'(comint-strip-ctrl-m)))
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)"
- (interactive)
- (sql-product-interactive 'postgres))
+ (interactive "P")
+ (sql-product-interactive 'postgres buffer))
-(defun sql-connect-postgres ()
- "Create comint buffer and connect to Postgres using the login
-parameters and command options."
+(defun sql-comint-postgres (product options)
+ "Create comint buffer and connect to Postgres."
;; username and password are ignored. Mark Stosberg suggest to add
;; the database at the end. Jason Beegan suggest using --pset and
;; pager=off instead of \\o|cat. The later was the solution by
;; Gregor Zych. Jason's suggestion is the default value for
;; sql-postgres-options.
- (let ((params sql-postgres-options))
+ (let ((params options))
(if (not (string= "" sql-database))
(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))))
+ (if (not (= 0 sql-port))
+ (setq params (append (list "-p" sql-port) params)))
+ (sql-comint product params)))
;;;###autoload
-(defun sql-interbase ()
+(defun sql-interbase (&optional buffer)
"Run isql by Interbase as an inferior process.
If buffer `*SQL*' exists but no process is running, make a new process.
@@ -2768,6 +4144,11 @@ defaults, if set.
The buffer is put in SQL interactive mode, giving commands for sending
input. See `sql-interactive-mode'.
+To set the buffer name directly, use \\[universal-argument]
+before \\[sql-interbase]. Once session has started,
+\\[sql-rename-buffer] can be called separately to rename the
+buffer.
+
To specify a coding system for converting non-ASCII characters
in the input and output to the process, use \\[universal-coding-system-argument]
before \\[sql-interbase]. You can also specify this with \\[set-buffer-process-coding-system]
@@ -2776,28 +4157,26 @@ The default comes from `process-coding-system-alist' and
`default-process-coding-system'.
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)"
- (interactive)
- (sql-product-interactive 'interbase))
+ (interactive "P")
+ (sql-product-interactive 'interbase buffer))
-(defun sql-connect-interbase ()
- "Create comint buffer and connect to Interbase using the login
-parameters and command options."
+(defun sql-comint-interbase (product options)
+ "Create comint buffer and connect to Interbase."
;; Put all parameters to the program (if defined) in a list and call
;; make-comint.
- (let ((params sql-interbase-options))
+ (let ((params options))
(if (not (string= "" sql-user))
(setq params (append (list "-u" sql-user) params)))
(if (not (string= "" sql-password))
(setq params (append (list "-p" sql-password) params)))
(if (not (string= "" sql-database))
(setq params (cons sql-database params))) ; add to the front!
- (set-buffer (apply 'make-comint "SQL" sql-interbase-program
- nil params))))
+ (sql-comint product params)))
;;;###autoload
-(defun sql-db2 ()
+(defun sql-db2 (&optional buffer)
"Run db2 by IBM as an inferior process.
If buffer `*SQL*' exists but no process is running, make a new process.
@@ -2815,6 +4194,11 @@ db2, newlines will be escaped if necessary. If you don't want that, set
`comint-input-sender' back to `comint-simple-send' by writing an after
advice. See the elisp manual for more information.
+To set the buffer name directly, use \\[universal-argument]
+before \\[sql-db2]. Once session has started,
+\\[sql-rename-buffer] can be called separately to rename the
+buffer.
+
To specify a coding system for converting non-ASCII characters
in the input and output to the process, use \\[universal-coding-system-argument]
before \\[sql-db2]. You can also specify this with \\[set-buffer-process-coding-system]
@@ -2823,21 +4207,18 @@ The default comes from `process-coding-system-alist' and
`default-process-coding-system'.
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)"
- (interactive)
- (sql-product-interactive 'db2))
+ (interactive "P")
+ (sql-product-interactive 'db2 buffer))
-(defun sql-connect-db2 ()
- "Create comint buffer and connect to DB2 using the login
-parameters and command options."
+(defun sql-comint-db2 (product options)
+ "Create comint buffer and connect to DB2."
;; Put all parameters to the program (if defined) in a list and call
;; make-comint.
- (set-buffer (apply 'make-comint "SQL" sql-db2-program
- nil sql-db2-options))
- ;; Properly escape newlines when DB2 is interactive.
- (setq comint-input-sender 'sql-escape-newlines-and-send))
+ (sql-comint product options)
+)
;;;###autoload
-(defun sql-linter ()
+(defun sql-linter (&optional buffer)
"Run inl by RELEX as an inferior process.
If buffer `*SQL*' exists but no process is running, make a new process.
@@ -2847,7 +4228,7 @@ If buffer exists and a process is running, just switch to buffer
Interpreter used comes from variable `sql-linter-program' - usually `inl'.
Login uses the variables `sql-user', `sql-password', `sql-database' and
`sql-server' as defaults, if set. Additional command line parameters
-can be stored in the list `sql-linter-options'. Run inl -h to get help on
+can be stored in the list `sql-linter-options'. Run inl -h to get help on
parameters.
`sql-database' is used to set the LINTER_MBX environment variable for
@@ -2859,16 +4240,22 @@ an empty password.
The buffer is put in SQL interactive mode, giving commands for sending
input. See `sql-interactive-mode'.
+To set the buffer name directly, use \\[universal-argument]
+before \\[sql-linter]. Once session has started,
+\\[sql-rename-buffer] can be called separately to rename the
+buffer.
+
\(Type \\[describe-mode] in the SQL buffer for a list of commands.)"
- (interactive)
- (sql-product-interactive 'linter))
+ (interactive "P")
+ (sql-product-interactive 'linter buffer))
-(defun sql-connect-linter ()
- "Create comint buffer and connect to Linter using the login
-parameters and command options."
+(defun sql-comint-linter (product options)
+ "Create comint buffer and connect to Linter."
;; Put all parameters to the program (if defined) in a list and call
;; make-comint.
- (let ((params sql-linter-options) (login nil) (old-mbx (getenv "LINTER_MBX")))
+ (let ((params options)
+ (login nil)
+ (old-mbx (getenv "LINTER_MBX")))
(if (not (string= "" sql-user))
(setq login (concat sql-user "/" sql-password)))
(setq params (append (list "-u" login) params))
@@ -2877,8 +4264,7 @@ parameters and command options."
(if (string= "" sql-database)
(setenv "LINTER_MBX" nil)
(setenv "LINTER_MBX" sql-database))
- (set-buffer (apply 'make-comint "SQL" sql-linter-program nil
- params))
+ (sql-comint product params)
(setenv "LINTER_MBX" old-mbx)))
@@ -2886,3 +4272,4 @@ parameters and command options."
(provide 'sql)
;;; sql.el ends here
+
diff --git a/lisp/progmodes/subword.el b/lisp/progmodes/subword.el
index 4081791ae2e..7df42c8b9a2 100644
--- a/lisp/progmodes/subword.el
+++ b/lisp/progmodes/subword.el
@@ -76,7 +76,7 @@
;; the old `c-forward-into-nomenclature' originally contributed by
;; Terry_Glanfield dot Southern at rxuk dot xerox dot com.
-;; TODO: ispell-word and subword oriented C-w in isearch.
+;; TODO: ispell-word.
;;; Code:
diff --git a/lisp/progmodes/tcl.el b/lisp/progmodes/tcl.el
index cb69d49fcbd..620d236078b 100644
--- a/lisp/progmodes/tcl.el
+++ b/lisp/progmodes/tcl.el
@@ -411,9 +411,10 @@ This variable is generally set from `tcl-proc-regexp',
`tcl-typeword-list', and `tcl-keyword-list' by the function
`tcl-set-font-lock-keywords'.")
-(defvar tcl-font-lock-syntactic-keywords
- ;; Mark the few `#' that are not comment-markers.
- '(("[^;[{ \t\n][ \t]*\\(#\\)" (1 ".")))
+(defconst tcl-syntax-propertize-function
+ (syntax-propertize-rules
+ ;; Mark the few `#' that are not comment-markers.
+ ("[^;[{ \t\n][ \t]*\\(#\\)" (1 ".")))
"Syntactic keywords for `tcl-mode'.")
;; FIXME need some way to recognize variables because array refs look
@@ -545,7 +546,7 @@ Uses variables `tcl-proc-regexp' and `tcl-keyword-list'."
;;
;;;###autoload
-(define-derived-mode tcl-mode nil "Tcl"
+(define-derived-mode tcl-mode prog-mode "Tcl"
"Major mode for editing Tcl code.
Expression and list commands understand all Tcl brackets.
Tab indents for Tcl code.
@@ -593,9 +594,9 @@ Commands:
(set (make-local-variable 'outline-level) 'tcl-outline-level)
(set (make-local-variable 'font-lock-defaults)
- '(tcl-font-lock-keywords nil nil nil beginning-of-defun
- (font-lock-syntactic-keywords . tcl-font-lock-syntactic-keywords)
- (parse-sexp-lookup-properties . t)))
+ '(tcl-font-lock-keywords nil nil nil beginning-of-defun))
+ (set (make-local-variable 'syntax-propertize-function)
+ tcl-syntax-propertize-function)
(set (make-local-variable 'imenu-generic-expression)
tcl-imenu-generic-expression)
@@ -1199,8 +1200,7 @@ as input to future invocations. FLAG is nil if not in comment,
t otherwise. If in comment, leaves point at beginning of comment."
(let ((bol (save-excursion
(goto-char end)
- (beginning-of-line)
- (point)))
+ (line-beginning-position)))
real-comment
last-cstart)
(while (and (not last-cstart) (< (point) end))
@@ -1548,5 +1548,4 @@ The first line is assumed to look like \"#!.../program ...\"."
(provide 'tcl)
-;; arch-tag: 8a032554-c3ef-422e-b84c-acec0522179d
;;; tcl.el ends here
diff --git a/lisp/progmodes/vera-mode.el b/lisp/progmodes/vera-mode.el
index 96877a000a1..0d119503f31 100644
--- a/lisp/progmodes/vera-mode.el
+++ b/lisp/progmodes/vera-mode.el
@@ -770,7 +770,7 @@ the offset is simply returned."
relpos 0)
(setq offset (vera-evaluate-offset offset langelem symbol)))
(+ (if (and relpos
- (< relpos (save-excursion (beginning-of-line) (point))))
+ (< relpos (line-beginning-position)))
(save-excursion
(goto-char relpos)
(current-column))
@@ -1482,5 +1482,4 @@ If `vera-intelligent-tab' is nil, always indent line."
(provide 'vera-mode)
-;; arch-tag: 22eae722-7ac5-47ac-a713-c4db1cf623a9
;;; vera-mode.el ends here
diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el
index a75ed1b47d3..42527ff60eb 100644
--- a/lisp/progmodes/verilog-mode.el
+++ b/lisp/progmodes/verilog-mode.el
@@ -1378,19 +1378,8 @@ If set will become buffer local.")
;; Macros
;;
-(defsubst verilog-get-beg-of-line (&optional arg)
- (save-excursion
- (beginning-of-line arg)
- (point)))
-
-(defsubst verilog-get-end-of-line (&optional arg)
- (save-excursion
- (end-of-line arg)
- (point)))
-
(defsubst verilog-within-string ()
- (save-excursion
- (nth 3 (parse-partial-sexp (verilog-get-beg-of-line) (point)))))
+ (nth 3 (parse-partial-sexp (point-at-bol) (point))))
(defsubst verilog-string-replace-matches (from-string to-string fixedcase literal string)
"Replace occurrences of FROM-STRING with TO-STRING.
@@ -1480,7 +1469,7 @@ This speeds up complicated regexp matches."
(search-forward substr bound noerror))
(save-excursion
(beginning-of-line)
- (setq done (re-search-forward regexp (verilog-get-end-of-line) noerror)))
+ (setq done (re-search-forward regexp (point-at-eol) noerror)))
(unless (and (<= (match-beginning 0) (point))
(>= (match-end 0) (point)))
(setq done nil)))
@@ -1500,7 +1489,7 @@ This speeds up complicated regexp matches."
(search-backward substr bound noerror))
(save-excursion
(end-of-line)
- (setq done (re-search-backward regexp (verilog-get-beg-of-line) noerror)))
+ (setq done (re-search-backward regexp (point-at-bol) noerror)))
(unless (and (<= (match-beginning 0) (point))
(>= (match-end 0) (point)))
(setq done nil)))
@@ -2919,7 +2908,7 @@ Use filename, if current buffer being edited shorten to just buffer name."
(catch 'skip
(if (eq nest 'yes)
(let ((depth 1)
- here )
+ here)
(while (verilog-re-search-forward reg nil 'move)
(cond
((match-end md) ; a closer in regular expression, so we are climbing out
@@ -3925,7 +3914,7 @@ primitive or interface named NAME."
(or kill-existing-comment
(not (save-excursion
(end-of-line)
- (search-backward "//" (verilog-get-beg-of-line) t)))))
+ (search-backward "//" (point-at-bol) t)))))
(let ((nest 1) b e
m
(else (if (match-end 2) "!" " ")))
@@ -3978,7 +3967,7 @@ primitive or interface named NAME."
(or kill-existing-comment
(not (save-excursion
(end-of-line)
- (search-backward "//" (verilog-get-beg-of-line) t)))))
+ (search-backward "//" (point-at-bol) t)))))
(let ((type (car indent-str)))
(unless (eq type 'declaration)
(unless (looking-at (concat "\\(" verilog-end-block-ordered-re "\\)[ \t]*:")) ;; ignore named ends
@@ -4512,7 +4501,7 @@ becomes:
(cond
((looking-at "// surefire lint_off_line ")
(goto-char (match-end 0))
- (let ((lim (save-excursion (end-of-line) (point))))
+ (let ((lim (point-at-eol)))
(if (re-search-forward code lim 'move)
(throw 'already t)
(insert (concat " " code)))))
@@ -8287,8 +8276,7 @@ Some macros and such are also found and included. For dinotrace.el."
": Can't find verilog-getopt-file -f file: " filename)))
(goto-char (point-min))
(while (not (eobp))
- (setq line (buffer-substring (point)
- (save-excursion (end-of-line) (point))))
+ (setq line (buffer-substring (point) (point-at-eol)))
(forward-line 1)
(when (string-match "//" line)
(setq line (substring line 0 (match-beginning 0))))
@@ -11915,7 +11903,7 @@ Clicking on the middle-mouse button loads them in a buffer (as in dired)."
(verilog-save-scan-cache
(let (end-point)
(goto-char end)
- (setq end-point (verilog-get-end-of-line))
+ (setq end-point (point-at-eol))
(goto-char beg)
(beginning-of-line) ; scan entire line
;; delete overlays existing on this line
@@ -12139,5 +12127,4 @@ but instead, [[Fill in here]] happens!.
;; checkdoc-force-docstrings-flag:nil
;; End:
-;; arch-tag: 87923725-57b3-41b5-9494-be21118c6a6f
;;; verilog-mode.el ends here
diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el
index 1210592af18..c7814fed8a0 100644
--- a/lisp/progmodes/vhdl-mode.el
+++ b/lisp/progmodes/vhdl-mode.el
@@ -199,21 +199,6 @@ Examples:
"Customizations for modes."
:group 'vhdl)
-(defcustom vhdl-electric-mode t
- "*Non-nil enables electrification (automatic template generation).
-If nil, template generators can still be invoked through key bindings and
-menu. Is indicated in the modeline by \"/e\" after the mode name and can be
-toggled by `\\[vhdl-electric-mode]'."
- :type 'boolean
- :group 'vhdl-mode)
-
-(defcustom vhdl-stutter-mode t
- "*Non-nil enables stuttering.
-Is indicated in the modeline by \"/s\" after the mode name and can be toggled
-by `\\[vhdl-stutter-mode]'."
- :type 'boolean
- :group 'vhdl-mode)
-
(defcustom vhdl-indent-tabs-mode nil
"*Non-nil means indentation can insert tabs.
Overrides local variable `indent-tabs-mode'."
@@ -3466,13 +3451,11 @@ STRING are replaced by `-' and substrings are converted to lower case."
("Mode"
["Electric Mode"
(progn (customize-set-variable 'vhdl-electric-mode
- (not vhdl-electric-mode))
- (vhdl-mode-line-update))
+ (not vhdl-electric-mode)))
:style toggle :selected vhdl-electric-mode :keys "C-c C-m C-e"]
["Stutter Mode"
(progn (customize-set-variable 'vhdl-stutter-mode
- (not vhdl-stutter-mode))
- (vhdl-mode-line-update))
+ (not vhdl-stutter-mode)))
:style toggle :selected vhdl-stutter-mode :keys "C-c C-m C-s"]
["Indent Tabs Mode"
(progn (customize-set-variable 'vhdl-indent-tabs-mode
@@ -4670,7 +4653,10 @@ Key bindings:
(interactive)
(kill-all-local-variables)
(setq major-mode 'vhdl-mode)
- (setq mode-name "VHDL")
+ (setq mode-name '("VHDL"
+ (vhdl-electric-mode "/" (vhdl-stutter-mode "/"))
+ (vhdl-electric-mode "e")
+ (vhdl-stutter-mode "s")))
;; set maps and tables
(use-local-map vhdl-mode-map)
@@ -4707,8 +4693,15 @@ Key bindings:
(set (make-local-variable 'font-lock-defaults)
(list
'(nil vhdl-font-lock-keywords) nil
- (not vhdl-highlight-case-sensitive) '((?\_ . "w")) 'beginning-of-line
- '(font-lock-syntactic-keywords . vhdl-font-lock-syntactic-keywords)))
+ (not vhdl-highlight-case-sensitive) '((?\_ . "w")) 'beginning-of-line))
+ (if (eval-when-compile (fboundp 'syntax-propertize-rules))
+ (set (make-local-variable 'syntax-propertize-function)
+ (syntax-propertize-rules
+ ;; Mark single quotes as having string quote syntax in
+ ;; 'c' instances.
+ ("\\(\'\\).\\(\'\\)" (1 "\"'") (2 "\"'"))))
+ (set (make-local-variable 'font-lock-syntactic-keywords)
+ vhdl-font-lock-syntactic-keywords))
(unless vhdl-emacs-21
(set (make-local-variable 'font-lock-support-mode) 'lazy-lock-mode)
(set (make-local-variable 'lazy-lock-defer-contextually) nil)
@@ -4737,7 +4730,6 @@ Key bindings:
;; miscellaneous
(vhdl-ps-print-init)
(vhdl-write-file-hooks-init)
- (vhdl-mode-line-update)
(message "VHDL Mode %s.%s" vhdl-version
(if noninteractive "" " See menu for documentation and release notes."))
@@ -4757,8 +4749,7 @@ Key bindings:
(vhdl-write-file-hooks-init)
(vhdl-update-mode-menu)
(vhdl-hideshow-init)
- (run-hooks 'menu-bar-update-hook)
- (vhdl-mode-line-update))
+ (run-hooks 'menu-bar-update-hook))
(defun vhdl-write-file-hooks-init ()
"Add/remove hooks when buffer is saved."
@@ -7278,7 +7269,7 @@ indentation is done before aligning."
(save-excursion
(goto-char begin)
(let (element
- (eol (save-excursion (progn (end-of-line) (point)))))
+ (eol (point-at-eol)))
(setq element (nth 0 copy))
(when (and (or (and (listp (car element))
(memq major-mode (car element)))
@@ -7304,7 +7295,7 @@ the token in MATCH."
;; Determine the greatest whitespace distance to the alignment
;; character
(goto-char begin)
- (setq eol (progn (end-of-line) (point))
+ (setq eol (point-at-eol)
bol (setq begin (progn (beginning-of-line) (point))))
(while (< bol end)
(save-excursion
@@ -7315,13 +7306,13 @@ the token in MATCH."
(setq max distance))))
(forward-line)
(setq bol (point)
- eol (save-excursion (end-of-line) (point)))
+ eol (point-at-eol))
(setq lines (1+ lines)))
;; Now insert enough maxs to push each assignment operator to
;; the same column. We need to use 'lines' as a counter, since
;; the location of the mark may change
(goto-char (setq bol begin))
- (setq eol (save-excursion (end-of-line) (point)))
+ (setq eol (point-at-eol))
(while (> lines 0)
(when (and (re-search-forward match eol t)
(not (vhdl-in-literal)))
@@ -7333,7 +7324,7 @@ the token in MATCH."
(beginning-of-line)
(forward-line)
(setq bol (point)
- eol (save-excursion (end-of-line) (point)))
+ eol (point-at-eol))
(setq lines (1- lines))))))
(defun vhdl-align-region-groups (beg end &optional spacing
@@ -7997,7 +7988,7 @@ buffer."
(forward-char)
(vhdl-forward-syntactic-ws))
(goto-char end)
- (when (> pos (save-excursion (end-of-line) (point)))
+ (when (> pos (point-at-eol))
(error "ERROR: Not within a generic/port clause"))
;; delete closing parenthesis on separate line (not supported style)
(when (save-excursion (beginning-of-line) (looking-at "^\\s-*);"))
@@ -8010,7 +8001,7 @@ buffer."
(condition-case () (forward-sexp)
(error (goto-char (point-max))))
(< (point) end))
- (delete-backward-char 1))
+ (delete-char -1))
;; add closing parenthesis
(when (> (point) end)
(goto-char end)
@@ -8055,31 +8046,15 @@ project is defined."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Enabling/disabling
-(defun vhdl-mode-line-update ()
- "Update the modeline string for VHDL major mode."
- (setq mode-name (concat "VHDL"
- (and (or vhdl-electric-mode vhdl-stutter-mode) "/")
- (and vhdl-electric-mode "e")
- (and vhdl-stutter-mode "s")))
- (force-mode-line-update t))
-
-(defun vhdl-electric-mode (arg)
+(define-minor-mode vhdl-electric-mode
"Toggle VHDL electric mode.
Turn on if ARG positive, turn off if ARG negative, toggle if ARG zero or nil."
- (interactive "P")
- (setq vhdl-electric-mode
- (cond ((or (not arg) (zerop arg)) (not vhdl-electric-mode))
- ((> arg 0) t) (t nil)))
- (vhdl-mode-line-update))
+ :global t)
-(defun vhdl-stutter-mode (arg)
+(define-minor-mode vhdl-stutter-mode
"Toggle VHDL stuttering mode.
Turn on if ARG positive, turn off if ARG negative, toggle if ARG zero or nil."
- (interactive "P")
- (setq vhdl-stutter-mode
- (cond ((or (not arg) (zerop arg)) (not vhdl-stutter-mode))
- ((> arg 0) t) (t nil)))
- (vhdl-mode-line-update))
+ :global t)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Stuttering
@@ -8137,7 +8112,7 @@ Turn on if ARG positive, turn off if ARG negative, toggle if ARG zero or nil."
(interactive "p")
(if (and vhdl-stutter-mode (= count 1) (not (vhdl-in-literal)))
(if (= (preceding-char) last-input-event)
- (progn (delete-backward-char 1) (insert-char ?\" 1))
+ (progn (delete-char -1) (insert-char ?\" 1))
(insert-char ?\' 1))
(self-insert-command count)))
@@ -8204,7 +8179,7 @@ Turn on if ARG positive, turn off if ARG negative, toggle if ARG zero or nil."
(unless (vhdl-template-field
(concat "[type" (and (vhdl-standard-p 'ams) " or nature") "]")
nil t)
- (delete-backward-char 3))
+ (delete-char -3))
(vhdl-insert-keyword " IS ")
(vhdl-template-field "name" ";")
(vhdl-comment-insert-inline))))
@@ -8568,7 +8543,7 @@ a configuration declaration if not within a design unit."
(vhdl-template-field "library name" "." nil nil nil nil
(vhdl-work-library))
(vhdl-template-field "configuration name" ";"))
- (t (delete-backward-char 1) (insert ";") t))))))
+ (t (delete-char -1) (insert ";") t))))))
(defun vhdl-template-configuration-decl ()
@@ -8735,7 +8710,7 @@ a configuration declaration if not within a design unit."
(vhdl-insert-keyword " OPEN ")
(unless (vhdl-template-field "[READ_MODE | WRITE_MODE | APPEND_MODE]"
nil t)
- (delete-backward-char 6)))
+ (delete-char -6)))
(vhdl-insert-keyword " IS ")
(when (vhdl-standard-p '87)
(vhdl-template-field "[IN | OUT]" " " t))
@@ -9063,7 +9038,7 @@ otherwise."
(insert "\n")
(indent-to margin))
(delete-region end-pos (point))
- (delete-backward-char 1)
+ (delete-char -1)
(insert ")")
(when vhdl-auto-align (vhdl-align-region-groups start (point) 1))
t)
@@ -9437,7 +9412,7 @@ otherwise."
(vhdl-insert-keyword "REPORT ")
(if (equal "\"\"" (vhdl-template-field
"string expression" nil t start (point) t))
- (delete-backward-char 2)
+ (delete-char -2)
(setq start (point))
(vhdl-insert-keyword " SEVERITY ")
(unless (vhdl-template-field "[NOTE | WARNING | ERROR | FAILURE]" nil t)
@@ -9585,7 +9560,7 @@ otherwise."
"[scalar type | ARRAY | RECORD | ACCESS | FILE]" nil t)
""))))
(cond ((equal definition "")
- (delete-backward-char 4)
+ (delete-char -4)
(insert ";"))
((equal definition "ARRAY")
(delete-region (point) (progn (forward-word -1) (point)))
@@ -10085,13 +10060,13 @@ If starting after end-comment-column, start a new line."
(if (not (or (and string (progn (insert string) t))
(vhdl-template-field "[comment]" nil t)))
(delete-region position (point))
- (while (= (preceding-char) ? ) (delete-backward-char 1))
-; (when (> (current-column) end-comment-column)
-; (setq position (point-marker))
-; (re-search-backward "-- ")
-; (insert "\n")
-; (indent-to comment-column)
-; (goto-char position))
+ (while (= (preceding-char) ?\ ) (delete-char -1))
+ ;; (when (> (current-column) end-comment-column)
+ ;; (setq position (point-marker))
+ ;; (re-search-backward "-- ")
+ ;; (insert "\n")
+ ;; (indent-to comment-column)
+ ;; (goto-char position))
))))
(defun vhdl-comment-block ()
@@ -10224,7 +10199,7 @@ Point is left between them."
(when semicolon-pos (goto-char semicolon-pos))
(if not-empty
(progn (delete-char 1) (insert ")"))
- (delete-backward-char 2))))
+ (delete-char -2))))
(defun vhdl-template-generic-list (optional &optional no-value)
"Read from user a generic spec argument list."
@@ -12140,9 +12115,7 @@ options vhdl-upper-case-{keywords,types,attributes,enum-values}."
"Return the line number of the line containing point."
(save-restriction
(widen)
- (save-excursion
- (beginning-of-line)
- (1+ (count-lines (point-min) (point))))))
+ (1+ (count-lines (point-min) (point-at-bol)))))
(defun vhdl-line-kill-entire (&optional arg)
"Delete entire line."
@@ -12159,8 +12132,7 @@ options vhdl-upper-case-{keywords,types,attributes,enum-values}."
"Copy current line."
(interactive "p")
(save-excursion
- (beginning-of-line)
- (let ((position (point)))
+ (let ((position (point-at-bol)))
(forward-line (or arg 1))
(copy-region-as-kill position (point)))))
@@ -12533,7 +12505,7 @@ File statistics: \"%s\"\n\
(add-hook 'hs-minor-mode-hook 'hs-hide-all)
(remove-hook 'hs-minor-mode-hook 'hs-hide-all))
(hs-minor-mode arg)
- (vhdl-mode-line-update))) ; hack to update menu bar
+ (force-mode-line-update))) ; hack to update menu bar
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -12946,10 +12918,9 @@ This does background highlighting of translate-off regions.")
"Re-initialize fontification and fontify buffer."
(interactive)
(setq font-lock-defaults
- (list
- 'vhdl-font-lock-keywords nil
- (not vhdl-highlight-case-sensitive) '((?\_ . "w")) 'beginning-of-line
- '(font-lock-syntactic-keywords . vhdl-font-lock-syntactic-keywords)))
+ `(vhdl-font-lock-keywords
+ nil ,(not vhdl-highlight-case-sensitive) ((?\_ . "w"))
+ beginning-of-line))
(when (fboundp 'font-lock-unset-defaults)
(font-lock-unset-defaults)) ; not implemented in XEmacs
(font-lock-set-defaults)
@@ -15942,7 +15913,7 @@ current project/directory."
&optional insert-conf)
"Generate block configuration for architecture."
(let ((margin (current-indentation))
- (beg (save-excursion (beginning-of-line) (point)))
+ (beg (point-at-bol))
ent-entry inst-entry inst-path inst-prev-path cons-key tmp-alist)
;; insert block configuration (for architecture)
(vhdl-insert-keyword "FOR ") (insert arch-name "\n")
@@ -17003,5 +16974,4 @@ to visually support naming conventions.")
(provide 'vhdl-mode)
-;; arch-tag: 780d7073-9b5d-4c6c-b0d8-26b28783aba3
;;; vhdl-mode.el ends here
diff --git a/lisp/progmodes/xscheme.el b/lisp/progmodes/xscheme.el
index 0324bc3c5b2..217424b9424 100644
--- a/lisp/progmodes/xscheme.el
+++ b/lisp/progmodes/xscheme.el
@@ -701,12 +701,7 @@ parse an expression from the beginning of the line and send that instead."
"Send the current line to the Scheme process.
Useful for working with debugging Scheme under adb."
(interactive)
- (let ((line
- (save-excursion
- (beginning-of-line)
- (let ((start (point)))
- (end-of-line)
- (buffer-substring start (point))))))
+ (let ((line (buffer-substring (line-beginning-position) (line-end-position))))
(end-of-line)
(insert ?\n)
(xscheme-send-string-2 line)))
@@ -1224,5 +1219,4 @@ the remaining input.")
(provide 'xscheme)
-;; arch-tag: cfc14adc-2917-409e-ad16-432e8d0017de
;;; xscheme.el ends here
diff --git a/lisp/ps-bdf.el b/lisp/ps-bdf.el
index 65ec4bf101a..585b5f9eb69 100644
--- a/lisp/ps-bdf.el
+++ b/lisp/ps-bdf.el
@@ -15,6 +15,7 @@
;; Author: Kenichi Handa <handa@m17n.org>
;; (according to ack.texi)
;; Keywords: wp, BDF, font, PostScript
+;; Package: ps-print
;; This file is part of GNU Emacs.
diff --git a/lisp/ps-def.el b/lisp/ps-def.el
index 5e045bccf9a..9122b8fdc9a 100644
--- a/lisp/ps-def.el
+++ b/lisp/ps-def.el
@@ -8,6 +8,7 @@
;; Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, print, PostScript
;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
+;; Package: ps-print
;; This file is part of GNU Emacs.
@@ -49,95 +50,25 @@
(cond
((featurep 'xemacs) ; XEmacs
-
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ps-bdf
(defvar installation-directory nil)
(defvar coding-system-for-read)
-
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ps-mule
- (defvar leading-code-private-22 157)
-
- (or (fboundp 'charset-bytes)
- (defun charset-bytes (charset) 1)) ; ascii
-
(or (fboundp 'charset-dimension)
(defun charset-dimension (charset) 1)) ; ascii
- (or (fboundp 'charset-id)
- (defun charset-id (charset) 0)) ; ascii
-
- (or (fboundp 'charset-width)
- (defun charset-width (charset) 1)) ; ascii
-
- (or (fboundp 'find-charset-region)
- (defun find-charset-region (beg end &optional table)
- (list 'ascii)))
-
(or (fboundp 'char-width)
(defun char-width (char) 1)) ; ascii
- (or (fboundp 'chars-in-region)
- (defun chars-in-region (beg end)
- (- (max beg end) (min beg end))))
-
- (or (fboundp 'forward-point)
- (defun forward-point (arg)
- (save-excursion
- (let ((count (abs arg))
- (step (if (zerop arg)
- 0
- (/ arg arg))))
- (while (and (> count 0)
- (< (point-min) (point)) (< (point) (point-max)))
- (forward-char step)
- (setq count (1- count)))
- (+ (point) (* count step))))))
-
- (or (fboundp 'decompose-composite-char)
- (defun decompose-composite-char (char &optional type
- with-composition-rule)
- nil))
-
- (or (fboundp 'encode-coding-string)
- (defun encode-coding-string (string coding-system &optional nocopy)
- (if nocopy
- string
- (copy-sequence string))))
-
- (or (fboundp 'coding-system-p)
- (defun coding-system-p (obj) nil))
-
- (or (fboundp 'ccl-execute-on-string)
- (defun ccl-execute-on-string (ccl-prog status str
- &optional contin unibyte-p)
- str))
-
- (or (fboundp 'define-ccl-program)
- (defmacro define-ccl-program (name ccl-program &optional doc)
- `(defconst ,name nil ,doc)))
-
- (or (fboundp 'multibyte-string-p)
- (defun multibyte-string-p (str)
- (let ((len (length str))
- (i 0)
- multibyte)
- (while (and (< i len) (not (setq multibyte (> (aref str i) 255))))
- (setq i (1+ i)))
- multibyte)))
-
- (or (fboundp 'string-make-multibyte)
- (defalias 'string-make-multibyte 'copy-sequence))
-
(or (fboundp 'encode-char)
(defun encode-char (ch ccs)
ch))
-
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ps-print
diff --git a/lisp/ps-mule.el b/lisp/ps-mule.el
index 0fcb6dff79b..95a982f29a2 100644
--- a/lisp/ps-mule.el
+++ b/lisp/ps-mule.el
@@ -8,6 +8,7 @@
;; Maintainer: Kenichi Handa <handa@m17n.org> (multi-byte characters)
;; Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, print, PostScript, multibyte, mule
+;; Package: ps-print
;; This file is part of GNU Emacs.
diff --git a/lisp/ps-print.el b/lisp/ps-print.el
index 69b32e5d52d..885fe68be26 100644
--- a/lisp/ps-print.el
+++ b/lisp/ps-print.el
@@ -1466,12 +1466,9 @@ Please send all bug fixes and enhancements to
(require 'lpr)
-(or (featurep 'lisp-float-type)
- (error "`ps-print' requires floating point support"))
-
-
(if (featurep 'xemacs)
- ()
+ (or (featurep 'lisp-float-type)
+ (error "`ps-print' requires floating point support"))
(unless (and (boundp 'emacs-major-version)
(>= emacs-major-version 23))
(error "`ps-print' only supports Emacs 23 and higher")))
@@ -1497,7 +1494,7 @@ Please send all bug fixes and enhancements to
"Support for printing and PostScript."
:tag "PostScript"
:version "20"
- :group 'emacs)
+ :group 'external)
(defgroup ps-print nil
"PostScript generator for Emacs."
@@ -6656,7 +6653,7 @@ If FACE is not a valid face name, use default face."
;; But autoload them here to make the separation invisible.
;;;### (autoloads (ps-mule-end-job ps-mule-begin-job ps-mule-initialize
-;;;;;; ps-multibyte-buffer) "ps-mule" "ps-mule.el" "18a8bc30e8755ff27de7267f4bce3d99")
+;;;;;; ps-multibyte-buffer) "ps-mule" "ps-mule.el" "26f1d5db9476d0e84ab55627fbb72b1b")
;;; Generated autoloads from ps-mule.el
(defvar ps-multibyte-buffer nil "\
@@ -6726,5 +6723,4 @@ Finish printing job for multi-byte chars.
(provide 'ps-print)
-;; arch-tag: fb06a585-1112-4206-885d-a57d95d50579
;;; ps-print.el ends here
diff --git a/lisp/ps-samp.el b/lisp/ps-samp.el
index 5ad1c6855d0..9fab290fc52 100644
--- a/lisp/ps-samp.el
+++ b/lisp/ps-samp.el
@@ -10,6 +10,7 @@
;; Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, print, PostScript
;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
+;; Package: ps-print
;; This file is part of GNU Emacs.
diff --git a/lisp/rect.el b/lisp/rect.el
index facc6d51858..66584089910 100644
--- a/lisp/rect.el
+++ b/lisp/rect.el
@@ -5,6 +5,7 @@
;; Maintainer: Didier Verna <didier@xemacs.org>
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/register.el b/lisp/register.el
index 1a6d84d2c17..97b6eb0dfc8 100644
--- a/lisp/register.el
+++ b/lisp/register.el
@@ -5,6 +5,7 @@
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/repeat.el b/lisp/repeat.el
index b82522ef855..abab47e7dc8 100644
--- a/lisp/repeat.el
+++ b/lisp/repeat.el
@@ -5,7 +5,7 @@
;; Author: Will Mengarini <seldon@eskimo.com>
;; Created: Mo 02 Mar 98
-;; Version: 0.51, We 13 May 98
+;; Version: 0.51
;; Keywords: convenience, vi, repeat
;; This file is part of GNU Emacs.
diff --git a/lisp/replace.el b/lisp/replace.el
index 12263cf5aa6..baea2820433 100644
--- a/lisp/replace.el
+++ b/lisp/replace.el
@@ -5,6 +5,7 @@
;; Free Software Foundation, Inc.
;; Maintainer: FSF
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -33,7 +34,10 @@
:type 'boolean
:group 'matching)
-(defvar query-replace-history nil)
+(defvar query-replace-history nil
+ "Default history list for query-replace commands.
+See `query-replace-from-history-variable' and
+`query-replace-to-history-variable'.")
(defvar query-replace-defaults nil
"Default values of FROM-STRING and TO-STRING for `query-replace'.
@@ -394,12 +398,13 @@ Fourth and fifth arg START and END specify the region to operate on."
(car regexp-search-ring)
(read-from-minibuffer "Map query replace (regexp): "
nil nil nil
- 'query-replace-history nil t)))
+ query-replace-from-history-variable
+ nil t)))
(to (read-from-minibuffer
(format "Query replace %s with (space-separated strings): "
(query-replace-descr from))
nil nil nil
- 'query-replace-history from t)))
+ query-replace-to-history-variable from t)))
(list from to
(and current-prefix-arg
(prefix-numeric-value current-prefix-arg))
@@ -1001,32 +1006,6 @@ which means to discard all text properties."
:group 'matching
:version "22.1")
-(defun occur-accumulate-lines (count &optional keep-props)
- (save-excursion
- (let ((forwardp (> count 0))
- result beg end)
- (while (not (or (zerop count)
- (if forwardp
- (eobp)
- (bobp))))
- (setq count (+ count (if forwardp -1 1)))
- (setq beg (line-beginning-position)
- end (line-end-position))
- (if (and keep-props (if (boundp 'jit-lock-mode) jit-lock-mode)
- (text-property-not-all beg end 'fontified t))
- (if (fboundp 'jit-lock-fontify-now)
- (jit-lock-fontify-now beg end)))
- (push
- (if (and keep-props (not (eq occur-excluded-properties t)))
- (let ((str (buffer-substring beg end)))
- (remove-list-of-text-properties
- 0 (length str) occur-excluded-properties str)
- str)
- (buffer-substring-no-properties beg end))
- result)
- (forward-line (if forwardp 1 -1)))
- (nreverse result))))
-
(defun occur-read-primary-args ()
(list (read-regexp "List lines matching regexp"
(car regexp-history))
@@ -1035,7 +1014,7 @@ which means to discard all text properties."
(defun occur-rename-buffer (&optional unique-p interactive-p)
"Rename the current *Occur* buffer to *Occur: original-buffer-name*.
-Here `original-buffer-name' is the buffer name were Occur was originally run.
+Here `original-buffer-name' is the buffer name where Occur was originally run.
When given the prefix argument, or called non-interactively, the renaming
will not clobber the existing buffer(s) of that name, but use
`generate-new-buffer-name' instead. You can add this to `occur-hook'
@@ -1052,7 +1031,7 @@ invoke `occur'."
(defun occur (regexp &optional nlines)
"Show all lines in the current buffer containing a match for REGEXP.
-This function can not handle matches that span more than one line.
+If a match spreads across multiple lines, all those lines are shown.
Each line is displayed with NLINES lines before and after, or -NLINES
before if NLINES is negative.
@@ -1162,12 +1141,15 @@ See also `multi-occur'."
(not (eq occur-excluded-properties t)))))
(let* ((bufcount (length active-bufs))
(diff (- (length bufs) bufcount)))
- (message "Searched %d buffer%s%s; %s match%s for `%s'"
+ (message "Searched %d buffer%s%s; %s match%s%s"
bufcount (if (= bufcount 1) "" "s")
(if (zerop diff) "" (format " (%d killed)" diff))
(if (zerop count) "no" (format "%d" count))
(if (= count 1) "" "es")
- regexp))
+ ;; Don't display regexp if with remaining text
+ ;; it is longer than window-width.
+ (if (> (+ (length regexp) 42) (window-width))
+ "" (format " for `%s'" (query-replace-descr regexp)))))
(setq occur-revert-arguments (list regexp nlines bufs))
(if (= count 0)
(kill-buffer occur-buf)
@@ -1177,12 +1159,6 @@ See also `multi-occur'."
(set-buffer-modified-p nil)
(run-hooks 'occur-hook)))))))
-(defun occur-engine-add-prefix (lines)
- (mapcar
- #'(lambda (line)
- (concat " :" line "\n"))
- lines))
-
(defun occur-engine (regexp buffers out-buf nlines case-fold-search
title-face prefix-face match-face keep-props)
(with-current-buffer out-buf
@@ -1193,12 +1169,15 @@ See also `multi-occur'."
(when (buffer-live-p buf)
(let ((matches 0) ;; count of matched lines
(lines 1) ;; line count
+ (prev-after-lines nil) ;; context lines of prev match
+ (prev-lines nil) ;; line number of prev match endpt
(matchbeg 0)
(origpt nil)
(begpt nil)
(endpt nil)
(marker nil)
(curstring "")
+ (ret nil)
(inhibit-field-text-motion t)
(headerpt (with-current-buffer out-buf (point))))
(with-current-buffer buf
@@ -1214,24 +1193,17 @@ See also `multi-occur'."
(when (setq endpt (re-search-forward regexp nil t))
(setq matches (1+ matches)) ;; increment match count
(setq matchbeg (match-beginning 0))
- (setq lines (+ lines (1- (count-lines origpt endpt))))
+ ;; Get beginning of first match line and end of the last.
(save-excursion
(goto-char matchbeg)
- (setq begpt (line-beginning-position)
- endpt (line-end-position)))
+ (setq begpt (line-beginning-position))
+ (goto-char endpt)
+ (setq endpt (line-end-position)))
+ ;; Sum line numbers up to the first match line.
+ (setq lines (+ lines (count-lines origpt begpt)))
(setq marker (make-marker))
(set-marker marker matchbeg)
- (if (and keep-props
- (if (boundp 'jit-lock-mode) jit-lock-mode)
- (text-property-not-all begpt endpt 'fontified t))
- (if (fboundp 'jit-lock-fontify-now)
- (jit-lock-fontify-now begpt endpt)))
- (if (and keep-props (not (eq occur-excluded-properties t)))
- (progn
- (setq curstring (buffer-substring begpt endpt))
- (remove-list-of-text-properties
- 0 (length curstring) occur-excluded-properties curstring))
- (setq curstring (buffer-substring-no-properties begpt endpt)))
+ (setq curstring (occur-engine-line begpt endpt keep-props))
;; Highlight the matches
(let ((len (length curstring))
(start 0))
@@ -1248,24 +1220,33 @@ See also `multi-occur'."
curstring)
(setq start (match-end 0))))
;; Generate the string to insert for this match
- (let* ((out-line
+ (let* ((match-prefix
+ ;; Using 7 digits aligns tabs properly.
+ (apply #'propertize (format "%7d:" lines)
+ (append
+ (when prefix-face
+ `(font-lock-face prefix-face))
+ `(occur-prefix t mouse-face (highlight)
+ occur-target ,marker follow-link t
+ help-echo "mouse-2: go to this occurrence"))))
+ (match-str
+ ;; We don't put `mouse-face' on the newline,
+ ;; because that loses. And don't put it
+ ;; on context lines to reduce flicker.
+ (propertize curstring 'mouse-face (list 'highlight)
+ 'occur-target marker
+ 'follow-link t
+ 'help-echo
+ "mouse-2: go to this occurrence"))
+ (out-line
(concat
- ;; Using 7 digits aligns tabs properly.
- (apply #'propertize (format "%7d:" lines)
- (append
- (when prefix-face
- `(font-lock-face prefix-face))
- `(occur-prefix t mouse-face (highlight)
- occur-target ,marker follow-link t
- help-echo "mouse-2: go to this occurrence")))
- ;; We don't put `mouse-face' on the newline,
- ;; because that loses. And don't put it
- ;; on context lines to reduce flicker.
- (propertize curstring 'mouse-face (list 'highlight)
- 'occur-target marker
- 'follow-link t
- 'help-echo
- "mouse-2: go to this occurrence")
+ match-prefix
+ ;; Add non-numeric prefix to all non-first lines
+ ;; of multi-line matches.
+ (replace-regexp-in-string
+ "\n"
+ "\n :"
+ match-str)
;; Add marker at eol, but no mouse props.
(propertize "\n" 'occur-target marker)))
(data
@@ -1273,30 +1254,47 @@ See also `multi-occur'."
;; The simple display style
out-line
;; The complex multi-line display style.
- (occur-context-lines out-line nlines keep-props)
- )))
+ (setq ret (occur-context-lines
+ out-line nlines keep-props begpt endpt
+ lines prev-lines prev-after-lines))
+ ;; Set first elem of the returned list to `data',
+ ;; and the second elem to `prev-after-lines'.
+ (setq prev-after-lines (nth 1 ret))
+ (nth 0 ret))))
;; Actually insert the match display data
(with-current-buffer out-buf
(let ((beg (point))
- (end (progn (insert data) (point))))
- (unless (= nlines 0)
- (insert "-------\n")))))
+ (end (progn (insert data) (point)))))))
(goto-char endpt))
(if endpt
(progn
- (setq lines (1+ lines))
+ ;; Sum line numbers between first and last match lines.
+ (setq lines (+ lines (count-lines begpt endpt)
+ ;; Add 1 for empty last match line since
+ ;; count-lines returns 1 line less.
+ (if (and (bolp) (eolp)) 1 0)))
;; On to the next match...
(forward-line 1))
- (goto-char (point-max))))))
+ (goto-char (point-max)))
+ (setq prev-lines (1- lines)))
+ ;; Flush remaining context after-lines.
+ (when prev-after-lines
+ (with-current-buffer out-buf
+ (insert (apply #'concat (occur-engine-add-prefix
+ prev-after-lines)))))))
(when (not (zerop matches)) ;; is the count zero?
(setq globalcount (+ globalcount matches))
(with-current-buffer out-buf
(goto-char headerpt)
(let ((beg (point))
end)
- (insert (format "%d match%s for \"%s\" in buffer: %s\n"
+ (insert (format "%d match%s%s in buffer: %s\n"
matches (if (= matches 1) "" "es")
- regexp (buffer-name buf)))
+ ;; Don't display regexp for multi-buffer.
+ (if (> (length buffers) 1)
+ "" (format " for \"%s\""
+ (query-replace-descr regexp)))
+ (buffer-name buf)))
(setq end (point))
(add-text-properties beg end
(append
@@ -1304,6 +1302,18 @@ See also `multi-occur'."
`(font-lock-face ,title-face))
`(occur-title ,buf))))
(goto-char (point-min)))))))
+ ;; Display total match count and regexp for multi-buffer.
+ (when (and (not (zerop globalcount)) (> (length buffers) 1))
+ (goto-char (point-min))
+ (let ((beg (point))
+ end)
+ (insert (format "%d match%s total for \"%s\":\n"
+ globalcount (if (= globalcount 1) "" "es")
+ (query-replace-descr regexp)))
+ (setq end (point))
+ (add-text-properties beg end (when title-face
+ `(font-lock-face ,title-face))))
+ (goto-char (point-min)))
(if coding
;; CODING is buffer-file-coding-system of the first buffer
;; that locally binds it. Let's use it also for the output
@@ -1312,21 +1322,98 @@ See also `multi-occur'."
;; Return the number of matches
globalcount)))
+(defun occur-engine-line (beg end &optional keep-props)
+ (if (and keep-props (if (boundp 'jit-lock-mode) jit-lock-mode)
+ (text-property-not-all beg end 'fontified t))
+ (if (fboundp 'jit-lock-fontify-now)
+ (jit-lock-fontify-now beg end)))
+ (if (and keep-props (not (eq occur-excluded-properties t)))
+ (let ((str (buffer-substring beg end)))
+ (remove-list-of-text-properties
+ 0 (length str) occur-excluded-properties str)
+ str)
+ (buffer-substring-no-properties beg end)))
+
+(defun occur-engine-add-prefix (lines)
+ (mapcar
+ #'(lambda (line)
+ (concat " :" line "\n"))
+ lines))
+
+(defun occur-accumulate-lines (count &optional keep-props pt)
+ (save-excursion
+ (when pt
+ (goto-char pt))
+ (let ((forwardp (> count 0))
+ result beg end moved)
+ (while (not (or (zerop count)
+ (if forwardp
+ (eobp)
+ (and (bobp) (not moved)))))
+ (setq count (+ count (if forwardp -1 1)))
+ (setq beg (line-beginning-position)
+ end (line-end-position))
+ (push (occur-engine-line beg end keep-props) result)
+ (setq moved (= 0 (forward-line (if forwardp 1 -1)))))
+ (nreverse result))))
+
;; Generate context display for occur.
;; OUT-LINE is the line where the match is.
;; NLINES and KEEP-PROPS are args to occur-engine.
+;; LINES is line count of the current match,
+;; PREV-LINES is line count of the previous match,
+;; PREV-AFTER-LINES is a list of after-context lines of the previous match.
;; Generate a list of lines, add prefixes to all but OUT-LINE,
;; then concatenate them all together.
-(defun occur-context-lines (out-line nlines keep-props)
- (apply #'concat
- (nconc
- (occur-engine-add-prefix
- (nreverse (cdr (occur-accumulate-lines
- (- (1+ (abs nlines))) keep-props))))
- (list out-line)
- (if (> nlines 0)
- (occur-engine-add-prefix
- (cdr (occur-accumulate-lines (1+ nlines) keep-props)))))))
+(defun occur-context-lines (out-line nlines keep-props begpt endpt
+ lines prev-lines prev-after-lines)
+ ;; Find after- and before-context lines of the current match.
+ (let ((before-lines
+ (nreverse (cdr (occur-accumulate-lines
+ (- (1+ (abs nlines))) keep-props begpt))))
+ (after-lines
+ (cdr (occur-accumulate-lines
+ (1+ nlines) keep-props endpt)))
+ separator)
+
+ ;; Combine after-lines of the previous match
+ ;; with before-lines of the current match.
+
+ (when prev-after-lines
+ ;; Don't overlap prev after-lines with current before-lines.
+ (if (>= (+ prev-lines (length prev-after-lines))
+ (- lines (length before-lines)))
+ (setq prev-after-lines
+ (butlast prev-after-lines
+ (- (length prev-after-lines)
+ (- lines prev-lines (length before-lines) 1))))
+ ;; Separate non-overlapping context lines with a dashed line.
+ (setq separator "-------\n")))
+
+ (when prev-lines
+ ;; Don't overlap current before-lines with previous match line.
+ (if (<= (- lines (length before-lines))
+ prev-lines)
+ (setq before-lines
+ (nthcdr (- (length before-lines)
+ (- lines prev-lines 1))
+ before-lines))
+ ;; Separate non-overlapping before-context lines.
+ (unless (> nlines 0)
+ (setq separator "-------\n"))))
+
+ (list
+ ;; Return a list where the first element is the output line.
+ (apply #'concat
+ (append
+ (and prev-after-lines
+ (occur-engine-add-prefix prev-after-lines))
+ (and separator (list separator))
+ (occur-engine-add-prefix before-lines)
+ (list out-line)))
+ ;; And the second element is the list of context after-lines.
+ (if (> nlines 0) after-lines))))
+
;; It would be nice to use \\[...], but there is no reasonable way
;; to make that display both SPC and Y.
@@ -1896,6 +1983,9 @@ make, or the user didn't cancel the call."
(isearch-case-fold-search case-fold)
(isearch-forward t)
(isearch-error nil))
+ ;; Set isearch-word to nil because word-replace is regexp-based,
+ ;; so `isearch-search-fun' should not use `word-search-forward'.
+ (if (and isearch-word isearch-regexp) (setq isearch-word nil))
(isearch-lazy-highlight-new-loop range-beg range-end))))
(defun replace-dehighlight ()
diff --git a/lisp/reposition.el b/lisp/reposition.el
index 9bc00795fe1..f6699f8c088 100644
--- a/lisp/reposition.el
+++ b/lisp/reposition.el
@@ -1,7 +1,7 @@
;;; reposition.el --- center a Lisp function or comment on the screen
-;; Copyright (C) 1991, 1994, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1991, 1994, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Michael D. Ernst <mernst@theory.lcs.mit.edu>
;; Created: Jan 1991
@@ -58,7 +58,7 @@ visible (if point is in code and it could not be made so, or if only
comments, including the first comment line, are visible), or to make the
first comment line visible (if point is in a comment)."
(interactive "P")
- (let* (;; (here (save-excursion (beginning-of-line) (point)))
+ (let* (;; (here (line-beginning-position))
(here (point))
;; change this name once I've gotten rid of references to ht.
;; this is actually the number of the last screen line
@@ -193,5 +193,4 @@ first comment line visible (if point is in a comment)."
(provide 'reposition)
-;; arch-tag: 79487039-3bd7-4ab5-a3e8-ecf3b4919010
;;; reposition.el ends here
diff --git a/lisp/reveal.el b/lisp/reveal.el
index 9838ade89f1..ff5c8807de5 100644
--- a/lisp/reveal.el
+++ b/lisp/reveal.el
@@ -49,7 +49,7 @@
(defgroup reveal nil
"Reveal hidden text on the fly."
- :group 'editing)
+ :group 'convenience)
(defcustom reveal-around-mark t
"Reveal text around the mark, if active."
diff --git a/lisp/rfn-eshadow.el b/lisp/rfn-eshadow.el
index 7c2cf0f96f5..fa7a9336156 100644
--- a/lisp/rfn-eshadow.el
+++ b/lisp/rfn-eshadow.el
@@ -5,6 +5,7 @@
;;
;; Author: Miles Bader <miles@gnu.org>
;; Keywords: convenience minibuffer
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/ruler-mode.el b/lisp/ruler-mode.el
index e3895efac8a..1c809bbd7e0 100644
--- a/lisp/ruler-mode.el
+++ b/lisp/ruler-mode.el
@@ -550,21 +550,36 @@ This variable is expected to be made buffer-local by modes.")
Call `ruler-mode-ruler-function' to compute the ruler value.")
;;;###autoload
+(defvar ruler-mode nil
+ "Non-nil if Ruler mode is enabled.
+Use the command `ruler-mode' to change this variable.")
+(make-variable-buffer-local 'ruler-mode)
+
+(defun ruler--save-header-line-format ()
+ "Install the header line format for Ruler mode.
+Unless Ruler mode is already enabled, save the old header line
+format first."
+ (when (and (not ruler-mode)
+ (local-variable-p 'header-line-format)
+ (not (local-variable-p 'ruler-mode-header-line-format-old)))
+ (set (make-local-variable 'ruler-mode-header-line-format-old)
+ header-line-format))
+ (setq header-line-format ruler-mode-header-line-format))
+
+;;;###autoload
(define-minor-mode ruler-mode
- "Display a ruler in the header line if ARG > 0."
+ "Toggle Ruler mode.
+In Ruler mode, Emacs displays a ruler in the header line."
nil nil
ruler-mode-map
:group 'ruler-mode
+ :variable (ruler-mode
+ . (lambda (enable)
+ (when enable
+ (ruler--save-header-line-format))
+ (setq ruler-mode enable)))
(if ruler-mode
- (progn
- ;; When `ruler-mode' is on save previous header line format
- ;; and install the ruler header line format.
- (when (and (local-variable-p 'header-line-format)
- (not (local-variable-p 'ruler-mode-header-line-format-old)))
- (set (make-local-variable 'ruler-mode-header-line-format-old)
- header-line-format))
- (setq header-line-format ruler-mode-header-line-format)
- (add-hook 'post-command-hook 'force-mode-line-update nil t))
+ (add-hook 'post-command-hook 'force-mode-line-update nil t)
;; When `ruler-mode' is off restore previous header line format if
;; the current one is the ruler header line format.
(when (eq header-line-format ruler-mode-header-line-format)
diff --git a/lisp/savehist.el b/lisp/savehist.el
index eebc5ec942b..15c841ac9c7 100644
--- a/lisp/savehist.el
+++ b/lisp/savehist.el
@@ -59,17 +59,6 @@
:version "22.1"
:group 'minibuffer)
-;;;###autoload
-(defcustom savehist-mode nil
- "Mode for automatic saving of minibuffer history.
-Set this by calling the `savehist-mode' function or using the customize
-interface."
- :type 'boolean
- :set (lambda (symbol value) (savehist-mode (or value 0)))
- :initialize 'custom-initialize-default
- :require 'savehist
- :group 'savehist)
-
(defcustom savehist-save-minibuffer-history t
"If non-nil, save all recorded minibuffer histories.
If you want to save only specific histories, use `savehist-save-hook' to
@@ -181,7 +170,7 @@ minibuffer history.")
;; Functions.
;;;###autoload
-(defun savehist-mode (arg)
+(define-minor-mode savehist-mode
"Toggle savehist-mode.
Positive ARG turns on `savehist-mode'. When on, savehist-mode causes
minibuffer history to be saved periodically and when exiting Emacs.
@@ -191,11 +180,7 @@ previous minibuffer history to be loaded from `savehist-file'.
This mode should normally be turned on from your Emacs init file.
Calling it at any other time replaces your current minibuffer histories,
which is probably undesirable."
- (interactive "P")
- (setq savehist-mode
- (if (null arg)
- (not savehist-mode)
- (> (prefix-numeric-value arg) 0)))
+ :global t
(if (not savehist-mode)
(savehist-uninstall)
(when (and (not savehist-loaded)
@@ -214,11 +199,7 @@ which is probably undesirable."
(setq savehist-mode nil)
(savehist-uninstall)
(signal (car errvar) (cdr errvar)))))
- (savehist-install)
- (run-hooks 'savehist-mode-hook))
- ;; Return the new setting.
- savehist-mode)
-(add-minor-mode 'savehist-mode "")
+ (savehist-install)))
(defun savehist-load ()
"Load the variables stored in `savehist-file' and turn on `savehist-mode'.
diff --git a/lisp/scroll-all.el b/lisp/scroll-all.el
index 458e2be07a1..4f9747cb90a 100644
--- a/lisp/scroll-all.el
+++ b/lisp/scroll-all.el
@@ -90,9 +90,9 @@
(call-interactively 'scroll-all-scroll-down-all))
((eq this-command 'previous-line)
(call-interactively 'scroll-all-scroll-up-all))
- ((eq this-command 'scroll-up)
+ ((memq this-command '(scroll-up scroll-up-command))
(call-interactively 'scroll-all-page-down-all))
- ((eq this-command 'scroll-down)
+ ((memq this-command '(scroll-down scroll-down-command))
(call-interactively 'scroll-all-page-up-all))
((eq this-command 'beginning-of-buffer)
(call-interactively 'scroll-all-beginning-of-buffer-all))
diff --git a/lisp/scroll-bar.el b/lisp/scroll-bar.el
index 3f763fc59da..8b8edab0009 100644
--- a/lisp/scroll-bar.el
+++ b/lisp/scroll-bar.el
@@ -5,6 +5,7 @@
;; Maintainer: FSF
;; Keywords: hardware
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -29,6 +30,7 @@
;;; Code:
(require 'mouse)
+(eval-when-compile (require 'cl))
;;;; Utilities.
@@ -79,9 +81,6 @@ SIDE must be the symbol `left' or `right'."
"Non-nil means `set-scroll-bar-mode' should really do something.
This is nil while loading `scroll-bar.el', and t afterward.")
-(defun set-scroll-bar-mode-1 (ignore value)
- (set-scroll-bar-mode value))
-
(defun set-scroll-bar-mode (value)
"Set `scroll-bar-mode' to VALUE and put the new value into effect."
(if scroll-bar-mode
@@ -107,27 +106,23 @@ Setting the variable with a customization buffer also takes effect."
;; The default value for :initialize would try to use :set
;; when processing the file in cus-dep.el.
:initialize 'custom-initialize-default
- :set 'set-scroll-bar-mode-1)
+ :set (lambda (sym val) (set-scroll-bar-mode val)))
;; We just set scroll-bar-mode, but that was the default.
;; If it is set again, that is for real.
(setq scroll-bar-mode-explicit t)
-(defun scroll-bar-mode (&optional flag)
+(defun get-scroll-bar-mode () scroll-bar-mode)
+(defsetf get-scroll-bar-mode set-scroll-bar-mode)
+(define-minor-mode scroll-bar-mode
"Toggle display of vertical scroll bars on all frames.
This command applies to all frames that exist and frames to be
created in the future.
With a numeric argument, if the argument is positive
turn on scroll bars; otherwise turn off scroll bars."
- (interactive "P")
-
- ;; Tweedle the variable according to the argument.
- (set-scroll-bar-mode (if (if (null flag)
- (not scroll-bar-mode)
- (setq flag (prefix-numeric-value flag))
- (or (not (numberp flag)) (> flag 0)))
- (or previous-scroll-bar-mode
- default-frame-scroll-bars))))
+ :variable (eq (get-scroll-bar-mode)
+ (or previous-scroll-bar-mode
+ default-frame-scroll-bars)))
(defun toggle-scroll-bar (arg)
"Toggle whether or not the selected frame has vertical scroll bars.
diff --git a/lisp/select.el b/lisp/select.el
index bada2e70e75..0f43ce05822 100644
--- a/lisp/select.el
+++ b/lisp/select.el
@@ -1,12 +1,11 @@
;;; select.el --- lisp portion of standard selection support
+;; Copyright (C) 1993, 1994, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
+
;; Maintainer: FSF
;; Keywords: internal
-;; Copyright (C) 1993, 1994, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010 Free Software Foundation, Inc.
-;; Based partially on earlier release by Lucid.
-
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
@@ -24,11 +23,20 @@
;;; Commentary:
+;; Based partially on earlier release by Lucid.
+
;;; Code:
(defcustom selection-coding-system nil
- "Coding system for communicating with other X clients.
+ "Coding system for communicating with other programs.
+
+For MS-Windows and MS-DOS:
+When sending or receiving text via selection and clipboard, the text
+is encoded or decoded by this coding system. The default value is
+the current system default encoding on 9x/Me, `utf-16le-dos'
+\(Unicode) on NT/W2K/XP, and `iso-latin-1-dos' on MS-DOS.
+For X Windows:
When sending text via selection and clipboard, if the target
data-type matches with the type of this coding system, it is used
for encoding the text. Otherwise (including the case that this
@@ -58,11 +66,11 @@ The default value is nil."
(set symbol value)))
(defvar next-selection-coding-system nil
- "Coding system for the next communication with other X clients.
+ "Coding system for the next communication with other programs.
Usually, `selection-coding-system' is used for communicating with
-other X clients. But, if this variable is set, it is used for
-the next communication only. After the communication, this
-variable is set to nil.")
+other programs (X Windows clients or MS Windows programs). But, if this
+variable is set, it is used for the next communication only.
+After the communication, this variable is set to nil.")
(declare-function x-get-selection-internal "xselect.c"
(selection-symbol target-type &optional time-stamp))
@@ -175,36 +183,6 @@ are not available to other programs."
(symbolp data)
(integerp data)))
-;;; Cut Buffer support
-
-(declare-function x-get-cut-buffer-internal "xselect.c")
-
-(defun x-get-cut-buffer (&optional which-one)
- "Return the value of one of the 8 X server cut-buffers.
-Optional arg WHICH-ONE should be a number from 0 to 7, defaulting to 0.
-Cut buffers are considered obsolete; you should use selections instead."
- (x-get-cut-buffer-internal
- (if which-one
- (aref [CUT_BUFFER0 CUT_BUFFER1 CUT_BUFFER2 CUT_BUFFER3
- CUT_BUFFER4 CUT_BUFFER5 CUT_BUFFER6 CUT_BUFFER7]
- which-one)
- 'CUT_BUFFER0)))
-
-(declare-function x-rotate-cut-buffers-internal "xselect.c")
-(declare-function x-store-cut-buffer-internal "xselect.c")
-
-(defun x-set-cut-buffer (string &optional push)
- "Store STRING into the X server's primary cut buffer.
-If PUSH is non-nil, also rotate the cut buffers:
-this means the previous value of the primary cut buffer moves to the second
-cut buffer, and the second to the third, and so on (there are 8 buffers.)
-Cut buffers are considered obsolete; you should use selections instead."
- (or (stringp string) (signal 'wrong-type-argument (list 'stringp string)))
- (if push
- (x-rotate-cut-buffers-internal 1))
- (x-store-cut-buffer-internal 'CUT_BUFFER0 string))
-
-
;; Functions to convert the selection into various other selection types.
;; Every selection type that Emacs handles is implemented this way, except
;; for TIMESTAMP, which is a special case.
diff --git a/lisp/server.el b/lisp/server.el
index 6297cc82ab0..e3af82231ae 100644
--- a/lisp/server.el
+++ b/lisp/server.el
@@ -110,8 +110,19 @@ If set, the server accepts remote connections; otherwise it is local."
(string :tag "Name or IP address")
(const :tag "Local" nil))
:version "22.1")
+;;;###autoload
(put 'server-host 'risky-local-variable t)
+(defcustom server-port nil
+ "The port number that the server process should listen on."
+ :group 'server
+ :type '(choice
+ (string :tag "Port number")
+ (const :tag "Random" nil))
+ :version "24.1")
+;;;###autoload
+(put 'server-port 'risky-local-variable t)
+
(defcustom server-auth-dir (locate-user-emacs-file "server/")
"Directory for server authentication files.
@@ -122,6 +133,7 @@ directory residing in a NTFS partition instead."
:group 'server
:type 'directory
:version "22.1")
+;;;###autoload
(put 'server-auth-dir 'risky-local-variable t)
(defcustom server-raise-frame t
@@ -344,7 +356,8 @@ If CLIENT is non-nil, add a description of it to the logged message."
;; for possible servers before doing anything, so it *should* be ours.
(and (process-contact proc :server)
(eq (process-status proc) 'closed)
- (ignore-errors (delete-file (process-get proc :server-file))))
+ (ignore-errors
+ (delete-file (process-get proc :server-file))))
(server-log (format "Status changed to %s: %s" (process-status proc) msg) proc)
(server-delete-client proc))
@@ -522,7 +535,9 @@ To force-start a server, do \\[server-force-delete] and then
;; Delete the socket files made by previous server invocations.
(if (not (eq t (server-running-p server-name)))
;; Remove any leftover socket or authentication file
- (ignore-errors (delete-file server-file))
+ (ignore-errors
+ (let (delete-by-moving-to-trash)
+ (delete-file server-file)))
(setq server-mode nil) ;; already set by the minor mode code
(display-warning
'server
@@ -566,8 +581,8 @@ server or call `M-x server-force-delete' to forcibly disconnect it.")
;; The other args depend on the kind of socket used.
(if server-use-tcp
(list :family 'ipv4 ;; We're not ready for IPv6 yet
- :service t
- :host (or server-host "127.0.0.1") ;; See bug#6781
+ :service (or server-port t)
+ :host (or server-host 'local)
:plist '(:authenticated nil))
(list :family 'local
:service server-file
@@ -579,7 +594,7 @@ server or call `M-x server-force-delete' to forcibly disconnect it.")
(loop
;; The auth key is a 64-byte string of random chars in the
;; range `!'..`~'.
- for i below 64
+ repeat 64
collect (+ 33 (random 94)) into auth
finally return (concat auth))))
(process-put server-process :auth-key auth-key)
@@ -588,7 +603,7 @@ server or call `M-x server-force-delete' to forcibly disconnect it.")
(setq buffer-file-coding-system 'no-conversion)
(insert (format-network-address
(process-contact server-process :local))
- " " (int-to-string (emacs-pid))
+ " " (number-to-string (emacs-pid)) ; Kept for compatibility
"\n" auth-key)))))))))
(defun server-force-stop ()
@@ -610,7 +625,7 @@ NAME defaults to `server-name'. With argument, ask for NAME."
server-auth-dir
server-socket-dir))))
(condition-case nil
- (progn
+ (let (delete-by-moving-to-trash)
(delete-file file)
(message "Connection file %S deleted" file))
(file-error
@@ -713,12 +728,9 @@ Server mode runs a process that accepts commands from the
;; Display *scratch* by default.
(switch-to-buffer (get-buffer-create "*scratch*") 'norecord)
- ;; Reply with our pid.
- (server-send-string proc (concat "-emacs-pid "
- (number-to-string (emacs-pid)) "\n"))
frame))
-(defun server-create-window-system-frame (display nowait proc)
+(defun server-create-window-system-frame (display nowait proc parent-id)
(add-to-list 'frame-inherited-parameters 'client)
(if (not (fboundp 'make-frame-on-display))
(progn
@@ -734,12 +746,14 @@ Server mode runs a process that accepts commands from the
(let* ((params `((client . ,(if nowait 'nowait proc))
;; This is a leftover, see above.
(environment . ,(process-get proc 'env))))
- (frame (make-frame-on-display
- (or display
- (frame-parameter nil 'display)
- (getenv "DISPLAY")
- (error "Please specify display"))
- params)))
+ (display (or display
+ (frame-parameter nil 'display)
+ (getenv "DISPLAY")
+ (error "Please specify display")))
+ frame)
+ (if parent-id
+ (push (cons 'parent-id (string-to-number parent-id)) params))
+ (setq frame (make-frame-on-display display params))
(server-log (format "%s created" frame) proc)
(select-frame frame)
(process-put proc 'frame frame)
@@ -884,6 +898,9 @@ The following commands are accepted by the client:
(server-log "Authentication failed" proc)
(server-send-string
proc (concat "-error " (server-quote-arg "Authentication failed")))
+ ;; Before calling `delete-process', give emacsclient time to
+ ;; receive the error string and shut down on its own.
+ (sit-for 1)
(delete-process proc)
;; We return immediately
(return-from server-process-filter)))
@@ -894,6 +911,9 @@ The following commands are accepted by the client:
(condition-case err
(progn
(server-add-client proc)
+ ;; Send our pid
+ (server-send-string proc (concat "-emacs-pid "
+ (number-to-string (emacs-pid)) "\n"))
(if (not (string-match "\n" string))
;; Save for later any partial line that remains.
(when (> (length string) 0)
@@ -907,15 +927,16 @@ The following commands are accepted by the client:
(coding-system (and (default-value 'enable-multibyte-characters)
(or file-name-coding-system
default-file-name-coding-system)))
- nowait ; t if emacsclient does not want to wait for us.
- frame ; The frame that was opened for the client (if any).
- display ; Open the frame on this display.
- dontkill ; t if the client should not be killed.
+ nowait ; t if emacsclient does not want to wait for us.
+ frame ; Frame opened for the client (if any).
+ display ; Open frame on this display.
+ parent-id ; Window ID for XEmbed
+ dontkill ; t if client should not be killed.
commands
dir
use-current-frame
- tty-name ;nil, `window-system', or the tty name.
- tty-type ;string.
+ tty-name ; nil, `window-system', or the tty name.
+ tty-type ; string.
files
filepos
command-line-args-left
@@ -942,6 +963,12 @@ The following commands are accepted by the client:
(setq display (pop command-line-args-left))
(if (zerop (length display)) (setq display nil)))
+ ;; -parent-id ID:
+ ;; Open X frame within window ID, via XEmbed.
+ ((and (equal "-parent-id" arg) command-line-args-left)
+ (setq parent-id (pop command-line-args-left))
+ (if (zerop (length parent-id)) (setq parent-id nil)))
+
;; -window-system: Open a new X frame.
((equal "-window-system" arg)
(setq dontkill t)
@@ -1046,7 +1073,8 @@ The following commands are accepted by the client:
(setq tty-name nil tty-type nil)
(if display (server-select-display display)))
((eq tty-name 'window-system)
- (server-create-window-system-frame display nowait proc))
+ (server-create-window-system-frame display nowait proc
+ parent-id))
;; When resuming on a tty, tty-name is nil.
(tty-name
(server-create-tty-frame tty-name tty-type proc))))
@@ -1090,9 +1118,7 @@ The following commands are accepted by the client:
(condition-case err
(let* ((buffers
(when files
- (run-hooks 'pre-command-hook)
- (prog1 (server-visit-files files proc nowait)
- (run-hooks 'post-command-hook)))))
+ (server-visit-files files proc nowait))))
(mapc 'funcall (nreverse commands))
@@ -1128,6 +1154,9 @@ The following commands are accepted by the client:
proc (concat "-error " (server-quote-arg
(error-message-string err))))
(server-log (error-message-string err) proc)
+ ;; Before calling `delete-process', give emacsclient time to
+ ;; receive the error string and shut down on its own.
+ (sit-for 5)
(delete-process proc)))
(defun server-goto-line-column (line-col)
@@ -1163,8 +1192,13 @@ so don't mark these buffers specially, just visit them normally."
(obuf (get-file-buffer filen)))
(add-to-history 'file-name-history filen)
(if (null obuf)
- (set-buffer (find-file-noselect filen))
+ (progn
+ (run-hooks 'pre-command-hook)
+ (set-buffer (find-file-noselect filen)))
(set-buffer obuf)
+ ;; separately for each file, in sync with post-command hooks,
+ ;; with the new buffer current:
+ (run-hooks 'pre-command-hook)
(cond ((file-exists-p filen)
(when (not (verify-visited-file-modtime obuf))
(revert-buffer t nil)))
@@ -1176,7 +1210,9 @@ so don't mark these buffers specially, just visit them normally."
(unless server-buffer-clients
(setq server-existing-buffer t)))
(server-goto-line-column (cdr file))
- (run-hooks 'server-visit-hook))
+ (run-hooks 'server-visit-hook)
+ ;; hooks may be specific to current buffer:
+ (run-hooks 'post-command-hook))
(unless nowait
;; When the buffer is killed, inform the clients.
(add-hook 'kill-buffer-hook 'server-kill-buffer nil t)
@@ -1459,5 +1495,4 @@ only these files will be asked to be saved."
(provide 'server)
-;; arch-tag: 1f7ecb42-f00a-49f8-906d-61995d84c8d6
;;; server.el ends here
diff --git a/lisp/sha1.el b/lisp/sha1.el
index 1db7a2835f4..0d97ac6ce4b 100644
--- a/lisp/sha1.el
+++ b/lisp/sha1.el
@@ -95,7 +95,7 @@ If this variable is set to nil, use internal function only."
(setq prog sha1-program
args nil))
(with-temp-buffer
- (set-buffer-multibyte nil)
+ (unless (featurep 'xemacs) (set-buffer-multibyte nil))
(insert string)
(apply (function call-process-region)
(point-min) (point-max)
@@ -439,5 +439,4 @@ If BINARY is non-nil, return a string in binary form."
(provide 'sha1)
-;; arch-tag: c0f9abd0-ffc1-4557-aac6-ece7f2d4c901
;;; sha1.el ends here
diff --git a/lisp/shell.el b/lisp/shell.el
index 4b93af48bea..815add76502 100644
--- a/lisp/shell.el
+++ b/lisp/shell.el
@@ -1,7 +1,8 @@
;;; shell.el --- specialized comint.el for running the shell
-;; Copyright (C) 1988, 1993, 1994, 1995, 1996, 1997, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1988, 1993, 1994, 1995, 1996, 1997, 2000, 2001, 2002,
+;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Olin Shivers <shivers@cs.cmu.edu>
;; Simon Marshall <simon@gnu.org>
@@ -70,7 +71,7 @@
;; c-c c-c comint-interrupt-subjob ^c
;; c-c c-z comint-stop-subjob ^z
;; c-c c-\ comint-quit-subjob ^\
-;; c-c c-o comint-kill-output Delete last batch of process output
+;; c-c c-o comint-delete-output Delete last batch of process output
;; c-c c-r comint-show-output Show last batch of process output
;; c-c c-l comint-dynamic-list-input-ring List input history
;; send-invisible Read line w/o echo & send to proc
@@ -334,25 +335,25 @@ Thus, this does not include the shell's current directory.")
(defvar shell-dirstack-query nil
"Command used by `shell-resync-dirs' to query the shell.")
-(defvar shell-mode-map nil)
-(cond ((not shell-mode-map)
- (setq shell-mode-map (nconc (make-sparse-keymap) comint-mode-map))
- (define-key shell-mode-map "\C-c\C-f" 'shell-forward-command)
- (define-key shell-mode-map "\C-c\C-b" 'shell-backward-command)
- (define-key shell-mode-map "\t" 'comint-dynamic-complete)
- (define-key shell-mode-map "\M-?"
- 'comint-dynamic-list-filename-completions)
- (define-key shell-mode-map [menu-bar completion]
- (cons "Complete"
- (copy-keymap (lookup-key comint-mode-map [menu-bar completion]))))
- (define-key-after (lookup-key shell-mode-map [menu-bar completion])
- [complete-env-variable] '("Complete Env. Variable Name" .
- shell-dynamic-complete-environment-variable)
- 'complete-file)
- (define-key-after (lookup-key shell-mode-map [menu-bar completion])
- [expand-directory] '("Expand Directory Reference" .
- shell-replace-by-expanded-directory)
- 'complete-expand)))
+(defvar shell-mode-map
+ (let ((map (nconc (make-sparse-keymap) comint-mode-map)))
+ (define-key map "\C-c\C-f" 'shell-forward-command)
+ (define-key map "\C-c\C-b" 'shell-backward-command)
+ (define-key map "\t" 'comint-dynamic-complete)
+ (define-key map (kbd "M-RET") 'shell-resync-dirs)
+ (define-key map "\M-?" 'comint-dynamic-list-filename-completions)
+ (define-key map [menu-bar completion]
+ (cons "Complete"
+ (copy-keymap (lookup-key comint-mode-map [menu-bar completion]))))
+ (define-key-after (lookup-key map [menu-bar completion])
+ [complete-env-variable] '("Complete Env. Variable Name" .
+ shell-dynamic-complete-environment-variable)
+ 'complete-file)
+ (define-key-after (lookup-key map [menu-bar completion])
+ [expand-directory] '("Expand Directory Reference" .
+ shell-replace-by-expanded-directory)
+ 'complete-expand)
+ map))
(defcustom shell-mode-hook '()
"Hook for customizing Shell mode."
@@ -367,6 +368,17 @@ Thus, this does not include the shell's current directory.")
;;; Basic Procedures
+(defcustom shell-dir-cookie-re nil
+ "Regexp matching your prompt, including some part of the current directory.
+If your prompt includes the current directory or the last few elements of it,
+set this to a pattern that matches your prompt and whose subgroup 1 matches
+the directory part of it.
+This is used by `shell-dir-cookie-watcher' to try and use this info
+to track your current directory. It can be used instead of or in addition
+to `dirtrack-mode'."
+ :group 'shell
+ :type '(choice (const nil) regexp))
+
(put 'shell-mode 'mode-class 'special)
(define-derived-mode shell-mode comint-mode "Shell"
@@ -471,6 +483,10 @@ buffer."
(when (string-equal shell "bash")
(add-hook 'comint-output-filter-functions
'shell-filter-ctrl-a-ctrl-b nil t)))
+ (when shell-dir-cookie-re
+ ;; Watch for magic cookies in the output to track the current dir.
+ (add-hook 'comint-output-filter-functions
+ 'shell-dir-cookie-watcher nil t))
(comint-read-input-ring t)))
(defun shell-filter-ctrl-a-ctrl-b (string)
@@ -549,13 +565,19 @@ Otherwise, one argument `-i' is passed to the shell.
(generate-new-buffer-name "*shell*"))
(if (file-remote-p default-directory)
;; It must be possible to declare a local default-directory.
+ ;; FIXME: This can't be right: it changes the default-directory
+ ;; of the current-buffer rather than of the *shell* buffer.
(setq default-directory
(expand-file-name
(read-file-name
"Default directory: " default-directory default-directory
t nil 'file-directory-p))))))))
(require 'ansi-color)
- (setq buffer (get-buffer-create (or buffer "*shell*")))
+ (setq buffer (if (or buffer (not (derived-mode-p 'shell-mode))
+ (comint-check-proc (current-buffer)))
+ (get-buffer-create (or buffer "*shell*"))
+ ;; If the current buffer is a dead shell buffer, use it.
+ (current-buffer)))
;; Pop to buffer, so that the buffer's window will be correctly set
;; when we call comint (so that comint sets the COLUMNS env var properly).
(pop-to-buffer buffer)
@@ -618,6 +640,20 @@ Otherwise, one argument `-i' is passed to the shell.
;; replace it with a process filter that watches for and strips out
;; these messages.
+(defun shell-dir-cookie-watcher (text)
+ ;; This is fragile: the TEXT could be split into several chunks and we'd
+ ;; miss it. Oh well. It's a best effort anyway. I'd expect that it's
+ ;; rather unusual to have the prompt split into several packets, but
+ ;; I'm sure Murphy will prove me wrong.
+ (when (and shell-dir-cookie-re (string-match shell-dir-cookie-re text))
+ (let ((dir (match-string 1 text)))
+ (cond
+ ((file-name-absolute-p dir) (shell-cd dir))
+ ;; Let's try and see if it seems to be up or down from where we were.
+ ((string-match "\\`\\(.*\\)\\(?:/.*\\)?\n\\(.*/\\)\\1\\(?:/.*\\)?\\'"
+ (setq text (concat dir "\n" default-directory)))
+ (shell-cd (concat (match-string 2 text) dir)))))))
+
(defun shell-directory-tracker (str)
"Tracks cd, pushd and popd commands issued to the shell.
This function is called on each input passed to the shell.
@@ -700,7 +736,7 @@ Environment variables are expanded, see function `substitute-in-file-name'."
(defun shell-process-popd (arg)
(let ((num (or (shell-extract-num arg) 0)))
(cond ((and num (= num 0) shell-dirstack)
- (shell-cd (car shell-dirstack))
+ (shell-cd (shell-prefixed-directory-name (car shell-dirstack)))
(setq shell-dirstack (cdr shell-dirstack))
(shell-dirstack-message))
((and num (> num 0) (<= num (length shell-dirstack)))
@@ -928,7 +964,7 @@ Copy Shell environment variable to Emacs: ")))
"Move forward across ARG shell command(s). Does not cross lines.
See `shell-command-regexp'."
(interactive "p")
- (let ((limit (save-excursion (end-of-line nil) (point))))
+ (let ((limit (line-end-position)))
(if (re-search-forward (concat shell-command-regexp "\\([;&|][\t ]*\\)+")
limit 'move arg)
(skip-syntax-backward " "))))
@@ -1111,5 +1147,4 @@ Returns t if successful."
(provide 'shell)
-;; arch-tag: bcb5f12a-c1f4-4aea-a809-2504bd5bd797
;;; shell.el ends here
diff --git a/lisp/simple.el b/lisp/simple.el
index 3f4e12133b5..3b9bfc0519a 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -1,11 +1,12 @@
;;; simple.el --- basic editing commands for Emacs
-;; Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1996, 1997, 1998,
+;; 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+;; 2010 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -401,8 +402,7 @@ location."
Other major modes are defined by comparison with this one."
(interactive)
(kill-all-local-variables)
- (unless delay-mode-hooks
- (run-hooks 'after-change-major-mode-hook)))
+ (run-mode-hooks 'fundamental-mode-hook))
;; Special major modes to view specially formatted data rather than files.
@@ -423,6 +423,28 @@ Other major modes are defined by comparison with this one."
"Parent major mode from which special major modes should inherit."
(setq buffer-read-only t))
+;; Major mode meant to be the parent of programming modes.
+
+(defvar prog-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [?\C-\M-q] 'prog-indent-sexp)
+ map)
+ "Keymap used for programming modes.")
+
+(defun prog-indent-sexp ()
+ "Indent the expression after point."
+ (interactive)
+ (let ((start (point))
+ (end (save-excursion (forward-sexp 1) (point))))
+ (indent-region start end nil)))
+
+(define-derived-mode prog-mode fundamental-mode "Prog"
+ "Major mode for editing programming language source code."
+ (set (make-local-variable 'require-final-newline) mode-require-final-newline)
+ (set (make-local-variable 'parse-sexp-ignore-comments) t)
+ ;; Any programming language is always written left to right.
+ (setq bidi-paragraph-direction 'left-to-right))
+
;; Making and deleting lines.
(defvar hard-newline (propertize "\n" 'hard t 'rear-nonsticky '(hard))
@@ -437,72 +459,43 @@ Call `auto-fill-function' if the current column number is greater
than the value of `fill-column' and ARG is nil."
(interactive "*P")
(barf-if-buffer-read-only)
- ;; Inserting a newline at the end of a line produces better redisplay in
- ;; try_window_id than inserting at the beginning of a line, and the textual
- ;; result is the same. So, if we're at beginning of line, pretend to be at
- ;; the end of the previous line.
- (let ((flag (and (not (bobp))
- (bolp)
- ;; Make sure no functions want to be told about
- ;; the range of the changes.
- (not after-change-functions)
- (not before-change-functions)
- ;; Make sure there are no markers here.
- (not (buffer-has-markers-at (1- (point))))
- (not (buffer-has-markers-at (point)))
- ;; Make sure no text properties want to know
- ;; where the change was.
- (not (get-char-property (1- (point)) 'modification-hooks))
- (not (get-char-property (1- (point)) 'insert-behind-hooks))
- (or (eobp)
- (not (get-char-property (point) 'insert-in-front-hooks)))
- ;; Make sure the newline before point isn't intangible.
- (not (get-char-property (1- (point)) 'intangible))
- ;; Make sure the newline before point isn't read-only.
- (not (get-char-property (1- (point)) 'read-only))
- ;; Make sure the newline before point isn't invisible.
- (not (get-char-property (1- (point)) 'invisible))
- ;; Make sure the newline before point has the same
- ;; properties as the char before it (if any).
- (< (or (previous-property-change (point)) -2)
- (- (point) 2))))
- (was-page-start (and (bolp)
- (looking-at page-delimiter)))
- (beforepos (point)))
- (if flag (backward-char 1))
- ;; Call self-insert so that auto-fill, abbrev expansion etc. happens.
- ;; Set last-command-event to tell self-insert what to insert.
- (let ((last-command-event ?\n)
- ;; Don't auto-fill if we have a numeric argument.
- ;; Also not if flag is true (it would fill wrong line);
- ;; there is no need to since we're at BOL.
- (auto-fill-function (if (or arg flag) nil auto-fill-function)))
- (unwind-protect
- (self-insert-command (prefix-numeric-value arg))
- ;; If we get an error in self-insert-command, put point at right place.
- (if flag (forward-char 1))))
- ;; Even if we did *not* get an error, keep that forward-char;
- ;; all further processing should apply to the newline that the user
- ;; thinks he inserted.
-
- ;; Mark the newline(s) `hard'.
- (if use-hard-newlines
- (set-hard-newline-properties
- (- (point) (prefix-numeric-value arg)) (point)))
- ;; If the newline leaves the previous line blank,
- ;; and we have a left margin, delete that from the blank line.
- (or flag
- (save-excursion
- (goto-char beforepos)
- (beginning-of-line)
- (and (looking-at "[ \t]$")
- (> (current-left-margin) 0)
- (delete-region (point) (progn (end-of-line) (point))))))
- ;; Indent the line after the newline, except in one case:
- ;; when we added the newline at the beginning of a line
- ;; which starts a page.
- (or was-page-start
- (move-to-left-margin nil t)))
+ ;; Call self-insert so that auto-fill, abbrev expansion etc. happens.
+ ;; Set last-command-event to tell self-insert what to insert.
+ (let* ((was-page-start (and (bolp) (looking-at page-delimiter)))
+ (beforepos (point))
+ (last-command-event ?\n)
+ ;; Don't auto-fill if we have a numeric argument.
+ (auto-fill-function (if arg nil auto-fill-function))
+ (postproc
+ ;; Do the rest in post-self-insert-hook, because we want to do it
+ ;; *before* other functions on that hook.
+ (lambda ()
+ ;; Mark the newline(s) `hard'.
+ (if use-hard-newlines
+ (set-hard-newline-properties
+ (- (point) (prefix-numeric-value arg)) (point)))
+ ;; If the newline leaves the previous line blank, and we
+ ;; have a left margin, delete that from the blank line.
+ (save-excursion
+ (goto-char beforepos)
+ (beginning-of-line)
+ (and (looking-at "[ \t]$")
+ (> (current-left-margin) 0)
+ (delete-region (point)
+ (line-end-position))))
+ ;; Indent the line after the newline, except in one case:
+ ;; when we added the newline at the beginning of a line which
+ ;; starts a page.
+ (or was-page-start
+ (move-to-left-margin nil t)))))
+ (unwind-protect
+ (progn
+ (add-hook 'post-self-insert-hook postproc)
+ (self-insert-command (prefix-numeric-value arg)))
+ ;; We first used let-binding to protect the hook, but that was naive
+ ;; since add-hook affects the symbol-default value of the variable,
+ ;; whereas the let-binding might only protect the buffer-local value.
+ (remove-hook 'post-self-insert-hook postproc)))
nil)
(defun set-hard-newline-properties (from to)
@@ -521,7 +514,7 @@ With arg N, insert N newlines."
(interactive "*p")
(let* ((do-fill-prefix (and fill-prefix (bolp)))
(do-left-margin (and (bolp) (> (current-left-margin) 0)))
- (loc (point))
+ (loc (point-marker))
;; Don't expand an abbrev before point.
(abbrev-mode nil))
(newline n)
@@ -840,6 +833,78 @@ Don't use this command in Lisp programs!
(overlay-recenter (point))
(recenter -3))))
+(defcustom delete-active-region t
+ "Whether single-char deletion commands delete an active region.
+This has an effect only if Transient Mark mode is enabled, and
+affects `delete-forward-char' and `delete-backward-char', though
+not `delete-char'.
+
+If the value is the symbol `kill', the active region is killed
+instead of deleted."
+ :type '(choice (const :tag "Delete active region" t)
+ (const :tag "Kill active region" kill)
+ (const :tag "Do ordinary deletion" nil))
+ :group 'editing
+ :version "24.1")
+
+(defun delete-backward-char (n &optional killflag)
+ "Delete the previous N characters (following if N is negative).
+If Transient Mark mode is enabled, the mark is active, and N is 1,
+delete the text in the region and deactivate the mark instead.
+To disable this, set `delete-active-region' to nil.
+
+Optional second arg KILLFLAG, if non-nil, means to kill (save in
+kill ring) instead of delete. Interactively, N is the prefix
+arg, and KILLFLAG is set if N is explicitly specified.
+
+In Overwrite mode, single character backward deletion may replace
+tabs with spaces so as to back over columns, unless point is at
+the end of the line."
+ (interactive "p\nP")
+ (unless (integerp n)
+ (signal 'wrong-type-argument (list 'integerp n)))
+ (cond ((and (use-region-p)
+ delete-active-region
+ (= n 1))
+ ;; If a region is active, kill or delete it.
+ (if (eq delete-active-region 'kill)
+ (kill-region (region-beginning) (region-end))
+ (delete-region (region-beginning) (region-end))))
+ ;; In Overwrite mode, maybe untabify while deleting
+ ((null (or (null overwrite-mode)
+ (<= n 0)
+ (memq (char-before) '(?\t ?\n))
+ (eobp)
+ (eq (char-after) ?\n)))
+ (let* ((ocol (current-column))
+ (val (delete-char (- n) killflag)))
+ (save-excursion
+ (insert-char ?\s (- ocol (current-column)) nil))))
+ ;; Otherwise, do simple deletion.
+ (t (delete-char (- n) killflag))))
+
+(defun delete-forward-char (n &optional killflag)
+ "Delete the following N characters (previous if N is negative).
+If Transient Mark mode is enabled, the mark is active, and N is 1,
+delete the text in the region and deactivate the mark instead.
+To disable this, set `delete-active-region' to nil.
+
+Optional second arg KILLFLAG non-nil means to kill (save in kill
+ring) instead of delete. Interactively, N is the prefix arg, and
+KILLFLAG is set if N was explicitly specified."
+ (interactive "p\nP")
+ (unless (integerp n)
+ (signal 'wrong-type-argument (list 'integerp n)))
+ (cond ((and (use-region-p)
+ delete-active-region
+ (= n 1))
+ ;; If a region is active, kill or delete it.
+ (if (eq delete-active-region 'kill)
+ (kill-region (region-beginning) (region-end))
+ (delete-region (region-beginning) (region-end))))
+ ;; Otherwise, do simple deletion.
+ (t (delete-char n killflag))))
+
(defun mark-whole-buffer ()
"Put point at beginning and mark at end of buffer.
You probably should not use this function in Lisp programs;
@@ -910,6 +975,21 @@ rather than line counts."
(re-search-forward "[\n\C-m]" nil 'end (1- line))
(forward-line (1- line)))))
+(defun count-words-region (start end)
+ "Print the number of words in the region.
+When called interactively, the word count is printed in echo area."
+ (interactive "r")
+ (let ((count 0))
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start end)
+ (goto-char (point-min))
+ (while (forward-word 1)
+ (setq count (1+ count)))))
+ (if (interactive-p)
+ (message "Region has %d words" count))
+ count))
+
(defun count-lines-region (start end)
"Print number of lines and characters in the region."
(interactive "r")
@@ -1212,6 +1292,40 @@ to get different commands to edit and resubmit."
(if command-history
(error "Argument %d is beyond length of command history" arg)
(error "There are no previous complex commands to repeat")))))
+
+(defun read-extended-command ()
+ "Read command name to invoke in `execute-extended-command'."
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (set (make-local-variable 'minibuffer-default-add-function)
+ (lambda ()
+ ;; Get a command name at point in the original buffer
+ ;; to propose it after M-n.
+ (with-current-buffer (window-buffer (minibuffer-selected-window))
+ (and (commandp (function-called-at-point))
+ (format "%S" (function-called-at-point)))))))
+ ;; Read a string, completing from and restricting to the set of
+ ;; all defined commands. Don't provide any initial input.
+ ;; Save the command read on the extended-command history list.
+ (completing-read
+ (concat (cond
+ ((eq current-prefix-arg '-) "- ")
+ ((and (consp current-prefix-arg)
+ (eq (car current-prefix-arg) 4)) "C-u ")
+ ((and (consp current-prefix-arg)
+ (integerp (car current-prefix-arg)))
+ (format "%d " (car current-prefix-arg)))
+ ((integerp current-prefix-arg)
+ (format "%d " current-prefix-arg)))
+ ;; This isn't strictly correct if `execute-extended-command'
+ ;; is bound to anything else (e.g. [menu]).
+ ;; It could use (key-description (this-single-command-keys)),
+ ;; but actually a prompt other than "M-x" would be confusing,
+ ;; because "M-x" is a well-known prompt to read a command
+ ;; and it serves as a shorthand for "Extended command: ".
+ "M-x ")
+ obarray 'commandp t nil 'extended-command-history)))
+
(defvar minibuffer-history nil
"Default minibuffer history list.
@@ -2073,7 +2187,11 @@ to `shell-command-history'."
Like `shell-command' but if COMMAND doesn't end in ampersand, adds `&'
surrounded by whitespace and executes the command asynchronously.
-The output appears in the buffer `*Async Shell Command*'."
+The output appears in the buffer `*Async Shell Command*'.
+
+In Elisp, you will often be better served by calling `start-process'
+directly, since it offers more control and does not impose the use of a
+shell (with its need to quote arguments)."
(interactive
(list
(read-shell-command "Async shell command: " nil nil
@@ -2134,7 +2252,11 @@ If the optional third argument ERROR-BUFFER is non-nil, it is a buffer
or buffer name to which to direct the command's standard error output.
If it is nil, error output is mingled with regular output.
In an interactive call, the variable `shell-command-default-error-buffer'
-specifies the value of ERROR-BUFFER."
+specifies the value of ERROR-BUFFER.
+
+In Elisp, you will often be better served by calling `call-process' or
+`start-process' directly, since it offers more control and does not impose
+the use of a shell (with its need to quote arguments)."
(interactive
(list
@@ -2691,6 +2813,60 @@ These commands include \\[set-mark-command] and \\[start-kbd-macro]."
(reset-this-command-lengths)
(restore-overriding-map))
+;; This function is here rather than in subr.el because it uses CL.
+(defmacro with-wrapper-hook (var args &rest body)
+ "Run BODY wrapped with the VAR hook.
+VAR is a special hook: its functions are called with a first argument
+which is the \"original\" code (the BODY), so the hook function can wrap
+the original function, or call it any number of times (including not calling
+it at all). This is similar to an `around' advice.
+VAR is normally a symbol (a variable) in which case it is treated like
+a hook, with a buffer-local and a global part. But it can also be an
+arbitrary expression.
+ARGS is a list of variables which will be passed as additional arguments
+to each function, after the initial argument, and which the first argument
+expects to receive when called."
+ (declare (indent 2) (debug t))
+ ;; We need those two gensyms because CL's lexical scoping is not available
+ ;; for function arguments :-(
+ (let ((funs (make-symbol "funs"))
+ (global (make-symbol "global"))
+ (argssym (make-symbol "args")))
+ ;; Since the hook is a wrapper, the loop has to be done via
+ ;; recursion: a given hook function will call its parameter in order to
+ ;; continue looping.
+ `(labels ((runrestofhook (,funs ,global ,argssym)
+ ;; `funs' holds the functions left on the hook and `global'
+ ;; holds the functions left on the global part of the hook
+ ;; (in case the hook is local).
+ (lexical-let ((funs ,funs)
+ (global ,global))
+ (if (consp funs)
+ (if (eq t (car funs))
+ (runrestofhook
+ (append global (cdr funs)) nil ,argssym)
+ (apply (car funs)
+ (lambda (&rest ,argssym)
+ (runrestofhook (cdr funs) global ,argssym))
+ ,argssym))
+ ;; Once there are no more functions on the hook, run
+ ;; the original body.
+ (apply (lambda ,args ,@body) ,argssym)))))
+ (runrestofhook ,var
+ ;; The global part of the hook, if any.
+ ,(if (symbolp var)
+ `(if (local-variable-p ',var)
+ (default-value ',var)))
+ (list ,@args)))))
+
+(defvar filter-buffer-substring-functions nil
+ "Wrapper hook around `filter-buffer-substring'.
+The functions on this special hook are called with 4 arguments:
+ NEXT-FUN BEG END DELETE
+NEXT-FUN is a function of 3 arguments (BEG END DELETE)
+that performs the default operation. The other 3 arguments are like
+the ones passed to `filter-buffer-substring'.")
+
(defvar buffer-substring-filters nil
"List of filter functions for `filter-buffer-substring'.
Each function must accept a single argument, a string, and return
@@ -2700,46 +2876,34 @@ the next. The return value of the last function is used as the
return value of `filter-buffer-substring'.
If this variable is nil, no filtering is performed.")
+(make-obsolete-variable 'buffer-substring-filters
+ 'filter-buffer-substring-functions "24.1")
-(defun filter-buffer-substring (beg end &optional delete noprops)
+(defun filter-buffer-substring (beg end &optional delete)
"Return the buffer substring between BEG and END, after filtering.
-The buffer substring is passed through each of the filter
-functions in `buffer-substring-filters', and the value from the
-last filter function is returned. If `buffer-substring-filters'
-is nil, the buffer substring is returned unaltered.
+The filtering is performed by `filter-buffer-substring-functions'.
If DELETE is non-nil, the text between BEG and END is deleted
from the buffer.
-If NOPROPS is non-nil, final string returned does not include
-text properties, while the string passed to the filters still
-includes text properties from the buffer text.
-
-Point is temporarily set to BEG before calling
-`buffer-substring-filters', in case the functions need to know
-where the text came from.
-
This function should be used instead of `buffer-substring',
`buffer-substring-no-properties', or `delete-and-extract-region'
when you want to allow filtering to take place. For example,
-major or minor modes can use `buffer-substring-filters' to
+major or minor modes can use `filter-buffer-substring-functions' to
extract characters that are special to a buffer, and should not
be copied into other buffers."
- (cond
- ((or delete buffer-substring-filters)
- (save-excursion
- (goto-char beg)
- (let ((string (if delete (delete-and-extract-region beg end)
- (buffer-substring beg end))))
- (dolist (filter buffer-substring-filters)
- (setq string (funcall filter string)))
- (if noprops
- (set-text-properties 0 (length string) nil string))
- string)))
- (noprops
- (buffer-substring-no-properties beg end))
- (t
- (buffer-substring beg end))))
+ (with-wrapper-hook filter-buffer-substring-functions (beg end delete)
+ (cond
+ ((or delete buffer-substring-filters)
+ (save-excursion
+ (goto-char beg)
+ (let ((string (if delete (delete-and-extract-region beg end)
+ (buffer-substring beg end))))
+ (dolist (filter buffer-substring-filters)
+ (setq string (funcall filter string)))
+ string)))
+ (t
+ (buffer-substring beg end)))))
;;;; Window system cut and paste hooks.
@@ -2753,11 +2917,8 @@ This variable holds a function that Emacs calls whenever text
is put in the kill ring, to make the new kill available to other
programs.
-The function takes one or two arguments.
-The first argument, TEXT, is a string containing
-the text which should be made available.
-The second, optional, argument PUSH, has the same meaning as the
-similar argument to `x-set-cut-buffer', which see.")
+The function takes one argument, TEXT, which is a string containing
+the text which should be made available.")
(defvar interprogram-paste-function nil
"Function to call to get text cut from other programs.
@@ -2846,27 +3007,30 @@ argument should still be a \"useful\" string for such uses."
(if yank-handler
(signal 'args-out-of-range
(list string "yank-handler specified for empty string"))))
- (when (and kill-do-not-save-duplicates
- (equal string (car kill-ring)))
- (setq replace t))
- (if (fboundp 'menu-bar-update-yank-menu)
- (menu-bar-update-yank-menu string (and replace (car kill-ring))))
+ (unless (and kill-do-not-save-duplicates
+ (equal string (car kill-ring)))
+ (if (fboundp 'menu-bar-update-yank-menu)
+ (menu-bar-update-yank-menu string (and replace (car kill-ring)))))
(when save-interprogram-paste-before-kill
(let ((interprogram-paste (and interprogram-paste-function
(funcall interprogram-paste-function))))
(when interprogram-paste
- (if (listp interprogram-paste)
- (dolist (s (nreverse interprogram-paste))
- (push s kill-ring))
- (push interprogram-paste kill-ring)))))
- (if (and replace kill-ring)
- (setcar kill-ring string)
- (push string kill-ring)
- (if (> (length kill-ring) kill-ring-max)
- (setcdr (nthcdr (1- kill-ring-max) kill-ring) nil)))
+ (dolist (s (if (listp interprogram-paste)
+ (nreverse interprogram-paste)
+ (list interprogram-paste)))
+ (unless (and kill-do-not-save-duplicates
+ (equal s (car kill-ring)))
+ (push s kill-ring))))))
+ (unless (and kill-do-not-save-duplicates
+ (equal string (car kill-ring)))
+ (if (and replace kill-ring)
+ (setcar kill-ring string)
+ (push string kill-ring)
+ (if (> (length kill-ring) kill-ring-max)
+ (setcdr (nthcdr (1- kill-ring-max) kill-ring) nil))))
(setq kill-ring-yank-pointer kill-ring)
(if interprogram-cut-function
- (funcall interprogram-cut-function string (not replace))))
+ (funcall interprogram-cut-function string)))
(set-advertised-calling-convention
'kill-new '(string &optional replace) "23.3")
@@ -3460,18 +3624,18 @@ START and END specify the portion of the current buffer to be copied."
(interactive
(list (read-buffer "Append to buffer: " (other-buffer (current-buffer) t))
(region-beginning) (region-end)))
- (let ((oldbuf (current-buffer)))
- (let* ((append-to (get-buffer-create buffer))
- (windows (get-buffer-window-list append-to t t))
- point)
- (save-excursion
- (with-current-buffer append-to
- (setq point (point))
- (barf-if-buffer-read-only)
- (insert-buffer-substring oldbuf start end)
- (dolist (window windows)
- (when (= (window-point window) point)
- (set-window-point window (point)))))))))
+ (let* ((oldbuf (current-buffer))
+ (append-to (get-buffer-create buffer))
+ (windows (get-buffer-window-list append-to t t))
+ point)
+ (save-excursion
+ (with-current-buffer append-to
+ (setq point (point))
+ (barf-if-buffer-read-only)
+ (insert-buffer-substring oldbuf start end)
+ (dolist (window windows)
+ (when (= (window-point window) point)
+ (set-window-point window (point))))))))
(defun prepend-to-buffer (buffer start end)
"Prepend to specified buffer the text of the region.
@@ -3527,29 +3691,28 @@ a mistake; see the documentation of `set-mark'."
(marker-position (mark-marker))
(signal 'mark-inactive nil)))
-(defcustom select-active-regions nil
- "If non-nil, an active region automatically becomes the window selection."
- :type 'boolean
- :group 'killing
- :version "23.1")
-
-(declare-function x-selection-owner-p "xselect.c" (&optional selection))
-
-;; Many places set mark-active directly, and several of them failed to also
-;; run deactivate-mark-hook. This shorthand should simplify.
(defsubst deactivate-mark (&optional force)
"Deactivate the mark by setting `mark-active' to nil.
Unless FORCE is non-nil, this function does nothing if Transient
Mark mode is disabled.
This function also runs `deactivate-mark-hook'."
(when (or transient-mark-mode force)
- ;; Copy the latest region into the primary selection, if desired.
- (and select-active-regions
- mark-active
- (display-selections-p)
- (x-selection-owner-p 'PRIMARY)
- (x-set-selection 'PRIMARY (buffer-substring-no-properties
- (region-beginning) (region-end))))
+ (when (and (if (eq select-active-regions 'only)
+ (eq (car-safe transient-mark-mode) 'only)
+ select-active-regions)
+ (region-active-p)
+ (display-selections-p))
+ ;; The var `saved-region-selection', if non-nil, is the text in
+ ;; the region prior to the last command modifying the buffer.
+ ;; Set the selection to that, or to the current region.
+ (cond (saved-region-selection
+ (x-set-selection 'PRIMARY saved-region-selection)
+ (setq saved-region-selection nil))
+ ((/= (region-beginning) (region-end))
+ (x-set-selection 'PRIMARY
+ (buffer-substring-no-properties
+ (region-beginning)
+ (region-end))))))
(if (and (null force)
(or (eq transient-mark-mode 'lambda)
(and (eq (car-safe transient-mark-mode) 'only)
@@ -3567,10 +3730,7 @@ This function also runs `deactivate-mark-hook'."
(when (mark t)
(setq mark-active t)
(unless transient-mark-mode
- (setq transient-mark-mode 'lambda))
- (when (and select-active-regions
- (display-selections-p))
- (x-set-selection 'PRIMARY (current-buffer)))))
+ (setq transient-mark-mode 'lambda))))
(defun set-mark (pos)
"Set this buffer's mark to POS. Don't use this function!
@@ -3593,9 +3753,6 @@ store it in a Lisp variable. Example:
(progn
(setq mark-active t)
(run-hooks 'activate-mark-hook)
- (when (and select-active-regions
- (display-selections-p))
- (x-set-selection 'PRIMARY (current-buffer)))
(set-marker (mark-marker) pos (current-buffer)))
;; Normally we never clear mark-active except in Transient Mark mode.
;; But when we actually clear out the mark value too, we must
@@ -3679,8 +3836,6 @@ Display `Mark set' unless the optional second arg NOMSG is non-nil."
(push-mark nil nomsg t)
(setq mark-active t)
(run-hooks 'activate-mark-hook)
- (and select-active-regions (display-selections-p)
- (x-set-selection 'PRIMARY (current-buffer)))
(unless nomsg
(message "Mark activated")))))
@@ -3870,8 +4025,8 @@ deactivate it, and restore the variable `transient-mark-mode' to
its earlier value."
(cond ((and shift-select-mode this-command-keys-shift-translated)
(unless (and mark-active
- (eq (car-safe transient-mark-mode) 'only))
- (setq transient-mark-mode
+ (eq (car-safe transient-mark-mode) 'only))
+ (setq transient-mark-mode
(cons 'only
(unless (eq transient-mark-mode 'lambda)
transient-mark-mode)))
@@ -3902,29 +4057,8 @@ Invoke \\[apropos-documentation] and type \"transient\" or
\"mark.*active\" at the prompt, to see the documentation of
commands which are sensitive to the Transient Mark mode."
:global t
- :init-value (not noninteractive)
- :initialize 'custom-initialize-delay
- :group 'editing-basics)
-
-;; The variable transient-mark-mode is ugly: it can take on special
-;; values. Document these here.
-(defvar transient-mark-mode t
- "*Non-nil if Transient Mark mode is enabled.
-See the command `transient-mark-mode' for a description of this minor mode.
-
-Non-nil also enables highlighting of the region whenever the mark is active.
-The variable `highlight-nonselected-windows' controls whether to highlight
-all windows or just the selected window.
-
-If the value is `lambda', that enables Transient Mark mode temporarily.
-After any subsequent action that would normally deactivate the mark
-\(such as buffer modification), Transient Mark mode is turned off.
-
-If the value is (only . OLDVAL), that enables Transient Mark mode
-temporarily. After any subsequent point motion command that is not
-shift-translated, or any other action that would normally deactivate
-the mark (such as buffer modification), the value of
-`transient-mark-mode' is set to OLDVAL.")
+ ;; It's defined in C/cus-start, this stops the d-m-m macro defining it again.
+ :variable transient-mark-mode)
(defvar widen-automatically t
"Non-nil means it is ok for commands to call `widen' when they want to.
@@ -3934,6 +4068,14 @@ the current accessible part of the buffer.
If `widen-automatically' is nil, these commands will do something else
as a fallback, and won't change the buffer bounds.")
+(defvar non-essential nil
+ "Whether the currently executing code is performing an essential task.
+This variable should be non-nil only when running code which should not
+disturb the user. E.g. it can be used to prevent Tramp from prompting the
+user for a password when we are simply scanning a set of files in the
+background or displaying possible completions before the user even asked
+for it.")
+
(defun pop-global-mark ()
"Pop off global mark ring and jump to the top location."
(interactive)
@@ -3997,9 +4139,10 @@ and more reliable (no dependence on goal column, etc.)."
(insert (if use-hard-newlines hard-newline "\n")))
(line-move arg nil nil try-vscroll))
(if (called-interactively-p 'interactive)
- (condition-case nil
+ (condition-case err
(line-move arg nil nil try-vscroll)
- ((beginning-of-buffer end-of-buffer) (ding)))
+ ((beginning-of-buffer end-of-buffer)
+ (signal (car err) (cdr err))))
(line-move arg nil nil try-vscroll)))
nil)
@@ -4027,9 +4170,10 @@ to use and more reliable (no dependence on goal column, etc.)."
(interactive "^p\np")
(or arg (setq arg 1))
(if (called-interactively-p 'interactive)
- (condition-case nil
+ (condition-case err
(line-move (- arg) nil nil try-vscroll)
- ((beginning-of-buffer end-of-buffer) (ding)))
+ ((beginning-of-buffer end-of-buffer)
+ (signal (car err) (cdr err))))
(line-move (- arg) nil nil try-vscroll))
nil)
@@ -4336,7 +4480,7 @@ into account variable-width characters and line continuation."
(let (new
(old (point))
- (line-beg (save-excursion (beginning-of-line) (point)))
+ (line-beg (line-beginning-position))
(line-end
;; Compute the end of the line
;; ignoring effectively invisible newlines.
@@ -4444,7 +4588,7 @@ and `current-column' to be able to ignore invisible text."
;; that will get us to the same place on the screen
;; but with a more reasonable buffer position.
(goto-char normal-location)
- (let ((line-beg (save-excursion (beginning-of-line) (point))))
+ (let ((line-beg (line-beginning-position)))
(while (and (not (bolp)) (invisible-p (1- (point))))
(goto-char (previous-char-property-change (point) line-beg))))))))
@@ -4467,6 +4611,9 @@ rests."
(let ((goal-column 0)
(line-move-visual nil))
(and (line-move arg t)
+ ;; With bidi reordering, we may not be at bol,
+ ;; so make sure we are.
+ (skip-chars-backward "^\n")
(not (bobp))
(progn
(while (and (not (bobp)) (invisible-p (1- (point))))
@@ -4729,52 +4876,7 @@ This also turns on `word-wrap' in the buffer."
(define-globalized-minor-mode global-visual-line-mode
visual-line-mode turn-on-visual-line-mode
:lighter " vl")
-
-(defun scroll-other-window-down (lines)
- "Scroll the \"other window\" down.
-For more details, see the documentation for `scroll-other-window'."
- (interactive "P")
- (scroll-other-window
- ;; Just invert the argument's meaning.
- ;; We can do that without knowing which window it will be.
- (if (eq lines '-) nil
- (if (null lines) '-
- (- (prefix-numeric-value lines))))))
-
-(defun beginning-of-buffer-other-window (arg)
- "Move point to the beginning of the buffer in the other window.
-Leave mark at previous position.
-With arg N, put point N/10 of the way from the true beginning."
- (interactive "P")
- (let ((orig-window (selected-window))
- (window (other-window-for-scrolling)))
- ;; We use unwind-protect rather than save-window-excursion
- ;; because the latter would preserve the things we want to change.
- (unwind-protect
- (progn
- (select-window window)
- ;; Set point and mark in that window's buffer.
- (with-no-warnings
- (beginning-of-buffer arg))
- ;; Set point accordingly.
- (recenter '(t)))
- (select-window orig-window))))
-
-(defun end-of-buffer-other-window (arg)
- "Move point to the end of the buffer in the other window.
-Leave mark at previous position.
-With arg N, put point N/10 of the way from the true end."
- (interactive "P")
- ;; See beginning-of-buffer-other-window for comments.
- (let ((orig-window (selected-window))
- (window (other-window-for-scrolling)))
- (unwind-protect
- (progn
- (select-window window)
- (with-no-warnings
- (end-of-buffer arg))
- (recenter '(t)))
- (select-window orig-window))))
+
(defun transpose-chars (arg)
"Interchange characters around point, moving forward one character.
@@ -4964,16 +5066,12 @@ If optional arg REALLY-WORD is non-nil, it finds just a word."
;; Point is neither within nor adjacent to a word.
(not strict))
;; Look for preceding word in same line.
- (skip-syntax-backward not-syntaxes
- (save-excursion (beginning-of-line)
- (point)))
+ (skip-syntax-backward not-syntaxes (line-beginning-position))
(if (bolp)
;; No preceding word in same line.
;; Look for following word in same line.
(progn
- (skip-syntax-forward not-syntaxes
- (save-excursion (end-of-line)
- (point)))
+ (skip-syntax-forward not-syntaxes (line-end-position))
(setq start (point))
(skip-syntax-forward syntaxes)
(setq end (point)))
@@ -5137,7 +5235,7 @@ Some major modes set this.")
(put 'auto-fill-function 'safe-local-variable 'null)
;; FIXME: turn into a proper minor mode.
;; Add a global minor mode version of it.
-(defun auto-fill-mode (&optional arg)
+(define-minor-mode auto-fill-mode
"Toggle Auto Fill mode.
With ARG, turn Auto Fill mode on if and only if ARG is positive.
In Auto Fill mode, inserting a space at a column beyond `current-fill-column'
@@ -5145,14 +5243,7 @@ automatically breaks the line at a previous space.
The value of `normal-auto-fill-function' specifies the function to use
for `auto-fill-function' when turning Auto Fill mode on."
- (interactive "P")
- (prog1 (setq auto-fill-function
- (if (if (null arg)
- (not auto-fill-function)
- (> (prefix-numeric-value arg) 0))
- normal-auto-fill-function
- nil))
- (force-mode-line-update)))
+ :variable (eq auto-fill-function normal-auto-fill-function))
;; This holds a document string used to document auto-fill-mode.
(defun auto-fill-function ()
@@ -5251,7 +5342,7 @@ if long lines are truncated."
(defvar overwrite-mode-binary (purecopy " Bin Ovwrt")
"The string displayed in the mode line when in binary overwrite mode.")
-(defun overwrite-mode (arg)
+(define-minor-mode overwrite-mode
"Toggle overwrite mode.
With prefix argument ARG, turn overwrite mode on if ARG is positive,
otherwise turn it off. In overwrite mode, printing characters typed
@@ -5260,14 +5351,9 @@ it to the right. At the end of a line, such characters extend the line.
Before a tab, such characters insert until the tab is filled in.
\\[quoted-insert] still inserts characters in overwrite mode; this
is supposed to make it easier to insert characters when necessary."
- (interactive "P")
- (setq overwrite-mode
- (if (if (null arg) (not overwrite-mode)
- (> (prefix-numeric-value arg) 0))
- 'overwrite-mode-textual))
- (force-mode-line-update))
+ :variable (eq overwrite-mode 'overwrite-mode-textual))
-(defun binary-overwrite-mode (arg)
+(define-minor-mode binary-overwrite-mode
"Toggle binary overwrite mode.
With prefix argument ARG, turn binary overwrite mode on if ARG is
positive, otherwise turn it off. In binary overwrite mode, printing
@@ -5280,13 +5366,7 @@ replaces the text at the cursor, just as ordinary typing characters do.
Note that binary overwrite mode is not its own minor mode; it is a
specialization of overwrite mode, entered by setting the
`overwrite-mode' variable to `overwrite-mode-binary'."
- (interactive "P")
- (setq overwrite-mode
- (if (if (null arg)
- (not (eq overwrite-mode 'overwrite-mode-binary))
- (> (prefix-numeric-value arg) 0))
- 'overwrite-mode-binary))
- (force-mode-line-update))
+ :variable (eq overwrite-mode 'overwrite-mode-binary))
(define-minor-mode line-number-mode
"Toggle Line Number mode.
@@ -5312,6 +5392,26 @@ With ARG, turn Size Indication mode on if ARG is positive,
otherwise turn it off. When Size Indication mode is enabled, the
size of the accessible part of the buffer appears in the mode line."
:global t :group 'mode-line)
+
+(define-minor-mode auto-save-mode
+ "Toggle auto-saving of contents of current buffer.
+With prefix argument ARG, turn auto-saving on if positive, else off."
+ :variable ((and buffer-auto-save-file-name
+ ;; If auto-save is off because buffer has shrunk,
+ ;; then toggling should turn it on.
+ (>= buffer-saved-size 0))
+ . (lambda (val)
+ (setq buffer-auto-save-file-name
+ (cond
+ ((null val) nil)
+ ((and buffer-file-name auto-save-visited-file-name
+ (not buffer-read-only))
+ buffer-file-name)
+ (t (make-auto-save-file-name))))))
+ ;; If -1 was stored here, to temporarily turn off saving,
+ ;; turn it back on.
+ (and (< buffer-saved-size 0)
+ (setq buffer-saved-size 0)))
(defgroup paren-blinking nil
"Blinking matching of parens and expressions."
@@ -5353,21 +5453,40 @@ it skips the contents of comments that end before point."
:type 'boolean
:group 'paren-blinking)
+(defun blink-matching-check-mismatch (start end)
+ "Return whether or not START...END are matching parens.
+END is the current point and START is the blink position.
+START might be nil if no matching starter was found.
+Returns non-nil if we find there is a mismatch."
+ (let* ((end-syntax (syntax-after (1- end)))
+ (matching-paren (and (consp end-syntax)
+ (eq (syntax-class end-syntax) 5)
+ (cdr end-syntax))))
+ ;; For self-matched chars like " and $, we can't know when they're
+ ;; mismatched or unmatched, so we can only do it for parens.
+ (when matching-paren
+ (not (and start
+ (or
+ (eq (char-after start) matching-paren)
+ ;; The cdr might hold a new paren-class info rather than
+ ;; a matching-char info, in which case the two CDRs
+ ;; should match.
+ (eq matching-paren (cdr-safe (syntax-after start)))))))))
+
+(defvar blink-matching-check-function #'blink-matching-check-mismatch
+ "Function to check parentheses mismatches.
+The function takes two arguments (START and END) where START is the
+position just before the opening token and END is the position right after.
+START can be nil, if it was not found.
+The function should return non-nil if the two tokens do not match.")
+
(defun blink-matching-open ()
"Move cursor momentarily to the beginning of the sexp before point."
(interactive)
- (when (and (> (point) (point-min))
- blink-matching-paren
- ;; Verify an even number of quoting characters precede the close.
- (= 1 (logand 1 (- (point)
- (save-excursion
- (forward-char -1)
- (skip-syntax-backward "/\\")
- (point))))))
+ (when (and (not (bobp))
+ blink-matching-paren)
(let* ((oldpos (point))
- (message-log-max nil) ; Don't log messages about paren matching.
- (atdollar (eq (syntax-class (syntax-after (1- oldpos))) 8))
- (isdollar)
+ (message-log-max nil) ; Don't log messages about paren matching.
(blinkpos
(save-excursion
(save-restriction
@@ -5380,38 +5499,29 @@ it skips the contents of comments that end before point."
(and parse-sexp-ignore-comments
(not blink-matching-paren-dont-ignore-comments))))
(condition-case ()
- (scan-sexps oldpos -1)
+ (progn
+ (forward-sexp -1)
+ ;; backward-sexp skips backward over prefix chars,
+ ;; so move back to the matching paren.
+ (while (and (< (point) (1- oldpos))
+ (let ((code (syntax-after (point))))
+ (or (eq (syntax-class code) 6)
+ (eq (logand 1048576 (car code))
+ 1048576))))
+ (forward-char 1))
+ (point))
(error nil))))))
- (matching-paren
- (and blinkpos
- ;; Not syntax '$'.
- (not (setq isdollar
- (eq (syntax-class (syntax-after blinkpos)) 8)))
- (let ((syntax (syntax-after blinkpos)))
- (and (consp syntax)
- (eq (syntax-class syntax) 4)
- (cdr syntax))))))
+ (mismatch (funcall blink-matching-check-function blinkpos oldpos)))
(cond
- ;; isdollar is for:
- ;; http://lists.gnu.org/archive/html/emacs-devel/2007-10/msg00871.html
- ((not (or (and isdollar blinkpos)
- (and atdollar (not blinkpos)) ; see below
- (eq matching-paren (char-before oldpos))
- ;; The cdr might hold a new paren-class info rather than
- ;; a matching-char info, in which case the two CDRs
- ;; should match.
- (eq matching-paren (cdr (syntax-after (1- oldpos))))))
- (if (minibufferp)
- (minibuffer-message " [Mismatched parentheses]")
- (message "Mismatched parentheses")))
- ((not blinkpos)
- (or blink-matching-paren-distance
- ;; Don't complain when `$' with no blinkpos, because it
- ;; could just be the first one typed in the buffer.
- atdollar
+ (mismatch
+ (if blinkpos
(if (minibufferp)
- (minibuffer-message " [Unmatched parenthesis]")
- (message "Unmatched parenthesis"))))
+ (minibuffer-message " [Mismatched parentheses]")
+ (message "Mismatched parentheses"))
+ (if (minibufferp)
+ (minibuffer-message " [Unmatched parenthesis]")
+ (message "Unmatched parenthesis"))))
+ ((not blinkpos) nil)
((pos-visible-in-window-p blinkpos)
;; Matching open within window, temporarily move to blinkpos but only
;; if `blink-matching-paren-on-screen' is non-nil.
@@ -5454,7 +5564,29 @@ it skips the contents of comments that end before point."
(message "Matches %s"
(substring-no-properties open-paren-line-string)))))))))
-(setq blink-paren-function 'blink-matching-open)
+(defvar blink-paren-function 'blink-matching-open
+ "Function called, if non-nil, whenever a close parenthesis is inserted.
+More precisely, a char with closeparen syntax is self-inserted.")
+
+(defun blink-paren-post-self-insert-function ()
+ (when (and (eq (char-before) last-command-event) ; Sanity check.
+ (memq (char-syntax last-command-event) '(?\) ?\$))
+ blink-paren-function
+ (not executing-kbd-macro)
+ (not noninteractive)
+ ;; Verify an even number of quoting characters precede the close.
+ (= 1 (logand 1 (- (point)
+ (save-excursion
+ (forward-char -1)
+ (skip-syntax-backward "/\\")
+ (point))))))
+ (funcall blink-paren-function)))
+
+(add-hook 'post-self-insert-hook #'blink-paren-post-self-insert-function
+ ;; Most likely, this hook is nil, so this arg doesn't matter,
+ ;; but I use it as a reminder that this function usually
+ ;; likes to be run after others since it does `sit-for'.
+ 'append)
;; This executes C-g typed while Emacs is waiting for a command.
;; Quitting out of a program does not go through here;
@@ -5464,7 +5596,10 @@ it skips the contents of comments that end before point."
During execution of Lisp code, this character causes a quit directly.
At top-level, as an editor command, this simply beeps."
(interactive)
- (deactivate-mark)
+ ;; Avoid adding the region to the window selection.
+ (setq saved-region-selection nil)
+ (let (select-active-regions)
+ (deactivate-mark))
(if (fboundp 'kmacro-keyboard-quit)
(kmacro-keyboard-quit))
(setq defining-kbd-macro nil)
@@ -5484,12 +5619,12 @@ cancel the use of the current buffer (for special-purpose buffers),
or go back to just one window (by deleting all but the selected window)."
(interactive)
(cond ((eq last-command 'mode-exited) nil)
+ ((region-active-p)
+ (deactivate-mark))
((> (minibuffer-depth) 0)
(abort-recursive-edit))
(current-prefix-arg
nil)
- ((region-active-p)
- (deactivate-mark))
((> (recursion-depth) 0)
(exit-recursive-edit))
(buffer-quit-function
@@ -6415,6 +6550,7 @@ call `normal-erase-is-backspace-mode' (which see) instead."
(if (if (eq normal-erase-is-backspace 'maybe)
(and (not noninteractive)
(or (memq system-type '(ms-dos windows-nt))
+ (memq window-system '(ns))
(and (memq window-system '(x))
(fboundp 'x-backspace-delete-keys-p)
(x-backspace-delete-keys-p))
@@ -6426,7 +6562,7 @@ call `normal-erase-is-backspace-mode' (which see) instead."
normal-erase-is-backspace)
1 0)))))
-(defun normal-erase-is-backspace-mode (&optional arg)
+(define-minor-mode normal-erase-is-backspace-mode
"Toggle the Erase and Delete mode of the Backspace and Delete keys.
With numeric ARG, turn the mode on if and only if ARG is positive.
@@ -6456,13 +6592,10 @@ probably not turn on this mode on a text-only terminal if you don't
have both Backspace, Delete and F1 keys.
See also `normal-erase-is-backspace'."
- (interactive "P")
- (let ((enabled (or (and arg (> (prefix-numeric-value arg) 0))
- (not (or arg
- (eq 1 (terminal-parameter
- nil 'normal-erase-is-backspace)))))))
- (set-terminal-parameter nil 'normal-erase-is-backspace
- (if enabled 1 0))
+ :variable (eq (terminal-parameter
+ nil 'normal-erase-is-backspace) 1)
+ (let ((enabled (eq 1 (terminal-parameter
+ nil 'normal-erase-is-backspace))))
(cond ((or (memq window-system '(x w32 ns pc))
(memq system-type '(ms-dos windows-nt)))
@@ -6474,7 +6607,7 @@ See also `normal-erase-is-backspace'."
(if enabled
(progn
- (define-key local-function-key-map [delete] [?\C-d])
+ (define-key local-function-key-map [delete] [deletechar])
(define-key local-function-key-map [kp-delete] [?\C-d])
(define-key local-function-key-map [backspace] [?\C-?])
(dolist (b bindings)
@@ -6498,7 +6631,6 @@ See also `normal-erase-is-backspace'."
(keyboard-translate ?\C-h ?\C-h)
(keyboard-translate ?\C-? ?\C-?))))
- (run-hooks 'normal-erase-is-backspace-hook)
(if (called-interactively-p 'interactive)
(message "Delete key deletes %s"
(if (eq 1 (terminal-parameter nil 'normal-erase-is-backspace))
@@ -6535,52 +6667,6 @@ the first N arguments are fixed at the values with which this function
was called."
(lexical-let ((fun fun) (args1 args))
(lambda (&rest args2) (apply fun (append args1 args2)))))
-
-;; This function is here rather than in subr.el because it uses CL.
-(defmacro with-wrapper-hook (var args &rest body)
- "Run BODY wrapped with the VAR hook.
-VAR is a special hook: its functions are called with a first argument
-which is the \"original\" code (the BODY), so the hook function can wrap
-the original function, or call it any number of times (including not calling
-it at all). This is similar to an `around' advice.
-VAR is normally a symbol (a variable) in which case it is treated like
-a hook, with a buffer-local and a global part. But it can also be an
-arbitrary expression.
-ARGS is a list of variables which will be passed as additional arguments
-to each function, after the initial argument, and which the first argument
-expects to receive when called."
- (declare (indent 2) (debug t))
- ;; We need those two gensyms because CL's lexical scoping is not available
- ;; for function arguments :-(
- (let ((funs (make-symbol "funs"))
- (global (make-symbol "global"))
- (argssym (make-symbol "args")))
- ;; Since the hook is a wrapper, the loop has to be done via
- ;; recursion: a given hook function will call its parameter in order to
- ;; continue looping.
- `(labels ((runrestofhook (,funs ,global ,argssym)
- ;; `funs' holds the functions left on the hook and `global'
- ;; holds the functions left on the global part of the hook
- ;; (in case the hook is local).
- (lexical-let ((funs ,funs)
- (global ,global))
- (if (consp funs)
- (if (eq t (car funs))
- (runrestofhook
- (append global (cdr funs)) nil ,argssym)
- (apply (car funs)
- (lambda (&rest ,argssym)
- (runrestofhook (cdr funs) global ,argssym))
- ,argssym))
- ;; Once there are no more functions on the hook, run
- ;; the original body.
- (apply (lambda ,args ,@body) ,argssym)))))
- (runrestofhook ,var
- ;; The global part of the hook, if any.
- ,(if (symbolp var)
- `(if (local-variable-p ',var)
- (default-value ',var)))
- (list ,@args)))))
;; Minibuffer prompt stuff.
@@ -6657,5 +6743,4 @@ warning using STRING as the message.")
(provide 'simple)
-;; arch-tag: 24af67c0-2a49-44f6-b3b1-312d8b570dfd
;;; simple.el ends here
diff --git a/lisp/skeleton.el b/lisp/skeleton.el
index b228b5031b2..0c3e0e8c413 100644
--- a/lisp/skeleton.el
+++ b/lisp/skeleton.el
@@ -1,7 +1,7 @@
;;; skeleton.el --- Lisp language extension for writing statement skeletons -*- coding: utf-8 -*-
-;; Copyright (C) 1993, 1994, 1995, 1996, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1994, 1995, 1996, 2001, 2002, 2003, 2004, 2005,
+;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Daniel Pfeiffer <occitan@esperanto.org>
;; Maintainer: FSF
@@ -108,7 +108,7 @@ The list describes the most recent skeleton insertion, and its elements
are integer buffer positions in the reverse order of the insertion order.")
;; reduce the number of compiler warnings
-(defvar skeleton)
+(defvar skeleton-il)
(defvar skeleton-modified)
(defvar skeleton-point)
(defvar skeleton-regions)
@@ -299,7 +299,10 @@ automatically, and you are prompted to fill in the variable parts.")))
(eolp (eolp)))
;; since Emacs doesn't show main window's cursor, do something noticeable
(or eolp
- (open-line 1))
+ ;; We used open-line before, but that can do a lot more than we want,
+ ;; since it runs self-insert-command. E.g. it may remove spaces
+ ;; before point.
+ (save-excursion (insert "\n")))
(unwind-protect
(setq prompt (if (stringp prompt)
(read-string (format prompt skeleton-subprompt)
@@ -317,25 +320,26 @@ automatically, and you are prompted to fill in the variable parts.")))
(signal 'quit t)
prompt))
-(defun skeleton-internal-list (skeleton &optional str recursive)
- (let* ((start (save-excursion (beginning-of-line) (point)))
+(defun skeleton-internal-list (skeleton-il &optional str recursive)
+ (let* ((start (line-beginning-position))
(column (current-column))
(line (buffer-substring start (line-end-position)))
opoint)
(or str
- (setq str `(setq str (skeleton-read ',(car skeleton) nil ,recursive))))
- (when (and (eq (cadr skeleton) '\n) (not recursive)
+ (setq str `(setq str
+ (skeleton-read ',(car skeleton-il) nil ,recursive))))
+ (when (and (eq (cadr skeleton-il) '\n) (not recursive)
(save-excursion (skip-chars-backward " \t") (bolp)))
- (setq skeleton (cons nil (cons '> (cddr skeleton)))))
+ (setq skeleton-il (cons nil (cons '> (cddr skeleton-il)))))
(while (setq skeleton-modified (eq opoint (point))
opoint (point)
- skeleton (cdr skeleton))
+ skeleton-il (cdr skeleton-il))
(condition-case quit
- (skeleton-internal-1 (car skeleton) nil recursive)
+ (skeleton-internal-1 (car skeleton-il) nil recursive)
(quit
(if (eq (cdr quit) 'recursive)
(setq recursive 'quit
- skeleton (memq 'resume: skeleton))
+ skeleton-il (memq 'resume: skeleton-il))
;; Remove the subskeleton as far as it has been shown
;; the subskeleton shouldn't have deleted outside current line.
(end-of-line)
@@ -343,7 +347,7 @@ automatically, and you are prompted to fill in the variable parts.")))
(insert line)
(move-to-column column)
(if (cdr quit)
- (setq skeleton ()
+ (setq skeleton-il ()
recursive nil)
(signal 'quit 'recursive)))))))
;; maybe continue loop or go on to next outer resume: section
@@ -351,6 +355,16 @@ automatically, and you are prompted to fill in the variable parts.")))
(signal 'quit 'recursive)
recursive))
+(defun skeleton-newline ()
+ (if (or (eq (point) skeleton-point)
+ (eq (point) (car skeleton-positions)))
+ ;; If point is recorded, avoid `newline' since it may do things like
+ ;; strip trailing spaces, and since recorded points are commonly placed
+ ;; right after a trailing space, calling `newline' can destroy the
+ ;; position and renders the recorded position incorrect.
+ (insert "\n")
+ (newline)))
+
(defun skeleton-internal-1 (element &optional literal recursive)
(cond
((or (integerp element) (stringp element))
@@ -358,36 +372,36 @@ automatically, and you are prompted to fill in the variable parts.")))
(< element 0))
(if skeleton-untabify
(backward-delete-char-untabify (- element))
- (delete-backward-char (- element)))
+ (delete-char element))
(insert (if (not literal)
(funcall skeleton-transformation-function element)
element))))
((or (eq element '\n) ; actually (eq '\n 'n)
;; The sequence `> \n' is handled specially so as to indent the first
;; line after inserting the newline (to get the proper indentation).
- (and (eq element '>) (eq (nth 1 skeleton) '\n) (pop skeleton)))
+ (and (eq element '>) (eq (nth 1 skeleton-il) '\n) (pop skeleton-il)))
(let ((pos (if (eq element '>) (point))))
(cond
- ((and skeleton-regions (eq (nth 1 skeleton) '_))
+ ((and skeleton-regions (eq (nth 1 skeleton-il) '_))
(or (eolp) (newline))
(if pos (save-excursion (goto-char pos) (indent-according-to-mode)))
(indent-region (line-beginning-position)
(car skeleton-regions) nil))
;; \n as last element only inserts \n if not at eol.
- ((and (null (cdr skeleton)) (not recursive) (eolp))
+ ((and (null (cdr skeleton-il)) (not recursive) (eolp))
(if pos (indent-according-to-mode)))
(skeleton-newline-indent-rigidly
(let ((pt (point)))
- (newline)
+ (skeleton-newline)
(indent-to (save-excursion
(goto-char pt)
(if pos (indent-according-to-mode))
(current-indentation)))))
(t (if pos (reindent-then-newline-and-indent)
- (newline)
+ (skeleton-newline)
(indent-according-to-mode))))))
((eq element '>)
- (if (and skeleton-regions (eq (nth 1 skeleton) '_))
+ (if (and skeleton-regions (eq (nth 1 skeleton-il) '_))
(indent-region (line-beginning-position)
(car skeleton-regions) nil)
(indent-according-to-mode)))
@@ -396,16 +410,16 @@ automatically, and you are prompted to fill in the variable parts.")))
(progn
(goto-char (pop skeleton-regions))
(and (<= (current-column) (current-indentation))
- (eq (nth 1 skeleton) '\n)
+ (eq (nth 1 skeleton-il) '\n)
(end-of-line 0)))
(or skeleton-point
(setq skeleton-point (point)))))
((eq element '-)
(setq skeleton-point (point)))
((eq element '&)
- (when skeleton-modified (pop skeleton)))
+ (when skeleton-modified (pop skeleton-il)))
((eq element '|)
- (unless skeleton-modified (pop skeleton)))
+ (unless skeleton-modified (pop skeleton-il)))
((eq element '@)
(push (point) skeleton-positions))
((eq 'quote (car-safe element))
@@ -562,5 +576,4 @@ symmetrical ones, and the same character twice for the others."
(provide 'skeleton)
-;; arch-tag: ccad7bd5-eb5d-40de-9ded-900197215c3e
;;; skeleton.el ends here
diff --git a/lisp/sort.el b/lisp/sort.el
index a858ad1f8f7..d4bbf6df056 100644
--- a/lisp/sort.el
+++ b/lisp/sort.el
@@ -1,7 +1,7 @@
;;; sort.el --- commands to sort text in an Emacs buffer
-;; Copyright (C) 1986, 1987, 1994, 1995, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1986, 1987, 1994, 1995, 2001, 2002, 2003, 2004, 2005,
+;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Howie Kaye
;; Maintainer: FSF
@@ -361,8 +361,8 @@ the sort order."
(if (eolp)
(error "Line has too few fields: %s"
(buffer-substring
- (save-excursion (beginning-of-line) (point))
- (save-excursion (end-of-line) (point))))))
+ (line-beginning-position)
+ (line-end-position)))))
(end-of-line)
;; Skip back across - N - 1 fields.
(let ((i (1- (- n))))
@@ -374,8 +374,8 @@ the sort order."
(if (bolp)
(error "Line has too few fields: %s"
(buffer-substring
- (save-excursion (beginning-of-line) (point))
- (save-excursion (end-of-line) (point)))))
+ (line-beginning-position)
+ (line-end-position))))
;; Position at the front of the field
;; even if moving backwards.
(skip-chars-backward "^ \t\n")))
@@ -559,5 +559,4 @@ From a program takes two point or marker arguments, BEG and END."
(provide 'sort)
-;; arch-tag: fbac12be-2a7b-4c8a-9665-264d61f70bd9
;;; sort.el ends here
diff --git a/lisp/speedbar.el b/lisp/speedbar.el
index d46dba39e85..7413f73ee50 100644
--- a/lisp/speedbar.el
+++ b/lisp/speedbar.el
@@ -1472,7 +1472,7 @@ File style information is displayed with `speedbar-item-info'."
(if (looking-at "\\s-*[[<({].[]>)}] ") (goto-char (match-end 0)))
;; Get the text
(speedbar-message "Text: %s" (buffer-substring-no-properties
- (point) (progn (end-of-line) (point))))))
+ (point) (line-end-position)))))
(defun speedbar-item-info ()
"Display info in the minibuffer about the button the mouse is over.
@@ -1498,8 +1498,7 @@ instead of reading it from the speedbar buffer."
Return nil if not applicable."
(save-excursion
(beginning-of-line)
- (if (re-search-forward " [-+=]?> \\([^\n]+\\)"
- (save-excursion(end-of-line)(point)) t)
+ (if (re-search-forward " [-+=]?> \\([^\n]+\\)" (line-end-position) t)
(let* ((tag (match-string 1))
(attr (speedbar-line-token))
(item nil)
@@ -1517,8 +1516,7 @@ Return nil if not applicable."
(looking-at "\\([0-9]+\\):")
(setq item (file-name-nondirectory (speedbar-line-directory)))
(speedbar-message "Tag: %s in %s" tag item)))
- (if (re-search-forward "{[+-]} \\([^\n]+\\)$"
- (save-excursion(end-of-line)(point)) t)
+ (if (re-search-forward "{[+-]} \\([^\n]+\\)$" (line-end-position) t)
(speedbar-message "Group of tags \"%s\"" (match-string 1))
(if (re-search-forward " [+-]?[()|@] \\([^\n]+\\)$" nil t)
(let* ((detailtext (match-string 1))
@@ -1645,8 +1643,8 @@ Files can be renamed to new names or moved to new directories."
(if (speedbar-y-or-n-p (format "Delete %s? " f) t)
(progn
(if (file-directory-p f)
- (delete-directory f)
- (delete-file f))
+ (delete-directory f t t)
+ (delete-file f t))
(speedbar-message "Okie dokie.")
(let ((p (point)))
(speedbar-refresh)
@@ -2061,8 +2059,7 @@ position to insert a new item, and that the new item will end with a CR."
"Change the expansion button character to CHAR for the current line."
(save-excursion
(beginning-of-line)
- (if (re-search-forward ":\\s-*.\\([-+?]\\)" (save-excursion (end-of-line)
- (point)) t)
+ (if (re-search-forward ":\\s-*.\\([-+?]\\)" (line-end-position) t)
(speedbar-with-writable
(goto-char (match-end 1))
(insert-char char 1 t)
@@ -2851,9 +2848,7 @@ indicator, then do not add a space."
(speedbar-with-writable
(save-excursion
(if (and replace-this
- (re-search-forward replace-this (save-excursion (end-of-line)
- (point))
- t))
+ (re-search-forward replace-this (line-end-position) t))
(delete-region (match-beginning 0) (match-end 0))))
(end-of-line)
(if (not (string= " " indicator-string))
@@ -2951,9 +2946,7 @@ the file being checked."
(fn (buffer-substring-no-properties
;; Skip-chars: thanks ptype@dra.hmg.gb
(point) (progn
- (skip-chars-forward "^ "
- (save-excursion (end-of-line)
- (point)))
+ (skip-chars-forward "^ " (line-end-position))
(point))))
(fulln (concat f fn)))
(if (<= 2 speedbar-verbosity-level)
@@ -3025,9 +3018,7 @@ the file being checked."
(fn (buffer-substring-no-properties
;; Skip-chars: thanks ptype@dra.hmg.gb
(point) (progn
- (skip-chars-forward "^ "
- (save-excursion (end-of-line)
- (point)))
+ (skip-chars-forward "^ " (line-end-position))
(point))))
(fulln (concat f fn)))
(if (<= 2 speedbar-verbosity-level)
@@ -3248,7 +3239,7 @@ directory with these items."
;; If this fails, then it is a non-standard click, and as such,
;; perfectly allowed.
(if (re-search-forward "[]>?}] [^ ]"
- (save-excursion (end-of-line) (point))
+ (line-end-position)
t)
(progn
(forward-char -1)
@@ -3266,7 +3257,7 @@ With universal argument ARG, flush cached data."
(condition-case nil
(progn
(re-search-forward ":\\s-*.\\+. "
- (save-excursion (end-of-line) (point)))
+ (line-end-position))
(forward-char -2)
(speedbar-do-function-pointer))
(error (speedbar-position-cursor-on-line)))))
@@ -3283,7 +3274,7 @@ With universal argument ARG, flush cached data."
(condition-case nil
(progn
(re-search-forward ":\\s-*.-. "
- (save-excursion (end-of-line) (point)))
+ (line-end-position))
(forward-char -2)
(speedbar-do-function-pointer))
(error (speedbar-position-cursor-on-line))))
@@ -3295,7 +3286,7 @@ With universal argument ARG, flush cached data."
(condition-case nil
(progn
(re-search-forward ":\\s-*.[-+]. "
- (save-excursion (end-of-line) (point)))
+ (line-end-position))
(forward-char -2)
(speedbar-do-function-pointer))
(error (speedbar-position-cursor-on-line))))
@@ -3763,17 +3754,12 @@ The line should contain output from etags. Parse the output using the
regular expression EXPR."
(let* ((sym (if (stringp expr)
(if (save-excursion
- (re-search-forward expr (save-excursion
- (end-of-line)
- (point)) t))
+ (re-search-forward expr (line-end-position) t))
(buffer-substring-no-properties (match-beginning 1)
(match-end 1)))
(funcall expr)))
(pos (let ((j (re-search-forward "[\C-?\C-a]\\([0-9]+\\),\\([0-9]+\\)"
- (save-excursion
- (end-of-line)
- (point))
- t)))
+ (line-end-position) t)))
(if (and j sym)
(1+ (string-to-number (buffer-substring-no-properties
(match-beginning 2)
@@ -3786,7 +3772,7 @@ regular expression EXPR."
(defun speedbar-parse-c-or-c++tag ()
"Parse a C or C++ tag, which tends to be a little complex."
(save-excursion
- (let ((bound (save-excursion (end-of-line) (point))))
+ (let ((bound (line-end-position)))
(cond ((re-search-forward "\C-?\\([^\C-a]+\\)\C-a" bound t)
(buffer-substring-no-properties (match-beginning 1)
(match-end 1)))
@@ -3802,7 +3788,7 @@ regular expression EXPR."
(defun speedbar-parse-tex-string ()
"Parse a Tex string. Only find data which is relevant."
(save-excursion
- (let ((bound (save-excursion (end-of-line) (point))))
+ (let ((bound (line-end-position)))
(cond ((re-search-forward "\\(\\(sub\\)*section\\|chapter\\|cite\\)\\s-*{[^\C-?}]*}?" bound t)
(buffer-substring-no-properties (match-beginning 0)
(match-end 0)))
@@ -3947,9 +3933,7 @@ Optional argument DEPTH specifies the current depth of the back search."
(let* ((bn (speedbar-line-text))
(buffer (if bn (get-buffer bn))))
(if buffer
- (if (save-excursion
- (end-of-line)
- (eq start (point)))
+ (if (eq start (line-end-position))
(or (with-current-buffer buffer default-directory)
"")
(buffer-file-name buffer))))))))
@@ -3981,14 +3965,10 @@ TEXT is the buffer's name, TOKEN and INDENT are unused."
(beginning-of-line)
;; If this fails, then it is a non-standard click, and as such,
;; perfectly allowed
- (if (re-search-forward "[]>?}] [^ ]"
- (save-excursion (end-of-line) (point))
- t)
+ (if (re-search-forward "[]>?}] [^ ]" (line-end-position) t)
(let ((text (progn
(forward-char -1)
- (buffer-substring (point) (save-excursion
- (end-of-line)
- (point))))))
+ (buffer-substring (point) (line-end-position)))))
(if (get-buffer text)
(progn
(set-buffer text)
@@ -4004,14 +3984,11 @@ TEXT is the buffer's name, TOKEN and INDENT are unused."
"Highlight the current line, unhighlighting a previously jumped to line."
(speedbar-unhighlight-one-tag-line)
(setq speedbar-highlight-one-tag-line
- (speedbar-make-overlay (save-excursion (beginning-of-line) (point))
- (save-excursion (end-of-line)
- (forward-char 1)
- (point))))
+ (speedbar-make-overlay (line-beginning-position)
+ (1+ (line-end-position))))
(speedbar-overlay-put speedbar-highlight-one-tag-line 'face
'speedbar-highlight-face)
- (add-hook 'pre-command-hook 'speedbar-unhighlight-one-tag-line)
- )
+ (add-hook 'pre-command-hook 'speedbar-unhighlight-one-tag-line))
(defun speedbar-unhighlight-one-tag-line ()
"Unhighlight the currently highlighted line."
diff --git a/lisp/startup.el b/lisp/startup.el
index 87f1a00bd54..99189b1df72 100644
--- a/lisp/startup.el
+++ b/lisp/startup.el
@@ -1,11 +1,12 @@
;;; startup.el --- process Emacs shell arguments
-;; Copyright (C) 1985, 1986, 1992, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
-;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Copyright (C) 1985, 1986, 1992, 1994, 1995, 1996, 1997, 1998, 1999,
+;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -199,47 +200,47 @@ and VALUE is the value which is given to that frame parameter
;;("-bw" . x-handle-numeric-switch)
;;("-d" . x-handle-display)
;;("-display" . x-handle-display)
- ("-name" 1 ns-handle-name-switch)
- ("-title" 1 ns-handle-switch title)
- ("-T" 1 ns-handle-switch title)
- ("-r" 0 ns-handle-switch reverse t)
- ("-rv" 0 ns-handle-switch reverse t)
- ("-reverse" 0 ns-handle-switch reverse t)
- ("-fn" 1 ns-handle-switch font)
- ("-font" 1 ns-handle-switch font)
- ("-ib" 1 ns-handle-numeric-switch internal-border-width)
+ ("-name" 1 x-handle-name-switch)
+ ("-title" 1 x-handle-switch title)
+ ("-T" 1 x-handle-switch title)
+ ("-r" 0 x-handle-switch reverse t)
+ ("-rv" 0 x-handle-switch reverse t)
+ ("-reverse" 0 x-handle-switch reverse t)
+ ("-fn" 1 x-handle-switch font)
+ ("-font" 1 x-handle-switch font)
+ ("-ib" 1 x-handle-numeric-switch internal-border-width)
;;("-g" . x-handle-geometry)
;;("-geometry" . x-handle-geometry)
- ("-fg" 1 ns-handle-switch foreground-color)
- ("-foreground" 1 ns-handle-switch foreground-color)
- ("-bg" 1 ns-handle-switch background-color)
- ("-background" 1 ns-handle-switch background-color)
-; ("-ms" 1 ns-handle-switch mouse-color)
- ("-itype" 0 ns-handle-switch icon-type t)
- ("-i" 0 ns-handle-switch icon-type t)
- ("-iconic" 0 ns-handle-iconic icon-type t)
+ ("-fg" 1 x-handle-switch foreground-color)
+ ("-foreground" 1 x-handle-switch foreground-color)
+ ("-bg" 1 x-handle-switch background-color)
+ ("-background" 1 x-handle-switch background-color)
+; ("-ms" 1 x-handle-switch mouse-color)
+ ("-itype" 0 x-handle-switch icon-type t)
+ ("-i" 0 x-handle-switch icon-type t)
+ ("-iconic" 0 x-handle-iconic icon-type t)
;;("-xrm" . x-handle-xrm-switch)
- ("-cr" 1 ns-handle-switch cursor-color)
- ("-vb" 0 ns-handle-switch vertical-scroll-bars t)
- ("-hb" 0 ns-handle-switch horizontal-scroll-bars t)
- ("-bd" 1 ns-handle-switch)
- ;; ("--border-width" 1 ns-handle-numeric-switch border-width)
+ ("-cr" 1 x-handle-switch cursor-color)
+ ("-vb" 0 x-handle-switch vertical-scroll-bars t)
+ ("-hb" 0 x-handle-switch horizontal-scroll-bars t)
+ ("-bd" 1 x-handle-switch)
+ ;; ("--border-width" 1 x-handle-numeric-switch border-width)
;; ("--display" 1 ns-handle-display)
- ("--name" 1 ns-handle-name-switch)
- ("--title" 1 ns-handle-switch title)
- ("--reverse-video" 0 ns-handle-switch reverse t)
- ("--font" 1 ns-handle-switch font)
- ("--internal-border" 1 ns-handle-numeric-switch internal-border-width)
+ ("--name" 1 x-handle-name-switch)
+ ("--title" 1 x-handle-switch title)
+ ("--reverse-video" 0 x-handle-switch reverse t)
+ ("--font" 1 x-handle-switch font)
+ ("--internal-border" 1 x-handle-numeric-switch internal-border-width)
;; ("--geometry" 1 ns-handle-geometry)
- ("--foreground-color" 1 ns-handle-switch foreground-color)
- ("--background-color" 1 ns-handle-switch background-color)
- ("--mouse-color" 1 ns-handle-switch mouse-color)
- ("--icon-type" 0 ns-handle-switch icon-type t)
- ("--iconic" 0 ns-handle-iconic)
+ ("--foreground-color" 1 x-handle-switch foreground-color)
+ ("--background-color" 1 x-handle-switch background-color)
+ ("--mouse-color" 1 x-handle-switch mouse-color)
+ ("--icon-type" 0 x-handle-switch icon-type t)
+ ("--iconic" 0 x-handle-iconic)
;; ("--xrm" 1 ns-handle-xrm-switch)
- ("--cursor-color" 1 ns-handle-switch cursor-color)
- ("--vertical-scroll-bars" 0 ns-handle-switch vertical-scroll-bars t)
- ("--border-color" 1 ns-handle-switch border-width))
+ ("--cursor-color" 1 x-handle-switch cursor-color)
+ ("--vertical-scroll-bars" 0 x-handle-switch vertical-scroll-bars t)
+ ("--border-color" 1 x-handle-switch border-width))
"Alist of NS options.
Each element has the form
(NAME NUMARGS HANDLER FRAME-PARAM VALUE)
@@ -465,9 +466,6 @@ or `CVS', and any subdirectory that contains a file named `.nosearch'."
;; `user-full-name' is now known; reset its standard-value here.
(put 'user-full-name 'standard-value
(list (default-value 'user-full-name)))
- ;; For root, preserve owner and group when editing files.
- (if (equal (user-uid) 0)
- (setq backup-by-copying-when-mismatch t))
;; Look in each dir in load-path for a subdirs.el file.
;; If we find one, load it, which will add the appropriate subdirs
;; of that dir into load-path,
@@ -690,6 +688,9 @@ opening the first frame (e.g. open a connection to an X server).")
(defvar server-name)
(defvar server-process)
+;; Autoload in package.el, but when we bootstrap, we don't have loaddefs yet.
+(defvar package-enable-at-startup)
+(declare-function package-initialize "package" (&optional no-activate))
(defun command-line ()
(setq before-init-time (current-time)
@@ -785,15 +786,16 @@ opening the first frame (e.g. open a connection to an X server).")
argi (match-string 1 argi)))
(when (string-match "\\`--." orig-argi)
(let ((completion (try-completion argi longopts)))
- (if (eq completion t)
- (setq argi (substring argi 1))
- (if (stringp completion)
- (let ((elt (assoc completion longopts)))
- (or elt
- (error "Option `%s' is ambiguous" argi))
- (setq argi (substring (car elt) 1)))
- (setq argval nil
- argi orig-argi)))))
+ (cond ((eq completion t)
+ (setq argi (substring argi 1)))
+ ((stringp completion)
+ (let ((elt (assoc completion longopts)))
+ (unless elt
+ (error "Option `%s' is ambiguous" argi))
+ (setq argi (substring (car elt) 1))))
+ (t
+ (setq argval nil
+ argi orig-argi)))))
(cond
;; The --display arg is handled partly in C, partly in Lisp.
;; When it shows up here, we just put it back to be handled
@@ -878,10 +880,40 @@ opening the first frame (e.g. open a connection to an X server).")
(run-hooks 'before-init-hook)
- ;; Under X Window, this creates the X frame and deletes the terminal frame.
+ ;; Under X, this creates the X frame and deletes the terminal frame.
(unless (daemonp)
+
+ ;; If X resources are available, use them to initialize the values
+ ;; of `tool-bar-mode' and `menu-bar-mode', as well as the value of
+ ;; `no-blinking-cursor' and the `cursor' face.
+ (cond
+ ((or noninteractive emacs-basic-display)
+ (setq menu-bar-mode nil
+ tool-bar-mode nil
+ no-blinking-cursor t))
+ ((memq initial-window-system '(x w32 ns))
+ (let ((no-vals '("no" "off" "false" "0")))
+ (if (member (x-get-resource "menuBar" "MenuBar") no-vals)
+ (setq menu-bar-mode nil))
+ (if (member (x-get-resource "toolBar" "ToolBar") no-vals)
+ (setq tool-bar-mode nil))
+ (if (member (x-get-resource "cursorBlink" "CursorBlink")
+ no-vals)
+ (setq no-blinking-cursor t)))
+ ;; If the cursorColor X resource exists, alter the `cursor' face
+ ;; spec, but mark it as changed outside of Customize.
+ (let ((color (x-get-resource "cursorColor" "CursorColor")))
+ (when color
+ (face-spec-set 'cursor `((t (:background ,color))))
+ (put 'cursor 'face-modified t)))))
(frame-initialize))
+ (when (fboundp 'x-create-frame)
+ ;; Set up the tool-bar (even in tty frames, since Emacs might open a
+ ;; graphical frame later).
+ (unless noninteractive
+ (tool-bar-setup)))
+
;; Turn off blinking cursor if so specified in X resources. This is here
;; only because all other settings of no-blinking-cursor are here.
(unless (or noninteractive
@@ -891,25 +923,6 @@ opening the first frame (e.g. open a connection to an X server).")
'("off" "false")))))
(setq no-blinking-cursor t))
- ;; If frame was created with a menu bar, set menu-bar-mode on.
- (unless (or noninteractive
- emacs-basic-display
- (and (memq initial-window-system '(x w32))
- (<= (frame-parameter nil 'menu-bar-lines) 0)))
- (menu-bar-mode 1))
-
- (unless (or noninteractive (not (fboundp 'tool-bar-mode)))
- ;; Set up the tool-bar. Do this even in tty frames, so that there
- ;; is a tool-bar if Emacs later opens a graphical frame.
- (if (or emacs-basic-display
- (and (numberp (frame-parameter nil 'tool-bar-lines))
- (<= (frame-parameter nil 'tool-bar-lines) 0)))
- ;; On a graphical display with the toolbar disabled via X
- ;; resources, set up the toolbar without enabling it.
- (tool-bar-setup)
- ;; Otherwise, enable tool-bar-mode.
- (tool-bar-mode 1)))
-
;; Re-evaluate predefined variables whose initial value depends on
;; the runtime context.
(mapc 'custom-reevaluate-setting
@@ -1166,6 +1179,31 @@ the `--debug-init' option to view a complete error backtrace."
(eq face-ignored-fonts old-face-ignored-fonts))
(clear-face-cache)))
+ ;; If any package directory exists, initialize the package system.
+ (and user-init-file
+ package-enable-at-startup
+ (catch 'package-dir-found
+ (let (dirs)
+ (if (boundp 'package-directory-list)
+ (setq dirs package-directory-list)
+ (dolist (f load-path)
+ (and (stringp f)
+ (equal (file-name-nondirectory f) "site-lisp")
+ (push (expand-file-name "elpa" f) dirs))))
+ (push (if (boundp 'package-user-dir)
+ package-user-dir
+ (locate-user-emacs-file "elpa"))
+ dirs)
+ (dolist (dir dirs)
+ (when (file-directory-p dir)
+ (dolist (subdir (directory-files dir))
+ (when (and (file-directory-p (expand-file-name subdir dir))
+ ;; package-subdirectory-regexp from package.el
+ (string-match "^\\([^.].*\\)-\\([0-9]+\\(?:[.][0-9]+\\)*\\)$"
+ subdir))
+ (throw 'package-dir-found t)))))))
+ (package-initialize))
+
(setq after-init-time (current-time))
(run-hooks 'after-init-hook)
@@ -1554,22 +1592,25 @@ a face or button specification."
(kill-buffer "*GNU Emacs*")))
" ")
(when (or user-init-file custom-file)
- (let ((checked (create-image "\300\300\141\143\067\076\034\030"
- 'xbm t :width 8 :height 8 :background "grey75"
- :foreground "black" :relief -2 :ascent 'center))
- (unchecked (create-image (make-string 8 0)
- 'xbm t :width 8 :height 8 :background "grey75"
- :foreground "black" :relief -2 :ascent 'center)))
+ (let ((checked (create-image "checked.xpm"
+ nil nil :ascent 'center))
+ (unchecked (create-image "unchecked.xpm"
+ nil nil :ascent 'center)))
(insert-button
- " " :on-glyph checked :off-glyph unchecked 'checked nil
- 'display unchecked 'follow-link t
+ " "
+ :on-glyph checked
+ :off-glyph unchecked
+ 'checked nil 'display unchecked 'follow-link t
'action (lambda (button)
(if (overlay-get button 'checked)
(progn (overlay-put button 'checked nil)
- (overlay-put button 'display (overlay-get button :off-glyph))
- (setq startup-screen-inhibit-startup-screen nil))
+ (overlay-put button 'display
+ (overlay-get button :off-glyph))
+ (setq startup-screen-inhibit-startup-screen
+ nil))
(overlay-put button 'checked t)
- (overlay-put button 'display (overlay-get button :on-glyph))
+ (overlay-put button 'display
+ (overlay-get button :on-glyph))
(setq startup-screen-inhibit-startup-screen t)))))
(fancy-splash-insert :face '(variable-pitch (:height 0.9))
" Never show it again.")))))
@@ -2224,6 +2265,11 @@ A fancy display is used on graphic displays, normal otherwise."
(move-to-column (1- cl1-column)))
(setq cl1-column 0))
+ ;; These command lines now have no effect.
+ ((string-match "\\`--?\\(no-\\)?\\(uni\\|multi\\)byte$" argi)
+ (display-warning 'initialization
+ (format "Ignoring obsolete arg %s" argi)))
+
((equal argi "--")
(setq just-files t))
(t
@@ -2342,5 +2388,4 @@ A fancy display is used on graphic displays, normal otherwise."
(setq file (replace-match "/" t t file)))
file))
-;; arch-tag: 7e294698-244d-4758-984b-4047f887a5db
;;; startup.el ends here
diff --git a/lisp/subr.el b/lisp/subr.el
index 7449295421c..70d8b76faa5 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -1,10 +1,12 @@
;;; subr.el --- basic lisp subroutines for Emacs
;; Copyright (C) 1985, 1986, 1992, 1994, 1995, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -287,14 +289,11 @@ 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 list))
- (while (consp p)
- (setq m (1+ m) p (cdr p)))
- (if (<= n 0) p
- (if (< n m) (nthcdr (- m n) list) list)))
- (while (consp (cdr list))
- (setq list (cdr list)))
- list))
+ (and (>= n 0)
+ (let ((m (safe-length list)))
+ (if (< n m) (nthcdr (- m n) list) list)))
+ (and list
+ (nthcdr (1- (safe-length list)) list))))
(defun butlast (list &optional n)
"Return a copy of LIST with the last N elements removed."
@@ -1017,7 +1016,6 @@ and `event-end' functions."
(define-obsolete-function-alias 'eval-current-buffer 'eval-buffer "22.1")
(define-obsolete-function-alias 'string-to-int 'string-to-number "22.1")
-(make-obsolete 'char-bytes "now always returns 1." "20.4")
(make-obsolete 'forward-point "use (+ (point) N) instead." "23.1")
(defun insert-string (&rest args)
@@ -1058,7 +1056,6 @@ is converted into a string by expressing it in decimal."
(make-obsolete-variable 'default-line-spacing 'line-spacing "23.2")
(make-obsolete-variable 'default-abbrev-mode 'abbrev-mode "23.2")
(make-obsolete-variable 'default-ctl-arrow 'ctl-arrow "23.2")
-(make-obsolete-variable 'default-direction-reversed 'direction-reversed "23.2")
(make-obsolete-variable 'default-truncate-lines 'truncate-lines "23.2")
(make-obsolete-variable 'default-left-margin 'left-margin "23.2")
(make-obsolete-variable 'default-tab-width 'tab-width "23.2")
@@ -1093,7 +1090,6 @@ is converted into a string by expressing it in decimal."
(make-obsolete 'process-filter-multibyte-p nil "23.1")
(make-obsolete 'set-process-filter-multibyte nil "23.1")
-(make-obsolete-variable 'directory-sep-char "do not use it." "21.1")
(make-obsolete-variable
'mode-line-inverse-video
"use the appropriate faces instead."
@@ -1160,37 +1156,6 @@ to reread, so it now uses nil to mean `no event', instead of -1."
;;;; Hook manipulation functions.
-(defun make-local-hook (hook)
- "Make the hook HOOK local to the current buffer.
-The return value is HOOK.
-
-You never need to call this function now that `add-hook' does it for you
-if its LOCAL argument is non-nil.
-
-When a hook is local, its local and global values
-work in concert: running the hook actually runs all the hook
-functions listed in *either* the local value *or* the global value
-of the hook variable.
-
-This function works by making t a member of the buffer-local value,
-which acts as a flag to run the hook functions in the default value as
-well. This works for all normal hooks, but does not work for most
-non-normal hooks yet. We will be changing the callers of non-normal
-hooks so that they can handle localness; this has to be done one by
-one.
-
-This function does nothing if HOOK is already local in the current
-buffer.
-
-Do not use `make-local-variable' to make a hook variable buffer-local."
- (if (local-variable-p hook)
- nil
- (or (boundp hook) (set hook nil))
- (make-local-variable hook)
- (set hook (list t)))
- hook)
-(make-obsolete 'make-local-hook "not necessary any more." "21.1")
-
(defun add-hook (hook function &optional append local)
"Add to the value of HOOK the function FUNCTION.
FUNCTION is not added if already present.
@@ -1481,8 +1446,7 @@ If TOGGLE has a `:menu-tag', that is used for the menu item's label."
(let ((rest (cdr found)))
(setcdr found nil)
(nconc found (list (list toggle name)) rest))
- (setq minor-mode-alist (cons (list toggle name)
- minor-mode-alist)))))))
+ (push (list toggle name) minor-mode-alist))))))
;; Add the toggle to the minor-modes menu if requested.
(when (get toggle :included)
(define-key mode-line-mode-menu
@@ -1511,8 +1475,7 @@ If TOGGLE has a `:menu-tag', that is used for the menu item's label."
(let ((rest (cdr found)))
(setcdr found nil)
(nconc found (list (cons toggle keymap)) rest))
- (setq minor-mode-map-alist (cons (cons toggle keymap)
- minor-mode-map-alist))))))))
+ (push (cons toggle keymap) minor-mode-map-alist)))))))
;;; Load history
@@ -1630,6 +1593,7 @@ Return nil if there isn't one."
load-elt (and loads (car loads)))))
load-elt))
+(put 'eval-after-load 'lisp-indent-function 1)
(defun eval-after-load (file form)
"Arrange that, if FILE is ever loaded, FORM will be run at that time.
If FILE is already loaded, evaluate FORM right now.
@@ -2418,8 +2382,9 @@ Otherwise, return nil."
(or (stringp object) (null object)))
(defun booleanp (object)
- "Return non-nil if OBJECT is one of the two canonical boolean values: t or nil."
- (memq object '(nil t)))
+ "Return t if OBJECT is one of the two canonical boolean values: t or nil.
+Otherwise, return nil."
+ (and (memq object '(nil t)) t))
(defun field-at-pos (pos)
"Return the field at position POS, taking stickiness etc into account."
@@ -2713,7 +2678,7 @@ nor the buffer list."
"Create a new buffer, evaluate BODY there, and write the buffer to FILE.
The value returned is the value of the last form in BODY.
See also `with-temp-buffer'."
- (declare (debug t))
+ (declare (indent 1) (debug t))
(let ((temp-file (make-symbol "temp-file"))
(temp-buffer (make-symbol "temp-buffer")))
`(let ((,temp-file ,file)
@@ -2735,7 +2700,7 @@ The value returned is the value of the last form in BODY.
MESSAGE is written to the message log buffer if `message-log-max' is non-nil.
If MESSAGE is nil, the echo area and message log buffer are unchanged.
Use a MESSAGE of \"\" to temporarily clear the echo area."
- (declare (debug t))
+ (declare (debug t) (indent 1))
(let ((current-message (make-symbol "current-message"))
(temp-message (make-symbol "with-temp-message")))
`(let ((,temp-message ,message)
@@ -2765,7 +2730,7 @@ See also `with-temp-file' and `with-output-to-string'."
(kill-buffer ,temp-buffer)))))))
(defmacro with-silent-modifications (&rest body)
- "Execute BODY, pretending it does not modifies the buffer.
+ "Execute BODY, pretending it does not modify the buffer.
If BODY performs real modifications to the buffer's text, other
than cosmetic ones, undo data may become corrupted.
Typically used around modifications of text-properties which do not really
@@ -3227,7 +3192,7 @@ that can be added."
The syntax table of the current buffer is saved, BODY is evaluated, and the
saved table is restored, even in case of an abnormal exit.
Value is what BODY returns."
- (declare (debug t))
+ (declare (debug t) (indent 1))
(let ((old-table (make-symbol "table"))
(old-buffer (make-symbol "buffer")))
`(let ((,old-table (syntax-table))
@@ -3357,6 +3322,56 @@ clone should be incorporated in the clone."
(overlay-put ol2 'evaporate t)
(overlay-put ol2 'text-clones dups)))
+;;;; Misc functions moved over from the C side.
+
+(defun y-or-n-p (prompt)
+ "Ask user a \"y or n\" question. Return t if answer is \"y\".
+The argument PROMPT is the string to display to ask the question.
+It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
+No confirmation of the answer is requested; a single character is enough.
+Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
+the bindings in `query-replace-map'; see the documentation of that variable
+for more information. In this case, the useful bindings are `act', `skip',
+`recenter', and `quit'.\)
+
+Under a windowing system a dialog box will be used if `last-nonmenu-event'
+is nil and `use-dialog-box' is non-nil."
+ ;; ¡Beware! when I tried to edebug this code, Emacs got into a weird state
+ ;; where all the keys were unbound (i.e. it somehow got triggered
+ ;; within read-key, apparently). I had to kill it.
+ (let ((answer 'recenter))
+ (if (and (display-popup-menus-p)
+ (listp last-nonmenu-event)
+ use-dialog-box)
+ (setq answer
+ (x-popup-dialog t `(,prompt ("yes" . act) ("No" . skip))))
+ (setq prompt (concat prompt
+ (if (eq ?\s (aref prompt (1- (length prompt))))
+ "" " ")
+ "(y or n) "))
+ (while
+ (let* ((key
+ (let ((cursor-in-echo-area t))
+ (when minibuffer-auto-raise
+ (raise-frame (window-frame (minibuffer-window))))
+ (read-key (propertize (if (eq answer 'recenter)
+ prompt
+ (concat "Please answer y or n. "
+ prompt))
+ 'face 'minibuffer-prompt)))))
+ (setq answer (lookup-key query-replace-map (vector key) t))
+ (cond
+ ((memq answer '(skip act)) nil)
+ ((eq answer 'recenter) (recenter) t)
+ ((memq answer '(exit-prefix quit)) (signal 'quit nil) t)
+ (t t)))
+ (ding)
+ (discard-input)))
+ (let ((ret (eq answer 'act)))
+ (unless noninteractive
+ (message "%s %s" prompt (if ret "y" "n")))
+ ret)))
+
;;;; Mail user agents.
;; Here we include just enough for other packages to be able
@@ -3416,51 +3431,59 @@ The properties used on SYMBOL are `composefunc', `sendfunc',
;; digits of precision, it doesn't really matter here. On the other
;; hand, it greatly simplifies the code.
-(defsubst progress-reporter-update (reporter value)
+(defsubst progress-reporter-update (reporter &optional value)
"Report progress of an operation in the echo area.
-However, if the change since last echo area update is too small
-or not enough time has passed, then do nothing (see
-`make-progress-reporter' for details).
-
-First parameter, REPORTER, should be the result of a call to
-`make-progress-reporter'. Second, VALUE, determines the actual
-progress of operation; it must be between MIN-VALUE and MAX-VALUE
-as passed to `make-progress-reporter'.
-
-This function is very inexpensive, you may not bother how often
-you call it."
- (when (>= value (car reporter))
- (progress-reporter-do-update reporter value)))
+REPORTER should be the result of a call to `make-progress-reporter'.
+
+If REPORTER is a numerical progress reporter---i.e. if it was
+ made using non-nil MIN-VALUE and MAX-VALUE arguments to
+ `make-progress-reporter'---then VALUE should be a number between
+ MIN-VALUE and MAX-VALUE.
+
+If REPORTER is a non-numerical reporter, VALUE should be nil.
-(defun make-progress-reporter (message min-value max-value
- &optional current-value
- min-change min-time)
- "Return progress reporter object to be used with `progress-reporter-update'.
-
-MESSAGE is shown in the echo area. When at least 1% of operation
-is complete, the exact percentage will be appended to the
-MESSAGE. When you call `progress-reporter-done', word \"done\"
-is printed after the MESSAGE. You can change MESSAGE of an
-existing progress reporter with `progress-reporter-force-update'.
-
-MIN-VALUE and MAX-VALUE designate starting (0% complete) and
-final (100% complete) states of operation. The latter should be
-larger; if this is not the case, then simply negate all values.
-Optional CURRENT-VALUE specifies the progress by the moment you
-call this function. You should omit it or set it to nil in most
-cases since it defaults to MIN-VALUE.
-
-Optional MIN-CHANGE determines the minimal change in percents to
-report (default is 1%.) Optional MIN-TIME specifies the minimal
-time before echo area updates (default is 0.2 seconds.) If
-`float-time' function is not present, then time is not tracked
-at all. If OS is not capable of measuring fractions of seconds,
-then this parameter is effectively rounded up."
+This function is relatively inexpensive. If the change since
+last update is too small or insufficient time has passed, it does
+nothing."
+ (when (or (not (numberp value)) ; For pulsing reporter
+ (>= value (car reporter))) ; For numerical reporter
+ (progress-reporter-do-update reporter value)))
+(defun make-progress-reporter (message &optional min-value max-value
+ current-value min-change min-time)
+ "Return progress reporter object for use with `progress-reporter-update'.
+
+MESSAGE is shown in the echo area, with a status indicator
+appended to the end. When you call `progress-reporter-done', the
+word \"done\" is printed after the MESSAGE. You can change the
+MESSAGE of an existing progress reporter by calling
+`progress-reporter-force-update'.
+
+MIN-VALUE and MAX-VALUE, if non-nil, are starting (0% complete)
+and final (100% complete) states of operation; the latter should
+be larger. In this case, the status message shows the percentage
+progress.
+
+If MIN-VALUE and/or MAX-VALUE is omitted or nil, the status
+message shows a \"spinning\", non-numeric indicator.
+
+Optional CURRENT-VALUE is the initial progress; the default is
+MIN-VALUE.
+Optional MIN-CHANGE is the minimal change in percents to report;
+the default is 1%.
+CURRENT-VALUE and MIN-CHANGE do not have any effect if MIN-VALUE
+and/or MAX-VALUE are nil.
+
+Optional MIN-TIME specifies the minimum interval time between
+echo area updates (default is 0.2 seconds.) If the function
+`float-time' is not present, time is not tracked at all. If the
+OS is not capable of measuring fractions of seconds, this
+parameter is effectively rounded up."
(unless min-time
(setq min-time 0.2))
(let ((reporter
- (cons min-value ;; Force a call to `message' now
+ ;; Force a call to `message' now
+ (cons (or min-value 0)
(vector (if (and (fboundp 'float-time)
(>= min-time 0.02))
(float-time) nil)
@@ -3472,12 +3495,11 @@ then this parameter is effectively rounded up."
(progress-reporter-update reporter (or current-value min-value))
reporter))
-(defun progress-reporter-force-update (reporter value &optional new-message)
+(defun progress-reporter-force-update (reporter &optional value new-message)
"Report progress of an operation in the echo area unconditionally.
-First two parameters are the same as for
-`progress-reporter-update'. Optional NEW-MESSAGE allows you to
-change the displayed message."
+The first two arguments are the same as in `progress-reporter-update'.
+NEW-MESSAGE, if non-nil, sets a new message for the reporter."
(let ((parameters (cdr reporter)))
(when new-message
(aset parameters 3 new-message))
@@ -3485,15 +3507,15 @@ change the displayed message."
(aset parameters 0 (float-time)))
(progress-reporter-do-update reporter value)))
+(defvar progress-reporter--pulse-characters ["-" "\\" "|" "/"]
+ "Characters to use for pulsing progress reporters.")
+
(defun progress-reporter-do-update (reporter value)
(let* ((parameters (cdr reporter))
+ (update-time (aref parameters 0))
(min-value (aref parameters 1))
(max-value (aref parameters 2))
- (one-percent (/ (- max-value min-value) 100.0))
- (percentage (if (= max-value min-value)
- 0
- (truncate (/ (- value min-value) one-percent))))
- (update-time (aref parameters 0))
+ (text (aref parameters 3))
(current-time (float-time))
(enough-time-passed
;; See if enough time has passed since the last update.
@@ -3501,26 +3523,41 @@ change the displayed message."
(when (>= current-time update-time)
;; Calculate time for the next update
(aset parameters 0 (+ update-time (aref parameters 5)))))))
- ;;
- ;; Calculate NEXT-UPDATE-VALUE. If we are not going to print
- ;; message this time because not enough time has passed, then use
- ;; 1 instead of MIN-CHANGE. This makes delays between echo area
- ;; updates closer to MIN-TIME.
- (setcar reporter
- (min (+ min-value (* (+ percentage
- (if enough-time-passed
- (aref parameters 4) ;; MIN-CHANGE
- 1))
- one-percent))
- max-value))
- (when (integerp value)
- (setcar reporter (ceiling (car reporter))))
- ;;
- ;; Only print message if enough time has passed
- (when enough-time-passed
- (if (> percentage 0)
- (message "%s%d%%" (aref parameters 3) percentage)
- (message "%s" (aref parameters 3))))))
+ (cond ((and min-value max-value)
+ ;; Numerical indicator
+ (let* ((one-percent (/ (- max-value min-value) 100.0))
+ (percentage (if (= max-value min-value)
+ 0
+ (truncate (/ (- value min-value)
+ one-percent)))))
+ ;; Calculate NEXT-UPDATE-VALUE. If we are not printing
+ ;; message because not enough time has passed, use 1
+ ;; instead of MIN-CHANGE. This makes delays between echo
+ ;; area updates closer to MIN-TIME.
+ (setcar reporter
+ (min (+ min-value (* (+ percentage
+ (if enough-time-passed
+ ;; MIN-CHANGE
+ (aref parameters 4)
+ 1))
+ one-percent))
+ max-value))
+ (when (integerp value)
+ (setcar reporter (ceiling (car reporter))))
+ ;; Only print message if enough time has passed
+ (when enough-time-passed
+ (if (> percentage 0)
+ (message "%s%d%%" text percentage)
+ (message "%s" text)))))
+ ;; Pulsing indicator
+ (enough-time-passed
+ (let ((index (mod (1+ (car reporter)) 4))
+ (message-log-max nil))
+ (setcar reporter index)
+ (message "%s %s"
+ text
+ (aref progress-reporter--pulse-characters
+ index)))))))
(defun progress-reporter-done (reporter)
"Print reporter's message followed by word \"done\" in echo area."
@@ -3557,18 +3594,18 @@ convenience wrapper around `make-progress-reporter' and friends.
;;;; Comparing version strings.
(defconst version-separator "."
- "*Specify the string used to separate the version elements.
+ "Specify the string used to separate the version elements.
Usually the separator is \".\", but it can be any other string.")
(defconst version-regexp-alist
- '(("^[-_+ ]?a\\(lpha\\)?$" . -3)
- ("^[-_+]$" . -3) ; treat "1.2.3-20050920" and "1.2-3" as alpha releases
- ("^[-_+ ]cvs$" . -3) ; treat "1.2.3-CVS" as alpha release
- ("^[-_+ ]?b\\(eta\\)?$" . -2)
- ("^[-_+ ]?\\(pre\\|rc\\)$" . -1))
- "*Specify association between non-numeric version and its priority.
+ '(("^[-_+ ]?alpha$" . -3)
+ ("^[-_+]$" . -3) ; treat "1.2.3-20050920" and "1.2-3" as alpha releases
+ ("^[-_+ ]cvs$" . -3) ; treat "1.2.3-CVS" as alpha release
+ ("^[-_+ ]?beta$" . -2)
+ ("^[-_+ ]?\\(pre\\|rcc\\)$" . -1))
+ "Specify association between non-numeric version and its priority.
This association is used to handle version string like \"1.0pre2\",
\"0.9alpha1\", etc. It's used by `version-to-list' (which see) to convert the
@@ -3660,8 +3697,13 @@ See documentation for `version-separator' and `version-regexp-alist'."
(setq al version-regexp-alist)
(while (and al (not (string-match (caar al) s)))
(setq al (cdr al)))
- (or al (error "Invalid version syntax: '%s'" ver))
- (setq lst (cons (cdar al) lst)))))
+ (cond (al
+ (push (cdar al) lst))
+ ;; Convert 22.3a to 22.3.1, 22.3b to 22.3.2, etc.
+ ((string-match "^[-_+ ]?\\([a-zA-Z]\\)$" s)
+ (push (- (aref (downcase (match-string 1 s)) 0) ?a -1)
+ lst))
+ (t (error "Invalid version syntax: '%s'" ver))))))
(if (null lst)
(error "Invalid version syntax: '%s'" ver)
(nreverse lst)))))
@@ -3713,7 +3755,7 @@ turn is higher than (1 -2), which is higher than (1 -3)."
"Return t if L1, a list specification of a version, is lower or equal to L2.
Note that integer list (1) is equal to (1 0), (1 0 0), (1 0 0 0),
-etc. That is, the trailing zeroes are irrelevant. Also, integer
+etc. That is, the trailing zeroes are insignificant. Also, integer
list (1) is greater than (1 -1) which is greater than (1 -2)
which is greater than (1 -3)."
(while (and l1 l2 (= (car l1) (car l2)))
@@ -3755,7 +3797,7 @@ which is higher than \"1alpha\"."
"Return t if version V1 is lower (older) than or equal to V2.
Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\",
-etc. That is, the trailing \".0\"s are insignificant.. Also, version
+etc. That is, the trailing \".0\"s are insignificant. Also, version
string \"1\" is higher (newer) than \"1pre\", which is higher than \"1beta\",
which is higher than \"1alpha\"."
(version-list-<= (version-to-list v1) (version-to-list v2)))
@@ -3764,7 +3806,7 @@ which is higher than \"1alpha\"."
"Return t if version V1 is equal to V2.
Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\",
-etc. That is, the trailing \".0\"s are insignificant.. Also, version
+etc. That is, the trailing \".0\"s are insignificant. Also, version
string \"1\" is higher (newer) than \"1pre\", which is higher than \"1beta\",
which is higher than \"1alpha\"."
(version-list-= (version-to-list v1) (version-to-list v2)))
diff --git a/lisp/tabify.el b/lisp/tabify.el
index c8cf877cb9c..591a9432fe5 100644
--- a/lisp/tabify.el
+++ b/lisp/tabify.el
@@ -4,6 +4,7 @@
;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Maintainer: FSF
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el
index a3f717ff40c..ba3cb862bf2 100644
--- a/lisp/tar-mode.el
+++ b/lisp/tar-mode.el
@@ -137,7 +137,6 @@ This information is useful, but it takes screen space away from file names."
(defvar tar-parse-info nil)
(defvar tar-superior-buffer nil)
(defvar tar-superior-descriptor nil)
-(defvar tar-subfile-mode nil)
(defvar tar-file-name-coding-system nil)
(put 'tar-superior-buffer 'permanent-local t)
@@ -673,29 +672,21 @@ See also: variables `tar-update-datestamp' and `tar-anal-blocksize'.
(signal (car err) (cdr err)))))
-(defun tar-subfile-mode (p)
+(define-minor-mode tar-subfile-mode
"Minor mode for editing an element of a tar-file.
This mode arranges for \"saving\" this buffer to write the data
into the tar-file buffer that it came from. The changes will actually
appear on disk when you save the tar-file's buffer."
- (interactive "P")
+ ;; Don't do this, because it is redundant and wastes mode line space.
+ ;; :lighter " TarFile"
+ nil nil nil
(or (and (boundp 'tar-superior-buffer) tar-superior-buffer)
(error "This buffer is not an element of a tar file"))
- ;; Don't do this, because it is redundant and wastes mode line space.
- ;; (or (assq 'tar-subfile-mode minor-mode-alist)
- ;; (setq minor-mode-alist (append minor-mode-alist
- ;; (list '(tar-subfile-mode " TarFile")))))
- (make-local-variable 'tar-subfile-mode)
- (setq tar-subfile-mode
- (if (null p)
- (not tar-subfile-mode)
- (> (prefix-numeric-value p) 0)))
(cond (tar-subfile-mode
(add-hook 'write-file-functions 'tar-subfile-save-buffer nil t)
;; turn off auto-save.
(auto-save-mode -1)
- (setq buffer-auto-save-file-name nil)
- (run-hooks 'tar-subfile-mode-hook))
+ (setq buffer-auto-save-file-name nil))
(t
(remove-hook 'write-file-functions 'tar-subfile-save-buffer t))))
@@ -853,14 +844,12 @@ appear on disk when you save the tar-file's buffer."
(set (make-local-variable 'tar-superior-descriptor) descriptor)
(setq buffer-read-only read-only-p)
(tar-subfile-mode 1)))
- (if view-p
- (view-buffer
- buffer (and just-created 'kill-buffer-if-not-modified))
- (if (eq other-window-p 'display)
- (display-buffer buffer)
- (if other-window-p
- (switch-to-buffer-other-window buffer)
- (switch-to-buffer buffer)))))))
+ (cond
+ (view-p
+ (view-buffer buffer (and just-created 'kill-buffer-if-not-modified)))
+ ((eq other-window-p 'display) (display-buffer buffer))
+ (other-window-p (switch-to-buffer-other-window buffer))
+ (t (switch-to-buffer buffer))))))
(defun tar-extract-other-window ()
diff --git a/lisp/term.el b/lisp/term.el
index 2223ff2587d..9c511592165 100644
--- a/lisp/term.el
+++ b/lisp/term.el
@@ -1,7 +1,8 @@
;;; term.el --- general command interpreter in a window stuff
-;; Copyright (C) 1988, 1990, 1992, 1994, 1995, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1988, 1990, 1992, 1994, 1995, 2001, 2002, 2003, 2004,
+;; 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Per Bothner <per@bothner.com>
;; Maintainer: Dan Nicolaescu <dann@ics.uci.edu>, Per Bothner <per@bothner.com>
@@ -1170,7 +1171,7 @@ Entry to this mode runs the hooks on `term-mode-hook'."
(let* ((str (car cur)) (len (length str)) (start (- (point) len)))
(if (and (>= start (point-min))
(string= str (buffer-substring start (point))))
- (progn (delete-backward-char len)
+ (progn (delete-char (- len))
(setq term-kill-echo-list (cdr cur))
(setq term-current-column nil)
(setq term-current-row nil)
@@ -1231,8 +1232,7 @@ without any interpretation."
(if (featurep 'xemacs)
(term-send-raw-string
(or (condition-case () (x-get-selection) (error ()))
- (x-get-cutbuffer)
- (error "No selection or cut buffer available")))
+ (error "No selection available")))
;; Give temporary modes such as isearch a chance to turn off.
(run-hooks 'mouse-leave-buffer-hook)
(setq this-command 'yank)
@@ -1799,15 +1799,11 @@ Returns t if successful."
"Expand directory stack reference before point.
See `term-replace-by-expanded-history'. Returns t if successful."
(save-excursion
- (let ((toend (- (save-excursion (end-of-line nil) (point)) (point)))
+ (let ((toend (- (line-end-position) (point)))
(start (progn (term-bol nil) (point))))
(while (progn
- (skip-chars-forward "^!^"
- (save-excursion
- (end-of-line nil) (- (point) toend)))
- (< (point)
- (save-excursion
- (end-of-line nil) (- (point) toend))))
+ (skip-chars-forward "^!^" (- (line-end-position) toend))
+ (< (point) (- (line-end-position) toend)))
;; This seems a bit complex. We look for references such as !!, !-num,
;; !foo, !?foo, !{bar}, !?{bar}, ^oh, ^my^, ^god^it, ^never^ends^.
;; If that wasn't enough, the plings can be suffixed with argument
@@ -2113,7 +2109,7 @@ Calls `term-get-old-input' to get old input."
(defun term-skip-prompt ()
"Skip past the text matching regexp `term-prompt-regexp'.
If this takes us past the end of the current line, don't skip at all."
- (let ((eol (save-excursion (end-of-line) (point))))
+ (let ((eol (line-end-position)))
(when (and (looking-at term-prompt-regexp)
(<= (match-end 0) eol))
(goto-char (match-end 0)))))
@@ -2472,11 +2468,10 @@ See `term-prompt-regexp'."
"Return string around `point' that starts the current line or nil."
(save-excursion
(let* ((point (point))
- (bol (progn (beginning-of-line) (point)))
- (eol (progn (end-of-line) (point)))
- (start (progn (goto-char point)
- (and (search-backward "\"" bol t)
- (1+ (point)))))
+ (bol (line-beginning-position))
+ (eol (line-end-position))
+ (start (and (search-backward "\"" bol t)
+ (1+ (point))))
(end (progn (goto-char point)
(and (search-forward "\"" eol t)
(1- (point))))))
@@ -2616,10 +2611,7 @@ See `term-prompt-regexp'."
(defun term-move-columns (delta)
(setq term-current-column (max 0 (+ (term-current-column) delta)))
- (let (point-at-eol)
- (save-excursion
- (end-of-line)
- (setq point-at-eol (point)))
+ (let ((point-at-eol (line-end-position)))
(move-to-column term-current-column t)
;; If move-to-column extends the current line it will use the face
;; from the last character on the line, set the face for the chars
@@ -3797,10 +3789,8 @@ if KIND is 1, erase from home to point; else erase from home to point-max."
(term-vertical-motion 1)
(when (bolp)
(backward-char))
- (setq save-eol (point))
- (save-excursion
- (end-of-line)
- (setq pnt-at-eol (point)))
+ (setq save-eol (point)
+ pnt-at-eol (line-end-position))
(move-to-column (+ (term-start-line-column) (- term-width count)) t)
;; If move-to-column extends the current line it will use the face
;; from the last character on the line, set the face for the chars
@@ -4233,7 +4223,7 @@ Return t if this is a Unix-based system, where serial ports are
files, such as /dev/ttyS0.
Return nil if this is Windows or DOS, where serial ports have
special identifiers such as COM1."
- (not (member system-type (list 'windows-nt 'cygwin 'ms-dos))))
+ (not (memq system-type '(windows-nt cygwin ms-dos))))
(defvar serial-name-history
(if (serial-port-is-file-p)
@@ -4535,5 +4525,4 @@ The return value may be nil for a special serial port."
(provide 'term)
-;; arch-tag: eee16bc8-2cd7-4147-9534-a5694752f716
;;; term.el ends here
diff --git a/lisp/term/common-win.el b/lisp/term/common-win.el
index ccdd47be470..0df5e57ee27 100644
--- a/lisp/term/common-win.el
+++ b/lisp/term/common-win.el
@@ -1,7 +1,7 @@
;;; common-win.el --- common part of handling window systems
;; Copyright (C) 1993, 1994, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010 Free Software Foundation, Inc.
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: terminals
@@ -25,54 +25,139 @@
;;; Code:
+(defcustom x-select-enable-clipboard t
+ "Non-nil means cutting and pasting uses the clipboard.
+This is in addition to, but in preference to, the primary selection.
+
+Note that MS-Windows does not support selection types other than the
+clipboard. (The primary selection that is set by Emacs is not
+accessible to other programs on MS-Windows.)
+
+This variable is not used by the Nextstep port."
+ :type 'boolean
+ :group 'killing
+ ;; The GNU/Linux version changed in 24.1, the MS-Windows version did not.
+ :version "24.1")
+
+(defvar x-last-selected-text) ; w32-fns.el
+(declare-function w32-set-clipboard-data "w32select.c"
+ (string &optional ignored))
+(defvar ns-last-selected-text) ; ns-win.el
+(declare-function ns-set-pasteboard "ns-win" (string))
+
+(defun x-select-text (text)
+ "Select TEXT, a string, according to the window system.
+
+On X, if `x-select-enable-clipboard' is non-nil, copy TEXT to the
+clipboard. If `x-select-enable-primary' is non-nil, put TEXT in
+the primary selection.
+
+On MS-Windows, make TEXT the current selection. If
+`x-select-enable-clipboard' is non-nil, copy the text to the
+clipboard as well.
+
+On Nextstep, put TEXT in the pasteboard (`x-select-enable-clipboard'
+is not used)."
+ (cond ((eq system-type 'windows-nt)
+ (if x-select-enable-clipboard
+ (w32-set-clipboard-data text))
+ (setq x-last-selected-text text))
+ ((featurep 'ns)
+ ;; Don't send the pasteboard too much text.
+ ;; It becomes slow, and if really big it causes errors.
+ (ns-set-pasteboard text)
+ (setq ns-last-selected-text text))
+ (t
+ ;; With multi-tty, this function may be called from a tty frame.
+ (when (eq (framep (selected-frame)) 'x)
+ (when x-select-enable-primary
+ (x-set-selection 'PRIMARY text)
+ (setq x-last-selected-text-primary text))
+ (when x-select-enable-clipboard
+ (x-set-selection 'CLIPBOARD text)
+ (setq x-last-selected-text-clipboard text))))))
+
+;;;; Function keys
+
+(defvar x-alternatives-map
+ (let ((map (make-sparse-keymap)))
+ ;; Map certain keypad keys into ASCII characters that people usually expect.
+ (define-key map [M-backspace] [?\M-\d])
+ (define-key map [M-delete] [?\M-\d])
+ (define-key map [M-tab] [?\M-\t])
+ (define-key map [M-linefeed] [?\M-\n])
+ (define-key map [M-clear] [?\M-\C-l])
+ (define-key map [M-return] [?\M-\C-m])
+ (define-key map [M-escape] [?\M-\e])
+ (unless (featurep 'ns)
+ (define-key map [iso-lefttab] [backtab])
+ (define-key map [S-iso-lefttab] [backtab]))
+ (and (or (eq system-type 'windows-nt)
+ (featurep 'ns))
+ (define-key map [S-tab] [backtab]))
+ map)
+ "Keymap of possible alternative meanings for some keys.")
+
+(defun x-setup-function-keys (frame)
+ "Set up `function-key-map' on the graphical frame FRAME."
+ ;; Don't do this twice on the same display, or it would break
+ ;; normal-erase-is-backspace-mode.
+ (unless (terminal-parameter frame 'x-setup-function-keys)
+ ;; Map certain keypad keys into ASCII characters that people usually expect.
+ (with-selected-frame frame
+ (let ((map (copy-keymap x-alternatives-map)))
+ (set-keymap-parent map (keymap-parent local-function-key-map))
+ (set-keymap-parent local-function-key-map map))
+ (when (featurep 'ns)
+ (setq interprogram-cut-function 'x-select-text
+ interprogram-paste-function 'x-selection-value
+ system-key-alist
+ (list
+ ;; These are special "keys" used to pass events from C to lisp.
+ (cons (logior (lsh 0 16) 1) 'ns-power-off)
+ (cons (logior (lsh 0 16) 2) 'ns-open-file)
+ (cons (logior (lsh 0 16) 3) 'ns-open-temp-file)
+ (cons (logior (lsh 0 16) 4) 'ns-drag-file)
+ (cons (logior (lsh 0 16) 5) 'ns-drag-color)
+ (cons (logior (lsh 0 16) 6) 'ns-drag-text)
+ (cons (logior (lsh 0 16) 7) 'ns-change-font)
+ (cons (logior (lsh 0 16) 8) 'ns-open-file-line)
+;;; (cons (logior (lsh 0 16) 9) 'ns-insert-working-text)
+;;; (cons (logior (lsh 0 16) 10) 'ns-delete-working-text)
+ (cons (logior (lsh 0 16) 11) 'ns-spi-service-call)
+;;; (cons (logior (lsh 0 16) 12) 'ns-new-frame)
+ (cons (logior (lsh 0 16) 13) 'ns-toggle-toolbar)
+;;; (cons (logior (lsh 0 16) 14) 'ns-show-prefs)
+ ))))
+ (set-terminal-parameter frame 'x-setup-function-keys t)))
(defvar x-invocation-args)
(defvar x-command-line-resources nil)
;; Handler for switches of the form "-switch value" or "-switch".
-(defun x-handle-switch (switch)
+(defun x-handle-switch (switch &optional numeric)
(let ((aelt (assoc switch command-line-x-option-alist)))
(if aelt
- (let ((param (nth 3 aelt))
- (value (nth 4 aelt)))
- (if value
- (setq default-frame-alist
- (cons (cons param value)
- default-frame-alist))
- (setq default-frame-alist
- (cons (cons param
- (car x-invocation-args))
- default-frame-alist)
- x-invocation-args (cdr x-invocation-args)))))))
+ (setq default-frame-alist
+ (cons (cons (nth 3 aelt)
+ (if numeric
+ (string-to-number (pop x-invocation-args))
+ (or (nth 4 aelt) (pop x-invocation-args))))
+ default-frame-alist)))))
;; Handler for switches of the form "-switch n"
(defun x-handle-numeric-switch (switch)
- (let ((aelt (assoc switch command-line-x-option-alist)))
- (if aelt
- (let ((param (nth 3 aelt)))
- (setq default-frame-alist
- (cons (cons param
- (string-to-number (car x-invocation-args)))
- default-frame-alist)
- x-invocation-args
- (cdr x-invocation-args))))))
+ (x-handle-switch switch t))
;; Handle options that apply to initial frame only
(defun x-handle-initial-switch (switch)
(let ((aelt (assoc switch command-line-x-option-alist)))
(if aelt
- (let ((param (nth 3 aelt))
- (value (nth 4 aelt)))
- (if value
- (setq initial-frame-alist
- (cons (cons param value)
- initial-frame-alist))
- (setq initial-frame-alist
- (cons (cons param
- (car x-invocation-args))
- initial-frame-alist)
- x-invocation-args (cdr x-invocation-args)))))))
+ (setq initial-frame-alist
+ (cons (cons (nth 3 aelt)
+ (or (nth 4 aelt) (pop x-invocation-args)))
+ initial-frame-alist)))))
;; Make -iconic apply only to the initial frame!
(defun x-handle-iconic (switch)
@@ -85,15 +170,14 @@
(error "%s: missing argument to `%s' option" (invocation-name) switch))
(setq x-command-line-resources
(if (null x-command-line-resources)
- (car x-invocation-args)
- (concat x-command-line-resources "\n" (car x-invocation-args))))
- (setq x-invocation-args (cdr x-invocation-args)))
+ (pop x-invocation-args)
+ (concat x-command-line-resources "\n" (pop x-invocation-args)))))
(declare-function x-parse-geometry "frame.c" (string))
;; Handle the geometry option
(defun x-handle-geometry (switch)
- (let* ((geo (x-parse-geometry (car x-invocation-args)))
+ (let* ((geo (x-parse-geometry (pop x-invocation-args)))
(left (assq 'left geo))
(top (assq 'top geo))
(height (assq 'height geo))
@@ -114,8 +198,7 @@
(append initial-frame-alist
'((user-position . t))
(if left (list left))
- (if top (list top)))))
- (setq x-invocation-args (cdr x-invocation-args))))
+ (if top (list top)))))))
(defvar x-resource-name)
@@ -125,9 +208,8 @@
(defun x-handle-name-switch (switch)
(or (consp x-invocation-args)
(error "%s: missing argument to `%s' option" (invocation-name) switch))
- (setq x-resource-name (car x-invocation-args)
- x-invocation-args (cdr x-invocation-args))
- (setq initial-frame-alist (cons (cons 'name x-resource-name)
+ (setq x-resource-name (pop x-invocation-args)
+ initial-frame-alist (cons (cons 'name x-resource-name)
initial-frame-alist)))
(defvar x-display-name nil
@@ -137,8 +219,7 @@ On X, the display name of individual X frames is recorded in the
(defun x-handle-display (switch)
"Handle -display DISPLAY option."
- (setq x-display-name (car x-invocation-args)
- x-invocation-args (cdr x-invocation-args))
+ (setq x-display-name (pop x-invocation-args))
;; Make subshell programs see the same DISPLAY value Emacs really uses.
;; Note that this isn't completely correct, since Emacs can use
;; multiple displays. However, there is no way to tell an already
@@ -146,21 +227,25 @@ On X, the display name of individual X frames is recorded in the
(setenv "DISPLAY" x-display-name))
(defun x-handle-args (args)
- "Process the X-related command line options in ARGS.
-This is done before the user's startup file is loaded. They are copied to
-`x-invocation-args', from which the X-related things are extracted, first
-the switch (e.g., \"-fg\") in the following code, and possible values
-\(e.g., \"black\") in the option handler code (e.g., x-handle-switch).
-This function returns ARGS minus the arguments that have been processed."
+ "Process the X (or Nextstep) related command line options in ARGS.
+This is done before the user's startup file is loaded.
+Copies the options in ARGS to `x-invocation-args'. It then extracts
+the X (or Nextstep) options according to the handlers defined in
+`command-line-x-option-alist' (or `command-line-ns-option-alist').
+For example, `x-handle-switch' handles a switch like \"-fg\" and its
+value \"black\". This function returns ARGS minus the arguments that
+have been processed."
;; We use ARGS to accumulate the args that we don't handle here, to return.
- (setq x-invocation-args args
+ (setq x-invocation-args args ; FIXME let-bind?
args nil)
(while (and x-invocation-args
(not (equal (car x-invocation-args) "--")))
- (let* ((this-switch (car x-invocation-args))
+ (let* ((this-switch (pop x-invocation-args))
(orig-this-switch this-switch)
+ (option-alist (if (featurep 'ns)
+ command-line-ns-option-alist
+ command-line-x-option-alist))
completion argval aelt handler)
- (setq x-invocation-args (cdr x-invocation-args))
;; Check for long options with attached arguments
;; and separate out the attached option argument into argval.
(if (string-match "^--[^=]*=" this-switch)
@@ -169,17 +254,17 @@ This function returns ARGS minus the arguments that have been processed."
;; Complete names of long options.
(if (string-match "^--" this-switch)
(progn
- (setq completion (try-completion this-switch command-line-x-option-alist))
+ (setq completion (try-completion this-switch option-alist))
(if (eq completion t)
;; Exact match for long option.
nil
(if (stringp completion)
- (let ((elt (assoc completion command-line-x-option-alist)))
+ (let ((elt (assoc completion option-alist)))
;; Check for abbreviated long option.
(or elt
(error "Option `%s' is ambiguous" this-switch))
(setq this-switch completion))))))
- (setq aelt (assoc this-switch command-line-x-option-alist))
+ (setq aelt (assoc this-switch option-alist))
(if aelt (setq handler (nth 2 aelt)))
(if handler
(if argval
@@ -203,96 +288,190 @@ This function returns ARGS minus the arguments that have been processed."
;; white, (v) numbered colors sorted by hue, and (vi) numbered shades
;; of grey.
+(declare-function ns-list-colors "nsfns.m" (&optional frame))
+
(defvar x-colors
- (purecopy
- '("gray100" "gray99" "gray98" "gray97" "gray96" "gray95" "gray94" "gray93" "gray92"
- "gray91" "gray90" "gray89" "gray88" "gray87" "gray86" "gray85" "gray84" "gray83"
- "gray82" "gray81" "gray80" "gray79" "gray78" "gray77" "gray76" "gray75" "gray74"
- "gray73" "gray72" "gray71" "gray70" "gray69" "gray68" "gray67" "gray66" "gray65"
- "gray64" "gray63" "gray62" "gray61" "gray60" "gray59" "gray58" "gray57" "gray56"
- "gray55" "gray54" "gray53" "gray52" "gray51" "gray50" "gray49" "gray48" "gray47"
- "gray46" "gray45" "gray44" "gray43" "gray42" "gray41" "gray40" "gray39" "gray38"
- "gray37" "gray36" "gray35" "gray34" "gray33" "gray32" "gray31" "gray30" "gray29"
- "gray28" "gray27" "gray26" "gray25" "gray24" "gray23" "gray22" "gray21" "gray20"
- "gray19" "gray18" "gray17" "gray16" "gray15" "gray14" "gray13" "gray12" "gray11"
- "gray10" "gray9" "gray8" "gray7" "gray6" "gray5" "gray4" "gray3" "gray2" "gray1"
- "gray0" "LightPink1" "LightPink2" "LightPink3" "LightPink4" "pink1" "pink2" "pink3"
- "pink4" "PaleVioletRed1" "PaleVioletRed2" "PaleVioletRed3" "PaleVioletRed4"
- "LavenderBlush1" "LavenderBlush2" "LavenderBlush3" "LavenderBlush4" "VioletRed1"
- "VioletRed2" "VioletRed3" "VioletRed4" "HotPink1" "HotPink2" "HotPink3" "HotPink4"
- "DeepPink1" "DeepPink2" "DeepPink3" "DeepPink4" "maroon1" "maroon2" "maroon3"
- "maroon4" "orchid1" "orchid2" "orchid3" "orchid4" "plum1" "plum2" "plum3" "plum4"
- "thistle1" "thistle2" "thistle3" "thistle4" "MediumOrchid1" "MediumOrchid2"
- "MediumOrchid3" "MediumOrchid4" "DarkOrchid1" "DarkOrchid2" "DarkOrchid3"
- "DarkOrchid4" "purple1" "purple2" "purple3" "purple4" "MediumPurple1"
- "MediumPurple2" "MediumPurple3" "MediumPurple4" "SlateBlue1" "SlateBlue2"
- "SlateBlue3" "SlateBlue4" "RoyalBlue1" "RoyalBlue2" "RoyalBlue3" "RoyalBlue4"
- "LightSteelBlue1" "LightSteelBlue2" "LightSteelBlue3" "LightSteelBlue4" "SlateGray1"
- "SlateGray2" "SlateGray3" "SlateGray4" "DodgerBlue1" "DodgerBlue2" "DodgerBlue3"
- "DodgerBlue4" "SteelBlue1" "SteelBlue2" "SteelBlue3" "SteelBlue4" "SkyBlue1"
- "SkyBlue2" "SkyBlue3" "SkyBlue4" "LightSkyBlue1" "LightSkyBlue2" "LightSkyBlue3"
- "LightSkyBlue4" "LightBlue1" "LightBlue2" "LightBlue3" "LightBlue4" "CadetBlue1"
- "CadetBlue2" "CadetBlue3" "CadetBlue4" "azure1" "azure2" "azure3" "azure4"
- "LightCyan1" "LightCyan2" "LightCyan3" "LightCyan4" "PaleTurquoise1"
- "PaleTurquoise2" "PaleTurquoise3" "PaleTurquoise4" "DarkSlateGray1" "DarkSlateGray2"
- "DarkSlateGray3" "DarkSlateGray4" "aquamarine1" "aquamarine2" "aquamarine3"
- "aquamarine4" "SeaGreen1" "SeaGreen2" "SeaGreen3" "SeaGreen4" "honeydew1"
- "honeydew2" "honeydew3" "honeydew4" "DarkSeaGreen1" "DarkSeaGreen2" "DarkSeaGreen3"
- "DarkSeaGreen4" "PaleGreen1" "PaleGreen2" "PaleGreen3" "PaleGreen4"
- "DarkOliveGreen1" "DarkOliveGreen2" "DarkOliveGreen3" "DarkOliveGreen4" "OliveDrab1"
- "OliveDrab2" "OliveDrab3" "OliveDrab4" "ivory1" "ivory2" "ivory3" "ivory4"
- "LightYellow1" "LightYellow2" "LightYellow3" "LightYellow4" "khaki1" "khaki2"
- "khaki3" "khaki4" "LemonChiffon1" "LemonChiffon2" "LemonChiffon3" "LemonChiffon4"
- "LightGoldenrod1" "LightGoldenrod2" "LightGoldenrod3" "LightGoldenrod4" "cornsilk1"
- "cornsilk2" "cornsilk3" "cornsilk4" "goldenrod1" "goldenrod2" "goldenrod3"
- "goldenrod4" "DarkGoldenrod1" "DarkGoldenrod2" "DarkGoldenrod3" "DarkGoldenrod4"
- "wheat1" "wheat2" "wheat3" "wheat4" "NavajoWhite1" "NavajoWhite2" "NavajoWhite3"
- "NavajoWhite4" "burlywood1" "burlywood2" "burlywood3" "burlywood4" "AntiqueWhite1"
- "AntiqueWhite2" "AntiqueWhite3" "AntiqueWhite4" "bisque1" "bisque2" "bisque3"
- "bisque4" "tan1" "tan2" "tan3" "tan4" "PeachPuff1" "PeachPuff2" "PeachPuff3"
- "PeachPuff4" "seashell1" "seashell2" "seashell3" "seashell4" "chocolate1"
- "chocolate2" "chocolate3" "chocolate4" "sienna1" "sienna2" "sienna3" "sienna4"
- "LightSalmon1" "LightSalmon2" "LightSalmon3" "LightSalmon4" "salmon1" "salmon2"
- "salmon3" "salmon4" "coral1" "coral2" "coral3" "coral4" "tomato1" "tomato2"
- "tomato3" "tomato4" "MistyRose1" "MistyRose2" "MistyRose3" "MistyRose4" "snow1"
- "snow2" "snow3" "snow4" "RosyBrown1" "RosyBrown2" "RosyBrown3" "RosyBrown4"
- "IndianRed1" "IndianRed2" "IndianRed3" "IndianRed4" "firebrick1" "firebrick2"
- "firebrick3" "firebrick4" "brown1" "brown2" "brown3" "brown4" "magenta1" "magenta2"
- "magenta3" "magenta4" "blue1" "blue2" "blue3" "blue4" "DeepSkyBlue1" "DeepSkyBlue2"
- "DeepSkyBlue3" "DeepSkyBlue4" "turquoise1" "turquoise2" "turquoise3" "turquoise4"
- "cyan1" "cyan2" "cyan3" "cyan4" "SpringGreen1" "SpringGreen2" "SpringGreen3"
- "SpringGreen4" "green1" "green2" "green3" "green4" "chartreuse1" "chartreuse2"
- "chartreuse3" "chartreuse4" "yellow1" "yellow2" "yellow3" "yellow4" "gold1" "gold2"
- "gold3" "gold4" "orange1" "orange2" "orange3" "orange4" "DarkOrange1" "DarkOrange2"
- "DarkOrange3" "DarkOrange4" "OrangeRed1" "OrangeRed2" "OrangeRed3" "OrangeRed4"
- "red1" "red2" "red3" "red4" "lavender blush" "ghost white" "lavender" "alice blue"
- "azure" "light cyan" "mint cream" "honeydew" "ivory" "light goldenrod yellow"
- "light yellow" "beige" "floral white" "old lace" "blanched almond" "moccasin"
- "papaya whip" "bisque" "antique white" "linen" "peach puff" "seashell" "misty rose"
- "snow" "light pink" "pink" "hot pink" "deep pink" "maroon" "pale violet red"
- "violet red" "medium violet red" "violet" "plum" "thistle" "orchid" "medium orchid"
- "dark orchid" "purple" "blue violet" "medium purple" "light slate blue"
- "medium slate blue" "slate blue" "dark slate blue" "midnight blue" "navy"
- "dark blue" "light steel blue" "cornflower blue" "dodger blue" "royal blue"
- "light slate gray" "slate gray" "dark slate gray" "steel blue" "cadet blue"
- "light sky blue" "sky blue" "light blue" "powder blue" "pale turquoise"
- "turquoise" "medium turquoise" "dark turquoise" "dark cyan" "aquamarine"
- "medium aquamarine" "light sea green"
- "medium sea green" "sea green" "dark sea green" "pale green" "lime green"
- "dark green" "forest green" "light green" "green yellow" "yellow green" "olive drab"
- "dark olive green" "lemon chiffon" "khaki" "dark khaki" "cornsilk"
- "pale goldenrod" "light goldenrod" "goldenrod" "dark goldenrod" "wheat"
- "navajo white" "tan" "burlywood" "sandy brown" "peru" "chocolate" "saddle brown"
- "sienna" "rosy brown" "dark salmon" "coral" "tomato" "light salmon" "salmon"
- "light coral" "indian red" "firebrick" "brown" "dark red" "magenta"
- "dark magenta" "dark violet" "medium blue" "blue" "deep sky blue"
- "cyan" "medium spring green" "spring green" "green" "lawn green" "chartreuse"
- "yellow" "gold" "orange" "dark orange" "orange red" "red" "white" "white smoke"
- "gainsboro" "light gray" "gray" "dark gray" "dim gray" "black" ))
+ (if (featurep 'ns) (ns-list-colors)
+ (purecopy
+ '("gray100" "grey100" "gray99" "grey99" "gray98" "grey98" "gray97"
+ "grey97" "gray96" "grey96" "gray95" "grey95" "gray94" "grey94"
+ "gray93" "grey93" "gray92" "grey92" "gray91" "grey91" "gray90"
+ "grey90" "gray89" "grey89" "gray88" "grey88" "gray87" "grey87"
+ "gray86" "grey86" "gray85" "grey85" "gray84" "grey84" "gray83"
+ "grey83" "gray82" "grey82" "gray81" "grey81" "gray80" "grey80"
+ "gray79" "grey79" "gray78" "grey78" "gray77" "grey77" "gray76"
+ "grey76" "gray75" "grey75" "gray74" "grey74" "gray73" "grey73"
+ "gray72" "grey72" "gray71" "grey71" "gray70" "grey70" "gray69"
+ "grey69" "gray68" "grey68" "gray67" "grey67" "gray66" "grey66"
+ "gray65" "grey65" "gray64" "grey64" "gray63" "grey63" "gray62"
+ "grey62" "gray61" "grey61" "gray60" "grey60" "gray59" "grey59"
+ "gray58" "grey58" "gray57" "grey57" "gray56" "grey56" "gray55"
+ "grey55" "gray54" "grey54" "gray53" "grey53" "gray52" "grey52"
+ "gray51" "grey51" "gray50" "grey50" "gray49" "grey49" "gray48"
+ "grey48" "gray47" "grey47" "gray46" "grey46" "gray45" "grey45"
+ "gray44" "grey44" "gray43" "grey43" "gray42" "grey42" "gray41"
+ "grey41" "gray40" "grey40" "gray39" "grey39" "gray38" "grey38"
+ "gray37" "grey37" "gray36" "grey36" "gray35" "grey35" "gray34"
+ "grey34" "gray33" "grey33" "gray32" "grey32" "gray31" "grey31"
+ "gray30" "grey30" "gray29" "grey29" "gray28" "grey28" "gray27"
+ "grey27" "gray26" "grey26" "gray25" "grey25" "gray24" "grey24"
+ "gray23" "grey23" "gray22" "grey22" "gray21" "grey21" "gray20"
+ "grey20" "gray19" "grey19" "gray18" "grey18" "gray17" "grey17"
+ "gray16" "grey16" "gray15" "grey15" "gray14" "grey14" "gray13"
+ "grey13" "gray12" "grey12" "gray11" "grey11" "gray10" "grey10"
+ "gray9" "grey9" "gray8" "grey8" "gray7" "grey7" "gray6" "grey6"
+ "gray5" "grey5" "gray4" "grey4" "gray3" "grey3" "gray2" "grey2"
+ "gray1" "grey1" "gray0" "grey0"
+ "LightPink1" "LightPink2" "LightPink3" "LightPink4"
+ "pink1" "pink2" "pink3" "pink4"
+ "PaleVioletRed1" "PaleVioletRed2" "PaleVioletRed3" "PaleVioletRed4"
+ "LavenderBlush1" "LavenderBlush2" "LavenderBlush3" "LavenderBlush4"
+ "VioletRed1" "VioletRed2" "VioletRed3" "VioletRed4"
+ "HotPink1" "HotPink2" "HotPink3" "HotPink4"
+ "DeepPink1" "DeepPink2" "DeepPink3" "DeepPink4"
+ "maroon1" "maroon2" "maroon3" "maroon4"
+ "orchid1" "orchid2" "orchid3" "orchid4"
+ "plum1" "plum2" "plum3" "plum4"
+ "thistle1" "thistle2" "thistle3" "thistle4"
+ "MediumOrchid1" "MediumOrchid2" "MediumOrchid3" "MediumOrchid4"
+ "DarkOrchid1" "DarkOrchid2" "DarkOrchid3" "DarkOrchid4"
+ "purple1" "purple2" "purple3" "purple4"
+ "MediumPurple1" "MediumPurple2" "MediumPurple3" "MediumPurple4"
+ "SlateBlue1" "SlateBlue2" "SlateBlue3" "SlateBlue4"
+ "RoyalBlue1" "RoyalBlue2" "RoyalBlue3" "RoyalBlue4"
+ "LightSteelBlue1" "LightSteelBlue2" "LightSteelBlue3" "LightSteelBlue4"
+ "SlateGray1" "SlateGray2" "SlateGray3" "SlateGray4"
+ "DodgerBlue1" "DodgerBlue2" "DodgerBlue3" "DodgerBlue4"
+ "SteelBlue1" "SteelBlue2" "SteelBlue3" "SteelBlue4"
+ "SkyBlue1" "SkyBlue2" "SkyBlue3" "SkyBlue4"
+ "LightSkyBlue1" "LightSkyBlue2" "LightSkyBlue3" "LightSkyBlue4"
+ "LightBlue1" "LightBlue2" "LightBlue3" "LightBlue4"
+ "CadetBlue1" "CadetBlue2" "CadetBlue3" "CadetBlue4"
+ "azure1" "azure2" "azure3" "azure4"
+ "LightCyan1" "LightCyan2" "LightCyan3" "LightCyan4"
+ "PaleTurquoise1" "PaleTurquoise2" "PaleTurquoise3" "PaleTurquoise4"
+ "DarkSlateGray1" "DarkSlateGray2" "DarkSlateGray3" "DarkSlateGray4"
+ "aquamarine1" "aquamarine2" "aquamarine3" "aquamarine4"
+ "SeaGreen1" "SeaGreen2" "SeaGreen3" "SeaGreen4"
+ "honeydew1" "honeydew2" "honeydew3" "honeydew4"
+ "DarkSeaGreen1" "DarkSeaGreen2" "DarkSeaGreen3" "DarkSeaGreen4"
+ "PaleGreen1" "PaleGreen2" "PaleGreen3" "PaleGreen4"
+ "DarkOliveGreen1" "DarkOliveGreen2" "DarkOliveGreen3" "DarkOliveGreen4"
+ "OliveDrab1" "OliveDrab2" "OliveDrab3" "OliveDrab4"
+ "ivory1" "ivory2" "ivory3" "ivory4"
+ "LightYellow1" "LightYellow2" "LightYellow3" "LightYellow4"
+ "khaki1" "khaki2" "khaki3" "khaki4"
+ "LemonChiffon1" "LemonChiffon2" "LemonChiffon3" "LemonChiffon4"
+ "LightGoldenrod1" "LightGoldenrod2" "LightGoldenrod3" "LightGoldenrod4"
+ "cornsilk1" "cornsilk2" "cornsilk3" "cornsilk4"
+ "goldenrod1" "goldenrod2" "goldenrod3" "goldenrod4"
+ "DarkGoldenrod1" "DarkGoldenrod2" "DarkGoldenrod3" "DarkGoldenrod4"
+ "wheat1" "wheat2" "wheat3" "wheat4"
+ "NavajoWhite1" "NavajoWhite2" "NavajoWhite3" "NavajoWhite4"
+ "burlywood1" "burlywood2" "burlywood3" "burlywood4"
+ "AntiqueWhite1" "AntiqueWhite2" "AntiqueWhite3" "AntiqueWhite4"
+ "bisque1" "bisque2" "bisque3" "bisque4"
+ "tan1" "tan2" "tan3" "tan4"
+ "PeachPuff1" "PeachPuff2" "PeachPuff3" "PeachPuff4"
+ "seashell1" "seashell2" "seashell3" "seashell4"
+ "chocolate1" "chocolate2" "chocolate3" "chocolate4"
+ "sienna1" "sienna2" "sienna3" "sienna4"
+ "LightSalmon1" "LightSalmon2" "LightSalmon3" "LightSalmon4"
+ "salmon1" "salmon2" "salmon3" "salmon4"
+ "coral1" "coral2" "coral3" "coral4"
+ "tomato1" "tomato2" "tomato3" "tomato4"
+ "MistyRose1" "MistyRose2" "MistyRose3" "MistyRose4"
+ "snow1" "snow2" "snow3" "snow4"
+ "RosyBrown1" "RosyBrown2" "RosyBrown3" "RosyBrown4"
+ "IndianRed1" "IndianRed2" "IndianRed3" "IndianRed4"
+ "firebrick1" "firebrick2" "firebrick3" "firebrick4"
+ "brown1" "brown2" "brown3" "brown4"
+ "magenta1" "magenta2" "magenta3" "magenta4"
+ "blue1" "blue2" "blue3" "blue4"
+ "DeepSkyBlue1" "DeepSkyBlue2" "DeepSkyBlue3" "DeepSkyBlue4"
+ "turquoise1" "turquoise2" "turquoise3" "turquoise4"
+ "cyan1" "cyan2" "cyan3" "cyan4"
+ "SpringGreen1" "SpringGreen2" "SpringGreen3" "SpringGreen4"
+ "green1" "green2" "green3" "green4"
+ "chartreuse1" "chartreuse2" "chartreuse3" "chartreuse4"
+ "yellow1" "yellow2" "yellow3" "yellow4"
+ "gold1" "gold2" "gold3" "gold4"
+ "orange1" "orange2" "orange3" "orange4"
+ "DarkOrange1" "DarkOrange2" "DarkOrange3" "DarkOrange4"
+ "OrangeRed1" "OrangeRed2" "OrangeRed3" "OrangeRed4"
+ "red1" "red2" "red3" "red4"
+ "lavender blush" "LavenderBlush" "ghost white" "GhostWhite"
+ "lavender" "alice blue" "AliceBlue" "azure" "light cyan"
+ "LightCyan" "mint cream" "MintCream" "honeydew" "ivory"
+ "light goldenrod yellow" "LightGoldenrodYellow" "light yellow"
+ "LightYellow" "beige" "floral white" "FloralWhite" "old lace"
+ "OldLace" "blanched almond" "BlanchedAlmond" "moccasin"
+ "papaya whip" "PapayaWhip" "bisque" "antique white"
+ "AntiqueWhite" "linen" "peach puff" "PeachPuff" "seashell"
+ "misty rose" "MistyRose" "snow" "light pink" "LightPink" "pink"
+ "hot pink" "HotPink" "deep pink" "DeepPink" "maroon"
+ "pale violet red" "PaleVioletRed" "violet red" "VioletRed"
+ "medium violet red" "MediumVioletRed" "violet" "plum" "thistle"
+ "orchid" "medium orchid" "MediumOrchid" "dark orchid"
+ "DarkOrchid" "purple" "blue violet" "BlueViolet" "medium purple"
+ "MediumPurple" "light slate blue" "LightSlateBlue"
+ "medium slate blue" "MediumSlateBlue" "slate blue" "SlateBlue"
+ "dark slate blue" "DarkSlateBlue" "midnight blue" "MidnightBlue"
+ "navy" "navy blue" "NavyBlue" "dark blue" "DarkBlue"
+ "light steel blue" "LightSteelBlue" "cornflower blue"
+ "CornflowerBlue" "dodger blue" "DodgerBlue" "royal blue"
+ "RoyalBlue" "light slate gray" "light slate grey"
+ "LightSlateGray" "LightSlateGrey" "slate gray" "slate grey"
+ "SlateGray" "SlateGrey" "dark slate gray" "dark slate grey"
+ "DarkSlateGray" "DarkSlateGrey" "steel blue" "SteelBlue"
+ "cadet blue" "CadetBlue" "light sky blue" "LightSkyBlue"
+ "sky blue" "SkyBlue" "light blue" "LightBlue" "powder blue"
+ "PowderBlue" "pale turquoise" "PaleTurquoise" "turquoise"
+ "medium turquoise" "MediumTurquoise" "dark turquoise"
+ "DarkTurquoise" "dark cyan" "DarkCyan" "aquamarine"
+ "medium aquamarine" "MediumAquamarine" "light sea green"
+ "LightSeaGreen" "medium sea green" "MediumSeaGreen" "sea green"
+ "SeaGreen" "dark sea green" "DarkSeaGreen" "pale green"
+ "PaleGreen" "lime green" "LimeGreen" "dark green" "DarkGreen"
+ "forest green" "ForestGreen" "light green" "LightGreen"
+ "green yellow" "GreenYellow" "yellow green" "YellowGreen"
+ "olive drab" "OliveDrab" "dark olive green" "DarkOliveGreen"
+ "lemon chiffon" "LemonChiffon" "khaki" "dark khaki" "DarkKhaki"
+ "cornsilk" "pale goldenrod" "PaleGoldenrod" "light goldenrod"
+ "LightGoldenrod" "goldenrod" "dark goldenrod" "DarkGoldenrod"
+ "wheat" "navajo white" "NavajoWhite" "tan" "burlywood"
+ "sandy brown" "SandyBrown" "peru" "chocolate" "saddle brown"
+ "SaddleBrown" "sienna" "rosy brown" "RosyBrown" "dark salmon"
+ "DarkSalmon" "coral" "tomato" "light salmon" "LightSalmon"
+ "salmon" "light coral" "LightCoral" "indian red" "IndianRed"
+ "firebrick" "brown" "dark red" "DarkRed" "magenta"
+ "dark magenta" "DarkMagenta" "dark violet" "DarkViolet"
+ "medium blue" "MediumBlue" "blue" "deep sky blue" "DeepSkyBlue"
+ "cyan" "medium spring green" "MediumSpringGreen" "spring green"
+ "SpringGreen" "green" "lawn green" "LawnGreen" "chartreuse"
+ "yellow" "gold" "orange" "dark orange" "DarkOrange" "orange red"
+ "OrangeRed" "red" "white" "white smoke" "WhiteSmoke" "gainsboro"
+ "light gray" "light grey" "LightGray" "LightGrey" "gray" "grey"
+ "dark gray" "dark grey" "DarkGray" "DarkGrey" "dim gray"
+ "dim grey" "DimGray" "DimGrey" "black")))
"List of basic colors available on color displays.
For X, the list comes from the `rgb.txt' file,v 10.41 94/02/20.
For Nextstep, this is a list of non-PANTONE colors returned by
the operating system.")
-;; arch-tag: 2a128601-99cc-401e-9dff-0ee6a36102ef
+(defvar w32-color-map)
+
+(defun xw-defined-colors (&optional frame)
+ "Internal function called by `defined-colors', which see."
+ (if (featurep 'ns)
+ x-colors
+ (or frame (setq frame (selected-frame)))
+ (let (defined-colors)
+ (dolist (this-color (if (eq system-type 'windows-nt)
+ (or (mapcar 'car w32-color-map) x-colors)
+ x-colors))
+ (and (color-supported-p this-color frame t)
+ (setq defined-colors (cons this-color defined-colors))))
+ defined-colors)))
+
;;; common-win.el ends here
diff --git a/lisp/term/ns-win.el b/lisp/term/ns-win.el
index b9177b2b432..89fcfde9358 100644
--- a/lisp/term/ns-win.el
+++ b/lisp/term/ns-win.el
@@ -41,131 +41,42 @@
;;; Code:
-
-(if (not (featurep 'ns))
+(or (featurep 'ns)
(error "%s: Loading ns-win.el but not compiled for GNUstep/MacOS"
- (invocation-name)))
+ (invocation-name)))
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl)) ; lexical-let
-;; Documentation-purposes only: actually loaded in loadup.el
+;; Documentation-purposes only: actually loaded in loadup.el.
(require 'frame)
(require 'mouse)
(require 'faces)
-(require 'easymenu)
(require 'menu-bar)
(require 'fontset)
-;; Not needed?
-;;(require 'ispell)
-
(defgroup ns nil
"GNUstep/Mac OS X specific features."
:group 'environment)
-;; nsterm.m
-(defvar ns-version-string)
-(defvar ns-alternate-modifier)
-(defvar ns-right-alternate-modifier)
-
;;;; Command line argument handling.
-(defvar ns-invocation-args nil)
-(defvar ns-command-line-resources nil)
-
-;; Handler for switches of the form "-switch value" or "-switch".
-(defun ns-handle-switch (switch &optional numeric)
- (let ((aelt (assoc switch command-line-ns-option-alist)))
- (if aelt
- (setq default-frame-alist
- (cons (cons (nth 3 aelt)
- (if numeric
- (string-to-number (pop ns-invocation-args))
- (or (nth 4 aelt) (pop ns-invocation-args))))
- default-frame-alist)))))
-
-;; Handler for switches of the form "-switch n"
-(defun ns-handle-numeric-switch (switch)
- (ns-handle-switch switch t))
-
-;; Make -iconic apply only to the initial frame!
-(defun ns-handle-iconic (switch)
- (setq initial-frame-alist
- (cons '(visibility . icon) initial-frame-alist)))
-
-;; Handle the -name option, set the name of the initial frame.
-(defun ns-handle-name-switch (switch)
- (or (consp ns-invocation-args)
- (error "%s: missing argument to `%s' option" (invocation-name) switch))
- (setq initial-frame-alist (cons (cons 'name (pop ns-invocation-args))
- initial-frame-alist)))
-
-;; Set (but not used?) in frame.el.
-(defvar x-display-name nil
- "The name of the window display on which Emacs was started.
-On X, the display name of individual X frames is recorded in the
-`display' frame parameter.")
+(defvar x-invocation-args)
+(defvar ns-command-line-resources nil) ; FIXME unused?
;; nsterm.m.
(defvar ns-input-file)
-(defun ns-handle-nxopen (switch)
- (setq unread-command-events (append unread-command-events '(ns-open-file))
- ns-input-file (append ns-input-file (list (pop ns-invocation-args)))))
+(defun ns-handle-nxopen (switch &optional temp)
+ (setq unread-command-events (append unread-command-events
+ (if temp '(ns-open-temp-file)
+ '(ns-open-file)))
+ ns-input-file (append ns-input-file (list (pop x-invocation-args)))))
(defun ns-handle-nxopentemp (switch)
- (setq unread-command-events (append unread-command-events
- '(ns-open-temp-file))
- ns-input-file (append ns-input-file (list (pop ns-invocation-args)))))
+ (ns-handle-nxopen switch t))
(defun ns-ignore-1-arg (switch)
- (setq ns-invocation-args (cdr ns-invocation-args)))
-(defun ns-ignore-2-arg (switch)
- (setq ns-invocation-args (cddr ns-invocation-args)))
-
-(defun ns-handle-args (args)
- "Process Nextstep-related command line options.
-This is run before the user's startup file is loaded.
-The options in ARGS are copied to `ns-invocation-args'.
-The Nextstep-related settings are then applied using the handlers
-defined in `command-line-ns-option-alist'.
-The return value is ARGS minus the number of arguments processed."
- ;; We use ARGS to accumulate the args that we don't handle here, to return.
- (setq ns-invocation-args args
- args nil)
- (while ns-invocation-args
- (let* ((this-switch (pop ns-invocation-args))
- (orig-this-switch this-switch)
- completion argval aelt handler)
- ;; Check for long options with attached arguments
- ;; and separate out the attached option argument into argval.
- (if (string-match "^--[^=]*=" this-switch)
- (setq argval (substring this-switch (match-end 0))
- this-switch (substring this-switch 0 (1- (match-end 0)))))
- ;; Complete names of long options.
- (if (string-match "^--" this-switch)
- (progn
- (setq completion (try-completion this-switch
- command-line-ns-option-alist))
- (if (eq completion t)
- ;; Exact match for long option.
- nil
- (if (stringp completion)
- (let ((elt (assoc completion command-line-ns-option-alist)))
- ;; Check for abbreviated long option.
- (or elt
- (error "Option `%s' is ambiguous" this-switch))
- (setq this-switch completion))))))
- (setq aelt (assoc this-switch command-line-ns-option-alist))
- (if aelt (setq handler (nth 2 aelt)))
- (if handler
- (if argval
- (let ((ns-invocation-args
- (cons argval ns-invocation-args)))
- (funcall handler this-switch))
- (funcall handler this-switch))
- (setq args (cons orig-this-switch args)))))
- (nreverse args))
+ (setq x-invocation-args (cdr x-invocation-args)))
(defun ns-parse-geometry (geom)
"Parse a Nextstep-style geometry string GEOM.
@@ -187,28 +98,13 @@ The properties returned may include `top', `left', `height', and `width'."
;;;; Keyboard mapping.
-;; These tell read-char how to convert these special chars to ASCII.
-(put 'S-tab 'ascii-character (logior 16 ?\t))
-
-(defvar ns-alternatives-map
- (let ((map (make-sparse-keymap)))
- ;; Map certain keypad keys into ASCII characters
- ;; that people usually expect.
- (define-key map [S-tab] [25])
- (define-key map [M-backspace] [?\M-\d])
- (define-key map [M-delete] [?\M-\d])
- (define-key map [M-tab] [?\M-\t])
- (define-key map [M-linefeed] [?\M-\n])
- (define-key map [M-clear] [?\M-\C-l])
- (define-key map [M-return] [?\M-\C-m])
- (define-key map [M-escape] [?\M-\e])
- map)
- "Keymap of alternative meanings for some keys under Nextstep.")
+(define-obsolete-variable-alias 'ns-alternatives-map 'x-alternatives-map "24.1")
;; Here are some Nextstep-like bindings for command key sequences.
(define-key global-map [?\s-,] 'customize)
(define-key global-map [?\s-'] 'next-multiframe-window)
(define-key global-map [?\s-`] 'other-frame)
+(define-key global-map [?\s-~] 'ns-prev-frame)
(define-key global-map [?\s--] 'center-line)
(define-key global-map [?\s-:] 'ispell)
(define-key global-map [?\s-\;] 'ispell-next)
@@ -258,13 +154,13 @@ The properties returned may include `top', `left', `height', and `width'."
(define-key global-map [kp-prior] 'scroll-down)
(define-key global-map [kp-next] 'scroll-up)
-;;; Allow shift-clicks to work similarly to under Nextstep
+;; Allow shift-clicks to work similarly to under Nextstep.
(define-key global-map [S-mouse-1] 'mouse-save-then-kill)
(global-unset-key [S-down-mouse-1])
-
;; Special Nextstep-generated events are converted to function keys. Here
-;; are the bindings for them.
+;; are the bindings for them. Note, these keys are actually declared in
+;; x-setup-function-keys in common-win.
(define-key global-map [ns-power-off] 'save-buffers-kill-emacs)
(define-key global-map [ns-open-file] 'ns-find-file)
(define-key global-map [ns-open-temp-file] [ns-open-file])
@@ -275,9 +171,7 @@ The properties returned may include `top', `left', `height', and `width'."
(define-key global-map [ns-change-font] 'ns-respond-to-change-font)
(define-key global-map [ns-open-file-line] 'ns-open-file-select-line)
(define-key global-map [ns-spi-service-call] 'ns-spi-service-call)
-(define-key global-map [ns-new-frame] 'make-frame)
(define-key global-map [ns-toggle-toolbar] 'ns-toggle-toolbar)
-(define-key global-map [ns-show-prefs] 'customize)
;; Set up a number of aliases and other layers to pretend we're using
@@ -285,196 +179,15 @@ The properties returned may include `top', `left', `height', and `width'."
(defvaralias 'mac-allow-anti-aliasing 'ns-antialias-text)
(defvaralias 'mac-command-modifier 'ns-command-modifier)
+(defvaralias 'mac-right-command-modifier 'ns-right-command-modifier)
(defvaralias 'mac-control-modifier 'ns-control-modifier)
+(defvaralias 'mac-right-control-modifier 'ns-right-control-modifier)
(defvaralias 'mac-option-modifier 'ns-option-modifier)
(defvaralias 'mac-right-option-modifier 'ns-right-option-modifier)
(defvaralias 'mac-function-modifier 'ns-function-modifier)
(declare-function ns-do-applescript "nsfns.m" (script))
(defalias 'do-applescript 'ns-do-applescript)
-(defun x-setup-function-keys (frame)
- "Set up `function-key-map' on the graphical frame FRAME."
- (unless (terminal-parameter frame 'x-setup-function-keys)
- (with-selected-frame frame
- (setq interprogram-cut-function 'x-select-text
- interprogram-paste-function 'x-cut-buffer-or-selection-value)
- (let ((map (copy-keymap ns-alternatives-map)))
- (set-keymap-parent map (keymap-parent local-function-key-map))
- (set-keymap-parent local-function-key-map map))
- (setq system-key-alist
- (list
- (cons (logior (lsh 0 16) 1) 'ns-power-off)
- (cons (logior (lsh 0 16) 2) 'ns-open-file)
- (cons (logior (lsh 0 16) 3) 'ns-open-temp-file)
- (cons (logior (lsh 0 16) 4) 'ns-drag-file)
- (cons (logior (lsh 0 16) 5) 'ns-drag-color)
- (cons (logior (lsh 0 16) 6) 'ns-drag-text)
- (cons (logior (lsh 0 16) 7) 'ns-change-font)
- (cons (logior (lsh 0 16) 8) 'ns-open-file-line)
-; (cons (logior (lsh 0 16) 9) 'ns-insert-working-text)
-; (cons (logior (lsh 0 16) 10) 'ns-delete-working-text)
- (cons (logior (lsh 0 16) 11) 'ns-spi-service-call)
- (cons (logior (lsh 0 16) 12) 'ns-new-frame)
- (cons (logior (lsh 0 16) 13) 'ns-toggle-toolbar)
- (cons (logior (lsh 0 16) 14) 'ns-show-prefs)
- (cons (logior (lsh 1 16) 32) 'f1)
- (cons (logior (lsh 1 16) 33) 'f2)
- (cons (logior (lsh 1 16) 34) 'f3)
- (cons (logior (lsh 1 16) 35) 'f4)
- (cons (logior (lsh 1 16) 36) 'f5)
- (cons (logior (lsh 1 16) 37) 'f6)
- (cons (logior (lsh 1 16) 38) 'f7)
- (cons (logior (lsh 1 16) 39) 'f8)
- (cons (logior (lsh 1 16) 40) 'f9)
- (cons (logior (lsh 1 16) 41) 'f10)
- (cons (logior (lsh 1 16) 42) 'f11)
- (cons (logior (lsh 1 16) 43) 'f12)
- (cons (logior (lsh 1 16) 44) 'kp-insert)
- (cons (logior (lsh 1 16) 45) 'kp-delete)
- (cons (logior (lsh 1 16) 46) 'kp-home)
- (cons (logior (lsh 1 16) 47) 'kp-end)
- (cons (logior (lsh 1 16) 48) 'kp-prior)
- (cons (logior (lsh 1 16) 49) 'kp-next)
- (cons (logior (lsh 1 16) 50) 'print-screen)
- (cons (logior (lsh 1 16) 51) 'scroll-lock)
- (cons (logior (lsh 1 16) 52) 'pause)
- (cons (logior (lsh 1 16) 53) 'system)
- (cons (logior (lsh 1 16) 54) 'break)
- (cons (logior (lsh 1 16) 56) 'please-tell-carl-what-this-key-is-called-56)
- (cons (logior (lsh 1 16) 61) 'please-tell-carl-what-this-key-is-called-61)
- (cons (logior (lsh 1 16) 62) 'please-tell-carl-what-this-key-is-called-62)
- (cons (logior (lsh 1 16) 63) 'please-tell-carl-what-this-key-is-called-63)
- (cons (logior (lsh 1 16) 64) 'please-tell-carl-what-this-key-is-called-64)
- (cons (logior (lsh 1 16) 69) 'please-tell-carl-what-this-key-is-called-69)
- (cons (logior (lsh 1 16) 70) 'please-tell-carl-what-this-key-is-called-70)
- (cons (logior (lsh 1 16) 71) 'please-tell-carl-what-this-key-is-called-71)
- (cons (logior (lsh 1 16) 72) 'please-tell-carl-what-this-key-is-called-72)
- (cons (logior (lsh 1 16) 73) 'please-tell-carl-what-this-key-is-called-73)
- (cons (logior (lsh 2 16) 3) 'kp-enter)
- (cons (logior (lsh 2 16) 9) 'kp-tab)
- (cons (logior (lsh 2 16) 28) 'kp-quit)
- (cons (logior (lsh 2 16) 35) 'kp-hash)
- (cons (logior (lsh 2 16) 42) 'kp-multiply)
- (cons (logior (lsh 2 16) 43) 'kp-add)
- (cons (logior (lsh 2 16) 44) 'kp-separator)
- (cons (logior (lsh 2 16) 45) 'kp-subtract)
- (cons (logior (lsh 2 16) 46) 'kp-decimal)
- (cons (logior (lsh 2 16) 47) 'kp-divide)
- (cons (logior (lsh 2 16) 48) 'kp-0)
- (cons (logior (lsh 2 16) 49) 'kp-1)
- (cons (logior (lsh 2 16) 50) 'kp-2)
- (cons (logior (lsh 2 16) 51) 'kp-3)
- (cons (logior (lsh 2 16) 52) 'kp-4)
- (cons (logior (lsh 2 16) 53) 'kp-5)
- (cons (logior (lsh 2 16) 54) 'kp-6)
- (cons (logior (lsh 2 16) 55) 'kp-7)
- (cons (logior (lsh 2 16) 56) 'kp-8)
- (cons (logior (lsh 2 16) 57) 'kp-9)
- (cons (logior (lsh 2 16) 60) 'kp-less)
- (cons (logior (lsh 2 16) 61) 'kp-equal)
- (cons (logior (lsh 2 16) 62) 'kp-more)
- (cons (logior (lsh 2 16) 64) 'kp-at)
- (cons (logior (lsh 2 16) 92) 'kp-backslash)
- (cons (logior (lsh 2 16) 96) 'kp-backtick)
- (cons (logior (lsh 2 16) 124) 'kp-bar)
- (cons (logior (lsh 2 16) 126) 'kp-tilde)
- (cons (logior (lsh 2 16) 157) 'kp-mu)
- (cons (logior (lsh 2 16) 165) 'kp-yen)
- (cons (logior (lsh 2 16) 167) 'kp-paragraph)
- (cons (logior (lsh 2 16) 172) 'left)
- (cons (logior (lsh 2 16) 173) 'up)
- (cons (logior (lsh 2 16) 174) 'right)
- (cons (logior (lsh 2 16) 175) 'down)
- (cons (logior (lsh 2 16) 176) 'kp-ring)
- (cons (logior (lsh 2 16) 201) 'kp-square)
- (cons (logior (lsh 2 16) 204) 'kp-cube)
- (cons (logior (lsh 3 16) 8) 'backspace)
- (cons (logior (lsh 3 16) 9) 'tab)
- (cons (logior (lsh 3 16) 10) 'linefeed)
- (cons (logior (lsh 3 16) 11) 'clear)
- (cons (logior (lsh 3 16) 13) 'return)
- (cons (logior (lsh 3 16) 18) 'pause)
- (cons (logior (lsh 3 16) 25) 'S-tab)
- (cons (logior (lsh 3 16) 27) 'escape)
- (cons (logior (lsh 3 16) 127) 'delete)
- )))
- (set-terminal-parameter frame 'x-setup-function-keys t)))
-
-
-;; Add a couple of menus and rearrange some others; easiest just to redo toplvl
-;; Note keymap defns must be given last-to-first
-(define-key global-map [menu-bar] (make-sparse-keymap "menu-bar"))
-
-(setq menu-bar-final-items
- (cond ((eq system-type 'darwin)
- '(buffer windows services help-menu))
- ;; Otherwise, GNUstep.
- (t
- '(buffer windows services hide-app quit))))
-
-;; Add standard top-level items to GNUstep menu.
-(unless (eq system-type 'darwin)
- (define-key global-map [menu-bar quit] '("Quit" . save-buffers-kill-emacs))
- (define-key global-map [menu-bar hide-app] '("Hide" . ns-do-hide-emacs)))
-
-(define-key global-map [menu-bar services]
- (cons "Services" (make-sparse-keymap "Services")))
-(define-key global-map [menu-bar buffer]
- (cons "Buffers" global-buffers-menu-map))
-;; (cons "Buffers" (make-sparse-keymap "Buffers")))
-(define-key global-map [menu-bar tools] (cons "Tools" menu-bar-tools-menu))
-(define-key global-map [menu-bar options] (cons "Options" menu-bar-options-menu))
-(define-key global-map [menu-bar edit] (cons "Edit" menu-bar-edit-menu))
-(define-key global-map [menu-bar file] (cons "File" menu-bar-file-menu))
-
-;; If running under GNUstep, rename "Help" to "Info"
-(cond ((eq system-type 'darwin)
- (define-key global-map [menu-bar help-menu]
- (cons "Help" menu-bar-help-menu)))
- (t
- (let ((contents (reverse (cdr menu-bar-help-menu))))
- (setq menu-bar-help-menu
- (append (list 'keymap) (cdr contents) (list "Info"))))
- (define-key global-map [menu-bar help-menu]
- (cons "Info" menu-bar-help-menu))))
-
-(if (not (eq system-type 'darwin))
- ;; in OS X it's in the app menu already
- (define-key menu-bar-help-menu [info-panel]
- '("About Emacs..." . ns-do-emacs-info-panel)))
-
-;;;; Edit menu: Modify slightly
-
-;; Substitute a Copy function that works better under X (for GNUstep).
-(easy-menu-remove-item global-map '("menu-bar" "edit") 'copy)
-(define-key-after menu-bar-edit-menu [copy]
- '(menu-item "Copy" ns-copy-including-secondary
- :enable mark-active
- :help "Copy text in region between mark and current position")
- 'cut)
-
-;; Change to same precondition as select-and-paste, as we don't have
-;; `x-selection-exists-p'.
-(easy-menu-remove-item global-map '("menu-bar" "edit") 'paste)
-(define-key-after menu-bar-edit-menu [paste]
- '(menu-item "Paste" yank
- :enable (and (cdr yank-menu) (not buffer-read-only))
- :help "Paste (yank) text most recently cut/copied")
- 'copy)
-
-;; Change text to be more consistent with surrounding menu items `paste', etc.
-(easy-menu-remove-item global-map '("menu-bar" "edit") 'paste-from-menu)
-(define-key-after menu-bar-edit-menu [select-paste]
- '(menu-item "Select and Paste" yank-menu
- :enable (and (cdr yank-menu) (not buffer-read-only))
- :help "Choose a string from the kill ring and paste it")
- 'paste)
-
-;; Separate undo from cut/paste section, add spell for platform consistency.
-(define-key-after menu-bar-edit-menu [separator-undo] '("--") 'undo)
-(define-key-after menu-bar-edit-menu [spell] '("Spell" . ispell-menu-map) 'fill)
-
-
;;;; Services
(declare-function ns-perform-service "nsfns.m" (service send))
@@ -538,10 +251,6 @@ The properties returned may include `top', `left', `height', and `width'."
(t (error (concat "Service " ns-input-spi-name " not recognized")))))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-
;; Composed key sequence handling for Nextstep system input methods.
;; (On Nextstep systems, input methods are provided for CJK
;; characters, etc. which require multiple keystrokes, and during
@@ -638,29 +347,24 @@ See `ns-insert-working-text'."
;;;; OS X file system Unicode UTF-8 NFD (decomposed form) support
;; Lisp code based on utf-8m.el, by Seiji Zenitani, Eiji Honjoh, and
;; Carsten Bormann.
-(if (eq system-type 'darwin)
- (progn
-
- (defun ns-utf8-nfd-post-read-conversion (length)
- "Calls `ns-convert-utf8-nfd-to-nfc' to compose char sequences."
- (save-excursion
- (save-restriction
- (narrow-to-region (point) (+ (point) length))
- (let ((str (buffer-string)))
- (delete-region (point-min) (point-max))
- (insert (ns-convert-utf8-nfd-to-nfc str))
- (- (point-max) (point-min))
- ))))
-
- (define-coding-system 'utf-8-nfd
- "UTF-8 NFD (decomposed) encoding."
- :coding-type 'utf-8
- :mnemonic ?U
- :charset-list '(unicode)
- :post-read-conversion 'ns-utf8-nfd-post-read-conversion)
- (set-file-name-coding-system 'utf-8-nfd)))
-
-
+(when (eq system-type 'darwin)
+ (defun ns-utf8-nfd-post-read-conversion (length)
+ "Calls `ns-convert-utf8-nfd-to-nfc' to compose char sequences."
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (point) (+ (point) length))
+ (let ((str (buffer-string)))
+ (delete-region (point-min) (point-max))
+ (insert (ns-convert-utf8-nfd-to-nfc str))
+ (- (point-max) (point-min))))))
+
+ (define-coding-system 'utf-8-nfd
+ "UTF-8 NFD (decomposed) encoding."
+ :coding-type 'utf-8
+ :mnemonic ?U
+ :charset-list '(unicode)
+ :post-read-conversion 'ns-utf8-nfd-post-read-conversion)
+ (set-file-name-coding-system 'utf-8-nfd))
;;;; Inter-app communications support.
@@ -676,12 +380,10 @@ See `ns-insert-working-text'."
"Insert contents of file `ns-input-file' like insert-file but with less
prompting. If file is a directory perform a `find-file' on it."
(interactive)
- (let ((f))
- (setq f (car ns-input-file))
- (setq ns-input-file (cdr ns-input-file))
+ (let ((f (pop ns-input-file)))
(if (file-directory-p f)
(find-file f)
- (push-mark (+ (point) (car (cdr (insert-file-contents f))))))))
+ (push-mark (+ (point) (cadr (insert-file-contents f)))))))
(defvar ns-select-overlay nil
"Overlay used to highlight areas in files requested by Nextstep apps.")
@@ -734,8 +436,6 @@ Lines are highlighted according to `ns-input-line'."
(add-hook 'first-change-hook 'ns-unselect-line)
-
-
;;;; Preferences handling.
(declare-function ns-get-resource "nsfns.m" (owner name))
@@ -786,12 +486,10 @@ unless the current buffer is a scratch buffer."
(defun ns-find-file ()
"Do a `find-file' with the `ns-input-file' as argument."
(interactive)
- (let ((f) (file) (bufwin1) (bufwin2))
- (setq f (file-truename (car ns-input-file)))
- (setq ns-input-file (cdr ns-input-file))
- (setq file (find-file-noselect f))
- (setq bufwin1 (get-buffer-window file 'visible))
- (setq bufwin2 (get-buffer-window "*scratch*" 'visibile))
+ (let* ((f (file-truename (pop ns-input-file)))
+ (file (find-file-noselect f))
+ (bufwin1 (get-buffer-window file 'visible))
+ (bufwin2 (get-buffer-window "*scratch*" 'visibile)))
(cond
(bufwin1
(select-frame (window-frame bufwin1))
@@ -810,13 +508,17 @@ unless the current buffer is a scratch buffer."
(ns-hide-emacs 'activate)
(find-file f)))))
-
-
;;;; Frame-related functions.
;; Don't show the frame name; that's redundant with Nextstep.
(setq-default mode-line-frame-identification '(" "))
+;; nsterm.m
+(defvar ns-alternate-modifier)
+(defvar ns-right-alternate-modifier)
+(defvar ns-right-command-modifier)
+(defvar ns-right-control-modifier)
+
;; You say tomAYto, I say tomAHto..
(defvaralias 'ns-option-modifier 'ns-alternate-modifier)
(defvaralias 'ns-right-option-modifier 'ns-right-alternate-modifier)
@@ -883,10 +585,8 @@ unless the current buffer is a scratch buffer."
(if (not tool-bar-mode) (tool-bar-mode t)))
-
;;;; Dialog-related functions.
-
;; Ask user for confirm before printing. Due to Kevin Rodgers.
(defun ns-print-buffer ()
"Interactive front-end to `print-buffer': asks for user confirmation first."
@@ -904,7 +604,6 @@ unless the current buffer is a scratch buffer."
(error "Cancelled")))
(print-buffer)))
-
;;;; Font support.
;; Needed for font listing functions under both backend and normal
@@ -949,17 +648,16 @@ come with OS X.
See the documentation of `create-fontset-from-fontset-spec' for the format.")
;; Conditional on new-fontset so bootstrapping works on non-GUI compiles.
-(if (fboundp 'new-fontset)
- (progn
- ;; Setup the default fontset.
- (create-default-fontset)
- ;; Create the standard fontset.
- (condition-case err
- (create-fontset-from-fontset-spec ns-standard-fontset-spec t)
- (error (display-warning
- 'initialization
- (format "Creation of the standard fontset failed: %s" err)
- :error)))))
+(when (fboundp 'new-fontset)
+ ;; Setup the default fontset.
+ (create-default-fontset)
+ ;; Create the standard fontset.
+ (condition-case err
+ (create-fontset-from-fontset-spec ns-standard-fontset-spec t)
+ (error (display-warning
+ 'initialization
+ (format "Creation of the standard fontset failed: %s" err)
+ :error))))
(defvar ns-reg-to-script) ; nsfont.m
@@ -1008,7 +706,7 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.")
(defun ns-get-pasteboard ()
"Returns the value of the pasteboard."
- (ns-get-cut-buffer-internal 'PRIMARY))
+ (ns-get-cut-buffer-internal 'CLIPBOARD))
(declare-function ns-store-cut-buffer-internal "nsselect.m" (buffer string))
@@ -1016,43 +714,21 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.")
"Store STRING into the pasteboard of the Nextstep display server."
;; Check the data type of STRING.
(if (not (stringp string)) (error "Nonstring given to pasteboard"))
- (ns-store-cut-buffer-internal 'PRIMARY string))
+ (ns-store-cut-buffer-internal 'CLIPBOARD string))
;; We keep track of the last text selected here, so we can check the
;; current selection against it, and avoid passing back our own text
-;; from x-cut-buffer-or-selection-value.
+;; from x-selection-value.
(defvar ns-last-selected-text nil)
-(defun x-select-text (text &optional push)
- "Select TEXT, a string, according to the window system.
-
-On X, put TEXT in the primary X selection. For backward
-compatibility with older X applications, set the value of X cut
-buffer 0 as well, and if the optional argument PUSH is non-nil,
-rotate the cut buffers. If `x-select-enable-clipboard' is
-non-nil, copy the text to the X clipboard as well.
-
-On Windows, make TEXT the current selection. If
-`x-select-enable-clipboard' is non-nil, copy the text to the
-clipboard as well. The argument PUSH is ignored.
-
-On Nextstep, put TEXT in the pasteboard; PUSH is ignored."
- ;; Don't send the pasteboard too much text.
- ;; It becomes slow, and if really big it causes errors.
- (ns-set-pasteboard text)
- (setq ns-last-selected-text text))
-
;; Return the value of the current Nextstep selection. For
;; compatibility with older Nextstep applications, this checks cut
;; buffer 0 before retrieving the value of the primary selection.
-(defun x-cut-buffer-or-selection-value ()
+(defun x-selection-value ()
(let (text)
-
- ;; Consult the selection, then the cut buffer. Treat empty strings
- ;; as if they were unset.
+ ;; Consult the selection. Treat empty strings as if they were unset.
(or text (setq text (ns-get-pasteboard)))
(if (string= text "") (setq text nil))
-
(cond
((not text) nil)
((eq text ns-last-selected-text) nil)
@@ -1073,7 +749,6 @@ On Nextstep, put TEXT in the pasteboard; PUSH is ignored."
(insert (ns-get-cut-buffer-internal 'SECONDARY)))
-
;;;; Scrollbar handling.
(global-set-key [vertical-scroll-bar down-mouse-1] 'ns-handle-scroll-bar-event)
@@ -1134,27 +809,6 @@ On Nextstep, put TEXT in the pasteboard; PUSH is ignored."
;;;; Color support.
-(declare-function ns-list-colors "nsfns.m" (&optional frame))
-
-(defvar x-colors (ns-list-colors)
- "List of basic colors available on color displays.
-For X, the list comes from the `rgb.txt' file,v 10.41 94/02/20.
-For Nextstep, this is a list of non-PANTONE colors returned by
-the operating system.")
-
-(defun xw-defined-colors (&optional frame)
- "Internal function called by `defined-colors'."
- (or frame (setq frame (selected-frame)))
- (let ((all-colors x-colors)
- (this-color nil)
- (defined-colors nil))
- (while all-colors
- (setq this-color (car all-colors)
- all-colors (cdr all-colors))
- ;; (and (face-color-supported-p frame this-color t)
- (setq defined-colors (cons this-color defined-colors))) ;;)
- defined-colors))
-
;; Functions for color panel + drag
(defun ns-face-at-pos (pos)
(let* ((frame (car pos))
@@ -1242,7 +896,7 @@ the operating system.")
"Initialize Emacs for Nextstep (Cocoa / GNUstep) windowing."
;; PENDING: not needed?
- (setq command-line-args (ns-handle-args command-line-args))
+ (setq command-line-args (x-handle-args command-line-args))
(x-open-connection (system-name) nil t)
@@ -1261,12 +915,11 @@ the operating system.")
(setq ns-initialized t))
-(add-to-list 'handle-args-function-alist '(ns . ns-handle-args))
+(add-to-list 'handle-args-function-alist '(ns . x-handle-args))
(add-to-list 'frame-creation-function-alist '(ns . x-create-frame-with-faces))
(add-to-list 'window-system-initialization-alist '(ns . ns-initialize-window-system))
(provide 'ns-win)
-;; arch-tag: eb138a45-4e2e-4d68-b1c9-a39665731644
;;; ns-win.el ends here
diff --git a/lisp/term/pc-win.el b/lisp/term/pc-win.el
index d9d4e3851fe..c13862a8da0 100644
--- a/lisp/term/pc-win.el
+++ b/lisp/term/pc-win.el
@@ -1,7 +1,7 @@
;;; pc-win.el --- setup support for `PC windows' (whatever that is)
-;; Copyright (C) 1994, 1996, 1997, 1999, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 1996, 1997, 1999, 2001, 2002, 2003, 2004, 2005,
+;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Morten Welinder <terra@diku.dk>
;; Maintainer: FSF
@@ -192,44 +192,43 @@ the operating system.")
;; From lisp/term/w32-win.el
;
-;;;; Selections and cut buffers
+;;;; Selections
;
;;; We keep track of the last text selected here, so we can check the
;;; current selection against it, and avoid passing back our own text
-;;; from x-cut-buffer-or-selection-value.
+;;; from x-selection-value.
(defvar x-last-selected-text nil)
(defcustom x-select-enable-clipboard t
"Non-nil means cutting and pasting uses the clipboard.
This is in addition to, but in preference to, the primary selection.
-On MS-Windows, this is non-nil by default, since Windows does not
-support other types of selections. \(The primary selection that is
-set by Emacs is not accessible to other programs on Windows.\)"
+Note that MS-Windows does not support selection types other than the
+clipboard. (The primary selection that is set by Emacs is not
+accessible to other programs on MS-Windows.)
+
+This variable is not used by the Nextstep port."
:type 'boolean
:group 'killing)
-(defun x-select-text (text &optional push)
+(defun x-select-text (text)
"Select TEXT, a string, according to the window system.
-On X, put TEXT in the primary X selection. For backward
-compatibility with older X applications, set the value of X cut
-buffer 0 as well, and if the optional argument PUSH is non-nil,
-rotate the cut buffers. If `x-select-enable-clipboard' is
-non-nil, copy the text to the X clipboard as well.
+On X, if `x-select-enable-clipboard' is non-nil, copy TEXT to the
+clipboard. If `x-select-enable-primary' is non-nil, put TEXT in
+the primary selection.
On Windows, make TEXT the current selection. If
`x-select-enable-clipboard' is non-nil, copy the text to the
-clipboard as well. The argument PUSH is ignored.
+clipboard as well.
-On Nextstep, put TEXT in the pasteboard; PUSH is ignored."
+On Nextstep, put TEXT in the pasteboard."
(if x-select-enable-clipboard
(w16-set-clipboard-data text))
(setq x-last-selected-text text))
;;; Return the value of the current selection.
-;;; Consult the selection, then the cut buffer. Treat empty strings
-;;; as if they were unset.
+;;; Consult the selection. Treat empty strings as if they were unset.
(defun x-get-selection-value ()
(if x-select-enable-clipboard
(let (text)
@@ -289,14 +288,15 @@ Disowning it means there is no such selection."
(if (x-selection-owner-p selection)
t))
-;; From lisp/faces.el: we only have one font, so always return
-;; it, no matter which variety they've asked for.
-(defun x-frob-font-slant (font which)
- font)
-(make-obsolete 'x-frob-font-slant 'make-face-... "21.1")
-(defun x-frob-font-weight (font which)
- font)
-(make-obsolete 'x-frob-font-weight 'make-face-... "21.1")
+;; x-get-selection-internal is used in select.el
+(defun x-get-selection-internal (selection type &optional time_stamp)
+ "Return text selected from some X window.
+SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
+\(Those are literal upper-case symbol names, since that's what X expects.)
+TYPE is the type of data desired, typically `STRING'.
+TIME_STAMP is the time to use in the XConvertSelection call for foreign
+selections. If omitted, defaults to the time for the last event."
+ (x-get-selection-value))
;; From src/fontset.c:
(fset 'query-fontset 'ignore)
@@ -420,5 +420,4 @@ Errors out because it is not supposed to be called, ever."
(provide 'pc-win)
-;; arch-tag: 5cbdb455-b495-427b-95d0-e417d77d00b4
;;; pc-win.el ends here
diff --git a/lisp/term/tty-colors.el b/lisp/term/tty-colors.el
index cc462455517..df45dc192a7 100644
--- a/lisp/term/tty-colors.el
+++ b/lisp/term/tty-colors.el
@@ -1,7 +1,7 @@
;;; tty-colors.el --- color support for character terminals
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Eli Zaretskii
;; Maintainer: FSF
@@ -768,11 +768,6 @@
(yes . 8))
"An alist of supported standard tty color modes and their aliases.")
-(defvar tty-defined-color-alist nil
- "An alist of defined terminal colors and their RGB values.
-
-See the docstring of `tty-color-alist' for the details.")
-
(defun tty-color-alist (&optional frame)
"Return an alist of colors supported by FRAME's terminal.
FRAME defaults to the selected frame.
@@ -1039,5 +1034,4 @@ A color is considered gray if the 3 components of its RGB value are equal."
(setq colors (cdr colors)))
count))
-;; arch-tag: 84d5c3ef-ae22-4754-99ac-e6350c0967ae
;;; tty-colors.el ends here
diff --git a/lisp/term/tvi970.el b/lisp/term/tvi970.el
index 389adcde6c4..4476165febc 100644
--- a/lisp/term/tvi970.el
+++ b/lisp/term/tvi970.el
@@ -28,6 +28,8 @@
;;; Code:
+(eval-when-compile (require 'cl))
+
(defvar tvi970-terminal-map
(let ((map (make-sparse-keymap)))
@@ -102,7 +104,7 @@
;; Should keypad numbers send ordinary digits or distinct escape sequences?
-(defun tvi970-set-keypad-mode (&optional arg)
+(define-minor-mode tvi970-set-keypad-mode
"Set the current mode of the TVI 970 numeric keypad.
In ``numeric keypad mode'', the number keys on the keypad act as
ordinary digits. In ``alternate keypad mode'', the keys send distinct
@@ -111,12 +113,9 @@ independent of the normal number keys.
With no argument, toggle between the two possible modes.
With a positive argument, select alternate keypad mode.
With a negative argument, select numeric keypad mode."
- (interactive "P")
- (let ((newval (if (null arg)
- (not (terminal-parameter nil 'tvi970-keypad-numeric))
- (> (prefix-numeric-value arg) 0))))
- (set-terminal-parameter nil 'tvi970-keypad-numeric newval)
- (send-string-to-terminal (if newval "\e=" "\e>"))))
+ :variable (terminal-parameter nil 'tvi970-keypad-numeric)
+ (send-string-to-terminal
+ (if (terminal-parameter nil 'tvi970-keypad-numeric) "\e=" "\e>")))
;; arch-tag: c1334cf0-1462-41c3-a963-c077d175f8f0
;;; tvi970.el ends here
diff --git a/lisp/term/vt100.el b/lisp/term/vt100.el
index d0560702ac0..24561fe835f 100644
--- a/lisp/term/vt100.el
+++ b/lisp/term/vt100.el
@@ -41,19 +41,13 @@
(tty-run-terminal-initialization (selected-frame) "lk201"))
;;; Controlling the screen width.
-(defvar vt100-wide-mode (= (frame-width) 132)
- "t if vt100 is in 132-column mode.")
-
-(defun vt100-wide-mode (&optional arg)
+(define-minor-mode vt100-wide-mode
"Toggle 132/80 column mode for vt100s.
With positive argument, switch to 132-column mode.
With negative argument, switch to 80-column mode."
- (interactive "P")
- (setq vt100-wide-mode
- (if (null arg) (not vt100-wide-mode)
- (> (prefix-numeric-value arg) 0)))
- (send-string-to-terminal (if vt100-wide-mode "\e[?3h" "\e[?3l"))
- (set-frame-width terminal-frame (if vt100-wide-mode 132 80)))
+ :global t :init-value (= (frame-width) 132)
+ (send-string-to-terminal (if vt100-wide-mode "\e[?3h" "\e[?3l"))
+ (set-frame-width terminal-frame (if vt100-wide-mode 132 80)))
;; arch-tag: 9ff41f24-a7c9-4dee-9cf2-fbaa951eb840
;;; vt100.el ends here
diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el
index 1779d1025e0..a1ab5a8225c 100644
--- a/lisp/term/w32-win.el
+++ b/lisp/term/w32-win.el
@@ -148,18 +148,8 @@ the last file dropped is selected."
(global-set-key [language-change] 'ignore)
(defvar x-resource-name)
-(defvar x-colors)
-(defun xw-defined-colors (&optional frame)
- "Internal function called by `defined-colors', which see."
- (or frame (setq frame (selected-frame)))
- (let ((defined-colors nil))
- (dolist (this-color (or (mapcar 'car w32-color-map) x-colors))
- (and (color-supported-p this-color frame t)
- (setq defined-colors (cons this-color defined-colors))))
- defined-colors))
-
;;;; Function keys
;;; make f10 activate the real menubar rather than the mini-buffer menu
@@ -196,10 +186,10 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.")
"Report an error when a suspend is attempted."
(error "Suspending an Emacs running under W32 makes no sense"))
-(defvar image-library-alist)
+(defvar dynamic-library-alist)
-;;; Set default known names for image libraries
-(setq image-library-alist
+;;; Set default known names for external libraries
+(setq dynamic-library-alist
'((xpm "libxpm.dll" "xpm4.dll" "libXpm-nox4.dll")
(png "libpng12d.dll" "libpng12.dll" "libpng.dll"
;; these are libpng 1.2.8 from GTK+
@@ -316,5 +306,4 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.")
(provide 'w32-win)
-;; arch-tag: 69fb1701-28c2-4890-b351-3d1fe4b4f166
;;; w32-win.el ends here
diff --git a/lisp/term/w32console.el b/lisp/term/w32console.el
index 5da8b84d3f4..0d3aa934b9b 100644
--- a/lisp/term/w32console.el
+++ b/lisp/term/w32console.el
@@ -45,7 +45,7 @@
("white" 15 65535 65535 65535))
"A list of VGA console colors, their indices and 16-bit RGB values.")
-(declare-function x-setup-function-keys "w32-fns" (frame))
+(declare-function x-setup-function-keys "term/common-win" (frame))
(defun terminal-init-w32console ()
"Terminal initialization function for w32 console."
@@ -62,4 +62,4 @@
(tty-set-up-initial-frame-faces)
(run-hooks 'terminal-init-w32-hook))
-;; arch-tag: 3195fd5e-ab86-4a46-b1dc-4f7a8c8deff3
+;;; w32console.el ends here
diff --git a/lisp/term/x-win.el b/lisp/term/x-win.el
index 3208ece9c09..afb706ab972 100644
--- a/lisp/term/x-win.el
+++ b/lisp/term/x-win.el
@@ -1,7 +1,7 @@
;;; x-win.el --- parse relevant switches and set up for X -*-coding: iso-2022-7bit;-*-
;; Copyright (C) 1993, 1994, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010 Free Software Foundation, Inc.
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: FSF
;; Keywords: terminals, i18n
@@ -252,50 +252,6 @@ exists."
(defconst x-pointer-invisible 255)
-(defvar x-colors)
-
-(defun xw-defined-colors (&optional frame)
- "Internal function called by `defined-colors'."
- (or frame (setq frame (selected-frame)))
- (let ((all-colors x-colors)
- (this-color nil)
- (defined-colors nil))
- (while all-colors
- (setq this-color (car all-colors)
- all-colors (cdr all-colors))
- (and (color-supported-p this-color frame t)
- (setq defined-colors (cons this-color defined-colors))))
- defined-colors))
-
-;;;; Function keys
-
-(defvar x-alternatives-map
- (let ((map (make-sparse-keymap)))
- ;; Map certain keypad keys into ASCII characters that people usually expect.
- (define-key map [M-backspace] [?\M-\d])
- (define-key map [M-delete] [?\M-\d])
- (define-key map [M-tab] [?\M-\t])
- (define-key map [M-linefeed] [?\M-\n])
- (define-key map [M-clear] [?\M-\C-l])
- (define-key map [M-return] [?\M-\C-m])
- (define-key map [M-escape] [?\M-\e])
- (define-key map [iso-lefttab] [backtab])
- (define-key map [S-iso-lefttab] [backtab])
- map)
- "Keymap of possible alternative meanings for some keys.")
-
-(defun x-setup-function-keys (frame)
- "Set up `function-key-map' on the graphical frame FRAME."
- ;; Don't do this twice on the same display, or it would break
- ;; normal-erase-is-backspace-mode.
- (unless (terminal-parameter frame 'x-setup-function-keys)
- ;; Map certain keypad keys into ASCII characters that people usually expect.
- (with-selected-frame frame
- (let ((map (copy-keymap x-alternatives-map)))
- (set-keymap-parent map (keymap-parent local-function-key-map))
- (set-keymap-parent local-function-key-map map)))
- (set-terminal-parameter frame 'x-setup-function-keys t)))
-
;;;; Keysyms
(defun vendor-specific-keysyms (vendor)
@@ -1192,83 +1148,25 @@ as returned by `x-server-vendor'."
;; #x0dde THAI MAIHANAKAT Thai
-;;;; Selections and cut buffers
+;;;; Selections
;; We keep track of the last text selected here, so we can check the
;; current selection against it, and avoid passing back our own text
-;; from x-cut-buffer-or-selection-value. We track all three
+;; from x-selection-value. We track both
;; separately in case another X application only sets one of them
-;; (say the cut buffer) we aren't fooled by the PRIMARY or
-;; CLIPBOARD selection staying the same.
+;; we aren't fooled by the PRIMARY or CLIPBOARD selection staying the same.
(defvar x-last-selected-text-clipboard nil
"The value of the CLIPBOARD X selection last time we selected or
pasted text.")
(defvar x-last-selected-text-primary nil
"The value of the PRIMARY X selection last time we selected or
pasted text.")
-(defvar x-last-selected-text-cut nil
- "The value of the X cut buffer last time we selected or pasted text.
-The actual text stored in the X cut buffer is what encoded from this value.")
-(defvar x-last-selected-text-cut-encoded nil
- "The value of the X cut buffer last time we selected or pasted text.
-This is the actual text stored in the X cut buffer.")
-(defvar x-last-cut-buffer-coding 'iso-latin-1
- "The coding we last used to encode/decode the text from the X cut buffer")
-
-(defvar x-cut-buffer-max 20000 ; Note this value is overridden below.
- "Max number of characters to put in the cut buffer.
-It is said that overlarge strings are slow to put into the cut buffer.")
-
-(defcustom x-select-enable-clipboard nil
- "Non-nil means cutting and pasting uses the clipboard.
-This is in addition to, but in preference to, the primary selection.
-
-On MS-Windows, this is non-nil by default, since Windows does not
-support other types of selections. \(The primary selection that is
-set by Emacs is not accessible to other programs on Windows.\)"
- :type 'boolean
- :group 'killing)
-(defcustom x-select-enable-primary t
+(defcustom x-select-enable-primary nil
"Non-nil means cutting and pasting uses the primary selection."
:type 'boolean
- :group 'killing)
-
-(defun x-select-text (text &optional push)
- "Select TEXT, a string, according to the window system.
-
-On X, put TEXT in the primary X selection. For backward
-compatibility with older X applications, set the value of X cut
-buffer 0 as well, and if the optional argument PUSH is non-nil,
-rotate the cut buffers. If `x-select-enable-clipboard' is
-non-nil, copy the text to the X clipboard as well.
-
-On Windows, make TEXT the current selection. If
-`x-select-enable-clipboard' is non-nil, copy the text to the
-clipboard as well. The argument PUSH is ignored.
-
-On Nextstep, put TEXT in the pasteboard; PUSH is ignored."
- ;; With multi-tty, this function may be called from a tty frame.
- (when (eq (framep (selected-frame)) 'x)
- ;; Don't send the cut buffer too much text.
- ;; It becomes slow, and if really big it causes errors.
- (cond ((>= (length text) x-cut-buffer-max)
- (x-set-cut-buffer "" push)
- (setq x-last-selected-text-cut ""
- x-last-selected-text-cut-encoded ""))
- (t
- (setq x-last-selected-text-cut text
- x-last-cut-buffer-coding 'iso-latin-1
- x-last-selected-text-cut-encoded
- ;; ICCCM says cut buffer always contain ISO-Latin-1
- (encode-coding-string text 'iso-latin-1))
- (x-set-cut-buffer x-last-selected-text-cut-encoded push)))
- (when x-select-enable-primary
- (x-set-selection 'PRIMARY text)
- (setq x-last-selected-text-primary text))
- (when x-select-enable-clipboard
- (x-set-selection 'CLIPBOARD text)
- (setq x-last-selected-text-clipboard text))))
+ :group 'killing
+ :version "24.1")
(defvar x-select-request-type nil
"*Data type request for X selection.
@@ -1290,7 +1188,7 @@ The value nil is the same as this list:
;; The return value is already decoded. If x-get-selection causes an
;; error, this function return nil.
-(defun x-selection-value (type)
+(defun x-selection-value-internal (type)
(let ((request-type (or x-select-request-type
'(UTF8_STRING COMPOUND_TEXT STRING)))
text)
@@ -1308,17 +1206,16 @@ The value nil is the same as this list:
text))
;; Return the value of the current X selection.
-;; Consult the selection, and the cut buffer. Treat empty strings
-;; as if they were unset.
+;; Consult the selection. Treat empty strings as if they were unset.
;; If this function is called twice and finds the same text,
;; it returns nil the second time. This is so that a single
;; selection won't be added to the kill ring over and over.
-(defun x-cut-buffer-or-selection-value ()
+(defun x-selection-value ()
;; With multi-tty, this function may be called from a tty frame.
(when (eq (framep (selected-frame)) 'x)
- (let (clip-text primary-text cut-text)
+ (let (clip-text primary-text)
(when x-select-enable-clipboard
- (setq clip-text (x-selection-value 'CLIPBOARD))
+ (setq clip-text (x-selection-value-internal 'CLIPBOARD))
(if (string= clip-text "") (setq clip-text nil))
;; Check the CLIPBOARD selection for 'newness', is it different
@@ -1337,7 +1234,7 @@ The value nil is the same as this list:
(t (setq x-last-selected-text-clipboard clip-text)))))
(when x-select-enable-primary
- (setq primary-text (x-selection-value 'PRIMARY))
+ (setq primary-text (x-selection-value-internal 'PRIMARY))
;; Check the PRIMARY selection for 'newness', is it different
;; from what we remebered them to be last time we did a
;; cut/paste operation.
@@ -1354,69 +1251,45 @@ The value nil is the same as this list:
(t
(setq x-last-selected-text-primary primary-text)))))
- (setq cut-text (x-get-cut-buffer 0))
-
- ;; Check the x cut buffer for 'newness', is it different
- ;; from what we remebered them to be last time we did a
- ;; cut/paste operation.
- (setq cut-text
- (let ((next-coding (or next-selection-coding-system 'iso-latin-1)))
- (cond ;; check cut buffer
- ((or (not cut-text) (string= cut-text ""))
- (setq x-last-selected-text-cut nil))
- ;; This short cut doesn't work because x-get-cut-buffer
- ;; always returns a newly created string.
- ;; ((eq cut-text x-last-selected-text-cut) nil)
- ((and (string= cut-text x-last-selected-text-cut-encoded)
- (eq x-last-cut-buffer-coding next-coding))
- ;; See the comment above. No need of this recording.
- ;; Record the newer string,
- ;; so subsequent calls can use the `eq' test.
- ;; (setq x-last-selected-text-cut cut-text)
- nil)
- (t
- (setq x-last-selected-text-cut-encoded cut-text
- x-last-cut-buffer-coding next-coding
- x-last-selected-text-cut
- ;; ICCCM says cut buffer always contain ISO-Latin-1, but
- ;; use next-selection-coding-system if not nil.
- (decode-coding-string
- cut-text next-coding))))))
-
;; As we have done one selection, clear this now.
(setq next-selection-coding-system nil)
;; At this point we have recorded the current values for the
- ;; selection from clipboard (if we are supposed to) primary,
- ;; and cut buffer. So return the first one that has changed
+ ;; selection from clipboard (if we are supposed to) and primary.
+ ;; So return the first one that has changed
;; (which is the first non-null one).
;;
;; NOTE: There will be cases where more than one of these has
;; changed and the new values differ. This indicates that
;; something like the following has happened since the last time
;; we looked at the selections: Application X set all the
- ;; selections, then Application Y set only one or two of them (say
- ;; just the cut-buffer). In this case since we don't have
+ ;; selections, then Application Y set only one of them.
+ ;; In this case since we don't have
;; timestamps there is no way to know what the 'correct' value to
;; return is. The nice thing to do would be to tell the user we
;; saw multiple possible selections and ask the user which was the
;; one they wanted.
- ;; This code is still a big improvement because now the user can
- ;; futz with the current selection and get emacs to pay attention
- ;; to the cut buffer again (previously as soon as clipboard or
- ;; primary had been set the cut buffer would essentially never be
- ;; checked again).
- (or clip-text primary-text cut-text)
+ (or clip-text primary-text)
)))
+(define-obsolete-function-alias 'x-cut-buffer-or-selection-value
+ 'x-selection-value "24.1")
+
;; Arrange for the kill and yank functions to set and check the clipboard.
(setq interprogram-cut-function 'x-select-text)
-(setq interprogram-paste-function 'x-cut-buffer-or-selection-value)
+(setq interprogram-paste-function 'x-selection-value)
+
+;; Make paste from other applications use the decoding in x-select-request-type
+;; and not just STRING.
+(defun x-get-selection-value ()
+ "Get the current value of the PRIMARY selection.
+Request data types in the order specified by `x-select-request-type'."
+ (x-selection-value-internal 'PRIMARY))
(defun x-clipboard-yank ()
"Insert the clipboard contents, or the last stretch of killed text."
(interactive "*")
- (let ((clipboard-text (x-selection-value 'CLIPBOARD))
+ (let ((clipboard-text (x-selection-value-internal 'CLIPBOARD))
(x-select-enable-clipboard t))
(if (and clipboard-text (> (length clipboard-text) 0))
(kill-new clipboard-text))
@@ -1473,9 +1346,6 @@ The value nil is the same as this list:
;; are the initial display.
(eq initial-window-system 'x))
- (setq x-cut-buffer-max (min (- (/ (x-server-max-request-size) 2) 100)
- x-cut-buffer-max))
-
;; Create the default fontset.
(create-default-fontset)
@@ -1560,12 +1430,12 @@ The value nil is the same as this list:
;; Enable CLIPBOARD copy/paste through menu bar commands.
(menu-bar-enable-clipboard)
- ;; Override Paste so it looks at CLIPBOARD first.
- (define-key menu-bar-edit-menu [paste]
- (append '(menu-item "Paste" x-clipboard-yank
- :enable (not buffer-read-only)
- :help "Paste (yank) text most recently cut/copied")
- nil))
+ ;; ;; Override Paste so it looks at CLIPBOARD first.
+ ;; (define-key menu-bar-edit-menu [paste]
+ ;; (append '(menu-item "Paste" x-clipboard-yank
+ ;; :enable (not buffer-read-only)
+ ;; :help "Paste (yank) text most recently cut/copied")
+ ;; nil))
(setq x-initialized t))
@@ -1705,5 +1575,4 @@ This uses `icon-map-list' to map icon file names to stock icon names."
(provide 'x-win)
-;; arch-tag: f1501302-db8b-4d95-88e3-116697d89f78
;;; x-win.el ends here
diff --git a/lisp/textmodes/artist.el b/lisp/textmodes/artist.el
index bca7eed00d2..549b3b3c52a 100644
--- a/lisp/textmodes/artist.el
+++ b/lisp/textmodes/artist.el
@@ -1,7 +1,7 @@
;;; artist.el --- draw ascii graphics with your mouse
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+;; 2009, 2010 Free Software Foundation, Inc.
;; Author: Tomas Abrahamsson <tab@lysator.liu.se>
;; Maintainer: Tomas Abrahamsson <tab@lysator.liu.se>
@@ -1957,24 +1957,11 @@ The replacement is used to convert tabs and new-lines to spaces."
(defun artist-replace-char (new-char)
"Replace the character at point with NEW-CHAR."
- ;; Check that the variable exists first. The doc says it was added in 19.23.
- (if (and (and (boundp 'emacs-major-version) (= emacs-major-version 20))
- (and (boundp 'emacs-minor-version) (<= emacs-minor-version 3)))
- ;; This is a bug workaround for Emacs 20, versions up to 20.3:
- ;; The self-insert-command doesn't care about the overwrite-mode,
- ;; so the insertion is done in the same way as in picture mode.
- ;; This seems to be a little bit slower.
- (progn
- (artist-move-to-xy (1+ (artist-current-column))
- (artist-current-line))
- (delete-char -1)
- (insert (artist-get-replacement-char new-char)))
- ;; In emacs-19, the self-insert-command works better and faster
- (let ((overwrite-mode 'overwrite-mode-textual)
- (fill-column 32765) ; Large :-)
- (blink-matching-paren nil))
- (setq last-command-event (artist-get-replacement-char new-char))
- (self-insert-command 1))))
+ (let ((overwrite-mode 'overwrite-mode-textual)
+ (fill-column 32765) ; Large :-)
+ (blink-matching-paren nil))
+ (setq last-command-event (artist-get-replacement-char new-char))
+ (self-insert-command 1)))
(defun artist-replace-chars (new-char count)
"Replace characters at point with NEW-CHAR. COUNT chars are replaced."
diff --git a/lisp/textmodes/bibtex-style.el b/lisp/textmodes/bibtex-style.el
index 688d6fe0bc1..3e84c37af9e 100644
--- a/lisp/textmodes/bibtex-style.el
+++ b/lisp/textmodes/bibtex-style.el
@@ -1,6 +1,7 @@
;;; bibtex-style.el --- Major mode for BibTeX Style files
-;; Copyright (C) 2005, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2005, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: tex
@@ -63,8 +64,6 @@
("\\<\\(FUNCTION\\|MACRO\\)\\s-+{\\([^}\n]+\\)}"
(2 font-lock-function-name-face))))
-;;;###autoload (add-to-list 'auto-mode-alist (cons (purecopy "\\.bst\\'") 'bibtex-style-mode))
-
;;;###autoload
(define-derived-mode bibtex-style-mode nil "BibStyle"
"Major mode for editing BibTeX style files."
diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el
index 682adbb5a25..75dd4f80153 100644
--- a/lisp/textmodes/bibtex.el
+++ b/lisp/textmodes/bibtex.el
@@ -2095,7 +2095,7 @@ Formats current entry according to variable `bibtex-entry-format'."
;; if match not at left subfield boundary...
(if (< (1+ (nth 1 bounds)) (match-beginning 0))
(insert (bibtex-field-right-delimiter) " # ")
- (delete-backward-char 1))))))))
+ (delete-char -1))))))))
;; use book title of crossref'd entry
(if (and (memq 'inherit-booktitle format)
@@ -3028,12 +3028,14 @@ if that value is non-nil.
;; brace-delimited ones
)
nil
- (font-lock-syntactic-keywords . bibtex-font-lock-syntactic-keywords)
(font-lock-extra-managed-props . (category))
(font-lock-mark-block-function
. (lambda ()
(set-mark (bibtex-end-of-entry))
(bibtex-beginning-of-entry)))))
+ (set (make-local-variable 'syntax-propertize-function)
+ (syntax-propertize-via-font-lock
+ bibtex-font-lock-syntactic-keywords))
(setq imenu-generic-expression
(list (list nil bibtex-entry-head bibtex-key-in-head))
imenu-case-fold-search t)
diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el
index 6e80b737284..759778eb025 100644
--- a/lisp/textmodes/css-mode.el
+++ b/lisp/textmodes/css-mode.el
@@ -212,6 +212,8 @@
(defconst css-nmchar-re (concat "\\(?:[-[:alnum:]]\\|" css-escapes-re "\\)"))
(defconst css-nmstart-re (concat "\\(?:[[:alpha:]]\\|" css-escapes-re "\\)"))
(defconst css-ident-re (concat css-nmstart-re css-nmchar-re "*"))
+(defconst css-proprietary-nmstart-re ;; Vendor-specific properties.
+ "[-_]\\(?:ms\\|moz\\|o\\|webkit\\|khtml\\)-")
(defconst css-name-re (concat css-nmchar-re "+"))
(defface css-selector '((t :inherit font-lock-function-name-face))
@@ -220,6 +222,8 @@
(defface css-property '((t :inherit font-lock-variable-name-face))
"Face to use for properties."
:group 'css)
+(defface css-proprietary-property '((t :inherit (css-property italic)))
+ "Face to use for vendor-specific properties.")
(defvar css-font-lock-keywords
`(("!\\s-*important" . font-lock-builtin-face)
@@ -251,13 +255,15 @@
;; No face.
nil)))
;; Properties. Again, we don't limit ourselves to css-property-ids.
- (,(concat "\\(?:[{;]\\|^\\)[ \t]*\\(" css-ident-re "\\)\\s-*:")
- (1 'css-property))))
+ (,(concat "\\(?:[{;]\\|^\\)[ \t]*\\("
+ "\\(?:\\(" css-proprietary-nmstart-re "\\)\\|"
+ css-nmstart-re "\\)" css-nmchar-re "*"
+ "\\)\\s-*:")
+ (1 (if (match-end 2) 'css-proprietary-property 'css-property)))))
(defvar css-font-lock-defaults
'(css-font-lock-keywords nil t))
-;;;###autoload (add-to-list 'auto-mode-alist (cons (purecopy "\\.css\\'") 'css-mode))
;;;###autoload
(define-derived-mode css-mode fundamental-mode "CSS"
"Major mode to edit Cascading Style Sheets."
diff --git a/lisp/textmodes/dns-mode.el b/lisp/textmodes/dns-mode.el
index bb9fedad206..ed84b5be914 100644
--- a/lisp/textmodes/dns-mode.el
+++ b/lisp/textmodes/dns-mode.el
@@ -28,11 +28,6 @@
;; C-c C-s Increment SOA serial.
;; Understands YYYYMMDDNN, Unix time, and serial number formats,
;; and complains if it fail to find SOA serial.
-;;
-;; Put something similar to the following in your ~/.emacs to use this file:
-;;
-;; (load "~/path/to/dns-mode.el")
-;; (setq auto-mode-alist (cons '("\\.soa\\'" . dns-mode) auto-mode-alist))
;;; References:
@@ -222,9 +217,6 @@ This function is run from `before-save-hook'."
;; We return nil in case this is used in write-contents-functions.
nil)))
-;;;###autoload(add-to-list 'auto-mode-alist (purecopy '("\\.soa\\'" . dns-mode)))
-
(provide 'dns-mode)
-;; arch-tag: 6a179f0a-072f-49db-8b01-37b8f23998c0
;;; dns-mode.el ends here
diff --git a/lisp/textmodes/enriched.el b/lisp/textmodes/enriched.el
index 64eb83f8178..c2711a7345c 100644
--- a/lisp/textmodes/enriched.el
+++ b/lisp/textmodes/enriched.el
@@ -1,7 +1,7 @@
;;; enriched.el --- read and save files in text/enriched format
-;; Copyright (C) 1994, 1995, 1996, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 1995, 1996, 2001, 2002, 2003, 2004, 2005, 2006,
+;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Boris Goldowsky <boris@gnu.org>
;; Keywords: wp, faces
@@ -50,7 +50,7 @@
:group 'wp)
(defcustom enriched-verbose t
- "*If non-nil, give status messages when reading and writing files."
+ "If non-nil, give status messages when reading and writing files."
:type 'boolean
:group 'enriched)
diff --git a/lisp/textmodes/fill.el b/lisp/textmodes/fill.el
index da6e02bfa2f..2dd7b1e2c95 100644
--- a/lisp/textmodes/fill.el
+++ b/lisp/textmodes/fill.el
@@ -1,10 +1,12 @@
;;; fill.el --- fill commands for Emacs -*- coding: utf-8 -*-
-;; Copyright (C) 1985, 1986, 1992, 1994, 1995, 1996, 1997, 1999, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1986, 1992, 1994, 1995, 1996, 1997, 1999, 2001,
+;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: wp
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -136,7 +138,7 @@ The fill column to use for a line is the first column at which the column
number equals or exceeds the local fill-column - right-margin difference."
(save-excursion
(if fill-column
- (let* ((here (progn (beginning-of-line) (point)))
+ (let* ((here (line-beginning-position))
(here-col 0)
(eol (progn (end-of-line) (point)))
margin fill-col change col)
@@ -657,7 +659,7 @@ space does not end a sentence, so don't break a line there."
(if (and oneleft
(not (and use-hard-newlines
(get-text-property (1- (point)) 'hard))))
- (delete-backward-char 1)
+ (delete-char -1)
(backward-char 1)
(setq oneleft t)))
(setq to (copy-marker (point) t))
@@ -1289,18 +1291,16 @@ otherwise it is made canonical."
(skip-chars-backward " "))
(setq ncols (- fc endcol))
;; Ncols is number of additional space chars needed
- (if (and (> ncols 0) (> nspaces 0) (not eop))
- (progn
- (setq curr-fracspace (+ ncols (/ (1+ nspaces) 2))
- count nspaces)
- (while (> count 0)
- (skip-chars-forward " ")
- (insert-and-inherit
- (make-string (/ curr-fracspace nspaces) ?\s))
- (search-forward " " nil t)
- (setq count (1- count)
- curr-fracspace
- (+ (% curr-fracspace nspaces) ncols)))))))
+ (when (and (> ncols 0) (> nspaces 0) (not eop))
+ (setq curr-fracspace (+ ncols (/ nspaces 2))
+ count nspaces)
+ (while (> count 0)
+ (skip-chars-forward " ")
+ (insert-char ?\s (/ curr-fracspace nspaces) t)
+ (search-forward " " nil t)
+ (setq count (1- count)
+ curr-fracspace
+ (+ (% curr-fracspace nspaces) ncols))))))
(t (error "Unknown justification value"))))
(goto-char pos)
(move-marker pos nil)))
@@ -1518,5 +1518,4 @@ Also, if CITATION-REGEXP is non-nil, don't fill header lines."
"")
string))
-;; arch-tag: 727ad455-1161-4fa9-8df5-0f74b179216d
;;; fill.el ends here
diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el
index e5727f41e93..5dbcb2d7d77 100644
--- a/lisp/textmodes/flyspell.el
+++ b/lisp/textmodes/flyspell.el
@@ -199,9 +199,9 @@ Ispell's ultimate default dictionary."
(defcustom flyspell-check-tex-math-command nil
"Non-nil means check even inside TeX math environment.
-TeX math environments are discovered by the TEXMATHP that implemented
-inside the texmathp.el Emacs package. That package may be found at:
-http://strw.leidenuniv.nl/~dominik/Tools"
+TeX math environments are discovered by `texmathp', implemented
+inside AUCTeX package. That package may be found at
+URL `http://www.gnu.org/software/auctex/'"
:group 'flyspell
:type 'boolean)
@@ -380,7 +380,8 @@ like <img alt=\"Some thing.\">."
(defun flyspell-generic-progmode-verify ()
"Used for `flyspell-generic-check-word-predicate' in programming modes."
- (let ((f (get-text-property (point) 'face)))
+ ;; (point) is next char after the word. Must check one char before.
+ (let ((f (get-text-property (- (point) 1) 'face)))
(memq f flyspell-prog-text-faces)))
;;;###autoload
@@ -494,9 +495,9 @@ in your .emacs file.
:keymap flyspell-mode-map
:group 'flyspell
(if flyspell-mode
- (condition-case ()
+ (condition-case err
(flyspell-mode-on)
- (error (message "Enabling Flyspell mode gave an error")
+ (error (message "Error enabling Flyspell mode:\n%s" (cdr err))
(flyspell-mode -1)))
(flyspell-mode-off)))
@@ -1013,11 +1014,13 @@ Mostly we check word delimiters."
;;*---------------------------------------------------------------------*/
;;* flyspell-word ... */
;;*---------------------------------------------------------------------*/
-(defun flyspell-word (&optional following)
+(defun flyspell-word (&optional following known-misspelling)
"Spell check a word.
If the optional argument FOLLOWING, or, when called interactively
`ispell-following-word', is non-nil, checks the following (rather
-than preceding) word when the cursor is not over a word."
+than preceding) word when the cursor is not over a word. If
+optional argument KNOWN-MISSPELLING is non nil considers word a
+misspelling and skips redundant spell-checking step."
(interactive (list ispell-following-word))
(ispell-set-spellchecker-params) ; Initialize variables and dicts alists
(save-excursion
@@ -1078,29 +1081,35 @@ than preceding) word when the cursor is not over a word."
(setq flyspell-word-cache-end end)
(setq flyspell-word-cache-word word)
;; now check spelling of word.
- (ispell-send-string "%\n")
- ;; put in verbose mode
- (ispell-send-string (concat "^" word "\n"))
- ;; we mark the ispell process so it can be killed
- ;; when emacs is exited without query
- (set-process-query-on-exit-flag ispell-process nil)
- ;; Wait until ispell has processed word. Since this code is often
- ;; executed from post-command-hook but the ispell process may not
- ;; be responsive, it's important to make sure we re-enable C-g.
- (with-local-quit
- (while (progn
- (accept-process-output ispell-process)
- (not (string= "" (car ispell-filter))))))
- ;; (ispell-send-string "!\n")
- ;; back to terse mode.
- ;; Remove leading empty element
- (setq ispell-filter (cdr ispell-filter))
- ;; ispell process should return something after word is sent.
- ;; Tag word as valid (i.e., skip) otherwise
- (or ispell-filter
- (setq ispell-filter '(*)))
- (if (consp ispell-filter)
- (setq poss (ispell-parse-output (car ispell-filter))))
+ (if (not known-misspelling)
+ (progn
+ (ispell-send-string "%\n")
+ ;; put in verbose mode
+ (ispell-send-string (concat "^" word "\n"))
+ ;; we mark the ispell process so it can be killed
+ ;; when emacs is exited without query
+ (set-process-query-on-exit-flag ispell-process nil)
+ ;; Wait until ispell has processed word. Since this
+ ;; code is often executed from post-command-hook but
+ ;; the ispell process may not be responsive, it's
+ ;; important to make sure we re-enable C-g.
+ (with-local-quit
+ (while (progn
+ (accept-process-output ispell-process)
+ (not (string= "" (car ispell-filter))))))
+ ;; (ispell-send-string "!\n")
+ ;; back to terse mode.
+ ;; Remove leading empty element
+ (setq ispell-filter (cdr ispell-filter))
+ ;; ispell process should return something after word is sent.
+ ;; Tag word as valid (i.e., skip) otherwise
+ (or ispell-filter
+ (setq ispell-filter '(*)))
+ (if (consp ispell-filter)
+ (setq poss (ispell-parse-output (car ispell-filter)))))
+ ;; Else, this was a known misspelling to begin with, and
+ ;; we should forge an ispell return value.
+ (setq poss (list word 0 '() '())))
(let ((res (cond ((eq poss t)
;; correct
(setq flyspell-word-cache-result t)
@@ -1433,7 +1442,7 @@ The buffer to mark them in is `flyspell-large-region-buffer'."
t
nil))))
(setq keep nil)
- (flyspell-word)
+ (flyspell-word nil t)
;; Search for next misspelled word will begin from
;; end of last validated match.
(setq buffer-scan-pos (point))))
@@ -1465,7 +1474,7 @@ The buffer to mark them in is `flyspell-large-region-buffer'."
(goto-char (point-min))
;; Localwords parsing copied from ispell.el.
(while (search-forward ispell-words-keyword nil t)
- (let ((end (save-excursion (end-of-line) (point)))
+ (let ((end (point-at-eol))
string)
;; buffer-local words separated by a space, and can contain
;; any character other than a space. Not rigorous enough.
@@ -1817,7 +1826,9 @@ misspelled words backwards."
(throw 'exit t)))))))
(save-excursion
(goto-char pos)
- (ispell-word))
+ (ispell-word)
+ (setq flyspell-word-cache-word nil) ;; Force flyspell-word re-check
+ (flyspell-word))
(error "No word to correct before point"))))
;;*---------------------------------------------------------------------*/
@@ -2352,5 +2363,4 @@ This function is meant to be added to `flyspell-incorrect-hook'."
(provide 'flyspell)
-;; arch-tag: 05d915b9-e9cf-44fb-9137-fc28f5eaab2a
;;; flyspell.el ends here
diff --git a/lisp/textmodes/ispell.el b/lisp/textmodes/ispell.el
index 81b87cd5641..9a494897b74 100644
--- a/lisp/textmodes/ispell.el
+++ b/lisp/textmodes/ispell.el
@@ -1,7 +1,8 @@
;;; ispell.el --- interface to International Ispell Versions 3.1 and 3.2
;; Copyright (C) 1994, 1995, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Ken Stevens <k.stevens@ieee.org>
;; Maintainer: Ken Stevens <k.stevens@ieee.org>
@@ -221,10 +222,10 @@ compatibility function in case `version<=' is not available."
(let (ver mver)
(if (string-match "[0-9]+" version start-ver)
(setq start-ver (match-end 0)
- ver (string-to-number (substring version (match-beginning 0) (match-end 0)))))
+ ver (string-to-number (match-string 0 version))))
(if (string-match "[0-9]+" minver start-mver)
(setq start-mver (match-end 0)
- mver (string-to-number (substring minver (match-beginning 0) (match-end 0)))))
+ mver (string-to-number (match-string 0 minver))))
(if (or ver mver)
(progn
@@ -310,7 +311,9 @@ Warning! Not checking comments, when a comment start is embedded in strings,
may produce undesired results."
:type '(choice (const exclusive) (const :tag "off" nil) (const :tag "on" t))
:group 'ispell)
-;;;###autoload(put 'ispell-check-comments 'safe-local-variable (lambda (a) (memq a '(nil t exclusive))))
+;;;###autoload
+(put 'ispell-check-comments 'safe-local-variable
+ (lambda (a) (memq a '(nil t exclusive))))
(defcustom ispell-query-replace-choices nil
"*Corrections made throughout region when non-nil.
@@ -357,21 +360,21 @@ Must be greater than 1."
:group 'ispell)
(defcustom ispell-alternate-dictionary
- (cond ((file-exists-p "/usr/dict/web2") "/usr/dict/web2")
- ((file-exists-p "/usr/share/dict/web2") "/usr/share/dict/web2")
- ((file-exists-p "/usr/dict/words") "/usr/dict/words")
- ((file-exists-p "/usr/lib/dict/words") "/usr/lib/dict/words")
- ((file-exists-p "/usr/share/dict/words") "/usr/share/dict/words")
- ((file-exists-p "/usr/share/lib/dict/words")
+ (cond ((file-readable-p "/usr/dict/web2") "/usr/dict/web2")
+ ((file-readable-p "/usr/share/dict/web2") "/usr/share/dict/web2")
+ ((file-readable-p "/usr/dict/words") "/usr/dict/words")
+ ((file-readable-p "/usr/lib/dict/words") "/usr/lib/dict/words")
+ ((file-readable-p "/usr/share/dict/words") "/usr/share/dict/words")
+ ((file-readable-p "/usr/share/lib/dict/words")
"/usr/share/lib/dict/words")
- ((file-exists-p "/sys/dict") "/sys/dict")
- (t "/usr/dict/words"))
- "*Alternate dictionary for spelling help."
+ ((file-readable-p "/sys/dict") "/sys/dict"))
+ "*Alternate plain word-list dictionary for spelling help."
:type '(choice file (const :tag "None" nil))
:group 'ispell)
-(defcustom ispell-complete-word-dict ispell-alternate-dictionary
- "*Dictionary used for word completion."
+(defcustom ispell-complete-word-dict nil
+ "*Plain word-list dictionary used for word completion if
+different from `ispell-alternate-dictionary'."
:type '(choice file (const :tag "None" nil))
:group 'ispell)
@@ -514,7 +517,8 @@ is automatically set when defined in the file with either
:type '(choice string
(const :tag "default" nil))
:group 'ispell)
-;;;###autoload(put 'ispell-local-dictionary 'safe-local-variable 'string-or-null-p)
+;;;###autoload
+(put 'ispell-local-dictionary 'safe-local-variable 'string-or-null-p)
(make-variable-buffer-local 'ispell-local-dictionary)
@@ -660,8 +664,8 @@ re-start Emacs."
"[^A-Za-z\241\243\246\254\257\261\263\266\274\277\306\312\321\323\346\352\361\363]"
"[.]" nil nil nil iso-8859-2)
("portugues" ; Portuguese mode
- "[a-zA-Z\301\302\311\323\340\341\342\351\352\355\363\343\372]"
- "[^a-zA-Z\301\302\311\323\340\341\342\351\352\355\363\343\372]"
+ "[a-zA-Z\301\302\307\311\323\340\341\342\351\352\355\363\343\347\372]"
+ "[^a-zA-Z\301\302\307\311\323\340\341\342\351\352\355\363\343\347\372]"
"[']" t ("-C") "~latin1" iso-8859-1)
("russian" ; Russian.aff (KOI8-R charset)
"[\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]"
@@ -738,8 +742,8 @@ Note that the CASECHARS and OTHERCHARS slots of the alist should
contain the same character set as casechars and otherchars in the
LANGUAGE.aff file \(e.g., english.aff\).")
-(defvar ispell-really-aspell nil) ; Non-nil if aspell extensions should be used
-(defvar ispell-really-hunspell nil) ; Non-nil if hunspell extensions should be used
+(defvar ispell-really-aspell nil) ; Non-nil if we can use aspell extensions.
+(defvar ispell-really-hunspell nil) ; Non-nil if we can use hunspell extensions.
(defvar ispell-encoding8-command nil
"Command line option prefix to select UTF-8 if supported, nil otherwise.
If UTF-8 if supported by spellchecker and is selectable from the command line
@@ -767,8 +771,8 @@ here just for backwards compatibility.")
-;;; The version must be 3.1 or greater for this version of ispell.el
-;;; There is an incompatibility between version 3.1.12 and lower versions.
+;; The version must be 3.1 or greater for this version of ispell.el
+;; There is an incompatibility between version 3.1.12 and lower versions.
(defconst ispell-required-version '(3 1 12)
"Ispell versions with which this version of ispell.el is known to work.")
(defvar ispell-offset -1
@@ -962,7 +966,8 @@ Internal use.")
(setq found (nconc found (list dict)))))
(setq ispell-aspell-dictionary-alist found)
;; Add a default entry
- (let ((default-dict '(nil "[[:alpha:]]" "[^[:alpha:]]" "[']" nil ("-B") nil utf-8)))
+ (let ((default-dict
+ '(nil "[[:alpha:]]" "[^[:alpha:]]" "[']" nil ("-B") nil utf-8)))
(push default-dict ispell-aspell-dictionary-alist))))
(defvar ispell-aspell-data-dir nil
@@ -979,19 +984,32 @@ Assumes that value contains no whitespace."
(car (split-string (buffer-string)))))
(defun ispell-aspell-find-dictionary (dict-name)
- ;; This returns nil if the data file does not exist.
- ;; Can someone please explain the return value format when the
- ;; file does exist -- rms?
- (let* ((lang ;; Strip out region, variant, etc.
- (and (string-match "^[[:alpha:]]+" dict-name)
- (match-string 0 dict-name)))
+ "For aspell dictionary DICT-NAME, return a list of parameters if an
+ associated data file is found or nil otherwise. List format is
+ that of `ispell-dictionary-base-alist' elements."
+ ;; Make sure `ispell-aspell-data-dir' is defined
+ (or ispell-aspell-data-dir
+ (setq ispell-aspell-data-dir
+ (ispell-get-aspell-config-value "data-dir")))
+ ;; Try finding associated datafile
+ (let* ((datafile1
+ (concat ispell-aspell-data-dir "/"
+ ;; Strip out variant, country code, etc.
+ (and (string-match "^[[:alpha:]]+" dict-name)
+ (match-string 0 dict-name)) ".dat"))
+ (datafile2
+ (concat ispell-aspell-data-dir "/"
+ ;; Strip out anything but xx_YY.
+ (and (string-match "^[[:alpha:]_]+" dict-name)
+ (match-string 0 dict-name)) ".dat"))
(data-file
- (concat (or ispell-aspell-data-dir
- (setq ispell-aspell-data-dir
- (ispell-get-aspell-config-value "data-dir")))
- "/" lang ".dat"))
+ (if (file-readable-p datafile1)
+ datafile1
+ (if (file-readable-p datafile2)
+ datafile2)))
otherchars)
- (condition-case ()
+
+ (if data-file
(with-temp-buffer
(insert-file-contents data-file)
;; There is zero or one line with special characters declarations.
@@ -1019,14 +1037,13 @@ Assumes that value contains no whitespace."
;; Here we specify the encoding to use while communicating with
;; aspell. This doesn't apply to command line arguments, so
;; just don't pass words to spellcheck as arguments...
- 'utf-8))
- (file-error
- nil))))
+ 'utf-8)))))
(defun ispell-aspell-add-aliases (alist)
"Find aspell's dictionary aliases and add them to dictionary ALIST.
Return the new dictionary alist."
- (let ((aliases (file-expand-wildcards
+ (let ((aliases
+ (file-expand-wildcards
(concat (or ispell-aspell-dict-dir
(setq ispell-aspell-dict-dir
(ispell-get-aspell-config-value "dict-dir")))
@@ -1101,7 +1118,7 @@ aspell is used along with Emacs).")
(defun ispell-valid-dictionary-list ()
- "Returns a list of valid dictionaries.
+ "Return a list of valid dictionaries.
The variable `ispell-library-directory' defines the library location."
;; Initialize variables and dictionaries alists for desired spellchecker.
;; Make sure ispell.el is loaded to avoid some autoload loops in XEmacs
@@ -1111,26 +1128,24 @@ The variable `ispell-library-directory' defines the library location."
(let ((dicts (append ispell-local-dictionary-alist ispell-dictionary-alist))
(dict-list (cons "default" nil))
- name load-dict)
+ name dict-bname)
(dolist (dict dicts)
(setq name (car dict)
- load-dict (car (cdr (member "-d" (nth 5 dict)))))
+ dict-bname (or (car (cdr (member "-d" (nth 5 dict))))
+ name))
;; Include if the dictionary is in the library, or dir not defined.
(if (and
name
- ;; include all dictionaries if lib directory not known.
;; For Aspell, we already know which dictionaries exist.
(or ispell-really-aspell
+ ;; Include all dictionaries if lib directory not known.
+ ;; Same for Hunspell, where ispell-library-directory is nil.
(not ispell-library-directory)
(file-exists-p (concat ispell-library-directory
- "/" name ".hash"))
- (file-exists-p (concat ispell-library-directory "/" name ".has"))
- (and load-dict
- (or (file-exists-p (concat ispell-library-directory
- "/" load-dict ".hash"))
- (file-exists-p (concat ispell-library-directory
- "/" load-dict ".has"))))))
- (setq dict-list (cons name dict-list))))
+ "/" dict-bname ".hash"))
+ (file-exists-p (concat ispell-library-directory
+ "/" dict-bname ".has"))))
+ (push name dict-list)))
dict-list))
;;; define commands in menu in opposite order you want them to appear.
@@ -1168,7 +1183,8 @@ The variable `ispell-library-directory' defines the library location."
`(menu-item ,(purecopy "Complete Word") ispell-complete-word
:help ,(purecopy "Complete word at cursor using dictionary")))
(define-key ispell-menu-map [ispell-complete-word-interior-frag]
- `(menu-item ,(purecopy "Complete Word Fragment") ispell-complete-word-interior-frag
+ `(menu-item ,(purecopy "Complete Word Fragment")
+ ispell-complete-word-interior-frag
:help ,(purecopy "Complete word fragment at cursor")))))
;;;###autoload
@@ -1185,7 +1201,8 @@ The variable `ispell-library-directory' defines the library location."
`(menu-item ,(purecopy "Spell-Check Word") ispell-word
:help ,(purecopy "Spell-check word at cursor")))
(define-key ispell-menu-map [ispell-comments-and-strings]
- `(menu-item ,(purecopy "Spell-Check Comments") ispell-comments-and-strings
+ `(menu-item ,(purecopy "Spell-Check Comments")
+ ispell-comments-and-strings
:help ,(purecopy "Spell-check only comments and strings")))))
;;;###autoload
@@ -1264,9 +1281,6 @@ The variable `ispell-library-directory' defines the library location."
;;; **********************************************************************
-
-;;; This variable contains the current dictionary being used if the ispell
-;;; process is running.
(defvar ispell-current-dictionary nil
"The name of the current dictionary, or nil for the default.
This is passed to the ispell process using the `-d' switch and is
@@ -1291,6 +1305,7 @@ Protects against bogus binding of `enable-multibyte-characters' in XEmacs."
;; Return a string decoded from Nth element of the current dictionary.
(defun ispell-get-decoded-string (n)
+ "Get the decoded string in slot N of the descriptor of the current dict."
(let* ((slot (or
(assoc ispell-current-dictionary ispell-local-dictionary-alist)
(assoc ispell-current-dictionary ispell-dictionary-alist)
@@ -1397,7 +1412,8 @@ The last occurring definition in the buffer will be used.")
(ispell-dictionary-keyword forward-line)
(ispell-pdict-keyword forward-line)
(ispell-parsing-keyword forward-line)
- (,(purecopy "^---*BEGIN PGP [A-Z ]*--*") . ,(purecopy "^---*END PGP [A-Z ]*--*"))
+ (,(purecopy "^---*BEGIN PGP [A-Z ]*--*")
+ . ,(purecopy "^---*END PGP [A-Z ]*--*"))
;; assume multiline uuencoded file? "\nM.*$"?
(,(purecopy "^begin [0-9][0-9][0-9] [^ \t]+$") . ,(purecopy "\nend\n"))
(,(purecopy "^%!PS-Adobe-[123].0") . ,(purecopy "\n%%EOF\n"))
@@ -1877,9 +1893,10 @@ Global `ispell-quit' set to start location to continue spell session."
;; setup the *Choices* buffer with valid data.
(with-current-buffer (get-buffer-create ispell-choices-buffer)
(setq mode-line-format
- (concat "-- %b -- word: " word
- " -- dict: " (or ispell-current-dictionary "default")
- " -- prog: " (file-name-nondirectory ispell-program-name)))
+ (concat
+ "-- %b -- word: " word
+ " -- dict: " (or ispell-current-dictionary "default")
+ " -- prog: " (file-name-nondirectory ispell-program-name)))
;; XEmacs: no need for horizontal scrollbar in choices window
(with-no-warnings
(and (fboundp 'set-specifier)
@@ -2046,10 +2063,11 @@ Global `ispell-quit' set to start location to continue spell session."
(erase-buffer)
(setq count ?0
skipped 0
- mode-line-format
+ mode-line-format ;; setup the *Choices* buffer with valid data.
(concat "-- %b -- word: " new-word
- " -- dict: "
- ispell-alternate-dictionary)
+ " -- word-list: "
+ (or ispell-complete-word-dict
+ ispell-alternate-dictionary))
miss (lookup-words new-word)
choices miss
line ispell-choices-win-default-height)
@@ -2143,7 +2161,7 @@ Global `ispell-quit' set to start location to continue spell session."
(if (and ispell-use-framepop-p (fboundp 'framepop-display-buffer))
(progn
(framepop-display-buffer (get-buffer ispell-choices-buffer))
-;;; (get-buffer-window ispell-choices-buffer t)
+ ;; (get-buffer-window ispell-choices-buffer t)
(select-window (previous-window))) ; *Choices* window
;; standard selection by splitting a small buffer out of this window.
(let ((choices-window (get-buffer-window ispell-choices-buffer)))
@@ -2264,11 +2282,21 @@ Otherwise the variable `ispell-grep-command' contains the command used to
search for the words (usually egrep).
Optional second argument contains the dictionary to use; the default is
-`ispell-alternate-dictionary'."
+`ispell-alternate-dictionary', overriden by `ispell-complete-word-dict'
+if defined."
;; We don't use the filter for this function, rather the result is written
;; into a buffer. Hence there is no need to save the filter values.
(if (null lookup-dict)
- (setq lookup-dict ispell-alternate-dictionary))
+ (setq lookup-dict (or ispell-complete-word-dict
+ ispell-alternate-dictionary)))
+
+ (if lookup-dict
+ (unless (file-readable-p lookup-dict)
+ (error "lookup-words error: Unreadable or missing plain word-list %s."
+ lookup-dict))
+ (error (concat "lookup-words error: No plain word-list found at system"
+ "default locations. "
+ "Customize `ispell-alternate-dictionary' to set yours.")))
(let* ((process-connection-type ispell-use-ptys-p)
(wild-p (string-match "\\*" word))
@@ -2319,16 +2347,16 @@ Optional second argument contains the dictionary to use; the default is
results))
-;;; "ispell-filter" is a list of output lines from the generating function.
-;;; Each full line (ending with \n) is a separate item on the list.
-;;; "output" can contain multiple lines, part of a line, or both.
-;;; "start" and "end" are used to keep bounds on lines when "output" contains
-;;; multiple lines.
-;;; "ispell-filter-continue" is true when we have received only part of a
-;;; line as output from a generating function ("output" did not end with \n)
-;;; THIS FUNCTION WILL FAIL IF THE PROCESS OUTPUT DOESN'T END WITH \n!
-;;; This is the case when a process dies or fails. The default behavior
-;;; in this case treats the next input received as fresh input.
+;; "ispell-filter" is a list of output lines from the generating function.
+;; Each full line (ending with \n) is a separate item on the list.
+;; "output" can contain multiple lines, part of a line, or both.
+;; "start" and "end" are used to keep bounds on lines when "output" contains
+;; multiple lines.
+;; "ispell-filter-continue" is true when we have received only part of a
+;; line as output from a generating function ("output" did not end with \n)
+;; THIS FUNCTION WILL FAIL IF THE PROCESS OUTPUT DOESN'T END WITH \n!
+;; This is the case when a process dies or fails. The default behavior
+;; in this case treats the next input received as fresh input.
(defun ispell-filter (process output)
"Output filter function for ispell, grep, and look."
@@ -2528,18 +2556,18 @@ Optional third arg SHIFT is an offset to apply based on previous corrections."
(setq count (string-to-number output) ; get number of misses.
output (substring output (1+ (string-match " " output 1)))))
(setq offset (string-to-number output))
- (if (eq type ?#) ; No miss or guess list.
- (setq output nil)
- (setq output (substring output (1+ (string-match " " output 1)))))
+ (setq output (if (eq type ?#) ; No miss or guess list.
+ nil
+ (substring output (1+ (string-match " " output 1)))))
(while output
(let ((end (string-match ", \\|\\($\\)" output))) ; end of miss/guess.
(setq cur-count (1+ cur-count))
(if (> cur-count count)
- (setq guess-list (cons (substring output 0 end) guess-list))
- (setq miss-list (cons (substring output 0 end) miss-list)))
- (if (match-end 1) ; True only when at end of line.
- (setq output nil) ; no more misses or guesses
- (setq output (substring output (+ end 2))))))
+ (push (substring output 0 end) guess-list)
+ (push (substring output 0 end) miss-list))
+ (setq output (if (match-end 1) ; True only when at end of line.
+ nil ; No more misses or guesses.
+ (substring output (+ end 2))))))
;; return results. Accept word if it was already accepted.
;; adjust offset.
(if (member original-word accept-list)
@@ -2560,37 +2588,35 @@ When asynchronous processes are not supported, `run' is always returned."
(defun ispell-start-process ()
"Start the ispell process, with support for no asynchronous processes.
Keeps argument list for future ispell invocations for no async support."
- (let ((default-directory default-directory)
- args)
- (unless (and (file-directory-p default-directory)
- (file-readable-p default-directory))
- ;; Defend against bad `default-directory'.
- (setq default-directory (expand-file-name "~/")))
- ;; Local dictionary becomes the global dictionary in use.
- (setq ispell-current-dictionary
- (or ispell-local-dictionary ispell-dictionary))
- (setq ispell-current-personal-dictionary
- (or ispell-local-pdict ispell-personal-dictionary))
- (setq args (ispell-get-ispell-args))
- (if (and ispell-current-dictionary ; use specified dictionary
- (not (member "-d" args))) ; only define if not overridden
- (setq args
- (append (list "-d" ispell-current-dictionary) args)))
- (if ispell-current-personal-dictionary ; use specified pers dict
- (setq args
- (append args
- (list "-p"
- (expand-file-name ispell-current-personal-dictionary)))))
-
- ;; If we are using recent aspell or hunspell, make sure we use the right encoding
- ;; for communication. ispell or older aspell/hunspell does not support this
- (if ispell-encoding8-command
- (setq args
- (append args
- (list
- (concat ispell-encoding8-command
- (symbol-name (ispell-get-coding-system)))))))
- (setq args (append args ispell-extra-args))
+ ;; Local dictionary becomes the global dictionary in use.
+ (setq ispell-current-dictionary
+ (or ispell-local-dictionary ispell-dictionary))
+ (setq ispell-current-personal-dictionary
+ (or ispell-local-pdict ispell-personal-dictionary))
+ (let* ((default-directory
+ (if (and (file-directory-p default-directory)
+ (file-readable-p default-directory))
+ default-directory
+ ;; Defend against bad `default-directory'.
+ (expand-file-name "~/")))
+ (orig-args (ispell-get-ispell-args))
+ (args
+ (append
+ (if (and ispell-current-dictionary ; Not for default dict (nil)
+ (not (member "-d" orig-args))) ; Only define if not overridden.
+ (list "-d" ispell-current-dictionary))
+ orig-args
+ (if ispell-current-personal-dictionary ; Use specified pers dict.
+ (list "-p"
+ (expand-file-name ispell-current-personal-dictionary)))
+ ;; If we are using recent aspell or hunspell, make sure we use the
+ ;; right encoding for communication. ispell or older aspell/hunspell
+ ;; does not support this.
+ (if ispell-encoding8-command
+ (list
+ (concat ispell-encoding8-command
+ (symbol-name (ispell-get-coding-system)))))
+ ispell-extra-args)))
;; Initially we don't know any buffer's local words.
(setq ispell-buffer-local-name nil)
@@ -2599,9 +2625,11 @@ Keeps argument list for future ispell invocations for no async support."
(let ((process-connection-type ispell-use-ptys-p))
(apply 'start-process
"ispell" nil ispell-program-name
- "-a" ; accept single input lines
- (if ispell-really-hunspell "" "-m") ; make root/affix combos not in dict
- args)) ; hunspell -m option means different
+ "-a" ; Accept single input lines.
+ ;; Make root/affix combos not in dict.
+ ;; hunspell -m option means different.
+ (if ispell-really-hunspell "" "-m")
+ args))
(setq ispell-cmd-args args
ispell-output-buffer (generate-new-buffer " *ispell-output*")
ispell-session-buffer (generate-new-buffer " *ispell-session*"))
@@ -2609,65 +2637,114 @@ Keeps argument list for future ispell invocations for no async support."
t)))
-
(defun ispell-init-process ()
"Check status of Ispell process and start if necessary."
- (if (and ispell-process
- (eq (ispell-process-status) 'run)
- ;; If we're using a personal dictionary, ensure
- ;; we're in the same default directory!
- (or (not ispell-personal-dictionary)
- (equal ispell-process-directory default-directory)))
- (setq ispell-filter nil ispell-filter-continue nil)
- ;; may need to restart to select new personal dictionary.
- (ispell-kill-ispell t)
- (message "Starting new Ispell process [%s] ..."
- (or ispell-local-dictionary ispell-dictionary "default"))
- (sit-for 0)
- (setq ispell-library-directory (ispell-check-version)
- ispell-process-directory default-directory
- ispell-process (ispell-start-process)
- ispell-filter nil
- ispell-filter-continue nil)
- (if ispell-async-processp
- (set-process-filter ispell-process 'ispell-filter))
- ;; protect against bogus binding of `enable-multibyte-characters' in XEmacs
- (if (and (or (featurep 'xemacs)
- (and (boundp 'enable-multibyte-characters)
- enable-multibyte-characters))
- (fboundp 'set-process-coding-system))
- (set-process-coding-system ispell-process (ispell-get-coding-system)
- (ispell-get-coding-system)))
- ;; Get version ID line
- (ispell-accept-output 3)
- ;; get more output if filter empty?
- (if (null ispell-filter) (ispell-accept-output 3))
- (cond ((null ispell-filter)
- (error "%s did not output version line" ispell-program-name))
- ((and
- (stringp (car ispell-filter))
- (if (string-match "warning: " (car ispell-filter))
- (progn
- (ispell-accept-output 3) ; was warn msg.
- (stringp (car ispell-filter)))
- (null (cdr ispell-filter)))
- (string-match "^@(#) " (car ispell-filter)))
- ;; got the version line as expected (we already know it's the right
- ;; version, so don't bother checking again.)
- nil)
- (t
- ;; Otherwise, it must be an error message. Show the user.
- ;; But first wait to see if some more output is going to arrive.
- ;; Otherwise we get cool errors like "Can't open ".
- (sleep-for 1)
- (ispell-accept-output 3)
- (error "%s" (mapconcat 'identity ispell-filter "\n"))))
- (setq ispell-filter nil) ; Discard version ID line
- (let ((extended-char-mode (ispell-get-extended-character-mode)))
- (if extended-char-mode ; ~ extended character mode
- (ispell-send-string (concat extended-char-mode "\n"))))
- (if ispell-async-processp
- (set-process-query-on-exit-flag ispell-process nil))))
+ (let* (;; Basename of dictionary used by the spell-checker
+ (dict-bname (or (car (cdr (member "-d" (ispell-get-ispell-args))))
+ ispell-current-dictionary))
+ ;; Use "~/" as default-directory unless using Ispell with per-dir
+ ;; personal dictionaries and not in a minibuffer under XEmacs
+ (default-directory
+ (if (or ispell-really-aspell
+ ispell-really-hunspell
+ ;; Protect against bad default-directory
+ (not (and (file-directory-p default-directory)
+ (file-readable-p default-directory)))
+ ;; Ispell and per-dir personal dicts available
+ (not (or (file-readable-p (concat default-directory
+ ".ispell_words"))
+ (file-readable-p (concat default-directory
+ ".ispell_"
+ (or dict-bname
+ "default")))))
+ ;; Ispell, in a minibuffer, and XEmacs
+ (and (window-minibuffer-p)
+ (not (fboundp 'minibuffer-selected-window))))
+ (expand-file-name "~/")
+ (expand-file-name default-directory))))
+ ;; Check if process needs restart
+ (if (and ispell-process
+ (eq (ispell-process-status) 'run)
+ ;; Unless we are using an explicit personal dictionary, ensure
+ ;; we're in the same default directory! Restart check for
+ ;; personal dictionary is done in
+ ;; `ispell-internal-change-dictionary', called from
+ ;; `ispell-buffer-local-dict'
+ (or (or ispell-local-pdict ispell-personal-dictionary)
+ (equal ispell-process-directory default-directory)))
+ (setq ispell-filter nil ispell-filter-continue nil)
+ ;; may need to restart to select new personal dictionary.
+ (ispell-kill-ispell t)
+ (message "Starting new Ispell process [%s] ..."
+ (or ispell-local-dictionary ispell-dictionary "default"))
+ (sit-for 0)
+ (setq ispell-library-directory (ispell-check-version)
+ ispell-process (ispell-start-process)
+ ispell-filter nil
+ ispell-filter-continue nil
+ ispell-process-directory default-directory)
+
+ (unless (equal ispell-process-directory (expand-file-name "~/"))
+ ;; At this point, `ispell-process-directory' will be "~/" unless using
+ ;; Ispell with directory-specific dicts and not in XEmacs minibuffer.
+ ;; If not, kill ispell process when killing buffer. It may be in a
+ ;; removable device that would otherwise become un-mountable.
+ (with-current-buffer
+ (if (and (window-minibuffer-p) ;; In minibuffer
+ (fboundp 'minibuffer-selected-window)) ;; Not XEmacs.
+ ;; In this case kill ispell only when parent buffer is killed
+ ;; to avoid over and over ispell kill.
+ (window-buffer (minibuffer-selected-window))
+ (current-buffer))
+ ;; 'local does not automatically make hook buffer-local in XEmacs.
+ (if (featurep 'xemacs)
+ (make-local-hook 'kill-buffer-hook))
+ (add-hook 'kill-buffer-hook
+ (lambda () (ispell-kill-ispell t)) nil 'local)))
+
+ (if ispell-async-processp
+ (set-process-filter ispell-process 'ispell-filter))
+ ;; Protect against XEmacs bogus binding of `enable-multibyte-characters'.
+ (if (and (or (featurep 'xemacs)
+ (and (boundp 'enable-multibyte-characters)
+ enable-multibyte-characters))
+ (fboundp 'set-process-coding-system))
+ (set-process-coding-system ispell-process (ispell-get-coding-system)
+ (ispell-get-coding-system)))
+ ;; Get version ID line
+ (ispell-accept-output 3)
+ ;; get more output if filter empty?
+ (if (null ispell-filter) (ispell-accept-output 3))
+ (cond ((null ispell-filter)
+ (error "%s did not output version line" ispell-program-name))
+ ((and
+ (stringp (car ispell-filter))
+ (if (string-match "warning: " (car ispell-filter))
+ (progn
+ (ispell-accept-output 3) ; was warn msg.
+ (stringp (car ispell-filter)))
+ (null (cdr ispell-filter)))
+ (string-match "^@(#) " (car ispell-filter)))
+ ;; got the version line as expected (we already know it's the right
+ ;; version, so don't bother checking again.)
+ nil)
+ (t
+ ;; Otherwise, it must be an error message. Show the user.
+ ;; But first wait to see if some more output is going to arrive.
+ ;; Otherwise we get cool errors like "Can't open ".
+ (sleep-for 1)
+ (ispell-accept-output 3)
+ (error "%s" (mapconcat 'identity ispell-filter "\n"))))
+ (setq ispell-filter nil) ; Discard version ID line
+ (let ((extended-char-mode (ispell-get-extended-character-mode)))
+ (if extended-char-mode ; ~ extended character mode
+ (ispell-send-string (concat extended-char-mode "\n"))))
+ (if ispell-async-processp
+ (if (featurep 'emacs)
+ (set-process-query-on-exit-flag ispell-process nil)
+ (if (fboundp 'set-process-query-on-exit-flag)
+ (set-process-query-on-exit-flag ispell-process nil)
+ (process-kill-without-query ispell-process)))))))
;;;###autoload
(defun ispell-kill-ispell (&optional no-error)
@@ -2693,7 +2770,6 @@ With NO-ERROR, just return non-nil if there was no Ispell running."
(message "Ispell process killed")
nil))
-
;;; ispell-change-dictionary is set in some people's hooks. Maybe this should
;;; call ispell-init-process rather than wait for a spell checking command?
@@ -2754,7 +2830,11 @@ a new one will be started when needed."
(setq ispell-current-dictionary dict
ispell-current-personal-dictionary pdict))))
-;;; Spelling of comments are checked when ispell-check-comments is non-nil.
+;; Avoid error messages when compiling for these dynamic variables.
+(defvar ispell-start)
+(defvar ispell-end)
+
+;; Spelling of comments are checked when ispell-check-comments is non-nil.
;;;###autoload
(defun ispell-region (reg-start reg-end &optional recheckp shift)
@@ -2785,14 +2865,14 @@ Return nil if spell session is quit,
(message "searching for regions to skip"))
(if (re-search-forward (ispell-begin-skip-region-regexp) reg-end t)
(progn
- (setq key (buffer-substring-no-properties
- (match-beginning 0) (match-end 0)))
+ (setq key (match-string-no-properties 0))
(set-marker skip-region-start (- (point) (length key)))
(goto-char reg-start)))
(let (message-log-max)
- (message "Continuing spelling check using %s with %s dictionary..."
- (file-name-nondirectory ispell-program-name)
- (or ispell-current-dictionary "default")))
+ (message
+ "Continuing spelling check using %s with %s dictionary..."
+ (file-name-nondirectory ispell-program-name)
+ (or ispell-current-dictionary "default")))
(set-marker rstart reg-start)
(set-marker ispell-region-end reg-end)
(while (and (not ispell-quit)
@@ -2831,18 +2911,19 @@ Return nil if spell session is quit,
(if (marker-position skip-region-start)
(min skip-region-start ispell-region-end)
(marker-position ispell-region-end))))
- (let* ((start (point))
- (end (save-excursion (end-of-line) (min (point) reg-end)))
- (string (ispell-get-line start end in-comment)))
+ (let* ((ispell-start (point))
+ (ispell-end (min (point-at-eol) reg-end))
+ (string (ispell-get-line
+ ispell-start ispell-end in-comment)))
(if in-comment ; account for comment chars added
- (setq start (- start (length in-comment))
+ (setq ispell-start (- ispell-start (length in-comment))
in-comment nil))
- (setq end (point)) ; "end" tracks region retrieved.
+ (setq ispell-end (point)) ; "end" tracks region retrieved.
(if string ; there is something to spell check!
;; (special start end)
(setq shift (ispell-process-line string
(and recheckp shift))))
- (goto-char end)))))
+ (goto-char ispell-end)))))
(if ispell-quit
nil
(or shift 0)))
@@ -2879,42 +2960,30 @@ Return nil if spell session is quit,
"Return a regexp of the search keys for region skipping.
Includes `ispell-skip-region-alist' plus tex, tib, html, and comment keys.
Must call after `ispell-buffer-local-parsing' due to dependence on mode."
- ;; start with regions generic to all buffers
- (let ((skip-regexp (ispell-begin-skip-region ispell-skip-region-alist)))
- ;; Comments
- (if (and (null ispell-check-comments) comment-start)
- (setq skip-regexp (concat (regexp-quote comment-start) "\\|"
- skip-regexp)))
- (if (and (eq 'exclusive ispell-check-comments) comment-start)
- ;; search from end of current comment to start of next comment.
- (setq skip-regexp (concat (if (string= "" comment-end) "^"
- (regexp-quote comment-end))
- "\\|" skip-regexp)))
- ;; tib
- (if ispell-skip-tib
- (setq skip-regexp (concat ispell-tib-ref-beginning "\\|" skip-regexp)))
- ;; html stuff
- (if ispell-skip-html
- (setq skip-regexp (concat
- (ispell-begin-skip-region ispell-html-skip-alists)
- "\\|"
- skip-regexp)))
- ;; tex
- (if (eq ispell-parser 'tex)
- (setq skip-regexp (concat (ispell-begin-tex-skip-regexp) "\\|"
- skip-regexp)))
- ;; messages
- (if (and ispell-checking-message
- (not (eq t ispell-checking-message)))
- (setq skip-regexp (concat
- (mapconcat (lambda (lst) (car lst))
- ispell-checking-message
- "\\|")
- "\\|"
- skip-regexp)))
-
- ;; return new regexp
- skip-regexp))
+ (mapconcat
+ 'identity
+ (delq nil
+ (list
+ ;; messages
+ (if (and ispell-checking-message
+ (not (eq t ispell-checking-message)))
+ (mapconcat #'car ispell-checking-message "\\|"))
+ ;; tex
+ (if (eq ispell-parser 'tex)
+ (ispell-begin-tex-skip-regexp))
+ ;; html stuff
+ (if ispell-skip-html
+ (ispell-begin-skip-region ispell-html-skip-alists))
+ ;; tib
+ (if ispell-skip-tib ispell-tib-ref-beginning)
+ ;; Comments
+ (if (and (eq 'exclusive ispell-check-comments) comment-start)
+ ;; search from end of current comment to start of next comment.
+ (if (string= "" comment-end) "^" (regexp-quote comment-end)))
+ (if (and (null ispell-check-comments) comment-start)
+ (regexp-quote comment-start))
+ (ispell-begin-skip-region ispell-skip-region-alist)))
+ "\\|"))
(defun ispell-begin-skip-region (skip-alist)
@@ -3057,9 +3126,9 @@ Point is placed at end of skipped region."
(sit-for 2)))))
-;;; Grab the next line of data.
-;;; Returns a string with the line data
(defun ispell-get-line (start end in-comment)
+ "Grab the next line of data.
+Returns a string with the line data."
(let ((ispell-casechars (ispell-get-casechars))
string)
(cond ; LOOK AT THIS LINE AND SKIP OR PROCESS
@@ -3086,16 +3155,13 @@ Point is placed at end of skipped region."
(point) (+ (point) len))
coding)))))
-;;; Avoid error messages when compiling for these dynamic variables.
-(defvar start)
-(defvar end)
-
(defun ispell-process-line (string shift)
"Send STRING, a line of text, to ispell and processes the result.
This will modify the buffer for spelling errors.
-Requires variables START and END to be defined in its lexical scope.
+Requires variables ISPELL-START and ISPELL-END to be defined in its
+dynamic scope.
Returns the sum SHIFT due to changes in word replacements."
- ;;(declare special start end)
+ ;;(declare special ispell-start ispell-end)
(let (poss accept-list)
(if (not (numberp shift))
(setq shift 0))
@@ -3118,10 +3184,10 @@ Returns the sum SHIFT due to changes in word replacements."
;; Markers can move with highlighting! This destroys
;; end of region markers line-end and ispell-region-end
(let ((word-start
- (copy-marker (+ start ispell-offset (car (cdr poss)))))
+ (copy-marker (+ ispell-start ispell-offset (car (cdr poss)))))
(word-len (length (car poss)))
- (line-end (copy-marker end))
- (line-start (copy-marker start))
+ (line-end (copy-marker ispell-end))
+ (line-start (copy-marker ispell-start))
recheck-region replace)
(goto-char word-start)
;; Adjust the horizontal scroll & point
@@ -3221,16 +3287,19 @@ Returns the sum SHIFT due to changes in word replacements."
;; (length (car poss)))))
))
(if (not ispell-quit)
+ ;; FIXME: remove redundancy with identical code above.
(let (message-log-max)
- (message "Continuing spelling check using %s with %s dictionary..."
- (file-name-nondirectory ispell-program-name)
- (or ispell-current-dictionary "default"))))
+ (message
+ "Continuing spelling check using %s with %s dictionary..."
+ (file-name-nondirectory ispell-program-name)
+ (or ispell-current-dictionary "default"))))
(sit-for 0)
- (setq start (marker-position line-start)
- end (marker-position line-end))
+ (setq ispell-start (marker-position line-start)
+ ispell-end (marker-position line-end))
;; Adjust markers when end of region lost from highlighting.
- (if (and (not recheck-region) (< end (+ word-start word-len)))
- (setq end (+ word-start word-len)))
+ (if (and (not recheck-region)
+ (< ispell-end (+ word-start word-len)))
+ (setq ispell-end (+ word-start word-len)))
(if (= word-start ispell-region-end)
(set-marker ispell-region-end (+ word-start word-len)))
;; going out of scope - unneeded
@@ -3297,7 +3366,7 @@ Returns the sum SHIFT due to changes in word replacements."
;;; Interactive word completion.
-;;; Forces "previous-word" processing. Do we want to make this selectable?
+;; Forces "previous-word" processing. Do we want to make this selectable?
;;;###autoload
(defun ispell-complete-word (&optional interior-frag)
@@ -3319,7 +3388,8 @@ Standard ispell choices are then available."
(lookup-words (concat (and interior-frag "*") word
(if (or interior-frag (null ispell-look-p))
"*"))
- ispell-complete-word-dict)))
+ (or ispell-complete-word-dict
+ ispell-alternate-dictionary))))
(cond ((eq possibilities t)
(message "No word to complete"))
((null possibilities)
@@ -3387,15 +3457,6 @@ available on the net."
;;; Ispell Minor Mode
;;; **********************************************************************
-(defvar ispell-minor-mode nil
- "Non-nil if Ispell minor mode is enabled.")
-;; Variable indicating that ispell minor mode is active.
-(make-variable-buffer-local 'ispell-minor-mode)
-
-(or (assq 'ispell-minor-mode minor-mode-alist)
- (setq minor-mode-alist
- (cons '(ispell-minor-mode " Spell") minor-mode-alist)))
-
(defvar ispell-minor-keymap
(let ((map (make-sparse-keymap)))
(define-key map " " 'ispell-minor-check)
@@ -3403,14 +3464,8 @@ available on the net."
map)
"Keymap used for Ispell minor mode.")
-(or (not (boundp 'minor-mode-map-alist))
- (assoc 'ispell-minor-mode minor-mode-map-alist)
- (setq minor-mode-map-alist
- (cons (cons 'ispell-minor-mode ispell-minor-keymap)
- minor-mode-map-alist)))
-
;;;###autoload
-(defun ispell-minor-mode (&optional arg)
+(define-minor-mode ispell-minor-mode
"Toggle Ispell minor mode.
With prefix argument ARG, turn Ispell minor mode on if ARG is positive,
otherwise turn it off.
@@ -3420,11 +3475,7 @@ warns you if the previous word is incorrectly spelled.
All the buffer-local variables and dictionaries are ignored -- to read
them into the running ispell process, type \\[ispell-word] SPC."
- (interactive "P")
- (setq ispell-minor-mode
- (not (or (and (null arg) ispell-minor-mode)
- (<= (prefix-numeric-value arg) 0))))
- (force-mode-line-update))
+ nil " Spell" ispell-minor-keymap)
(defun ispell-minor-check ()
"Check previous word then continue with the normal binding of this key.
@@ -3690,15 +3741,14 @@ You can bind this to the key C-c i in GNUS or mail by adding to
(goto-char (point-min))
;; Select type or skip checking if this is a non-multipart message
;; Point moved to end of buffer if region is encoded.
- (if (and mimep (not boundary))
- (let (skip-regexp) ; protect from `ispell-mime-skip-part'
+ (when (and mimep (not boundary))
(goto-char (point-min))
(re-search-forward "Content-[^ \t]*:" end-of-headers t)
(forward-line -1) ; following fn starts one line above
(ispell-mime-skip-part nil)
;; if message-text-end region, limit may be less than point.
(if (> (point) limit)
- (set-marker limit (point)))))
+ (set-marker limit (point))))
(goto-char (max end-of-headers (point)))
(forward-line 1)
(setq case-fold-search old-case-fold-search)
@@ -3764,7 +3814,7 @@ Includes Latex/Nroff modes and extended character mode."
(goto-char (point-max))
;; Uses last occurrence of ispell-parsing-keyword
(if (search-backward ispell-parsing-keyword nil t)
- (let ((end (save-excursion (end-of-line) (point)))
+ (let ((end (point-at-eol))
string)
(search-forward ispell-parsing-keyword)
(while (re-search-forward " *\\([^ \"]+\\)" end t)
@@ -3781,7 +3831,7 @@ Includes Latex/Nroff modes and extended character mode."
(sit-for 2))))))))
-;;; Can kill the current ispell process
+;; Can kill the current ispell process
(defun ispell-buffer-local-dict (&optional no-reload)
"Initializes local dictionary and local personal dictionary.
@@ -3800,7 +3850,7 @@ Both should not be used to define a buffer-local dictionary."
(if (search-backward ispell-dictionary-keyword nil t)
(progn
(search-forward ispell-dictionary-keyword)
- (setq end (save-excursion (end-of-line) (point)))
+ (setq end (point-at-eol))
(if (re-search-forward " *\\([^ \"]+\\)" end t)
(setq ispell-local-dictionary
(match-string-no-properties 1))))))
@@ -3808,7 +3858,7 @@ Both should not be used to define a buffer-local dictionary."
(if (search-backward ispell-pdict-keyword nil t)
(progn
(search-forward ispell-pdict-keyword)
- (setq end (save-excursion (end-of-line) (point)))
+ (setq end (point-at-eol))
(if (re-search-forward " *\\([^ \"]+\\)" end t)
(setq ispell-local-pdict
(match-string-no-properties 1)))))))
@@ -3832,7 +3882,7 @@ Both should not be used to define a buffer-local dictionary."
(while (search-forward ispell-words-keyword nil t)
(or ispell-buffer-local-name
(setq ispell-buffer-local-name (buffer-name)))
- (let ((end (save-excursion (end-of-line) (point)))
+ (let ((end (point-at-eol))
(ispell-casechars (ispell-get-casechars))
string)
;; buffer-local words separated by a space, and can contain
@@ -3848,22 +3898,23 @@ Both should not be used to define a buffer-local dictionary."
;;; returns optionally adjusted region-end-point.
+;; If comment-padright is defined, newcomment must be loaded.
+(declare-function comment-add "newcomment" (arg))
+
(defun ispell-add-per-file-word-list (word)
"Add WORD to the per-file word list."
(or ispell-buffer-local-name
(setq ispell-buffer-local-name (buffer-name)))
(save-excursion
(goto-char (point-min))
- (let ((old-case-fold-search case-fold-search)
- line-okay search done found)
+ (let (line-okay search done found)
(while (not done)
- (setq case-fold-search nil
- search (search-forward ispell-words-keyword nil 'move)
+ (let ((case-fold-search nil))
+ (setq search (search-forward ispell-words-keyword nil 'move)
found (or found search)
line-okay (< (+ (length word) 1 ; 1 for space after word..
(progn (end-of-line) (current-column)))
- 80)
- case-fold-search old-case-fold-search)
+ fill-column)))
(if (or (and search line-okay)
(null search))
(progn
@@ -3872,7 +3923,13 @@ Both should not be used to define a buffer-local dictionary."
(progn
(open-line 1)
(unless found (newline))
- (insert (concat comment-start " " ispell-words-keyword))
+ (insert (if (fboundp 'comment-padright)
+ ;; Try and use the proper comment marker,
+ ;; e.g. ";;" rather than ";".
+ (comment-padright comment-start
+ (comment-add nil))
+ comment-start)
+ " " ispell-words-keyword)
(if (> (length comment-end) 0)
(save-excursion
(newline)
@@ -3918,5 +3975,4 @@ Both should not be used to define a buffer-local dictionary."
; LocalWords: uuencoded unidiff sc nn VM SGML eval IspellPersDict unsplitable
; LocalWords: lns XEmacs HTML casechars Multibyte
-;; arch-tag: 4941b9f9-3b7c-4a76-a4ed-5fa8b6010ef5
;;; ispell.el ends here
diff --git a/lisp/textmodes/makeinfo.el b/lisp/textmodes/makeinfo.el
index 0f0c3a372a5..b5f1336d535 100644
--- a/lisp/textmodes/makeinfo.el
+++ b/lisp/textmodes/makeinfo.el
@@ -1,7 +1,7 @@
;;; makeinfo.el --- run makeinfo conveniently
-;; Copyright (C) 1991, 1993, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1991, 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Robert J. Chassell
;; Maintainer: FSF
@@ -58,13 +58,13 @@
(defcustom makeinfo-run-command "makeinfo"
- "*Command used to run `makeinfo' subjob.
+ "Command used to run `makeinfo' subjob.
The name of the file is appended to this string, separated by a space."
:type 'string
:group 'makeinfo)
(defcustom makeinfo-options "--fill-column=70"
- "*String containing options for running `makeinfo'.
+ "String containing options for running `makeinfo'.
Do not include `--footnote-style' or `--paragraph-indent';
the proper way to specify those is with the Texinfo commands
`@footnotestyle` and `@paragraphindent'."
diff --git a/lisp/textmodes/nroff-mode.el b/lisp/textmodes/nroff-mode.el
index 61ea89582b2..52538064053 100644
--- a/lisp/textmodes/nroff-mode.el
+++ b/lisp/textmodes/nroff-mode.el
@@ -55,6 +55,7 @@
(define-key map "\n" 'nroff-electric-newline)
(define-key map "\en" 'nroff-forward-text-line)
(define-key map "\ep" 'nroff-backward-text-line)
+ (define-key map "\C-c\C-c" 'nroff-view)
(define-key map [menu-bar nroff-mode] (cons "Nroff" menu-map))
(define-key menu-map [nn]
'(menu-item "Newline" nroff-electric-newline
@@ -73,6 +74,9 @@
nroff-electric-mode
:help "Auto insert closing requests if necessary"
:button (:toggle . nroff-electric-mode)))
+ (define-key menu-map [npm]
+ '(menu-item "Preview as man page" nroff-view
+ :help "Run man on this file."))
map)
"Major mode keymap for `nroff-mode'.")
@@ -301,6 +305,23 @@ turns it on if arg is positive, otherwise off."
:lighter " Electric"
(or (derived-mode-p 'nroff-mode) (error "Must be in nroff mode")))
+(declare-function Man-getpage-in-background "man" (topic))
+
+(defun nroff-view ()
+ "Run man on this file."
+ (interactive)
+ (require 'man)
+ (let* ((file (buffer-file-name))
+ (viewbuf (get-buffer (concat "*Man " file "*"))))
+ (unless file
+ (error "Buffer is not associated with any file"))
+ (and (buffer-modified-p)
+ (y-or-n-p (format "Save buffer %s first? " (buffer-name)))
+ (save-buffer))
+ (if viewbuf
+ (kill-buffer viewbuf))
+ (Man-getpage-in-background file)))
+
;; Old names that were not namespace clean.
(define-obsolete-function-alias 'count-text-lines 'nroff-count-text-lines "22.1")
(define-obsolete-function-alias 'forward-text-line 'nroff-forward-text-line "22.1")
diff --git a/lisp/textmodes/page-ext.el b/lisp/textmodes/page-ext.el
index a87e7942e9b..548223e4f2c 100644
--- a/lisp/textmodes/page-ext.el
+++ b/lisp/textmodes/page-ext.el
@@ -1,7 +1,7 @@
;;; page-ext.el --- extended page handling commands
-;; Copyright (C) 1990, 1991, 1993, 1994, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1990, 1991, 1993, 1994, 2001, 2002, 2003, 2004, 2005,
+;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Robert J. Chassell <bob@gnu.org>
;; (according to ack.texi)
@@ -242,17 +242,17 @@
(defcustom pages-directory-buffer-narrowing-p t
- "*If non-nil, `pages-directory-goto' narrows pages buffer to entry."
+ "If non-nil, `pages-directory-goto' narrows pages buffer to entry."
:type 'boolean
:group 'pages)
(defcustom pages-directory-for-adding-page-narrowing-p t
- "*If non-nil, `add-new-page' narrows page buffer to new entry."
+ "If non-nil, `add-new-page' narrows page buffer to new entry."
:type 'boolean
:group 'pages)
(defcustom pages-directory-for-adding-new-page-before-current-page-p t
- "*If non-nil, `add-new-page' inserts new page before current page."
+ "If non-nil, `add-new-page' inserts new page before current page."
:type 'boolean
:group 'pages)
@@ -260,23 +260,23 @@
;;; Addresses related variables
(defcustom pages-addresses-file-name "~/addresses"
- "*Standard name for file of addresses. Entries separated by page-delimiter.
+ "Standard name for file of addresses. Entries separated by page-delimiter.
Used by `pages-directory-for-addresses' function."
:type 'file
:group 'pages)
(defcustom pages-directory-for-addresses-goto-narrowing-p t
- "*If non-nil, `pages-directory-goto' narrows addresses buffer to entry."
+ "If non-nil, `pages-directory-goto' narrows addresses buffer to entry."
:type 'boolean
:group 'pages)
(defcustom pages-directory-for-addresses-buffer-keep-windows-p t
- "*If nil, `pages-directory-for-addresses' deletes other windows."
+ "If nil, `pages-directory-for-addresses' deletes other windows."
:type 'boolean
:group 'pages)
(defcustom pages-directory-for-adding-addresses-narrowing-p t
- "*If non-nil, `add-new-page' narrows addresses buffer to new entry."
+ "If non-nil, `add-new-page' narrows addresses buffer to new entry."
:type 'boolean
:group 'pages)
@@ -671,7 +671,7 @@ Used by `pages-directory' function."
(setq position (make-marker))
(set-marker position (point))
(let ((start (point))
- (end (save-excursion (end-of-line) (point)))
+ (end (line-end-position))
inserted-at)
;; change to directory buffer
(set-buffer standard-output)
@@ -783,7 +783,7 @@ directory."
(delete-other-windows))
(save-excursion
(goto-char (point-min))
- (delete-region (point) (save-excursion (end-of-line) (point)))
+ (delete-region (point) (line-end-position))
(insert
"=== Address List Directory: use `C-c C-c' to go to page under cursor. ===")
(set-buffer-modified-p nil)
@@ -801,5 +801,4 @@ to the same line in the pages buffer."
(provide 'page-ext)
-;; arch-tag: 2f311550-c6e0-4458-9c12-7f039c058bdb
;;; page-ext.el ends here
diff --git a/lisp/textmodes/page.el b/lisp/textmodes/page.el
index a672dc92158..1c213fcbea2 100644
--- a/lisp/textmodes/page.el
+++ b/lisp/textmodes/page.el
@@ -5,6 +5,7 @@
;; Maintainer: FSF
;; Keywords: wp convenience
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/textmodes/paragraphs.el b/lisp/textmodes/paragraphs.el
index 2c698a836fe..4f1bcefa90e 100644
--- a/lisp/textmodes/paragraphs.el
+++ b/lisp/textmodes/paragraphs.el
@@ -6,6 +6,7 @@
;; Maintainer: FSF
;; Keywords: wp
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/textmodes/picture.el b/lisp/textmodes/picture.el
index f1bb9957125..98add4cfd28 100644
--- a/lisp/textmodes/picture.el
+++ b/lisp/textmodes/picture.el
@@ -34,30 +34,30 @@
(defgroup picture nil
"Picture mode --- editing using quarter-plane screen model."
:prefix "picture-"
- :group 'editing)
+ :group 'wp)
(defcustom picture-rectangle-ctl ?+
- "*Character `picture-draw-rectangle' uses for top left corners."
+ "Character `picture-draw-rectangle' uses for top left corners."
:type 'character
:group 'picture)
(defcustom picture-rectangle-ctr ?+
- "*Character `picture-draw-rectangle' uses for top right corners."
+ "Character `picture-draw-rectangle' uses for top right corners."
:type 'character
:group 'picture)
(defcustom picture-rectangle-cbr ?+
- "*Character `picture-draw-rectangle' uses for bottom right corners."
+ "Character `picture-draw-rectangle' uses for bottom right corners."
:type 'character
:group 'picture)
(defcustom picture-rectangle-cbl ?+
- "*Character `picture-draw-rectangle' uses for bottom left corners."
+ "Character `picture-draw-rectangle' uses for bottom left corners."
:type 'character
:group 'picture)
(defcustom picture-rectangle-v ?|
- "*Character `picture-draw-rectangle' uses for vertical lines."
+ "Character `picture-draw-rectangle' uses for vertical lines."
:type 'character
:group 'picture)
(defcustom picture-rectangle-h ?-
- "*Character `picture-draw-rectangle' uses for horizontal lines."
+ "Character `picture-draw-rectangle' uses for horizontal lines."
:type 'character
:group 'picture)
@@ -377,7 +377,7 @@ With positive argument insert that many lines."
;; Picture Tabs
(defcustom picture-tab-chars "!-~"
- "*A character set which controls behavior of commands.
+ "A character set which controls behavior of commands.
\\[picture-set-tab-stops] and \\[picture-tab-search]. It is NOT a
regular expression, any regexp special characters will be quoted.
It defines a set of \"interesting characters\" to look for when setting
@@ -452,7 +452,7 @@ If no such character is found, move to beginning of line."
(move-to-column target))
(if (re-search-forward
(concat "[ \t]+[" (regexp-quote picture-tab-chars) "]")
- (save-excursion (end-of-line) (point))
+ (line-end-position)
'move)
(setq target (1- (current-column)))
(setq target nil)))
@@ -789,5 +789,4 @@ Runs `picture-mode-exit-hook' at the end."
(provide 'picture)
-;; arch-tag: e452d08d-a470-4fbf-896e-ea276698d1ca
;;; picture.el ends here
diff --git a/lisp/textmodes/refer.el b/lisp/textmodes/refer.el
index c35b76b3053..a811c8f6580 100644
--- a/lisp/textmodes/refer.el
+++ b/lisp/textmodes/refer.el
@@ -1,7 +1,7 @@
;;; refer.el --- look up references in bibliography files
-;; Copyright (C) 1992, 1996, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 1996, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Ashwin Ram <ashwin@cc.gatech.edu>
;; Maintainer: Gernot Heiser <gernot@acm.org>
@@ -96,7 +96,7 @@ happen anyway)."
:group 'refer)
(defcustom refer-bib-files 'dir
- "*List of \\.bib files to search for references,
+ "List of \\.bib files to search for references,
or one of the following special values:
nil = prompt for \\.bib file (if visiting a \\.bib file, use it as default)
auto = read \\.bib file names from appropriate command in buffer (see
@@ -115,7 +115,7 @@ each time it is needed."
:group 'refer)
(defcustom refer-cache-bib-files t
- "*Variable determining whether the value of `refer-bib-files' should be cached.
+ "Variable determining whether the value of `refer-bib-files' should be cached.
If t, initialize the value of refer-bib-files the first time it is used. If
nil, re-read the list of \\.bib files depending on the value of `refer-bib-files'
each time it is needed."
@@ -123,7 +123,7 @@ each time it is needed."
:group 'refer)
(defcustom refer-bib-files-regexp "\\\\bibliography"
- "*Regexp matching a bibliography file declaration.
+ "Regexp matching a bibliography file declaration.
The current buffer is expected to contain a line such as
\\bibliography{file1,file2,file3}
which is read to set up `refer-bib-files'. The regexp must specify the command
diff --git a/lisp/textmodes/reftex-auc.el b/lisp/textmodes/reftex-auc.el
index 498148f0de4..89e8d26bc65 100644
--- a/lisp/textmodes/reftex-auc.el
+++ b/lisp/textmodes/reftex-auc.el
@@ -6,6 +6,7 @@
;; Author: Carsten Dominik <dominik@science.uva.nl>
;; Maintainer: auctex-devel@gnu.org
;; Version: 4.31
+;; Package: reftex
;; This file is part of GNU Emacs.
@@ -58,7 +59,7 @@ What is being used depends upon `reftex-plug-into-AUCTeX'."
;; Create a new label, with a temporary brace for `reftex-what-macro'
(unwind-protect
(progn (insert "{") (setq label (or (reftex-label nil t) "")))
- (delete-backward-char 1)))
+ (delete-char -1)))
((and (not definition) (reftex-plug-flag 2))
;; Reference a label with RefTeX
(setq label (reftex-reference nil t)))
diff --git a/lisp/textmodes/reftex-cite.el b/lisp/textmodes/reftex-cite.el
index 3972a1df31c..2c8a14a3808 100644
--- a/lisp/textmodes/reftex-cite.el
+++ b/lisp/textmodes/reftex-cite.el
@@ -6,6 +6,7 @@
;; Author: Carsten Dominik <dominik@science.uva.nl>
;; Maintainer: auctex-devel@gnu.org
;; Version: 4.31
+;; Package: reftex
;; This file is part of GNU Emacs.
@@ -357,27 +358,30 @@
(message "Scanning thebibliography environment in %s" file)
(with-current-buffer buf
- (save-restriction
- (widen)
- (goto-char (point-min))
- (while (re-search-forward
- "\\(\\`\\|[\n\r]\\)[ \t]*\\\\begin{thebibliography}" nil t)
- (beginning-of-line 2)
- (setq start (point))
- (if (re-search-forward
- "\\(\\`\\|[\n\r]\\)[ \t]*\\\\end{thebibliography}" nil t)
- (progn
- (beginning-of-line 1)
- (setq end (point))))
- (when (and start end)
- (setq entries
- (append entries
- (mapcar 'reftex-parse-bibitem
- (delete ""
- (split-string
- (buffer-substring-no-properties start end)
- "[ \t\n\r]*\\\\bibitem\\(\\[[^]]*]\\)*"))))))
- (goto-char end)))))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (while (re-search-forward
+ "\\(\\`\\|[\n\r]\\)[ \t]*\\\\begin{thebibliography}" nil t)
+ (beginning-of-line 2)
+ (setq start (point))
+ (if (re-search-forward
+ "\\(\\`\\|[\n\r]\\)[ \t]*\\\\end{thebibliography}" nil t)
+ (progn
+ (beginning-of-line 1)
+ (setq end (point))))
+ (when (and start end)
+ (setq entries
+ (append entries
+ (mapcar 'reftex-parse-bibitem
+ (delete ""
+ (split-string
+ (buffer-substring-no-properties
+ start end)
+ "[ \t\n\r]*\\\\bibitem[ \t]*\
+\\(\\[[^]]*]\\)*\[ \t]*"))))))
+ (goto-char end))))))
(unless entries
(error "No bibitems found"))
@@ -1143,9 +1147,8 @@ The sequence in the new file is the same as it was in the old database."
(save-restriction
(widen)
(goto-char (point-min))
- (while (re-search-forward
- "^[ \t]*@[a-zA-Z]+[ \t]*{\\([^ \t\r\n]+\\),"
- nil t)
+ (while (re-search-forward "^[ \t]*@\\(?:\\w\\|\\s_\\)+[ \t\n\r]*\
+\[{(][ \t\n\r]*\\([^ \t\n\r,]+\\)" nil t)
(setq key (match-string 1)
beg (match-beginning 0)
end (progn
diff --git a/lisp/textmodes/reftex-dcr.el b/lisp/textmodes/reftex-dcr.el
index d15cf3f9931..39fc0f4a81c 100644
--- a/lisp/textmodes/reftex-dcr.el
+++ b/lisp/textmodes/reftex-dcr.el
@@ -6,6 +6,7 @@
;; Author: Carsten Dominik <dominik@science.uva.nl>
;; Maintainer: auctex-devel@gnu.org
;; Version: 4.31
+;; Package: reftex
;; This file is part of GNU Emacs.
diff --git a/lisp/textmodes/reftex-global.el b/lisp/textmodes/reftex-global.el
index 22e8a577d97..dc533185b24 100644
--- a/lisp/textmodes/reftex-global.el
+++ b/lisp/textmodes/reftex-global.el
@@ -6,6 +6,7 @@
;; Author: Carsten Dominik <dominik@science.uva.nl>
;; Maintainer: auctex-devel@gnu.org
;; Version: 4.31
+;; Package: reftex
;; This file is part of GNU Emacs.
diff --git a/lisp/textmodes/reftex-index.el b/lisp/textmodes/reftex-index.el
index 35cae5ae874..2da5897827d 100644
--- a/lisp/textmodes/reftex-index.el
+++ b/lisp/textmodes/reftex-index.el
@@ -6,6 +6,7 @@
;; Author: Carsten Dominik <dominik@science.uva.nl>
;; Maintainer: auctex-devel@gnu.org
;; Version: 4.31
+;; Package: reftex
;; This file is part of GNU Emacs.
@@ -1698,7 +1699,7 @@ it first compares the macro identifying chars and then the phrases."
(let* ((lines (split-string (buffer-substring beg end) "\n"))
(lines1 (sort lines 'reftex-compare-phrase-lines)))
(message "Sorting lines...done")
- (let ((inhibit-quit t)) ;; make sure we do not loose lines
+ (let ((inhibit-quit t)) ;; make sure we do not lose lines
(delete-region beg end)
(insert (mapconcat 'identity lines1 "\n"))))
(goto-char (point-max))
@@ -2103,5 +2104,4 @@ Does not do a save-excursion."
["Save and Return" reftex-index-phrases-save-and-return t]))
-;; arch-tag: 4b2362af-c156-42c1-8932-ea2823e205c1
;;; reftex-index.el ends here
diff --git a/lisp/textmodes/reftex-parse.el b/lisp/textmodes/reftex-parse.el
index dc03a387082..fa0275b58be 100644
--- a/lisp/textmodes/reftex-parse.el
+++ b/lisp/textmodes/reftex-parse.el
@@ -6,6 +6,7 @@
;; Author: Carsten Dominik <dominik@science.uva.nl>
;; Maintainer: auctex-devel@gnu.org
;; Version: 4.31
+;; Package: reftex
;; This file is part of GNU Emacs.
@@ -384,7 +385,7 @@ of master file."
(defun reftex-section-info (file)
;; Return a section entry for the current match.
- ;; Carefull: This function expects the match-data to be still in place!
+ ;; Careful: This function expects the match-data to be still in place!
(let* ((marker (set-marker (make-marker) (1- (match-beginning 3))))
(macro (reftex-match-string 3))
(prefix (save-match-data
@@ -774,16 +775,18 @@ of master file."
pos cmd-list cmd cnt cnt-opt entry)
(save-restriction
(save-excursion
- (narrow-to-region (max 1 bound) (point-max))
+ (narrow-to-region (max (point-min) bound) (point-max))
;; move back out of the current parenthesis
(while (condition-case nil
- (progn (up-list -1) t)
+ (let ((forward-sexp-function nil))
+ (up-list -1) t)
(error nil))
(setq cnt 1 cnt-opt 0)
;; move back over any touching sexps
(while (and (reftex-move-to-previous-arg bound)
(condition-case nil
- (progn (backward-sexp) t)
+ (let ((forward-sexp-function nil))
+ (backward-sexp) t)
(error nil)))
(if (eq (following-char) ?\[) (incf cnt-opt))
(incf cnt))
@@ -964,15 +967,14 @@ of master file."
(if (re-search-forward "\\\\end{" nil t)
(match-beginning 0)
(point-max))))))
- ((or (= (preceding-char) ?\{)
- (= (preceding-char) ?\[))
+ ((memq (preceding-char) '(?\{ ?\[))
;; Inside a list - get only the list.
(buffer-substring-no-properties
(point)
(min (+ (point) 150)
(point-max)
(condition-case nil
- (progn
+ (let ((forward-sexp-function nil)) ;Unneeded fanciness.
(up-list 1)
(1- (point)))
(error (point-max))))))
diff --git a/lisp/textmodes/reftex-ref.el b/lisp/textmodes/reftex-ref.el
index b186a1ea713..91cc77480eb 100644
--- a/lisp/textmodes/reftex-ref.el
+++ b/lisp/textmodes/reftex-ref.el
@@ -6,6 +6,7 @@
;; Author: Carsten Dominik <dominik@science.uva.nl>
;; Maintainer: auctex-devel@gnu.org
;; Version: 4.31
+;; Package: reftex
;; This file is part of GNU Emacs.
@@ -179,8 +180,8 @@ This function is controlled by the settings of reftex-insert-label-flags."
(string-match "^[ \t]*$" default))
(setq default prefix
force-prompt t) ; need to prompt
- (setq default
- (concat prefix
+ (setq default
+ (concat prefix
(funcall reftex-string-to-label-function default)))
;; Make it unique.
@@ -226,7 +227,7 @@ This function is controlled by the settings of reftex-insert-label-flags."
((setq entry (assoc label
(symbol-value reftex-docstruct-symbol)))
(ding)
- (if (y-or-n-p
+ (if (y-or-n-p
(format "Label '%s' exists. Use anyway? " label))
(setq valid t)))
@@ -236,9 +237,9 @@ This function is controlled by the settings of reftex-insert-label-flags."
(setq label default))
;; Insert the label into the label list
- (let* ((here-I-am-info
+ (let* ((here-I-am-info
(save-excursion
- (if (and (or naked no-insert)
+ (if (and (or naked no-insert)
(integerp (cdr macro-cell)))
(goto-char (cdr macro-cell)))
(reftex-where-am-I)))
@@ -293,7 +294,7 @@ also applies `reftex-translate-to-ascii-function' to the string."
;; Translate the upper 128 chars in the Latin-1 charset to ASCII equivalents
(let ((tab "@@@@@@@@@@@@@@@@@@'@@@@@@@@@@@@@ icLxY|S\"ca<--R-o|23'uq..1o>423?AAAAAAACEEEEIIIIDNOOOOOXOUUUUYP3aaaaaaaceeeeiiiidnooooo:ouuuuypy")
(emacsp (not (featurep 'xemacs))))
- (mapconcat
+ (mapconcat
(lambda (c)
(cond ((and (> c 127) (< c 256)) ; 8 bit Latin-1
(char-to-string (aref tab (- c 128))))
@@ -429,7 +430,7 @@ When called with 2 C-u prefix args, disable magic word recognition."
type (car type))
(setq type (reftex-query-label-type))))
- (let* ((refstyle
+ (let* ((reftex-refstyle
(cond ((reftex-typekey-check type reftex-vref-is-default) "\\vref")
((reftex-typekey-check type reftex-fref-is-default) "\\fref")
(t "\\ref")))
@@ -451,7 +452,7 @@ When called with 2 C-u prefix args, disable magic word recognition."
(setq type (nth 1 (car labels))
form (or (cdr (assoc type reftex-typekey-to-format-alist))
form))
-
+
(cond
(no-insert
;; Just return the first label
@@ -465,7 +466,7 @@ When called with 2 C-u prefix args, disable magic word recognition."
sep (nth 2 (car labels))
sep1 (cdr (assoc sep reftex-multiref-punctuation))
labels (cdr labels))
- (when cut
+ (when cut
(backward-delete-char cut)
(setq cut nil))
@@ -476,9 +477,9 @@ When called with 2 C-u prefix args, disable magic word recognition."
;; do we have a special format?
(setq reftex-format-ref-function
(cond
- ((string= refstyle "\\vref") 'reftex-format-vref)
- ((string= refstyle "\\fref") 'reftex-format-fref)
- ((string= refstyle "\\Fref") 'reftex-format-Fref)
+ ((string= reftex-refstyle "\\vref") 'reftex-format-vref)
+ ((string= reftex-refstyle "\\fref") 'reftex-format-fref)
+ ((string= reftex-refstyle "\\Fref") 'reftex-format-Fref)
(t reftex-format-ref-function)))
;; ok, insert the reference
(if sep1 (insert sep1))
@@ -500,7 +501,7 @@ When called with 2 C-u prefix args, disable magic word recognition."
matched cell)
(save-excursion
(while (and (setq cell (pop words))
- (not (setq matched
+ (not (setq matched
(re-search-backward (car cell) bound t))))))
(if matched
(cons (cdr cell) (- (match-end 0) (match-end 1)))
@@ -548,7 +549,7 @@ When called with 2 C-u prefix args, disable magic word recognition."
(setq mode-line-format
(list "---- " 'mode-line-buffer-identification
" " 'global-mode-string " (" mode-name ")"
- " S<" 'refstyle ">"
+ " S<" 'reftex-refstyle ">"
" -%-"))
(cond
((= 0 (buffer-size))
@@ -563,9 +564,9 @@ When called with 2 C-u prefix args, disable magic word recognition."
context
counter
commented
- (or here-I-am offset)
+ (or here-I-am offset)
prefix
- nil ; no a toc buffer
+ nil ; no a toc buffer
))))
(here-I-am
(setq offset (reftex-get-offset buf here-I-am typekey)))
@@ -689,13 +690,13 @@ When called with 2 C-u prefix args, disable magic word recognition."
(defun reftex-query-label-type ()
;; Ask for label type
- (let ((key (reftex-select-with-char
+ (let ((key (reftex-select-with-char
reftex-type-query-prompt reftex-type-query-help 3)))
(unless (member (char-to-string key) reftex-typekey-list)
(error "No such label type: %s" (char-to-string key)))
(char-to-string key)))
-(defun reftex-show-label-location (data forward no-revisit
+(defun reftex-show-label-location (data forward no-revisit
&optional stay error)
;; View the definition site of a label in another window.
;; DATA is an entry from the docstruct list.
@@ -717,7 +718,7 @@ When called with 2 C-u prefix args, disable magic word recognition."
(throw 'exit nil))
;; Goto the file in another window
- (setq buffer
+ (setq buffer
(if no-revisit
(reftex-get-buffer-visiting file)
(reftex-get-file-buffer-force
@@ -783,7 +784,7 @@ When called with 2 C-u prefix args, disable magic word recognition."
(when (or (not (eq major-mode 'latex-mode))
(not font-lock-mode))
(latex-mode)
- (run-hook-with-args
+ (run-hook-with-args
'reftex-pre-refontification-functions
reftex-call-back-to-this-buffer 'reftex-hidden)
(turn-on-font-lock))
@@ -829,8 +830,16 @@ Optional prefix argument OTHER-WINDOW goes to the label in another window."
(reftex-access-scan-info)
(let* ((wcfg (current-window-configuration))
(docstruct (symbol-value reftex-docstruct-symbol))
- (label (completing-read "Label: " docstruct
- (lambda (x) (stringp (car x))) t))
+ ;; If point is inside a \ref{} or \pageref{}, use that as
+ ;; default value.
+ (default (when (looking-back "\\\\\\(?:page\\)?ref{[-a-zA-Z0-9_*.:]*")
+ (reftex-this-word "-a-zA-Z0-9_*.:")))
+ (label (completing-read (if default
+ (format "Label (default %s): " default)
+ "Label: ")
+ docstruct
+ (lambda (x) (stringp (car x))) t nil nil
+ default))
(selection (assoc label docstruct))
(where (progn
(reftex-show-label-location selection t nil 'stay)
@@ -838,10 +847,8 @@ Optional prefix argument OTHER-WINDOW goes to the label in another window."
(unless other-window
(set-window-configuration wcfg)
(switch-to-buffer (marker-buffer where))
- (goto-char where))
+ (goto-char where))
(reftex-unhighlight 0)))
-
-;; arch-tag: 52f14032-fb76-4d31-954f-750c72415675
;;; reftex-ref.el ends here
diff --git a/lisp/textmodes/reftex-sel.el b/lisp/textmodes/reftex-sel.el
index 90dc01a6bbe..bb6531d7980 100644
--- a/lisp/textmodes/reftex-sel.el
+++ b/lisp/textmodes/reftex-sel.el
@@ -6,6 +6,7 @@
;; Author: Carsten Dominik <dominik@science.uva.nl>
;; Maintainer: auctex-devel@gnu.org
;; Version: 4.31
+;; Package: reftex
;; This file is part of GNU Emacs.
@@ -368,22 +369,21 @@ During a selection process, these are the local bindings.
(defvar reftex-last-line nil)
(defvar reftex-select-marked nil)
-(defun reftex-select-item (prompt help-string keymap
+(defun reftex-select-item (reftex-select-prompt help-string keymap
&optional offset
call-back cb-flag)
-;; Select an item, using PROMPT. The function returns a key indicating
-;; an exit status, along with a data structure indicating which item was
-;; selected.
-;; HELP-STRING contains help. KEYMAP is a keymap with the available
-;; selection commands.
-;; OFFSET can be a label list item which will be selected at start.
-;; When it is t, point will start out at the beginning of the buffer.
-;; Any other value will cause restart where last selection left off.
-;; When CALL-BACK is given, it is a function which is called with the index
-;; of the element.
-;; CB-FLAG is the initial value of that flag.
-
- (let* (ev data last-data (selection-buffer (current-buffer)))
+ ;; Select an item, using REFTEX-SELECT-PROMPT.
+ ;; The function returns a key indicating an exit status, along with a
+ ;; data structure indicating which item was selected.
+ ;; HELP-STRING contains help. KEYMAP is a keymap with the available
+ ;; selection commands.
+ ;; OFFSET can be a label list item which will be selected at start.
+ ;; When it is t, point will start out at the beginning of the buffer.
+ ;; Any other value will cause restart where last selection left off.
+ ;; When CALL-BACK is given, it is a function which is called with the index
+ ;; of the element.
+ ;; CB-FLAG is the initial value of that flag.
+ (let (ev reftex-select-data last-data (selection-buffer (current-buffer)))
(setq reftex-select-marked nil)
@@ -403,7 +403,7 @@ During a selection process, these are the local bindings.
(use-local-map keymap)
(add-hook 'pre-command-hook 'reftex-select-pre-command-hook nil t)
(add-hook 'post-command-hook 'reftex-select-post-command-hook nil t)
- (princ prompt)
+ (princ reftex-select-prompt)
(set-marker reftex-recursive-edit-marker (point))
;; XEmacs does not run post-command-hook here
(and (featurep 'xemacs) (run-hooks 'post-command-hook))
@@ -425,19 +425,18 @@ During a selection process, these are the local bindings.
(reftex-kill-buffer "*RefTeX Help*")
(setq reftex-callback-fwd (not reftex-callback-fwd)) ;; ;-)))
(message "")
- (list ev data last-data)))
+ (list ev reftex-select-data last-data)))
;; The following variables are all bound dynamically in `reftex-select-item'.
;; The defvars are here only to silence the byte compiler.
(defvar found-list)
(defvar cb-flag)
-(defvar data)
-(defvar prompt)
+(defvar reftex-select-data)
+(defvar reftex-select-prompt)
(defvar last-data)
(defvar call-back)
(defvar help-string)
-(defvar refstyle)
;; The selection commands
@@ -447,15 +446,15 @@ During a selection process, these are the local bindings.
(defun reftex-select-post-command-hook ()
(let (b e)
- (setq data (get-text-property (point) :data))
- (setq last-data (or data last-data))
+ (setq reftex-select-data (get-text-property (point) :data))
+ (setq last-data (or reftex-select-data last-data))
- (when (and data cb-flag
+ (when (and reftex-select-data cb-flag
(not (equal reftex-last-follow-point (point))))
(setq reftex-last-follow-point (point))
- (funcall call-back data reftex-callback-fwd
+ (funcall call-back reftex-select-data reftex-callback-fwd
(not reftex-revisit-to-follow)))
- (if data
+ (if reftex-select-data
(setq b (or (previous-single-property-change
(1+ (point)) :data)
(point-min))
@@ -469,7 +468,7 @@ During a selection process, these are the local bindings.
(not (pos-visible-in-window-p e)))
(recenter '(4)))
(unless (current-message)
- (princ prompt))))
+ (princ reftex-select-prompt))))
(defun reftex-select-next (&optional arg)
"Move to next selectable item."
@@ -530,19 +529,22 @@ Useful for large TOC's."
(interactive)
(setq reftex-last-follow-point -1)
(setq cb-flag (not cb-flag)))
+
+(defvar reftex-refstyle) ; from reftex-reference
+
(defun reftex-select-toggle-varioref ()
"Toggle the macro used for referencing the label between \\ref and \\vref."
(interactive)
- (if (string= refstyle "\\ref")
- (setq refstyle "\\vref")
- (setq refstyle "\\ref"))
+ (if (string= reftex-refstyle "\\ref")
+ (setq reftex-refstyle "\\vref")
+ (setq reftex-refstyle "\\ref"))
(force-mode-line-update))
(defun reftex-select-toggle-fancyref ()
"Toggle the macro used for referencing the label between \\ref and \\vref."
(interactive)
- (setq refstyle
- (cond ((string= refstyle "\\ref") "\\fref")
- ((string= refstyle "\\fref") "\\Fref")
+ (setq reftex-refstyle
+ (cond ((string= reftex-refstyle "\\ref") "\\fref")
+ ((string= reftex-refstyle "\\fref") "\\Fref")
(t "\\ref")))
(force-mode-line-update))
(defun reftex-select-show-insertion-point ()
@@ -559,7 +561,7 @@ Useful for large TOC's."
(defun reftex-select-callback ()
"Show full context in another window."
(interactive)
- (if data (funcall call-back data reftex-callback-fwd nil) (ding)))
+ (if reftex-select-data (funcall call-back reftex-select-data reftex-callback-fwd nil) (ding)))
(defun reftex-select-accept ()
"Accept the currently selected item."
(interactive)
@@ -568,8 +570,8 @@ Useful for large TOC's."
"Accept the item at the mouse click."
(interactive "e")
(mouse-set-point ev)
- (setq data (get-text-property (point) :data))
- (setq last-data (or data last-data))
+ (setq reftex-select-data (get-text-property (point) :data))
+ (setq last-data (or reftex-select-data last-data))
(throw 'myexit 'return))
(defun reftex-select-read-label ()
"Use minibuffer to read a label to reference, with completion."
@@ -587,8 +589,8 @@ Useful for large TOC's."
(cond
((or (null key) (equal key "")))
(entry
- (setq data entry)
- (setq last-data data)
+ (setq reftex-select-data entry)
+ (setq last-data reftex-select-data)
(throw 'myexit 'return))
(t (throw 'myexit key)))))
@@ -735,5 +737,4 @@ Useful for large TOC's."
do (define-key reftex-select-bib-map (car x) (cdr x)))
-;; arch-tag: 842078ff-0586-4e0b-957e-536e08218464
;;; reftex-sel.el ends here
diff --git a/lisp/textmodes/reftex-toc.el b/lisp/textmodes/reftex-toc.el
index ae1690416b9..20903706a0e 100644
--- a/lisp/textmodes/reftex-toc.el
+++ b/lisp/textmodes/reftex-toc.el
@@ -6,6 +6,7 @@
;; Author: Carsten Dominik <dominik@science.uva.nl>
;; Maintainer: auctex-devel@gnu.org
;; Version: 4.31
+;; Package: reftex
;; This file is part of GNU Emacs.
@@ -544,8 +545,6 @@ Useful for large TOC's."
;; Promotion/Demotion stuff
-(defvar delta)
-(defvar mpos)
(defvar pro-or-de)
(defvar start-pos)
(defvar start-line)
@@ -574,7 +573,7 @@ point."
(if (bolp) 1 0)))))
(start-pos (point))
(pro-or-de (if (> delta 0) "de" "pro"))
- beg end entries data sections nsec mpos msg)
+ beg end entries data sections nsec msg)
(setq msg
(catch 'exit
(if (reftex-region-active-p)
@@ -601,7 +600,9 @@ point."
(reftex-toc-extract-section-number
(nth (1- nsec) entries)))))
;; Run through the list and prepare the changes.
- (setq entries (mapcar 'reftex-toc-promote-prepare entries))
+ (setq entries (mapcar
+ (lambda (e) (reftex-toc-promote-prepare e delta))
+ entries))
;; Ask for permission
(if (or (not reftex-toc-confirm-promotion) ; never confirm
(and (integerp reftex-toc-confirm-promotion) ; confirm if many
@@ -628,31 +629,26 @@ point."
(defun reftex-toc-restore-region (point-line &optional mark-line)
- (when mark-line
- (goto-char (point-min))
- (forward-line (1- mark-line))
- (setq mpos (point)))
- (when point-line
- (goto-char (point-min))
- (forward-line (1- point-line)))
- (if mark-line
- (progn
- (set-mark mpos)
- (if (featurep 'xemacs)
- (zmacs-activate-region)
- (setq mark-active t
- deactivate-mark nil)))))
-
-(defvar name1)
-(defvar dummy)
-(defvar dummy2)
-
-(defun reftex-toc-promote-prepare (x)
+ (let (mpos)
+ (when mark-line
+ (goto-char (point-min))
+ (forward-line (1- mark-line))
+ (setq mpos (point)))
+ (when point-line
+ (goto-char (point-min))
+ (forward-line (1- point-line)))
+ (when mark-line
+ (set-mark mpos)
+ (if (featurep 'xemacs)
+ (zmacs-activate-region)
+ (setq mark-active t
+ deactivate-mark nil)))))
+
+(defun reftex-toc-promote-prepare (x delta)
"Look at a toc entry and see if we could pro/demote it.
-Expects the level change DELTA to be dynamically scoped into this function.
This function prepares everything for the changes, but does not do it.
The return value is a list with information needed when doing the
-promotion/demotion later."
+promotion/demotion later. DELTA is the level change."
(let* ((data (car x))
(toc-point (cdr x))
(marker (nth 4 data))
@@ -677,7 +673,7 @@ promotion/demotion later."
(error "Something is wrong! Contact maintainer!")))
;; Section has changed, request scan and loading
;; We use a variable to delay until after the safe-exc.
- ;; because otherwise we loose the region.
+ ;; because otherwise we lose the region.
(setq load t)))
;; Scan document and load all files, this exits command
(if load (reftex-toc-load-all-files-for-promotion))) ; exits
@@ -688,7 +684,6 @@ promotion/demotion later."
(progn
(goto-char toc-point)
(error "Cannot %smote special sections" pro-or-de))))
- ;; Delta is dynamically scoped into here...
(newlevel (if (>= level 0) (+ delta level) (- level delta)))
(dummy2 (if (or (and (>= level 0) (= newlevel -1))
(and (< level 0) (= newlevel 0)))
@@ -702,7 +697,7 @@ promotion/demotion later."
(defun reftex-toc-promote-action (x)
"Change the level of a toc entry.
-DELTA and PRO-OR-DE are assumed to be dynamically scoped into this function."
+PRO-OR-DE is assumed to be dynamically scoped into this function."
(let* ((data (car x))
(name (nth 1 x))
(newname (nth 2 x))
@@ -1099,5 +1094,4 @@ always show the current section in connection with the option
["Help" reftex-toc-show-help t]))
-;; arch-tag: 92400ce2-0b86-4c89-a606-4ed71acea17e
;;; reftex-toc.el ends here
diff --git a/lisp/textmodes/reftex-vars.el b/lisp/textmodes/reftex-vars.el
index ce0ac32492d..5b83e7a43ad 100644
--- a/lisp/textmodes/reftex-vars.el
+++ b/lisp/textmodes/reftex-vars.el
@@ -6,6 +6,7 @@
;; Author: Carsten Dominik <dominik@science.uva.nl>
;; Maintainer: auctex-devel@gnu.org
;; Version: 4.31
+;; Package: reftex
;; This file is part of GNU Emacs.
diff --git a/lisp/textmodes/reftex.el b/lisp/textmodes/reftex.el
index 66dec462b83..2a2e725e92e 100644
--- a/lisp/textmodes/reftex.el
+++ b/lisp/textmodes/reftex.el
@@ -305,10 +305,6 @@
(defconst reftex-version "RefTeX version 4.31"
"Version string for RefTeX.")
-(defvar reftex-mode nil
- "Determines if RefTeX mode is active.")
-(make-variable-buffer-local 'reftex-mode)
-
(defvar reftex-mode-map (make-sparse-keymap)
"Keymap for RefTeX mode.")
@@ -504,8 +500,10 @@
"Turn on RefTeX mode."
(reftex-mode t))
+(put 'reftex-mode :included '(memq major-mode '(latex-mode tex-mode)))
+(put 'reftex-mode :menu-tag "RefTeX Mode")
;;;###autoload
-(defun reftex-mode (&optional arg)
+(define-minor-mode reftex-mode
"Minor mode with distinct support for \\label, \\ref and \\cite in LaTeX.
\\<reftex-mode-map>A Table of Contents of the entire (multifile) document with browsing
@@ -535,11 +533,7 @@ Under X, these and other functions will also be available as `Ref' menu
on the menu bar.
------------------------------------------------------------------------------"
-
- (interactive "P")
- (setq reftex-mode (not (or (and (null arg) reftex-mode)
- (<= (prefix-numeric-value arg) 0))))
-
+ :lighter " Ref" :keymap reftex-mode-map
(if reftex-mode
(progn
;; Mode was turned on
@@ -565,24 +559,10 @@ on the menu bar.
(modify-syntax-entry ?\' "." reftex-syntax-table-for-bib)
(modify-syntax-entry ?\" "." reftex-syntax-table-for-bib)
(modify-syntax-entry ?\[ "." reftex-syntax-table-for-bib)
- (modify-syntax-entry ?\] "." reftex-syntax-table-for-bib)
-
- (run-hooks 'reftex-mode-hook))
+ (modify-syntax-entry ?\] "." reftex-syntax-table-for-bib))
;; Mode was turned off
(easy-menu-remove reftex-mode-menu)))
-(if (fboundp 'add-minor-mode)
- ;; Use it so that we get the extras
- (progn
- (put 'reftex-mode :included '(memq major-mode '(latex-mode tex-mode)))
- (put 'reftex-mode :menu-tag "RefTeX Mode")
- (add-minor-mode 'reftex-mode " Ref" reftex-mode-map))
- ;; The standard way
- (unless (assoc 'reftex-mode minor-mode-alist)
- (push '(reftex-mode " Ref") minor-mode-alist))
- (unless (assoc 'reftex-mode minor-mode-map-alist)
- (push (cons 'reftex-mode reftex-mode-map) minor-mode-map-alist)))
-
(defvar reftex-docstruct-symbol)
(defun reftex-kill-buffer-hook ()
"Save RefTeX's parse file for this buffer if the information has changed."
@@ -619,17 +599,16 @@ on the menu bar.
(defvar font-lock-mode)
(defvar font-lock-keywords)
(defvar font-lock-fontify-region-function)
-(defvar font-lock-syntactic-keywords)
;;; =========================================================================
;;;
;;; Multibuffer Variables
;;;
-;;; Technical notes: These work as follows: We keep just one list
-;;; of labels for each master file - this can save a lot of memory.
-;;; `reftex-master-index-list' is an alist which connects the true file name
-;;; of each master file with the symbols holding the information on that
-;;; document. Each buffer has local variables which point to these symbols.
+;; Technical notes: These work as follows: We keep just one list
+;; of labels for each master file - this can save a lot of memory.
+;; `reftex-master-index-list' is an alist which connects the true file name
+;; of each master file with the symbols holding the information on that
+;; document. Each buffer has local variables which point to these symbols.
;; List of variables which handle the multifile stuff.
;; This list is used to tie, untie, and reset these symbols.
diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el
index d4de4e49b93..ab2c27563b0 100644
--- a/lisp/textmodes/remember.el
+++ b/lisp/textmodes/remember.el
@@ -1,7 +1,7 @@
;;; remember --- a mode for quickly jotting down things to remember
-;; Copyright (C) 1999, 2000, 2001, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2000, 2001, 2003, 2004, 2005, 2006, 2007, 2008,
+;; 2009, 2010 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
;; Created: 29 Mar 1999
@@ -315,12 +315,6 @@ With a prefix or a visible region, use the region as INITIAL."
(let ((remember-in-new-frame t))
(remember initial)))
-(defsubst remember-time-to-seconds (time)
- "Convert TIME to a floating point number."
- (+ (* (car time) 65536.0)
- (cadr time)
- (/ (or (car (cdr (cdr time))) 0) 1000000.0)))
-
(defsubst remember-mail-date (&optional rfc822-p)
"Return a simple date. Nothing fancy."
(if rfc822-p
@@ -355,8 +349,7 @@ In which case `remember-mailbox' should be the name of the mailbox.
Each piece of pseudo-mail created will have an `X-Todo-Priority'
field, for the purpose of appropriate splitting."
(let ((who (read-string "Who is this item related to? "))
- (moment
- (format "%.0f" (remember-time-to-seconds (current-time))))
+ (moment (format "%.0f" (float-time)))
(desc (remember-buffer-desc))
(text (buffer-string)))
(with-temp-buffer
@@ -535,5 +528,4 @@ the data away for latter retrieval, and possible indexing.
\\{remember-mode-map}"
(set-keymap-parent remember-mode-map nil))
-;; arch-tag: 59312a05-06c7-4da1-b6f7-5ea41c9d5577
;;; remember.el ends here
diff --git a/lisp/textmodes/rst.el b/lisp/textmodes/rst.el
index 3f21fbe7a2c..5bf1a7c7894 100644
--- a/lisp/textmodes/rst.el
+++ b/lisp/textmodes/rst.el
@@ -698,11 +698,9 @@ existing decoration, they are removed before adding the
requested decoration."
(interactive)
- (let (marker
- len)
-
(end-of-line)
- (setq marker (point-marker))
+ (let ((marker (point-marker))
+ len)
;; Fixup whitespace at the beginning and end of the line
(if (or (null indent) (eq style 'simple))
@@ -789,7 +787,7 @@ This function does not detect the hierarchy of decorations, it
just finds all of them in a file. You can then invoke another
function to remove redundancies and inconsistencies."
- (let (positions
+ (let ((positions ())
(curline 1))
;; Iterate over all the section titles/decorations in the file.
(save-excursion
@@ -870,7 +868,7 @@ A decoration can be said to exist if the style is not nil.
A point can be specified to go to the given location before
extracting the decoration."
- (let (char style indent)
+ (let (char style)
(save-excursion
(if point (goto-char point))
(beginning-of-line)
@@ -879,10 +877,10 @@ extracting the decoration."
(forward-line -1)
(rst-line-homogeneous-nodent-p)))
- (under (save-excursion
- (forward-line +1)
- (rst-line-homogeneous-nodent-p)))
- )
+ (under (save-excursion
+ (forward-line +1)
+ (rst-line-homogeneous-nodent-p)))
+ )
;; Check that the line above the overline is not part of a title
;; above it.
@@ -910,15 +908,11 @@ extracting the decoration."
;; Both overline and underline.
(t
(setq char under
- style 'over-and-under))
- )
- )
- )
- ;; Find indentation.
- (setq indent (save-excursion (back-to-indentation) (current-column)))
- )
- ;; Return values.
- (list char style indent)))
+ style 'over-and-under)))))
+ ;; Return values.
+ (list char style
+ ;; Find indentation.
+ (save-excursion (back-to-indentation) (current-column))))))
(defun rst-get-decorations-around (&optional alldecos)
@@ -1041,7 +1035,7 @@ b. a negative numerical argument, which generally inverts the
(interactive)
(let* (;; Save our original position on the current line.
- (origpt (set-marker (make-marker) (point)))
+ (origpt (point-marker))
;; Parse the positive and negative prefix arguments.
(reverse-direction
@@ -1395,32 +1389,28 @@ hierarchy is similar to that used by `rst-adjust-decoration'."
;; Create a list of markers for all the decorations which are found within
;; the region.
(save-excursion
- (let (m line)
+ (let (line)
(while (and cur (< (setq line (caar cur)) region-end-line))
- (setq m (make-marker))
(goto-char (point-min))
(forward-line (1- line))
- (push (list (set-marker m (point)) (cdar cur)) marker-list)
+ (push (list (point-marker) (cdar cur)) marker-list)
(setq cur (cdr cur)) ))
;; Apply modifications.
- (let (nextdeco)
- (dolist (p marker-list)
- ;; Go to the decoration to promote.
- (goto-char (car p))
-
- ;; Rotate the next decoration.
- (setq nextdeco (rst-get-next-decoration
- (cadr p) hier suggestion demote))
-
- ;; Update the decoration.
- (apply 'rst-update-section nextdeco)
-
- ;; Clear marker to avoid slowing down the editing after we're done.
- (set-marker (car p) nil)
- ))
+ (dolist (p marker-list)
+ ;; Go to the decoration to promote.
+ (goto-char (car p))
+
+ ;; Update the decoration.
+ (apply 'rst-update-section
+ ;; Rotate the next decoration.
+ (rst-get-next-decoration
+ (cadr p) hier suggestion demote))
+
+ ;; Clear marker to avoid slowing down the editing after we're done.
+ (set-marker (car p) nil))
(setq deactivate-mark nil)
- )))
+ )))
@@ -1463,11 +1453,10 @@ in order to adapt it to our preferred style."
(levels-and-markers (mapcar
(lambda (deco)
(cons (rst-position (cdr deco) hier)
- (let ((m (make-marker)))
+ (progn
(goto-char (point-min))
(forward-line (1- (car deco)))
- (set-marker m (point))
- m)))
+ (point-marker))))
alldecos))
)
(dolist (lm levels-and-markers)
@@ -1511,7 +1500,7 @@ section levels."
"Find all the positions of prefixes in region between BEG and END.
This is used to find bullets and enumerated list items. PFX-RE
is a regular expression for matching the lines with items."
- (let (pfx)
+ (let ((pfx ()))
(save-excursion
(goto-char beg)
(while (< (point) end)
@@ -1635,10 +1624,9 @@ child. This has advantages later in processing the graph."
(forward-line (1- (car deco)))
(list (gethash (cons (cadr deco) (caddr deco)) levels)
(rst-get-stripped-line)
- (let ((m (make-marker)))
+ (progn
(beginning-of-line 1)
- (set-marker m (point)))
- ))
+ (point-marker))))
alldecos)))
(let ((lcontnr (cons nil lines)))
@@ -1787,7 +1775,7 @@ The TOC is inserted indented at the current column."
(delete-region init-point (+ init-point (length initial-indent)))
;; Delete the last newline added.
- (delete-backward-char 1)
+ (delete-char -1)
)))
(defun rst-toc-insert-node (node level indent pfx)
@@ -2057,11 +2045,11 @@ brings the cursor in that section."
"In `rst-toc' mode, go to the occurrence whose line you click on.
EVENT is the input event."
(interactive "e")
- (let (pos)
+ (let ((pos
(with-current-buffer (window-buffer (posn-window (event-end event)))
(save-excursion
(goto-char (posn-point (event-end event)))
- (setq pos (rst-toc-mode-find-section))))
+ (rst-toc-mode-find-section)))))
(pop-to-buffer (marker-buffer pos))
(goto-char pos)
(recenter 5)))
@@ -2306,8 +2294,8 @@ of (COLUMN-NUMBER . LINE) pairs."
(defun rst-shift-region-guts (find-next-fun offset-fun)
"(See `rst-shift-region-right' for a description)."
- (let* ((mbeg (set-marker (make-marker) (region-beginning)))
- (mend (set-marker (make-marker) (region-end)))
+ (let* ((mbeg (copy-marker (region-beginning)))
+ (mend (copy-marker (region-end)))
(tabs (rst-compute-bullet-tabs mbeg))
(leftmostcol (rst-find-leftmost-column (region-beginning) (region-end)))
)
@@ -2386,8 +2374,8 @@ Also, if invoked with a negative prefix arg, the entire
indentation is removed, up to the leftmost character in the
region, and automatic filling is disabled."
(interactive "P")
- (let ((mbeg (set-marker (make-marker) (region-beginning)))
- (mend (set-marker (make-marker) (region-end)))
+ (let ((mbeg (copy-marker (region-beginning)))
+ (mend (copy-marker (region-end)))
(leftmostcol (rst-find-leftmost-column
(region-beginning) (region-end)))
(rst-shift-fill-region
@@ -2421,8 +2409,7 @@ Set FIRST-ONLY to true if you want to callback on the first line
of each paragraph only."
`(save-excursion
(let ((leftcol (rst-find-leftmost-column ,beg ,end))
- (endm (set-marker (make-marker) ,end))
- )
+ (endm (copy-marker ,end)))
(do* (;; Iterate lines
(l (progn (goto-char ,beg) (back-to-indentation))
@@ -2460,8 +2447,7 @@ first of a paragraph."
`(save-excursion
(let ((,leftmost (rst-find-leftmost-column ,beg ,end))
- (endm (set-marker (make-marker) ,end))
- )
+ (endm (copy-marker ,end)))
(do* (;; Iterate lines
(l (progn (goto-char ,beg) (back-to-indentation))
@@ -2538,9 +2524,7 @@ region to enumerated lists, renumbering as necessary."
(let* (;; Find items and convert the positions to markers.
(items (mapcar
(lambda (x)
- (cons (let ((m (make-marker)))
- (set-marker m (car x))
- m)
+ (cons (copy-marker (car x))
(cdr x)))
(rst-find-pfx-in-region beg end rst-re-items)))
(count 1)
@@ -2585,62 +2569,132 @@ With prefix argument set the empty lines too."
:group 'faces
:version "21.1")
-(defcustom rst-block-face 'font-lock-keyword-face
+(defface rst-block '((t :inherit font-lock-keyword-face))
+ "Face used for all syntax marking up a special block."
+ :version "24.1"
+ :group 'rst-faces)
+
+(defcustom rst-block-face 'rst-block
"All syntax marking up a special block."
+ :version "24.1"
:group 'rst-faces
:type '(face))
+(make-obsolete-variable 'rst-block-face
+ "customize the face `rst-block' instead."
+ "24.1")
-(defcustom rst-external-face 'font-lock-type-face
+(defface rst-external '((t :inherit font-lock-type-face))
+ "Face used for field names and interpreted text."
+ :version "24.1"
+ :group 'rst-faces)
+
+(defcustom rst-external-face 'rst-external
"Field names and interpreted text."
+ :version "24.1"
:group 'rst-faces
:type '(face))
+(make-obsolete-variable 'rst-external-face
+ "customize the face `rst-external' instead."
+ "24.1")
+
+(defface rst-definition '((t :inherit font-lock-function-name-face))
+ "Face used for all other defining constructs."
+ :version "24.1"
+ :group 'rst-faces)
-(defcustom rst-definition-face 'font-lock-function-name-face
+(defcustom rst-definition-face 'rst-definition
"All other defining constructs."
+ :version "24.1"
:group 'rst-faces
:type '(face))
-
-(defcustom rst-directive-face
- ;; XEmacs compatibility
- (if (boundp 'font-lock-builtin-face)
- 'font-lock-builtin-face
- 'font-lock-preprocessor-face)
+(make-obsolete-variable 'rst-definition-face
+ "customize the face `rst-definition' instead."
+ "24.1")
+
+;; XEmacs compatibility (?).
+(defface rst-directive (if (boundp 'font-lock-builtin-face)
+ '((t :inherit font-lock-builtin-face))
+ '((t :inherit font-lock-preprocessor-face)))
+ "Face used for directives and roles."
+ :version "24.1"
+ :group 'rst-faces)
+
+(defcustom rst-directive-face 'rst-directive
"Directives and roles."
:group 'rst-faces
:type '(face))
+(make-obsolete-variable 'rst-directive-face
+ "customize the face `rst-directive' instead."
+ "24.1")
-(defcustom rst-comment-face 'font-lock-comment-face
+(defface rst-comment '((t :inherit font-lock-comment-face))
+ "Face used for comments."
+ :version "24.1"
+ :group 'rst-faces)
+
+(defcustom rst-comment-face 'rst-comment
"Comments."
+ :version "24.1"
:group 'rst-faces
:type '(face))
+(make-obsolete-variable 'rst-comment-face
+ "customize the face `rst-comment' instead."
+ "24.1")
+
+(defface rst-emphasis1 '((t :inherit italic))
+ "Face used for simple emphasis."
+ :version "24.1"
+ :group 'rst-faces)
-(defcustom rst-emphasis1-face
- ;; XEmacs compatibility
- (if (facep 'italic)
- ''italic
- 'italic)
+(defcustom rst-emphasis1-face 'rst-emphasis1
"Simple emphasis."
+ :version "24.1"
:group 'rst-faces
:type '(face))
+(make-obsolete-variable 'rst-emphasis1-face
+ "customize the face `rst-emphasis1' instead."
+ "24.1")
+
+(defface rst-emphasis2 '((t :inherit bold))
+ "Face used for double emphasis."
+ :version "24.1"
+ :group 'rst-faces)
-(defcustom rst-emphasis2-face
- ;; XEmacs compatibility
- (if (facep 'bold)
- ''bold
- 'bold)
+(defcustom rst-emphasis2-face 'rst-emphasis2
"Double emphasis."
:group 'rst-faces
:type '(face))
+(make-obsolete-variable 'rst-emphasis2-face
+ "customize the face `rst-emphasis2' instead."
+ "24.1")
-(defcustom rst-literal-face 'font-lock-string-face
+(defface rst-literal '((t :inherit font-lock-string-face))
+ "Face used for literal text."
+ :version "24.1"
+ :group 'rst-faces)
+
+(defcustom rst-literal-face 'rst-literal
"Literal text."
+ :version "24.1"
:group 'rst-faces
:type '(face))
+(make-obsolete-variable 'rst-literal-face
+ "customize the face `rst-literal' instead."
+ "24.1")
+
+(defface rst-reference '((t :inherit font-lock-variable-name-face))
+ "Face used for references to a definition."
+ :version "24.1"
+ :group 'rst-faces)
-(defcustom rst-reference-face 'font-lock-variable-name-face
+(defcustom rst-reference-face 'rst-reference
"References to a definition."
+ :version "24.1"
:group 'rst-faces
:type '(face))
+(make-obsolete-variable 'rst-reference-face
+ "customize the face `rst-reference' instead."
+ "24.1")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -2789,10 +2843,7 @@ details check the Rst Faces Defaults group."
;; There seems to be a bug leading to error "Stack overflow in regexp
;; matcher" when "|" or "\\*" are the characters searched for
- (re-imendbeg
- (if (< emacs-major-version 21)
- "]"
- "\\]\\|\\\\."))
+ (re-imendbeg "\\]\\|\\\\.")
;; inline markup content end
(re-imend (concat re-imendbeg "\\)*[^\t \\\\]\\)"))
;; inline markup content without asterisk
@@ -2818,94 +2869,76 @@ details check the Rst Faces Defaults group."
;; Simple `Body Elements`_
;; `Bullet Lists`_
- (list
- (concat re-bol "\\([-*+]" re-blksep1 "\\)")
- 1 rst-block-face)
+ `(,(concat re-bol "\\([-*+]" re-blksep1 "\\)")
+ 1 rst-block-face)
;; `Enumerated Lists`_
- (list
- (concat re-bol "\\((?\\(#\\|[0-9]+\\|[A-Za-z]\\|[IVXLCMivxlcm]+\\)[.)]"
- re-blksep1 "\\)")
- 1 rst-block-face)
+ `(,(concat re-bol "\\((?\\(#\\|[0-9]+\\|[A-Za-z]\\|[IVXLCMivxlcm]+\\)[.)]"
+ re-blksep1 "\\)")
+ 1 rst-block-face)
;; `Definition Lists`_ FIXME: missing
;; `Field Lists`_
- (list
- (concat re-bol "\\(:[^:\n]+:\\)" re-blksep1)
- 1 rst-external-face)
+ `(,(concat re-bol "\\(:[^:\n]+:\\)" re-blksep1)
+ 1 rst-external-face)
;; `Option Lists`_
- (list
- (concat re-bol "\\(\\(\\(\\([-+/]\\|--\\)\\sw\\(-\\|\\sw\\)*"
- "\\([ =]\\S +\\)?\\)\\(,[\t ]\\)?\\)+\\)\\($\\|[\t ]\\{2\\}\\)")
- 1 rst-block-face)
+ `(,(concat re-bol "\\(\\(\\(\\([-+/]\\|--\\)\\sw\\(-\\|\\sw\\)*"
+ "\\([ =]\\S +\\)?\\)\\(,[\t ]\\)?\\)+\\)\\($\\|[\t ]\\{2\\}\\)")
+ 1 rst-block-face)
;; `Tables`_ FIXME: missing
;; All the `Explicit Markup Blocks`_
;; `Footnotes`_ / `Citations`_
- (list
- (concat re-bol "\\(" re-ems "\\[[^[\n]+\\]\\)" re-blksep1)
+ `(,(concat re-bol "\\(" re-ems "\\[[^[\n]+\\]\\)" re-blksep1)
1 rst-definition-face)
;; `Directives`_ / `Substitution Definitions`_
- (list
- (concat re-bol "\\(" re-ems "\\)\\(\\(|[^|\n]+|[\t ]+\\)?\\)\\("
- re-sym1 "+::\\)" re-blksep1)
- (list 1 rst-directive-face)
- (list 2 rst-definition-face)
- (list 4 rst-directive-face))
+ `(,(concat re-bol "\\(" re-ems "\\)\\(\\(|[^|\n]+|[\t ]+\\)?\\)\\("
+ re-sym1 "+::\\)" re-blksep1)
+ (1 rst-directive-face)
+ (2 rst-definition-face)
+ (4 rst-directive-face))
;; `Hyperlink Targets`_
- (list
- (concat re-bol "\\(" re-ems "_\\([^:\\`\n]\\|\\\\.\\|`[^`\n]+`\\)+:\\)"
- re-blksep1)
- 1 rst-definition-face)
- (list
- (concat re-bol "\\(__\\)" re-blksep1)
- 1 rst-definition-face)
+ `(,(concat re-bol "\\(" re-ems "_\\([^:\\`\n]\\|\\\\.\\|`[^`\n]+`\\)+:\\)"
+ re-blksep1)
+ 1 rst-definition-face)
+ `(,(concat re-bol "\\(__\\)" re-blksep1)
+ 1 rst-definition-face)
;; All `Inline Markup`_
;; FIXME: Condition 5 preventing fontification of e.g. "*" not implemented
;; `Strong Emphasis`_
- (list
- (concat re-imp1 "\\(\\*\\*" re-ima2 "\\*\\*\\)" re-ims1)
- 2 rst-emphasis2-face)
+ `(,(concat re-imp1 "\\(\\*\\*" re-ima2 "\\*\\*\\)" re-ims1)
+ 2 rst-emphasis2-face)
;; `Emphasis`_
- (list
- (concat re-imp1 "\\(\\*" re-ima2 "\\*\\)" re-ims1)
- 2 rst-emphasis1-face)
+ `(,(concat re-imp1 "\\(\\*" re-ima2 "\\*\\)" re-ims1)
+ 2 rst-emphasis1-face)
;; `Inline Literals`_
- (list
- (concat re-imp1 "\\(``" re-imb2 "``\\)" re-ims1)
- 2 rst-literal-face)
+ `(,(concat re-imp1 "\\(``" re-imb2 "``\\)" re-ims1)
+ 2 rst-literal-face)
;; `Inline Internal Targets`_
- (list
- (concat re-imp1 "\\(_`" re-imb2 "`\\)" re-ims1)
- 2 rst-definition-face)
+ `(,(concat re-imp1 "\\(_`" re-imb2 "`\\)" re-ims1)
+ 2 rst-definition-face)
;; `Hyperlink References`_
;; FIXME: `Embedded URIs`_ not considered
- (list
- (concat re-imp1 "\\(\\(`" re-imb2 "`\\|\\(\\sw\\(\\sw\\|-\\)+\\sw\\)\\)__?\\)" re-ims1)
+ `(,(concat re-imp1 "\\(\\(`" re-imb2 "`\\|\\(\\sw\\(\\sw\\|-\\)+\\sw\\)\\)__?\\)" re-ims1)
2 rst-reference-face)
;; `Interpreted Text`_
- (list
- (concat re-imp1 "\\(\\(:" re-sym1 "+:\\)?\\)\\(`" re-imb2 "`\\)\\(\\(:"
- re-sym1 "+:\\)?\\)" re-ims1)
- (list 2 rst-directive-face)
- (list 5 rst-external-face)
- (list 8 rst-directive-face))
+ `(,(concat re-imp1 "\\(\\(:" re-sym1 "+:\\)?\\)\\(`" re-imb2 "`\\)\\(\\(:"
+ re-sym1 "+:\\)?\\)" re-ims1)
+ (2 rst-directive-face)
+ (5 rst-external-face)
+ (8 rst-directive-face))
;; `Footnote References`_ / `Citation References`_
- (list
- (concat re-imp1 "\\(\\[[^]]+\\]_\\)" re-ims1)
- 2 rst-reference-face)
+ `(,(concat re-imp1 "\\(\\[[^]]+\\]_\\)" re-ims1)
+ 2 rst-reference-face)
;; `Substitution References`_
- (list
- (concat re-imp1 "\\(|" re-imv2 "|\\)" re-ims1)
- 2 rst-reference-face)
+ `(,(concat re-imp1 "\\(|" re-imv2 "|\\)" re-ims1)
+ 2 rst-reference-face)
;; `Standalone Hyperlinks`_
- (list
- ;; FIXME: This takes it easy by using a whitespace as delimiter
- (concat re-imp1 "\\(" re-uris1 ":\\S +\\)" re-ims1)
- 2 rst-definition-face)
- (list
- (concat re-imp1 "\\(" re-sym1 "+@" re-sym1 "+\\)" re-ims1)
- 2 rst-definition-face)
+ `(;; FIXME: This takes it easy by using a whitespace as delimiter
+ ,(concat re-imp1 "\\(" re-uris1 ":\\S +\\)" re-ims1)
+ 2 rst-definition-face)
+ `(,(concat re-imp1 "\\(" re-sym1 "+@" re-sym1 "+\\)" re-ims1)
+ 2 rst-definition-face)
;; Do all block fontification as late as possible so 'append works
@@ -2914,7 +2947,7 @@ details check the Rst Faces Defaults group."
(list
re-ado2)
(if (not rst-mode-lazy)
- (list 1 rst-block-face)
+ '(1 rst-block-face)
(list
(list 'rst-font-lock-handle-adornment
'(progn
@@ -2934,7 +2967,7 @@ details check the Rst Faces Defaults group."
(list
(concat re-bol "\\(" re-ems "\\)\[^[|_]\\([^:\n]\\|:\\([^:\n]\\|$\\)\\)*$")
- (list 1 rst-comment-face))
+ '(1 rst-comment-face))
(if rst-mode-lazy
(list
(list 'rst-font-lock-find-unindented-line
@@ -2942,12 +2975,12 @@ details check the Rst Faces Defaults group."
(setq rst-font-lock-indentation-point (match-end 1))
(point-max))
nil
- (list 0 rst-comment-face 'append)))))
+ '(0 rst-comment-face append)))))
(append
(list
(concat re-bol "\\(" re-emt "\\)\\(\\s *\\)$")
- (list 1 rst-comment-face)
- (list 2 rst-comment-face))
+ '(1 rst-comment-face)
+ '(2 rst-comment-face))
(if rst-mode-lazy
(list
(list 'rst-font-lock-find-unindented-line
@@ -2955,13 +2988,13 @@ details check the Rst Faces Defaults group."
(setq rst-font-lock-indentation-point 'next)
(point-max))
nil
- (list 0 rst-comment-face 'append)))))
+ '(0 rst-comment-face append)))))
;; `Literal Blocks`_
(append
(list
(concat re-bol "\\(\\([^.\n]\\|\\.[^.\n]\\).*\\)?\\(::\\)$")
- (list 3 rst-block-face))
+ '(3 rst-block-face))
(if rst-mode-lazy
(list
(list 'rst-font-lock-find-unindented-line
@@ -2969,14 +3002,14 @@ details check the Rst Faces Defaults group."
(setq rst-font-lock-indentation-point t)
(point-max))
nil
- (list 0 rst-literal-face 'append)))))
+ '(0 rst-literal-face append)))))
;; `Doctest Blocks`_
(append
(list
(concat re-bol "\\(>>>\\|\\.\\.\\.\\)\\(.+\\)")
- (list 1 rst-block-face)
- (list 2 rst-literal-face)))
+ '(1 rst-block-face)
+ '(2 rst-literal-face)))
)))
diff --git a/lisp/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el
index b9d52acdeba..47d2f7a45e0 100644
--- a/lisp/textmodes/sgml-mode.el
+++ b/lisp/textmodes/sgml-mode.el
@@ -100,7 +100,13 @@ This takes effect when first loading the `sgml-mode' library.")
(define-key map "\C-c\C-d" 'sgml-delete-tag)
(define-key map "\C-c\^?" 'sgml-delete-tag)
(define-key map "\C-c?" 'sgml-tag-help)
+ (define-key map "\C-c]" 'sgml-close-tag)
(define-key map "\C-c/" 'sgml-close-tag)
+
+ ;; Redundant keybindings, for consistency with TeX mode.
+ (define-key map "\C-c\C-o" 'sgml-tag)
+ (define-key map "\C-c\C-e" 'sgml-close-tag)
+
(define-key map "\C-c8" 'sgml-name-8bit-mode)
(define-key map "\C-c\C-v" 'sgml-validate)
(when sgml-quick-keys
@@ -288,11 +294,12 @@ Any terminating `>' or `/' is not matched.")
(defvar sgml-font-lock-keywords sgml-font-lock-keywords-1
"*Rules for highlighting SGML code. See also `sgml-tag-face-alist'.")
-(defvar sgml-font-lock-syntactic-keywords
+(defconst sgml-syntax-propertize-function
+ (syntax-propertize-rules
;; Use the `b' style of comments to avoid interference with the -- ... --
;; comments recognized when `sgml-specials' includes ?-.
;; FIXME: beware of <!--> blabla <!--> !!
- '(("\\(<\\)!--" (1 "< b"))
+ ("\\(<\\)!--" (1 "< b"))
("--[ \t\n]*\\(>\\)" (1 "> b"))
;; Double quotes outside of tags should not introduce strings.
;; Be careful to call `syntax-ppss' on a position before the one we're
@@ -472,9 +479,9 @@ Do \\[describe-key] on the following bindings to discover what they do.
'((sgml-font-lock-keywords
sgml-font-lock-keywords-1
sgml-font-lock-keywords-2)
- nil t nil nil
- (font-lock-syntactic-keywords
- . sgml-font-lock-syntactic-keywords)))
+ nil t))
+ (set (make-local-variable 'syntax-propertize-function)
+ sgml-syntax-propertize-function)
(set (make-local-variable 'facemenu-add-face-function)
'sgml-mode-facemenu-add-face-function)
(set (make-local-variable 'sgml-xml-mode) (sgml-xml-guess))
@@ -521,7 +528,7 @@ Behaves electrically if `sgml-quick-keys' is non-nil."
(insert-char ?/ 1)
(indent-according-to-mode))
((eq sgml-quick-keys 'close)
- (delete-backward-char 1)
+ (delete-char -1)
(sgml-close-tag))
(t
(sgml-slash-matching arg))))
@@ -578,7 +585,7 @@ encoded keyboard operation."
(insert ?&)
(or char
(setq char (read-quoted-char "Enter char or octal number")))
- (delete-backward-char 1)
+ (delete-char -1)
(insert char)
(undo-boundary)
(sgml-namify-char))
@@ -596,7 +603,7 @@ Uses `sgml-char-names'."
((encode-char char 'ucs)))))
(if (not name)
(error "Don't know the name of `%c'" char)
- (delete-backward-char 1)
+ (delete-char -1)
(insert (format (if (numberp name) "&#%d;" "&%s;") name)))))
(defun sgml-name-self ()
@@ -702,7 +709,7 @@ If QUIET, do not print a message when there are no attributes for TAG."
(sgml-value (assoc (downcase attribute) alist))
(setq i (1- i))))
(if (eq (preceding-char) ?\s)
- (delete-backward-char 1)))
+ (delete-char -1)))
car)))
(defun sgml-auto-attributes (arg)
@@ -1112,7 +1119,7 @@ See `sgml-tag-alist' for info about attribute rules."
(setq alist (skeleton-read '(completing-read "Value: " (cdr alist))))
(if (string< "" alist)
(insert alist ?\")
- (delete-backward-char 2)))
+ (delete-char -2)))
(insert "=\"")
(if (cdr alist)
(insert (skeleton-read '(completing-read "Value: " alist)))
diff --git a/lisp/textmodes/spell.el b/lisp/textmodes/spell.el
index fe31bc57d95..dc4859ac53c 100644
--- a/lisp/textmodes/spell.el
+++ b/lisp/textmodes/spell.el
@@ -1,7 +1,7 @@
;;; spell.el --- spelling correction interface for Emacs
-;; Copyright (C) 1985, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+;; 2009, 2010 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: wp, unix
@@ -37,12 +37,12 @@
:group 'applications)
(defcustom spell-command "spell"
- "*Command to run the spell program."
+ "Command to run the spell program."
:type 'string
:group 'spell)
(defcustom spell-filter nil
- "*Filter function to process text before passing it to spell program.
+ "Filter function to process text before passing it to spell program.
This function might remove text-processor commands.
nil means don't alter the text before checking it."
:type '(choice (const nil) function)
diff --git a/lisp/textmodes/table.el b/lisp/textmodes/table.el
index 44933bff327..eb2d4849a32 100644
--- a/lisp/textmodes/table.el
+++ b/lisp/textmodes/table.el
@@ -6,7 +6,6 @@
;; Keywords: wp, convenience
;; Author: Takaaki Ota <Takaaki.Ota@am.sony.com>
;; Created: Sat Jul 08 2000 13:28:45 (PST)
-;; Revised: Fri Aug 21 2009 00:16:58 (PDT)
;; This file is part of GNU Emacs.
@@ -640,14 +639,10 @@
;;;
(defgroup table nil
- "Text based table manipulation utilities.
-See `table-insert' for examples about how to use."
+ "Text based table manipulation utilities."
:tag "Table"
:prefix "table-"
- :group 'editing
:group 'wp
- :group 'paragraphs
- :group 'fill
:version "22.1")
(defgroup table-hooks nil
@@ -655,7 +650,7 @@ See `table-insert' for examples about how to use."
:group 'table)
(defcustom table-time-before-update 0.2
- "*Time in seconds before updating the cell contents after typing.
+ "Time in seconds before updating the cell contents after typing.
Updating the cell contents on the screen takes place only after this
specified amount of time has passed after the last modification to the
cell contents. When the contents of a table cell changes repetitively
@@ -669,7 +664,7 @@ annoying delay before the typed result start appearing on the screen."
:group 'table)
(defcustom table-time-before-reformat 0.2
- "*Time in seconds before reformatting the table.
+ "Time in seconds before reformatting the table.
This many seconds must pass in addition to `table-time-before-update'
before the table is updated with newly widened width or heightened
height."
@@ -678,7 +673,7 @@ height."
:group 'table)
(defcustom table-command-prefix [(control c) (control c)]
- "*Key sequence to be used as prefix for table command key bindings."
+ "Key sequence to be used as prefix for table command key bindings."
:type '(vector (repeat :inline t sexp))
:tag "Table Command Prefix"
:group 'table)
@@ -689,30 +684,30 @@ height."
(((class color))
(:foreground "gray90" :background "blue"))
(t (:bold t)))
- "*Face used for table cell contents."
+ "Face used for table cell contents."
:tag "Cell Face"
:group 'table)
(defcustom table-cell-horizontal-chars "-="
- "*Characters that may be used for table cell's horizontal border line."
+ "Characters that may be used for table cell's horizontal border line."
:tag "Cell Horizontal Boundary Characters"
:type 'string
:group 'table)
(defcustom table-cell-vertical-char ?\|
- "*Character that forms table cell's vertical border line."
+ "Character that forms table cell's vertical border line."
:tag "Cell Vertical Boundary Character"
:type 'character
:group 'table)
(defcustom table-cell-intersection-char ?\+
- "*Character that forms table cell's corner."
+ "Character that forms table cell's corner."
:tag "Cell Intersection Character"
:type 'character
:group 'table)
(defcustom table-word-continuation-char ?\\
- "*Character that indicates word continuation into the next line.
+ "Character that indicates word continuation into the next line.
This character has a special meaning only in the fixed width mode,
that is when `table-fixed-width-mode' is non-nil . In the fixed width
mode this character indicates that the location is continuing into the
@@ -731,7 +726,7 @@ select a character that is unlikely to appear in your document."
(set variable value))
(defcustom table-fixed-width-mode nil
- "*Cell width is fixed when this is non-nil.
+ "Cell width is fixed when this is non-nil.
Normally it should be nil for allowing automatic cell width expansion
that widens a cell when it is necessary. When non-nil, typing in a
cell does not automatically expand the cell width. A word that is too
@@ -746,7 +741,7 @@ run-time."
:group 'table)
(defcustom table-detect-cell-alignment t
- "*Detect cell contents alignment automatically.
+ "Detect cell contents alignment automatically.
When non-nil cell alignment is automatically determined by the
appearance of the current cell contents when recognizing tables as a
whole. This applies to `table-recognize', `table-recognize-region'
@@ -756,38 +751,38 @@ and `table-recognize-table' but not to `table-recognize-cell'."
:group 'table)
(defcustom table-dest-buffer-name "table"
- "*Default buffer name (without a suffix) for source generation."
+ "Default buffer name (without a suffix) for source generation."
:tag "Source Buffer Name"
:type 'string
:group 'table)
(defcustom table-html-delegate-spacing-to-user-agent nil
- "*Non-nil delegates cell contents spacing entirely to user agent.
+ "Non-nil delegates cell contents spacing entirely to user agent.
Otherwise, when nil, it preserves the original spacing and line breaks."
:tag "HTML delegate spacing"
:type 'boolean
:group 'table)
(defcustom table-html-th-rows 0
- "*Number of top rows to become header cells automatically in HTML generation."
+ "Number of top rows to become header cells automatically in HTML generation."
:tag "HTML Header Rows"
:type 'integer
:group 'table)
(defcustom table-html-th-columns 0
- "*Number of left columns to become header cells automatically in HTML generation."
+ "Number of left columns to become header cells automatically in HTML generation."
:tag "HTML Header Columns"
:type 'integer
:group 'table)
(defcustom table-html-table-attribute "border=\"1\""
- "*Table attribute that applies to the table in HTML generation."
+ "Table attribute that applies to the table in HTML generation."
:tag "HTML table attribute"
:type 'string
:group 'table)
(defcustom table-html-cell-attribute ""
- "*Cell attribute that applies to all cells in HTML generation.
+ "Cell attribute that applies to all cells in HTML generation.
Do not specify \"align\" and \"valign\" because they are determined by
the cell contents dynamically."
:tag "HTML cell attribute"
@@ -795,28 +790,28 @@ the cell contents dynamically."
:group 'table)
(defcustom table-cals-thead-rows 1
- "*Number of top rows to become header rows in CALS table."
+ "Number of top rows to become header rows in CALS table."
:tag "CALS Header Rows"
:type 'integer
:group 'table)
;;;###autoload
(defcustom table-cell-map-hook nil
- "*Normal hooks run when finishing construction of `table-cell-map'.
+ "Normal hooks run when finishing construction of `table-cell-map'.
User can modify `table-cell-map' by adding custom functions here."
:tag "Cell Keymap Hooks"
:type 'hook
:group 'table-hooks)
(defcustom table-disable-incompatibility-warning nil
- "*Disable compatibility warning notice.
+ "Disable compatibility warning notice.
When nil user is reminded of known incompatible issues."
:tag "Disable Incompatibility Warning"
:type 'boolean
:group 'table)
(defcustom table-abort-recognition-when-input-pending t
- "*Abort current recognition process when input pending.
+ "Abort current recognition process when input pending.
Abort current recognition process when we are not sure that no input
is available. When non-nil lengthy recognition process is aborted
simply by any key input."
@@ -826,19 +821,19 @@ simply by any key input."
;;;###autoload
(defcustom table-load-hook nil
- "*List of functions to be called after the table is first loaded."
+ "List of functions to be called after the table is first loaded."
:type 'hook
:group 'table-hooks)
;;;###autoload
(defcustom table-point-entered-cell-hook nil
- "*List of functions to be called after point entered a table cell."
+ "List of functions to be called after point entered a table cell."
:type 'hook
:group 'table-hooks)
;;;###autoload
(defcustom table-point-left-cell-hook nil
- "*List of functions to be called after point left a table cell."
+ "List of functions to be called after point left a table cell."
:type 'hook
:group 'table-hooks)
@@ -864,7 +859,7 @@ time.")
;;; No need of user configuration
(defconst table-paragraph-start "[ \t\n\f]"
- "*Regexp for beginning of a line that starts OR separates paragraphs.")
+ "Regexp for beginning of a line that starts OR separates paragraphs.")
(defconst table-cache-buffer-name " *table cell cache*"
"Cell cache buffer name.")
(defvar table-cell-info-lu-coordinate nil
@@ -923,12 +918,12 @@ This is always set to nil at the entry to `table-with-cache-buffer' before execu
(defvar table-source-info-plist nil
"General storage for temporary information used while generating source.")
-;;; The following history containers not only keep the history of user
-;;; entries but also serve as the default value providers. When an
-;;; interactive command is invoked it offers a user the latest entry
-;;; of the history as a default selection. Therefore the values below
-;;; are the first default value when a command is invoked for the very
-;;; first time when there is no real history existing yet.
+;; The following history containers not only keep the history of user
+;; entries but also serve as the default value providers. When an
+;; interactive command is invoked it offers a user the latest entry
+;; of the history as a default selection. Therefore the values below
+;; are the first default value when a command is invoked for the very
+;; first time when there is no real history existing yet.
(defvar table-cell-span-direction-history '("right"))
(defvar table-cell-split-orientation-history '("horizontally"))
(defvar table-cell-split-contents-to-history '("split"))
@@ -952,19 +947,19 @@ This is always set to nil at the entry to `table-with-cache-buffer' before execu
(defvar table-capture-columns-history '(""))
(defvar table-target-history '("cell"))
-;;; Some entries in `table-cell-bindings' are duplicated in
-;;; `table-command-remap-alist'. There is a good reason for
-;;; this. Common key like return key may be taken by some other
-;;; function than normal `newline' function. Thus binding return key
-;;; directly for `*table--cell-newline' ensures that the correct enter
-;;; operation in a table cell. However
-;;; `table-command-remap-alist' has an additional role than
-;;; replacing commands. It is also used to construct a table command
-;;; list. This list is very important because it is used to check if
-;;; the previous command was one of them in this list or not. If the
-;;; previous command is found in the list the current command will not
-;;; refill the table cache. If the command were not listed fast
-;;; typing can cause unwanted cache refill.
+;; Some entries in `table-cell-bindings' are duplicated in
+;; `table-command-remap-alist'. There is a good reason for
+;; this. Common key like return key may be taken by some other
+;; function than normal `newline' function. Thus binding return key
+;; directly for `*table--cell-newline' ensures that the correct enter
+;; operation in a table cell. However
+;; `table-command-remap-alist' has an additional role than
+;; replacing commands. It is also used to construct a table command
+;; list. This list is very important because it is used to check if
+;; the previous command was one of them in this list or not. If the
+;; previous command is found in the list the current command will not
+;; refill the table cache. If the command were not listed fast
+;; typing can cause unwanted cache refill.
(defconst table-cell-bindings
'(([(control i)] . table-forward-cell)
([(control I)] . table-backward-cell)
@@ -5062,7 +5057,7 @@ Focus only on the corner pattern. Further cell validity check is required."
(intersection-str (regexp-quote (char-to-string table-cell-intersection-char)))
(v-border (format "[%c%c]" table-cell-vertical-char table-cell-intersection-char))
(h-border (format "[%s%c]" table-cell-horizontal-chars table-cell-intersection-char))
- (limit (save-excursion (beginning-of-line) (point))))
+ (limit (line-beginning-position)))
(catch 'end
(while t
(catch 'retry-horizontal
@@ -5100,7 +5095,7 @@ Focus only on the corner pattern. Further cell validity check is required."
(intersection-str (regexp-quote (char-to-string table-cell-intersection-char)))
(v-border (format "[%c%c]" table-cell-vertical-char table-cell-intersection-char))
(h-border (format "[%s%c]" table-cell-horizontal-chars table-cell-intersection-char))
- (limit (save-excursion (end-of-line) (point))))
+ (limit (line-end-position)))
(catch 'end
(while t
(catch 'retry-horizontal
@@ -5594,14 +5589,4 @@ It returns COLUMN unless STR contains some wide characters."
(provide 'table)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Local Variables: ***
-;; time-stamp-line-limit: 16 ***
-;; time-stamp-start: ";; Revised:[ \t]+" ***
-;; time-stamp-end: "$" ***
-;; time-stamp-format: "%3a %3b %02d %:y %02H:%02M:%02S (%Z)" ***
-;; End: ***
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; arch-tag: 0d69b03e-aa5f-4e72-8806-5727217617e0
;;; table.el ends here
diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el
index 5fc92a92d37..08f8257407e 100644
--- a/lisp/textmodes/tex-mode.el
+++ b/lisp/textmodes/tex-mode.el
@@ -58,14 +58,14 @@
;;;###autoload
(defcustom tex-shell-file-name nil
- "*If non-nil, the shell file name to run in the subshell used to run TeX."
+ "If non-nil, the shell file name to run in the subshell used to run TeX."
:type '(choice (const :tag "None" nil)
string)
:group 'tex-run)
;;;###autoload
(defcustom tex-directory (purecopy ".")
- "*Directory in which temporary files are written.
+ "Directory in which temporary files are written.
You can make this `/tmp' if your TEXINPUTS has no relative directories in it
and you don't try to apply \\[tex-region] or \\[tex-buffer] when there are
`\\input' commands with relative directories."
@@ -84,7 +84,7 @@ if it matches the first line of the file,
;;;###autoload
(defcustom tex-main-file nil
- "*The main TeX source file which includes this buffer's file.
+ "The main TeX source file which includes this buffer's file.
The command `tex-file' runs TeX on the file specified by `tex-main-file'
if the variable is non-nil."
:type '(choice (const :tag "None" nil)
@@ -93,13 +93,13 @@ if the variable is non-nil."
;;;###autoload
(defcustom tex-offer-save t
- "*If non-nil, ask about saving modified buffers before \\[tex-file] is run."
+ "If non-nil, ask about saving modified buffers before \\[tex-file] is run."
:type 'boolean
:group 'tex-file)
;;;###autoload
(defcustom tex-run-command (purecopy "tex")
- "*Command used to run TeX subjob.
+ "Command used to run TeX subjob.
TeX Mode sets `tex-command' to this string.
See the documentation of that variable."
:type 'string
@@ -107,7 +107,7 @@ See the documentation of that variable."
;;;###autoload
(defcustom latex-run-command (purecopy "latex")
- "*Command used to run LaTeX subjob.
+ "Command used to run LaTeX subjob.
LaTeX Mode sets `tex-command' to this string.
See the documentation of that variable."
:type 'string
@@ -115,7 +115,7 @@ See the documentation of that variable."
;;;###autoload
(defcustom slitex-run-command (purecopy "slitex")
- "*Command used to run SliTeX subjob.
+ "Command used to run SliTeX subjob.
SliTeX Mode sets `tex-command' to this string.
See the documentation of that variable."
:type 'string
@@ -123,7 +123,7 @@ See the documentation of that variable."
;;;###autoload
(defcustom tex-start-options (purecopy "")
- "*TeX options to use when starting TeX.
+ "TeX options to use when starting TeX.
These immediately precede the commands in `tex-start-commands'
and the input file name, with no separating space and are not shell-quoted.
If nil, TeX runs with no options. See the documentation of `tex-command'."
@@ -133,7 +133,7 @@ If nil, TeX runs with no options. See the documentation of `tex-command'."
;;;###autoload
(defcustom tex-start-commands (purecopy "\\nonstopmode\\input")
- "*TeX commands to use when starting TeX.
+ "TeX commands to use when starting TeX.
They are shell-quoted and precede the input file name, with a separating space.
If nil, no commands are used. See the documentation of `tex-command'."
:type '(radio (const :tag "Interactive \(nil\)" nil)
@@ -157,14 +157,14 @@ If nil, no commands are used. See the documentation of `tex-command'."
;;;###autoload
(defcustom latex-block-names nil
- "*User defined LaTeX block names.
+ "User defined LaTeX block names.
Combined with `latex-standard-block-names' for minibuffer completion."
:type '(repeat string)
:group 'tex-run)
;;;###autoload
(defcustom tex-bibtex-command (purecopy "bibtex")
- "*Command used by `tex-bibtex-file' to gather bibliographic data.
+ "Command used by `tex-bibtex-file' to gather bibliographic data.
If this string contains an asterisk (`*'), that is replaced by the file name;
otherwise, the file name, preceded by blank, is added at the end."
:type 'string
@@ -172,7 +172,7 @@ otherwise, the file name, preceded by blank, is added at the end."
;;;###autoload
(defcustom tex-dvi-print-command (purecopy "lpr -d")
- "*Command used by \\[tex-print] to print a .dvi file.
+ "Command used by \\[tex-print] to print a .dvi file.
If this string contains an asterisk (`*'), that is replaced by the file name;
otherwise, the file name, preceded by blank, is added at the end."
:type 'string
@@ -180,7 +180,7 @@ otherwise, the file name, preceded by blank, is added at the end."
;;;###autoload
(defcustom tex-alt-dvi-print-command (purecopy "lpr -d")
- "*Command used by \\[tex-print] with a prefix arg to print a .dvi file.
+ "Command used by \\[tex-print] with a prefix arg to print a .dvi file.
If this string contains an asterisk (`*'), that is replaced by the file name;
otherwise, the file name, preceded by blank, is added at the end.
@@ -203,7 +203,7 @@ use."
((eq window-system 'x) ,(purecopy "xdvi"))
((eq window-system 'w32) ,(purecopy "yap"))
(t ,(purecopy "dvi2tty * | cat -s")))
- "*Command used by \\[tex-view] to display a `.dvi' file.
+ "Command used by \\[tex-view] to display a `.dvi' file.
If it is a string, that specifies the command directly.
If this string contains an asterisk (`*'), that is replaced by the file name;
otherwise, the file name, preceded by a space, is added at the end.
@@ -214,14 +214,14 @@ If the value is a form, it is evaluated to get the command to use."
;;;###autoload
(defcustom tex-show-queue-command (purecopy "lpq")
- "*Command used by \\[tex-show-print-queue] to show the print queue.
+ "Command used by \\[tex-show-print-queue] to show the print queue.
Should show the queue(s) that \\[tex-print] puts jobs on."
:type 'string
:group 'tex-view)
;;;###autoload
(defcustom tex-default-mode 'latex-mode
- "*Mode to enter for a new file that might be either TeX or LaTeX.
+ "Mode to enter for a new file that might be either TeX or LaTeX.
This variable is used when it can't be determined whether the file
is plain TeX or LaTeX or what because the file contains no commands.
Normally set to either `plain-tex-mode' or `latex-mode'."
@@ -230,14 +230,14 @@ Normally set to either `plain-tex-mode' or `latex-mode'."
;;;###autoload
(defcustom tex-open-quote (purecopy "``")
- "*String inserted by typing \\[tex-insert-quote] to open a quotation."
+ "String inserted by typing \\[tex-insert-quote] to open a quotation."
:type 'string
:options '("``" "\"<" "\"`" "<<" "«")
:group 'tex)
;;;###autoload
(defcustom tex-close-quote (purecopy "''")
- "*String inserted by typing \\[tex-insert-quote] to close a quotation."
+ "String inserted by typing \\[tex-insert-quote] to close a quotation."
:type 'string
:options '("''" "\">" "\"'" ">>" "»")
:group 'tex)
@@ -327,7 +327,7 @@ Set by \\[tex-region], \\[tex-buffer], and \\[tex-file].")
;;;;
(defcustom latex-imenu-indent-string ". "
- "*String to add repeated in front of nested sectional units for Imenu.
+ "String to add repeated in front of nested sectional units for Imenu.
An alternative value is \" . \", if you use a font with a narrow period."
:type 'string
:group 'tex)
@@ -488,10 +488,6 @@ An alternative value is \" . \", if you use a font with a narrow period."
;; (arg "\\(?:{\\(\\(?:[^{}\\]+\\|\\\\.\\|{[^}]*}\\)+\\)\\|\\\\[a-z*]+\\)"))
(arg "{\\(\\(?:[^{}\\]+\\|\\\\.\\|{[^}]*}\\)+\\)"))
(list
- ;; font-lock-syntactic-keywords causes the \ of \end{verbatim} to be
- ;; highlighted as tex-verbatim face. Let's undo that.
- ;; This is ugly and brittle :-( --Stef
- '("^\\(\\\\\\)end" (1 (get-text-property (match-end 1) 'face) t))
;; display $$ math $$
;; We only mark the match between $$ and $$ because the $$ delimiters
;; themselves have already been marked (along with $..$) by syntactic
@@ -642,28 +638,90 @@ An alternative value is \" . \", if you use a font with a narrow period."
(put 'tex-verbatim-environments 'safe-local-variable
(lambda (x) (null (delq t (mapcar 'stringp x)))))
-(defvar tex-font-lock-syntactic-keywords
- '((eval . `(,(concat "^\\\\begin *{"
- (regexp-opt tex-verbatim-environments t)
- "}.*\\(\n\\)") 2 "|"))
- ;; Technically, we'd like to put the "|" property on the \n preceding
- ;; the \end, but this would have 2 disadvantages:
- ;; 1 - it's wrong if the verbatim env is empty (the same \n is used to
- ;; start and end the fenced-string).
- ;; 2 - font-lock considers the preceding \n as being part of the
- ;; preceding line, so things gets screwed every time the previous
- ;; line is re-font-locked on its own.
- ;; There's a hack in tex-font-lock-keywords-1 to remove the verbatim
- ;; face from the \ but C-M-f still jumps to the wrong spot :-( --Stef
- (eval . `(,(concat "^\\(\\\\\\)end *{"
- (regexp-opt tex-verbatim-environments t)
- "}\\(.?\\)") (1 "|") (3 "<")))
- ;; ("^\\(\\\\\\)begin *{comment}" 1 "< b")
- ;; ("^\\\\end *{comment}.*\\(\n\\)" 1 "> b")
+(eval-when-compile
+ (defconst tex-syntax-propertize-rules
+ (syntax-propertize-precompile-rules
("\\\\verb\\**\\([^a-z@*]\\)"
- ;; Do it last, because it uses syntax-ppss which needs the
- ;; syntax-table properties of previous entries.
- 1 (tex-font-lock-verb (match-end 1)))))
+ (1 (prog1 "\""
+ (tex-font-lock-verb
+ (match-beginning 0) (char-after (match-beginning 1))))))))
+
+ (defconst latex-syntax-propertize-rules
+ (syntax-propertize-precompile-rules
+ tex-syntax-propertize-rules
+ ("\\\\\\(?:end\\|begin\\) *\\({[^\n{}]*}\\)"
+ (1 (ignore
+ (tex-env-mark (match-beginning 0)
+ (match-beginning 1) (match-end 1))))))))
+
+(defun tex-env-mark (cmd start end)
+ (when (= cmd (line-beginning-position))
+ (let ((arg (buffer-substring-no-properties (1+ start) (1- end))))
+ (when (member arg tex-verbatim-environments)
+ (if (eq ?b (char-after (1+ cmd)))
+ ;; \begin
+ (put-text-property (line-end-position)
+ (line-beginning-position 2)
+ 'syntax-table (string-to-syntax "< c"))
+ ;; In the case of an empty verbatim env, the \n after the \begin is
+ ;; the same as the \n before the \end. Lucky for us, the "> c"
+ ;; property associated to the \end will be placed afterwards, so it
+ ;; will override the "< c".
+ (put-text-property (1- cmd) cmd
+ 'syntax-table (string-to-syntax "> c"))
+ ;; The text between \end{verbatim} and \n is ignored, so we'll treat
+ ;; it as a comment.
+ (put-text-property end (min (1+ end) (line-end-position))
+ 'syntax-table (string-to-syntax "<"))))))
+ ;; Mark env args for possible electric pairing.
+ (unless (get-char-property (1+ start) 'text-clones) ;Already paired-up.
+ (put-text-property start end 'latex-env-pair t)))
+
+(define-minor-mode latex-electric-env-pair-mode
+ "Automatically update the \\end arg when editing the \\begin one.
+And vice-versa."
+ :lighter "/e"
+ (if latex-electric-env-pair-mode
+ (add-hook 'before-change-functions
+ #'latex-env-before-change nil 'local)
+ (remove-hook 'before-change-functions
+ #'latex-env-before-change 'local)))
+
+(defun latex-env-before-change (start end)
+ (when (get-text-property start 'latex-env-pair)
+ (condition-case err
+ (with-silent-modifications
+ ;; Remove properties even if don't find a pair.
+ (remove-text-properties
+ (previous-single-property-change (1+ start) 'latex-env-pair)
+ (next-single-property-change start 'latex-env-pair)
+ '(latex-env-pair))
+ (unless (or (get-char-property start 'text-clones)
+ (get-char-property (1+ start) 'text-clones)
+ (save-excursion
+ (goto-char start)
+ (not (re-search-backward
+ "\\\\\\(?:end\\|begi\\(n\\)\\) *{"
+ (line-beginning-position) t))))
+ (let ((cmd-start (match-beginning 0))
+ (type (match-end 1)) ;nil for \end, else \begin.
+ (arg-start (1- (match-end 0))))
+ (save-excursion
+ (goto-char (match-end 0))
+ (when (and (looking-at "[^\n{}]*}")
+ (> (match-end 0) end))
+ (let ((arg-end (match-end 0)))
+ (if (null type) ;\end
+ (progn (goto-char arg-end)
+ (latex-forward-sexp -1) (forward-word 1))
+ (goto-char cmd-start)
+ (latex-forward-sexp 1)
+ (let (forward-sexp-function) (backward-sexp)))
+ (when (looking-at
+ (regexp-quote (buffer-substring arg-start arg-end)))
+ (text-clone-create arg-start arg-end))))))))
+ (scan-error nil)
+ (error (message "Error in latex-env-before-change: %s" err)))))
(defun tex-font-lock-unfontify-region (beg end)
(font-lock-default-unfontify-region beg end)
@@ -730,37 +788,32 @@ Not smaller than the value set by `tex-suscript-height-minimum'."
(define-obsolete-face-alias 'tex-verbatim-face 'tex-verbatim "22.1")
(defvar tex-verbatim-face 'tex-verbatim)
-(defun tex-font-lock-verb (end)
- "Place syntax-table properties on the \verb construct.
-END is the position of the first delimiter after \verb."
- (unless (nth 8 (syntax-ppss end))
+(defun tex-font-lock-verb (start delim)
+ "Place syntax table properties on the \verb construct.
+START is the position of the \\ and DELIM is the delimiter char."
;; Do nothing if the \verb construct is itself inside a comment or
;; verbatim env.
- (save-excursion
+ (unless (nth 8 (save-excursion (syntax-ppss start)))
;; Let's find the end and mark it.
- ;; We used to do it inside tex-font-lock-syntactic-face-function, but
- ;; this leads to funny effects when jumping to the end of the buffer,
- ;; because font-lock applies font-lock-syntactic-keywords to the whole
- ;; preceding text but font-lock-syntactic-face-function only to the
- ;; actually displayed text.
- (goto-char end)
- (let ((char (char-before)))
- (skip-chars-forward (string ?^ char)) ;; Use `end' ?
- (when (eq (char-syntax (preceding-char)) ?/)
- (put-text-property (1- (point)) (point) 'syntax-table '(1)))
+ ;; This may span more than a single line, but we don't bother
+ ;; placing a syntax-multiline property since such multiline verbs aren't
+ ;; valid anyway.
+ (skip-chars-forward (string ?^ delim))
(unless (eobp)
- (put-text-property (point) (1+ (point)) 'syntax-table '(7))
- ;; Cause the rest of the buffer to be re-fontified.
- ;; (remove-text-properties (1+ (point)) (point-max) '(fontified))
- )))
- "\""))
+ (when (eq (char-syntax (preceding-char)) ?/)
+ (put-text-property (1- (point)) (point)
+ 'syntax-table (string-to-syntax ".")))
+ (put-text-property (point) (1+ (point))
+ 'syntax-table (string-to-syntax "\"")))))
;; Use string syntax but math face for $...$.
(defun tex-font-lock-syntactic-face-function (state)
(let ((char (nth 3 state)))
(cond
- ((not char) font-lock-comment-face)
+ ((not char)
+ (if (eq 2 (nth 7 state)) tex-verbatim-face font-lock-comment-face))
((eq char ?$) tex-math-face)
+ ;; A \verb element.
(t tex-verbatim-face))))
@@ -808,6 +861,12 @@ END is the position of the first delimiter after \verb."
(define-key map "\C-c\C-c" 'tex-compile)
(define-key map "\C-c\C-i" 'tex-bibtex-file)
(define-key map "\C-c\C-o" 'latex-insert-block)
+
+ ;; Redundant keybindings, for consistency with SGML mode.
+ (define-key map "\C-c\C-t" 'latex-insert-block)
+ (define-key map "\C-c]" 'latex-close-block)
+ (define-key map "\C-c/" 'latex-close-block)
+
(define-key map "\C-c\C-e" 'latex-close-block)
(define-key map "\C-c\C-u" 'tex-goto-last-unclosed-latex-block)
(define-key map "\C-c\C-m" 'tex-feed-input)
@@ -1158,10 +1217,9 @@ Entering SliTeX mode runs the hook `text-mode-hook', then the hook
(font-lock-syntactic-face-function
. tex-font-lock-syntactic-face-function)
(font-lock-unfontify-region-function
- . tex-font-lock-unfontify-region)
- (font-lock-syntactic-keywords
- . tex-font-lock-syntactic-keywords)
- (parse-sexp-lookup-properties . t)))
+ . tex-font-lock-unfontify-region)))
+ (set (make-local-variable 'syntax-propertize-function)
+ (syntax-propertize-rules latex-syntax-propertize-rules))
;; TABs in verbatim environments don't do what you think.
(set (make-local-variable 'indent-tabs-mode) nil)
;; Other vars that should be buffer-local.
@@ -2807,15 +2865,15 @@ There might be text before point."
;; syntax-table can't deal with. We could turn it
;; into a non-comment, or use `\n%' or `%^' as the comment.
;; Instead, we include it in the ^^A comment.
- (eval-when-compile (string-to-syntax "< b"))
- (eval-when-compile (string-to-syntax ">"))))
+ (string-to-syntax "< b")
+ (string-to-syntax ">")))
(let ((end (line-end-position)))
(if (< end (point-max))
(put-text-property
end (1+ end)
'syntax-table
- (eval-when-compile (string-to-syntax "> b")))))
- (eval-when-compile (string-to-syntax "< b")))))
+ (string-to-syntax "> b"))))
+ (string-to-syntax "< b"))))
(defun doctex-font-lock-syntactic-face-function (state)
;; Mark DocTeX documentation, which is parsed as a style A comment
@@ -2827,11 +2885,12 @@ There might be text before point."
(tex-font-lock-syntactic-face-function state)
font-lock-doc-face))
-(defvar doctex-font-lock-syntactic-keywords
- (append
- tex-font-lock-syntactic-keywords
- ;; For DocTeX comment-in-doc.
- `(("\\(\\^\\)\\^A" (1 (doctex-font-lock-^^A))))))
+(eval-when-compile
+ (defconst doctex-syntax-propertize-rules
+ (syntax-propertize-precompile-rules
+ latex-syntax-propertize-rules
+ ;; For DocTeX comment-in-doc.
+ ("\\(\\^\\)\\^A" (1 (doctex-font-lock-^^A))))))
(defvar doctex-font-lock-keywords
(append tex-font-lock-keywords
@@ -2845,12 +2904,12 @@ There might be text before point."
(mapcar
(lambda (x)
(case (car-safe x)
- (font-lock-syntactic-keywords
- (cons (car x) 'doctex-font-lock-syntactic-keywords))
(font-lock-syntactic-face-function
(cons (car x) 'doctex-font-lock-syntactic-face-function))
(t x)))
- (cdr font-lock-defaults)))))
+ (cdr font-lock-defaults))))
+ (set (make-local-variable 'syntax-propertize-function)
+ (syntax-propertize-rules doctex-syntax-propertize-rules)))
(run-hooks 'tex-mode-load-hook)
diff --git a/lisp/textmodes/texinfmt.el b/lisp/textmodes/texinfmt.el
index da33df7113d..7c331c7809d 100644
--- a/lisp/textmodes/texinfmt.el
+++ b/lisp/textmodes/texinfmt.el
@@ -1,8 +1,8 @@
;;; texinfmt.el --- format Texinfo files into Info files
-;; Copyright (C) 1985, 1986, 1988, 1990, 1991, 1992, 1993,
-;; 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1986, 1988, 1990, 1991, 1992, 1993, 1994, 1995,
+;; 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Maintainer: Robert J. Chassell <bug-texinfo@gnu.org>
;; Keywords: maint, tex, docs
@@ -224,7 +224,7 @@ converted to Info is stored in a temporary buffer."
(save-restriction
(widen)
(goto-char (point-min))
- (let ((search-end (save-excursion (forward-line 100) (point))))
+ (let ((search-end (line-beginning-position 101)))
(if (or
;; Either copy header text.
(and
@@ -285,7 +285,7 @@ converted to Info is stored in a temporary buffer."
(let ((filename (concat input-directory
(texinfo-parse-line-arg))))
(re-search-backward "^@include")
- (delete-region (point) (save-excursion (forward-line 1) (point)))
+ (delete-region (point) (line-beginning-position 2))
(message "Reading included file: %s" filename)
(save-excursion
(save-restriction
@@ -323,8 +323,7 @@ converted to Info is stored in a temporary buffer."
;; Insert Info region title text.
(goto-char (point-min))
- (if (search-forward
- "@setfilename" (save-excursion (forward-line 100) (point)) t)
+ (if (search-forward "@setfilename" (line-beginning-position 101) t)
(progn
(setq texinfo-command-end (point))
(beginning-of-line)
@@ -664,11 +663,12 @@ Do not append @refill to paragraphs containing @w{TEXT} or @*."
;; Else
;; 3. Do not refill a paragraph containing @w or @*, or ending
;; with @<newline> followed by a newline.
- (if (or (>= (point) (point-max))
- (re-search-forward
- "@w{\\|@\\*\\|@\n\n"
- (save-excursion (forward-paragraph) (forward-line 1) (point))
- t))
+ (if (or (>= (point) (point-max))
+ (re-search-forward
+ "@w{\\|@\\*\\|@\n\n"
+ (save-excursion (forward-paragraph)
+ (line-beginning-position 2))
+ t))
;; Go to end of paragraph and do nothing.
(forward-paragraph)
;; 4. Else go to end of paragraph and insert @refill
@@ -772,13 +772,13 @@ commands."
((eq type '@raisesections)
(setq level (1+ level))
(delete-region
- (point) (save-excursion (forward-line 1) (point))))
+ (point) (line-beginning-position 2)))
;; 2. Decrement level
((eq type '@lowersections)
(setq level (1- level))
(delete-region
- (point) (save-excursion (forward-line 1) (point))))
+ (point) (line-beginning-position 2)))
;; Now handle structuring commands
((cond
@@ -945,8 +945,8 @@ insert the text with the @insertcopying command."
(end (progn (re-search-forward "^@end copying[ \t]*\n") (point))))
(setq texinfo-copying-text
(buffer-substring-no-properties
- (save-excursion (goto-char beg) (forward-line 1) (point))
- (save-excursion (goto-char end) (forward-line -1) (point))))
+ (save-excursion (goto-char beg) (line-beginning-position 2))
+ (save-excursion (goto-char end) (line-beginning-position 0))))
(delete-region beg end)))
(defun texinfo-insertcopying ()
@@ -1505,9 +1505,7 @@ The node is constructed automatically."
(progn (goto-char node-name-beginning) ; skip over node command
(skip-chars-forward " \t") ; and over spaces
(point))
- (if (search-forward
- ","
- (save-excursion (end-of-line) (point)) t) ; bound search
+ (if (search-forward "," (line-end-position) t) ; bound search
(1- (point))
(end-of-line) (point))))))
(texinfo-discard-command) ; remove or insert whitespace, as needed
@@ -1692,7 +1690,7 @@ Used by @refill indenting command to avoid indenting within lists, etc.")
(put 'itemize 'texinfo-item 'texinfo-itemize-item)
(defun texinfo-itemize-item ()
;; (texinfo-discard-line) ; Did not handle text on same line as @item.
- (delete-region (1+ (point)) (save-excursion (beginning-of-line) (point)))
+ (delete-region (1+ (point)) (line-beginning-position))
(if (looking-at "[ \t]*[^ \t\n]+")
;; Text on same line as @item command.
(insert "\b " (nth 1 (car texinfo-stack)) " \n")
@@ -2132,10 +2130,10 @@ This command is executed when texinfmt sees @item inside @multitable."
(narrow-to-region start end)
;; Remove whitespace before and after entry.
(skip-chars-forward " ")
- (delete-region (point) (save-excursion (beginning-of-line) (point)))
+ (delete-region (point) (line-beginning-position))
(goto-char (point-max))
(skip-chars-backward " ")
- (delete-region (point) (save-excursion (end-of-line) (point)))
+ (delete-region (point) (line-end-position))
;; Temporarily set texinfo-stack to nil so texinfo-format-scan
;; does not see an unterminated @multitable.
(let (texinfo-stack) ; nil
@@ -2409,16 +2407,14 @@ Use only the FILENAME arg; for Info, ignore the other arguments to @image."
(let ((start (1- (point)))
args)
(skip-chars-forward " ")
- (save-excursion (end-of-line) (setq texinfo-command-end (point)))
+ (setq texinfo-command-end (line-end-position))
(if (not (looking-at "\\([^=]+\\)=\\(.*\\)"))
(error "Invalid alias command")
(push (cons
(match-string-no-properties 1)
(match-string-no-properties 2))
texinfo-alias-list)
- (texinfo-discard-command))
- )
- )
+ (texinfo-discard-command))))
;;; @var, @code and the like
@@ -2455,7 +2451,7 @@ Use only the FILENAME arg; for Info, ignore the other arguments to @image."
"Insert ` ... ' around arg unless inside a table; in that case, no quotes."
;; `looking-at-backward' not available in v. 18.57, 20.2
(if (not (search-backward "" ; searched-for character is a control-H
- (save-excursion (beginning-of-line) (point))
+ (line-beginning-position)
t))
(insert "`" (texinfo-parse-arg-discard) "'")
(insert (texinfo-parse-arg-discard)))
@@ -2507,7 +2503,7 @@ For example, @verb\{|@|\} results in @ and
(error "Not found: @verb start brace"))
(delete-region texinfo-command-start (+ 2 texinfo-command-end))
(search-forward delimiter))
- (delete-backward-char 1)
+ (delete-char -1)
(unless (looking-at "}")
(error "Not found: @verb end brace"))
(delete-char 1))
@@ -2840,8 +2836,7 @@ Default is to leave paragraph indentation as is."
(defun texinfo-noindent ()
(save-excursion
(forward-paragraph 1)
- (if (search-backward "@refill"
- (save-excursion (forward-line -1) (point)) t)
+ (if (search-backward "@refill" (line-beginning-position 0) t)
() ; leave @noindent command so @refill command knows not to indent
;; else
(texinfo-discard-line))))
@@ -4303,5 +4298,4 @@ For example, invoke
;;; Place `provide' at end of file.
(provide 'texinfmt)
-;; arch-tag: 1e8d9a2d-bca0-40a0-ac6c-dab01bc6f725
;;; texinfmt.el ends here
diff --git a/lisp/textmodes/texinfo.el b/lisp/textmodes/texinfo.el
index 7c71acd044b..be23a439bf3 100644
--- a/lisp/textmodes/texinfo.el
+++ b/lisp/textmodes/texinfo.el
@@ -310,10 +310,11 @@ chapter."
("Chapters" "^@chapter[ \t]+\\(.*\\)$" 1))
"Imenu generic expression for Texinfo mode. See `imenu-generic-expression'.")
-(defvar texinfo-font-lock-syntactic-keywords
- '(("\\(@\\)c\\(omment\\)?\\>" (1 "<"))
- ("^\\(@\\)ignore\\>" (1 "< b"))
- ("^@end ignore\\(\n\\)" (1 "> b")))
+(defconst texinfo-syntax-propertize-function
+ (syntax-propertize-rules
+ ("\\(@\\)c\\(omment\\)?\\>" (1 "<"))
+ ("^\\(@\\)ignore\\>" (1 "< b"))
+ ("^@end ignore\\(\n\\)" (1 "> b")))
"Syntactic keywords to catch comment delimiters in `texinfo-mode'.")
(defconst texinfo-environments
@@ -600,9 +601,9 @@ value of `texinfo-mode-hook'."
(setq imenu-case-fold-search nil)
(make-local-variable 'font-lock-defaults)
(setq font-lock-defaults
- '(texinfo-font-lock-keywords nil nil nil backward-paragraph
- (font-lock-syntactic-keywords
- . texinfo-font-lock-syntactic-keywords)))
+ '(texinfo-font-lock-keywords nil nil nil backward-paragraph))
+ (set (make-local-variable 'syntax-propertize-function)
+ texinfo-syntax-propertize-function)
(set (make-local-variable 'parse-sexp-lookup-properties) t)
;; Outline settings.
diff --git a/lisp/textmodes/texnfo-upd.el b/lisp/textmodes/texnfo-upd.el
index f4fcc95908b..ff021532c50 100644
--- a/lisp/textmodes/texnfo-upd.el
+++ b/lisp/textmodes/texnfo-upd.el
@@ -1,7 +1,7 @@
;;; texnfo-upd.el --- utilities for updating nodes and menus in Texinfo files
-;; Copyright (C) 1989, 1990, 1991, 1992, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1989, 1990, 1991, 1992, 2001, 2002, 2003, 2004, 2005,
+;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Robert J. Chassell
;; Maintainer: bug-texinfo@gnu.org
@@ -349,9 +349,7 @@ section titles are often too short to explain a node well."
(when (search-forward texinfo-master-menu-header nil t)
;; Check if @detailmenu kludge is used;
;; if so, leave point before @detailmenu.
- (search-backward "\n@detailmenu"
- (save-excursion (forward-line -3) (point))
- t)
+ (search-backward "\n@detailmenu" (line-beginning-position -2) t)
;; Remove detailed master menu listing
(setq master-menu-p t)
(goto-char (match-beginning 0))
@@ -627,9 +625,7 @@ Single argument, END-OF-MENU, is position limiting search."
(point)
(save-excursion
(re-search-forward "\\(^\\* \\|^@ignore\\|^@end menu\\)" end-of-menu t)
- (forward-line -1)
- (end-of-line) ; go to end of last description line
- (point)))
+ (line-end-position 0))) ; end of last description line
""))
(defun texinfo-menu-end ()
@@ -719,34 +715,32 @@ complements the node name rather than repeats it as a title does."
(let (beginning end node-name title)
(save-excursion
(beginning-of-line)
- (if (search-forward "* " (save-excursion (end-of-line) (point)) t)
+ (if (search-forward "* " (line-end-position) t)
(progn (skip-chars-forward " \t")
(setq beginning (point)))
(error "This is not a line in a menu"))
(cond
;; "Double colon" entry line; menu entry and node name are the same,
- ((search-forward "::" (save-excursion (end-of-line) (point)) t)
+ ((search-forward "::" (line-end-position) t)
(if (looking-at "[ \t]*[^ \t\n]+")
(error "Descriptive text already exists"))
(skip-chars-backward ": \t")
(setq node-name (buffer-substring beginning (point))))
;; "Single colon" entry line; menu entry and node name are different.
- ((search-forward ":" (save-excursion (end-of-line) (point)) t)
+ ((search-forward ":" (line-end-position) t)
(skip-chars-forward " \t")
(setq beginning (point))
;; Menu entry line ends in a period, comma, or tab.
- (if (re-search-forward "[.,\t]"
- (save-excursion (forward-line 1) (point)) t)
+ (if (re-search-forward "[.,\t]" (line-beginning-position 2) t)
(progn
(if (looking-at "[ \t]*[^ \t\n]+")
(error "Descriptive text already exists"))
(skip-chars-backward "., \t")
(setq node-name (buffer-substring beginning (point))))
;; Menu entry line ends in a return.
- (re-search-forward ".*\n"
- (save-excursion (forward-line 1) (point)) t)
+ (re-search-forward ".*\n" (line-beginning-position 2) t)
(skip-chars-backward " \t\n")
(setq node-name (buffer-substring beginning (point)))
(if (= 0 (length node-name))
@@ -904,9 +898,7 @@ section titles are often too short to explain a node well."
(progn
;; Check if @detailmenu kludge is used;
;; if so, leave point before @detailmenu.
- (search-backward "\n@detailmenu"
- (save-excursion (forward-line -3) (point))
- t)
+ (search-backward "\n@detailmenu" (line-beginning-position -2) t)
;; Remove detailed master menu listing
(goto-char (match-beginning 0))
(let ((end-of-detailed-menu-descriptions
@@ -941,9 +933,7 @@ section titles are often too short to explain a node well."
(goto-char (match-beginning 0))
;; Check if @detailmenu kludge is used;
;; if so, leave point before @detailmenu.
- (search-backward "\n@detailmenu"
- (save-excursion (forward-line -3) (point))
- t)
+ (search-backward "\n@detailmenu" (line-beginning-position -2) t)
(insert "\n")
(delete-blank-lines)
(goto-char (point-min))))
@@ -1154,8 +1144,7 @@ Only argument is a string of the general type of section."
(save-excursion
(goto-char (point-min))
(re-search-forward "^@node [ \t]*top[ \t]*\\(,\\|$\\)" nil t)
- (beginning-of-line)
- (point)))
+ (line-beginning-position)))
(t
(save-excursion
(re-search-backward
@@ -1206,13 +1195,11 @@ The menu will be located just before this position.
First argument is the position of the beginning of the section in
which the menu will be located; second argument is the position of the
end of that region; it limits the search."
-
(save-excursion
(goto-char beginning)
(forward-line 1)
(re-search-forward "^@node" end t)
- (beginning-of-line)
- (point)))
+ (line-beginning-position)))
;;; Updating a node
@@ -1331,7 +1318,7 @@ Point must be at beginning of node line. Does not move point."
Starts from the current position of the cursor, and searches forward
on the line for a comma and if one is found, deletes the rest of the
line, including the comma. Leaves point at beginning of line."
- (let ((eol-point (save-excursion (end-of-line) (point))))
+ (let ((eol-point (line-end-position)))
(if (search-forward "," eol-point t)
(delete-region (1- (point)) eol-point)))
(beginning-of-line))
@@ -1437,8 +1424,7 @@ will be at some level higher in the Texinfo file. The fourth argument
"\\)")
(save-excursion
(goto-char beginning)
- (beginning-of-line)
- (point))
+ (line-beginning-position))
t)
'normal
'no-pointer))
@@ -1453,7 +1439,7 @@ The argument is the kind of section, either `normal' or `no-pointer'."
(end-of-line) ; this handles prev node top case
(re-search-backward ; when point is already
"^@node" ; at the beginning of @node line
- (save-excursion (forward-line -3))
+ (line-beginning-position -2)
t)
(setq name (texinfo-copy-node-name)))
((eq kind 'no-pointer)
@@ -1483,7 +1469,7 @@ towards which the pointer is directed, one of `next', `previous', or `up'."
"Remove extra commas, if any, at end of node line."
(end-of-line)
(skip-chars-backward ", ")
- (delete-region (point) (save-excursion (end-of-line) (point))))
+ (delete-region (point) (line-end-position)))
;;; Updating nodes sequentially
@@ -1647,13 +1633,14 @@ node names in pre-existing `@node' lines that lack names."
(skip-chars-forward " \t")
(setq title (buffer-substring
(point)
- (save-excursion (end-of-line) (point))))))
+ (line-end-position)))))
;; Insert node line if necessary.
(if (re-search-backward
"^@node"
;; Avoid finding previous node line if node lines are close.
(or last-section-position
- (save-excursion (forward-line -2) (point))) t)
+ (line-beginning-position -1))
+ t)
;; @node is present, and point at beginning of that line
(forward-word 1) ; Leave point just after @node.
;; Else @node missing; insert one.
@@ -1675,7 +1662,7 @@ node names in pre-existing `@node' lines that lack names."
(message "Inserted title %s ... " title)))))
;; Go forward beyond current section title.
(re-search-forward texinfo-section-types-regexp
- (save-excursion (forward-line 3) (point)) t)
+ (line-beginning-position 4) t)
(setq last-section-position (point))
(forward-line 1))
@@ -1993,9 +1980,7 @@ chapter."
(point-min)
(save-excursion
(re-search-forward "^@include")
- (beginning-of-line)
- (point)))
-
+ (line-beginning-position)))
;; If found, leave point after word `menu' on the `@menu' line.
(progn
(texinfo-incorporate-descriptions main-menu-list)
@@ -2021,9 +2006,7 @@ chapter."
(goto-char (match-beginning 0))
;; Check if @detailmenu kludge is used;
;; if so, leave point before @detailmenu.
- (search-backward "\n@detailmenu"
- (save-excursion (forward-line -3) (point))
- t)
+ (search-backward "\n@detailmenu" (line-beginning-position -2) t)
;; Remove detailed master menu listing
(let ((end-of-detailed-menu-descriptions
(save-excursion ; beginning of end menu line
@@ -2057,5 +2040,4 @@ chapter."
;; Place `provide' at end of file.
(provide 'texnfo-upd)
-;; arch-tag: d21613a5-c32f-43f4-8af4-bfb1e7455842
;;; texnfo-upd.el ends here
diff --git a/lisp/textmodes/text-mode.el b/lisp/textmodes/text-mode.el
index 75897a2cf07..b6868d3a8e8 100644
--- a/lisp/textmodes/text-mode.el
+++ b/lisp/textmodes/text-mode.el
@@ -5,6 +5,7 @@
;; Maintainer: FSF
;; Keywords: wp
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -32,7 +33,7 @@
"Normal hook run when entering Text mode and many related modes."
:type 'hook
:options '(turn-on-auto-fill turn-on-flyspell)
- :group 'data)
+ :group 'wp)
(defvar text-mode-variant nil
"Non-nil if this buffer's major mode is a variant of Text mode.
diff --git a/lisp/textmodes/two-column.el b/lisp/textmodes/two-column.el
index 9c5e70e93d4..c19be4bd66b 100644
--- a/lisp/textmodes/two-column.el
+++ b/lisp/textmodes/two-column.el
@@ -209,19 +209,19 @@
(defcustom 2C-mode-line-format
'("-%*- %15b --" (-3 . "%p") "--%[(" mode-name
minor-mode-alist "%n" mode-line-process ")%]%-")
- "*Value of `mode-line-format' for a buffer in two-column minor mode."
+ "Value of `mode-line-format' for a buffer in two-column minor mode."
:type 'sexp
:group 'two-column)
(defcustom 2C-other-buffer-hook 'text-mode
- "*Hook run in new buffer when it is associated with current one."
+ "Hook run in new buffer when it is associated with current one."
:type 'function
:group 'two-column)
(defcustom 2C-separator ""
- "*A string inserted between the two columns when merging.
+ "A string inserted between the two columns when merging.
This gets set locally by \\[2C-split]."
:type 'string
:group 'two-column)
@@ -230,7 +230,7 @@ This gets set locally by \\[2C-split]."
(defcustom 2C-window-width 40
- "*The width of the first column. (Must be at least `window-min-width')
+ "The width of the first column. (Must be at least `window-min-width')
This value is local for every buffer that sets it."
:type 'integer
:group 'two-column)
@@ -240,7 +240,7 @@ This value is local for every buffer that sets it."
(defcustom 2C-beyond-fill-column 4
- "*Base for calculating `fill-column' for a buffer in two-column minor mode.
+ "Base for calculating `fill-column' for a buffer in two-column minor mode.
The value of `fill-column' becomes `2C-window-width' for this buffer
minus this value."
:type 'integer
diff --git a/lisp/time.el b/lisp/time.el
index 302a8c7cd73..006fd758a7c 100644
--- a/lisp/time.el
+++ b/lisp/time.el
@@ -454,8 +454,9 @@ update which can wait for the next redisplay."
(force-mode-line-update))
(defun display-time-file-nonempty-p (file)
- (and (file-exists-p file)
- (< 0 (nth 7 (file-attributes (file-chase-links file))))))
+ (let ((remote-file-name-inhibit-cache (- display-time-interval 5)))
+ (and (file-exists-p file)
+ (< 0 (nth 7 (file-attributes (file-chase-links file)))))))
;;;###autoload
(define-minor-mode display-time-mode
@@ -490,15 +491,10 @@ This runs the normal hook `display-time-hook' after each update."
'display-time-event-handler)))
-(defun display-time-world-mode ()
+(define-derived-mode display-time-world-mode nil "World clock"
"Major mode for buffer that displays times in various time zones.
See `display-time-world'."
- (interactive)
- (kill-all-local-variables)
- (setq
- major-mode 'display-time-world-mode
- mode-name "World clock")
- (use-local-map display-time-world-mode-map))
+ (setq show-trailing-whitespace nil))
(defun display-time-world-display (alist)
"Replace current buffer text with times in various zones, based on ALIST."
@@ -506,25 +502,23 @@ See `display-time-world'."
(buffer-undo-list t))
(erase-buffer)
(let ((max-width 0)
- (result ()))
+ (result ())
+ fmt)
(unwind-protect
(dolist (zone alist)
(let* ((label (cadr zone))
(width (string-width label)))
(set-time-zone-rule (car zone))
- (setq result
- (append result
- (list
- label width
- (format-time-string display-time-world-time-format))))
+ (push (cons label
+ (format-time-string display-time-world-time-format))
+ result)
(when (> width max-width)
(setq max-width width))))
(set-time-zone-rule nil))
- (while result
- (insert (pop result)
- (make-string (1+ (- max-width (pop result))) ?\s)
- (pop result) "\n")))
- (delete-backward-char 1)))
+ (setq fmt (concat "%-" (int-to-string max-width) "s %s\n"))
+ (dolist (timedata (nreverse result))
+ (insert (format fmt (car timedata) (cdr timedata)))))
+ (delete-char -1)))
;;;###autoload
(defun display-time-world ()
diff --git a/lisp/tool-bar.el b/lisp/tool-bar.el
index 875eb240433..a3292c42046 100644
--- a/lisp/tool-bar.el
+++ b/lisp/tool-bar.el
@@ -1,10 +1,11 @@
;;; tool-bar.el --- setting up the tool bar
-;;
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-;;
+
+;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+;; 2009, 2010 Free Software Foundation, Inc.
+
;; Author: Dave Love <fx@gnu.org>
;; Keywords: mouse frames
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -48,21 +49,23 @@ With numeric ARG, display the tool bar if and only if ARG is positive.
See `tool-bar-add-item' and `tool-bar-add-item-from-menu' for
conveniently adding tool bar items."
- :init-value nil
+ :init-value t
:global t
- :group 'mouse
- :group 'frames
- (if tool-bar-mode
- (progn
- ;; Make one tool-bar-line for any - including non-graphical -
- ;; terminal, see Bug#1754. If this causes problems, we should
- ;; handle the problem in `modify-frame-parameters' or do not
- ;; call `modify-all-frames-parameters' when toggling the tool
- ;; bar off either.
- (modify-all-frames-parameters (list (cons 'tool-bar-lines 1)))
- (if (= 1 (length (default-value 'tool-bar-map))) ; not yet setup
- (tool-bar-setup)))
- (modify-all-frames-parameters (list (cons 'tool-bar-lines 0)))))
+ ;; It's defined in C/cus-start, this stops the d-m-m macro defining it again.
+ :variable tool-bar-mode
+ (let ((val (if tool-bar-mode 1 0)))
+ (dolist (frame (frame-list))
+ (set-frame-parameter frame 'tool-bar-lines val))
+ ;; If the user has given `default-frame-alist' a `tool-bar-lines'
+ ;; parameter, replace it.
+ (if (assq 'tool-bar-lines default-frame-alist)
+ (setq default-frame-alist
+ (cons (cons 'tool-bar-lines val)
+ (assq-delete-all 'tool-bar-lines
+ default-frame-alist)))))
+ (and tool-bar-mode
+ (= 1 (length (default-value 'tool-bar-map))) ; not yet setup
+ (tool-bar-setup)))
;;;###autoload
;; Used in the Show/Hide menu, to have the toggle reflect the current frame.
@@ -74,17 +77,6 @@ See `tool-bar-mode' for more information."
(tool-bar-mode (if (> (frame-parameter nil 'tool-bar-lines) 0) 0 1))
(tool-bar-mode arg)))
-;;;###autoload
-;; We want to pretend the toolbar by standard is on, as this will make
-;; customize consider disabling the toolbar a customization, and save
-;; that. We could do this for real by setting :init-value above, but
-;; that would turn on the toolbar in MS Windows where it is currently
-;; useless, and it would overwrite disabling the tool bar from X
-;; resources. If anyone want to implement this in a cleaner way,
-;; please do so.
-;; -- Per Abrahamsen <abraham@dina.kvl.dk> 2002-02-21.
-(put 'tool-bar-mode 'standard-value '(t))
-
(defvar tool-bar-map (make-sparse-keymap)
"Keymap for the tool bar.
Define this locally to override the global tool bar.")
@@ -232,6 +224,7 @@ holds a keymap."
submap key)
;; We'll pick up the last valid entry in the list of keys if
;; there's more than one.
+ ;; FIXME: Aren't they *all* "valid"?? --Stef
(dolist (k keys)
;; We're looking for a binding of the command in a submap of
;; the menu bar map, so the key sequence must be two or more
@@ -267,57 +260,68 @@ holds a keymap."
;; People say it's bad to have EXIT on the tool bar, since users
;; might inadvertently click that button.
;;(tool-bar-add-item-from-menu 'save-buffers-kill-emacs "exit")
- (tool-bar-add-item-from-menu 'find-file "new")
- (tool-bar-add-item-from-menu 'menu-find-file-existing "open")
- (tool-bar-add-item-from-menu 'dired "diropen")
- (tool-bar-add-item-from-menu 'kill-this-buffer "close")
- (tool-bar-add-item-from-menu 'save-buffer "save" nil
+ (tool-bar-add-item-from-menu 'find-file "new" nil :label "New File"
+ :vert-only t)
+ (tool-bar-add-item-from-menu 'menu-find-file-existing "open" nil
+ :vert-only t)
+ (tool-bar-add-item-from-menu 'dired "diropen" nil :vert-only t)
+ (tool-bar-add-item-from-menu 'kill-this-buffer "close" nil :vert-only t)
+ (tool-bar-add-item-from-menu 'save-buffer "save" nil :vert-only t
:visible '(or buffer-file-name
(not (eq 'special
(get major-mode
'mode-class)))))
- (tool-bar-add-item-from-menu 'write-file "saveas" nil
- :visible '(or buffer-file-name
- (not (eq 'special
- (get major-mode
- 'mode-class)))))
- (tool-bar-add-item-from-menu 'undo "undo" nil
+ (tool-bar-add-item-from-menu 'undo "undo" nil :vert-only t
:visible '(not (eq 'special (get major-mode
'mode-class))))
(tool-bar-add-item-from-menu (lookup-key menu-bar-edit-menu [cut])
- "cut" nil
+ "cut" nil :vert-only t
:visible '(not (eq 'special (get major-mode
'mode-class))))
(tool-bar-add-item-from-menu (lookup-key menu-bar-edit-menu [copy])
- "copy")
+ "copy" nil :vert-only t)
(tool-bar-add-item-from-menu (lookup-key menu-bar-edit-menu [paste])
- "paste" nil
+ "paste" nil :vert-only t
:visible '(not (eq 'special (get major-mode
'mode-class))))
- (tool-bar-add-item-from-menu 'nonincremental-search-forward "search")
+ (tool-bar-add-item-from-menu 'nonincremental-search-forward "search"
+ nil :label "Search")
;;(tool-bar-add-item-from-menu 'ispell-buffer "spell")
;; There's no icon appropriate for News and we need a command rather
;; than a lambda for Read Mail.
;;(tool-bar-add-item-from-menu 'compose-mail "mail/compose")
- (tool-bar-add-item-from-menu 'print-buffer "print")
;; tool-bar-add-item-from-menu itself operates on
;; (default-value 'tool-bar-map), but when we don't use that function,
;; we must explicitly operate on the default value.
(let ((tool-bar-map (default-value 'tool-bar-map)))
- (tool-bar-add-item "preferences" 'customize 'customize
- :help "Edit preferences (customize)")
-
(tool-bar-add-item "help" (lambda ()
(interactive)
(popup-menu menu-bar-help-menu))
'help
:help "Pop up the Help menu")))
+(if (featurep 'move-toolbar)
+ (defcustom tool-bar-position 'top
+ "Specify on which side the tool bar shall be.
+Possible values are `top' (tool bar on top), `bottom' (tool bar at bottom),
+`left' (tool bar on left) and `right' (tool bar on right).
+Customize `tool-bar-mode' if you want to show or hide the tool bar."
+ :type '(choice (const top)
+ (const bottom)
+ (const left)
+ (const right))
+ :group 'frames
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (set-default sym val)
+ (modify-all-frames-parameters
+ (list (cons 'tool-bar-position val))))))
+
(provide 'tool-bar)
-;; arch-tag: 15f30f0a-d0d7-4d50-bbb7-f48fd0c8582f
+
;;; tool-bar.el ends here
diff --git a/lisp/tooltip.el b/lisp/tooltip.el
index 344f01fa4cc..5987b00f92e 100644
--- a/lisp/tooltip.el
+++ b/lisp/tooltip.el
@@ -5,6 +5,7 @@
;; Author: Gerd Moellmann <gerd@acm.org>
;; Keywords: help c mouse tools
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/tutorial.el b/lisp/tutorial.el
index de7f7ab4a3c..6961fafb3aa 100644
--- a/lisp/tutorial.el
+++ b/lisp/tutorial.el
@@ -4,6 +4,7 @@
;; Maintainer: FSF
;; Keywords: help, internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -218,8 +219,8 @@ LEFT and RIGHT are the elements to compare."
(save-buffers-kill-terminal [?\C-x ?\C-c])
;; * SUMMARY
- (scroll-up [?\C-v])
- (scroll-down [?\M-v])
+ (scroll-up-command [?\C-v])
+ (scroll-down-command [?\M-v])
(recenter-top-bottom [?\C-l])
;; * BASIC CURSOR CONTROL
@@ -252,7 +253,7 @@ LEFT and RIGHT are the elements to compare."
;; * INSERTING AND DELETING
;; C-u 8 * to insert ********.
(delete-backward-char "\d")
- (delete-char [?\C-d])
+ (delete-forward-char [?\C-d])
(backward-kill-word [?\M-\d])
(kill-word [?\M-d])
(kill-line [?\C-k])
@@ -829,6 +830,8 @@ Run the Viper tutorial? "))
(if old-tut-file
(progn
(insert-file-contents (tutorial--saved-file))
+ (let ((enable-local-variables :safe))
+ (hack-local-variables))
(goto-char (point-min))
(setq old-tut-point
(string-to-number
@@ -844,6 +847,8 @@ Run the Viper tutorial? "))
(goto-char tutorial--point-before-chkeys)
(setq tutorial--point-before-chkeys (point-marker)))
(insert-file-contents (expand-file-name filename tutorial-directory))
+ (let ((enable-local-variables :safe))
+ (hack-local-variables))
(forward-line)
(setq tutorial--point-before-chkeys (point-marker)))
diff --git a/lisp/type-break.el b/lisp/type-break.el
index 46523c22995..83278cbc6cc 100644
--- a/lisp/type-break.el
+++ b/lisp/type-break.el
@@ -1,7 +1,7 @@
;;; type-break.el --- encourage rests from typing at appropriate intervals
-;; Copyright (C) 1994, 1995, 1997, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 1995, 1997, 2000, 2001, 2002, 2003, 2004, 2005,
+;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Noah Friedman
;; Maintainer: Noah Friedman <friedman@splode.com>
@@ -152,13 +152,6 @@ guess a reasonably good pair of values for this variable."
:type 'sexp
:group 'type-break)
-(defcustom type-break-query-mode t
- "Non-nil means ask whether or not to prompt user for breaks.
-If so, call the function specified in the value of the variable
-`type-break-query-function' to do the asking."
- :type 'boolean
- :group 'type-break)
-
(defcustom type-break-query-function 'yes-or-no-p
"Function to use for making query for a typing break.
It should take a string as an argument, the prompt.
@@ -245,14 +238,6 @@ remove themselves after running.")
;; Mode line frobs
-(defcustom type-break-mode-line-message-mode nil
- "Non-nil means put type-break related messages in the mode line.
-Otherwise, messages typically go in the echo area.
-
-See also `type-break-mode-line-format' and its members."
- :type 'boolean
- :group 'type-break)
-
(defvar type-break-mode-line-format
'(type-break-mode-line-message-mode
(""
@@ -447,7 +432,7 @@ problems."
(message "Type Break mode is disabled")))))
type-break-mode)
-(defun type-break-mode-line-message-mode (&optional prefix)
+(define-minor-mode type-break-mode-line-message-mode
"Enable or disable warnings in the mode line about typing breaks.
A negative PREFIX argument disables this mode.
@@ -462,16 +447,9 @@ Variables controlling the display of messages in the mode line include:
`global-mode-string'
`type-break-mode-line-break-message'
`type-break-mode-line-warning'"
- (interactive "P")
- (setq type-break-mode-line-message-mode
- (>= (prefix-numeric-value prefix) 0))
- (and (called-interactively-p 'interactive)
- (if type-break-mode-line-message-mode
- (message "type-break-mode-line-message-mode is enabled")
- (message "type-break-mode-line-message-mode is disabled")))
- type-break-mode-line-message-mode)
-
-(defun type-break-query-mode (&optional prefix)
+ :global t)
+
+(define-minor-mode type-break-query-mode
"Enable or disable warnings in the mode line about typing breaks.
When enabled, the user is periodically queried about whether to take a
@@ -483,14 +461,7 @@ No argument or any non-negative argument enables it.
The user may also enable or disable this mode simply by setting the
variable of the same name."
- (interactive "P")
- (setq type-break-query-mode
- (>= (prefix-numeric-value prefix) 0))
- (and (called-interactively-p 'interactive)
- (if type-break-query-mode
- (message "type-break-query-mode is enabled")
- (message "type-break-query-mode is disabled")))
- type-break-query-mode)
+ :global t)
;;; session file functions
@@ -524,7 +495,7 @@ variable of the same name."
(let ((inhibit-read-only t))
(goto-char (point-min))
(forward-line)
- (delete-region (point) (save-excursion (end-of-line) (point)))
+ (delete-region (point) (line-end-position))
(insert (format "%s" type-break-keystroke-count))
;; file saving is left to auto-save
))))))
@@ -1272,5 +1243,4 @@ With optional non-nil ALL, force redisplay of all mode-lines."
(if type-break-mode
(type-break-mode 1))
-;; arch-tag: 943a2eb3-07e6-420b-993f-96e4796f5fd0
;;; type-break.el ends here
diff --git a/lisp/uniquify.el b/lisp/uniquify.el
index ddf15e243c4..a654b2dcfc5 100644
--- a/lisp/uniquify.el
+++ b/lisp/uniquify.el
@@ -7,6 +7,7 @@
;; Maintainer: FSF
;; Keywords: files
;; Created: 15 May 86
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -89,7 +90,7 @@
(defgroup uniquify nil
"Unique buffer names dependent on file name."
- :group 'applications)
+ :group 'files)
(defcustom uniquify-buffer-name-style nil
diff --git a/lisp/url/ChangeLog b/lisp/url/ChangeLog
index 90533fa297c..44cc511c99c 100644
--- a/lisp/url/ChangeLog
+++ b/lisp/url/ChangeLog
@@ -1,27 +1,132 @@
-2010-09-18 Glenn Morris <rgm@gnu.org>
+2010-11-16 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * url-file.el (url-file-build-filename): Avoid interpreting
+ file:/foo:/bar URLs via tramp.
+
+2010-10-14 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * url-gw.el (url-open-stream): Use open-gnutls-stream if it exists.
+
+2010-10-07 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * url-http.el (url-http-end-of-document-sentinel): Protect against
+ the process buffer being killed.
+
+2010-10-04 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * url-http.el (url-http-wait-for-headers-change-function): Protect
+ against url-http-response-status for degenerate documents.
+ (url-http-wait-for-headers-change-function): Revert previous
+ change. It lead to really slow loads.
+
+2010-10-03 Glenn Morris <rgm@gnu.org>
+
+ * url-util.el (url-get-url-filename-chars): Don't eval-and-compile.
+ (url-get-url-at-point): Don't use eval-when-compile.
+
+ * url-cache.el (url-cache-create-filename-human-readable)
+ (url-cache-create-filename-using-md5):
+ * url-util.el (url-file-directory, url-file-nondirectory):
+ Don't use eval-when-compile and regexp-quote.
+
+2010-10-03 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * url-vars.el (url-mime-charset-string): Changed the default to
+ nil to avoid sending 1171 bytes of not very useful data to the
+ HTTP server every request.
+
+2010-10-02 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * url-util.el (url-display-percentage): Don't message when the URL
+ is silent.
+ (url-lazy-message): Ditto.
+ (url-lazy-message): Remove leftover debugging code.
+
+ * url-http.el (url-http-parse-headers): Pass the SILENT parameter
+ back to the fetching function.
+
+ * url.el (url-retrieve): Add a silent parameter.
+ (url-retrieve-internal): Ditto.
+
+ * url-parse.el (url): Add a `silent' slot in the URL struct.
+
+2010-10-01 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * url-cookie.el (url-cookie-handle-set-cookie): Use
+ url-lazy-message for the cookie warning, which isn't very interesting.
+
+ * url-http.el (url-http-async-sentinel): Check that the buffer is
+ still alive before switching to it.
+
+2010-09-25 Julien Danjou <julien@danjou.info>
+
+ * url-cache.el (url-cache-create-filename): Ensure no-port and
+ default-port end up with the same cache file.
+ (url-cache-create-filename-human-readable)
+ (url-cache-create-filename-using-md5): Argument is always in the form of
+ a string now.
+
+2010-09-23 Glenn Morris <rgm@gnu.org>
* url-cache.el (url-is-cached): Doc fix.
-2010-09-11 Julien Danjou <julien@danjou.info>
+2010-09-23 Glenn Morris <rgm@gnu.org>
+
+ * url-cache.el (url-cache-expired): Don't autoload.
+ Tweak previous change.
+ (url-cache-expire-time): Doc fix.
+
+2010-09-23 Julien Danjou <julien@danjou.info>
- * url-cache (url-store-in-cache): Make `buff' argument really optional.
+ * url-cache.el (url-cache-expire-time): New option.
+ (url-cache-expired): Rewrite.
-2010-09-09 Glenn Morris <rgm@gnu.org>
+2010-09-19 Julien Danjou <julien@danjou.info>
+
+ * url-cache.el (url-fetch-from-cache): New function.
+
+2010-09-18 Julien Danjou <julien@danjou.info>
+
+ * url-vars.el (url-cache-expired): Remove unused variable.
+
+2010-09-14 Julien Danjou <julien@danjou.info>
+
+ * url-cache.el (url-store-in-cache):
+ Make `buff' argument really optional.
+
+2010-09-14 Glenn Morris <rgm@gnu.org>
* url-cookie.el (url-cookie-expired-p): Tweak previous change.
-2010-09-09 shawn boles <shawn.boles@gmail.com> (tiny change)
+2010-09-14 shawn boles <shawn.boles@gmail.com> (tiny change)
* url-cookie.el (url-cookie-expired-p): Simplify and fix. (Bug#6957)
-2010-07-26 Michael Albinus <michael.albinus@gmx.de>
+2010-09-11 Glenn Morris <rgm@gnu.org>
- * url-http (url-http-parse-headers): Disable file name handlers at
+ * url-cache.el, url-gw.el, url-history.el, url-irc.el, url-util.el:
+ * url-vars.el: Remove leading `*' from defcustom docs.
+
+2010-07-27 Michael Albinus <michael.albinus@gmx.de>
+
+ * url-http.el (url-http-parse-headers): Disable file name handlers at
all (not only Tramp). (Bug#6717)
-2010-07-25 Michael Albinus <michael.albinus@gmx.de>
+2010-07-27 Michael Albinus <michael.albinus@gmx.de>
+
+ * url-http.el (url-http-parse-headers): Disable Tramp. (Bug#6717)
+
+2010-07-01 Mark A. Hershberger <mah@everybody.org>
+
+ * url-http.el (url-http-create-request): Add a CRLF on the end so
+ that POSTs with content to https urls work. See
+ <https://bugs.launchpad.net/mediawiki-el/+bug/540759>
+
+2010-06-22 Mark A. Hershberger <mah@everybody.org>
- * url-http (url-http-parse-headers): Disable Tramp. (Bug#6717)
+ * url-parse.el (url-user-for-url, url-password-for-url):
+ Convenience functions that get usernames and passwords for urls
+ from auth-source functions.
2010-06-12 Štěpán Němec <stepnem@gmail.com> (tiny change)
@@ -35,6 +140,33 @@
* Version 23.2 released.
+2010-05-03 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * url-dired.el (url-dired-minor-mode): Use define-minor-mode.
+
+2010-03-24 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * url-http.el (url-http-parse-headers): Fix wrong variable name.
+
+2010-03-24 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * url-http.el (url-http-codes): New variable to hold a mapping of
+ HTTP status codes' numbers, their symbolic name, and their text.
+ (url-http-parse-headers): Use it, leaving the original numeric
+ code in a comment.
+
+2010-03-19 Glenn Morris <rgm@gnu.org>
+
+ * url.el: Move mailcap require earlier in the file.
+
+2010-03-12 Chong Yidong <cyd@stupidchicken.com>
+
+ * url-vars.el (url): Put in comm group.
+
+2010-03-10 Chong Yidong <cyd@stupidchicken.com>
+
+ * Branch for 23.2.
+
2010-01-23 Chong Yidong <cyd@stupidchicken.com>
* url-util.el: Require url-vars (Bug#5459).
@@ -72,8 +204,8 @@
2009-09-12 Chong Yidong <cyd@stupidchicken.com>
* url-methods.el (url-scheme--registering-proxy): New variable.
- (url-scheme-register-proxy, url-scheme-get-property): Avoid
- calling url-scheme-register-proxy in an infloop (Bug#4191).
+ (url-scheme-register-proxy, url-scheme-get-property):
+ Avoid calling url-scheme-register-proxy in an infloop (Bug#4191).
2009-08-22 Glenn Morris <rgm@gnu.org>
@@ -206,7 +338,7 @@
2008-03-09 Magnus Henoch <mange@freemail.hu>
* url-http.el (url-http-chunked-encoding-after-change-function):
- Remove superfluous CRLF at end of file. (bug #42)
+ Remove superfluous CRLF at end of file. (Bug #42)
2008-03-02 Andreas Schwab <schwab@suse.de>
diff --git a/lisp/url/url-cache.el b/lisp/url/url-cache.el
index 19b2442f584..4ef8ab5d902 100644
--- a/lisp/url/url-cache.el
+++ b/lisp/url/url-cache.el
@@ -28,10 +28,17 @@
(defcustom url-cache-directory
(expand-file-name "cache" url-configuration-directory)
- "*The directory where cache files should be stored."
+ "The directory where cache files should be stored."
:type 'directory
:group 'url-file)
+(defcustom url-cache-expire-time 3600
+ "Default maximum time in seconds before cache files expire.
+Used by the function `url-cache-expired'."
+ :version "24.1"
+ :type 'integer
+ :group 'url-cache)
+
;; Cache manager
(defun url-cache-file-writable-p (file)
"Follows the documentation of `file-writable-p', unlike `file-writable-p'."
@@ -68,6 +75,12 @@ FILE can be created or overwritten."
(let ((coding-system-for-write 'binary))
(write-region (point-min) (point-max) fname nil 5))))))
+(defun url-fetch-from-cache (url)
+ "Fetch URL from cache and return a buffer with the content."
+ (with-current-buffer (generate-new-buffer " *temp*")
+ (url-cache-extract (url-cache-create-filename url))
+ (current-buffer)))
+
;;;###autoload
(defun url-is-cached (url)
"Return non-nil if the URL is cached.
@@ -82,8 +95,7 @@ The actual return value is the last modification time of the cache file."
(defun url-cache-create-filename-human-readable (url)
"Return a filename in the local cache for URL."
(if url
- (let* ((url (if (vectorp url) (url-recreate-url url) url))
- (urlobj (url-generic-parse-url url))
+ (let* ((urlobj (url-generic-parse-url url))
(protocol (url-type urlobj))
(hostname (url-host urlobj))
(host-components
@@ -91,8 +103,7 @@ The actual return value is the last modification time of the cache file."
(user-real-login-name)
(cons (or protocol "file")
(reverse (split-string (or hostname "localhost")
- (eval-when-compile
- (regexp-quote ".")))))))
+ "\\.")))))
(fname (url-filename urlobj)))
(if (and fname (/= (length fname) 0) (= (aref fname 0) ?/))
(setq fname (substring fname 1 nil)))
@@ -141,8 +152,7 @@ The actual return value is the last modification time of the cache file."
Very fast if you have an `md5' primitive function, suitably fast otherwise."
(require 'md5)
(if url
- (let* ((url (if (vectorp url) (url-recreate-url url) url))
- (checksum (md5 url))
+ (let* ((checksum (md5 url))
(urlobj (url-generic-parse-url url))
(protocol (url-type urlobj))
(hostname (url-host urlobj))
@@ -153,8 +163,7 @@ Very fast if you have an `md5' primitive function, suitably fast otherwise."
(nreverse
(delq nil
(split-string (or hostname "localhost")
- (eval-when-compile
- (regexp-quote "."))))))))
+ "\\."))))))
(fname (url-filename urlobj)))
(and fname
(expand-file-name checksum
@@ -163,7 +172,7 @@ Very fast if you have an `md5' primitive function, suitably fast otherwise."
url-cache-directory))))))
(defcustom url-cache-creation-function 'url-cache-create-filename-using-md5
- "*What function to use to create a cached filename."
+ "What function to use to create a cached filename."
:type '(choice (const :tag "MD5 of filename (low collision rate)"
:value url-cache-create-filename-using-md5)
(const :tag "Human readable filenames (higher collision rate)"
@@ -172,7 +181,13 @@ Very fast if you have an `md5' primitive function, suitably fast otherwise."
:group 'url-cache)
(defun url-cache-create-filename (url)
- (funcall url-cache-creation-function url))
+ (funcall url-cache-creation-function
+ ;; We need to parse+recreate in order to remove the default port
+ ;; if it has been specified: e.g. http://www.example.com:80 will
+ ;; be transcoded as http://www.example.com
+ (url-recreate-url
+ (if (vectorp url) url
+ (url-generic-parse-url url)))))
;;;###autoload
(defun url-cache-extract (fnam)
@@ -180,22 +195,19 @@ Very fast if you have an `md5' primitive function, suitably fast otherwise."
(erase-buffer)
(insert-file-contents-literally fnam))
-;;;###autoload
-(defun url-cache-expired (url mod)
- "Return t if a cached file has expired."
- (let* ((urlobj (if (vectorp url) url (url-generic-parse-url url)))
- (type (url-type urlobj)))
- (cond
- (url-standalone-mode
- (not (file-exists-p (url-cache-create-filename url))))
- ((string= type "http")
- t)
- ((member type '("file" "ftp"))
- (if (or (equal mod '(0 0)) (not mod))
- t
- (or (> (nth 0 mod) (nth 0 (current-time)))
- (> (nth 1 mod) (nth 1 (current-time))))))
- (t nil))))
+(defun url-cache-expired (url &optional expire-time)
+ "Return non-nil if a cached URL is older than EXPIRE-TIME seconds.
+The default value of EXPIRE-TIME is `url-cache-expire-time'.
+If `url-standalone-mode' is non-nil, cached items never expire."
+ (if url-standalone-mode
+ (not (file-exists-p (url-cache-create-filename url)))
+ (let ((cache-time (url-is-cached url)))
+ (or (not cache-time)
+ (time-less-p
+ (time-add
+ cache-time
+ (seconds-to-time (or expire-time url-cache-expire-time)))
+ (current-time))))))
(provide 'url-cache)
diff --git a/lisp/url/url-cookie.el b/lisp/url/url-cookie.el
index 2067f097224..e056db38a98 100644
--- a/lisp/url/url-cookie.el
+++ b/lisp/url/url-cookie.el
@@ -400,8 +400,8 @@ telling Microsoft that."
(url-cookie-store (car cur) (cdr cur)
expires domain localpart secure))))
(t
- (message "%s tried to set a cookie for domain %s - rejected."
- (url-host url-current-object) domain)))))
+ (url-lazy-message "%s tried to set a cookie for domain %s - rejected."
+ (url-host url-current-object) domain)))))
(defvar url-cookie-timer nil)
diff --git a/lisp/url/url-dired.el b/lisp/url/url-dired.el
index af2f4b202d9..143c5721b34 100644
--- a/lisp/url/url-dired.el
+++ b/lisp/url/url-dired.el
@@ -31,11 +31,6 @@
map)
"Keymap used when browsing directories.")
-(defvar url-dired-minor-mode nil
- "Whether we are in url-dired-minor-mode.")
-
-(make-variable-buffer-local 'url-dired-minor-mode)
-
(defun url-dired-find-file ()
"In dired, visit the file or directory named on this line."
(interactive)
@@ -48,39 +43,9 @@
(mouse-set-point event)
(url-dired-find-file))
-(defun url-dired-minor-mode (&optional arg)
+(define-minor-mode url-dired-minor-mode
"Minor mode for directory browsing."
- (interactive "P")
- (cond
- ((null arg)
- (setq url-dired-minor-mode (not url-dired-minor-mode)))
- ((equal 0 arg)
- (setq url-dired-minor-mode nil))
- (t
- (setq url-dired-minor-mode t))))
-
-(if (not (fboundp 'add-minor-mode))
- (defun add-minor-mode (toggle name &optional keymap after toggle-fun)
- "Add a minor mode to `minor-mode-alist' and `minor-mode-map-alist'.
-TOGGLE is a symbol which is used as the variable which toggle the minor mode,
-NAME is the name that should appear in the modeline (it should be a string
-beginning with a space), KEYMAP is a keymap to make active when the minor
-mode is active, and AFTER is the toggling symbol used for another minor
-mode. If AFTER is non-nil, then it is used to position the new mode in the
-minor-mode alists. TOGGLE-FUN specifies an interactive function that
-is called to toggle the mode on and off; this affects what appens when
-button2 is pressed on the mode, and when button3 is pressed somewhere
-in the list of modes. If TOGGLE-FUN is nil and TOGGLE names an
-interactive function, TOGGLE is used as the toggle function.
-
-Example: (add-minor-mode 'view-minor-mode \" View\" view-mode-map)"
- (if (not (assq toggle minor-mode-alist))
- (setq minor-mode-alist (cons (list toggle name) minor-mode-alist)))
- (if (and keymap (not (assq toggle minor-mode-map-alist)))
- (setq minor-mode-map-alist (cons (cons toggle keymap)
- minor-mode-map-alist)))))
-
-(add-minor-mode 'url-dired-minor-mode " URL" url-dired-minor-mode-map)
+ :lighter " URL" :keymap url-dired-minor-mode-map)
(defun url-find-file-dired (dir)
"\"Edit\" directory DIR, but with additional URL-friendly bindings."
diff --git a/lisp/url/url-file.el b/lisp/url/url-file.el
index 4e86c653c8c..22d74b3371b 100644
--- a/lisp/url/url-file.el
+++ b/lisp/url/url-file.el
@@ -103,12 +103,19 @@ to them."
(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 '(ms-dos windows-nt))
- (string-match "^/[a-zA-Z]:/" file))
- (substring file 1)
- file)))
+ (filename (cond
+ ;; ftp: URL.
+ ((or user (not (url-file-host-is-local-p host)))
+ (concat "/" (or user "anonymous") "@" site ":" file))
+ ;; file: URL on Windows.
+ ((and (string-match "\\`/[a-zA-Z]:/" file)
+ (memq system-type '(ms-dos windows-nt)))
+ (substring file 1))
+ ;; file: URL with a file:/bar:/foo-like spec.
+ ((string-match "\\`/[^/]+:/" file)
+ (concat "/:" file))
+ (t
+ file)))
pos-index)
(and user pass
diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el
index 9915ccc6781..4358255bde5 100644
--- a/lisp/url/url-gw.el
+++ b/lisp/url/url-gw.el
@@ -37,50 +37,50 @@
:group 'url)
(defcustom url-gateway-local-host-regexp nil
- "*A regular expression specifying local hostnames/machines."
+ "A regular expression specifying local hostnames/machines."
:type '(choice (const nil) regexp)
:group 'url-gateway)
(defcustom url-gateway-prompt-pattern
"^[^#$%>;]*[#$%>;] *" ;; "bash\\|\$ *\r?$\\|> *\r?"
- "*A regular expression matching a shell prompt."
+ "A regular expression matching a shell prompt."
:type 'regexp
:group 'url-gateway)
(defcustom url-gateway-rlogin-host nil
- "*What hostname to actually rlog into before doing a telnet."
+ "What hostname to actually rlog into before doing a telnet."
:type '(choice (const nil) string)
:group 'url-gateway)
(defcustom url-gateway-rlogin-user-name nil
- "*Username to log into the remote machine with when using rlogin."
+ "Username to log into the remote machine with when using rlogin."
:type '(choice (const nil) string)
:group 'url-gateway)
(defcustom url-gateway-rlogin-parameters '("telnet" "-8")
- "*Parameters to `url-open-rlogin'.
+ "Parameters to `url-open-rlogin'.
This list will be used as the parameter list given to rsh."
:type '(repeat string)
:group 'url-gateway)
(defcustom url-gateway-telnet-host nil
- "*What hostname to actually login to before doing a telnet."
+ "What hostname to actually login to before doing a telnet."
:type '(choice (const nil) string)
:group 'url-gateway)
(defcustom url-gateway-telnet-parameters '("exec" "telnet" "-8")
- "*Parameters to `url-open-telnet'.
+ "Parameters to `url-open-telnet'.
This list will be executed as a command after logging in via telnet."
:type '(repeat string)
:group 'url-gateway)
(defcustom url-gateway-telnet-login-prompt "^\r*.?login:"
- "*Prompt that tells us we should send our username when loggin in w/telnet."
+ "Prompt that tells us we should send our username when loggin in w/telnet."
:type 'regexp
:group 'url-gateway)
(defcustom url-gateway-telnet-password-prompt "^\r*.?password:"
- "*Prompt that tells us we should send our password when loggin in w/telnet."
+ "Prompt that tells us we should send our password when loggin in w/telnet."
:type 'regexp
:group 'url-gateway)
@@ -95,7 +95,7 @@ This list will be executed as a command after logging in via telnet."
:group 'url-gateway)
(defcustom url-gateway-broken-resolution nil
- "*Whether to use nslookup to resolve hostnames.
+ "Whether to use nslookup to resolve hostnames.
This should be used when your version of Emacs cannot correctly use DNS,
but your machine can. This usually happens if you are running a statically
linked Emacs under SunOS 4.x."
@@ -103,7 +103,7 @@ linked Emacs under SunOS 4.x."
:group 'url-gateway)
(defcustom url-gateway-nslookup-program "nslookup"
- "*If non-nil then a string naming nslookup program."
+ "If non-nil then a string naming nslookup program."
:type '(choice (const :tag "None" :value nil) string)
:group 'url-gateway)
@@ -245,7 +245,10 @@ Might do a non-blocking connection; use `process-status' to check."
(coding-system-for-write 'binary))
(setq conn (case gw-method
(tls
- (open-tls-stream name buffer host service))
+ (funcall (if (fboundp 'open-gnutls-stream)
+ 'open-gnutls-stream
+ 'open-tls-stream)
+ name buffer host service))
(ssl
(open-ssl-stream name buffer host service))
((native)
diff --git a/lisp/url/url-history.el b/lisp/url/url-history.el
index 5b4f330ed2e..0cc891b32b7 100644
--- a/lisp/url/url-history.el
+++ b/lisp/url/url-history.el
@@ -1,7 +1,7 @@
;;; url-history.el --- Global history tracking for URL package
-;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1998, 1999, 2004, 2005, 2006, 2007, 2008,
+;; 2009, 2010 Free Software Foundation, Inc.
;; Keywords: comm, data, processes, hypermedia
@@ -35,7 +35,7 @@
:group 'url)
(defcustom url-history-track nil
- "*Controls whether to keep a list of all the URLs being visited.
+ "Controls whether to keep a list of all the URLs being visited.
If non-nil, the URL package will keep track of all the URLs visited.
If set to t, then the list is saved to disk at the end of each Emacs
session."
@@ -49,14 +49,14 @@ session."
:group 'url-history)
(defcustom url-history-file nil
- "*The global history file for the URL package.
+ "The global history file for the URL package.
This file contains a list of all the URLs you have visited. This file
is parsed at startup and used to provide URL completion."
:type '(choice (const :tag "Default" :value nil) file)
:group 'url-history)
(defcustom url-history-save-interval 3600
- "*The number of seconds between automatic saves of the history list.
+ "The number of seconds between automatic saves of the history list.
Default is 1 hour. Note that if you change this variable outside of
the `customize' interface after `url-do-setup' has been run, you need
to run the `url-history-setup-save-timer' function manually."
diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el
index 00cfa46ea18..9bfb6df1d42 100644
--- a/lisp/url/url-http.el
+++ b/lisp/url/url-http.el
@@ -1,7 +1,7 @@
;;; url-http.el --- HTTP retrieval routines
-;; Copyright (C) 1999, 2001, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2001, 2004, 2005, 2006, 2007, 2008, 2009,
+;; 2010 Free Software Foundation, Inc.
;; Author: Bill Perry <wmperry@gnu.org>
;; Keywords: comm, data, processes
@@ -64,6 +64,55 @@ This is only useful when debugging the HTTP subsystem. Setting to
nil will explicitly close the connection to the server after every
request.")
+(defconst url-http-codes
+ '((100 continue "Continue with request")
+ (101 switching-protocols "Switching protocols")
+ (102 processing "Processing (Added by DAV)")
+ (200 OK "OK")
+ (201 created "Created")
+ (202 accepted "Accepted")
+ (203 non-authoritative "Non-authoritative information")
+ (204 no-content "No content")
+ (205 reset-content "Reset content")
+ (206 partial-content "Partial content")
+ (207 multi-status "Multi-status (Added by DAV)")
+ (300 multiple-choices "Multiple choices")
+ (301 moved-permanently "Moved permanently")
+ (302 found "Found")
+ (303 see-other "See other")
+ (304 not-modified "Not modified")
+ (305 use-proxy "Use proxy")
+ (307 temporary-redirect "Temporary redirect")
+ (400 bad-request "Bad Request")
+ (401 unauthorized "Unauthorized")
+ (402 payment-required "Payment required")
+ (403 forbidden "Forbidden")
+ (404 not-found "Not found")
+ (405 method-not-allowed "Method not allowed")
+ (406 not-acceptable "Not acceptable")
+ (407 proxy-authentication-required "Proxy authentication required")
+ (408 request-timeout "Request time-out")
+ (409 conflict "Conflict")
+ (410 gone "Gone")
+ (411 length-required "Length required")
+ (412 precondition-failed "Precondition failed")
+ (413 request-entity-too-large "Request entity too large")
+ (414 request-uri-too-large "Request-URI too large")
+ (415 unsupported-media-type "Unsupported media type")
+ (416 requested-range-not-satisfiable "Requested range not satisfiable")
+ (417 expectation-failed "Expectation failed")
+ (422 unprocessable-entity "Unprocessable Entity (Added by DAV)")
+ (423 locked "Locked")
+ (424 failed-Dependency "Failed Dependency")
+ (500 internal-server-error "Internal server error")
+ (501 not-implemented "Not implemented")
+ (502 bad-gateway "Bad gateway")
+ (503 service-unavailable "Service unavailable")
+ (504 gateway-timeout "Gateway time-out")
+ (505 http-version-not-supported "HTTP version not supported")
+ (507 insufficient-storage "Insufficient storage")
+"The HTTP return codes and their text."))
+
;(eval-when-compile
;; These are all macros so that they are hidden from external sight
;; when the file is byte-compiled.
@@ -290,7 +339,7 @@ request.")
;; End request
"\r\n"
;; Any data
- url-http-data))
+ url-http-data "\r\n"))
""))
(url-http-debug "Request is: \n%s" request)
request))
@@ -436,6 +485,8 @@ should be shown to the user."
(let ((buffer (current-buffer))
(class nil)
(success nil)
+ ;; other status symbols: jewelry and luxury cars
+ (status-symbol (cadr (assq url-http-response-status url-http-codes)))
;; The filename part of a URL could be in remote file syntax,
;; see Bug#6717 for an example. We disable file name
;; handlers, therefore.
@@ -467,8 +518,8 @@ should be shown to the user."
;; 205 Reset content
;; 206 Partial content
;; 207 Multi-status (Added by DAV)
- (case url-http-response-status
- ((204 205)
+ (case status-symbol
+ ((no-content reset-content)
;; No new data, just stay at the same document
(url-mark-buffer-as-dead buffer)
(setq success t))
@@ -489,8 +540,8 @@ should be shown to the user."
;; 307 Temporary redirect
(let ((redirect-uri (or (mail-fetch-field "Location")
(mail-fetch-field "URI"))))
- (case url-http-response-status
- (300
+ (case status-symbol
+ (multiple-choices ; 300
;; Quoth the spec (section 10.3.1)
;; -------------------------------
;; The requested resource corresponds to any one of a set of
@@ -507,7 +558,7 @@ should be shown to the user."
;; We do not support agent-driven negotiation, so we just
;; redirect to the preferred URI if one is provided.
nil)
- ((301 302 307)
+ ((moved-permanently found temporary-redirect) ; 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
@@ -523,20 +574,20 @@ should be shown to the user."
url-http-method url-http-response-status)
(setq url-http-method "GET"
url-http-data nil)))
- (303
+ (see-other ; 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
+ (not-modified ; 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
+ (use-proxy ; 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
@@ -592,7 +643,8 @@ should be shown to the user."
(set (make-local-variable 'url-redirect-buffer)
(url-retrieve-internal
redirect-uri url-callback-function
- url-callback-arguments))
+ url-callback-arguments
+ (url-silent url-current-object)))
(url-mark-buffer-as-dead buffer))
;; We hit url-max-redirections, so issue an error and
;; stop redirecting.
@@ -624,51 +676,51 @@ should be shown to the user."
;; 422 Unprocessable Entity (Added by DAV)
;; 423 Locked
;; 424 Failed Dependency
- (case url-http-response-status
- (401
+ (case status-symbol
+ (unauthorized ; 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
+ (payment-required ; 402
;; This code is reserved for future use
(url-mark-buffer-as-dead buffer)
(error "Somebody wants you to give them money"))
- (403
+ (forbidden ; 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 ; 404
;; Not found
(setq success t))
- (405
+ (method-not-allowed ; 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
+ (not-acceptable ; 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
+ (proxy-authentication-required ; 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
+ (request-timeout ; 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
+ (conflict ; 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
@@ -677,11 +729,11 @@ should be shown to the user."
;; information for the user to recognize the source of the
;; conflict.
(setq success t))
- (410
+ (gone ; 410
;; The requested resource is no longer available at the
;; server and no forwarding address is known.
(setq success t))
- (411
+ (length-required ; 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
@@ -691,29 +743,29 @@ should be shown to the user."
;; `url-http-create-request' automatically calculates the
;; content-length.
(setq success t))
- (412
+ (precondition-failed ; 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)
+ ((request-entity-too-large request-uri-too-large) ; 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
+ (unsupported-media-type ; 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
+ (requested-range-not-satisfiable ; 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
+ (expectation-failed ; 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
@@ -740,16 +792,16 @@ should be shown to the user."
;; 507 Insufficient storage
(setq success t)
(case url-http-response-status
- (501
+ (not-implemented ; 501
;; The server does not support the functionality required to
;; fulfill the request.
nil)
- (502
+ (bad-gateway ; 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
+ (service-unavailable ; 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
@@ -758,19 +810,19 @@ should be shown to the user."
;; header. If no Retry-After is given, the client SHOULD
;; handle the response as it would for a 500 response.
nil)
- (504
+ (gateway-timeout ; 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
+ (http-version-not-supported ; 505
;; The server does not support, or refuses to support, the
;; HTTP protocol version that was used in the request
;; message.
nil)
- (507 ; DAV
+ (insufficient-storage ; 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
@@ -822,13 +874,14 @@ should be shown to the user."
(url-http-debug "url-http-end-of-document-sentinel in buffer (%s)"
(process-buffer proc))
(url-http-idle-sentinel proc why)
- (with-current-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)))))
+ (when (buffer-name (process-buffer proc))
+ (with-current-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
@@ -1193,20 +1246,21 @@ CBARGS as the arguments."
(declare (special url-callback-arguments))
;; We are performing an asynchronous connection, and a status change
;; has occurred.
- (with-current-buffer (process-buffer proc)
- (cond
- (url-http-connection-opened
- (url-http-end-of-document-sentinel proc why))
- ((string= (substring why 0 4) "open")
- (setq url-http-connection-opened t)
- (process-send-string proc (url-http-create-request)))
- (t
- (setf (car url-callback-arguments)
- (nconc (list :error (list 'error 'connection-failed why
- :host (url-host (or url-http-proxy url-current-object))
- :service (url-port (or url-http-proxy url-current-object))))
- (car url-callback-arguments)))
- (url-http-activate-callback)))))
+ (when (buffer-name (process-buffer proc))
+ (with-current-buffer (process-buffer proc)
+ (cond
+ (url-http-connection-opened
+ (url-http-end-of-document-sentinel proc why))
+ ((string= (substring why 0 4) "open")
+ (setq url-http-connection-opened t)
+ (process-send-string proc (url-http-create-request)))
+ (t
+ (setf (car url-callback-arguments)
+ (nconc (list :error (list 'error 'connection-failed why
+ :host (url-host (or url-http-proxy url-current-object))
+ :service (url-port (or url-http-proxy url-current-object))))
+ (car url-callback-arguments)))
+ (url-http-activate-callback))))))
;; Since Emacs 19/20 does not allow you to change the
;; `after-change-functions' hook in the midst of running them, we fake
@@ -1214,6 +1268,7 @@ CBARGS as the arguments."
;; 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.
+;; FIXME this can probably be simplified since the above is no longer true.
(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
diff --git a/lisp/url/url-irc.el b/lisp/url/url-irc.el
index 1469cb9eb8b..715eecd211c 100644
--- a/lisp/url/url-irc.el
+++ b/lisp/url/url-irc.el
@@ -1,7 +1,7 @@
;;; url-irc.el --- IRC URL interface
-;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1998, 1999, 2004, 2005, 2006, 2007, 2008,
+;; 2009, 2010 Free Software Foundation, Inc.
;; Keywords: comm, data, processes
@@ -22,7 +22,8 @@
;;; Commentary:
-;; IRC URLs are defined in http://www.w3.org/Addressing/draft-mirashi-url-irc-01.txt
+;; IRC URLs are defined in
+;; http://www.w3.org/Addressing/draft-mirashi-url-irc-01.txt
;;; Code:
@@ -32,7 +33,7 @@
(defconst url-irc-default-port 6667 "Default port for IRC connections.")
(defcustom url-irc-function 'url-irc-rcirc
- "*Function to actually open an IRC connection.
+ "Function to actually open an IRC connection.
The function should take the following arguments:
HOST - the hostname of the IRC server to contact
PORT - the port number of the IRC server to contact
diff --git a/lisp/url/url-parse.el b/lisp/url/url-parse.el
index e68e0791558..7cfaf2a6b55 100644
--- a/lisp/url/url-parse.el
+++ b/lisp/url/url-parse.el
@@ -25,6 +25,7 @@
;;; Code:
(require 'url-vars)
+(require 'auth-source)
(eval-when-compile (require 'cl))
(autoload 'url-scheme-get-property "url-methods")
@@ -35,7 +36,7 @@
(&optional type user password host portspec filename
target attributes fullness))
(:copier nil))
- type user password host portspec filename target attributes fullness)
+ type user password host portspec filename target attributes fullness silent)
(defsubst url-port (urlobj)
(or (url-portspec urlobj)
@@ -174,6 +175,25 @@ TYPE USER PASSWORD HOST PORTSPEC FILENAME TARGET ATTRIBUTES FULLNESS."
(url-parse-make-urlobj
prot user pass host port file refs attr full)))))))
+(defmacro url-bit-for-url (method lookfor url)
+ `(let* ((urlobj (url-generic-parse-url url))
+ (bit (funcall ,method urlobj))
+ (methods (list 'url-recreate-url
+ 'url-host)))
+ (while (and (not bit) (> (length methods) 0))
+ (setq bit
+ (auth-source-user-or-password
+ ,lookfor (funcall (pop methods) urlobj) (url-type urlobj))))
+ bit))
+
+(defun url-user-for-url (url)
+ "Attempt to use .authinfo to find a user for this URL."
+ (url-bit-for-url 'url-user "login" url))
+
+(defun url-password-for-url (url)
+ "Attempt to use .authinfo to find a password for this URL."
+ (url-bit-for-url 'url-password "password" url))
+
(provide 'url-parse)
;; arch-tag: f338325f-71ab-4bee-93cc-78fb9a03d403
diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el
index e92ccc76285..62a9a75f2db 100644
--- a/lisp/url/url-util.el
+++ b/lisp/url/url-util.el
@@ -43,7 +43,7 @@
;;;###autoload
(defcustom url-debug nil
- "*What types of debug messages from the URL library to show.
+ "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.
@@ -177,7 +177,9 @@ Strips out default port numbers, etc."
(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)
+ (if (or (and url-current-object
+ (url-silent url-current-object))
+ (null url-show-status)
(active-minibuffer-window)
(= url-lazy-message-time
(setq url-lazy-message-time (nth 1 (current-time)))))
@@ -222,7 +224,9 @@ Will not do anything if `url-show-status' is nil."
;;;###autoload
(defun url-display-percentage (fmt perc &rest args)
- (when url-show-status
+ (when (and url-show-status
+ (or (null url-current-object)
+ (not (url-silent url-current-object))))
(if (null fmt)
(if (fboundp 'clear-progress-display)
(clear-progress-display))
@@ -244,7 +248,7 @@ Will not do anything if `url-show-status' is nil."
"Return the directory part of FILE, for a URL."
(cond
((null file) "")
- ((string-match (eval-when-compile (regexp-quote "?")) file)
+ ((string-match "\\?" file)
(file-name-directory (substring file 0 (match-beginning 0))))
(t (file-name-directory file))))
@@ -253,7 +257,7 @@ Will not do anything if `url-show-status' is nil."
"Return the nondirectory part of FILE, for a URL."
(cond
((null file) "")
- ((string-match (eval-when-compile (regexp-quote "?")) file)
+ ((string-match "\\?" file)
(file-name-nondirectory (substring file 0 (match-beginning 0))))
(t (file-name-nondirectory file))))
@@ -432,10 +436,8 @@ This uses `url-current-object', set locally to the buffer."
(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.")
- )
+(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.
@@ -453,8 +455,7 @@ Has a preference for looking backward when not directly on a symbol."
(if (not (bobp))
(backward-char 1)))))
(if (and (char-after (point))
- (string-match (eval-when-compile
- (concat "[" url-get-url-filename-chars "]"))
+ (string-match (concat "[" url-get-url-filename-chars "]")
(char-to-string (char-after (point)))))
(progn
(skip-chars-backward url-get-url-filename-chars)
diff --git a/lisp/url/url-vars.el b/lisp/url/url-vars.el
index c7df921f585..8aba3efdbb6 100644
--- a/lisp/url/url-vars.el
+++ b/lisp/url/url-vars.el
@@ -1,7 +1,7 @@
;;; url-vars.el --- Variables for Uniform Resource Locator tool
-;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2004, 2005, 2006, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Keywords: comm, data, processes, hypermedia
@@ -30,7 +30,7 @@
(defgroup url nil
"Uniform Resource Locator tool."
:version "22.1"
- :group 'hypermedia)
+ :group 'comm)
(defgroup url-file nil
"URL storage."
@@ -68,7 +68,7 @@
))
(defcustom url-honor-refresh-requests t
- "*Whether to do automatic page reloads.
+ "Whether to do automatic page reloads.
These are done at the request of the document author or the server via
the `Refresh' header in an HTTP response. If nil, no refresh
requests will be honored. If t, all refresh requests will be honored.
@@ -79,31 +79,22 @@ If non-nil and not t, the user will be asked for each refresh request."
:group 'url-hairy)
(defcustom url-automatic-caching nil
- "*If non-nil, all documents will be automatically cached to the local disk."
+ "If non-nil, all documents will be automatically cached to the local disk."
:type 'boolean
:group 'url-cache)
-;; Fixme: sanitize this.
-(defcustom url-cache-expired
- (lambda (t1 t2) (>= (- (car t2) (car t1)) 5))
- "*A function determining if a cached item has expired.
-It takes two times (numbers) as its arguments, and returns non-nil if
-the second time is 'too old' when compared to the first time."
- :type 'function
- :group 'url-cache)
-
(defconst url-bug-address "bug-gnu-emacs@gnu.org"
"Where to send bug reports.")
(defcustom url-personal-mail-address nil
- "*Your full email address.
+ "Your full email address.
This is what is sent to HTTP servers as the FROM field in an HTTP
request."
:type '(choice (const :tag "Unspecified" nil) string)
:group 'url)
(defcustom url-directory-index-file "index.html"
- "*The filename to look for when indexing a directory.
+ "The filename to look for when indexing a directory.
If this file exists, and is readable, then it will be viewed instead of
using `dired' to view the directory."
:type 'string
@@ -166,14 +157,14 @@ variable."
(".hqx" . "x-hqx")
(".Z" . "x-compress")
(".bz2" . "x-bzip2"))
- "*An alist of file extensions and appropriate content-transfer-encodings."
+ "An alist of file extensions and appropriate content-transfer-encodings."
:type '(repeat (cons :format "%v"
(string :tag "Extension")
(string :tag "Encoding")))
:group 'url-mime)
(defcustom url-mail-command 'compose-mail
- "*This function will be called whenever URL needs to send mail.
+ "This function will be called whenever URL needs to send mail.
It should enter a mail-mode-like buffer in the current window.
The commands `mail-to' and `mail-subject' should still work in this
buffer, and it should use `mail-header-separator' if possible."
@@ -181,7 +172,7 @@ buffer, and it should use `mail-header-separator' if possible."
:group 'url)
(defcustom url-proxy-services nil
- "*An alist of schemes and proxy servers that gateway them.
+ "An alist of schemes and proxy servers that gateway them.
Looks like ((\"http\" . \"hostname:portnumber\") ...). This is set up
from the ACCESS_proxy environment variables."
:type '(repeat (cons :format "%v"
@@ -190,7 +181,7 @@ from the ACCESS_proxy environment variables."
:group 'url)
(defcustom url-standalone-mode nil
- "*Rely solely on the cache?"
+ "Rely solely on the cache?"
:type 'boolean
:group 'url-cache)
@@ -202,7 +193,7 @@ from the ACCESS_proxy environment variables."
(defcustom url-bad-port-list
'("25" "119" "19")
- "*List of ports to warn the user about connecting to.
+ "List of ports to warn the user about connecting to.
Defaults to just the mail, chargen, and NNTP ports so you cannot be
tricked into sending fake mail or forging messages by a malicious HTML
document."
@@ -243,7 +234,7 @@ Generated according to current coding system priorities."
(mapconcat 'symbol-name ordered ";q=0.5, ")
";q=0.5"))))
-(defvar url-mime-charset-string (url-mime-charset-string)
+(defvar url-mime-charset-string nil
"*String to send in the Accept-charset: field in HTTP requests.
The MIME charset corresponding to the most preferred coding system is
given priority 1 and the rest are given priority 0.5.")
@@ -255,7 +246,7 @@ given priority 1 and the rest are given priority 0.5.")
;; Fixme: set from the locale.
(defcustom url-mime-language-string nil
- "*String to send in the Accept-language: field in HTTP requests.
+ "String to send in the Accept-language: field in HTTP requests.
Specifies the preferred language when servers can serve documents in
several languages. Use RFC 1766 abbreviations, e.g.: `en' for
@@ -284,20 +275,20 @@ get the first available language (as opposed to the default)."
"What OS we are on.")
(defcustom url-max-password-attempts 5
- "*Maximum number of times a password will be prompted for.
+ "Maximum number of times a password will be prompted for.
Applies when a protected document is denied by the server."
:type 'integer
:group 'url)
(defcustom url-temporary-directory (or (getenv "TMPDIR") "/tmp")
- "*Where temporary files go."
+ "Where temporary files go."
:type 'directory
:group 'url-file)
(make-obsolete-variable 'url-temporary-directory
'temporary-file-directory "23.1")
(defcustom url-show-status t
- "*Whether to show a running total of bytes transferred.
+ "Whether to show a running total of bytes transferred.
Can cause a large hit if using a remote X display over a slow link, or
a terminal with a slow modem."
:type 'boolean
@@ -308,7 +299,7 @@ a terminal with a slow modem."
http://www.example.com/")
(defcustom url-news-server nil
- "*The default news server from which to get newsgroups/articles.
+ "The default news server from which to get newsgroups/articles.
Applies if no server is specified in the URL. Defaults to the
environment variable NNTPSERVER or \"news\" if NNTPSERVER is
undefined."
@@ -320,13 +311,13 @@ undefined."
"A regular expression that will match an absolute URL.")
(defcustom url-max-redirections 30
- "*The maximum number of redirection requests to honor in a HTTP connection.
+ "The maximum number of redirection requests to honor in a HTTP connection.
A negative number means to honor an unlimited number of redirection requests."
:type 'integer
:group 'url)
(defcustom url-confirmation-func 'y-or-n-p
- "*What function to use for asking yes or no functions.
+ "What function to use for asking yes or no functions.
Possible values are `yes-or-no-p' or `y-or-n-p', or any function that
takes a single argument (the prompt), and returns t only if a positive
answer is given."
@@ -336,7 +327,7 @@ answer is given."
:group 'url-hairy)
(defcustom url-gateway-method 'native
- "*The type of gateway support to use.
+ "The type of gateway support to use.
Should be a symbol specifying how to get a connection from the local machine.
Currently supported methods:
diff --git a/lisp/url/url.el b/lisp/url/url.el
index 9f47e104043..9d44718625b 100644
--- a/lisp/url/url.el
+++ b/lisp/url/url.el
@@ -1,7 +1,7 @@
;;; url.el --- Uniform Resource Locator retrieval tool
-;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2004, 2005, 2006, 2007,
+;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Bill Perry <wmperry@gnu.org>
;; Keywords: comm, data, processes, hypermedia
@@ -29,11 +29,12 @@
(eval-when-compile (require 'cl))
+(require 'mailcap)
+
(eval-when-compile
(require 'mm-decode)
(require 'mm-view))
-(require 'mailcap)
(require 'url-vars)
(require 'url-cookie)
(require 'url-history)
@@ -120,7 +121,7 @@ than the one returned initially by `url-retrieve'. In this case, it sets this
variable in the original buffer as a forwarding pointer.")
;;;###autoload
-(defun url-retrieve (url callback &optional cbargs)
+(defun url-retrieve (url callback &optional cbargs silent)
"Retrieve URL asynchronously and call CALLBACK with CBARGS when finished.
URL is either a string or a parsed URL.
@@ -142,7 +143,9 @@ the callback is not called).
The variables `url-request-data', `url-request-method' and
`url-request-extra-headers' can be dynamically bound around the
request; dynamic binding of other variables doesn't necessarily
-take effect."
+take effect.
+
+If SILENT, then don't message progress reports and the like."
;;; XXX: There is code in Emacs that does dynamic binding
;;; of the following variables around url-retrieve:
;;; url-standalone-mode, url-gateway-unplugged, w3-honor-stylesheets,
@@ -153,12 +156,14 @@ take effect."
;;; webmail.el; the latter should be updated. Is
;;; url-cookie-multiple-line needed anymore? The other url-cookie-*
;;; are (for now) only used in synchronous retrievals.
- (url-retrieve-internal url callback (cons nil cbargs)))
+ (url-retrieve-internal url callback (cons nil cbargs) silent))
-(defun url-retrieve-internal (url callback cbargs)
+(defun url-retrieve-internal (url callback cbargs &optional silent)
"Internal function; external interface is `url-retrieve'.
CBARGS is what the callback will actually receive - the first item is
-the list of events, as described in the docstring of `url-retrieve'."
+the list of events, as described in the docstring of `url-retrieve'.
+
+If SILENT, don't message progress reports and the like."
(url-do-setup)
(url-gc-dead-buffers)
(if (stringp url)
@@ -169,6 +174,7 @@ the list of events, as described in the docstring of `url-retrieve'."
(error "Must provide a callback function to url-retrieve"))
(unless (url-type url)
(error "Bad url: %s" (url-recreate-url url)))
+ (setf (url-silent url) silent)
(let ((loader (url-scheme-get-property (url-type url) 'loader))
(url-using-proxy (if (url-host url)
(url-find-proxy-for-url url (url-host url))))
@@ -178,7 +184,8 @@ the list of events, as described in the docstring of `url-retrieve'."
(setq asynch t
loader 'url-proxy))
(if asynch
- (setq buffer (funcall loader url callback cbargs))
+ (let ((url-current-object url))
+ (setq buffer (funcall loader url callback cbargs)))
(setq buffer (funcall loader url))
(if buffer
(with-current-buffer buffer
diff --git a/lisp/add-log.el b/lisp/vc/add-log.el
index 4fec68f4c02..c356dde8226 100644
--- a/lisp/add-log.el
+++ b/lisp/vc/add-log.el
@@ -5,7 +5,7 @@
;; Free Software Foundation, Inc.
;; Maintainer: FSF
-;; Keywords: tools
+;; Keywords: vc tools
;; This file is part of GNU Emacs.
@@ -37,9 +37,6 @@
;;; Code:
-(eval-when-compile
- (require 'timezone))
-
(defgroup change-log nil
"Change log maintenance."
:group 'tools
@@ -245,7 +242,7 @@ Note: The search is conducted only within 10%, at the beginning of the file."
;; wrongly with a non-date line existing as a random note. In
;; addition, using any kind of fixed setting like this doesn't
;; work if a user customizes add-log-time-format.
- ("^[0-9-]+ +\\|^\\(Sun\\|Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\) [A-z][a-z][a-z] [0-9:+ ]+"
+ ("^[0-9-]+ +\\|^ \\{11,\\}\\|^\\(Sun\\|Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\) [A-z][a-z][a-z] [0-9:+ ]+"
(0 'change-log-date-face)
;; Name and e-mail; some people put e-mail in parens, not angles.
("\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]" nil nil
@@ -755,7 +752,17 @@ Optional arg BUFFER-FILE overrides `buffer-file-name'."
(if add-log-file-name-function
(funcall add-log-file-name-function buffer-file)
(setq buffer-file
- (file-relative-name buffer-file (file-name-directory log-file)))
+ (let* ((dir (file-name-directory log-file))
+ (rel (file-relative-name buffer-file dir)))
+ ;; Sometimes with symlinks, the two buffers may have names that
+ ;; appear to belong to different directory trees. So check the
+ ;; file-truenames, to see if we get a better result.
+ (if (not (string-match "\\`\\.\\./" rel))
+ rel
+ (let ((new (file-relative-name (file-truename buffer-file)
+ (file-truename dir))))
+ (if (< (length new) (length rel))
+ new rel)))))
;; If we have a backup file, it's presumably because we're
;; comparing old and new versions (e.g. for deleted
;; functions) and we'll want to use the original name.
@@ -1242,19 +1249,18 @@ Has a preference of looking backwards."
(change-log-get-method-definition-1 ""))
(concat change-log-get-method-definition-md "]"))))))
+(autoload 'timezone-make-date-sortable "timezone")
+
(defun change-log-sortable-date-at ()
"Return date of log entry in a consistent form for sorting.
Point is assumed to be at the start of the entry."
- (require 'timezone)
(if (looking-at change-log-start-entry-re)
(let ((date (match-string-no-properties 0)))
(if date
(if (string-match "\\(....\\)-\\(..\\)-\\(..\\)\\s-+" date)
(concat (match-string 1 date) (match-string 2 date)
(match-string 3 date))
- (condition-case nil
- (timezone-make-date-sortable date)
- (error nil)))))
+ (ignore-errors (timezone-make-date-sortable date)))))
(error "Bad date")))
(defun change-log-resolve-conflict ()
diff --git a/lisp/compare-w.el b/lisp/vc/compare-w.el
index 866c6e3e4f8..6e2ab7327de 100644
--- a/lisp/compare-w.el
+++ b/lisp/vc/compare-w.el
@@ -4,7 +4,7 @@
;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Maintainer: FSF
-;; Keywords: convenience files
+;; Keywords: convenience files vc
;; This file is part of GNU Emacs.
diff --git a/lisp/cvs-status.el b/lisp/vc/cvs-status.el
index 1cc9ca9d713..b0e66c055ac 100644
--- a/lisp/cvs-status.el
+++ b/lisp/vc/cvs-status.el
@@ -4,7 +4,7 @@
;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Keywords: pcl-cvs cvs status tree tools
+;; Keywords: pcl-cvs cvs status tree vc tools
;; This file is part of GNU Emacs.
@@ -356,11 +356,11 @@ the list is a three-string list TAG, KIND, REV."
tags)))
(defvar font-lock-mode)
-(defun cvs-refontify (beg end)
- (when (and (boundp 'font-lock-mode)
- font-lock-mode
- (fboundp 'font-lock-fontify-region))
- (font-lock-fontify-region (1- beg) (1+ end))))
+;; (defun cvs-refontify (beg end)
+;; (when (and (boundp 'font-lock-mode)
+;; font-lock-mode
+;; (fboundp 'font-lock-fontify-region))
+;; (font-lock-fontify-region (1- beg) (1+ end))))
(defun cvs-status-trees ()
"Look for a lists of tags, and replace them with trees."
diff --git a/lisp/diff-mode.el b/lisp/vc/diff-mode.el
index 907bf7d5b83..cec4fb24616 100644
--- a/lisp/diff-mode.el
+++ b/lisp/vc/diff-mode.el
@@ -4,7 +4,7 @@
;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Keywords: convenience patch diff
+;; Keywords: convenience patch diff vc
;; This file is part of GNU Emacs.
@@ -1291,7 +1291,9 @@ a diff with \\[diff-reverse-direction].
(set (make-local-variable 'add-log-current-defun-function)
'diff-current-defun)
(set (make-local-variable 'add-log-buffer-file-name-function)
- (lambda () (diff-find-file-name nil 'noprompt))))
+ (lambda () (diff-find-file-name nil 'noprompt)))
+ (unless (buffer-file-name)
+ (hack-dir-local-variables-non-file-buffer)))
;;;###autoload
(define-minor-mode diff-minor-mode
diff --git a/lisp/diff.el b/lisp/vc/diff.el
index 0206c17e770..5809eee9aef 100644
--- a/lisp/diff.el
+++ b/lisp/vc/diff.el
@@ -6,7 +6,7 @@
;; Author: Frank Bresz
;; (according to authors.el)
;; Maintainer: FSF
-;; Keywords: unix, tools
+;; Keywords: unix, vc, tools
;; This file is part of GNU Emacs.
@@ -31,6 +31,8 @@
;;; Code:
+(eval-when-compile (require 'cl))
+
(defgroup diff nil
"Comparing files with `diff'."
:group 'tools)
@@ -47,11 +49,6 @@
:type 'string
:group 'diff)
-(defvar diff-old-temp-file nil
- "This is the name of a temp file to be deleted after diff finishes.")
-(defvar diff-new-temp-file nil
- "This is the name of a temp file to be deleted after diff finishes.")
-
;; prompt if prefix arg present
(defun diff-switches ()
(if current-prefix-arg
@@ -60,12 +57,12 @@
diff-switches
(mapconcat 'identity diff-switches " ")))))
-(defun diff-sentinel (code)
+(defun diff-sentinel (code old-temp-file new-temp-file)
"Code run when the diff process exits.
CODE is the exit code of the process. It should be 0 only if no diffs
were found."
- (if diff-old-temp-file (delete-file diff-old-temp-file))
- (if diff-new-temp-file (delete-file diff-new-temp-file))
+ (if old-temp-file (delete-file old-temp-file))
+ (if new-temp-file (delete-file new-temp-file))
(save-excursion
(goto-char (point-max))
(let ((inhibit-read-only t))
@@ -75,10 +72,6 @@ were found."
(t ""))
(current-time-string))))))
-(defvar diff-old-file nil)
-(defvar diff-new-file nil)
-(defvar diff-extra-args nil)
-
;;;###autoload
(defun diff (old new &optional switches no-async)
"Find and display the differences between OLD and NEW files.
@@ -91,16 +84,14 @@ When called interactively with a prefix argument, prompt
interactively for diff switches. Otherwise, the switches
specified in `diff-switches' are passed to the diff command."
(interactive
- (let (oldf newf)
- (setq newf (buffer-file-name)
- newf (if (and newf (file-exists-p newf))
+ (let* ((newf (if (and buffer-file-name (file-exists-p buffer-file-name))
(read-file-name
(concat "Diff new file (default "
- (file-name-nondirectory newf) "): ")
- nil newf t)
+ (file-name-nondirectory buffer-file-name) "): ")
+ nil buffer-file-name t)
(read-file-name "Diff new file: " nil nil t)))
- (setq oldf (file-newest-backup newf)
- oldf (if (and oldf (file-exists-p oldf))
+ (oldf (file-newest-backup newf)))
+ (setq oldf (if (and oldf (file-exists-p oldf))
(read-file-name
(concat "Diff original file (default "
(file-name-nondirectory oldf) "): ")
@@ -108,59 +99,82 @@ specified in `diff-switches' are passed to the diff command."
(read-file-name "Diff original file: "
(file-name-directory newf) nil t)))
(list oldf newf (diff-switches))))
- (setq new (expand-file-name new)
- old (expand-file-name old))
+ (display-buffer
+ (diff-no-select old new switches no-async)))
+
+(defun diff-file-local-copy (file-or-buf)
+ (if (bufferp file-or-buf)
+ (with-current-buffer file-or-buf
+ (let ((tempfile (make-temp-file "buffer-content-")))
+ (write-region nil nil tempfile nil 'nomessage)
+ tempfile))
+ (file-local-copy file-or-buf)))
+
+(defun diff-better-file-name (file)
+ (if (bufferp file) file
+ (let ((rel (file-relative-name file))
+ (abbr (abbreviate-file-name (expand-file-name file))))
+ (if (< (length abbr) (length rel))
+ abbr
+ rel))))
+
+(defun diff-no-select (old new &optional switches no-async buf)
+ ;; Noninteractive helper for creating and reverting diff buffers
+ (setq new (diff-better-file-name new)
+ old (diff-better-file-name old))
(or switches (setq switches diff-switches)) ; If not specified, use default.
- (let* ((old-alt (file-local-copy old))
- (new-alt (file-local-copy new))
+ (unless (listp switches) (setq switches (list switches)))
+ (or buf (setq buf (get-buffer-create "*Diff*")))
+ (let* ((old-alt (diff-file-local-copy old))
+ (new-alt (diff-file-local-copy new))
(command
(mapconcat 'identity
`(,diff-command
;; Use explicitly specified switches
- ,@(if (listp switches) switches (list switches))
- ,@(if (or old-alt new-alt)
- (list "-L" old "-L" new))
- ,(shell-quote-argument (or old-alt old))
- ,(shell-quote-argument (or new-alt new)))
+ ,@switches
+ ,@(mapcar #'shell-quote-argument
+ (nconc
+ (when (or old-alt new-alt)
+ (list "-L" (if (stringp old)
+ old (prin1-to-string old))
+ "-L" (if (stringp new)
+ new (prin1-to-string new))))
+ (list (or old-alt old)
+ (or new-alt new)))))
" "))
- (buf (get-buffer-create "*Diff*"))
- (thisdir default-directory)
- proc)
- (save-excursion
- (display-buffer buf)
- (set-buffer buf)
- (setq buffer-read-only nil)
+ (thisdir default-directory))
+ (with-current-buffer buf
+ (setq buffer-read-only t)
(buffer-disable-undo (current-buffer))
(let ((inhibit-read-only t))
(erase-buffer))
(buffer-enable-undo (current-buffer))
(diff-mode)
- ;; Use below 2 vars for backward-compatibility.
- (set (make-local-variable 'diff-old-file) old)
- (set (make-local-variable 'diff-new-file) new)
- (set (make-local-variable 'diff-extra-args) (list switches no-async))
(set (make-local-variable 'revert-buffer-function)
- (lambda (ignore-auto noconfirm)
- (apply 'diff diff-old-file diff-new-file diff-extra-args)))
- (set (make-local-variable 'diff-old-temp-file) old-alt)
- (set (make-local-variable 'diff-new-temp-file) new-alt)
+ (lexical-let ((old old) (new new)
+ (switches switches)
+ (no-async no-async))
+ (lambda (ignore-auto noconfirm)
+ (diff-no-select old new switches no-async (current-buffer)))))
(setq default-directory thisdir)
(let ((inhibit-read-only t))
(insert command "\n"))
(if (and (not no-async) (fboundp 'start-process))
- (progn
- (setq proc (start-process "Diff" buf shell-file-name
- shell-command-switch command))
+ (let ((proc (start-process "Diff" buf shell-file-name
+ shell-command-switch command)))
(set-process-filter proc 'diff-process-filter)
- (set-process-sentinel
- proc (lambda (proc msg)
- (with-current-buffer (process-buffer proc)
- (diff-sentinel (process-exit-status proc))))))
+ (lexical-let ((old-alt old-alt) (new-alt new-alt))
+ (set-process-sentinel
+ proc (lambda (proc msg)
+ (with-current-buffer (process-buffer proc)
+ (diff-sentinel (process-exit-status proc)
+ old-alt new-alt))))))
;; Async processes aren't available.
(let ((inhibit-read-only t))
(diff-sentinel
(call-process shell-file-name nil buf nil
- shell-command-switch command)))))
+ shell-command-switch command)
+ old-alt new-alt))))
buf))
(defun diff-process-filter (proc string)
@@ -199,6 +213,14 @@ With prefix arg, prompt for diff switches."
(funcall handler 'diff-latest-backup-file fn)
(file-newest-backup fn))))
+;;;###autoload
+(defun diff-buffer-with-file (&optional buffer)
+ "View the differences between BUFFER and its associated file.
+This requires the external program `diff' to be in your `exec-path'."
+ (interactive "bBuffer: ")
+ (with-current-buffer (get-buffer (or buffer (current-buffer)))
+ (diff buffer-file-name (current-buffer) nil 'noasync)))
+
(provide 'diff)
;; arch-tag: 7de2c29b-7ea5-4b85-9b9d-72dd860de2bd
diff --git a/lisp/ediff-diff.el b/lisp/vc/ediff-diff.el
index 5695b058d27..70352751d8d 100644
--- a/lisp/ediff-diff.el
+++ b/lisp/vc/ediff-diff.el
@@ -1,9 +1,11 @@
;;; ediff-diff.el --- diff-related utilities
-;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
;; This file is part of GNU Emacs.
@@ -53,8 +55,7 @@ Must produce output compatible with Unix's diff3 program."
(fset 'ediff-set-actual-diff-options '(lambda () nil))
(defcustom ediff-shell
- (cond ((eq system-type 'emx) "cmd") ; OS/2
- ((memq system-type '(ms-dos windows-nt windows-95))
+ (cond ((memq system-type '(ms-dos windows-nt))
shell-file-name) ; no standard name on MS-DOS
(t "sh")) ; UNIX
"The shell used to run diff and patch.
@@ -84,7 +85,7 @@ are `-I REGEXP', to ignore changes whose lines match the REGEXP."
(ediff-set-actual-diff-options))
(defcustom ediff-diff-options
- (if (memq system-type '(ms-dos windows-nt windows-95)) "--binary" "")
+ (if (memq system-type '(ms-dos windows-nt)) "--binary" "")
"Options to pass to `ediff-diff-program'.
If Unix diff is used as `ediff-diff-program',
then a useful option is `-w', to ignore space.
@@ -1228,15 +1229,14 @@ delimiter regions"))
(with-current-buffer buffer
(erase-buffer)
(setq default-directory directory)
- (if (or (memq system-type '(emx ms-dos windows-nt windows-95))
+ (if (or (memq system-type '(ms-dos windows-nt))
synch)
- ;; In OS/2 (emx) do it synchronously, since OS/2 doesn't let us
+ ;; In Windows do it synchronously, since Windows doesn't let us
;; delete files used by other processes. Thus, in ediff-buffers
;; and similar functions, we can't delete temp files because
;; they might be used by the asynch process that computes
;; custom diffs. So, we have to wait till custom diff
;; subprocess is done.
- ;; Similarly for Windows-*
;; In DOS, must synchronize because DOS doesn't have
;; asynchronous processes.
(apply 'call-process program nil buffer nil args)
@@ -1532,5 +1532,4 @@ affects only files whose names match the expression."
;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
;; End:
-;; arch-tag: a86d448e-58d7-4572-a1d9-fdedfa22f648
;;; ediff-diff.el ends here
diff --git a/lisp/ediff-help.el b/lisp/vc/ediff-help.el
index d9ca687e6b0..06a600f0af4 100644
--- a/lisp/ediff-help.el
+++ b/lisp/vc/ediff-help.el
@@ -4,6 +4,7 @@
;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
;; This file is part of GNU Emacs.
diff --git a/lisp/ediff-hook.el b/lisp/vc/ediff-hook.el
index 390538ed009..e917d29a7b4 100644
--- a/lisp/ediff-hook.el
+++ b/lisp/vc/ediff-hook.el
@@ -4,6 +4,7 @@
;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
;; This file is part of GNU Emacs.
diff --git a/lisp/ediff-init.el b/lisp/vc/ediff-init.el
index 0ea1e8c02f6..9665a21cd14 100644
--- a/lisp/ediff-init.el
+++ b/lisp/vc/ediff-init.el
@@ -4,6 +4,7 @@
;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
;; This file is part of GNU Emacs.
@@ -786,16 +787,6 @@ TYPE-OF-EMACS is either 'xemacs or 'emacs."
"")
-(if (ediff-has-face-support-p)
- (if (featurep 'xemacs)
- (progn
- (defalias 'ediff-valid-color-p 'valid-color-name-p)
- (defalias 'ediff-get-face 'get-face))
- (defalias 'ediff-valid-color-p (if (fboundp 'color-defined-p)
- 'color-defined-p
- 'x-color-defined-p))
- (defalias 'ediff-get-face 'internal-get-face)))
-
(if (ediff-window-display-p)
(if (featurep 'xemacs)
(progn
diff --git a/lisp/ediff-merg.el b/lisp/vc/ediff-merg.el
index c4b94a02e0c..4c6aee15d1d 100644
--- a/lisp/ediff-merg.el
+++ b/lisp/vc/ediff-merg.el
@@ -4,6 +4,7 @@
;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
;; This file is part of GNU Emacs.
diff --git a/lisp/ediff-mult.el b/lisp/vc/ediff-mult.el
index a2c1043049d..39bd06fbd97 100644
--- a/lisp/ediff-mult.el
+++ b/lisp/vc/ediff-mult.el
@@ -4,6 +4,7 @@
;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
;; This file is part of GNU Emacs.
diff --git a/lisp/ediff-ptch.el b/lisp/vc/ediff-ptch.el
index 1203747fdb7..393bdcb673c 100644
--- a/lisp/ediff-ptch.el
+++ b/lisp/vc/ediff-ptch.el
@@ -1,9 +1,11 @@
;;; ediff-ptch.el --- Ediff's patch support
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+;; 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
;; This file is part of GNU Emacs.
@@ -61,7 +63,7 @@ case the default value for this variable should be changed."
;; the default backup extension
(defconst ediff-default-backup-extension
- (if (memq system-type '(emx ms-dos))
+ (if (eq system-type 'ms-dos)
"_orig" ".orig"))
@@ -840,5 +842,4 @@ you can still examine the changes via M-x ediff-files"
;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
;; End:
-;; arch-tag: 2fe2161e-e116-469b-90fa-5cbb44c1bd1b
;;; ediff-ptch.el ends here
diff --git a/lisp/ediff-util.el b/lisp/vc/ediff-util.el
index 77284a19f50..4eec5577e7b 100644
--- a/lisp/ediff-util.el
+++ b/lisp/vc/ediff-util.el
@@ -1,9 +1,11 @@
;;; ediff-util.el --- the core commands and utilities of ediff
;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
-;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
;; This file is part of GNU Emacs.
@@ -309,7 +311,7 @@ to invocation.")
ediff-word-mode-job (ediff-word-mode-job))
;; Don't delete variants in case of ediff-buffer-* jobs without asking.
- ;; This is because one may loose work---dangerous.
+ ;; This is because one may lose work---dangerous.
(if (string-match "buffer" (symbol-name ediff-job-name))
(setq ediff-keep-variants t))
@@ -3993,7 +3995,7 @@ byte-compilation may produce output like this:
........................
While compiling the end of the data:
** The following functions are not known to be defined:
- ediff-valid-color-p, ediff-set-face,
+ xxx, yyy
........................
These are NOT errors, but inevitable warnings, which ought to be ignored.
@@ -4287,5 +4289,4 @@ Mail anyway? (y or n) ")
;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
;; End:
-;; arch-tag: f51099b6-ef4b-470f-88a1-3a0e0b03a879
;;; ediff-util.el ends here
diff --git a/lisp/ediff-vers.el b/lisp/vc/ediff-vers.el
index e314afc24b5..581aad3e4dc 100644
--- a/lisp/ediff-vers.el
+++ b/lisp/vc/ediff-vers.el
@@ -4,6 +4,7 @@
;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
;; This file is part of GNU Emacs.
diff --git a/lisp/ediff-wind.el b/lisp/vc/ediff-wind.el
index 61213c039c0..4d6666a86f2 100644
--- a/lisp/ediff-wind.el
+++ b/lisp/vc/ediff-wind.el
@@ -1,9 +1,11 @@
;;; ediff-wind.el --- window manipulation utilities
-;; Copyright (C) 1994, 1995, 1996, 1997, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2004,
+;; 2005, 2006, 2007, 2008, 2009, 2010
+;; Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
+;; Package: ediff
;; This file is part of GNU Emacs.
@@ -977,12 +979,11 @@ into icons, regardless of the window manager."
(set-specifier left-toolbar-width (list ctl-frame 0))
(set-specifier right-toolbar-width (list ctl-frame 0))))
- ;; Under OS/2 (emx) we have to call modify frame parameters twice, in order
- ;; to make sure that at least once we do it for non-iconified frame. If
- ;; appears that in the OS/2 port of Emacs, one can't modify frame
- ;; parameters of iconified frames. As a precaution, we do likewise for
- ;; windows-nt.
- (if (memq system-type '(emx windows-nt windows-95))
+ ;; As a precaution, we call modify frame parameters twice, in
+ ;; order to make sure that at least once we do it for
+ ;; a non-iconified frame. (It appears that in the Windows port of
+ ;; Emacs, one can't modify frame parameters of iconified frames.)
+ (if (eq system-type 'windows-nt)
(modify-frame-parameters ctl-frame adjusted-parameters))
;; make or zap toolbar (if not requested)
@@ -1309,5 +1310,4 @@ It assumes that it is called from within the control buffer."
;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body))
;; End:
-;; arch-tag: 73d9a5d7-eed7-4d9c-8b4b-21d5d78eb597
;;; ediff-wind.el ends here
diff --git a/lisp/ediff.el b/lisp/vc/ediff.el
index 97dc537cd7e..c41a6e4a1af 100644
--- a/lisp/ediff.el
+++ b/lisp/vc/ediff.el
@@ -5,7 +5,8 @@
;; Author: Michael Kifer <kifer@cs.stonybrook.edu>
;; Created: February 2, 1994
-;; Keywords: comparing, merging, patching, tools, unix
+;; Keywords: comparing, merging, patching, vc, tools, unix
+;; Version: 2.81.4
;; Yoni Rabkin <yoni@rabkins.net> contacted the maintainer of this
;; file on 20/3/2008, and the maintainer agreed that when a bug is
diff --git a/lisp/emerge.el b/lisp/vc/emerge.el
index 997077aa08f..ee34944e448 100644
--- a/lisp/emerge.el
+++ b/lisp/vc/emerge.el
@@ -5,7 +5,7 @@
;; This file is part of GNU Emacs.
;; Author: Dale R. Worley <worley@world.std.com>
-;; Keywords: unix, tools
+;; Keywords: unix, vc, tools
;; This software was created by Dale R. Worley and is
;; distributed free of charge. It is placed in the public domain and
@@ -29,25 +29,13 @@
(defvar A-end)
(defvar B-begin)
(defvar B-end)
-(defvar diff)
(defvar diff-vector)
(defvar merge-begin)
(defvar merge-end)
-(defvar template)
(defvar valid-diff)
;;; Macros
-(defmacro emerge-eval-in-buffer (buffer &rest forms)
- "Macro to switch to BUFFER, evaluate FORMS, returns to original buffer.
-Differs from `save-excursion' in that it doesn't save the point and mark."
- `(let ((StartBuffer (current-buffer)))
- (unwind-protect
- (progn
- (set-buffer ,buffer)
- ,@forms)
- (set-buffer StartBuffer))))
-
(defmacro emerge-defvar-local (var value doc)
"Defines SYMBOL as an advertised variable.
Performs a defvar, then executes `make-variable-buffer-local' on
@@ -565,7 +553,7 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(if output-file
(setq emerge-last-dir-output (file-name-directory output-file)))
;; Make sure the entire files are seen, and they reflect what is on disk
- (emerge-eval-in-buffer
+ (with-current-buffer
buffer-A
(widen)
(let ((temp (file-local-copy file-A)))
@@ -576,7 +564,7 @@ This is *not* a user option, since Emerge uses it for its own processing.")
startup-hooks))
;; Verify that the file matches the buffer
(emerge-verify-file-buffer))))
- (emerge-eval-in-buffer
+ (with-current-buffer
buffer-B
(widen)
(let ((temp (file-local-copy file-B)))
@@ -599,10 +587,10 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(let* ((merge-buffer-name (emerge-unique-buffer-name "*merge" "*"))
;; create the merge buffer from buffer A, so it inherits buffer A's
;; default directory, etc.
- (merge-buffer (emerge-eval-in-buffer
+ (merge-buffer (with-current-buffer
buffer-A
(get-buffer-create merge-buffer-name))))
- (emerge-eval-in-buffer
+ (with-current-buffer
merge-buffer
(emerge-copy-modes buffer-A)
(setq buffer-read-only nil)
@@ -625,14 +613,14 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(emerge-remember-buffer-characteristics)
(emerge-handle-local-variables))
(emerge-setup-windows buffer-A buffer-B merge-buffer t)
- (emerge-eval-in-buffer merge-buffer
+ (with-current-buffer merge-buffer
(run-hooks 'startup-hooks 'emerge-startup-hook)
(setq buffer-read-only t))))
;; Generate the Emerge difference list between two files
(defun emerge-make-diff-list (file-A file-B)
(setq emerge-diff-buffer (get-buffer-create "*emerge-diff*"))
- (emerge-eval-in-buffer
+ (with-current-buffer
emerge-diff-buffer
(erase-buffer)
(shell-command
@@ -648,7 +636,7 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(defun emerge-extract-diffs (diff-buffer)
(let (list)
- (emerge-eval-in-buffer
+ (with-current-buffer
diff-buffer
(goto-char (point-min))
(while (re-search-forward emerge-match-diff-line nil t)
@@ -692,7 +680,7 @@ This is *not* a user option, since Emerge uses it for its own processing.")
;; Set up buffer of diff/diff3 error messages.
(defun emerge-prepare-error-list (ok-regexp)
(setq emerge-diff-error-buffer (get-buffer-create "*emerge-diff-errors*"))
- (emerge-eval-in-buffer
+ (with-current-buffer
emerge-diff-error-buffer
(erase-buffer)
(save-excursion (insert-buffer-substring emerge-diff-buffer))
@@ -719,7 +707,7 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(if output-file
(setq emerge-last-dir-output (file-name-directory output-file)))
;; Make sure the entire files are seen, and they reflect what is on disk
- (emerge-eval-in-buffer
+ (with-current-buffer
buffer-A
(widen)
(let ((temp (file-local-copy file-A)))
@@ -730,7 +718,7 @@ This is *not* a user option, since Emerge uses it for its own processing.")
startup-hooks))
;; Verify that the file matches the buffer
(emerge-verify-file-buffer))))
- (emerge-eval-in-buffer
+ (with-current-buffer
buffer-B
(widen)
(let ((temp (file-local-copy file-B)))
@@ -741,7 +729,7 @@ This is *not* a user option, since Emerge uses it for its own processing.")
startup-hooks))
;; Verify that the file matches the buffer
(emerge-verify-file-buffer))))
- (emerge-eval-in-buffer
+ (with-current-buffer
buffer-ancestor
(widen)
(let ((temp (file-local-copy file-ancestor)))
@@ -768,10 +756,10 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(let* ((merge-buffer-name (emerge-unique-buffer-name "*merge" "*"))
;; create the merge buffer from buffer A, so it inherits buffer A's
;; default directory, etc.
- (merge-buffer (emerge-eval-in-buffer
+ (merge-buffer (with-current-buffer
buffer-A
(get-buffer-create merge-buffer-name))))
- (emerge-eval-in-buffer
+ (with-current-buffer
merge-buffer
(emerge-copy-modes buffer-A)
(setq buffer-read-only nil)
@@ -796,14 +784,14 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(emerge-select-prefer-Bs)
(emerge-handle-local-variables))
(emerge-setup-windows buffer-A buffer-B merge-buffer t)
- (emerge-eval-in-buffer merge-buffer
+ (with-current-buffer merge-buffer
(run-hooks 'startup-hooks 'emerge-startup-hook)
(setq buffer-read-only t))))
;; Generate the Emerge difference list between two files with an ancestor
(defun emerge-make-diff3-list (file-A file-B file-ancestor)
(setq emerge-diff-buffer (get-buffer-create "*emerge-diff*"))
- (emerge-eval-in-buffer
+ (with-current-buffer
emerge-diff-buffer
(erase-buffer)
(shell-command
@@ -820,7 +808,7 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(defun emerge-extract-diffs3 (diff-buffer)
(let (list)
- (emerge-eval-in-buffer
+ (with-current-buffer
diff-buffer
(while (re-search-forward "^====\\(.?\\)$" nil t)
;; leave point after matched line
@@ -928,10 +916,10 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(interactive "bBuffer A to merge: \nbBuffer B to merge: ")
(let ((emerge-file-A (emerge-make-temp-file "A"))
(emerge-file-B (emerge-make-temp-file "B")))
- (emerge-eval-in-buffer
+ (with-current-buffer
buffer-A
(write-region (point-min) (point-max) emerge-file-A nil 'no-message))
- (emerge-eval-in-buffer
+ (with-current-buffer
buffer-B
(write-region (point-min) (point-max) emerge-file-B nil 'no-message))
(emerge-setup (get-buffer buffer-A) emerge-file-A
@@ -953,13 +941,13 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(let ((emerge-file-A (emerge-make-temp-file "A"))
(emerge-file-B (emerge-make-temp-file "B"))
(emerge-file-ancestor (emerge-make-temp-file "anc")))
- (emerge-eval-in-buffer
+ (with-current-buffer
buffer-A
(write-region (point-min) (point-max) emerge-file-A nil 'no-message))
- (emerge-eval-in-buffer
+ (with-current-buffer
buffer-B
(write-region (point-min) (point-max) emerge-file-B nil 'no-message))
- (emerge-eval-in-buffer
+ (with-current-buffer
buffer-ancestor
(write-region (point-min) (point-max) emerge-file-ancestor nil
'no-message))
@@ -1093,7 +1081,7 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(emerge-file-A (emerge-make-temp-file "A"))
(emerge-file-B (emerge-make-temp-file "B")))
;; Get the revisions into buffers
- (emerge-eval-in-buffer
+ (with-current-buffer
buffer-A
(erase-buffer)
(shell-command
@@ -1101,7 +1089,7 @@ This is *not* a user option, since Emerge uses it for its own processing.")
t)
(write-region (point-min) (point-max) emerge-file-A nil 'no-message)
(set-buffer-modified-p nil))
- (emerge-eval-in-buffer
+ (with-current-buffer
buffer-B
(erase-buffer)
(shell-command
@@ -1131,7 +1119,7 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(emerge-file-B (emerge-make-temp-file "B"))
(emerge-ancestor (emerge-make-temp-file "ancestor")))
;; Get the revisions into buffers
- (emerge-eval-in-buffer
+ (with-current-buffer
buffer-A
(erase-buffer)
(shell-command
@@ -1140,7 +1128,7 @@ This is *not* a user option, since Emerge uses it for its own processing.")
t)
(write-region (point-min) (point-max) emerge-file-A nil 'no-message)
(set-buffer-modified-p nil))
- (emerge-eval-in-buffer
+ (with-current-buffer
buffer-B
(erase-buffer)
(shell-command
@@ -1148,7 +1136,7 @@ This is *not* a user option, since Emerge uses it for its own processing.")
t)
(write-region (point-min) (point-max) emerge-file-B nil 'no-message)
(set-buffer-modified-p nil))
- (emerge-eval-in-buffer
+ (with-current-buffer
buffer-ancestor
(erase-buffer)
(shell-command
@@ -1379,7 +1367,7 @@ Otherwise, the A or B file present is copied to the output file."
(if pos
(goto-char (point-min)))
;; If diff/diff3 reports errors, display them rather than the merge buffer.
- (if (/= 0 (emerge-eval-in-buffer emerge-diff-error-buffer (buffer-size)))
+ (if (/= 0 (with-current-buffer emerge-diff-error-buffer (buffer-size)))
(progn
(ding)
(message "Errors found in diff/diff3 output. Merge buffer is %s."
@@ -1434,14 +1422,14 @@ These characteristics are restored by `emerge-restore-buffer-characteristics'."
(do-auto-save)
;; remember and alter buffer characteristics
(setq emerge-A-buffer-values
- (emerge-eval-in-buffer
+ (with-current-buffer
emerge-A-buffer
(prog1
(emerge-save-variables emerge-saved-variables)
(emerge-restore-variables emerge-saved-variables
emerge-merging-values))))
(setq emerge-B-buffer-values
- (emerge-eval-in-buffer
+ (with-current-buffer
emerge-B-buffer
(prog1
(emerge-save-variables emerge-saved-variables)
@@ -1452,10 +1440,10 @@ These characteristics are restored by `emerge-restore-buffer-characteristics'."
"Restore characteristics saved by `emerge-remember-buffer-characteristics'."
(let ((A-values emerge-A-buffer-values)
(B-values emerge-B-buffer-values))
- (emerge-eval-in-buffer emerge-A-buffer
+ (with-current-buffer emerge-A-buffer
(emerge-restore-variables emerge-saved-variables
A-values))
- (emerge-eval-in-buffer emerge-B-buffer
+ (with-current-buffer emerge-B-buffer
(emerge-restore-variables emerge-saved-variables
B-values))))
@@ -1470,15 +1458,15 @@ These characteristics are restored by `emerge-restore-buffer-characteristics'."
merge-buffer
lineno-list)
(let* (marker-list
- (A-point-min (emerge-eval-in-buffer A-buffer (point-min)))
+ (A-point-min (with-current-buffer A-buffer (point-min)))
(offset (1- A-point-min))
- (B-point-min (emerge-eval-in-buffer B-buffer (point-min)))
+ (B-point-min (with-current-buffer B-buffer (point-min)))
;; Record current line number in each buffer
;; so we don't have to count from the beginning.
(a-line 1)
(b-line 1))
- (emerge-eval-in-buffer A-buffer (goto-char (point-min)))
- (emerge-eval-in-buffer B-buffer (goto-char (point-min)))
+ (with-current-buffer A-buffer (goto-char (point-min)))
+ (with-current-buffer B-buffer (goto-char (point-min)))
(while lineno-list
(let* ((list-element (car lineno-list))
a-begin-marker
@@ -1493,13 +1481,13 @@ These characteristics are restored by `emerge-restore-buffer-characteristics'."
(b-end (aref list-element 3))
(state (aref list-element 4)))
;; place markers at the appropriate places in the buffers
- (emerge-eval-in-buffer
+ (with-current-buffer
A-buffer
(setq a-line (emerge-goto-line a-begin a-line))
(setq a-begin-marker (point-marker))
(setq a-line (emerge-goto-line a-end a-line))
(setq a-end-marker (point-marker)))
- (emerge-eval-in-buffer
+ (with-current-buffer
B-buffer
(setq b-line (emerge-goto-line b-begin b-line))
(setq b-begin-marker (point-marker))
@@ -1759,7 +1747,7 @@ This resets the horizontal scrolling of all three merge buffers
to the left margin, if they are in windows."
(interactive)
(emerge-operate-on-windows
- (function (lambda (x) (set-window-hscroll (selected-window) 0)))
+ (lambda (x) (set-window-hscroll (selected-window) 0))
nil))
;; Attempt to show the region nicely.
@@ -1869,13 +1857,13 @@ buffer after this will cause serious problems."
(emerge-restore-buffer-characteristics)
;; null out the difference markers so they don't slow down future editing
;; operations
- (mapc (function (lambda (d)
- (set-marker (aref d 0) nil)
- (set-marker (aref d 1) nil)
- (set-marker (aref d 2) nil)
- (set-marker (aref d 3) nil)
- (set-marker (aref d 4) nil)
- (set-marker (aref d 5) nil)))
+ (mapc (lambda (d)
+ (set-marker (aref d 0) nil)
+ (set-marker (aref d 1) nil)
+ (set-marker (aref d 2) nil)
+ (set-marker (aref d 3) nil)
+ (set-marker (aref d 4) nil)
+ (set-marker (aref d 5) nil))
emerge-difference-list)
;; allow them to be garbage collected
(setq emerge-difference-list nil)
@@ -1900,19 +1888,18 @@ A prefix argument forces the variant to be selected
even if the difference has been edited."
(interactive "P")
(let ((operate
- (function (lambda ()
- (emerge-select-A-edit merge-begin merge-end A-begin A-end)
- (if emerge-auto-advance
- (emerge-next-difference)))))
+ (lambda ()
+ (emerge-select-A-edit merge-begin merge-end A-begin A-end)
+ (if emerge-auto-advance
+ (emerge-next-difference))))
(operate-no-change
- (function (lambda ()
- (if emerge-auto-advance
- (emerge-next-difference))))))
+ (lambda () (if emerge-auto-advance
+ (emerge-next-difference)))))
(emerge-select-version force operate-no-change operate operate)))
;; Actually select the A variant
(defun emerge-select-A-edit (merge-begin merge-end A-begin A-end)
- (emerge-eval-in-buffer
+ (with-current-buffer
emerge-merge-buffer
(delete-region merge-begin merge-end)
(goto-char merge-begin)
@@ -1929,19 +1916,18 @@ A prefix argument forces the variant to be selected
even if the difference has been edited."
(interactive "P")
(let ((operate
- (function (lambda ()
- (emerge-select-B-edit merge-begin merge-end B-begin B-end)
- (if emerge-auto-advance
- (emerge-next-difference)))))
+ (lambda ()
+ (emerge-select-B-edit merge-begin merge-end B-begin B-end)
+ (if emerge-auto-advance
+ (emerge-next-difference))))
(operate-no-change
- (function (lambda ()
- (if emerge-auto-advance
- (emerge-next-difference))))))
+ (lambda () (if emerge-auto-advance
+ (emerge-next-difference)))))
(emerge-select-version force operate operate-no-change operate)))
;; Actually select the B variant
(defun emerge-select-B-edit (merge-begin merge-end B-begin B-end)
- (emerge-eval-in-buffer
+ (with-current-buffer
emerge-merge-buffer
(delete-region merge-begin merge-end)
(goto-char merge-begin)
@@ -2134,12 +2120,12 @@ Use C-u l to reset the windows afterward."
(interactive)
(delete-other-windows)
(let ((temp-buffer-show-function
- (function (lambda (buf)
- (split-window-vertically)
- (switch-to-buffer buf)
- (other-window 1)))))
+ (lambda (buf)
+ (split-window-vertically)
+ (switch-to-buffer buf)
+ (other-window 1))))
(with-output-to-temp-buffer "*Help*"
- (emerge-eval-in-buffer emerge-A-buffer
+ (with-current-buffer emerge-A-buffer
(if buffer-file-name
(progn
(princ "File A is: ")
@@ -2148,7 +2134,7 @@ Use C-u l to reset the windows afterward."
(princ "Buffer A is: ")
(princ (buffer-name))))
(princ "\n"))
- (emerge-eval-in-buffer emerge-B-buffer
+ (with-current-buffer emerge-B-buffer
(if buffer-file-name
(progn
(princ "File B is: ")
@@ -2158,7 +2144,7 @@ Use C-u l to reset the windows afterward."
(princ (buffer-name))))
(princ "\n"))
(if emerge-ancestor-buffer
- (emerge-eval-in-buffer emerge-ancestor-buffer
+ (with-current-buffer emerge-ancestor-buffer
(if buffer-file-name
(progn
(princ "Ancestor file is: ")
@@ -2229,9 +2215,9 @@ With a prefix argument, join with the preceding one."
;; check that this is a valid difference
(emerge-validate-difference)
;; get the point values and old difference
- (let ((A-point (emerge-eval-in-buffer emerge-A-buffer
+ (let ((A-point (with-current-buffer emerge-A-buffer
(point-marker)))
- (B-point (emerge-eval-in-buffer emerge-B-buffer
+ (B-point (with-current-buffer emerge-B-buffer
(point-marker)))
(merge-point (point-marker))
(old-diff (aref emerge-difference-list n)))
@@ -2313,10 +2299,10 @@ ancestor version does not share.)"
(while success
(setq size (min size (- bottom-a top-a) (- bottom-b top-b)
(- bottom-m top-m)))
- (setq sa (emerge-eval-in-buffer emerge-A-buffer
+ (setq sa (with-current-buffer emerge-A-buffer
(buffer-substring top-a
(+ size top-a))))
- (setq sb (emerge-eval-in-buffer emerge-B-buffer
+ (setq sb (with-current-buffer emerge-B-buffer
(buffer-substring top-b
(+ size top-b))))
(setq sm (buffer-substring top-m (+ size top-m)))
@@ -2335,10 +2321,10 @@ ancestor version does not share.)"
(while success
(setq size (min size (- bottom-a top-a) (- bottom-b top-b)
(- bottom-m top-m)))
- (setq sa (emerge-eval-in-buffer emerge-A-buffer
+ (setq sa (with-current-buffer emerge-A-buffer
(buffer-substring (- bottom-a size)
bottom-a)))
- (setq sb (emerge-eval-in-buffer emerge-B-buffer
+ (setq sb (with-current-buffer emerge-B-buffer
(buffer-substring (- bottom-b size)
bottom-b)))
(setq sm (buffer-substring (- bottom-m size) bottom-m))
@@ -2351,14 +2337,14 @@ ancestor version does not share.)"
;; {top,bottom}-{a,b,m} are now set at the new beginnings and ends
;; of the difference regions. Move them to the beginning of lines, as
;; appropriate.
- (emerge-eval-in-buffer emerge-A-buffer
+ (with-current-buffer emerge-A-buffer
(goto-char top-a)
(beginning-of-line)
(aset diff 0 (point-marker))
(goto-char bottom-a)
(beginning-of-line 2)
(aset diff 1 (point-marker)))
- (emerge-eval-in-buffer emerge-B-buffer
+ (with-current-buffer emerge-B-buffer
(goto-char top-b)
(beginning-of-line)
(aset diff 2 (point-marker))
@@ -2413,7 +2399,7 @@ the nearest previous difference."
;; search for the point in the A buffer, using the markers
;; for the beginning and end of the differences in the A buffer
(emerge-find-difference1 arg
- (emerge-eval-in-buffer emerge-A-buffer (point))
+ (with-current-buffer emerge-A-buffer (point))
0 1))
(defun emerge-find-difference-B (arg)
@@ -2426,7 +2412,7 @@ the nearest previous difference."
;; search for the point in the B buffer, using the markers
;; for the beginning and end of the differences in the B buffer
(emerge-find-difference1 arg
- (emerge-eval-in-buffer emerge-B-buffer (point))
+ (with-current-buffer emerge-B-buffer (point))
2 3))
(defun emerge-find-difference1 (arg location begin end)
@@ -2474,26 +2460,27 @@ merge buffers."
(let* ((valid-diff
(and (>= emerge-current-difference 0)
(< emerge-current-difference emerge-number-of-differences)))
- (diff (and valid-diff
- (aref emerge-difference-list emerge-current-difference)))
- (merge-line (emerge-line-number-in-buf 4 5))
- (A-line (emerge-eval-in-buffer emerge-A-buffer
- (emerge-line-number-in-buf 0 1)))
- (B-line (emerge-eval-in-buffer emerge-B-buffer
- (emerge-line-number-in-buf 2 3))))
+ (emerge-line-diff (and valid-diff
+ (aref emerge-difference-list
+ emerge-current-difference)))
+ (merge-line (emerge-line-number-in-buf 4 5))
+ (A-line (with-current-buffer emerge-A-buffer
+ (emerge-line-number-in-buf 0 1)))
+ (B-line (with-current-buffer emerge-B-buffer
+ (emerge-line-number-in-buf 2 3))))
(message "At lines: merge = %d, A = %d, B = %d"
merge-line A-line B-line)))
+(defvar emerge-line-diff)
+
(defun emerge-line-number-in-buf (begin-marker end-marker)
- (let (temp)
- (setq temp (save-excursion
- (beginning-of-line)
- (1+ (count-lines 1 (point)))))
+ ;; FIXME point-min rather than 1? widen?
+ (let ((temp (1+ (count-lines 1 (line-beginning-position)))))
(if valid-diff
(progn
- (if (> (point) (aref diff begin-marker))
+ (if (> (point) (aref emerge-line-diff begin-marker))
(setq temp (- temp emerge-before-flag-lines)))
- (if (> (point) (aref diff end-marker))
+ (if (> (point) (aref emerge-line-diff end-marker))
(setq temp (- temp emerge-after-flag-lines)))))
temp))
@@ -2548,30 +2535,32 @@ been edited."
(error "Register does not contain text"))
(emerge-combine-versions-internal template force)))
-(defun emerge-combine-versions-internal (template force)
+(defun emerge-combine-versions-internal (emerge-combine-template force)
(let ((operate
- (function (lambda ()
- (emerge-combine-versions-edit merge-begin merge-end
- A-begin A-end B-begin B-end)
- (if emerge-auto-advance
- (emerge-next-difference))))))
+ (lambda ()
+ (emerge-combine-versions-edit merge-begin merge-end
+ A-begin A-end B-begin B-end)
+ (if emerge-auto-advance
+ (emerge-next-difference)))))
(emerge-select-version force operate operate operate)))
+(defvar emerge-combine-template)
+
(defun emerge-combine-versions-edit (merge-begin merge-end
A-begin A-end B-begin B-end)
- (emerge-eval-in-buffer
+ (with-current-buffer
emerge-merge-buffer
(delete-region merge-begin merge-end)
(goto-char merge-begin)
(let ((i 0))
- (while (< i (length template))
- (let ((c (aref template i)))
+ (while (< i (length emerge-combine-template))
+ (let ((c (aref emerge-combine-template i)))
(if (= c ?%)
(progn
(setq i (1+ i))
(setq c
(condition-case nil
- (aref template i)
+ (aref emerge-combine-template i)
(error ?%)))
(cond ((= c ?a)
(insert-buffer-substring emerge-A-buffer A-begin A-end))
@@ -2620,7 +2609,7 @@ keymap. Leaves merge in fast mode."
(defun emerge-place-flags-in-buffer (buffer difference before-index
after-index)
(if buffer
- (emerge-eval-in-buffer
+ (with-current-buffer
buffer
(emerge-place-flags-in-buffer1 difference before-index after-index))
(emerge-place-flags-in-buffer1 difference before-index after-index)))
@@ -2689,7 +2678,7 @@ keymap. Leaves merge in fast mode."
(run-hooks 'emerge-unselect-hook))
(defun emerge-remove-flags-in-buffer (buffer before after)
- (emerge-eval-in-buffer
+ (with-current-buffer
buffer
(let ((buffer-read-only nil))
;; remove the flags, if they're there
@@ -2838,11 +2827,11 @@ keymap. Leaves merge in fast mode."
(while (< x-begin x-end)
;; bite off and compare no more than 1000 characters at a time
(let* ((compare-length (min (- x-end x-begin) 1000))
- (x-string (emerge-eval-in-buffer
+ (x-string (with-current-buffer
buffer-x
(buffer-substring x-begin
(+ x-begin compare-length))))
- (y-string (emerge-eval-in-buffer
+ (y-string (with-current-buffer
buffer-y
(buffer-substring y-begin
(+ y-begin compare-length)))))
@@ -2879,9 +2868,9 @@ keymap. Leaves merge in fast mode."
;; A "function" is anything that funcall can handle as an argument.
(defun emerge-save-variables (vars)
- (mapcar (function (lambda (v) (if (symbolp v)
- (symbol-value v)
- (funcall (car v)))))
+ (mapcar (lambda (v) (if (symbolp v)
+ (symbol-value v)
+ (funcall (car v))))
vars))
(defun emerge-restore-variables (vars values)
@@ -2972,7 +2961,7 @@ around the current difference are removed."
;; buffer.
(defun emerge-copy-modes (buffer)
;; Set the major mode
- (funcall (emerge-eval-in-buffer buffer major-mode)))
+ (funcall (with-current-buffer buffer major-mode)))
;; Define a key, even if a prefix of it is defined
(defun emerge-force-define-key (keymap key definition)
@@ -3163,11 +3152,11 @@ See also `auto-save-file-name-p'."
(aref s i))
65536))
(setq i (1+ i)))
- (mapconcat (function (lambda (b)
- (setq b (+ (% b 93) ?!))
- (if (>= b ?/)
- (setq b (1+ b)))
- (char-to-string b)))
+ (mapconcat (lambda (b)
+ (setq b (+ (% b 93) ?!))
+ (if (>= b ?/)
+ (setq b (1+ b)))
+ (char-to-string b))
bins "")))
;; Quote any /s in a string by replacing them with \!.
@@ -3205,5 +3194,4 @@ More precisely, a [...] regexp to match any one such character."
(provide 'emerge)
-;; arch-tag: a575f092-6e44-400e-b8a2-4124e9377585
;;; emerge.el ends here
diff --git a/lisp/log-edit.el b/lisp/vc/log-edit.el
index ddc0f601701..2bce58f50f2 100644
--- a/lisp/log-edit.el
+++ b/lisp/vc/log-edit.el
@@ -4,7 +4,7 @@
;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Keywords: pcl-cvs cvs commit log
+;; Keywords: pcl-cvs cvs commit log vc
;; This file is part of GNU Emacs.
@@ -149,12 +149,12 @@ can be obtained from `log-edit-files'."
:type '(hook :options (log-edit-set-common-indentation
log-edit-add-to-changelog)))
-(defcustom log-edit-strip-single-file-name t
+(defcustom log-edit-strip-single-file-name nil
"If non-nil, remove file name from single-file log entries."
:type 'boolean
:safe 'booleanp
:group 'log-edit
- :version "23.2")
+ :version "24.1")
(defvar cvs-changelog-full-paragraphs t)
(make-obsolete-variable 'cvs-changelog-full-paragraphs
@@ -418,7 +418,8 @@ commands (under C-x v for VC, for example).
\\{log-edit-mode-map}"
(set (make-local-variable 'font-lock-defaults)
'(log-edit-font-lock-keywords t t))
- (make-local-variable 'log-edit-comment-ring-index))
+ (make-local-variable 'log-edit-comment-ring-index)
+ (hack-dir-local-variables-non-file-buffer))
(defun log-edit-hide-buf (&optional buf where)
(when (setq buf (get-buffer (or buf log-edit-files-buf)))
diff --git a/lisp/log-view.el b/lisp/vc/log-view.el
index 6d0e1332830..ac32cea6202 100644
--- a/lisp/log-view.el
+++ b/lisp/vc/log-view.el
@@ -4,7 +4,7 @@
;; 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Keywords: rcs sccs cvs log version-control tools
+;; Keywords: rcs, sccs, cvs, log, vc, tools
;; This file is part of GNU Emacs.
@@ -256,7 +256,8 @@ The match group number 1 should match the revision number itself.")
'log-view-beginning-of-defun)
(set (make-local-variable 'end-of-defun-function)
'log-view-end-of-defun)
- (set (make-local-variable 'cvs-minor-wrap-function) 'log-view-minor-wrap))
+ (set (make-local-variable 'cvs-minor-wrap-function) 'log-view-minor-wrap)
+ (hack-dir-local-variables-non-file-buffer))
;;;;
;;;; Navigation
diff --git a/lisp/pcvs-defs.el b/lisp/vc/pcvs-defs.el
index a49cd2f1ab1..7dda4533f6e 100644
--- a/lisp/pcvs-defs.el
+++ b/lisp/vc/pcvs-defs.el
@@ -6,6 +6,7 @@
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: pcl-cvs
+;; Package: pcvs
;; This file is part of GNU Emacs.
diff --git a/lisp/pcvs-info.el b/lisp/vc/pcvs-info.el
index 198b3dd057d..1ae924ff177 100644
--- a/lisp/pcvs-info.el
+++ b/lisp/vc/pcvs-info.el
@@ -6,6 +6,7 @@
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: pcl-cvs
+;; Package: pcvs
;; This file is part of GNU Emacs.
diff --git a/lisp/pcvs-parse.el b/lisp/vc/pcvs-parse.el
index deb11936c86..560a270a731 100644
--- a/lisp/pcvs-parse.el
+++ b/lisp/vc/pcvs-parse.el
@@ -5,6 +5,7 @@
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: pcl-cvs
+;; Package: pcvs
;; This file is part of GNU Emacs.
diff --git a/lisp/pcvs-util.el b/lisp/vc/pcvs-util.el
index 26f4a829a5f..595b762b2fa 100644
--- a/lisp/pcvs-util.el
+++ b/lisp/vc/pcvs-util.el
@@ -5,6 +5,7 @@
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: pcl-cvs
+;; Package: pcvs
;; This file is part of GNU Emacs.
diff --git a/lisp/pcvs.el b/lisp/vc/pcvs.el
index 28c24847b4d..305e109b6d6 100644
--- a/lisp/pcvs.el
+++ b/lisp/vc/pcvs.el
@@ -13,7 +13,7 @@
;; (Greg Klanderman) greg@alphatech.com
;; (Jari Aalto+mail.emacs) jari.aalto@poboxes.com
;; Maintainer: (Stefan Monnier) monnier@gnu.org
-;; Keywords: CVS, version control, release management
+;; Keywords: CVS, vc, release management
;; This file is part of GNU Emacs.
diff --git a/lisp/smerge-mode.el b/lisp/vc/smerge-mode.el
index 732f7d19cf9..32f829f814e 100644
--- a/lisp/smerge-mode.el
+++ b/lisp/vc/smerge-mode.el
@@ -4,7 +4,7 @@
;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Keywords: tools revision-control merge diff3 cvs conflict
+;; Keywords: vc, tools, revision control, merge, diff3, cvs, conflict
;; This file is part of GNU Emacs.
@@ -457,8 +457,8 @@ BUF contains a plain diff between match-1 and match-3."
(defun smerge-resolve (&optional safe)
"Resolve the conflict at point intelligently.
-This relies on mode-specific knowledge and thus only works in
-some major modes. Uses `smerge-resolve-function' to do the actual work."
+This relies on mode-specific knowledge and thus only works in some
+major modes. Uses `smerge-resolve-function' to do the actual work."
(interactive)
(smerge-match-conflict)
(smerge-remove-props (match-beginning 0) (match-end 0))
@@ -815,12 +815,12 @@ Its behavior has mainly two restrictions:
This only matters if `smerge-refine-weight-hack' is nil.")
(defvar smerge-refine-ignore-whitespace t
- "If non-nil,Indicate that smerge-refine should try to ignore change in whitespace.")
+ "If non-nil, indicate that `smerge-refine' should try to ignore change in whitespace.")
(defvar smerge-refine-weight-hack t
"If non-nil, pass to diff as many lines as there are chars in the region.
I.e. each atomic element (e.g. word) will be copied as many times (on different
-lines) as it has chars. This has 2 advantages:
+lines) as it has chars. This has two advantages:
- if `diff' tries to minimize the number *lines* (rather than chars)
added/removed, this adjust the weights so that adding/removing long
symbols is considered correspondingly more costly.
@@ -919,8 +919,8 @@ chars to try and eliminate some spurious differences."
"Show fine differences in the two regions BEG1..END1 and BEG2..END2.
PROPS is an alist of properties to put (via overlays) on the changes.
If non-nil, PREPROC is called with no argument in a buffer that contains
-a copy of a region, just before preparing it to for `diff'. It can be used to
-replace chars to try and eliminate some spurious differences."
+a copy of a region, just before preparing it to for `diff'. It can be
+used to replace chars to try and eliminate some spurious differences."
(let* ((buf (current-buffer))
(pos (point))
(file1 (make-temp-file "diff1"))
@@ -988,9 +988,9 @@ replace chars to try and eliminate some spurious differences."
(defun smerge-refine (&optional part)
"Highlight the words of the conflict that are different.
-For 3-way conflicts, highlights only 2 of the 3 parts.
-A numeric argument PART can be used to specify which 2 parts;
-repeating the command will highlight other 2 parts."
+For 3-way conflicts, highlights only two of the three parts.
+A numeric argument PART can be used to specify which two parts;
+repeating the command will highlight other two parts."
(interactive
(if (integerp current-prefix-arg) (list current-prefix-arg)
(smerge-match-conflict)
@@ -1009,6 +1009,10 @@ repeating the command will highlight other 2 parts."
(setq part (cond ((null (match-end 2)) 2)
((eq (match-end 1) (match-end 3)) 1)
((integerp part) part)
+ ;; If one of the parts is empty, any refinement using
+ ;; it will be trivial and uninteresting.
+ ((eq (match-end 1) (match-beginning 1)) 1)
+ ((eq (match-end 3) (match-beginning 3)) 3)
(t 2)))
(let ((n1 (if (eq part 1) 2 1))
(n2 (if (eq part 3) 2 3)))
@@ -1161,7 +1165,7 @@ buffer names."
(defun smerge-makeup-conflict (pt1 pt2 pt3 &optional pt4)
"Insert diff3 markers to make a new conflict.
-Uses point and mark for 2 of the relevant positions and previous marks
+Uses point and mark for two of the relevant positions and previous marks
for the other ones.
By default, makes up a 2-way conflict,
with a \\[universal-argument] prefix, makes up a 3-way conflict."
@@ -1184,7 +1188,7 @@ with a \\[universal-argument] prefix, makes up a 3-way conflict."
(insert "<<<<<<< MINE\n"))
(if smerge-mode nil (smerge-mode 1))
(smerge-refine))
-
+
(defconst smerge-parsep-re
(concat smerge-begin-re "\\|" smerge-end-re "\\|"
diff --git a/lisp/vc-annotate.el b/lisp/vc/vc-annotate.el
index da2f5de80df..10b88e6f14c 100644
--- a/lisp/vc-annotate.el
+++ b/lisp/vc/vc-annotate.el
@@ -5,7 +5,8 @@
;; Author: Martin Lorentzson <emwson@emw.ericsson.se>
;; Maintainer: FSF
-;; Keywords: tools
+;; Keywords: vc tools
+;; Package: vc
;; This file is part of GNU Emacs.
@@ -162,7 +163,8 @@ menu items."
(remove-from-invisibility-spec 'foo)
(set (make-local-variable 'truncate-lines) t)
(set (make-local-variable 'font-lock-defaults)
- '(vc-annotate-font-lock-keywords t)))
+ '(vc-annotate-font-lock-keywords t))
+ (hack-dir-local-variables-non-file-buffer))
(defun vc-annotate-toggle-annotation-visibility ()
"Toggle whether or not the annotation is visible."
diff --git a/lisp/vc-arch.el b/lisp/vc/vc-arch.el
index d9002f9f7d5..ba91f7f23c6 100644
--- a/lisp/vc-arch.el
+++ b/lisp/vc/vc-arch.el
@@ -5,6 +5,7 @@
;; Author: FSF (see vc.el for full credits)
;; Maintainer: Stefan Monnier <monnier@gnu.org>
+;; Package: vc
;; This file is part of GNU Emacs.
diff --git a/lisp/vc-bzr.el b/lisp/vc/vc-bzr.el
index 39736bb0377..9c253e027e4 100644
--- a/lisp/vc-bzr.el
+++ b/lisp/vc/vc-bzr.el
@@ -4,10 +4,11 @@
;; Author: Dave Love <fx@gnu.org>
;; Riccardo Murri <riccardo.murri@gmail.com>
-;; Keywords: tools
+;; Keywords: vc tools
;; Created: Sept 2006
-;; Version: 2008-01-04 (Bzr revno 25)
+;; Version: 2008-01-04
;; URL: http://launchpad.net/vc-bzr
+;; Package: vc
;; This file is part of GNU Emacs.
@@ -114,6 +115,8 @@ Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and
(concat vc-bzr-admin-dirname "/branch/revision-history"))
(defconst vc-bzr-admin-lastrev
(concat vc-bzr-admin-dirname "/branch/last-revision"))
+(defconst vc-bzr-admin-branchconf
+ (concat vc-bzr-admin-dirname "/branch/branch.conf"))
;;;###autoload (defun vc-bzr-registered (file)
;;;###autoload (if (vc-find-root file vc-bzr-admin-checkout-format-file)
@@ -128,6 +131,13 @@ Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and
(let ((root (vc-find-root file vc-bzr-admin-checkout-format-file)))
(when root (vc-file-setprop file 'bzr-root root)))))
+(defun vc-bzr--branch-conf (file)
+ "Return the Bzr branch config for file FILE, as a string."
+ (with-temp-buffer
+ (insert-file-contents
+ (expand-file-name vc-bzr-admin-branchconf (vc-bzr-root file)))
+ (buffer-string)))
+
(require 'sha1) ;For sha1-program
(defun vc-bzr-sha1 (file)
@@ -227,6 +237,9 @@ Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and
"added\\|ignored\\|kind changed\\|modified\\|removed\\|renamed\\|unknown"
"Regexp matching file status words as reported in `bzr' output.")
+;; History of Bzr commands.
+(defvar vc-bzr-history nil)
+
(defun vc-bzr-file-name-relative (filename)
"Return file name FILENAME stripped of the initial Bzr repository path."
(lexical-let*
@@ -235,6 +248,94 @@ Invoke the bzr command adding `BZR_PROGRESS_BAR=none' and
(when rootdir
(file-relative-name filename* rootdir))))
+(defun vc-bzr-async-command (command args)
+ "Run Bzr COMMAND asynchronously with ARGS, displaying the result.
+Send the output to a buffer named \"*vc-bzr : NAME*\", where NAME
+is the root of the current Bzr branch. Display the buffer in
+some window, but don't select it."
+ ;; TODO: set up hyperlinks.
+ (let* ((dir default-directory)
+ (root (vc-bzr-root default-directory))
+ (buffer (get-buffer-create
+ (format "*vc-bzr : %s*"
+ (expand-file-name root)))))
+ (with-current-buffer buffer
+ (setq default-directory root)
+ (goto-char (point-max))
+ (unless (eq (point) (point-min))
+ (insert " \n"))
+ (insert "Running \"" vc-bzr-program " " command)
+ (dolist (arg args)
+ (insert " " arg))
+ (insert "\"...\n")
+ ;; Run bzr in the original working directory.
+ (let ((default-directory dir))
+ (apply 'vc-bzr-command command t 'async nil args)))
+ (display-buffer buffer)))
+
+(defun vc-bzr-pull (prompt)
+ "Pull changes into the current Bzr branch.
+Normally, this runs \"bzr pull\". However, if the branch is a
+bound branch, run \"bzr update\" instead. If there is no default
+location from which to pull or update, or if PROMPT is non-nil,
+prompt for the Bzr command to run."
+ (let* ((vc-bzr-program vc-bzr-program)
+ (branch-conf (vc-bzr--branch-conf default-directory))
+ ;; Check whether the branch is bound.
+ (bound (string-match "^bound\\s-*=\\s-*True" branch-conf))
+ ;; If we need to do a "bzr pull", check for a parent. If it
+ ;; does not exist, bzr will need a pull location.
+ (parent (unless bound
+ (string-match
+ "^parent_location\\s-*=\\s-*[^\n[:space:]]+"
+ branch-conf)))
+ (command (if bound "update" "pull"))
+ args)
+ ;; If necessary, prompt for the exact command.
+ (when (or prompt (not (or bound parent)))
+ (setq args (split-string
+ (read-shell-command
+ "Run Bzr (like this): "
+ (concat vc-bzr-program " " command)
+ 'vc-bzr-history)
+ " " t))
+ (setq vc-bzr-program (car args)
+ command (cadr args)
+ args (cddr args)))
+ (vc-bzr-async-command command args)))
+
+(defun vc-bzr-merge-branch ()
+ "Merge another Bzr branch into the current one.
+Prompt for the Bzr command to run, providing a pre-defined merge
+source (an upstream branch or a previous merge source) as a
+default if it is available."
+ (let* ((branch-conf (vc-bzr--branch-conf default-directory))
+ ;; "bzr merge" without an argument defaults to submit_branch,
+ ;; then parent_location. We extract the specific location
+ ;; and add it explicitly to the command line.
+ (location
+ (cond
+ ((string-match
+ "^submit_branch\\s-*=\\s-*\\(?:file://\\)?\\([^\n[:space:]]+\\)$"
+ branch-conf)
+ (match-string 1 branch-conf))
+ ((string-match
+ "^parent_location\\s-*=\\s-*\\(?:file://\\)?\\([^\n[:space:]]+\\)$"
+ branch-conf)
+ (match-string 1 branch-conf))))
+ (cmd
+ (split-string
+ (read-shell-command
+ "Run Bzr (like this): "
+ (concat vc-bzr-program " merge --pull"
+ (if location (concat " " location) ""))
+ 'vc-bzr-history)
+ " " t))
+ (vc-bzr-program (car cmd))
+ (command (cadr cmd))
+ (args (cddr cmd)))
+ (vc-bzr-async-command command args)))
+
(defun vc-bzr-status (file)
"Return FILE status according to Bzr.
Return value is a cons (STATUS . WARNING), where WARNING is a
diff --git a/lisp/vc-cvs.el b/lisp/vc/vc-cvs.el
index 1abef9f48b8..a78b59ffba5 100644
--- a/lisp/vc-cvs.el
+++ b/lisp/vc/vc-cvs.el
@@ -5,6 +5,7 @@
;; Author: FSF (see vc.el for full credits)
;; Maintainer: Andre Spiegel <spiegel@gnu.org>
+;; Package: vc
;; This file is part of GNU Emacs.
@@ -91,9 +92,9 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches."
:version "21.1"
:group 'vc)
-(defcustom vc-cvs-header (or (cdr (assoc 'CVS vc-header-alist)) '("\$Id\$"))
+(defcustom vc-cvs-header '("\$Id\$")
"Header keywords to be inserted by `vc-insert-headers'."
- :version "21.1"
+ :version "24.1" ; no longer consult the obsolete vc-header-alist
:type '(repeat string)
:group 'vc)
diff --git a/lisp/vc-dav.el b/lisp/vc/vc-dav.el
index 1036f34fe79..bd495eaf4b7 100644
--- a/lisp/vc-dav.el
+++ b/lisp/vc/vc-dav.el
@@ -5,6 +5,7 @@
;; Author: Bill Perry <wmperry@gnu.org>
;; Maintainer: Bill Perry <wmperry@gnu.org>
;; Keywords: url, vc
+;; Package: vc
;; 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
diff --git a/lisp/vc-dir.el b/lisp/vc/vc-dir.el
index 96eb67085b6..4397251959d 100644
--- a/lisp/vc-dir.el
+++ b/lisp/vc/vc-dir.el
@@ -4,7 +4,8 @@
;; Free Software Foundation, Inc.
;; Author: Dan Nicolaescu <dann@ics.uci.edu>
-;; Keywords: tools
+;; Keywords: vc tools
+;; Package: vc
;; This file is part of GNU Emacs.
@@ -310,7 +311,8 @@ If BODY uses EVENT, it should be a variable,
map vc-dir-mode-map)
(tool-bar-local-item "bookmark_add"
'vc-dir-toggle-mark 'vc-dir-toggle-mark map
- :help "Toggle mark on current item")
+ :help "Toggle mark on current item"
+ :label "Toggle Mark")
(tool-bar-local-item-from-menu 'vc-dir-previous-line "left-arrow"
map vc-dir-mode-map
:rtl "right-arrow")
@@ -322,11 +324,14 @@ If BODY uses EVENT, it should be a variable,
(tool-bar-local-item-from-menu 'revert-buffer "refresh"
map vc-dir-mode-map)
(tool-bar-local-item-from-menu 'nonincremental-search-forward
- "search" map)
+ "search" map nil
+ :label "Search")
(tool-bar-local-item-from-menu 'vc-dir-query-replace-regexp
- "search-replace" map vc-dir-mode-map)
+ "search-replace" map vc-dir-mode-map
+ :label "Replace")
(tool-bar-local-item-from-menu 'vc-dir-kill-dir-status-process "cancel"
- map vc-dir-mode-map)
+ map vc-dir-mode-map
+ :label "Cancel")
(tool-bar-local-item-from-menu 'quit-window "exit"
map vc-dir-mode-map)
map))
@@ -962,6 +967,7 @@ the *vc-dir* buffer.
;; Make sure that if the directory buffer is killed, the update
;; process running in the background is also killed.
(add-hook 'kill-buffer-query-functions 'vc-dir-kill-query nil t)
+ (hack-dir-local-variables-non-file-buffer)
(vc-dir-refresh)))
(defun vc-dir-headers (backend dir)
diff --git a/lisp/vc-dispatcher.el b/lisp/vc/vc-dispatcher.el
index d0648570bec..b6ccae1af1b 100644
--- a/lisp/vc-dispatcher.el
+++ b/lisp/vc/vc-dispatcher.el
@@ -5,7 +5,8 @@
;; Author: FSF (see below for full credits)
;; Maintainer: Eric S. Raymond <esr@thyrsus.com>
-;; Keywords: tools
+;; Keywords: vc tools
+;; Package: vc
;; This file is part of GNU Emacs.
@@ -317,16 +318,9 @@ case, and the process object in the asynchronous case."
(status 0))
(when files
(setq squeezed (nconc squeezed files)))
- (let ((exec-path (append vc-path exec-path))
- ;; Add vc-path to PATH for the execution of this command.
- ;; Also, since some functions need to parse the output
+ (let (;; Since some functions need to parse the output
;; from external commands, set LC_MESSAGES to C.
- (process-environment
- (cons (concat "PATH=" (getenv "PATH")
- path-separator
- (mapconcat 'identity vc-path path-separator))
- (cons "LC_MESSAGES=C"
- process-environment)))
+ (process-environment (cons "LC_MESSAGES=C" process-environment))
(w32-quote-process-args t))
(if (eq okstatus 'async)
;; Run asynchronously.
diff --git a/lisp/vc-git.el b/lisp/vc/vc-git.el
index 4383e609adb..48a86454f74 100644
--- a/lisp/vc-git.el
+++ b/lisp/vc/vc-git.el
@@ -3,7 +3,8 @@
;; Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Alexandre Julliard <julliard@winehq.org>
-;; Keywords: tools
+;; Keywords: vc tools
+;; Package: vc
;; This file is part of GNU Emacs.
@@ -629,7 +630,7 @@ for the --graph option."
(vc-git-command nil 0 nil "fetch")
(vc-git-command
buffer 0 nil
- "log"
+ "log"
"--no-color" "--graph" "--decorate" "--date=short"
"--pretty=tformat:%d%h %ad %s" "--abbrev-commit"
(concat "HEAD.." (if (string= remote-location "")
diff --git a/lisp/vc-hg.el b/lisp/vc/vc-hg.el
index 52b74870427..2a2879aadb8 100644
--- a/lisp/vc-hg.el
+++ b/lisp/vc/vc-hg.el
@@ -3,7 +3,8 @@
;; Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Ivan Kanis
-;; Keywords: tools
+;; Keywords: vc tools
+;; Package: vc
;; This file is part of GNU Emacs.
diff --git a/lisp/vc-hooks.el b/lisp/vc/vc-hooks.el
index a0cf06fbe12..37426eb25f2 100644
--- a/lisp/vc-hooks.el
+++ b/lisp/vc/vc-hooks.el
@@ -6,6 +6,7 @@
;; Author: FSF (see vc.el for full credits)
;; Maintainer: Andre Spiegel <spiegel@gnu.org>
+;; Package: vc
;; This file is part of GNU Emacs.
@@ -48,9 +49,6 @@ vc-BACKEND-master-templates. To enable or disable VC for a given
BACKEND, use `vc-handled-backends'."
"21.1")
-(defvar vc-header-alist ())
-(make-obsolete-variable 'vc-header-alist 'vc-BACKEND-header "21.1")
-
(defcustom vc-ignore-dir-regexp
;; Stop SMB, automounter, AFS, and DFS host lookups.
locate-dominating-stop-dir-regexp
@@ -84,13 +82,6 @@ An empty list disables VC altogether."
:type '(repeat string)
:group 'vc)
-(defcustom vc-path nil
- "List of extra directories to search for version control commands."
- :type '(repeat directory)
- :group 'vc)
-
-(make-obsolete-variable 'vc-path "should not be necessary anymore." "23.2")
-
(defcustom vc-make-backup-files nil
"If non-nil, backups of registered files are made as with other files.
If nil (the default), files covered by version control don't get backups."
@@ -467,6 +458,9 @@ For registered files, the value returned is one of:
'edited The working file has been edited by the user. If
locking is used for the file, this state means that
the current version is locked by the calling user.
+ This status should *not* be reported for files
+ which have a changed mtime but the same content
+ as the repo copy.
USER The current version of the working file is locked by
some other USER (a string).
diff --git a/lisp/vc-mtn.el b/lisp/vc/vc-mtn.el
index f89b6a34d21..a1ca6ab4d65 100644
--- a/lisp/vc-mtn.el
+++ b/lisp/vc/vc-mtn.el
@@ -3,7 +3,8 @@
;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
-;; Keywords:
+;; Keywords: vc
+;; Package: vc
;; This file is part of GNU Emacs.
@@ -22,7 +23,7 @@
;;; Commentary:
-;;
+;;
;;; TODO:
diff --git a/lisp/vc-rcs.el b/lisp/vc/vc-rcs.el
index 91cae8ed970..f8d5214d776 100644
--- a/lisp/vc-rcs.el
+++ b/lisp/vc/vc-rcs.el
@@ -6,6 +6,7 @@
;; Author: FSF (see vc.el for full credits)
;; Maintainer: Andre Spiegel <spiegel@gnu.org>
+;; Package: vc
;; This file is part of GNU Emacs.
@@ -76,10 +77,10 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches."
:version "21.1"
:group 'vc)
-(defcustom vc-rcs-header (or (cdr (assoc 'RCS vc-header-alist)) '("\$Id\$"))
+(defcustom vc-rcs-header '("\$Id\$")
"Header keywords to be inserted by `vc-insert-headers'."
:type '(repeat string)
- :version "21.1"
+ :version "24.1" ; no longer consult the obsolete vc-header-alist
:group 'vc)
(defcustom vc-rcsdiff-knows-brief nil
diff --git a/lisp/vc-sccs.el b/lisp/vc/vc-sccs.el
index 43bbda42d3f..2acd778881a 100644
--- a/lisp/vc-sccs.el
+++ b/lisp/vc/vc-sccs.el
@@ -6,6 +6,7 @@
;; Author: FSF (see vc.el for full credits)
;; Maintainer: Andre Spiegel <spiegel@gnu.org>
+;; Package: vc
;; This file is part of GNU Emacs.
@@ -70,9 +71,10 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches."
:version "21.1"
:group 'vc)
-(defcustom vc-sccs-header (or (cdr (assoc 'SCCS vc-header-alist)) '("%W%"))
+(defcustom vc-sccs-header '("%W%")
"Header keywords to be inserted by `vc-insert-headers'."
:type '(repeat string)
+ :version "24.1" ; no longer consult the obsolete vc-header-alist
:group 'vc)
;;;###autoload
diff --git a/lisp/vc-svn.el b/lisp/vc/vc-svn.el
index 7b95c2a214d..3e4c299f096 100644
--- a/lisp/vc-svn.el
+++ b/lisp/vc/vc-svn.el
@@ -5,6 +5,7 @@
;; Author: FSF (see vc.el for full credits)
;; Maintainer: Stefan Monnier <monnier@gnu.org>
+;; Package: vc
;; This file is part of GNU Emacs.
@@ -83,9 +84,9 @@ want to force an empty list of arguments, use t."
:version "22.1"
:group 'vc)
-(defcustom vc-svn-header (or (cdr (assoc 'SVN vc-header-alist)) '("\$Id\$"))
+(defcustom vc-svn-header '("\$Id\$")
"Header keywords to be inserted by `vc-insert-headers'."
- :version "22.1"
+ :version "24.1" ; no longer consult the obsolete vc-header-alist
:type '(repeat string)
:group 'vc)
@@ -282,7 +283,7 @@ to the SVN command."
"Return non-nil if FILE could be registered in SVN.
This is only possible if SVN is responsible for FILE's directory.")
-(defun vc-svn-checkin (files rev comment)
+(defun vc-svn-checkin (files rev comment &optional extra-args-ignored)
"SVN-specific version of `vc-backend-checkin'."
(if rev (error "Committing to a specific revision is unsupported in SVN"))
(let ((status (apply
diff --git a/lisp/vc.el b/lisp/vc/vc.el
index 7ba24821ef6..40f91b70757 100644
--- a/lisp/vc.el
+++ b/lisp/vc/vc.el
@@ -6,7 +6,7 @@
;; Author: FSF (see below for full credits)
;; Maintainer: Andre Spiegel <spiegel@gnu.org>
-;; Keywords: tools
+;; Keywords: vc tools
;; This file is part of GNU Emacs.
@@ -100,7 +100,7 @@
;; In the list of functions below, each identifier needs to be prepended
;; with `vc-sys-'. Some of the functions are mandatory (marked with a
;; `*'), others are optional (`-').
-;;
+
;; BACKEND PROPERTIES
;;
;; * revision-granularity
@@ -109,7 +109,7 @@
;; that return 'file have per-file revision numbering; backends
;; that return 'repository have per-repository revision numbering,
;; so a revision level implicitly identifies a changeset
-;;
+
;; STATE-QUERYING FUNCTIONS
;;
;; * registered (file)
@@ -313,11 +313,24 @@
;;
;; - merge (file rev1 rev2)
;;
-;; Merge the changes between REV1 and REV2 into the current working file.
+;; Merge the changes between REV1 and REV2 into the current working file
+;; (for non-distributed VCS).
+;;
+;; - merge-branch ()
+;;
+;; Merge another branch into the current one, prompting for a
+;; location to merge from.
;;
;; - merge-news (file)
;;
;; Merge recent changes from the current branch into FILE.
+;; (for non-distributed VCS).
+;;
+;; - pull (prompt)
+;;
+;; Pull "upstream" changes into the current branch (for distributed
+;; VCS). If PROMPT is non-nil, or if necessary, prompt for a
+;; location to pull from.
;;
;; - steal-lock (file &optional revision)
;;
@@ -335,7 +348,7 @@
;;
;; Mark conflicts as resolved. Some VC systems need to run a
;; command to mark conflicts as resolved.
-;;
+
;; HISTORY FUNCTIONS
;;
;; * print-log (files buffer &optional shortlog start-revision limit)
@@ -440,7 +453,7 @@
;; If the backend supports annotating through copies and renames,
;; and displays a file name and a revision, then return a cons
;; (REVISION . FILENAME).
-;;
+
;; TAG SYSTEM
;;
;; - create-tag (dir name branchp)
@@ -461,7 +474,7 @@
;; does a sanity check whether there aren't any uncommitted changes at
;; or below DIR, and then performs a tree walk, using the `checkout'
;; function to retrieve the corresponding revisions.
-;;
+
;; MISCELLANEOUS
;;
;; - make-version-backups-p (file)
@@ -920,7 +933,8 @@ Within directories, only files already under version control are noticed."
(cond ((derived-mode-p 'vc-dir-mode) vc-dir-backend)
((derived-mode-p 'log-view-mode) log-view-vc-backend)
((derived-mode-p 'diff-mode) diff-vc-backend)
- ((derived-mode-p 'dired-mode)
+ ;; Maybe we could even use comint-mode rather than shell-mode?
+ ((derived-mode-p 'dired-mode 'shell-mode 'compilation-mode)
(vc-responsible-backend default-directory))
(vc-mode (vc-backend buffer-file-name))))
@@ -986,7 +1000,7 @@ current buffer."
(let ((backend (vc-responsible-backend default-directory)))
(unless backend (error "Directory not under VC"))
(list backend
- (dired-map-over-marks (dired-get-filename nil t) nil))))
+ (dired-map-over-marks (dired-get-filename nil t) nil))))
(defun vc-ensure-vc-buffer ()
"Make sure that the current buffer visits a version-controlled file."
@@ -1815,53 +1829,65 @@ The headers are reset to their non-expanded form."
;;;###autoload
(defun vc-merge ()
- "Merge changes between two revisions into the current buffer's file.
-This asks for two revisions to merge from in the minibuffer. If the
-first revision is a branch number, then merge all changes from that
-branch. If the first revision is empty, merge news, i.e. recent changes
-from the current branch.
-
-See Info node `Merging'."
+ "Perform a version control merge operation.
+On a distributed version control system, this runs a \"merge\"
+operation to incorporate changes from another branch onto the
+current branch, prompting for an argument list.
+
+On a non-distributed version control system, this merges changes
+between two revisions into the current fileset. This asks for
+two revisions to merge from in the minibuffer. If the first
+revision is a branch number, then merge all changes from that
+branch. If the first revision is empty, merge the most recent
+changes from the current branch."
(interactive)
- (vc-ensure-vc-buffer)
- (vc-buffer-sync)
- (let* ((file buffer-file-name)
- (backend (vc-backend file))
- (state (vc-state file))
- first-revision second-revision status)
+ (let* ((vc-fileset (vc-deduce-fileset t))
+ (backend (car vc-fileset))
+ (files (cadr vc-fileset)))
(cond
- ((stringp state) ;; Locking VCses only
- (error "File is locked by %s" state))
- ((not (vc-editable-p file))
- (if (y-or-n-p
- "File must be checked out for merging. Check out now? ")
- (vc-checkout file t)
- (error "Merge aborted"))))
- (setq first-revision
- (vc-read-revision
- (concat "Branch or revision to merge from "
- "(default news on current branch): ")
- (list file)
- backend))
- (if (string= first-revision "")
- (setq status (vc-call-backend backend 'merge-news file))
- (if (not (vc-find-backend-function backend 'merge))
- (error "Sorry, merging is not implemented for %s" backend)
- (if (not (vc-branch-p first-revision))
- (setq second-revision
- (vc-read-revision
- "Second revision: "
- (list file) backend nil
- ;; FIXME: This is CVS/RCS/SCCS specific.
- (concat (vc-branch-part first-revision) ".")))
- ;; We want to merge an entire branch. Set revisions
- ;; accordingly, so that vc-BACKEND-merge understands us.
- (setq second-revision first-revision)
- ;; first-revision must be the starting point of the branch
- (setq first-revision (vc-branch-part first-revision)))
- (setq status (vc-call-backend backend 'merge file
- first-revision second-revision))))
- (vc-maybe-resolve-conflicts file status "WORKFILE" "MERGE SOURCE")))
+ ;; If a branch-merge operation is defined, use it.
+ ((vc-find-backend-function backend 'merge-branch)
+ (vc-call-backend backend 'merge-branch))
+ ;; Otherwise, do a per-file merge.
+ ((vc-find-backend-function backend 'merge)
+ (vc-buffer-sync)
+ (dolist (file files)
+ (let* ((state (vc-state file))
+ first-revision second-revision status)
+ (cond
+ ((stringp state) ;; Locking VCses only
+ (error "File %s is locked by %s" file state))
+ ((not (vc-editable-p file))
+ (vc-checkout file t)))
+ (setq first-revision
+ (vc-read-revision
+ (concat "Merge " file
+ "from branch or revision "
+ "(default news on current branch): ")
+ (list file)
+ backend))
+ (cond
+ ((string= first-revision "")
+ (setq status (vc-call-backend backend 'merge-news file)))
+ (t
+ (if (not (vc-branch-p first-revision))
+ (setq second-revision
+ (vc-read-revision
+ "Second revision: "
+ (list file) backend nil
+ ;; FIXME: This is CVS/RCS/SCCS specific.
+ (concat (vc-branch-part first-revision) ".")))
+ ;; We want to merge an entire branch. Set revisions
+ ;; accordingly, so that vc-BACKEND-merge understands us.
+ (setq second-revision first-revision)
+ ;; first-revision must be the starting point of the branch
+ (setq first-revision (vc-branch-part first-revision)))
+ (setq status (vc-call-backend backend 'merge file
+ first-revision second-revision))))
+ (vc-maybe-resolve-conflicts file status "WORKFILE" "MERGE SOURCE"))))
+ (t
+ (error "Sorry, merging is not implemented for %s" backend)))))
+
(defun vc-maybe-resolve-conflicts (file status &optional name-A name-B)
(vc-resynch-buffer file t (not (buffer-modified-p)))
@@ -2273,35 +2299,47 @@ depending on the underlying version-control system."
(define-obsolete-function-alias 'vc-revert-buffer 'vc-revert "23.1")
;;;###autoload
-(defun vc-update ()
- "Update the current fileset's files to their tip revisions.
-For each one that contains no changes, and is not locked, then this simply
-replaces the work file with the latest revision on its branch. If the file
-contains changes, and the backend supports merging news, then any recent
-changes from the current branch are merged into the working file."
- (interactive)
- (let* ((vc-fileset (vc-deduce-fileset))
+(defun vc-update (&optional arg)
+ "Update the current fileset or branch.
+On a distributed version control system, this runs a \"pull\"
+operation to update the current branch, prompting for an argument
+list if required. Optional prefix ARG forces a prompt.
+
+On a non-distributed version control system, update the current
+fileset to the tip revisions. For each unchanged and unlocked
+file, this simply replaces the work file with the latest revision
+on its branch. If the file contains changes, any changes in the
+tip revision are merged into the working file."
+ (interactive "P")
+ (let* ((vc-fileset (vc-deduce-fileset t))
(backend (car vc-fileset))
(files (cadr vc-fileset)))
- (save-some-buffers ; save buffers visiting files
- nil (lambda ()
- (and (buffer-modified-p)
- (let ((file (buffer-file-name)))
- (and file (member file files))))))
- (dolist (file files)
- (if (vc-up-to-date-p file)
- (vc-checkout file nil t)
- (if (eq (vc-checkout-model backend (list file)) 'locking)
- (if (eq (vc-state file) 'edited)
- (error "%s"
- (substitute-command-keys
- "File is locked--type \\[vc-revert] to discard changes"))
- (error "Unexpected file state (%s) -- type %s"
- (vc-state file)
- (substitute-command-keys
- "\\[vc-next-action] to correct")))
- (vc-maybe-resolve-conflicts
- file (vc-call-backend backend 'merge-news file)))))))
+ (cond
+ ;; If a pull operation is defined, use it.
+ ((vc-find-backend-function backend 'pull)
+ (vc-call-backend backend 'pull arg))
+ ;; If VCS has `merge-news' functionality (CVS and SVN), use it.
+ ((vc-find-backend-function backend 'merge-news)
+ (save-some-buffers ; save buffers visiting files
+ nil (lambda ()
+ (and (buffer-modified-p)
+ (let ((file (buffer-file-name)))
+ (and file (member file files))))))
+ (dolist (file files)
+ (if (vc-up-to-date-p file)
+ (vc-checkout file nil t)
+ (vc-maybe-resolve-conflicts
+ file (vc-call-backend backend 'merge-news file)))))
+ ;; For a locking VCS, check out each file.
+ ((eq (vc-checkout-model backend files) 'locking)
+ (dolist (file files)
+ (if (vc-up-to-date-p file)
+ (vc-checkout file nil t))))
+ (t
+ (error "VC update is unsupported for `%s'" backend)))))
+
+;;;###autoload
+(defalias 'vc-pull 'vc-update)
(defun vc-version-backup-file (file &optional rev)
"Return name of backup file for revision REV of FILE.
diff --git a/lisp/vcursor.el b/lisp/vcursor.el
index 3573a86ad49..9e8fbf431f1 100644
--- a/lisp/vcursor.el
+++ b/lisp/vcursor.el
@@ -325,7 +325,7 @@
(defgroup vcursor nil
"Manipulate an alternative (\"virtual\") cursor."
:prefix "vcursor-"
- :group 'editing)
+ :group 'convenience)
(defface vcursor
'((((class color)) (:foreground "blue" :background "cyan" :underline t))
diff --git a/lisp/version.el b/lisp/version.el
index 49c355d7020..b4e2c61b570 100644
--- a/lisp/version.el
+++ b/lisp/version.el
@@ -6,6 +6,7 @@
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -29,12 +30,6 @@
;;; Code:
-(defconst emacs-copyright "Copyright (C) 2010 Free Software Foundation, Inc." "\
-Short copyright string for this version of Emacs.")
-
-(defconst emacs-version "23.2.90" "\
-Version numbers of this version of Emacs.")
-
(defconst emacs-major-version (progn (string-match "^[0-9]+" emacs-version) (string-to-number (match-string 0 emacs-version))) "\
Major version number of this version of Emacs.
This variable first existed in version 19.23.")
diff --git a/lisp/view.el b/lisp/view.el
index 219af1b6e1e..f6698ae5a9f 100644
--- a/lisp/view.el
+++ b/lisp/view.el
@@ -48,8 +48,7 @@
"Peruse file or buffer without editing."
:link '(function-link view-mode)
:link '(custom-manual "(emacs)Misc File Ops")
- :group 'wp
- :group 'editing)
+ :group 'wp)
(defcustom view-highlight-face 'highlight
"The face used for highlighting the match found by View mode search."
@@ -162,14 +161,6 @@ that use View mode automatically.")
"Overlay used to display where a search operation found its match.
This is local in each buffer, once it is used.")
(make-variable-buffer-local 'view-overlay)
-
-(unless (assq 'view-mode minor-mode-alist)
- (setq minor-mode-alist
- (cons (list 'view-mode
- (propertize " View"
- 'local-map mode-line-minor-mode-keymap
- 'help-echo "mouse-3: minor mode menu"))
- minor-mode-alist)))
;; Define keymap inside defvar to make it easier to load changes.
;; Some redundant "less"-like key bindings below have been commented out.
@@ -231,10 +222,6 @@ This is local in each buffer, once it is used.")
(define-key map "?" 'describe-mode) ; Maybe do as less instead? See above.
(define-key map "h" 'describe-mode)
map))
-
-(or (assq 'view-mode minor-mode-map-alist)
- (setq minor-mode-map-alist
- (cons (cons 'view-mode view-mode-map) minor-mode-map-alist)))
;;; Commands that enter or exit view mode.
@@ -263,13 +250,7 @@ This command runs the normal hook `view-mode-hook'."
(unless (file-exists-p file) (error "%s does not exist" file))
(let ((had-a-buf (get-file-buffer file))
(buffer (find-file-noselect file)))
- (if (eq (with-current-buffer buffer
- (get major-mode 'mode-class))
- 'special)
- (progn
- (switch-to-buffer buffer)
- (message "Not using View mode because the major mode is special"))
- (view-buffer buffer (and (not had-a-buf) 'kill-buffer-if-not-modified)))))
+ (view-buffer buffer (and (not had-a-buf) 'kill-buffer-if-not-modified))))
;;;###autoload
(defun view-file-other-window (file)
@@ -335,10 +316,16 @@ file: Users may suspend viewing in order to modify the buffer.
Exiting View mode will then discard the user's edits. Setting
EXIT-ACTION to `kill-buffer-if-not-modified' avoids this."
(interactive "bView buffer: ")
- (let ((undo-window (list (window-buffer) (window-start) (window-point))))
- (switch-to-buffer buffer)
- (view-mode-enter (cons (selected-window) (cons nil undo-window))
- exit-action)))
+ (if (eq (with-current-buffer buffer
+ (get major-mode 'mode-class))
+ 'special)
+ (progn
+ (switch-to-buffer buffer)
+ (message "Not using View mode because the major mode is special"))
+ (let ((undo-window (list (window-buffer) (window-start) (window-point))))
+ (switch-to-buffer buffer)
+ (view-mode-enter (cons (selected-window) (cons nil undo-window))
+ exit-action))))
;;;###autoload
(defun view-buffer-other-window (buffer &optional not-return exit-action)
@@ -394,7 +381,7 @@ this argument instead of explicitly setting `view-exit-action'."
exit-action)))
;;;###autoload
-(defun view-mode (&optional arg)
+(define-minor-mode view-mode
;; In the following documentation string we have to use some explicit key
;; bindings instead of using the \\[] construction. The reason for this
;; is that most commands have more than one key binding.
@@ -474,11 +461,8 @@ If view-mode was entered from another buffer, by \\[view-buffer],
then \\[View-leave], \\[View-quit] and \\[View-kill-and-leave] will return to that buffer.
Entry to view-mode runs the normal hook `view-mode-hook'."
- (interactive "P")
- (unless (and arg ; Do nothing if already OK.
- (if (> (prefix-numeric-value arg) 0) view-mode (not view-mode)))
- (if view-mode (view-mode-disable)
- (view-mode-enable))))
+ :lighter " View" :keymap view-mode-map
+ (if view-mode (view-mode-enable) (view-mode-disable)))
(defun view-mode-enable ()
"Turn on View mode."
diff --git a/lisp/w32-fns.el b/lisp/w32-fns.el
index efdf26b529c..0c6c56f84fb 100644
--- a/lisp/w32-fns.el
+++ b/lisp/w32-fns.el
@@ -5,6 +5,7 @@
;; Author: Geoff Voelker <voelker@cs.washington.edu>
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -31,34 +32,6 @@
;;;; Function keys
-(defvar x-alternatives-map
- (let ((map (make-sparse-keymap)))
- ;; Map certain keypad keys into ASCII characters that people usually expect.
- (define-key map [M-backspace] [?\M-\d])
- (define-key map [M-delete] [?\M-\d])
- (define-key map [M-tab] [?\M-\t])
- (define-key map [M-linefeed] [?\M-\n])
- (define-key map [M-clear] [?\M-\C-l])
- (define-key map [M-return] [?\M-\C-m])
- (define-key map [M-escape] [?\M-\e])
- (define-key map [iso-lefttab] [backtab])
- (define-key map [S-iso-lefttab] [backtab])
- (define-key map [S-tab] [backtab])
- map)
- "Keymap of possible alternative meanings for some keys.")
-
-(defun x-setup-function-keys (frame)
- "Set up `function-key-map' on the graphical frame FRAME."
- ;; Don't do this twice on the same display, or it would break
- ;; normal-erase-is-backspace-mode.
- (unless (terminal-parameter frame 'x-setup-function-keys)
- ;; Map certain keypad keys into ASCII characters that people usually expect.
- (with-selected-frame frame
- (let ((map (copy-keymap x-alternatives-map)))
- (set-keymap-parent map (keymap-parent local-function-key-map))
- (set-keymap-parent local-function-key-map map)))
- (set-terminal-parameter frame 'x-setup-function-keys t)))
-
(declare-function set-message-beep "w32console.c")
(declare-function w32-get-clipboard-data "w32select.c")
(declare-function w32-get-locale-info "w32proc.c")
@@ -253,15 +226,16 @@ You should set this to t when using a non-system shell.\n\n"))))
;; (setq source-directory (file-name-as-directory
;; (expand-file-name ".." exec-directory)))))
-(defun convert-standard-filename (filename)
- "Convert a standard file's name to something suitable for the current OS.
+(defun w32-convert-standard-filename (filename)
+ "Convert a standard file's name to something suitable for MS-Windows.
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')."
+This function is called by `convert-standard-filename'.
+
+Replace invalid characters and turn Cygwin names into native
+names, and also turn slashes into backslashes if the shell
+requires it (see `w32-shell-dos-semantics')."
(save-match-data
(let ((name
(if (string-match "\\`/cygdrive/\\([a-zA-Z]\\)/" filename)
@@ -423,40 +397,16 @@ bit output with no translation."
'w32-charset-info-alist "21.1")
-;;;; Selections and cut buffers
+;;;; Selections
;; We keep track of the last text selected here, so we can check the
;; current selection against it, and avoid passing back our own text
-;; from x-cut-buffer-or-selection-value.
+;; from x-selection-value.
(defvar x-last-selected-text nil)
-;; It is said that overlarge strings are slow to put into the cut buffer.
-;; Note this value is overridden below.
-(defvar x-cut-buffer-max 20000
- "Max number of characters to put in the cut buffer.")
-
-(defun x-select-text (text &optional push)
- "Select TEXT, a string, according to the window system.
-
-On X, put TEXT in the primary X selection. For backward
-compatibility with older X applications, set the value of X cut
-buffer 0 as well, and if the optional argument PUSH is non-nil,
-rotate the cut buffers. If `x-select-enable-clipboard' is
-non-nil, copy the text to the X clipboard as well.
-
-On Windows, make TEXT the current selection. If
-`x-select-enable-clipboard' is non-nil, copy the text to the
-clipboard as well. The argument PUSH is ignored.
-
-On Nextstep, put TEXT in the pasteboard; PUSH is ignored."
- (if x-select-enable-clipboard
- (w32-set-clipboard-data text))
- (setq x-last-selected-text text))
-
(defun x-get-selection-value ()
"Return the value of the current selection.
-Consult the selection, then the cut buffer. Treat empty strings as if
-they were unset."
+Consult the selection. Treat empty strings as if they were unset."
(if x-select-enable-clipboard
(let (text)
;; Don't die if x-get-selection signals an error.
@@ -474,7 +424,7 @@ they were unset."
(t
(setq x-last-selected-text text))))))
-(defalias 'x-cut-buffer-or-selection-value 'x-get-selection-value)
+(defalias 'x-selection-value 'x-get-selection-value)
;; Arrange for the kill and yank functions to set and check the clipboard.
(setq interprogram-cut-function 'x-select-text)
@@ -509,5 +459,4 @@ to include Sed, which is used by leim/Makefile.in to do the job."
(delete-matching-lines "^$\\|^;")
(save-buffers-kill-emacs t))
-;; arch-tag: c49b48cc-0f4f-454f-a274-c2dc34815e14
;;; w32-fns.el ends here
diff --git a/lisp/w32-vars.el b/lisp/w32-vars.el
index c1d593ea4ec..80cdfb57129 100644
--- a/lisp/w32-vars.el
+++ b/lisp/w32-vars.el
@@ -5,6 +5,7 @@
;; Author: Jason Rumney <jasonr@gnu.org>
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -147,17 +148,6 @@ menu if the variable `w32-use-w32-font-dialog' is nil."
(string :tag "Font")))))))
:group 'w32)
-(defcustom x-select-enable-clipboard t
- "Non-nil means cutting and pasting uses the clipboard.
-This is in addition to, but in preference to, the primary selection.
-
-On MS-Windows, this is non-nil by default, since Windows does not
-support other types of selections. \(The primary selection that is
-set by Emacs is not accessible to other programs on Windows.\)"
- :type 'boolean
- :group 'killing)
-
(provide 'w32-vars)
-;; arch-tag: ee2394fb-9db7-4c15-a8f0-66b47f4a2bb1
;;; w32-vars.el ends here
diff --git a/lisp/wid-browse.el b/lisp/wid-browse.el
index 698e6e805a4..96e6bd236cf 100644
--- a/lisp/wid-browse.el
+++ b/lisp/wid-browse.el
@@ -5,6 +5,7 @@
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: extensions
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el
index e75aba22269..9c7de61d7cd 100644
--- a/lisp/wid-edit.el
+++ b/lisp/wid-edit.el
@@ -6,6 +6,7 @@
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Maintainer: FSF
;; Keywords: extensions
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -56,8 +57,6 @@
;;; Code:
-(defvar widget)
-
;;; Compatibility.
(defun widget-event-point (event)
@@ -78,8 +77,7 @@
:link '(custom-manual "(widget)Top")
:link '(emacs-library-link :tag "Lisp File" "widget.el")
:prefix "widget-"
- :group 'extensions
- :group 'hypermedia)
+ :group 'extensions)
(defgroup widget-documentation nil
"Options controlling the display of documentation strings."
@@ -254,7 +252,9 @@ minibuffer."
;; Allocate digits to disabled alternatives
;; so that the digit of a given alternative never varies.
(setq next-digit (1+ next-digit)))
- (insert "\nC-g = Quit"))
+ (insert "\nC-g = Quit")
+ (goto-char (point-min))
+ (forward-line))
(or some-choice-enabled
(error "None of the choices is currently meaningful"))
(define-key map [?\C-g] 'keyboard-quit)
@@ -637,9 +637,9 @@ extension (xpm, xbm, gif, jpg, or png) located in
specs)
(dolist (elt widget-image-conversion)
(dolist (ext (cdr elt))
- (push (list :type (car elt) :file (concat image ext)) specs)))
- (setq specs (nreverse specs))
- (find-image specs)))
+ (push (list :type (car elt) :file (concat image ext)
+ :ascent 'center) specs)))
+ (find-image (nreverse specs))))
(t
;; Oh well.
nil)))
@@ -656,7 +656,7 @@ IMAGE should either be an image or an image file name sans extension
Optional arguments DOWN and INACTIVE are used instead of IMAGE when the
button is pressed or inactive, respectively. These are currently ignored."
- (if (and (display-graphic-p)
+ (if (and (featurep 'image)
(setq image (widget-image-find image)))
(progn (widget-put widget :suppress-face t)
(insert-image image tag))
@@ -1336,7 +1336,7 @@ Unlike (get-char-property POS 'field), this works with empty fields too."
(goto-char end)
(while (and (eq (preceding-char) ?\s)
(> (point) begin))
- (delete-backward-char 1)))))))
+ (delete-char -1)))))))
(widget-specify-secret field))
(widget-apply field :notify field))))
@@ -1460,11 +1460,15 @@ The value of the :type attribute should be an unconverted widget type."
:notify 'widget-default-notify
:prompt-value 'widget-default-prompt-value)
+(defvar widget--completing-widget)
+
(defun widget-default-complete (widget)
"Call the value of the :complete-function property of WIDGET.
-If that does not exist, call the value of `widget-complete-field'."
- (call-interactively (or (widget-get widget :complete-function)
- widget-complete-field)))
+If that does not exist, call the value of `widget-complete-field'.
+During this call, `widget--completing-widget' is bound to WIDGET."
+ (let ((widget--completing-widget widget))
+ (call-interactively (or (widget-get widget :complete-function)
+ widget-complete-field))))
(defun widget-default-create (widget)
"Create WIDGET at point in the current buffer."
@@ -1479,7 +1483,7 @@ If that does not exist, call the value of `widget-complete-field'."
;; Parse escapes in format.
(while (re-search-forward "%\\(.\\)" nil t)
(let ((escape (char-after (match-beginning 1))))
- (delete-backward-char 2)
+ (delete-char -2)
(cond ((eq escape ?%)
(insert ?%))
((eq escape ?\[)
@@ -1512,7 +1516,7 @@ If that does not exist, call the value of `widget-complete-field'."
(setq doc-begin (point))
(insert doc)
(while (eq (preceding-char) ?\n)
- (delete-backward-char 1))
+ (delete-char -1))
(insert ?\n)
(setq doc-end (point)))))
((eq escape ?h)
@@ -1876,6 +1880,7 @@ by some other text in the `:format' string (if specified)."
:valid-regexp ""
:error "Field's value doesn't match allowed forms"
:value-create 'widget-field-value-create
+ :value-set 'widget-field-value-set
:value-delete 'widget-field-value-delete
:value-get 'widget-field-value-get
:match 'widget-field-match)
@@ -1914,6 +1919,18 @@ the earlier input."
(widget-apply widget :value-get))
widget))
+(defun widget-field-value-set (widget value)
+ "Set an editable text field WIDGET to VALUE"
+ (let ((from (widget-field-start widget))
+ (to (widget-field-text-end widget))
+ (buffer (widget-field-buffer widget))
+ (size (widget-get widget :size)))
+ (when (and from to (buffer-live-p buffer))
+ (with-current-buffer buffer
+ (goto-char from)
+ (delete-char (- to from))
+ (insert value)))))
+
(defun widget-field-value-create (widget)
"Create an editable text field."
(let ((size (widget-get widget :size))
@@ -1951,7 +1968,6 @@ the earlier input."
(let ((from (widget-field-start widget))
(to (widget-field-text-end widget))
(buffer (widget-field-buffer widget))
- (size (widget-get widget :size))
(secret (widget-get widget :secret))
(old (current-buffer)))
(if (and from to)
@@ -2179,19 +2195,9 @@ when he invoked the menu."
;; We could probably do the same job as the images using single
;; space characters in a boxed face with a stretch specification to
;; make them square.
- :on-glyph '(create-image "\300\300\141\143\067\076\034\030"
- 'xbm t :width 8 :height 8
- :background "grey75" ; like default mode line
- :foreground "black"
- :relief -2
- :ascent 'center)
+ :on-glyph "checked"
:off "[ ]"
- :off-glyph '(create-image (make-string 8 0)
- 'xbm t :width 8 :height 8
- :background "grey75"
- :foreground "black"
- :relief -2
- :ascent 'center)
+ :off-glyph "unchecked"
:help-echo "Toggle this item."
:action 'widget-checkbox-action)
@@ -2223,11 +2229,10 @@ when he invoked the menu."
(defun widget-checklist-value-create (widget)
;; Insert all values
- (let ((alist (widget-checklist-match-find widget (widget-get widget :value)))
- (args (widget-get widget :args)))
- (while args
- (widget-checklist-add-item widget (car args) (assq (car args) alist))
- (setq args (cdr args)))
+ (let ((alist (widget-checklist-match-find widget))
+ (args (widget-get widget :args)))
+ (dolist (item args)
+ (widget-checklist-add-item widget item (assq item alist)))
(widget-put widget :children (nreverse (widget-get widget :children)))))
(defun widget-checklist-add-item (widget type chosen)
@@ -2248,7 +2253,7 @@ If the item is checked, CHOSEN is a cons whose cdr is the value."
;; Parse % escapes in format.
(while (re-search-forward "%\\([bv%]\\)" nil t)
(let ((escape (char-after (match-beginning 1))))
- (delete-backward-char 2)
+ (delete-char -2)
(cond ((eq escape ?%)
(insert ?%))
((eq escape ?b)
@@ -2300,9 +2305,10 @@ If the item is checked, CHOSEN is a cons whose cdr is the value."
values nil)))))
(cons found rest)))
-(defun widget-checklist-match-find (widget vals)
+(defun widget-checklist-match-find (widget &optional vals)
"Find the vals which match a type in the checklist.
Return an alist of (TYPE MATCH)."
+ (or vals (setq vals (widget-get widget :value)))
(let ((greedy (widget-get widget :greedy))
(args (copy-sequence (widget-get widget :args)))
found)
@@ -2431,7 +2437,7 @@ Return an alist of (TYPE MATCH)."
;; Parse % escapes in format.
(while (re-search-forward "%\\([bv%]\\)" nil t)
(let ((escape (char-after (match-beginning 1))))
- (delete-backward-char 2)
+ (delete-char -2)
(cond ((eq escape ?%)
(insert ?%))
((eq escape ?b)
@@ -2710,7 +2716,7 @@ Return an alist of (TYPE MATCH)."
;; Parse % escapes in format.
(while (re-search-forward "%\\(.\\)" nil t)
(let ((escape (char-after (match-beginning 1))))
- (delete-backward-char 2)
+ (delete-char -2)
(cond ((eq escape ?%)
(insert ?%))
((eq escape ?i)
@@ -2795,11 +2801,10 @@ Return an alist of (TYPE MATCH)."
argument answer found)
(while args
(setq argument (car args)
- args (cdr args)
- answer (widget-match-inline argument vals))
- (if answer
- (setq vals (cdr answer)
- found (append found (car answer)))
+ args (cdr args))
+ (if (setq answer (widget-match-inline argument vals))
+ (setq found (append found (car answer))
+ vals (cdr answer))
(setq vals nil
args nil)))
(if answer
@@ -2808,11 +2813,19 @@ Return an alist of (TYPE MATCH)."
;;; The `visibility' Widget.
(define-widget 'visibility 'item
- "An indicator and manipulator for hidden items."
+ "An indicator and manipulator for hidden items.
+
+The following properties have special meanings for this widget:
+:on-image Image filename or spec to display when the item is visible.
+:on Text shown if the \"on\" image is nil or cannot be displayed.
+:off-image Image filename or spec to display when the item is hidden.
+:off Text shown if the \"off\" image is nil cannot be displayed."
:format "%[%v%]"
:button-prefix ""
:button-suffix ""
+ :on-image "down"
:on "Hide"
+ :off-image "right"
:off "Show"
:value-create 'widget-visibility-value-create
:action 'widget-toggle-action
@@ -2820,21 +2833,17 @@ Return an alist of (TYPE MATCH)."
(defun widget-visibility-value-create (widget)
;; Insert text representing the `on' and `off' states.
- (let ((on (widget-get widget :on))
- (off (widget-get widget :off)))
- (if on
- (setq on (concat widget-push-button-prefix
- on
- widget-push-button-suffix))
- (setq on ""))
- (if off
- (setq off (concat widget-push-button-prefix
- off
- widget-push-button-suffix))
- (setq off ""))
- (if (widget-value widget)
- (widget-image-insert widget on "down" "down-pushed")
- (widget-image-insert widget off "right" "right-pushed"))))
+ (let* ((val (widget-value widget))
+ (text (widget-get widget (if val :on :off)))
+ (img (widget-image-find
+ (widget-get widget (if val :on-image :off-image)))))
+ (widget-image-insert widget
+ (if text
+ (concat widget-push-button-prefix text
+ widget-push-button-suffix)
+ "")
+ (if img
+ (append img '(:ascent center))))))
;;; The `documentation-link' Widget.
;;
@@ -2937,7 +2946,7 @@ link for that string."
(widget-create-child-and-convert
widget (widget-get widget :visibility-widget)
:help-echo "Show or hide rest of the documentation."
- :on "Hide Rest"
+ :on "Hide"
:off "More"
:always-active t
:action 'widget-parent-action
@@ -3031,14 +3040,13 @@ as the value."
:complete-function 'ispell-complete-word
:prompt-history 'widget-string-prompt-value-history)
-(defvar widget)
-
(defun widget-string-complete ()
"Complete contents of string field.
Completions are taken from the :completion-alist property of the
widget. If that isn't a list, it's evalled and expected to yield a list."
(interactive)
- (let* ((completion-ignore-case (widget-get widget :completion-ignore-case))
+ (let* ((widget widget--completing-widget)
+ (completion-ignore-case (widget-get widget :completion-ignore-case))
(alist (widget-get widget :completion-alist))
(_ (unless (listp alist)
(setq alist (eval alist)))))
@@ -3083,9 +3091,10 @@ It reads a file name from an editable text field."
(defun widget-file-complete ()
"Perform completion on file name preceding point."
(interactive)
- (completion-in-region (widget-field-start widget)
- (max (point) (widget-field-text-end widget))
- 'completion-file-name-table))
+ (let ((widget widget--completing-widget))
+ (completion-in-region (widget-field-start widget)
+ (max (point) (widget-field-text-end widget))
+ 'completion-file-name-table)))
(defun widget-file-prompt-value (widget prompt value unbound)
;; Read file from minibuffer.
@@ -3694,6 +3703,7 @@ example:
(define-widget 'color 'editable-field
"Choose a color name (with sample)."
:format "%{%t%}: %v (%{sample%})\n"
+ :value-create 'widget-color-value-create
:size 10
:tag "Color"
:value "black"
@@ -3702,6 +3712,27 @@ example:
:notify 'widget-color-notify
:action 'widget-color-action)
+(defun widget-color-value-create (widget)
+ (widget-field-value-create widget)
+ (widget-insert " ")
+ (widget-create-child-and-convert
+ widget 'push-button
+ :tag " Choose " :action 'widget-color--choose-action)
+ (widget-insert " "))
+
+(defun widget-color--choose-action (widget &optional event)
+ (list-colors-display
+ nil nil
+ `(lambda (color)
+ (when (buffer-live-p ,(current-buffer))
+ (widget-value-set ',(widget-get widget :parent) color)
+ (let* ((buf (get-buffer "*Colors*"))
+ (win (get-buffer-window buf 0)))
+ (bury-buffer buf)
+ (and win (> (length (window-list)) 1)
+ (delete-window win)))
+ (pop-to-buffer ,(current-buffer))))))
+
(defun widget-color-complete (widget)
"Complete the color in WIDGET."
(require 'facemenu) ; for facemenu-color-alist
diff --git a/lisp/widget.el b/lisp/widget.el
index 3e35f6c25ab..962235a25d2 100644
--- a/lisp/widget.el
+++ b/lisp/widget.el
@@ -7,6 +7,7 @@
;; Keywords: help, extensions, faces, hypermedia
;; Version: 1.9920
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
+;; Package: emacs
;; This file is part of GNU Emacs.
diff --git a/lisp/window.el b/lisp/window.el
index 4b1155f2388..45d7875cf20 100644
--- a/lisp/window.el
+++ b/lisp/window.el
@@ -6,6 +6,7 @@
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -54,6 +55,7 @@ This macro saves and restores the current buffer, since otherwise
its normal operation could make a different buffer current. The
order of recently selected windows and the buffer list ordering
are not altered by this macro (unless they are altered in BODY)."
+ (declare (indent 0) (debug t))
`(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
@@ -1220,19 +1222,16 @@ at the front of the list of recently selected ones."
(let ((buf (get-buffer-create buffer-or-name)))
(set-buffer-major-mode buf)
buf))))
- (old-window (selected-window))
(old-frame (selected-frame))
new-window new-frame)
(set-buffer buffer)
(setq new-window (display-buffer buffer other-window))
- (unless (eq new-window old-window)
- ;; `display-buffer' has chosen another window, select it.
- (select-window new-window norecord)
- (setq new-frame (window-frame new-window))
- (unless (eq new-frame old-frame)
- ;; `display-buffer' has chosen another frame, make sure it gets
- ;; input focus and is risen.
- (select-frame-set-input-focus new-frame)))
+ (select-window new-window norecord)
+ (setq new-frame (window-frame new-window))
+ (unless (eq new-frame old-frame)
+ ;; `display-buffer' has chosen another frame, make sure it gets
+ ;; input focus and is risen.
+ (select-frame-set-input-focus new-frame))
buffer))
;; I think this should be the default; I think people will prefer it--rms.
@@ -1617,6 +1616,7 @@ Otherwise, bury WINDOW's buffer, see `bury-buffer'."
(kill-buffer buffer)
(bury-buffer buffer))))
+
(defvar recenter-last-op nil
"Indicates the last recenter operation performed.
Possible values: `top', `middle', `bottom', integer or float numbers.")
@@ -1709,6 +1709,154 @@ by `recenter-positions'."
(define-key global-map [?\M-r] 'move-to-window-line-top-bottom)
+;;; Scrolling commands.
+
+;;; Scrolling commands which does not signal errors at top/bottom
+;;; of buffer at first key-press (instead moves to top/bottom
+;;; of buffer).
+
+(defcustom scroll-error-top-bottom nil
+ "Move point to top/bottom of buffer before signalling a scrolling error.
+A value of nil means just signal an error if no more scrolling possible.
+A value of t means point moves to the beginning or the end of the buffer
+\(depending on scrolling direction) when no more scrolling possible.
+When point is already on that position, then signal an error."
+ :type 'boolean
+ :group 'scrolling
+ :version "24.1")
+
+(defun scroll-up-command (&optional arg)
+ "Scroll text of selected window upward ARG lines; or near full screen if no ARG.
+If `scroll-error-top-bottom' is non-nil and `scroll-up' cannot
+scroll window further, move cursor to the bottom line.
+When point is already on that position, then signal an error.
+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
+ ((null scroll-error-top-bottom)
+ (scroll-up arg))
+ ((eq arg '-)
+ (scroll-down-command nil))
+ ((< (prefix-numeric-value arg) 0)
+ (scroll-down-command (- (prefix-numeric-value arg))))
+ ((eobp)
+ (scroll-up arg)) ; signal error
+ (t
+ (condition-case nil
+ (scroll-up arg)
+ (end-of-buffer
+ (if arg
+ ;; When scrolling by ARG lines can't be done,
+ ;; move by ARG lines instead.
+ (forward-line arg)
+ ;; When ARG is nil for full-screen scrolling,
+ ;; move to the bottom of the buffer.
+ (goto-char (point-max))))))))
+
+(put 'scroll-up-command 'scroll-command t)
+
+(defun scroll-down-command (&optional arg)
+ "Scroll text of selected window down ARG lines; or near full screen if no ARG.
+If `scroll-error-top-bottom' is non-nil and `scroll-down' cannot
+scroll window further, move cursor to the top line.
+When point is already on that position, then signal an error.
+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
+ ((null scroll-error-top-bottom)
+ (scroll-down arg))
+ ((eq arg '-)
+ (scroll-up-command nil))
+ ((< (prefix-numeric-value arg) 0)
+ (scroll-up-command (- (prefix-numeric-value arg))))
+ ((bobp)
+ (scroll-down arg)) ; signal error
+ (t
+ (condition-case nil
+ (scroll-down arg)
+ (beginning-of-buffer
+ (if arg
+ ;; When scrolling by ARG lines can't be done,
+ ;; move by ARG lines instead.
+ (forward-line (- arg))
+ ;; When ARG is nil for full-screen scrolling,
+ ;; move to the top of the buffer.
+ (goto-char (point-min))))))))
+
+(put 'scroll-down-command 'scroll-command t)
+
+;;; Scrolling commands which scroll a line instead of full screen.
+
+(defun scroll-up-line (&optional arg)
+ "Scroll text of selected window upward ARG lines; or one line if no ARG.
+If ARG is omitted or nil, scroll upward by one line.
+This is different from `scroll-up-command' that scrolls a full screen."
+ (interactive "p")
+ (scroll-up (or arg 1)))
+
+(put 'scroll-up-line 'scroll-command t)
+
+(defun scroll-down-line (&optional arg)
+ "Scroll text of selected window down ARG lines; or one line if no ARG.
+If ARG is omitted or nil, scroll down by one line.
+This is different from `scroll-down-command' that scrolls a full screen."
+ (interactive "p")
+ (scroll-down (or arg 1)))
+
+(put 'scroll-down-line 'scroll-command t)
+
+
+(defun scroll-other-window-down (lines)
+ "Scroll the \"other window\" down.
+For more details, see the documentation for `scroll-other-window'."
+ (interactive "P")
+ (scroll-other-window
+ ;; Just invert the argument's meaning.
+ ;; We can do that without knowing which window it will be.
+ (if (eq lines '-) nil
+ (if (null lines) '-
+ (- (prefix-numeric-value lines))))))
+
+(defun beginning-of-buffer-other-window (arg)
+ "Move point to the beginning of the buffer in the other window.
+Leave mark at previous position.
+With arg N, put point N/10 of the way from the true beginning."
+ (interactive "P")
+ (let ((orig-window (selected-window))
+ (window (other-window-for-scrolling)))
+ ;; We use unwind-protect rather than save-window-excursion
+ ;; because the latter would preserve the things we want to change.
+ (unwind-protect
+ (progn
+ (select-window window)
+ ;; Set point and mark in that window's buffer.
+ (with-no-warnings
+ (beginning-of-buffer arg))
+ ;; Set point accordingly.
+ (recenter '(t)))
+ (select-window orig-window))))
+
+(defun end-of-buffer-other-window (arg)
+ "Move point to the end of the buffer in the other window.
+Leave mark at previous position.
+With arg N, put point N/10 of the way from the true end."
+ (interactive "P")
+ ;; See beginning-of-buffer-other-window for comments.
+ (let ((orig-window (selected-window))
+ (window (other-window-for-scrolling)))
+ (unwind-protect
+ (progn
+ (select-window window)
+ (with-no-warnings
+ (end-of-buffer arg))
+ (recenter '(t)))
+ (select-window orig-window))))
+
+
(defvar mouse-autoselect-window-timer nil
"Timer used by delayed window autoselection.")
diff --git a/lisp/woman.el b/lisp/woman.el
index 63c61016b52..25113419deb 100644
--- a/lisp/woman.el
+++ b/lisp/woman.el
@@ -7,7 +7,7 @@
;; Maintainer: FSF
;; Keywords: help, unix
;; Adapted-By: Eli Zaretskii <eliz@gnu.org>
-;; Version: see `woman-version'
+;; Version: 0.551
;; URL: http://centaur.maths.qmul.ac.uk/Emacs/WoMan/
;; This file is part of GNU Emacs.
@@ -810,7 +810,7 @@ without interactive confirmation, if it exists as a topic."
(defvar woman-file-regexp nil
"Regexp used to select (possibly compressed) man source files, e.g.
-\"\\.\\([0-9lmnt]\\w*\\)\\(\\.\\(g?z\\|bz2\\)\\)?\\'\".
+\"\\.\\([0-9lmnt]\\w*\\)\\(\\.\\(g?z\\|bz2\\|xz\\)\\)?\\'\".
Built automatically from the customizable user options
`woman-uncompressed-file-regexp' and `woman-file-compression-regexp'.")
@@ -846,16 +846,17 @@ MUST NOT end with any kind of string terminator such as $ or \\'."
:group 'woman-interface)
(defcustom woman-file-compression-regexp
- "\\.\\(g?z\\|bz2\\)\\'"
+ "\\.\\(g?z\\|bz2\\|xz\\)\\'"
"Do not change this unless you are sure you know what you are doing!
Regexp used to match compressed man file extensions for which
decompressors are available and handled by auto-compression mode,
-e.g. \"\\\\.\\\\(g?z\\\\|bz2\\\\)\\\\'\" for `gzip' or `bzip2'.
+e.g. \"\\\\.\\\\(g?z\\\\|bz2\\\\|xz\\\\)\\\\'\" for `gzip', `bzip2', or `xz'.
Should begin with \\. and end with \\' and MUST NOT be optional."
;; Should be compatible with car of
;; `jka-compr-file-name-handler-entry', but that is unduly
;; complicated, includes an inappropriate extension (.tgz) and is
;; not loaded by default!
+ :version "24.1" ; added xz
:type 'regexp
:set 'set-woman-file-regexp
:group 'woman-interface)
@@ -1897,6 +1898,7 @@ Argument EVENT is the invoking mouse event."
(setq woman-emulation value)
(woman-reformat-last-file))
+(defvar bookmark-make-record-function)
(put 'woman-mode 'mode-class 'special)
(defun woman-mode ()
@@ -1934,6 +1936,9 @@ See `Man-mode' for additional details."
;; `make-local-variable' in case imenu not yet loaded!
woman-imenu-generic-expression)
(set (make-local-variable 'imenu-space-replacement) " ")
+ ;; Bookmark support.
+ (set (make-local-variable 'bookmark-make-record-function)
+ 'woman-bookmark-make-record)
;; For reformat ...
;; necessary when reformatting a file in its old buffer:
(setq imenu--last-menubar-index-alist nil)
@@ -2439,7 +2444,7 @@ Preserves location of `point'."
(while (and
(<= (setq N (1+ N)) 0)
(cond ((memq (preceding-char) '(?\ ?\t))
- (delete-backward-char 1) t)
+ (delete-char -1) t)
((memq (following-char) '(?\ ?\t))
(delete-char 1) t)
(t nil))))
@@ -2470,23 +2475,23 @@ Preserves location of `point'."
Start at FROM and re-scan new text as appropriate."
(goto-char from)
(let ((woman0-if-to (make-marker))
- request woman0-macro-alist
+ woman-request woman0-macro-alist
(woman0-search-regex-start woman0-search-regex-start)
(woman0-search-regex
(concat woman0-search-regex-start woman0-search-regex-end))
woman0-rename-alist)
(set-marker-insertion-type woman0-if-to t)
(while (re-search-forward woman0-search-regex nil t)
- (setq request (match-string 1))
- (cond ((string= request "ig") (woman0-ig))
- ((string= request "if") (woman0-if "if"))
- ((string= request "ie") (woman0-if "ie"))
- ((string= request "el") (woman0-el))
- ((string= request "so") (woman0-so))
- ((string= request "rn") (woman0-rn))
- ((string= request "de") (woman0-de))
- ((string= request "am") (woman0-de 'append))
- (t (woman0-macro request))))
+ (setq woman-request (match-string 1))
+ (cond ((string= woman-request "ig") (woman0-ig))
+ ((string= woman-request "if") (woman0-if "if"))
+ ((string= woman-request "ie") (woman0-if "ie"))
+ ((string= woman-request "el") (woman0-el))
+ ((string= woman-request "so") (woman0-so))
+ ((string= woman-request "rn") (woman0-rn))
+ ((string= woman-request "de") (woman0-de))
+ ((string= woman-request "am") (woman0-de 'append))
+ (t (woman0-macro woman-request))))
(set-marker woman0-if-to nil)
(woman0-rename)
;; Should now re-run `woman0-roff-buffer' if any renaming was
@@ -2517,6 +2522,7 @@ Start at FROM and re-scan new text as appropriate."
(goto-char from) ; necessary!
(woman2-process-escapes to 'numeric))
+;; request does not appear to be used dynamically by any callees.
(defun woman0-if (request)
".if/ie c anything -- Discard unless c evaluates to true.
Remember condition for use by a subsequent `.el'.
@@ -2568,6 +2574,7 @@ REQUEST is the invoking directive without the leading dot."
(woman-if-ignore woman0-if-to request) ; ERROR!
(woman-if-body request woman0-if-to (eq c negated)))))
+;; request is not used dynamically by any callees.
(defun woman-if-body (request to delete) ; should be reversed as `accept'?
"Process if-body, including \\{ ... \\}.
REQUEST is the invoking directive without the leading dot.
@@ -2624,6 +2631,7 @@ If DELETE is non-nil then delete from point."
(if (looking-at "[ \t]*\\{") (search-forward "\\}"))
(forward-line 1))))
+;; request is not used dynamically by any callees.
(defun woman-if-ignore (to request)
"Ignore but warn about an if request ending at TO, named REQUEST."
(WoMan-warn-ignored request "ignored -- condition not handled!")
@@ -2755,15 +2763,17 @@ Optional argument APPEND, if non-nil, means append macro."
(beginning-of-line) ; delete .de/am line
(woman-delete-line 1))
-(defun woman0-macro (request)
- "Process the macro call named REQUEST."
+;; request may be used dynamically (woman-interpolate-macro calls
+;; woman-forward-arg).
+(defun woman0-macro (woman-request)
+ "Process the macro call named WOMAN-REQUEST."
;; Leaves point at start of new text.
- (let ((macro (assoc request woman0-macro-alist)))
+ (let ((macro (assoc woman-request woman0-macro-alist)))
(if macro
(woman-interpolate-macro (cdr macro))
;; SHOULD DELETE THE UNINTERPRETED REQUEST!!!!!
;; Output this message once only per call (cf. strings)?
- (WoMan-warn "Undefined macro %s not interpolated!" request))))
+ (WoMan-warn "Undefined macro %s not interpolated!" woman-request))))
(defun woman-interpolate-macro (macro)
"Interpolate (.de) or append (.am) expansion of MACRO into the buffer."
@@ -2980,8 +2990,10 @@ Useful for constructing the alist variable `woman-special-characters'."
;;; Formatting macros that do not cause a break:
-(defvar request) ; Bound locally by woman1-roff-buffer
-(defvar unquote) ; Bound locally by woman1-roff-buffer
+;; Bound locally by woman[012]-roff-buffer, and also, annoyingly and
+;; confusingly, as a function argument. Use dynamically in
+;; woman-unquote and woman-forward-arg.
+(defvar woman-request)
(defun woman-unquote (to)
"Delete any double-quote characters between point and TO.
@@ -2996,7 +3008,7 @@ Leave point at TO (which should be a marker)."
(setq in-quote (not in-quote))
))
(if in-quote
- (WoMan-warn "Unpaired \" in .%s arguments." request))))
+ (WoMan-warn "Unpaired \" in .%s arguments." woman-request))))
(defsubst woman-unquote-args ()
"Delete any double-quote characters up to the end of the line."
@@ -3005,7 +3017,7 @@ Leave point at TO (which should be a marker)."
(defun woman1-roff-buffer ()
"Process non-breaking requests."
(let ((case-fold-search t)
- request fn unquote)
+ woman-request fn woman1-unquote)
(while
;; Find next control line:
(re-search-forward woman-request-regexp nil t)
@@ -3013,14 +3025,14 @@ Leave point at TO (which should be a marker)."
;; Construct woman function to call:
((setq fn (intern-soft
(concat "woman1-"
- (setq request (match-string 1)))))
+ (setq woman-request (match-string 1)))))
(if (get fn 'notfont) ; not a font-change request
(funcall fn)
;; Delete request or macro name:
(woman-delete-match 0)
;; If no args then apply to next line else unquote args
- ;; (unquote is used by called function):
- (setq unquote (not (eolp)))
+ ;; (woman1-unquote is used by called function):
+ (setq woman1-unquote (not (eolp)))
(if (eolp) (delete-char 1))
; ;; Hide leading control character in unquoted argument:
; (cond ((memq (following-char) '(?. ?'))
@@ -3029,7 +3041,7 @@ Leave point at TO (which should be a marker)."
;; Call the appropriate function:
(funcall fn)
;; Hide leading control character in quoted argument (only):
- (if (and unquote (memq (following-char) '(?. ?')))
+ (if (and woman1-unquote (memq (following-char) '(?. ?')))
(insert "\\&"))))))))
;;; Font-changing macros:
@@ -3042,6 +3054,8 @@ Leave point at TO (which should be a marker)."
".I -- Set words of current line in italic font."
(woman1-B-or-I ".ft I\n"))
+(defvar woman1-unquote) ; bound locally by woman1-roff-buffer
+
(defun woman1-B-or-I (B-or-I)
".B/I -- Set words of current line in bold/italic font.
B-OR-I is the appropriate complete control line."
@@ -3050,7 +3064,7 @@ B-OR-I is the appropriate complete control line."
;; Return to bol to process .SM/.B, .B/.if etc.
;; or start of first arg to hide leading control char.
(save-excursion
- (if unquote
+ (if woman1-unquote
(woman-unquote-args)
(while (looking-at "^[.']") (forward-line))
(end-of-line)
@@ -3097,11 +3111,12 @@ B-OR-I is the appropriate complete control line."
;; Return to start of first arg to hide leading control char:
(save-excursion
(setq fonts (cdr fonts))
- (woman-forward-arg unquote 'concat) ; unquote is bound above
+ ;; woman1-unquote is bound in woman1-roff-buffer.
+ (woman-forward-arg woman1-unquote 'concat)
(while (not (eolp))
(insert (car fonts))
(setq fonts (cdr fonts))
- (woman-forward-arg unquote 'concat)) ; unquote is bound above
+ (woman-forward-arg woman1-unquote 'concat))
(insert "\\fR")))
(defun woman-forward-arg (&optional unquote concat)
@@ -3117,8 +3132,8 @@ If optional arg CONCAT is non-nil then join arguments."
(if unquote (delete-char 1) (forward-char))
(re-search-forward "\"\\|$"))
(if (eq (preceding-char) ?\")
- (if unquote (delete-backward-char 1))
- (WoMan-warn "Unpaired \" in .%s arguments." request)))
+ (if unquote (delete-char -1))
+ (WoMan-warn "Unpaired \" in .%s arguments." woman-request)))
;; (re-search-forward "[^\\\n] \\|$") ; inconsistent
(skip-syntax-forward "^ "))
(cond ((null concat) (skip-chars-forward " \t")) ; don't skip eol!
@@ -3333,7 +3348,12 @@ Ignore the default face and underline only word characters."
;;; Output translation:
-(defvar translations nil) ; Also bound locally by woman2-roff-buffer
+;; This is only set by woman2-tr. It is bound locally in woman2-roff-buffer.
+;; It is also used by woman-translate. woman-translate may be called
+;; outside the scope of woman2-roff-buffer (by experiment). Therefore
+;; this used to be globally bound to nil, to avoid an error. Instead
+;; we can use bound-and-true-p in woman-translate.
+(defvar woman-translations)
;; A list of the form (\"[ace]\" (a . b) (c . d) (e . ?\ )) or nil.
(defun woman-get-next-char ()
@@ -3353,8 +3373,8 @@ Format paragraphs upto TO. Supports special chars.
;; This should be an update, but consing onto the front of the alist
;; has the same effect and match duplicates should not matter.
;; Initialize translation data structures:
- (let ((matches (car translations))
- (alist (cdr translations))
+ (let ((matches (car woman-translations))
+ (alist (cdr woman-translations))
a b)
;; `matches' must be a string:
(setq matches
@@ -3376,15 +3396,15 @@ Format paragraphs upto TO. Supports special chars.
(if (= (string-to-char matches) ?\])
(substring matches 3)
(concat "[" matches))
- translations (cons matches alist))
+ woman-translations (cons matches alist))
;; Format any following text:
(woman2-format-paragraphs to)))
(defsubst woman-translate (to)
"Translate up to marker TO. Do this last of all transformations."
- (if translations
- (let ((matches (car translations))
- (alist (cdr translations))
+ (if (bound-and-true-p woman-translations)
+ (let ((matches (car woman-translations))
+ (alist (cdr woman-translations))
;; Translations are case-sensitive, eg ".tr ab" does not
;; affect "A" (bug#6849).
(case-fold-search nil))
@@ -3523,8 +3543,8 @@ The expression may be an argument in quotes."
; (WoMan-warn "Unimplemented numerical operator `%c' in %s"
; (following-char)
; (buffer-substring
-; (save-excursion (beginning-of-line) (point))
-; (save-excursion (end-of-line) (point))))
+; (line-beginning-position)
+; (line-end-position)))
; (skip-syntax-forward "^ "))
value
))
@@ -3593,7 +3613,7 @@ expression in parentheses. Leaves point after the value."
(WoMan-warn "Numeric/register argument error: %s"
(buffer-substring
(point)
- (save-excursion (end-of-line) (point))))
+ (line-end-position)))
(skip-syntax-forward "^ ")
0)
(goto-char (match-end 0))
@@ -3628,7 +3648,7 @@ expression in parentheses. Leaves point after the value."
(insert-and-inherit (symbol-function 'insert-and-inherit))
(set-text-properties (symbol-function 'set-text-properties))
(woman-registers woman-registers)
- fn request translations
+ fn woman-request woman-translations
tab-stop-list)
(set-marker-insertion-type to t)
;; ?roff does not squeeze multiple spaces, but does fill, so...
@@ -3644,13 +3664,13 @@ expression in parentheses. Leaves point after the value."
;; Construct woman function to call:
((setq fn (intern-soft
(concat "woman2-"
- (setq request (match-string 1)))))
+ (setq woman-request (match-string 1)))))
;; Delete request or macro name:
(woman-delete-match 0))
;; Unrecognised request:
((prog1 nil
- ;; (WoMan-warn ".%s request ignored!" request)
- (WoMan-warn-ignored request "ignored!")
+ ;; (WoMan-warn ".%s request ignored!" woman-request)
+ (WoMan-warn-ignored woman-request "ignored!")
;; (setq fn 'woman2-LP)
;; AVOID LEAVING A BLANK LINE!
;; (setq fn 'woman2-format-paragraphs)
@@ -3743,8 +3763,7 @@ v alters page foot left; m alters page head center.
(buffer-substring start here))
(delete-region here (point)))))
;; Embolden heading (point is at end of heading):
- (woman-set-face
- (save-excursion (beginning-of-line) (point)) (point) 'woman-bold)
+ (woman-set-face (line-beginning-position) (point) 'woman-bold)
(forward-line)
(delete-blank-lines)
(setq woman-left-margin woman-default-indent)
@@ -3763,8 +3782,7 @@ Format paragraphs upto TO. Set prevailing indent to 5."
(setq woman-leave-blank-lines nil)
;; Optionally embolden heading (point is at beginning of heading):
(if woman-bold-headings
- (woman-set-face
- (point) (save-excursion (end-of-line) (point)) 'woman-bold))
+ (woman-set-face (point) (line-end-position) 'woman-bold))
(forward-line)
(setq woman-left-margin woman-default-indent
woman-nofill nil) ; fill output lines
@@ -4345,7 +4363,7 @@ The variable `tab-stop-list' is a list whose elements are either left
tab stop columns or pairs (COLUMN . TYPE) where TYPE is R or C."
;; Based on tab-to-tab-stop in indent.el.
;; R & C tabs probably not quite right!
- (delete-backward-char 1)
+ (delete-char -1)
(let ((tabs tab-stop-list))
(while (and tabs (>= (current-column)
(woman-get-tab-stop (car tabs))))
@@ -4356,7 +4374,7 @@ tab stop columns or pairs (COLUMN . TYPE) where TYPE is R or C."
eol n)
(if type
(setq tab (woman-get-tab-stop tab)
- eol (save-excursion (end-of-line) (point))
+ eol (line-end-position)
n (save-excursion
(search-forward "\t" eol t))
n (- (if n (1- n) eol) (point))
@@ -4399,7 +4417,7 @@ Needs doing properly!"
(delete-char 1)
(insert woman-unpadded-space-char)
(goto-char (match-end 0))
- (delete-backward-char 1)
+ (delete-char -1)
(insert-before-markers woman-unpadded-space-char)
(subst-char-in-region
(match-beginning 0) (match-end 0)
@@ -4481,12 +4499,13 @@ Format paragraphs upto TO."
(setq format (apply 'format format args))
(WoMan-log-1 (concat "** " format)))
+;; request is not used dynamically by any callees.
(defun WoMan-warn-ignored (request ignored)
"Log a warning message about ignored directive REQUEST.
IGNORED is a string appended to the log message."
(let ((tail
(buffer-substring (point)
- (save-excursion (end-of-line) (point)))))
+ (line-end-position))))
(if (and (> (length tail) 0)
(/= (string-to-char tail) ?\ ))
(setq tail (concat " " tail)))
@@ -4519,7 +4538,37 @@ logging the message."
(recenter 0))))))))
nil) ; for woman-file-readable-p etc.
+;;; Bookmark Woman support.
+(declare-function bookmark-make-record-default
+ "bookmark" (&optional no-file no-context posn))
+(declare-function bookmark-prop-get "bookmark" (bookmark prop))
+(declare-function bookmark-default-handler "bookmark" (bmk))
+(declare-function bookmark-get-bookmark-record "bookmark" (bmk))
+
+;; FIXME: woman.el and man.el should be better integrated so, for
+;; example, bookmarks of one can be used with the other.
+
+(defun woman-bookmark-make-record ()
+ "Make a bookmark entry for a Woman buffer."
+ `(,(Man-default-bookmark-title)
+ ,@(bookmark-make-record-default 'no-file)
+ (location . ,(concat "woman " woman-last-file-name))
+ ;; Use the same form as man's bookmarks, as much as possible.
+ (man-args . ,woman-last-file-name)
+ (handler . woman-bookmark-jump)))
+
+;;;###autoload
+(defun woman-bookmark-jump (bookmark)
+ "Default bookmark handler for Woman buffers."
+ (let* ((file (bookmark-prop-get bookmark 'man-args))
+ ;; FIXME: we need woman-find-file-noselect, since
+ ;; save-window-excursion can't protect us from the case where
+ ;; woman-find-file creates a new frame.
+ (buf (save-window-excursion
+ (woman-find-file file) (current-buffer))))
+ (bookmark-default-handler
+ `("" (buffer . ,buf) . ,(bookmark-get-bookmark-record bookmark)))))
+
(provide 'woman)
-;; arch-tag: eea35e90-552f-4712-a94b-d9ffd3db7651
;;; woman.el ends here
diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el
index 6d38fd043fe..f071bc49b74 100644
--- a/lisp/x-dnd.el
+++ b/lisp/x-dnd.el
@@ -6,6 +6,7 @@
;; Author: Jan Djärv <jan.h.d@swipnet.se>
;; Maintainer: FSF
;; Keywords: window, drag, drop
+;; Package: emacs
;; This file is part of GNU Emacs.
@@ -219,7 +220,7 @@ The first string is the URL, the second string is the title of that URL.
DATA is encoded in utf-16. Decode the URL and call `x-dnd-handle-uri-list'."
;; Mozilla and applications based on it (Galeon for example) uses
;; text/unicode, but it is impossible to tell if it is le or be. Use what
- ;; the machine Emacs runs on use. This looses if dropping between machines
+ ;; the machine Emacs runs on use. This loses if dropping between machines
;; with different endian, but it is the best we can do.
(let* ((coding (if (eq (byteorder) ?B) 'utf-16be 'utf-16le))
(string (decode-coding-string data coding))
@@ -765,5 +766,4 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent."
(provide 'x-dnd)
-;; arch-tag: b621fb7e-50da-4323-850b-5fc71ae64621
;;; x-dnd.el ends here